phylobase/0000755000176200001440000000000014556040263012245 5ustar liggesusersphylobase/NAMESPACE0000644000176200001440000000370714553736442013503 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(drawDetails,bubLegend) export("[") export("edgeLabels<-") export("edgeLength<-") export("labels<-") export("nodeData<-") export("nodeLabels<-") export("rootNode<-") export("tdata<-") export("tipData<-") export("tipLabels<-") export(MRCA) export(addData) export(ancestor) export(ancestors) export(checkPhylo4) export(children) export(depthTips) export(descendants) export(edgeId) export(edgeLabels) export(edgeLength) export(edgeOrder) export(edges) export(extractTree) export(getEdge) export(getNode) export(hasDuplicatedLabels) export(hasEdgeLabels) export(hasEdgeLength) export(hasNodeData) export(hasNodeLabels) export(hasPoly) export(hasRetic) export(hasSingle) export(hasTipData) export(internalEdges) export(isRooted) export(isUltrametric) export(nData) export(nEdges) export(nNodes) export(nTips) export(names) export(nodeData) export(nodeDepth) export(nodeHeight) export(nodeId) export(nodeLabels) export(nodeType) export(phylo4) export(phylo4d) export(phyloXXYY) export(phylobase.options) export(phylobubbles) export(plotOneTree) export(prune) export(readNCL) export(readNewick) export(readNexus) export(rootNode) export(shortestPath) export(siblings) export(sumEdgeLength) export(tdata) export(terminalEdges) export(tip.data.plot) export(tipData) export(tipLabels) export(treePlot) exportClasses(phylo4) exportClasses(phylo4d) exportClasses(phylo4vcov) exportMethods("[") exportMethods(head) exportMethods(labels) exportMethods(names) exportMethods(plot) exportMethods(print) exportMethods(reorder) exportMethods(show) exportMethods(subset) exportMethods(summary) exportMethods(tail) import(RNeXML) import(ape) import(grid) import(stats) importFrom(Rcpp,evalCpp) importFrom(ade4,newick2phylog) importFrom(graphics,plot) importFrom(methods,as) importFrom(methods,is) importFrom(methods,new) importFrom(methods,show) importFrom(rncl,rncl) importFrom(utils,head) importFrom(utils,tail) useDynLib(phylobase, .registration = TRUE) phylobase/README.md0000644000176200001440000002051714555723715013542 0ustar liggesusers # phylobase [![R-CMD-check](https://github.com/fmichonneau/phylobase/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/fmichonneau/phylobase/actions/workflows/R-CMD-check.yaml) \[\[codecov.io\]\[()\]() ![](https://cranlogs.r-pkg.org/badges/phylobase) [![CRAN version](https://www.r-pkg.org/badges/version/phylobase)](https://cran.r-project.org/package=phylobase) ## About this package `phylobase` provides classes and methods to easily associate, manipulate, explore, and plot phylogenetic trees and data about the species they include. The goal of this package is to provide a base set of tools likely to be shared by all packages designed for phylogenetic analysis. This standardization will benefit both *end-users* by allowing them to move results across packages and keep data associated with the phylogenetic trees; and *developers* by focusing on method development instead of having to rewrite the base functions. - Authors: R Hackathon et al. (alphabetically: Ben Bolker, Marguerite Butler, Peter Cowan, Damien de Vienne, Dirk Eddelbuettel, Mark Holder, Thibaut Jombart, Steve Kembel, Francois Michonneau, David Orme, Brian O’Meara, Emmanuel Paradis, Jim Regetz, Derrick Zwickl) - Maintainer: Francois Michonneau - Licence: GPL (\>= 2) - Issues, bug reports, feature requests, discussion: ## Installation ### Stable version The stable version (the minor and patch version numbers are even, e.g., 0.6.8) can be downloaded from CRAN. ``` r install.packages("phylobase") ``` ### Development version The development version (the patch version number is odd, e.g., 0.6.9) is available on GitHub (), and can be installed using the [`devtools`](https://cran.r-project.org/package=devtools) package. ``` r pak::install_github("fmichonneau/phylobase") library(phylobase) ``` ### Getting started `phylobase` comes with example data sets `geospiza` and `geospiza_raw`. - `geospiza` is a `phylo4d` object (the `phylobase` class that holds together a phylogenetic tree and associated data, the `phylo4` class is for phylogenetic trees only). - `geospiza_raw` is a list that contains the tree `geospiza_raw$tree` (as an `ape::phylo` object) and the data `geospiza_raw$data` (as a `data.frame`) that were used to build the `geospiza` object. Now we’ll take the data from and merge it with the tree. However, since is included in the tree but not in the data set, we will initially run into some trouble: ``` r data(geospiza_raw) g1 <- as(geospiza_raw$tree, "phylo4") geodata <- geospiza_raw$data g2 <- phylo4d(g1, geodata) #> Error in formatData(phy = x, dt = tip.data, type = "tip", ...): The following nodes are not found in the dataset: olivacea ``` To deal with *G. olivacea* missing from the data, we have a few choices. The easiest is to use `missing.data="warn"` to allow `R` to create the new object with a warning (you can also use `missing.data="OK"` to proceed without warnings): ``` r g2 <- phylo4d(g1, geodata, missing.data="warn") #> Warning in formatData(phy = x, dt = tip.data, type = "tip", ...): The following #> nodes are not found in the dataset: olivacea head(g2) #> label node ancestor edge.length node.type wingL tarsusL culmenL #> 1 fuliginosa 1 24 0.05500 tip 4.132957 2.806514 2.094971 #> 2 fortis 2 24 0.05500 tip 4.244008 2.894717 2.407025 #> 3 magnirostris 3 23 0.11000 tip 4.404200 3.038950 2.724667 #> 4 conirostris 4 22 0.18333 tip 4.349867 2.984200 2.654400 #> 5 scandens 5 21 0.19250 tip 4.261222 2.929033 2.621789 #> 6 difficilis 6 20 0.22800 tip 4.224067 2.898917 2.277183 #> 7 pallida 7 25 0.08667 tip 4.265425 3.089450 2.430250 #> 8 parvulus 8 27 0.02000 tip 4.131600 2.973060 1.974420 #> 9 psittacula 9 27 0.02000 tip 4.235020 3.049120 2.259640 #> 10 pauper 10 26 0.03500 tip 4.232500 3.035900 2.187000 #> 11 Platyspiza 11 18 0.46550 tip 4.419686 3.270543 2.331471 #> 12 fusca 12 17 0.53409 tip 3.975393 2.936536 2.051843 #> 13 Pinaroloxias 13 16 0.58333 tip 4.188600 2.980200 2.311100 #> 14 olivacea 14 15 0.88077 tip NA NA NA #> 15 15 0 NA root NA NA NA #> 16 16 15 0.29744 internal NA NA NA #> 17 17 16 0.04924 internal NA NA NA #> 18 18 17 0.06859 internal NA NA NA #> 19 19 18 0.13404 internal NA NA NA #> 20 20 19 0.10346 internal NA NA NA #> beakD gonysW #> 1 1.941157 1.845379 #> 2 2.362658 2.221867 #> 3 2.823767 2.675983 #> 4 2.513800 2.360167 #> 5 2.144700 2.036944 #> 6 2.011100 1.929983 #> 7 2.016350 1.949125 #> 8 1.873540 1.813340 #> 9 2.230040 2.073940 #> 10 2.073400 1.962100 #> 11 2.347471 2.282443 #> 12 1.191264 1.401186 #> 13 1.547500 1.630100 #> 14 NA NA #> 15 NA NA #> 16 NA NA #> 17 NA NA #> 18 NA NA #> 19 NA NA #> 20 NA NA ``` ### Importing data #### From NEXUS files `phylobase` has a robust parser for NEXUS files (it uses the NEXUS Class Library from Paul Lewis and Mark Holder, [NCL](https://sourceforge.net/projects/ncl/files/)). It can be used to import simultaneously tree and species data. ``` r myrmeFile <- system.file("nexusfiles/treeWithDiscreteData.nex", package="phylobase") myrme <- readNexus(file=myrmeFile) head(myrme) #> label node ancestor edge.length node.type time #> 1 Myrmecocystussemirufus 1 27 1.724765 tip diurnal #> 2 Myrmecocystusplacodops 2 27 1.724765 tip diurnal #> 3 Myrmecocystusmendax 3 26 4.650818 tip diurnal #> 4 Myrmecocystuskathjuli 4 28 1.083870 tip diurnal #> 5 Myrmecocystuswheeleri 5 28 1.083870 tip diurnal #> 6 Myrmecocystusmimicus 6 30 2.708942 tip diurnal #> 7 Myrmecocystusdepilis 7 30 2.708942 tip diurnal #> 8 Myrmecocystusromainei 8 32 2.193845 tip diurnal #> 9 Myrmecocystusnequazcatl 9 32 2.193845 tip diurnal #> 10 Myrmecocystusyuma 10 31 4.451425 tip crepuscular #> 11 Myrmecocystuskennedyi 11 23 6.044804 tip diurnal #> 12 Myrmecocystuscreightoni 12 22 10.569191 tip crepuscular #> 13 Myrmecocystussnellingi 13 33 2.770378 tip crepuscular #> 14 Myrmecocystustenuinodis 14 33 2.770378 tip crepuscular #> 15 Myrmecocystustestaceus 15 20 12.300701 tip crepuscular #> 16 Myrmecocystusmexicanus 16 34 5.724923 tip nocturnal #> 17 Myrmecocystuscfnavajo 17 35 2.869547 tip nocturnal #> 18 Myrmecocystusnavajo 18 35 2.869547 tip nocturnal #> 19 19 0 NA root #> 20 20 19 1.699299 internal #> subgenus #> 1 Endiodioctes #> 2 Endiodioctes #> 3 Endiodioctes #> 4 Endiodioctes #> 5 Endiodioctes #> 6 Endiodioctes #> 7 Endiodioctes #> 8 Endiodioctes #> 9 Endiodioctes #> 10 Eremnocystus #> 11 Endiodioctes #> 12 Eremnocystus #> 13 Eremnocystus #> 14 Eremnocystus #> 15 Myrmecocystus #> 16 Myrmecocystus #> 17 Myrmecocystus #> 18 Myrmecocystus #> 19 #> 20 ``` #### From NeXML ``` r library(RNeXML) #> Loading required package: ape #> #> Attaching package: 'ape' #> The following object is masked from 'package:phylobase': #> #> edges nxmlFile <- system.file("nexmlfiles/comp_analysis.xml", package="phylobase") nxml <- nexml_read(nxmlFile) nxmlEx <- phylo4(nxml) ``` phylobase/data/0000755000176200001440000000000014553646170013164 5ustar liggesusersphylobase/data/geospiza_raw.rda0000644000176200001440000000227414553646170016353 0ustar liggesusersUkLW}Q1- Hz"v؝]Fgg]^Zbֈ5ZSF|hLEThhڊAVJMcUw?ߞ=;+,/RESNEjjh(cS(*f)fm)L5 4#Èa˜!acD`DbDD]8m1f/_c&r9RZ &CQ?HC'dR6Ihr]c] X3qӌ<ƁAH3o[:ғn^OЦF'.+WJѸm;ފ=Kh{y9'0ՀZ:ח4>,؎{U*moοyv3U5)]?\ߟo DfYAyN|_Ԫ"HosN%htv$"Mq2sY*de+(r9+-.9be^8zy.brT.h^TIs9'0n+8Ɵsee&Zq郆(5>HxVpxJ; M9p$)fɞ<#)JWI%/NiIX@FT?LN=%LAڏ<ҟ` -z20o O?{a@X[‰{}`lStޜk6>)~ y4E 7`, 6d>'}[ NTl.a"g܅_=3=R9xT[umAxsi4;-wiTyo58GC@]3T=|=@Ok;k?{e/,jubѴ׀^KR!_HC/}tfWj>43VU*2wP_i 3htD0T=ϥ$j<]J(G #qr4ho.Z%Egz2]@6Xl@ubal\-y$' jLzɁRw-drIvKUHX7/<4D=Hd ԣi /G, Î o'{f_BRH.ڽ"*UIQqex} 'x} [x} YјARhC^/EIԑ ꍩE-7 ICQCxG] vJsW{/yC_G܇n\tuN/*99$H<{9kxs0C0?d0_WS'ԤҒZRRKIj IyRkr(, k‚,1`d(#\sCaj( 0/¬P#!Po(S䶏F}󊕢T#q(yqgViQFWE e&#A*9z| .dٿB + phylobase/data/owls4.rda0000644000176200001440000000053114553646170014723 0ustar liggesusersmRKN0u~EXEЦV.rQ[յQa]8܇0Ǵ 4y2Oqc-ֺ9Dn` 0: t‚ h[2;ۇ 0pw_#&\q@U>Ag s.c/;re֨qev|e{N,wQhtpcGɑ;9c#]ќgSl^R.L`7*Ut05HHLɝj z{ ksUCA+Vlp\JeךR]ٯ_Jޞg[n۱vP\5Mȿ"phylobase/man/0000755000176200001440000000000014555723756013036 5ustar liggesusersphylobase/man/phyloXXYY.Rd0000644000176200001440000000302514553646170015212 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/treePlot.R \name{phyloXXYY} \alias{phyloXXYY} \title{Calculate node x and y coordinates} \usage{ phyloXXYY(phy, tip.order = NULL) } \arguments{ \item{phy}{A \code{phylo4} or \code{phylo4d} object.} \item{tip.order}{A character vector of tip labels, indicating their order along the y axis (from top to bottom). Or, a numeric vector of tip node IDs indicating the order.} } \value{ \item{yy}{Internal node and tip y coordinates} \item{xx}{Internal node and tip x coordinates} \item{phy}{A \code{phylo4} or \code{phylo4d} object} \item{segs}{A list of \code{h0x, h1x, v0x, v1x} and \code{h0y, h1y, v0y, v1y} describing the start and end points for the plot line segments} \item{torder}{The tip order provided as \code{tip.order} or if NULL the preoder tip order} \item{eorder}{The an index of the reordered edges compared to the result of \code{edges(phy)}} } \description{ Calculates the node x and y locations for plotting a phylogenetic tree. } \details{ The y coordinates of the tips are evenly spaced from 0 to 1 in pruningwise order. Ancestor y nodes are given the mean value of immediate descendants. The root is given the x coordinate 0 and descendant nodes are placed according to the cumulative branch length from the root, with a maximum x value of 1. } \examples{ data(geospiza) coor <- phyloXXYY(geospiza) plot(coor$xx, coor$yy, pch = 20) } \seealso{ \code{treePlot}, \code{\link{plotOneTree}} } \author{ Peter Cowan \email{pdc@berkeley.edu} } \keyword{methods} phylobase/man/treePlot-methods.Rd0000644000176200001440000000724314553646170016562 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/treePlot.R \docType{methods} \name{treePlot-methods} \alias{treePlot-methods} \alias{treePlot} \alias{plot,ANY,ANY-method} \alias{plot,pdata,missing-method} \alias{plot,phylo4,missing-method} \alias{treePlot-method} \alias{treePlot,phylo4,phylo4d-method} \alias{plot} \alias{plot,phylo4-method} \title{Phylogeny plotting} \usage{ treePlot( phy, type = c("phylogram", "cladogram", "fan"), show.tip.label = TRUE, show.node.label = FALSE, tip.order = NULL, plot.data = is(phy, "phylo4d"), rot = 0, tip.plot.fun = "bubbles", plot.at.tip = TRUE, edge.color = "black", node.color = "black", tip.color = "black", edge.width = 1, newpage = TRUE, margins = c(1.1, 1.1, 1.1, 1.1), ... ) plot(x, y, ...) \S4method{plot}{phylo4,missing}(x, y, ...) } \arguments{ \item{phy}{A \code{phylo4} or \code{phylo4d} object} \item{type}{A character string indicating the shape of plotted tree} \item{show.tip.label}{Logical, indicating whether tip labels should be shown} \item{show.node.label}{Logical, indicating whether node labels should be shown} \item{tip.order}{If NULL the tree is plotted with tips in preorder, if "rev" this is reversed. Otherwise, it is a character vector of tip labels, indicating their order along the y axis (from top to bottom). Or, a numeric vector of tip node IDs indicating the order.} \item{plot.data}{Logical indicating whether \code{phylo4d} data should be plotted} \item{rot}{Numeric indicating the rotation of the plot in degrees} \item{tip.plot.fun}{A function used to generate plot at the each tip of the phylogenetic trees} \item{plot.at.tip}{should the data plots be at the tip? (logical)} \item{edge.color}{A vector of colors in the order of \code{edges(phy)}} \item{node.color}{A vector of colors indicating the colors of the node labels} \item{tip.color}{A vector of colors indicating the colors of the tip labels} \item{edge.width}{A vector in the order of \code{edges(phy)} indicating the widths of edge lines} \item{newpage}{Logical indicating whether the page should be cleared before plotting} \item{margins}{number of lines around the plot (similar to \code{par(mar)}).} \item{\dots}{additional arguments} \item{x}{A \code{phylo4} or \code{phylo4d} object} \item{y}{(only here for compatibility)} } \value{ No return value, function invoked for plotting side effect } \description{ Plot \code{phylo4} or \code{phylo4d} objects, including associated data. } \details{ Currently, \code{treePlot} can only plot numeric values for tree-associated data. The dataset will be subset to only include columns of class \code{numeric}, \code{integer} or \code{double}. If a \code{phylo4d} object is passed to the function and it contains no data, or if the data is in a format that cannot be plotted, the function will produce a warning. You can avoid this by using the argument \code{plot.data=FALSE}. } \section{Methods}{ \describe{ \item{phy = "phylo4"}{plots a tree of class \linkS4class{phylo4}} \item{phy = "phylo4d"}{plots a tree with one or more quantitative traits contained in a \linkS4class{phylo4d} object.} } } \examples{ ## example of plotting two grid plots on the same page library(grid) data(geospiza) geotree <- extractTree(geospiza) grid.newpage() pushViewport(viewport(layout=grid.layout(nrow=1, ncol=2), name="base")) pushViewport(viewport(layout.pos.col=1, name="plot1")) treePlot(geotree, newpage=FALSE) popViewport() pushViewport(viewport(layout.pos.col=2, name="plot2")) treePlot(geotree, newpage=FALSE, rot=180) popViewport(2) } \seealso{ \code{\link{phylobubbles}} } \author{ Peter Cowan \email{pdc@berkeley.edu}, Francois Michonneau } \keyword{methods} phylobase/man/treeStructure-methods.Rd0000644000176200001440000000317114553646170017640 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/treestruc.R \name{hasSingle} \alias{hasSingle} \alias{hasSingle,phylo4-method} \alias{hasRetic} \alias{hasRetic,phylo4-method} \alias{hasPoly} \alias{hasPoly,phylo4-method} \title{Test trees for polytomies, inline nodes (singletons), or reticulation} \usage{ hasSingle(object) \S4method{hasSingle}{phylo4}(object) hasRetic(object) \S4method{hasRetic}{phylo4}(object) hasPoly(object) \S4method{hasPoly}{phylo4}(object) } \arguments{ \item{object}{an object inheriting from class \code{phylo4}} } \value{ Logical value } \description{ Methods to test whether trees have (structural) polytomies, inline nodes (i.e., nodes with a single descendant), or reticulation (i.e., nodes with more than one ancestor). \code{hasPoly} only check for structural polytomies (1 node has more than 2 descendants) and not polytomies that result from having edges with a length of 0. } \note{ Some algorithms are unhappy with structural polytomies (i.e., >2 descendants from a node), with single-descendant nodes, or with reticulation; these functions check those properties. We haven't bothered to check for zero branch lengths: the consensus is that it doesn't come up much, and that it's simple enough to test \code{any(edgeLength(x) == 0)} in these cases. (Single-descendant nodes are used e.g. in OUCH, or in other cases to represent events occurring along a branch.) } \examples{ tree.owls.bis <- ape::read.tree(text="((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3);") owls4 <- as(tree.owls.bis, "phylo4") hasPoly(owls4) hasSingle(owls4) } \author{ Ben Bolker } \keyword{misc} phylobase/man/phylo4d-class.Rd0000644000176200001440000000162414553646170016006 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phylo4d-class.R \docType{class} \name{phylo4d-class} \alias{phylo4d-class} \title{phylo4d class} \description{ S4 class for phylogenetic tree and data. } \section{Objects from the Class}{ Objects can be created from various trees and a data.frame using the constructor \code{phylo4d}, or using \code{new("phylo4d", \dots{})} for empty objects. } \examples{ example(read.tree, "ape") obj <- phylo4d(as(tree.owls.bis,"phylo4"), data.frame(wing=1:3)) obj names(obj) summary(obj) } \seealso{ \code{\link{coerce-methods}} for translation functions. The \code{\link{phylo4d-methods}} constructor. See also the \code{\link{phylo4-methods}} constructor, the \linkS4class{phylo4} class, and the \code{\link{checkPhylo4}} function to check the validity of \code{phylo4} trees. } \author{ Ben Bolker, Thibaut Jombart } \keyword{classes} phylobase/man/phylo4-methods.Rd0000644000176200001440000001016414553653724016202 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phylo4-methods.R \docType{methods} \name{phylo4-methods} \alias{phylo4-methods} \alias{phylo4} \alias{phylo4_orderings} \alias{phylo4,matrix-method} \alias{phylo4,phylo-method} \alias{phylo4,nexml-method} \alias{nexml,phylo4-method} \title{Create a phylogenetic tree} \format{ An object of class \code{character} of length 5. } \usage{ phylo4(x, ...) phylo4_orderings \S4method{phylo4}{matrix}( x, edge.length = NULL, tip.label = NULL, node.label = NULL, edge.label = NULL, order = "unknown", annote = list() ) \S4method{phylo4}{phylo}(x, check.node.labels = c("keep", "drop"), annote = list()) \S4method{phylo4}{nexml}(x) } \arguments{ \item{x}{a matrix of edges or an object of class \code{phylo} (see above)} \item{\dots}{optional arguments (none used at present).} \item{edge.length}{Edge (branch) length. (Optional)} \item{tip.label}{A character vector of species names (names of "tip" nodes). (Optional)} \item{node.label}{A character vector of internal node names. (Optional)} \item{edge.label}{A character vector of edge (branch) names. (Optional)} \item{order}{character: tree ordering (allowable values are listed in \code{phylo4_orderings}, currently "unknown", "preorder" (="cladewise" in \code{ape}), and "postorder", with "cladewise" and "pruningwise" also allowed for compatibility with \code{ape})} \item{annote}{any additional annotation data to be passed to the new object} \item{check.node.labels}{if \code{x} is of class \code{phylo}, either "keep" (the default) or "drop" node labels. This argument is useful if the \code{phylo} object has non-unique node labels.} \item{edge}{A numeric, two-column matrix with as many rows as branches in the phylogeny.} } \description{ \code{phylo4} is a generic constructor that creates a phylogenetic tree object for use in phylobase methods. Phylobase contains functions for input of phylogenetic trees and data, manipulation of these objects including pruning and subsetting, and plotting. The phylobase package also contains translation functions to forms used in other comparative phylogenetic method packages. } \details{ The minimum information necessary to create a phylobase tree object is a valid edge matrix. The edge matrix describes the topology of the phylogeny. Each row describes a branch of the phylogeny, with the (descendant) node number in column 2 and its ancestor's node number in column 1. These numbers are used internally and must be unique for each node. The labels designate either nodes or edges. The vector \code{node.label} names internal nodes, and together with \code{tip.label}, name all nodes in the tree. The vector \code{edge.label} names all branches in the tree. All label vectors are optional, and if they are not given, internally-generated labels will be assigned. The labels, whether user-specified or internally generated, must be unique as they are used to join species data with phylogenetic trees. \code{phylobase} also allows to create \code{phylo4} objects using the function \code{phylo4()} from objects of the classes: \code{phylo} (from \code{ape}), and \code{nexml} (from \code{RNeXML}). } \note{ Translation functions are available from many valid tree formats. See \link{coerce-methods}. } \examples{ # a three species tree: mytree <- phylo4(x=matrix(data=c(4,1, 4,5, 5,2, 5,3, 0,4), ncol=2, byrow=TRUE), tip.label=c("speciesA", "speciesB", "speciesC")) mytree plot(mytree) # another way to specify the same tree: mytree <- phylo4(x=cbind(c(4, 4, 5, 5, 0), c(1, 5, 2, 3, 4)), tip.label=c("speciesA", "speciesB", "speciesC")) # another way: mytree <- phylo4(x=rbind(c(4, 1), c(4, 5), c(5, 2), c(5, 3), c(0, 4)), tip.label=c("speciesA", "speciesB", "speciesC")) # with branch lengths: mytree <- phylo4(x=rbind(c(4, 1), c(4, 5), c(5, 2), c(5, 3), c(0, 4)), tip.label=c("speciesA", "speciesB", "speciesC"), edge.length=c(1, .2, .8, .8, NA)) plot(mytree) } \seealso{ \code{\link{coerce-methods}} for translation functions. The \linkS4class{phylo4} class. See also the \code{\link{phylo4d-methods}} constructor, and \linkS4class{phylo4d} class. } \author{ phylobase team } \keyword{datasets} phylobase/man/subset-methods.Rd0000644000176200001440000001542714555723756016304 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/subset-methods.R \docType{methods} \name{subset-methods} \alias{subset-methods} \alias{subset} \alias{subset,phylo4-method} \alias{[} \alias{[,phylo4,character,missing,missing-method} \alias{[,phylo4,numeric,missing,missing-method} \alias{[,phylo4,logical,missing,missing-method} \alias{[,phylo4,missing,missing,missing-method} \alias{[,phylo4d,ANY,character,missing-method} \alias{[,phylo4d,ANY,numeric,missing-method} \alias{[,phylo4d,ANY,logical,missing-method} \alias{[,phylo4,ANY,ANY,ANY-method} \alias{prune} \alias{prune,phylo4-method} \alias{prune,phylo4d-method} \title{Methods for creating subsets of phylogenies} \usage{ subset(x, ...) \S4method{subset}{phylo4}( x, tips.include = NULL, tips.exclude = NULL, mrca = NULL, node.subtree = NULL, ... ) x[i, ...] \S4method{[}{phylo4,character,missing,missing}(x, i, j, ..., drop = TRUE) \S4method{[}{phylo4,numeric,missing,missing}(x, i, j, ..., drop = TRUE) \S4method{[}{phylo4,logical,missing,missing}(x, i, j, ..., drop = TRUE) \S4method{[}{phylo4,missing,missing,missing}(x, i, j, ..., drop = TRUE) \S4method{[}{phylo4d,ANY,character,missing}(x, i, j, ..., drop = TRUE) \S4method{[}{phylo4d,ANY,numeric,missing}(x, i, j, ..., drop = TRUE) \S4method{[}{phylo4d,ANY,logical,missing}(x, i, j, ..., drop = TRUE) \S4method{[}{phylo4,ANY,ANY,ANY}(x, i, j, ..., drop = TRUE) prune(x, ...) \S4method{prune}{phylo4}(x, tips.exclude, trim.internal = TRUE) \S4method{prune}{phylo4d}(x, tips.exclude, trim.internal = TRUE) } \arguments{ \item{x}{an object of class \code{"phylo4"} or \code{"phylo4d"}} \item{\dots}{optional additional parameters (not in use)} \item{tips.include}{A vector of tips to include in the subset tree} \item{tips.exclude}{A vector of tips to exclude from the subset tree} \item{mrca}{A vector of nodes for determining the most recent common ancestor, which is then used as the root of the subset tree} \item{node.subtree}{A single internal node specifying the root of the subset tree} \item{i}{(\code{[} method) An index vector indicating tips to include} \item{j}{(\code{[} method, phylo4d only) An index vector indicating columns of node/tip data to include} \item{drop}{(not in use: for compatibility with the generic method)} \item{trim.internal}{A logical specifying whether to remove internal nodes that no longer have tip descendants in the subset tree} } \value{ an object of class \code{"phylo4"} or \code{"phylo4d"} } \description{ Methods for creating subsets of phylogenies, based on pruning a tree to include or exclude a set of terminal taxa, to include all descendants of the MRCA of multiple taxa, or to return a subtree rooted at a given node. } \details{ The \code{subset} methods must be called using no more than one of the four main subsetting criteria arguments (\code{tips.include}, \code{tips.exclude}, \code{mrca}, or \code{node.subtree}). Each of these arguments can be either character or numeric. In the first case, they are treated as node labels; in the second case, they are treated as node numbers. For the first two arguments, any supplied tips not found in the tree (\code{tipLabels(x)}) will be ignored, with a warning. Similarly, for the \code{mrca} argument, any supplied tips or internal nodes not found in the tree will be ignored, with a warning. For the \code{node.subtree} argument, failure to provide a single, valid internal node will result in an error. Although \code{prune} is mainly intended as the workhorse function called by \code{subset}, it may also be called directly. In general it should be equivalent to the \code{tips.exclude} form of \code{subset} (although perhaps with less up-front error checking). The "[" operator, when used as \code{x[i]}, is similar to the \code{tips.include} form of \code{subset}. However, the indices used with this operator can also be logical, in which case the corresponding tips are assumed to be ordered as in \code{nodeId(x, "tip")}, and recycling rules will apply (just like with a vector or a matrix). With a \linkS4class{phylo4d} object 'x', \code{x[i,j]} creates a subset of \code{x} taking \code{i} for a tip index and \code{j} for the index of data variables in \code{tdata(geospiza, "all")}. Note that the second index is optional: \code{x[i, TRUE]}, \code{x[i,]}, and \code{x[i]} are all equivalent. Regardless of which approach to subsetting is used, the argument values must be such that at least two tips are retained. If the most recent common ancestor of the retained tips is not the original root node, then the root node of the subset tree will be a descendant of the original root. For rooted trees with non-NA root edge length, this has implications for the new root edge length. In particular, the new length will be the summed edge length from the new root node back to the original root (including the original root edge). As an alternative, see the examples for a way to determine the length of the edge that was immediately ancestral to the new root node in the original tree. Note that the correspondance between nodes and labels (and data in the case of \linkS4class{phylo4d}) will be retained after all forms of subsetting. Beware, however, that the node numbers (IDs) will likely be altered to reflect the new tree topology, and therefore cannot be compared directly between the original tree and the subset tree. } \section{Methods}{ \describe{ \item{x = "phylo4"}{subset tree} \item{x = "phylo4d"}{subset tree and corresponding node and tip data} } } \examples{ data(geospiza) nodeLabels(geospiza) <- paste("N", nodeId(geospiza, "internal"), sep="") geotree <- extractTree(geospiza) ## "subset" examples tips <- c("difficilis", "fortis", "fuliginosa", "fusca", "olivacea", "pallida", "parvulus", "scandens") plot(subset(geotree, tips.include=tips)) plot(subset(geotree, tips.include=tips, trim.internal=FALSE)) plot(subset(geotree, tips.exclude="scandens")) plot(subset(geotree, mrca=c("scandens","fortis","pauper"))) plot(subset(geotree, node.subtree=18)) ## "prune" examples (equivalent to subset using tips.exclude) plot(prune(geotree, tips)) ## "[" examples (equivalent to subset using tips.include) plot(geotree[c(1:6,14)]) plot(geospiza[c(1:6,14)]) ## for phylo4d, subset both tips and data columns geospiza[c(1:6,14), c("wingL", "beakD")] ## note handling of root edge length: edgeLength(geotree)['0-15'] <- 0.1 geotree2 <- geotree[1:2] ## in subset tree, edge of new root extends back to the original root edgeLength(geotree2)['0-3'] ## edge length immediately ancestral to this node in the original tree edgeLength(geotree, MRCA(geotree, tipLabels(geotree2))) } \author{ Jim Regetz \email{regetz@nceas.ucsb.edu}\cr Steven Kembel \email{skembel@berkeley.edu}\cr Damien de Vienne \email{damien.de-vienne@u-psud.fr}\cr Thibaut Jombart \email{jombart@biomserv.univ-lyon1.fr} } \keyword{methods} phylobase/man/reorder-methods.Rd0000644000176200001440000000346014553646170016423 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reorder-methods.R \docType{methods} \name{reorder-methods} \alias{reorder-methods} \alias{reorder} \alias{reorder,phylo4-method} \title{reordering trees within phylobase objects} \usage{ reorder(x, ...) \S4method{reorder}{phylo4}(x, order = c("preorder", "postorder")) } \arguments{ \item{x}{a \code{phylo4} or \code{phylo4d} object} \item{\dots}{additional optional elements (not in use)} \item{order}{The desired traversal order; currently only \dQuote{preorder} and \dQuote{postorder} are allowed for \code{phylo4} and \code{phylo4d} objects.} } \value{ A \code{phylo4} or \code{phylo4d} object with the edge, label, length and data slots ordered as \code{order}, which is itself recorded in the order slot. } \description{ Methods for reordering trees into various traversal orders } \details{ The \code{reorder} method takes a \code{phylo4} or \code{phylo4d} tree and orders the edge matrix (i.e. \code{edges(x)}) in the requested traversal order. Currently only two orderings are permitted, and both require rooted trees. In \code{postorder}, a node's descendants come before that node, thus the root, which is ancestral to all nodes, comes last. In \code{preorder}, a node is visited before its descendants, thus the root comes first. } \note{ The \code{preorder} parameter corresponds to \code{cladewise} in the \code{ape} package, and \code{postorder} corresponds (almost) to \code{pruningwise}. } \examples{ phy <- phylo4(ape::rtree(5)) edges(reorder(phy, "preorder")) edges(reorder(phy, "postorder")) } \seealso{ \code{\link[ape]{reorder.phylo}} in the \code{ape} package. \code{\link{ancestors}} \code{\link{ancestor}} \code{\link{siblings}} \code{\link{children}} \code{\link{descendants}} } \author{ Peter Cowan, Jim Regetz } \keyword{methods} phylobase/man/addData-methods.Rd0000644000176200001440000000476114553646170016310 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/addData-methods.R \name{addData} \alias{addData} \alias{addData,phylo4d-method} \alias{addData-methods} \alias{addData,phylo4-method} \title{Adding data to a phylo4 or a phylo4d object} \usage{ addData(x, ...) \S4method{addData}{phylo4d}( x, tip.data = NULL, node.data = NULL, all.data = NULL, merge.data = TRUE, pos = c("after", "before"), ... ) \S4method{addData}{phylo4}( x, tip.data = NULL, node.data = NULL, all.data = NULL, merge.data = TRUE, pos = c("after", "before"), ... ) } \arguments{ \item{x}{a phylo4 or a phylo4d object} \item{\dots}{additional arguments to control how matching between data and tree (see Details section of \code{\link{phylo4d-methods}} for more details).} \item{tip.data}{a data frame (or object to be coerced to one) containing only tip data} \item{node.data}{a data frame (or object to be coerced to one) containing only node data} \item{all.data}{a data frame (or object to be coerced to one) containing both tip and node data} \item{merge.data}{if both \code{tip.data} and \code{node.data} are provided, it determines whether columns with common names will be merged together (default TRUE). If FALSE, columns with common names will be preserved separately, with ".tip" and ".node" appended to the names. This argument has no effect if \code{tip.data} and \code{node.data} have no column names in common.} \item{pos}{should the new data provided be bound \code{before} or \code{after} the pre-existing data?} } \value{ \code{addData} returns a \code{phylo4d} object. } \description{ \code{addData} adds data to a \code{phylo4} (converting it in a \code{phylo4d} object) or to a \code{phylo4d} object } \details{ Rules for matching data to tree nodes are identical to those used by the \code{\link{phylo4d-methods}} constructor. If any column names in the original data are the same as columns in the new data, ".old" is appended to the former column names and ".new" is appended to the new column names. The option \code{pos} is ignored (silently) if \code{x} is a \code{phylo4} object. It is provided for compatibility reasons. } \examples{ data(geospiza) nDt <- data.frame(a=rnorm(nNodes(geospiza)), b=1:nNodes(geospiza), row.names=nodeId(geospiza, "internal")) t1 <- addData(geospiza, node.data=nDt) } \seealso{ \code{\link{tdata}} for extracting or updating data and \code{\link{phylo4d-methods}} constructor. } \author{ Francois Michonneau } \keyword{methods} phylobase/man/phylobase-package.Rd0000644000176200001440000000467414553653724016712 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phylobase-package.R \docType{package} \name{phylobase-package} \alias{phylobase-package} \alias{phylobase} \title{Utilities and Tools for Phylogenetics} \description{ Base package for phylogenetic structures and comparative data. } \details{ \code{phylobase} provides a set of functions to associate and manipulate phylogenetic information and data about the species/individuals that are in the tree. \code{phylobase} intends to be robust, fast and efficient. We hope other people use the data structure it provides to develop new comparative methods in R. With \code{phylobase} it is easy to ensure that all your data are represented and associated with the tips or the internal nodes of your tree. \code{phylobase} provides functions to: \itemize{ \item prune (subset) your trees, find ancestor(s) a descendant(s) \item find the most common recent ancestor of 2 nodes (MRCA) \item calculate the distance of a given node from the tip or between two nodes in your tree \item robust functions to import data from NEXUS and Newick files using the NEXUS Class Library (\url{https://github.com/mtholder/ncl/}) } } \section{History}{ \code{phylobase} was started during a Hackathlon at NESCent on December 10-14 2007. Peter Cowan was a Google Summer of Code fellow in 2008 and developed all the code for plotting. In December 2008, a mini-virtual Hackathlon was organized to clean up and make the code more robust. In the spring and summer of 2009, Jim Regetz made several contributions that made the code faster (in particular with the re-ordering parts), found many bugs, and wrote most of the testing code. \code{phylobase} was first released on CRAN on November 1st, 2009 with version 0.5. Since then, several releases have followed adding new functionalities: better support of NEXUS files, creation of \code{phylobase.options()} function that controls the \code{phylo4} validator, rewrite of the validator in C++. Starting with 0.6.8, Francois Michonneau succeeds to Ben Bolker as the maintainer of the package. } \section{More Info}{ See the help index \code{help(package="phylobase")} and run \code{vignette("phylobase", "phylobase")} for further details and examples about how to use \code{phylobase}. } \seealso{ Useful links: \itemize{ \item \url{https://github.com/fmichonneau/phylobase} \item Report bugs at \url{https://github.com/fmichonneau/phylobase/issues} } } \keyword{package} phylobase/man/pdata-class.Rd0000644000176200001440000000107614553646170015515 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pdata.R \docType{class} \name{pdata-class} \alias{pdata-class} \alias{ptypes} \alias{[<-,pdata-method} \alias{[,pdata-method} \alias{[,pdata,ANY,ANY,ANY-method} \alias{[[,pdata-method} \alias{[[<-,pdata-method} \alias{[[,pdata,ANY,ANY-method} \alias{[[,pdata,ANY,missing-method} \title{Class "pdata"} \description{ Data class for phylo4d objects } \section{Objects from the Class}{ Objects can be created by calls of the form \code{new("pdata", ...)}. } \author{ Ben Bolker } \keyword{classes} phylobase/man/setAs-methods.Rd0000644000176200001440000000374414553646170016045 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/setAs-methods.R \docType{methods} \name{setAs} \alias{setAs} \alias{as} \alias{as-method} \alias{as,phylo,phylo4-method} \alias{as,phylo,phylo4d-method} \alias{as,nexml,phylo4-method} \alias{as,nexml,phylo4d-method} \alias{as,phylo4,phylo-method} \alias{setAs,phylo4,phylog-method} \alias{setAs,phylo4,data.frame-method} \title{Converting between phylo4/phylo4d and other phylogenetic tree formats} \description{ Translation functions to convert between phylobase objects (\code{phylo4} or \code{phylo4d}), and objects used by other comparative methods packages in R: \code{ape} objects (\code{phylo}, \code{multiPhylo}), \code{RNeXML} object (\code{nexml}), \code{ade4} objects (\code{phylog}, \emph{now deprecated}), and to \code{data.frame} representation. } \section{Usage}{ \code{as(object, class)} } \examples{ tree_string <- "(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);" tree.owls <- ape::read.tree(text=tree_string) ## round trip conversion tree_in_phylo <- tree.owls # tree is a phylo object (tree_in_phylo4 <- as(tree.owls,"phylo4")) # phylo converted to phylo4 identical(tree_in_phylo,as(tree_in_phylo4,"phylo")) ## test if phylo, and phylo4 converted to phylo are identical ## (no, because of dimnames) ## Conversion to phylog (ade4) as(tree_in_phylo4, "phylog") ## Conversion to data.frame as(tree_in_phylo4, "data.frame") ## Conversion to phylo (ape) as(tree_in_phylo4, "phylo") ## Conversion to phylo4d, (data slots empty) as(tree_in_phylo4, "phylo4d") } \seealso{ generic \code{\link[methods]{as}}, \code{\link{phylo4-methods}}, \code{\link{phylo4d-methods}}, \code{\link{extractTree}}, \code{nexml} class from the \code{RNeXML} package, \code{\link[ade4]{phylog}} from the \code{ade4} package and \code{\link[ape]{as.phylo}} from the \code{ape} package. } \author{ Ben Bolker, Thibaut Jombart, Marguerite Butler, Steve Kembel, Francois Michonneau } \keyword{methods} phylobase/man/phylomat-class.Rd0000644000176200001440000000333014553646170016254 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phylomats-class.R \docType{class} \name{phylomat-class} \alias{phylomat-class} \alias{phylo4vcov-class} \alias{as_phylo4vcov} \alias{phylomat-setAs} \alias{setAs,phylo,phylo4vcov-method} \alias{setAs,phylo4vcov,phylo4-method} \title{matrix classes for phylobase} \arguments{ \item{from}{a \code{phylo4} object} \item{\dots}{optional arguments, to be passed to \code{vcov.phylo} in \code{ape} (the main useful option is \code{cor}, which can be set to \code{TRUE} to compute a correlation rather than a variance-covariance matrix)} } \description{ Classes representing phylogenies as matrices } \section{Objects from the Class}{ These are square matrices (with rows and columns corresponding to tips, and internal nodes implicit) with different meanings depending on the type (variance-covariance matrix, distance matrix, etc.). } \examples{ tree_string <- "(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);" tree.owls <- ape::read.tree(text=tree_string) o2 <- as(tree.owls,"phylo4") ov <- as(o2,"phylo4vcov") o3 <- as(ov,"phylo4") ## these are not completely identical, but are ## topologically identical ... ## edge matrices are in a different order: ## cf. edges(o2) and edges(o3) ## BUT the edge matrices are otherwise identical o2edges <- edges(o2) o3edges <- edges(o3) identical(o2edges[order(o2edges[,2]),], o3edges[order(o3edges[,2]),]) ## There is left/right ambiguity here in the tree orders: ## in o2 the 5->6->7->1 lineage ## (terminating in Strix aluco) ## is first, in o3 the 5->6->3 lineage ## (terminating in Athene noctua) is first. } \author{ Ben Bolker } \keyword{classes} phylobase/man/extractTree.Rd0000644000176200001440000000237414553646170015615 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/extractTree.R \name{extractTree} \alias{extractTree} \title{Get tree from tree+data object} \usage{ extractTree(from) } \arguments{ \item{from}{a \code{phylo4d} object, containing a phylogenetic tree plus associated phenotypic data. Created by the \code{phylo4d()} function.} } \description{ Extracts a \code{phylo4} tree object from a \code{phylo4d} tree+data object. } \details{ \code{extractTree} extracts just the phylogeny from a tree+data object. The phylogeny contains the topology (how the nodes are linked together), the branch lengths (if any), and any tip and/or node labels. This may be useful for extracting a tree from a \code{phylo4d} object, and associating with another phenotypic dataset, or to convert the tree to another format. } \examples{ tree.phylo <- ape::read.tree(text = "((a,b),c);") tree <- as(tree.phylo, "phylo4") plot(tree) tip.data <- data.frame(size = c(1, 2, 3), row.names = c("a", "b", "c")) (treedata <- phylo4d(tree, tip.data)) plot(treedata) (tree1 <- extractTree(treedata)) plot(tree1) } \seealso{ \code{\link{phylo4-methods}}, \code{\link{phylo4d-methods}}, \code{\link{coerce-methods}} for translation functions. } \author{ Ben Bolker } \keyword{methods} phylobase/man/multiPhylo-class.Rd0000644000176200001440000000104614553646170016567 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/multiphylo4-class.R \docType{class} \name{multiPhylo-class} \alias{multiPhylo-class} \alias{multiPhylo4-class} \alias{multiPhylo4d-class} \alias{tbind} \title{multiPhylo4 and extended classes} \description{ Classes for lists of phylogenetic trees. These classes and methods are planned for a future version of \code{phylobase}. Classes for lists of phylogenetic trees. These classes and methods are planned for a future version of \code{phylobase}. } \keyword{classes} phylobase/man/pdata.Rd0000644000176200001440000000135314553646170014410 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pdata.R \name{pdata} \alias{pdata} \alias{check_pdata} \title{Constructor for pdata (phylogenetic data) class} \usage{ pdata(data, type, comment, metadata) } \arguments{ \item{data}{a data frame} \item{type}{a factor with levels as specified by \linkS4class{pdata}, the same length as \code{ncol(data)}} \item{comment}{a character vector, the same length as \code{ncol(data)}} \item{metadata}{an arbitrary list} } \value{ An object of class \code{pdata} } \description{ Combine data, type, comments, and metadata information to create a new pdata object, or check such an object for consistency } \seealso{ \linkS4class{pdata} } \author{ Ben Bolker } \keyword{misc} phylobase/man/phylo4d-accessors.Rd0000644000176200001440000000411614553646170016665 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phylo4d-accessors.R \docType{methods} \name{hasTipData} \alias{hasTipData} \alias{hasTipData,phylo4d-method} \alias{hasTipData-method,phylo4d-method} \alias{hasNodeData} \alias{hasNodeData-methods} \alias{hasNodeData,phylo4d-method} \alias{nData} \alias{nData,phylo4d-method} \title{Tests for presence of data associated with trees stored as phylo4d objects} \usage{ hasTipData(x) \S4method{hasTipData}{phylo4d}(x) hasNodeData(x) \S4method{hasNodeData}{phylo4d}(x) nData(x) \S4method{nData}{phylo4d}(x) } \arguments{ \item{x}{a \code{phylo4d} object} } \value{ \describe{ \item{\code{nData}}{returns the number of datasets (i.e., columns) associated with the object.} \item{\code{hasTipData}, \code{hasNodeData}}{return \code{TRUE} or \code{FALSE} depending whether data associated with the tree are associated with either tips or internal nodes respectively.}} } \description{ Methods that test for the presence of data associated with trees stored as \code{phylo4d} objects. } \details{ \code{nData} tests for the presence of data associated with the object. \code{hasTipData} and \code{hasNodeData} tests for the presence of data associated with the tips and the internal nodes respectively. The outcome of the test is based on row names of the data frame stored in the \code{data} slot. If no rows have names from the set \code{nodeId(x, "tip")}, then \code{hasTipData} returns FALSE. Likewise, if no rows have names from the set \code{nodeId(x, "internal")}, then \code{hasNodeData} returns FALSE. } \section{Methods}{ \describe{ \item{hasNodeData}{\code{signature(object = "phylo4d")}: whether tree has internal node data} \item{hasTipData}{\code{signature(object = "phylo4d")}: whether tree has data associated with its tips} } } \examples{ data(geospiza) nData(geospiza) ## 5 hasTipData(geospiza) ## TRUE hasNodeData(geospiza) ## FALSE } \seealso{ \code{\link{phylo4d-methods}} constructor and \code{\linkS4class{phylo4d}} class. } \author{ Ben Bolker, Thibault Jombart, Francois Michonneau } \keyword{methods} phylobase/man/plotOneTree.Rd0000644000176200001440000000343514553646170015562 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/treePlot.R \name{plotOneTree} \alias{plotOneTree} \title{Plot a phylo4 object} \usage{ plotOneTree( xxyy, type, show.tip.label, show.node.label, edge.color, node.color, tip.color, edge.width, rot ) } \arguments{ \item{xxyy}{A list created by the \code{\link{phyloXXYY}} function} \item{type}{A character string indicating the shape of plotted tree} \item{show.tip.label}{Logical, indicating whether tip labels should be shown} \item{show.node.label}{Logical, indicating whether node labels should be shown} \item{edge.color}{A vector of colors in the order of \code{edges(phy)}} \item{node.color}{A vector of colors indicating the colors of the node labels} \item{tip.color}{A vector of colors indicating the colors of the tip labels} \item{edge.width}{A vector in the order of \code{edges(phy)} indicating the widths of edge lines} \item{rot}{Numeric indicating the rotation of the plot in degrees} } \value{ Returns no values, function invoked for the plotting side effect. } \description{ Plots the phylogenetic tree contained in a \code{phylo4} or \code{phylo4d} object. } \examples{ library(grid) data(geospiza) grid.newpage() xxyy <- phyloXXYY(geospiza) plotOneTree(xxyy, type = 'phylogram', show.tip.label = TRUE, show.node.label = TRUE, edge.color = 'black', node.color = 'orange', tip.color = 'blue', edge.width = 1, rot = 0 ) grid.newpage() pushViewport(viewport(w = 0.8, h = 0.8)) plotOneTree(xxyy, type = 'phylogram', show.tip.label = TRUE, show.node.label = TRUE, edge.color = 'black', node.color = 'orange', tip.color = 'blue', edge.width = 1, rot = 0 ) popViewport() } \seealso{ \code{treePlot}, \code{\link{phyloXXYY}} } \author{ Peter Cowan \email{pdc@berkeley.edu} } \keyword{methods} phylobase/man/nTips-methods.Rd0000644000176200001440000000146314553646170016057 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phylo4-accessors.R \docType{methods} \name{nTips} \alias{nTips} \alias{nTips,phylo4-method} \alias{nTips,phylo-method} \alias{nNodes} \alias{nNodes,phylo4-method} \alias{nEdges} \alias{nEdges,phylo4-method} \title{nTips, nNodes, nEdges} \usage{ nTips(x) \S4method{nTips}{phylo4}(x) \S4method{nTips}{phylo}(x) nNodes(x) \S4method{nNodes}{phylo4}(x) nEdges(x) \S4method{nEdges}{phylo4}(x) } \arguments{ \item{x}{a \code{phylo4} or \code{phylo4d} object} } \value{ a numeric vector indicating the number of tips, nodes or edge respectively. } \description{ Number of tips, nodes and edges found in a tree. } \details{ Function to return the number of tips, nodes and edges found in a tree in the \code{phylo4} or \code{phylo4d} format. } phylobase/man/geospiza.Rd0000644000176200001440000000133514553653724015143 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phylobase-package.R \docType{data} \name{geospiza} \alias{geospiza} \alias{geospiza_raw} \title{Data from Darwin's finches} \format{ \code{geospiza} is a \code{phylo4d} object; \code{geospiza_raw} is a list containing \code{tree}, a \code{phylo} object (the tree), \code{data}, and a data frame with the data (for showing examples of how to merge tree and data) } \source{ Dolph Schluter via Luke Harmon } \description{ Phylogenetic tree and morphological data for Darwin's finches, in different formats } \note{ Stolen from Luke Harmon's Geiger package, to avoid unnecessary dependencies } \examples{ data(geospiza) plot(geospiza) } \keyword{datasets} phylobase/man/phylo4d-methods.Rd0000644000176200001440000002537414553715042016347 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phylo4d-methods.R \docType{methods} \name{phylo4d-methods} \alias{phylo4d-methods} \alias{phylo4d} \alias{phylo4d,phylo4-method} \alias{phylo4d,phylo4,phylo4-method} \alias{phylo4d,matrix-method} \alias{phylo4d,matrix,matrix-method} \alias{phylo4d,phylo-method} \alias{phylo4d,phylo,phylo-method} \alias{phylo4d,phylo4d-method} \alias{phylo4d,phylo4d,phylo4d-method} \alias{phylo4d,nexml-method} \alias{nexml,phylo4d-method} \title{Combine a phylogenetic tree with data} \usage{ phylo4d(x, ...) \S4method{phylo4d}{phylo4}( x, tip.data = NULL, node.data = NULL, all.data = NULL, merge.data = TRUE, metadata = list(), ... ) \S4method{phylo4d}{matrix}( x, tip.data = NULL, node.data = NULL, all.data = NULL, merge.data = TRUE, metadata = list(), edge.length = NULL, tip.label = NULL, node.label = NULL, edge.label = NULL, order = "unknown", annote = list(), ... ) \S4method{phylo4d}{phylo}( x, tip.data = NULL, node.data = NULL, all.data = NULL, check.node.labels = c("keep", "drop", "asdata"), annote = list(), metadata = list(), ... ) \S4method{phylo4d}{phylo4d}(x, ...) \S4method{phylo4d}{nexml}(x) } \arguments{ \item{x}{an object of class \code{phylo4}, \code{phylo}, \code{nexml} or a matrix of edges (see above)} \item{\dots}{further arguments to control the behavior of the constructor in the case of missing/extra data and where to look for labels in the case of non-unique labels that cannot be stored as row names in a data frame (see Details).} \item{tip.data}{a data frame (or object to be coerced to one) containing only tip data (Optional)} \item{node.data}{a data frame (or object to be coerced to one) containing only node data (Optional)} \item{all.data}{a data frame (or object to be coerced to one) containing both tip and node data (Optional)} \item{merge.data}{if both \code{tip.data} and \code{node.data} are provided, should columns with common names will be merged together (default TRUE) or not (FALSE)? See details.} \item{metadata}{any additional metadata to be passed to the new object} \item{edge.length}{Edge (branch) length. (Optional)} \item{tip.label}{A character vector of species names (names of "tip" nodes). (Optional)} \item{node.label}{A character vector of internal node names. (Optional)} \item{edge.label}{A character vector of edge (branch) names. (Optional)} \item{order}{character: tree ordering (allowable values are listed in \code{phylo4_orderings}, currently "unknown", "preorder" (="cladewise" in \code{ape}), and "postorder", with "cladewise" and "pruningwise" also allowed for compatibility with \code{ape})} \item{annote}{any additional annotation data to be passed to the new object} \item{check.node.labels}{if \code{x} is of class \code{phylo}, use either \dQuote{keep} (the default) to retain internal node labels, \dQuote{drop} to drop them, or \dQuote{asdata} to convert them to numeric tree data. This argument is useful if the \code{phylo} object has non-unique node labels or node labels with informative data (e.g., posterior probabilities).} } \value{ An object of class \linkS4class{phylo4d}. } \description{ \code{phylo4d} is a generic constructor which merges a phylogenetic tree with data frames to create a combined object of class \code{phylo4d} } \details{ You can provide several data frames to define traits associated with tip and/or internal nodes. By default, data row names are used to link data to nodes in the tree, with any number-like names (e.g., \dQuote{10}) matched against node ID numbers, and any non-number-like names (e.g., \dQuote{n10}) matched against node labels. Alternative matching rules can be specified by passing additional arguments (listed in the Details section); these include positional matching, matching exclusively on node labels, and matching based on a column of data rather than on row names. Matching rules will apply the same way to all supplied data frames. This means that you need to be consistent with the row names of your data frames. It is good practice to use tip and node labels (or node numbers if you use duplicated labels) when you combine data with a tree. If you provide both \code{tip.data} and \code{node.data}, the treatment of columns with common names will depend on the \code{merge.data} argument. If TRUE, columns with the same name in both data frames will be merged; when merging columns of different data types, coercion to a common type will follow standard R rules. If \code{merge.data} is FALSE, columns with common names will be preserved independently, with \dQuote{.tip} and \dQuote{.node} appended to the names. This argument has no effect if \code{tip.data} and \code{node.data} have no column names in common. If you provide \code{all.data} along with either of \code{tip.data} and \code{node.data}, it must have distinct column names, otherwise an error will result. Additionally, although supplying columns with the same names \emph{within} data frames is not illegal, automatic renaming for uniqeness may lead to surprising results, so this practice should be avoided. This is the list of additional arguments that can be used to control matching between the tree and the data: \describe{ \item{match.data}{(logical) should the rownames of the data frame be used to be matched against tip and internal node identifiers?} \item{rownamesAsLabels}{(logical), should the row names of the data provided be matched only to labels (TRUE), or should any number-like row names be matched to node numbers (FALSE and default)} \item{label.type}{character, \code{rownames} or \code{column}: should the labels be taken from the row names of \code{dt} or from the \code{label.column} column of \code{dt}?} \item{label.column}{iff \code{label.type=="column"}, column specifier (number or name) of the column containing tip labels} \item{missing.data}{action to take if there are missing data or if there are data labels that don't match} \item{extra.data}{action to take if there are extra data or if there are labels that don't match} \item{keep.all}{(logical), should the returned data have rows for all nodes (with NA values for internal rows when type='tip', and vice versa) (TRUE and default) or only rows corresponding to the type argument} } Rules for matching rows of data to tree nodes are determined jointly by the \code{match.data} and \code{rownamesAsLabels} arguments. If \code{match.data} is TRUE, data frame rows will be matched exclusively against tip and node labels if \code{rownamesAsLabels} is also TRUE, whereas any all-digit row names will be matched against tip and node numbers if \code{rownamesAsLabels} is FALSE (the default). If \code{match.data} is FALSE, \code{rownamesAsLabels} has no effect, and row matching is purely positional with respect to the order returned by \code{nodeId(phy, type)}. } \note{ Checking on matches between the tree and the data will be done by the validity checker (label matches between data and tree tips, number of rows of data vs. number of nodes/tips/etc.) } \section{Methods}{ \describe{ \item{x = "phylo4"}{merges a tree of class \code{phylo4} with a data.frame into a \code{phylo4d} object} \item{x = "matrix"}{merges a matrix of tree edges similar to the edge slot of a \code{phylo4} object (or to \code{$edge} of a \code{phylo} object) with a data.frame into a \code{phylo4d} object} \item{x = "phylo"}{merges a tree of class \code{phylo} with a data.frame into a \code{phylo4d} object } } } \examples{ treeOwls <- "((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3);" tree.owls.bis <- ape::read.tree(text=treeOwls) try(phylo4d(as(tree.owls.bis,"phylo4"),data.frame(wing=1:3)), silent=TRUE) obj <- phylo4d(as(tree.owls.bis,"phylo4"),data.frame(wing=1:3), match.data=FALSE) obj print(obj) #### data(geospiza_raw) geoTree <- geospiza_raw$tree geoData <- geospiza_raw$data ## fix differences in tip names between the tree and the data geoData <- rbind(geoData, array(, dim = c(1,ncol(geoData)), dimnames = list("olivacea", colnames(geoData)))) ### Example using a tree of class 'phylo' exGeo1 <- phylo4d(geoTree, tip.data = geoData) ### Example using a tree of class 'phylo4' geoTree <- as(geoTree, "phylo4") ## some random node data rNodeData <- data.frame(randomTrait = rnorm(nNodes(geoTree)), row.names = nodeId(geoTree, "internal")) exGeo2 <- phylo4d(geoTree, tip.data = geoData, node.data = rNodeData) ### Example using 'merge.data' data(geospiza) trGeo <- extractTree(geospiza) tDt <- data.frame(a=rnorm(nTips(trGeo)), row.names=nodeId(trGeo, "tip")) nDt <- data.frame(a=rnorm(nNodes(trGeo)), row.names=nodeId(trGeo, "internal")) (matchData1 <- phylo4d(trGeo, tip.data=tDt, node.data=nDt, merge.data=FALSE)) (matchData2 <- phylo4d(trGeo, tip.data=tDt, node.data=nDt, merge.data=TRUE)) ## Example with 'all.data' nodeLabels(geoTree) <- as.character(nodeId(geoTree, "internal")) rAllData <- data.frame(randomTrait = rnorm(nTips(geoTree) + nNodes(geoTree)), row.names = labels(geoTree, 'all')) exGeo5 <- phylo4d(geoTree, all.data = rAllData) ## Examples using 'rownamesAsLabels' and comparing with match.data=FALSE tDt <- data.frame(x=letters[1:nTips(trGeo)], row.names=sample(nodeId(trGeo, "tip"))) tipLabels(trGeo) <- as.character(sample(1:nTips(trGeo))) (exGeo6 <- phylo4d(trGeo, tip.data=tDt, rownamesAsLabels=TRUE)) (exGeo7 <- phylo4d(trGeo, tip.data=tDt, rownamesAsLabels=FALSE)) (exGeo8 <- phylo4d(trGeo, tip.data=tDt, match.data=FALSE)) ## generate a tree and some data set.seed(1) p3 <- ape::rcoal(5) dat <- data.frame(a = rnorm(5), b = rnorm(5), row.names = p3$tip.label) dat.defaultnames <- dat row.names(dat.defaultnames) <- NULL dat.superset <- rbind(dat, rnorm(2)) dat.subset <- dat[-1, ] ## create a phylo4 object from a phylo object p4 <- as(p3, "phylo4") ## create phylo4d objects with tip data p4d <- phylo4d(p4, dat) ###checkData(p4d) p4d.sorted <- phylo4d(p4, dat[5:1, ]) try(p4d.nonames <- phylo4d(p4, dat.defaultnames)) p4d.nonames <- phylo4d(p4, dat.defaultnames, match.data=FALSE) \dontrun{ p4d.subset <- phylo4d(p4, dat.subset) p4d.subset <- phylo4d(p4, dat.subset) try(p4d.superset <- phylo4d(p4, dat.superset)) p4d.superset <- phylo4d(p4, dat.superset) } ## create phylo4d objects with node data nod.dat <- data.frame(a = rnorm(4), b = rnorm(4)) p4d.nod <- phylo4d(p4, node.data = nod.dat, match.data=FALSE) ## create phylo4 objects with node and tip data p4d.all1 <- phylo4d(p4, node.data = nod.dat, tip.data = dat, match.data=FALSE) nodeLabels(p4) <- as.character(nodeId(p4, "internal")) p4d.all2 <- phylo4d(p4, all.data = rbind(dat, nod.dat), match.data=FALSE) } \seealso{ \code{\link{coerce-methods}} for translation functions. The \linkS4class{phylo4d} class; \linkS4class{phylo4} class and \link{phylo4} constructor. } \author{ Ben Bolker, Thibaut Jombart, Steve Kembel, Francois Michonneau, Jim Regetz } \keyword{misc} phylobase/man/shortestPath-methods.Rd0000644000176200001440000000207614553646170017453 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shortestPath-methods.R \docType{methods} \name{shortestPath} \alias{shortestPath} \alias{shortestPath-phylo4} \alias{shortestPath,phylo4-method} \alias{shortestPath-phylo} \alias{shortestPath,phylo-method} \title{shortestPath-methods} \usage{ shortestPath(x, node1, node2) \S4method{shortestPath}{phylo4}(x, node1, node2) \S4method{shortestPath}{phylo}(x, node1, node2) } \arguments{ \item{x}{a tree in the phylo4, phylo4d or phylo format} \item{node1}{a numeric or character (passed to \code{getNode}) indicating the beginning from which the path should be calculated.} \item{node2}{a numeric or character (passed to \code{getNode}) indicating the end of the path.} } \value{ a vector of nodes indcating the shortest path between 2 nodes } \description{ Finds the shortest path between two nodes in a tree } \details{ Given two nodes (i.e, tips or internal nodes), this function returns the shortest path between them (excluding \code{node1} and \code{node2} as a vector of nodes. } \seealso{ getNode } phylobase/man/phylobase.options.Rd0000644000176200001440000000211514553646170016774 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phylobase.options.R \name{phylobase.options} \alias{phylobase.options} \title{Set or return options of phylobase} \usage{ phylobase.options(...) } \arguments{ \item{\dots}{a list may be given as the only argument, or any number of arguments may be in the \code{name=value} form, or no argument at all may be given. See the Value and Details sections for explanation.} } \value{ A list with the updated values of the parameters. If arguments are provided, the returned list is invisible. } \description{ Provides a mean to control the validity of \code{phylobase} objects such as singletons, reticulated trees, polytomies, etc. } \details{ The parameter values set via a call to this function will remain in effect for the rest of the session, affecting the subsequent behavior of phylobase. } \examples{ \dontrun{ phylobase.options(poly="fail") # subsequent trees with polytomies will fail the validity check } } \author{ Francois Michonneau (adapted from the package \code{sm}) } \keyword{phylobase} \keyword{validator} phylobase/man/summary-methods.Rd0000644000176200001440000000473614553646170016465 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/summary-methods.R \docType{methods} \name{summary-methods} \alias{summary-methods} \alias{summary} \alias{summary,phylo4-method} \alias{summary,phylo4d-method} \alias{nodeType} \alias{nodeType,phylo4-method} \title{Summary for phylo4/phylo4d objects} \usage{ summary(object, ...) \S4method{summary}{phylo4}(object, quiet = FALSE) \S4method{summary}{phylo4d}(object, quiet = FALSE) nodeType(object) \S4method{nodeType}{phylo4}(object) } \arguments{ \item{object}{a phylo4d object} \item{\dots}{optional additional elements (not in use)} \item{quiet}{Should the summary be displayed on screen?} } \value{ The \code{nodeType} method returns named vector which has the type of node (internal, tip, root) for value, and the node number for name The \code{summary} method invisibly returns a list with the following components: \item{list("name")}{the name of the object} \item{list("nb.tips")}{the number of tips} \item{list("nb.nodes")}{the number of nodes} \item{list("mean.el")}{mean of edge lengths} \item{list("var.el")}{variance of edge lengths (estimate for population) } \item{list("sumry.el")}{summary (i.e. range and quartiles) of the edge lengths} \item{list("degree")}{(optional) type of polytomy for each node: \sQuote{node}, \sQuote{terminal} (all descendants are tips) or \sQuote{internal} (at least one descendant is an internal node); displayed only when there are polytomies} \item{list("sumry.tips")}{(optional) summary for the data associated with the tips} \item{list("sumry.nodes")}{(optional) summary for the data associated with the internal nodes} } \description{ Summary of information for the tree (\code{phylo4} only) and/or the associated data (\code{phylo4d}). } \examples{ tOwls <- "(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);" tree.owls <- ape::read.tree(text=tOwls) P1 <- as(tree.owls, "phylo4") P1 summary(P1) nodeType(P1) ## summary of a polytomous tree E <- matrix(c( 8, 9, 9, 10, 10, 1, 10, 2, 9, 3, 9, 4, 8, 11, 11, 5, 11, 6, 11, 7, 0, 8), ncol=2, byrow=TRUE) P2 <- phylo4(E) nodeLabels(P2) <- as.character(nodeId(P2, "internal")) plot(P2, show.node.label=TRUE) sumryP2 <- summary(P2) sumryP2 } \seealso{ \code{\link{phylo4d-methods}} constructor and \code{\linkS4class{phylo4d}} class. } \author{ Ben Bolker, Thibaut Jombart, Francois Michonneau } \keyword{methods} phylobase/man/root-methods.Rd0000644000176200001440000000170714553646170015746 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/root-methods.R \docType{methods} \name{isRooted} \alias{isRooted} \alias{isRooted,phylo4-method} \alias{rootNode} \alias{rootNode,phylo4-method} \alias{rootNode<-} \alias{rootNode<-,phylo4-method} \title{Methods to test, access (and modify) the root of a phylo4 object.} \usage{ isRooted(x) \S4method{isRooted}{phylo4}(x) rootNode(x) \S4method{rootNode}{phylo4}(x) rootNode(x) <- value \S4method{rootNode}{phylo4}(x) <- value } \arguments{ \item{x}{a \code{phylo4} or \code{phylo4d} object.} \item{value}{a character string or a numeric giving the new root.} } \value{ \describe{ \item{isRooted}{logical whether the tree is rooted} \item{rootNode}{the node corresponding to the root} } } \description{ Methods to test, access (and modify) the root of a phylo4 object. } \examples{ data(geospiza) isRooted(geospiza) rootNode(geospiza) } \author{ Ben Bolker, Francois Michonneau } phylobase/man/edges-accessors.Rd0000644000176200001440000000345514553646170016376 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phylo4-accessors.R \docType{methods} \name{edges} \alias{edges} \alias{edges,phylo4-method} \alias{edgeOrder} \alias{edgeOrder,phylo4-method} \alias{internalEdges} \alias{internalEdges,phylo4-method} \alias{terminalEdges} \alias{terminalEdges,phylo4-method} \title{Edges accessors} \usage{ edges(x, ...) \S4method{edges}{phylo4}(x, drop.root = FALSE) edgeOrder(x, ...) \S4method{edgeOrder}{phylo4}(x) internalEdges(x) \S4method{internalEdges}{phylo4}(x) terminalEdges(x) \S4method{terminalEdges}{phylo4}(x) } \arguments{ \item{x}{a \code{phylo4} or \code{phylo4d} object.} \item{\dots}{Optional arguments used by specific methods. (None used at present).} \item{drop.root}{logical (default FALSE), should the edge connecting the root be included in the edge matrix?} } \value{ \describe{ \item{\code{edges}}{returns the edge matrix that represent the ancestor-descendant relationships among the nodes of the tree.} \item{\code{edgeOrder}}{returns the order in which the edge matrix is in.} \item{\code{internalEdges}}{returns a logical vector indicating internal edges (edges that connect an internal node to another). This vector is named with the \code{edgeId}}. \item{\code{terminalEdges}}{returns a logical vector indicating terminal edges (edges that connect an internal node to a tip). This vector is named with the \code{edgeId} }} } \description{ Access or modify information about the edges. } \examples{ data(geospiza) edges(geospiza) edgeOrder(geospiza) geoPost <- reorder(geospiza, "postorder") edgeOrder(geoPost) ## with a binary tree this should always be true identical(!terminalEdges(geospiza), internalEdges(geospiza)) } \seealso{ reorder, edgeId } \author{ Ben Bolker, Francois Michonneau, Thibaut Jombart } phylobase/man/phylobubbles.Rd0000644000176200001440000000352214553646170016011 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/treePlot.R \name{phylobubbles} \alias{phylobubbles} \title{Bubble plots for phylo4d objects} \usage{ phylobubbles( type = type, place.tip.label = "right", show.node.label = show.node.label, rot = 0, edge.color = edge.color, node.color = node.color, tip.color = tip.color, edge.width = edge.width, newpage = TRUE, ..., XXYY, square = FALSE, grid = TRUE ) } \arguments{ \item{type}{the type of plot} \item{place.tip.label}{A string indicating whether labels should be plotted to the right or to the left of the bubble plot} \item{show.node.label}{A logical indicating whether internal node labels should be plotted} \item{rot}{The number of degrees that the plot should be rotated} \item{edge.color}{A vector of colors for the tree edge segments} \item{node.color}{A vector of colors for the coloring the nodes} \item{tip.color}{A vector of colors for the coloring the tip labels} \item{edge.width}{A vector of line widths for the tree edges} \item{newpage}{Logical to control whether the device is cleared before plotting, useful for adding plot inside other plots} \item{\dots}{Additional parameters passed to the bubble plotting functions} \item{XXYY}{The out put from the phyloXXYY function} \item{square}{Logical indicating whether the plot 'bubbles' should be squares} \item{grid}{A logical indicating whether a grey grid should be plotted behind the bubbles} } \description{ Plots either circles or squares corresponding to the magnitude of each cell of a \code{phylo4d} object. } \examples{ ##---- Should be DIRECTLY executable !! ---- ##-- ==> Define data, use random, ##-- or do help(data=index) for the standard data sets. } \seealso{ \code{\link{phyloXXYY}}, \code{treePlot} } \author{ Peter Cowan \email{pdc@berkeley.edu} } \keyword{methods} phylobase/man/checkPhylo4.Rd0000644000176200001440000000442214555723737015503 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/checkdata.R \name{checkPhylo4} \alias{checkPhylo4} \alias{checkTree} \alias{checkPhylo4Data} \title{Validity checking for phylo4 objects} \usage{ checkPhylo4(object) } \arguments{ \item{object}{A prospective phylo4 or phylo4d object} } \value{ As required by \code{\link[methods]{validObject}}, returns an error string (describing problems) or TRUE if everything is OK. } \description{ Basic checks on the validity of S4 phylogenetic objects } \note{ These functions are only intended to be called by other phylobase functions. \code{checkPhylo4} is an (inflexible) wrapper for \code{checkTree}. The rules for \code{phylo4} objects essentially follow those for \code{phylo} objects from the \code{ape} package, which are in turn defined in \url{https://emmanuelparadis.github.io/misc/FormatTreeR.pdf}. These are essentially that: \itemize{ \item if the tree has edge lengths defined, the number of edge lengths must match the number of edges; \item the number of tip labels must match the number of tips; \item in a tree with \code{ntips} tips and \code{nnodes} (total) nodes, nodes 1 to \code{ntips} must be tips \item if the tree is rooted, the root must be node number \code{ntips+1} and the root node must be the first row of the edge matrix \item tip labels, node labels, edge labels, edge lengths must have proper internal names (i.e. internal names that match the node numbers they document) \item tip and node labels must be unique } You can alter some of the default options by using the function \code{phylobase.options}. For \code{phylo4d} objects, \code{checkTree} also calls \code{checkPhylo4Data} to check the validity of the data associated with the tree. It ensures that (1) the data associated with the tree have the correct dimensions, (2) that the row names for the data are correct. } \seealso{ the \code{\link{phylo4}} constructor and \linkS4class{phylo4} class; the \code{\link{phylo4d-methods}} constructor and the \linkS4class{phylo4d} class do checks for the data associated with trees. See \code{\link{coerce-methods}} for translation functions and \code{\link{phylobase.options} to change some of the default options of the validator.} } \author{ Ben Bolker, Steven Kembel, Francois Michonneau } \keyword{misc} phylobase/man/getNode-methods.Rd0000644000176200001440000001013214553646170016340 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/getNode-methods.R \name{getNode} \alias{getNode} \alias{getNode,phylo4-method} \alias{getEdge} \alias{getEdge-methods} \alias{getEdge,phylo4-method} \title{Node and Edge look-up functions} \usage{ getNode( x, node, type = c("all", "tip", "internal"), missing = c("warn", "OK", "fail") ) \S4method{getNode}{phylo4}( x, node, type = c("all", "tip", "internal"), missing = c("warn", "OK", "fail") ) getEdge( x, node, type = c("descendant", "ancestor"), missing = c("warn", "OK", "fail") ) \S4method{getEdge}{phylo4}( x, node, type = c("descendant", "ancestor"), missing = c("warn", "OK", "fail") ) } \arguments{ \item{x}{a \linkS4class{phylo4} object (or one inheriting from \linkS4class{phylo4}, e.g. a \linkS4class{phylo4d} object)} \item{node}{either an integer vector corresponding to node ID numbers, or a character vector corresponding to node labels; if missing, all nodes appropriate to the specified type will be returned by \code{getNode}, and all edges appropriate to the specified type will be returned by \code{getEdge}.} \item{type}{(\code{getNode}) specify whether to return nodes matching "all" tree nodes (default), only "tip" nodes, or only "internal" nodes; (\code{nodeId, edgeId}) specify whether to return "all" tree nodes, or only those corresponding to "tip", "internal", or "root" nodes; (\code{getEdge}) specify whether to look up edges based on their descendant node ("descendant") or ancestral node ("ancestor")} \item{missing}{what to do if some requested node IDs or names are not in the tree: warn, do nothing, or stop with an error} } \value{ \item{list("getNode")}{returns a named integer vector of node IDs, in the order of input nodes if provided, otherwise in nodeId order} \item{list("getEdge")}{returns a named character vector of edge IDs, in the order of input nodes if provide, otherwise in nodeId order} \item{list("nodeId")}{returns an unnamed integer vector of node IDs, in ascending order} \item{list("getEdge")}{returns an unnamed character vector of edge IDs, in edge matrix order} } \description{ Functions for retrieving node and edge IDs (possibly with corresponding labels) from a phylogenetic tree. } \details{ \code{getNode} and \code{getEdge} are primarily intended for looking up the IDs either of nodes themselves or of edges associated with those nodes. Note that they behave quite differently. With \code{getNode}, any input nodes are looked up against tree nodes of the specified type, and those that match are returned as numeric node IDs with node labels (if they exist) as element names. With \code{getEdge}, any input nodes are looked up against edge ends of the specified type, and those that match are returned as character edge IDs with the corresponding node ID as element names. If \code{missing} is \dQuote{warn} or \dQuote{OK}, \code{NA} is returned for any nodes that are unmatched for the specified type. This can provide a mechanism for filtering a set of nodes or edges. \code{nodeId} provides similar output to \code{getNode} in the case when no node is supplied, but it is faster and returns an unnamed vector of the numeric IDs of all nodes of the specified node type. Similarly, \code{edgeId} simply returns an unnamed vector of the character IDs of all edges for which the descendant node is of the specified node type. } \examples{ data(geospiza) nodeLabels(geospiza) <- LETTERS[1:nNodes(geospiza)] plot(as(geospiza, "phylo4"), show.node.label=TRUE) getNode(geospiza, 18) getNode(geospiza, "D") getEdge(geospiza, "D") getEdge(geospiza, "D", type="ancestor") ## match nodes only to tip nodes, flagging invalid cases as NA getNode(geospiza, c(1, 18, 999), type="tip", missing="OK") ## get all edges that descend from internal nodes getEdge(geospiza, type="ancestor") ## identify an edge from its terminal node getEdge(geospiza, c("olivacea", "B", "fortis")) getNode(geospiza, c("olivacea", "B", "fortis")) edges(geospiza)[c(26, 1, 11),] ## quickly get all tip node IDs and tip edge IDs nodeId(geospiza, "tip") edgeId(geospiza, "tip") } \keyword{misc} phylobase/man/owls4.Rd0000644000176200001440000000076114553653724014374 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phylobase-package.R \docType{data} \name{owls4} \alias{owls4} \title{'Owls' data from ape} \format{ This is the standard 'owls' tree from the \code{ape} package, in \code{phylo4} format. } \source{ From various examples in the \code{ape} package } \description{ A tiny tree, for testing/example purposes, using one of the examples from the \code{ape} package } \examples{ data(owls4) plot(owls4) } \keyword{datasets} phylobase/man/labels-methods.Rd0000644000176200001440000001027014553646170016220 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/labels-methods.R \docType{methods} \name{phylo4-labels} \alias{phylo4-labels} \alias{labels} \alias{labels,phylo4-method} \alias{labels<-} \alias{labels<-,phylo4-method} \alias{hasDuplicatedLabels} \alias{hasDuplicatedLabels,phylo4-method} \alias{hasDuplicatedLabels,phylo4,ANY-method} \alias{hasNodeLabels} \alias{hasNodeLabels,phylo4-method} \alias{nodeLabels} \alias{nodeLabels,phylo4-method} \alias{nodeLabels<-} \alias{nodeLabels<-,phylo4-method} \alias{tipLabels} \alias{tipLabels,phylo4-method} \alias{tipLabels<-} \alias{tipLabels<-,phylo4-method} \alias{hasEdgeLabels} \alias{hasEdgeLabels,phylo4-method} \alias{edgeLabels} \alias{edgeLabels,phylo4-method} \alias{edgeLabels<-} \alias{edgeLabels<-,phylo4-method} \title{Labels for phylo4/phylo4d objects} \usage{ labels(object, ...) \S4method{labels}{phylo4}(object, type = c("all", "tip", "internal")) labels(x, type, use.names, ...) <- value \S4method{labels}{phylo4}(x, type = c("all", "tip", "internal"), use.names, ...) <- value hasDuplicatedLabels(x, type) \S4method{hasDuplicatedLabels}{phylo4}(x, type = c("all", "tip", "internal")) hasNodeLabels(x) \S4method{hasNodeLabels}{phylo4}(x) nodeLabels(x) \S4method{nodeLabels}{phylo4}(x) nodeLabels(x, ...) <- value \S4method{nodeLabels}{phylo4}(x, ...) <- value tipLabels(x) \S4method{tipLabels}{phylo4}(x) tipLabels(x, ...) <- value \S4method{tipLabels}{phylo4}(x, ...) <- value hasEdgeLabels(x) \S4method{hasEdgeLabels}{phylo4}(x) edgeLabels(x) \S4method{edgeLabels}{phylo4}(x) edgeLabels(x, ...) <- value \S4method{edgeLabels}{phylo4}(x, ...) <- value } \arguments{ \item{object}{a phylo4 or phylo4d object.} \item{\dots}{additional optional arguments (not in use)} \item{type}{which type of labels: \code{all} (tips and internal nodes), \code{tip} (tips only), \code{internal} (internal nodes only).} \item{x}{a phylo4 or phylo4d object.} \item{use.names}{should the names of the vector used to create/update labels be used to match the labels? See Details for more information.} \item{value}{a vector of class \code{character}, see Details for more information.} } \value{ labels in ascending order. } \description{ Methods for creating, accessing and updating labels in phylo4/phylo4d objects } \details{ In phylo4/phylo4d objects, tips must have labels (that's why there is no method for hasTipLabels), internal nodes and edges can have labels. Labels must be provided as a vector of class \code{character}. The length of the vector must match the number of elements they label. The option \code{use.names} allows the user to match a label to a particular node. In this case, the vector must have names that match the node numbers. The function \code{labels} is mostly intended to be used internally. } \section{Methods}{ \describe{ \item{labels}{\code{signature(object = "phylo4")}: tip and/or internal node labels, ordered by node ID} \item{hasDuplicatedLabels}{\code{signature(object = "phylo4")}: are any labels duplicated?} \item{tipLabels}{\code{signature(object = "phylo4")}: tip labels, ordered by node ID} \item{hasNodeLabels}{\code{signature(object = "phylo4")}: whether tree has (internal) node labels} \item{nodeLabels}{\code{signature(object = "phylo4")}: internal node labels, ordered by node ID} \item{hasEdgeLabels}{\code{signature(object = "phylo4")}: whether tree has (internal) edge labels} \item{edgeLabels}{\code{signature(object = "phylo4")}: internal edge labels, ordered according to the edge matrix} } } \examples{ data(geospiza) ## Return labels from geospiza tipLabels(geospiza) ## Internal node labels in geospiza are empty nodeLabels(geospiza) ## Creating internal node labels ndLbl <- paste("n", 1:nNodes(geospiza), sep="") nodeLabels(geospiza) <- ndLbl nodeLabels(geospiza) ## naming the labels names(ndLbl) <- nodeId(geospiza, "internal") ## shuffling the labels (ndLbl <- sample(ndLbl)) ## by default, the labels are attributed in the order ## they are given: nodeLabels(geospiza) <- ndLbl nodeLabels(geospiza) ## but use.names puts them in the correct order labels(geospiza, "internal", use.names=TRUE) <- ndLbl nodeLabels(geospiza) } \author{ Ben Bolker, Peter Cowan, Steve Kembel, Francois Michonneau } phylobase/man/ancestors.Rd0000644000176200001440000000672014553646170015323 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ancestors.R \name{ancestor} \alias{ancestor} \alias{children} \alias{descendants} \alias{siblings} \alias{ancestors} \title{Tree traversal and utility functions} \usage{ ancestor(phy, node) children(phy, node) descendants(phy, node, type = c("tips", "children", "all", "ALL")) siblings(phy, node, include.self = FALSE) ancestors(phy, node, type = c("all", "parent", "ALL")) } \arguments{ \item{phy}{a \linkS4class{phylo4} object (or one inheriting from \linkS4class{phylo4}, e.g. a \linkS4class{phylo4d} object)} \item{node}{either an integer corresponding to a node ID number, or a character corresponding to a node label; for \code{ancestors} and \code{descendants}, this may be a vector of multiple node numbers or names} \item{type}{(\code{ancestors}) specify whether to return just direct ancestor ("parent"), all ancestor nodes ("all"), or all ancestor nodes including self ("ALL"); (\code{descendants}) specify whether to return just direct descendants ("children"), all extant descendants ("tips"), or all descendant nodes ("all") or all descendant nodes including self ("ALL").} \item{include.self}{whether to include self in list of siblings} } \value{ \describe{ \item{\code{ancestors}}{ return a named vector (or a list of such vectors in the case of multiple input nodes) of the ancestors and descendants of a node} \item{\code{descendants}}{ return a named vector (or a list of such vectors in the case of multiple input nodes) of the ancestors and descendants of a node} \item{\code{ancestor}}{ \code{ancestor} is analogous to \code{ancestors(\dots{}, type="parent")} (i.e. direct ancestor only), but returns a single concatenated vector in the case of multiple input nodes} \item{\code{children}}{is analogous to \code{descendants(\dots{}, type="children")} (i.e. direct descendants only), but is not currently intended to be used with multiple input nodes } \item{\code{siblings}}{ returns sibling nodes (children of the same parent)} } } \description{ Functions for describing relationships among phylogenetic nodes (i.e. internal nodes or tips). } \details{ \code{ancestors} and \code{descendants} can take \code{node} vectors of arbitrary length, returning a list of output vectors if the number of valid input nodes is greater than one. List element names are taken directly from the input node vector. If any supplied nodes are not found in the tree, the behavior currently varies across functions. \itemize{ \item Invalid nodes are automatically omitted by \code{ancestors} and \code{descendants}, with a warning. \item \code{ancestor} will return \code{NA} for any invalid nodes, with a warning. \item Both \code{children} and \code{siblings} will return an empty vector, again with a warning. } } \examples{ data(geospiza) nodeLabels(geospiza) <- LETTERS[1:nNodes(geospiza)] plot(as(geospiza, "phylo4"), show.node.label=TRUE) ancestor(geospiza, "E") children(geospiza, "C") descendants(geospiza, "D", type="tips") descendants(geospiza, "D", type="all") ancestors(geospiza, "D") MRCA(geospiza, "conirostris", "difficilis", "fuliginosa") MRCA(geospiza, "olivacea", "conirostris") ## shortest path between 2 nodes shortestPath(geospiza, "fortis", "fuliginosa") shortestPath(geospiza, "F", "L") ## branch length from a tip to the root sumEdgeLength(geospiza, ancestors(geospiza, "fortis", type="ALL")) } \seealso{ \code{\link[ape]{mrca}}, in the ape package, gives a list of all subtrees } phylobase/man/phylo4-class.Rd0000644000176200001440000000137414553646170015644 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/phylo4-class.R \docType{class} \name{phylo4-class} \alias{phylo4-class} \title{The phylo4 class} \description{ Classes for phylogenetic trees } \section{Objects from the Class}{ Phylogenetic tree objects can be created by calls to the \code{\link{phylo4}} constructor function. Translation functions from other phylogenetic packages are also available. See \code{\link{coerce-methods}}. } \seealso{ The \code{\link{phylo4-methods}} constructor, the \code{\link{checkPhylo4}} function to check the validity of \code{phylo4} objects. See also the \code{\link{phylo4d-methods}} constructor and the \linkS4class{phylo4d} class. } \author{ Ben Bolker, Thibaut Jombart } \keyword{classes} phylobase/man/readNexus.Rd0000644000176200001440000001474714553646170015270 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/readNCL.R \docType{methods} \name{Import Nexus and Newick files} \alias{Import Nexus and Newick files} \alias{readNCL} \alias{readNexus} \alias{readNewick} \title{Create a \code{phylo4}, \code{phylo4d} or \code{data.frame} object from a NEXUS or a Newick file} \usage{ readNCL( file, simplify = FALSE, type = c("all", "tree", "data"), spacesAsUnderscores = TRUE, char.all = FALSE, polymorphic.convert = TRUE, levels.uniform = FALSE, quiet = TRUE, check.node.labels = c("keep", "drop", "asdata"), return.labels = TRUE, file.format = c("nexus", "newick"), check.names = TRUE, convert.edge.length = FALSE, ... ) readNexus( file, simplify = FALSE, type = c("all", "tree", "data"), char.all = FALSE, polymorphic.convert = TRUE, levels.uniform = FALSE, quiet = TRUE, check.node.labels = c("keep", "drop", "asdata"), return.labels = TRUE, check.names = TRUE, convert.edge.length = FALSE, ... ) readNewick( file, simplify = FALSE, quiet = TRUE, check.node.labels = c("keep", "drop", "asdata"), convert.edge.length = FALSE, ... ) } \arguments{ \item{file}{a NEXUS file for \code{readNexus} or a file that contains Newick formatted trees for \code{readNewick}.} \item{simplify}{If TRUE, if there are multiple trees in the file, only the first one is returned; otherwise a list of \code{phylo4(d)} objects is returned if the file contains multiple trees.} \item{type}{Determines which type of objects to return, if present in the file (see Details).} \item{spacesAsUnderscores}{In the NEXUS file format white spaces are not allowed in taxa labels and are represented by underscores. Therefore, NCL converts underscores found in taxa labels in the NEXUS file into white spaces (e.g. \code{species_1} will become \code{"species 1"}. If you want to preserve the underscores, set as TRUE, the default).} \item{char.all}{If \code{TRUE}, returns all characters, even those excluded in the NEXUS file} \item{polymorphic.convert}{If \code{TRUE}, converts polymorphic characters to missing data} \item{levels.uniform}{If \code{TRUE}, uses the same levels for all characters} \item{quiet}{If \code{FALSE} the output of the NCL interface is printed. This is mainly for debugging purposes. This option can considerably slow down the process if the tree is big or there are many trees in the file.} \item{check.node.labels}{Determines how the node labels in the NEXUS or Newick files should be treated in the phylo4 object, see Details for more information.} \item{return.labels}{Determines whether state names (if \code{TRUE}) or state codes should be returned.} \item{file.format}{character indicating the format of the specified file (either \dQuote{\code{newick}} or \dQuote{\code{nexus}}). It's more convenient to just use \code{readNexus} or \code{readNewick}.} \item{check.names}{logical. If \sQuote{TRUE} then the names of the characters from the NEXUS file are checked to ensure that they are syntactically valid variable names and are not duplicated. If necessary they are adjusted using \sQuote{make.names}.} \item{convert.edge.length}{logical. If \code{TRUE} negative edge lengths are replaced with 0. At this time \code{phylobase} does not accept objects with negative branch lengths, this workaround allows to import trees with negative branch lengths.} \item{\dots}{Additional arguments to be passed to phylo4 or phylo4d constructor (see Details)} } \value{ Depending on the value of \code{type} and the contents of the file, one of: a \code{data.frame}, a \linkS4class{phylo4} object, a \linkS4class{phylo4d} object or \code{NULL}. If several trees are included in the NEXUS file and the option \code{simplify=FALSE} a list of \linkS4class{phylo4} or \linkS4class{phylo4d} objects is returned. } \description{ \code{readNexus} reads a NEXUS file and outputs a \code{phylo4}, \code{phylo4d} or \code{data.frame} object. } \details{ \code{readNewick} reads a Newick file and outputs a \code{phylo4} or \code{phylo4d} object. \code{readNexus} is used internally by both \code{readNexus} and \code{readNewick} to extract data held in a tree files, specifically in NEXUS files from DATA, CHARACTER or TREES blocks. The \code{type} argument specifies which of these is returned: \describe{ \item{data}{will only return a \code{data.frame} of the contents of all DATA and CHARACTER blocks.} \item{tree}{will only return a \code{phylo4} object of the contents of the TREES block.} \item{all}{if only data or a tree are present in the file, this option will act as the options above, returning either a \code{data.frame} or a \code{phylo4} object respectively. If both are present then a \code{phylo4d} object is returned containing both.} } The function returns \code{NULL} if the \code{type} of data requested is not present in the file, or if neither data nor tree blocks are present. Depending on the context \code{readNexus} will call either the \code{phylo4} or \code{phylo4d} constructor. The \code{phylo4d} constructor will be used with \code{type="all"}, or if the option \code{check.node.labels="asdata"} is invoked. \code{readNewick} imports Newick formatted tree files and will return a \code{phylo4} or a \code{phylo4d} object if the option \code{check.node.labels="asdata"} is invoked. For both \code{readNexus} and \code{readNewick}, the options for \code{check.node.labels} can take the values: \describe{ \item{keep}{the node labels of the trees will be passed as node labels in the \code{phylo4} object} \item{drop}{the node labels of the trees will be ignored in the \code{phylo4} object} \item{asdata}{the node labels will be passed as data and a \code{phylo4d} object will be returned.} } If you use the option \code{asdata} on a file with no node labels, a warning message is issued, and is thus equivalent to the value \code{drop}. For both \code{readNexus} and \code{readNewick}, additional arguments can be passed to the constructors such as \code{annote}, \code{missing.data} or \code{extra.data}. See the \sQuote{Details} section of \code{\link{phylo4d-methods}} for the complete list of options. } \note{ Underscores in state labels (i.e. trait or taxon names) will be translated to spaces. Unless \code{check.names=FALSE}, trait names will be converted to valid R names (see \code{\link{make.names}}) on input to R, so spaces will be translated to periods. } \seealso{ the \linkS4class{phylo4d} class, the \linkS4class{phylo4} class } \author{ Brian O'Meara, Francois Michonneau, Derrick Zwickl } \keyword{misc} phylobase/man/nodeId-methods.Rd0000644000176200001440000000232414553646170016161 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nodeId-methods.R \docType{methods} \name{nodeId} \alias{nodeId} \alias{nodeId,phylo4-method} \alias{edgeId} \alias{edgeId,phylo4-method} \title{nodeId methods} \usage{ nodeId(x, type = c("all", "tip", "internal", "root")) \S4method{nodeId}{phylo4}(x, type = c("all", "tip", "internal", "root")) edgeId(x, type = c("all", "tip", "internal", "root")) \S4method{edgeId}{phylo4}(x, type = c("all", "tip", "internal", "root")) } \arguments{ \item{x}{a \code{phylo4} or \code{phylo4d} object.} \item{type}{a character vector indicating which subset of the nodes or edges you are interested in.} } \value{ \describe{ \item{nodeId}{an integer vector indicating node numbers} \item{edgeId}{a character vector indicating the edge identity} } } \description{ These functions gives the node (\code{nodeId}) or edge (\code{edgeId}) identity. } \details{ \code{nodeId} returns the node in ascending order, and \code{edgeId} in the same order as the edges are stored in the edge matrix. } \examples{ data(geospiza) identical(nodeId(geospiza, "tip"), 1:nTips(geospiza)) nodeId(geospiza, "internal") edgeId(geospiza, "internal") nodeId(geospiza, "root") } phylobase/man/MRCA.Rd0000644000176200001440000000226514553646170014044 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/MRCA-methods.R \name{MRCA} \alias{MRCA} \alias{MRCA,phylo4-method} \alias{MRCA,phylo-method} \title{MRCA} \usage{ MRCA(phy, ...) \S4method{MRCA}{phylo4}(phy, ...) \S4method{MRCA}{phylo}(phy, ...) } \arguments{ \item{phy}{a phylogenetic tree in phylo4, phylo4d or phylo format.} \item{...}{a vector of nodes} } \value{ the node corresponding to the most recent common ancestor } \description{ Most Recent Common Ancestor (MRCA) of 2 or more nodes. } \details{ Given some nodes (i.e., tips and/or internal), this function returns the node corresponding to the most recent common ancestor. If \code{phy} is a \code{phylo4} or \code{phylo4d} object, the nodes can contain both numeric or character values that will be used by \code{getNode} to retrieve the correct node. However, if \code{phy} is a \code{phylo} object, the nodes must be a numeric vector. With \code{phylo4} and \code{phylo4d} objects, if a single node is provided, it will be returned. } \examples{ data(geospiza) MRCA(geospiza, 1, 5) MRCA(geospiza, "fortis", 11) MRCA(geospiza, 2, 4, "fusca", 3) geo <- as(geospiza, "phylo") MRCA(geo, c(1,5)) } phylobase/man/tip.data.plot.Rd0000644000176200001440000000270114553646170015776 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/treePlot.R \name{tip.data.plot} \alias{tip.data.plot} \title{Plotting trees and associated data} \usage{ tip.data.plot( xxyy, type = c("phylogram", "cladogram", "fan"), show.tip.label = TRUE, show.node.label = FALSE, rot = 0, tip.plot.fun = grid.points, edge.color = "black", node.color = "black", tip.color = "black", edge.width = 1, ... ) } \arguments{ \item{xxyy}{A list created by the \code{\link{phyloXXYY}} function} \item{type}{A character string indicating the shape of plotted tree} \item{show.tip.label}{Logical, indicating whether tip labels should be shown} \item{show.node.label}{Logical, indicating whether node labels should be shown} \item{rot}{Numeric indicating the rotation of the plot in degrees} \item{tip.plot.fun}{A function used to plot the data elements of a \code{phylo4d} object} \item{edge.color}{A vector of colors in the order of \code{edges(phy)}} \item{node.color}{A vector of colors indicating the colors of the node labels} \item{tip.color}{A vector of colors indicating the colors of the tip labels} \item{edge.width}{A vector in the order of \code{edges(phy)} indicating the widths of edge lines} \item{\dots}{Additional parameters passed to \code{tip.plot.fun}} } \value{ creates a plot on the current graphics device. } \description{ Plotting phylogenetic trees and associated data } \author{ Peter Cowan } \keyword{methods} phylobase/man/print-methods.Rd0000644000176200001440000000621014553646170016111 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/print-methods.R \name{print} \alias{print} \alias{print,phylo4-method} \alias{show} \alias{show,phylo4-method} \alias{names} \alias{names,phylo4-method} \alias{head} \alias{head,phylo4-method} \alias{tail} \alias{tail,phylo4-method} \title{print a phylogeny} \usage{ print(x, ...) \S4method{print}{phylo4}(x, edgeOrder = c("pretty", "real"), printall = TRUE) show(object) \S4method{show}{phylo4}(object) names(x) \S4method{names}{phylo4}(x) head(x, ...) \S4method{head}{phylo4}(x, n = 20) tail(x, ...) \S4method{tail}{phylo4}(x, n = 20) } \arguments{ \item{x}{a \code{phylo4} tree or \code{phylo4d} tree+data object} \item{\dots}{optional additional arguments (not in use)} \item{edgeOrder}{in the data frame returned, the option 'pretty' returns the internal nodes followed by the tips, the option 'real' returns the nodes in the order they are stored in the edge matrix.} \item{printall}{default prints entire tree. printall=FALSE returns the first 6 rows} \item{object}{a \code{phylo4} or \code{phylo4d} object} \item{n}{for head() and tail(), the number of lines to print} } \value{ A data.frame with a row for each node (descendant), sorted as follows: root first, then other internal nodes, and finally tips.\cr The returned data.frame has the following columns:\cr \item{label}{Label for the taxon at the node (usually species name).} \item{node}{Node number, i.e. the number identifying the node in edge matrix.} \item{ancestor}{Node number of the node's ancestor.} \item{branch.length}{The branch length connecting the node to its ancestor (NAs if missing).} \item{node.type}{"root", "internal", or "tip". (internally generated)} \item{data}{phenotypic data associated with the nodes, with separate columns for each variable.} } \description{ Prints a phylo4 or phylo4d object in data.frame format with user-friendly column names } \details{ This is a user-friendly version of the tree representation, useful for checking that objects were read in completely and translated correctly. The phylogenetic tree is represented as a list of numbered nodes, linked in a particular way through time (or rates of evolutionary change). The topology is given by the pattern of links from each node to its ancestor. Also given are the taxon names, node type (root/internal/tip) and phenotypic data (if any) associated with the node, and the branch length from the node to its ancestor. A list of nodes (descendants) and ancestors is minimally required for a phylo4 object. } \note{ This is the default show() method for phylo4, phylo4d. It prints the user-supplied information for building a phylo4 object. For a full description of the phylo4 S4 object and slots, see \code{\link{phylo4}}. } \examples{ tree.phylo <- ape::read.tree(text="((a,b),c);") tree <- as(tree.phylo, "phylo4") ##plot(tree,show.node=TRUE) ## plotting broken with empty node labels: FIXME tip.data <- data.frame(size=c(1,2,3), row.names=c("a", "b", "c")) treedata <- phylo4d(tree, tip.data) plot(treedata) print(treedata) } \author{ Marguerite Butler, Thibaut Jombart \email{jombart@biomserv.univ-lyon1.fr}, Steve Kembel } \keyword{methods} phylobase/man/formatData.Rd0000644000176200001440000000650114553646170015401 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/formatData.R \name{formatData} \alias{formatData} \title{Format data for use in phylo4d objects} \usage{ formatData( phy, dt, type = c("tip", "internal", "all"), match.data = TRUE, rownamesAsLabels = FALSE, label.type = c("rownames", "column"), label.column = 1, missing.data = c("fail", "warn", "OK"), extra.data = c("warn", "OK", "fail"), keep.all = TRUE ) } \arguments{ \item{phy}{a valid \code{phylo4} object} \item{dt}{a data frame, matrix, vector, or factor} \item{type}{type of data to attach} \item{match.data}{(logical) should the rownames of the data frame be used to be matched against tip and internal node identifiers? See details.} \item{rownamesAsLabels}{(logical), should the row names of the data provided be matched only to labels (TRUE), or should any number-like row names be matched to node numbers (FALSE and default)} \item{label.type}{character, \code{rownames} or \code{column}: should the labels be taken from the row names of \code{dt} or from the \code{label.column} column of \code{dt}?} \item{label.column}{if \code{label.type=="column"}, column specifier (number or name) of the column containing tip labels} \item{missing.data}{action to take if there are missing data or if there are data labels that don't match} \item{extra.data}{action to take if there are extra data or if there are labels that don't match} \item{keep.all}{(logical), should the returned data have rows for all nodes (with NA values for internal rows when type='tip', and vice versa) (TRUE and default) or only rows corresponding to the type argument} } \value{ \code{formatData} returns a data frame having node numbers as row names. The data frame is also formatted to have the correct dimension given the \code{phylo4} object provided. } \description{ Associates data with tree nodes and applies consistent formatting rules. } \details{ \code{formatData} is an internal function that should not be called directly by the user. It is used to format data provided by the user before associating it with a tree, and is called internally by the \code{phylo4d}, \code{tdata}, and \code{addData} methods. However, users may pass additional arguments to these methods in order to control how the data are matched to nodes. Rules for matching rows of data to tree nodes are determined jointly by the \code{match.data} and \code{rownamesAsLabels} arguments. If \code{match.data} is TRUE, data frame rows will be matched exclusively against tip and node labels if \code{rownamesAsLabels} is also TRUE, whereas any all-digit row names will be matched against tip and node numbers if \code{rownamesAsLabels} is FALSE (the default). If \code{match.data} is FALSE, \code{rownamesAsLabels} has no effect, and row matching is purely positional with respect to the order returned by \code{nodeId(phy, type)}. \code{formatData} (1) converts labels provided in the data into node numbers, (2) makes sure that the data are appropriately matched against tip and/or internal nodes, (3) checks for differences between data and tree, (4) creates a data frame with the correct dimensions given a tree. } \seealso{ the \code{\link{phylo4d-methods}} constructor, the \linkS4class{phylo4d} class. See \code{\link{coerce-methods}} for translation functions. } \author{ Francois Michonneau } \keyword{misc} phylobase/man/edgeLength-methods.Rd0000644000176200001440000001113314553646170017023 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/edgeLength-methods.R \docType{methods} \name{hasEdgeLength} \alias{hasEdgeLength} \alias{hasEdgeLength,phylo4-method} \alias{edgeLength} \alias{edgeLength,phylo4-method} \alias{edgeLength<-} \alias{edgeLength<-,phylo4-method} \alias{edgeLength<-,phylo4,ANY-method} \alias{depthTips} \alias{depthTips,phylo4-method} \alias{depthTips,phylo4-methods} \alias{nodeDepth} \alias{nodeDepth,phylo4-method} \alias{nodeHeight} \alias{nodeHeight,phylo4-method} \alias{sumEdgeLength} \alias{sumEdgeLength,phylo4-method} \alias{isUltrametric} \alias{isUltrametric,phylo4-method} \title{edgeLength methods} \usage{ hasEdgeLength(x) \S4method{hasEdgeLength}{phylo4}(x) edgeLength(x, ...) \S4method{edgeLength}{phylo4}(x, node) edgeLength(x, use.names = TRUE, ...) <- value \S4method{edgeLength}{phylo4}(x, use.names = TRUE, ...) <- value depthTips(x) \S4method{depthTips}{phylo4}(x) nodeDepth(x, node) \S4method{nodeDepth}{phylo4}(x, node) nodeHeight(x, node, from) \S4method{nodeHeight}{phylo4}(x, node, from = c("root", "all_tip", "min_tip", "max_tip")) sumEdgeLength(x, node) \S4method{sumEdgeLength}{phylo4}(x, node) isUltrametric(x, tol = .Machine$double.eps^0.5) \S4method{isUltrametric}{phylo4}(x, tol = .Machine$double.eps^0.5) } \arguments{ \item{x}{a \code{phylo4} or \code{phylo4d} object.} \item{\dots}{optional arguments (none used at present).} \item{node}{optional numeric or character vector indicating the nodes for which edge} \item{use.names}{should the the name attributes of \code{value} be used to match the length to a given edge.} \item{value}{a numeric vector indicating the new values for the edge lengths} \item{from}{The point of reference for calculating the height of the node. \code{root} calculates the distance between the root of the tree and the node. \code{all_tip} return the distance between the node and all the tips descending from it. \code{min_tip} the distance between the node and its closest tip. \code{max_tip} the distance between the node and its farther tip. \code{min_tip} and \code{max_tip} will be identical if the tree is ultrametric. If more than one tip is equidistant from the node, the tip with the lowest node id will be returned.} \item{tol}{the tolerance to decide whether all the tips have the same depth to test if the tree is ultrametric. Default is \code{.Machine$double.eps^0.5}.} } \value{ \describe{ \item{hasEdgeLength}{whether or not the object has edge lengths (logical)} \item{edgeLength}{a named vector of the edge length for the object} \item{isUltrametric}{whether or not the tree is ultrametric (all the tips are have the same depth (distance from the root) (logical)} \item{sumEdgeLength}{the sum of the edge lengths for a set of nodes (intended to be used with \code{ancestors} or \code{descendants})} \item{nodeHeight}{the distance between a node and the root or the tips. The format of the result will depend on the options and the number of nodes provided, either a vector or a list.} \item{nodeDepth}{Deprecated, now replaced by \code{nodeHeight}. A named vector indicating the \dQuote{depth} (the distance between the root and a given node).} \item{depthTip}{Deprecated, now replaced by \code{nodeHeight}.} } } \description{ These functions give information about and allow replacement of edge lengths. } \details{ The \code{edgeLength} function returns the edge length in the same order as the edges in the matrix. } \examples{ data(geospiza) hasEdgeLength(geospiza) # TRUE topoGeo <- geospiza edgeLength(topoGeo) <- NULL hasEdgeLength(topoGeo) # FALSE edgeLength(geospiza)[2] # use the position in vector edgeLength(geospiza)["16-17"] # or the name of the edge edgeLength(geospiza, 17) # or the descendant node of the edge ## The same methods can be used to update an edge length edgeLength(geospiza)[2] <- 0.33 edgeLength(geospiza)["16-17"] <- 0.34 edgeLength(geospiza, 17) <- 0.35 ## Test if tree is ultrametric isUltrametric(geospiza) # TRUE ## indeed all tips are at the same distance from the root nodeHeight(geospiza, nodeId(geospiza, "tip"), from="root") ## compare distances from tips of two MRCA nodeHeight(geospiza, MRCA(geospiza, c("pallida", "psittacula")), from="min_tip") nodeHeight(geospiza, MRCA(geospiza, c("fortis", "difficilis")), from="min_tip") ## or the same but from the root nodeHeight(geospiza, MRCA(geospiza, c("pallida", "psittacula")), from="root") nodeHeight(geospiza, MRCA(geospiza, c("fortis", "difficilis")), from="root") } \seealso{ \code{ancestors}, \code{descendants}, \code{.Machine} for more information about tolerance. } phylobase/man/tdata-methods.Rd0000644000176200001440000000655714553646170016070 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tdata-methods.R \name{tdata} \alias{tdata} \alias{tdata,phylo4d-method} \alias{tdata<-} \alias{tdata<-,phylo4d-method} \alias{tdata<-,phylo4d,ANY-method} \alias{tipData} \alias{tipData-method} \alias{tipData,phylo4d-method} \alias{tipData<-} \alias{tipData<-,phylo4d-method} \alias{tipData<-,phylo4d,ANY-method} \alias{nodeData} \alias{nodeData-method} \alias{nodeData,phylo4d-method} \alias{nodeData<-} \alias{nodeData<-,phylo4d-method} \alias{nodeData<-,phylo4d,ANY-method} \title{Retrieving or updating tip and node data in phylo4d objects} \usage{ tdata(x, ...) \S4method{tdata}{phylo4d}( x, type = c("all", "tip", "internal"), label.type = c("row.names", "column"), empty.columns = TRUE ) tdata(x, ...) <- value \S4method{tdata}{phylo4d}( x, type = c("all", "tip", "internal"), merge.data = TRUE, clear.all = FALSE, ... ) <- value tipData(x, ...) \S4method{tipData}{phylo4d}(x, ...) tipData(x, ...) <- value \S4method{tipData}{phylo4d}(x, ...) <- value nodeData(x, ...) \S4method{nodeData}{phylo4d}(x, ...) nodeData(x, ...) <- value \S4method{nodeData}{phylo4d}(x, ...) <- value } \arguments{ \item{x}{A \code{phylo4d} object} \item{\dots}{For the \code{tipData} and \code{nodeData} accessors, further arguments to be used by \code{tdata}. For the replacement forms, further arguments to be used to control matching between tree and data (see Details section of \code{\link{phylo4d-methods}}).} \item{type}{The type of data to retrieve or update: \dQuote{\code{all}} (default) for data associated with both tip and internal nodes, \dQuote{\code{tip}} for data associated with tips only, \dQuote{\code{internal}} for data associated with internal nodes only.} \item{label.type}{How should the tip/node labels from the tree be returned? \dQuote{\code{row.names}} returns them as row names of the data frame, \dQuote{\code{column}} returns them in the first column of the data frame. This options is useful in the case of missing (\code{NA}) or non-unique labels.} \item{empty.columns}{Should columns filled with \code{NA} be returned?} \item{value}{a data frame (or object to be coerced to one) to replace the values associated with the nodes specified by the argument \code{type}} \item{merge.data}{if tip or internal node data are provided and data already exists for the other type, this determines whether columns with common names will be merged together (default TRUE). If FALSE, columns with common names will be preserved separately, with \dQuote{.tip} and \dQuote{.node} appended to the names. This argument has no effect if tip and node data have no column names in common, or if type=\dQuote{all}.} \item{clear.all}{If only tip or internal node data are to be replaced, should data of the other type be dropped?} } \value{ \code{tdata} returns a data frame } \description{ Methods to retrieve or update tip, node or all data associated with a phylogenetic tree stored as a phylo4d object } \section{Methods}{ \describe{ \item{tdata}{\code{signature(object="phylo4d")}: retrieve or update data associated with a tree in a \code{phylo4d} object} } } \examples{ data(geospiza) tdata(geospiza) tipData(geospiza) <- 1:nTips(geospiza) tdata(geospiza) } \seealso{ \code{\link{phylo4d-methods}}, \code{\linkS4class{phylo4d}} } \author{ Ben Bolker, Thibaut Jombart, Francois Michonneau } \keyword{methods} phylobase/DESCRIPTION0000644000176200001440000000344514556040263013761 0ustar liggesusersPackage: phylobase Type: Package Title: Base Package for Phylogenetic Structures and Comparative Data Version: 0.8.12 Imports: ade4, ape (>= 3.0), Rcpp (>= 0.11.0), rncl (>= 0.6.0), grid, methods, stats, RNeXML LinkingTo: Rcpp Suggests: MASS, testthat (>= 0.8.1), knitr, rmarkdown Author: R Hackathon et al. (alphabetically: Ben Bolker, Marguerite Butler, Peter Cowan, Damien de Vienne, Dirk Eddelbuettel, Mark Holder, Thibaut Jombart, Steve Kembel, Francois Michonneau, David Orme, Brian O'Meara, Emmanuel Paradis, Jim Regetz, Derrick Zwickl) Maintainer: Francois Michonneau Description: Provides a base S4 class for comparative methods, incorporating one or more trees and trait data. License: GPL (>= 2) URL: https://github.com/fmichonneau/phylobase BugReports: https://github.com/fmichonneau/phylobase/issues LazyData: true Collate: 'oldclasses-class.R' 'internal-constructors.R' 'phylo4-methods.R' 'RcppExports.R' 'checkdata.R' 'phylo4-class.R' 'getNode-methods.R' 'formatData.R' 'phylo4d-class.R' 'phylo4d-methods.R' 'MRCA-methods.R' 'addData-methods.R' 'ancestors.R' 'phylo4-accessors.R' 'root-methods.R' 'nodeId-methods.R' 'edgeLength-methods.R' 'setAs-methods.R' 'extractTree.R' 'labels-methods.R' 'multiphylo4-class.R' 'pdata.R' 'phylo4d-accessors.R' 'phylobase-package.R' 'phylobase.options.R' 'phylomats-class.R' 'print-methods.R' 'readNCL.R' 'reorder-methods.R' 'shortestPath-methods.R' 'subset-methods.R' 'summary-methods.R' 'tbind.R' 'tdata-methods.R' 'treePlot.R' 'treestruc.R' 'zzz.R' VignetteBuilder: knitr RoxygenNote: 7.3.1 Encoding: UTF-8 NeedsCompilation: yes Packaged: 2024-01-29 16:12:26 UTC; francois Repository: CRAN Date/Publication: 2024-01-30 00:20:03 UTC phylobase/build/0000755000176200001440000000000014555747152013356 5ustar liggesusersphylobase/build/vignette.rds0000644000176200001440000000033014555747152015711 0ustar liggesusersb```b`afd`b2 1# '-ȨOJ,N MA HU+0QHI,.N-VHKQM-O)FS͇0*$7Ma0",LHyFm]?4-ީE0=(jؠjX2sRad9.nP&c0Gq?gQ~ 6@QpH+%$Q/nJZphylobase/tests/0000755000176200001440000000000014553646170013415 5ustar liggesusersphylobase/tests/phylo4dtests.R0000644000176200001440000000170014553646170016204 0ustar liggesuserslibrary(phylobase) library(ape) tree.phylo <- read.tree(text="(((A,B)C,D),E);") #only one node is labelled tree <- as(tree.phylo, "phylo4") tree.phylo2 <- read.tree(text="(((A,B)C,D)F,E)G;") # all nodes labelled tree2 <- as(tree.phylo2, "phylo4") tip.data <- data.frame(size=c(1, 2, 3, 4)) rownames(tip.data) <- c("A", "B", "E", "D") treed <- phylo4d(tree, tip.data) dat2 <- data.frame(size=c(0,1,2), row.names=c("G", "F", "C")) try(phylo4d(tree, node.data=dat2), silent = TRUE) # error, cannot match data because no node labels on tree phylo4d(tree2, node.data=dat2) -> treed2 # OK tree labelled; has node data, no tip data plot(treed2) # works with a warning about no tip data to plot tipData(treed2, empty.columns=FALSE) #returns empty 4-row data.frame phylo4d(tree2, tip.data=tip.data, node.data=dat2) -> treed3 #node+tip data plot(treed3) # works tipData(treed3) #works, but returns tips only tdata(treed3, "all") print(tree) print(treed) phylobase/tests/testprune.R0000644000176200001440000000071414553646170015573 0ustar liggesuserslibrary(phylobase) library(ape) set.seed(1) r1 <- rcoal(5) ## trace("phylo4d", browser, signature = "phylo") ## untrace("phylo4d", signature = "phylo") tipdat <- data.frame(a=1:5,row.names=r1$tip.label) p1 <- phylo4d(r1,tip.data=tipdat,node.data=data.frame(a=6:9), match.data=FALSE) p2 <- prune(p1,1) summary(p2) ## from picante `phylo2phylog` <- function(phy, ...) { newick2phylog(write.tree(phy, multi.line = FALSE),...) } plot.phylo(as(p2,"phylo")) phylobase/tests/plottest.R0000644000176200001440000000276114553646170015424 0ustar liggesuserslibrary(phylobase) library(ape) data(geospiza) g1 <- as(geospiza,"phylo4") g2 <- geospiza par(mfrow=c(1,2)) plot(g1, show.node.label=TRUE) ## be careful with this: works if par("fin")=c(5.56,6.77) ## fails if par("fin")=c(4.87,6.77) ##try(plot(g2,show.node.label=TRUE),silent=TRUE) ## Here, R was complaining about a lack of room to plot data ## so nothing abnormal. -- TJ plot(g2, show.node.label=TRUE) ## commented out since phylog objects are deprecated anyway ## g2B <- as(extractTree(g2), "phylog") ## Note the numbering differences! ## round trip g2C <- as(read.tree(text=write.tree(as(g1, "phylo"))), "phylo4") ## comes back in same order try(plot(g1, show.node.label=TRUE)) try(plot(g2C, show.node.label=TRUE)) g3 = subset(g2, tips.exclude=c("fuliginosa", "fortis", "magnirostris", "conirostris", "scandens")) plot(extractTree(g3)) ## phylo4 plot(g3) ## Playing with new ways of plotting if (FALSE) { if(require(MASS)){ dist1 <- cophenetic.phylo(as(g2, "phylo")) mdspos <- isoMDS(dist1)$points par(mfrow=c(2, 2)) plot(g1) ## plot(mdspos,type="n") ## text(mdspos[,1],mdspos[,2],abbreviate(rownames(mdspos))) ## cmdpos <- cmdscale(dist1) ## plot(cmdpos,type="n") ## text(cmdpos[,1],cmdpos[,2],abbreviate(rownames(mdspos))) } ## never mind, I don't know how to construct a useful ## 2D color space anyway ... } treePlot(g2,plot.at.tip=TRUE,tip.plot.fun= function(x,...) { grid::grid.points(seq(along=x),x)}) phylobase/tests/phylosubtest.R0000644000176200001440000000070214553646170016304 0ustar liggesuserslibrary(phylobase) library(ape) data(geospiza) gtree <- extractTree(geospiza) stopifnot(identical(gtree,prune(gtree,character(0)))) stopifnot(identical(tdata(subset(geospiza)), tdata(subset(geospiza, tipLabels(geospiza))))) tr <- read.tree(text="(((spA:0.2,(spB:0.1,spC:0.1):0.15):0.5,spD:0.7):0.2,spE:1):0.4;") phyd <- as(tr, "phylo4d") tipData(phyd) <- 1:5 stopifnot(identical(phyd@data,subset(phyd,tipLabels(phyd))@data)) phylobase/tests/roundtrip.R0000644000176200001440000000223114553646170015564 0ustar liggesuserslibrary(phylobase) library(ape) ## set.seed(1) ## t0A <- rcoal(5) t0 <- read.tree(text="((t4:0.3210275554,(t2:0.2724586465,t3:0.2724586465):0.0485689089):0.1397952619,(t5:0.07551818331,t1:0.07551818331):0.385304634);") ## hack around variability in ape: ## read.tree() and rcoal() produce sets of ## elements in different orders t0 <- unclass(t0)[c("edge","edge.length","tip.label","Nnode")] class(t0) <- "phylo" ## phylo -> phylo4 -> phylo t1 <- as(t0,"phylo4") t5 <- as(t1,"phylo") stopifnot(identical(t0,t5)) ## phylo4 -> phylo4vcov -> phylo4 -> phylo t2<-as(t1,"phylo4vcov") t3<-as(t2,"phylo4") t4<-as(t3,"phylo") stopifnot(identical(t4$edge,t0$edge) && identical(t4$tip.label,t0$tip.label) && identical(t4$Nnode,t0$Nnode) && max(abs(t4$edge.length-t0$edge.length))<1e-10) ## UNROOTED t6 <- ape::unroot(t0) ## hack around ape conversion issues: ## unroot() converts integer to double storage.mode(t6$edge) <- "integer" storage.mode(t6$Nnode) <- "integer" t7 <- as(as(t6,"phylo4"),"phylo") stopifnot(identical(t6,t7)) ## EXPLICIT ROOT EDGE t8 <- t0 t8$root.edge <- 0.5 t9 <- as(as(t8,"phylo4"),"phylo") stopifnot(identical(t8,t9)) phylobase/tests/test-all.R0000644000176200001440000000073614553646170015273 0ustar liggesusers## This script is only run during R CMD check, so we can set an environment ## variable that will only run tests during R CMD check (or `devtools::check()`) ## and not during `devtools::test()`. ## Thus in the tests, we can request the NEXUS files that are stored in the ## `inst/` folder, but during the checks, we test the files that have been ## installed (using the `system.file()` function). library(testthat) Sys.setenv("R_CMD_CHECK" = "true") test_check("phylobase") phylobase/tests/testthat/0000755000176200001440000000000014553646170015255 5ustar liggesusersphylobase/tests/testthat/test.treestruc.R0000644000176200001440000000124414553646170020377 0ustar liggesusers# # --- Test treestruc.R functions --- # context("tree structures") test_that("hasPoly", { # construct simple polytomy owls <- ape::read.tree(text = "((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3);") owls$edge <- matrix(c(4,4,4,1,2,3), ncol=2) owls$Nnode <- 1 owls$edge.length <- owls$edge.length[-4] tr <- as(owls, "phylo4") expect_true(hasPoly(tr)) # test against empty tree expect_true(!hasPoly(new("phylo4"))) }) test_that("hasSingle", { # test against empty tree expect_true(!hasSingle(new("phylo4"))) }) test_that("hasRetic", { # test against empty tree expect_true(!hasRetic(new("phylo4"))) }) phylobase/tests/testthat/test.formatData.R0000644000176200001440000005315414553646170020450 0ustar liggesusers# # --- Test formatData.R --- # # create phylo4 object with a full complement of valid slots ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9)) descendant <- as.integer(c(7,1,2,8,3,6,9,4,5)) edge <- cbind(ancestor, descendant) nid.tip <- 1:5 nid.int <- 6:9 nid.all <- c(nid.tip, nid.int) lab.tip <- paste("t", nid.tip, sep="") lab.int <- paste("n", nid.int, sep="") lab.all <- c(lab.tip, lab.int) elen <- descendant/10 elab <- paste("e", ancestor, descendant, sep="-") phy <- phylo4(x=edge, tip.label=lab.tip, node.label=lab.int, edge.length=elen, edge.label=elab) # create altered version such that each slot is out of order with # respect to all others; methods should be able to handle this phy.alt <- phy phy.alt@label <- rev(phy@label) phy.alt@edge <- phy@edge[c(6:9, 1:5), ] phy.alt@edge.length <- phy@edge.length[c(7:9, 1:6)] phy.alt@edge.label <- phy@edge.label[c(8:9, 1:7)] # create data to add to phylo4 to create phylo4d, but with data rows out # of order set.seed(1) nid.tip.r <- sample(nid.tip) nid.int.r <- sample(nid.int) nid.all.r <- sample(c(nid.tip, nid.int)) allDt <- data.frame(a = letters[nid.all.r], b = 10 * nid.all.r, stringsAsFators = TRUE) tipDt <- data.frame(c=letters[nid.tip.r], d=10*nid.tip.r, stringsAsFators = TRUE) nodDt <- data.frame(c=letters[nid.int.r], e=10*nid.int.r, stringsAsFators = TRUE) ## set row.names as numeric node IDs (may be changed in tests below) row.names(allDt) <- nid.all.r row.names(tipDt) <- nid.tip.r row.names(nodDt) <- nid.int.r #----------------------------------------------------------------------- context("test formatData") ## function(phy, dt, type=c("tip", "internal", "all"), ## match.data=TRUE, rownamesAsLabels=FALSE, ## label.type=c("rownames", "column"), label.column=1, ## missing.data=c("fail", "warn", "OK"), ## extra.data=c("warn", "OK", "fail"), keep.all=TRUE test_that("works with data.frame", { ## vector data coerced to data.frame (colname dt) expect_equal(phylobase:::formatData(phy.alt, 1:5), phylobase:::formatData(phy.alt, data.frame(dt=1:5))) }) test_that("works with lists of vector", { ## list of vector data coerced to data.frame (colnames as given) expect_equal(phylobase:::formatData(phy.alt, list(a=1:5, b=6:10)), phylobase:::formatData(phy.alt, data.frame(a=1:5, b=6:10))) }) test_that("works factors", { ## factor data coerced to data.frame (colname dt) expect_equal(phylobase:::formatData(phy.alt, factor(letters[1:5])), phylobase:::formatData(phy.alt, data.frame(dt=letters[1:5], stringsAsFactors = TRUE))) }) test_that("works with data.frame and 2 columns", { ## matrix data coerced to data.frame (colnames V1, V2) expect_equal(phylobase:::formatData(phy.alt, matrix(1:10, ncol=2)), phylobase:::formatData(phy.alt, data.frame(V1=1:5, V2=6:10))) }) test_that("works with data.frame colname as given", { ## matrix data coerced to data.frame (colname as given) expect_equal(phylobase:::formatData(phy.alt, matrix(1:10, ncol=2, dimnames=list(NULL, c("a", "b")))), phylobase:::formatData(phy.alt, data.frame(a=1:5, b=6:10))) }) test_that("fails with non-supported objects (i.e. a phylo4)", { ## error if dt is, say, a phylo4 object expect_error(phylobase:::formatData(phy.alt, phy.alt)) }) test_that("fails with column number is out of range", { ## error if column number is out of range expect_error(phylobase:::formatData(phy.alt, data.frame(a=1:5, lab=rev(nid.tip)), type="tip", match.data=FALSE, label.type="column", label.column=3)) }) test_that("fails with column name is wrong", { ## error if column name is wrong expect_error(phylobase:::formatData(phy.alt, data.frame(a=1:5, lab=rev(nid.tip)), type="tip", match.data=FALSE, label.type="column", label.column="foo")) }) ## ## matching options ## test_that("matching options work as expected", { ## don't match (purely positional) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:5, row.names=rev(nid.tip)), type="tip", match.data=FALSE), data.frame(a=c(1:5, rep(NA, 4)), row.names=nid.all)) ## match on rownames (node numbers) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:5, row.names=rev(nid.tip)), type="tip", match.data=TRUE), data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all)) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:5, row.names=rev(nid.tip)), type="tip"), data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all)) ## match on rownames (labels) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:5, row.names=rev(lab.tip)), type="tip", match.data=TRUE), data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all)) ## match on rownames (mixed node numbers and labels) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:5, row.names=c(rev(lab.tip)[1:3], rev(nid.tip)[4:5])), type="tip", match.data=TRUE), data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all)) ## but fails if rownamesAsLabels is TRUE expect_error(phylobase:::formatData(phy.alt, data.frame(a=1:5, row.names=c(rev(lab.tip)[1:3], rev(nid.tip)[4:5])), type="tip", match.data=TRUE, rownamesAsLabels=TRUE)) }) ## ## label.type="column" and label.column=2 ## test_that("label.type=column works", { ## should ignore label (purely positional) and retain a label col expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:5, lab=rev(nid.tip)), type="tip", match.data=FALSE, label.type="column", label.column=2), data.frame(a=c(1:5, rep(NA, 4)), lab=c(rev(nid.tip), rep(NA, 4)), row.names=nid.all)) ## match on label column (node numbers) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:5, lab=rev(nid.tip)), type="tip", match.data=TRUE, label.type="column", label.column=2), data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all)) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:5, lab=rev(nid.tip)), type="tip", label.type="column", label.column=2), data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all)) ## match on label column (labels) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:5, lab=rev(lab.tip)), type="tip", match.data=TRUE, label.type="column", label.column=2), data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all)) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:5, lab=rev(lab.tip)), type="tip", match.data=TRUE, label.type="column", label.column="lab"), data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all)) ## match on label column (mixed node numbers and labels) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:5, lab=c(rev(lab.tip)[1:3], rev(nid.tip)[4:5])), type="tip", match.data=TRUE, label.type="column", label.column=2), data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all)) ## but fails if rownamesAsLabels is TRUE expect_error(phylobase:::formatData(phy.alt, data.frame(a=1:5, lab=c(rev(lab.tip)[1:3], rev(nid.tip)[4:5])), type="tip", match.data=TRUE, rownamesAsLabels=TRUE, label.type="column", label.column=2)) ## try to match internal nodes when type='tips' expect_error(phylobase:::formatData(phy.alt, data.frame(a=1:5, row.names=4:8), type="tip")) ## and vice versa expect_error(phylobase:::formatData(phy.alt, data.frame(a=6:9, row.names=1:4), type="internal")) }) ## ## missing.data ## test_that("behaves as expected with missing data", { ## force error conditions expect_error(phylobase:::formatData(phy.alt, data.frame(a=1:3), type="tip")) expect_error(phylobase:::formatData(phy.alt, data.frame(a=1:3), type="tip", missing.data="fail")) expect_warning(phylobase:::formatData(phy.alt, data.frame(a=1:3), type="tip", missing.data="warn")) ## missing data with matching expect_equal(phylobase:::formatData(phy.alt, data.frame(a=rev(nid.tip)[-1], row.names=rev(nid.tip)[-1]), type="tip", missing.data="OK"), data.frame(a=c(nid.tip[-5], rep(NA, 5)))) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=rev(nid.int)[-1], row.names=rev(nid.int)[-1]), type="internal", missing.data="OK"), data.frame(a=c(rep(NA, 5), nid.int[-4], NA))) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=rev(nid.all)[-1], row.names=rev(nid.all)[-1]), type="all", missing.data="OK"), data.frame(a=c(nid.all[-9], NA))) ## missing data without matching expect_equal(phylobase:::formatData(phy.alt, data.frame(a=rev(nid.tip)[-1]), type="tip", match.data=FALSE, missing.data="OK"), data.frame(a=c(rev(nid.tip)[-1], rep(NA, 5)))) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=rev(nid.int)[-1]), type="internal", match.data=FALSE, missing.data="OK"), data.frame(a=c(rep(NA, 5), rev(nid.int)[-1], NA))) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=rev(nid.all)[-1]), type="all", match.data=FALSE, missing.data="OK"), data.frame(a=c(rev(nid.all)[-1], NA))) }) ## ## extra.data ## test_that("works as expected with extra data", { ## force error conditions expect_error(phylobase:::formatData(phy.alt, data.frame(a=1:3), type="tip", missing.data="fail")) expect_warning(phylobase:::formatData(phy.alt, data.frame(a=0:5, row.names=0:5), type="tip", missing="warn"), "not found in the tree") expect_warning(phylobase:::formatData(phy.alt, data.frame(a=0:5, row.names=0:5), type="tip"), "not found in the tree") ## extra data with matching expect_equal(phylobase:::formatData(phy.alt, data.frame(a=c(0L, rev(nid.tip)), row.names=c(0, rev(nid.tip))), type="tip", extra.data="OK"), data.frame(a=c(nid.tip, rep(NA, 4)))) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=c(0L, rev(nid.int)), row.names=c(0, rev(nid.int))), type="internal", extra.data="OK"), data.frame(a=c(rep(NA, 5), nid.int))) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=c(0L, rev(nid.all)), row.names=c(0, rev(nid.all))), type="all", extra.data="OK"), data.frame(a=nid.all)) ## extra data without matching expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:15), type="tip", match.data=FALSE, extra.data="OK"), data.frame(a=c(1:5, rep(NA, 4)))) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:15), type="internal", match.data=FALSE, extra.data="OK"), data.frame(a=c(rep(NA, 5), 1:4))) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:15), type="all", match.data=FALSE, extra.data="OK"), data.frame(a=c(1:9))) }) test_that("works as expected with both missing & extra data", { ## allow both extra.data and missing.data expect_equal(phylobase:::formatData(phy.alt, data.frame(a=0:3, row.names=0:3), type="tip", extra.data="OK", missing.data="OK"), data.frame(a=c(1:3, rep(NA, 6)))) }) ## ## keep.all ## test_that("keep.all works", { ## keep all rows expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:5, row.names=nid.tip), type="tip", keep.all=TRUE), data.frame(a=c(1:5, rep(NA, 4)), row.names=nid.all)) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:5, row.names=nid.tip), type="tip"), data.frame(a=c(1:5, rep(NA, 4)), row.names=nid.all)) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=6:9, row.names=nid.int), type="internal", keep.all=TRUE), data.frame(a=c(rep(NA, 5), 6:9), row.names=nid.all)) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=6:9, row.names=nid.int), type="internal"), data.frame(a=c(rep(NA, 5), 6:9), row.names=nid.all)) ## only keep 'type' rows expect_equal(phylobase:::formatData(phy.alt, data.frame(a=1:5, row.names=nid.tip), type="tip", keep.all=FALSE), data.frame(a=c(1:5), row.names=nid.tip)) expect_equal(phylobase:::formatData(phy.alt, data.frame(a=6:9, row.names=nid.int), type="internal", keep.all=FALSE), data.frame(a=c(6:9), row.names=nid.int)) }) context("formatData with duplicated labels in object") test_that("formatData works with duplicated labels", { ## Saving default options op <- phylobase.options() ## Changing default options phylobase.options(allow.duplicated.labels="ok") ## Creating phylo4 object with duplicated labels phy.dup <- phy.alt tipLabels(phy.dup)[2] <- tipLabels(phy.dup)[1] ## vector data coerced to data.frame (colname dt) expect_equal(phylobase:::formatData(phy.dup, 1:5), phylobase:::formatData(phy.dup, data.frame(dt=1:5))) ## list of vector data coerced to data.frame (colnames as given) expect_equal(phylobase:::formatData(phy.dup, list(a=1:5, b=6:10)), phylobase:::formatData(phy.dup, data.frame(a=1:5, b=6:10))) ## factor data coerced to data.frame (colname dt) expect_equal(phylobase:::formatData(phy.dup, factor(letters[1:5])), phylobase:::formatData(phy.dup, data.frame(dt=letters[1:5], stringsAsFactors = TRUE))) ## matrix data coerced to data.frame (colnames V1, V2) expect_equal(phylobase:::formatData(phy.dup, matrix(1:10, ncol=2)), phylobase:::formatData(phy.dup, data.frame(V1=1:5, V2=6:10))) ## matrix data coerced to data.frame (colname as given) expect_equal(phylobase:::formatData(phy.dup, matrix(1:10, ncol=2, dimnames=list(NULL, c("a", "b")))), phylobase:::formatData(phy.dup, data.frame(a=1:5, b=6:10))) ## error if dt is, say, a phylo4 object expect_error(phylobase:::formatData(phy.dup, phy.dup)) # # matching options # ## don't match (purely positional) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=1:5, row.names=rev(nid.tip)), type="tip", match.data=FALSE), data.frame(a=c(1:5, rep(NA, 4)), row.names=nid.all)) ## match on rownames (node numbers) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=1:5, row.names=rev(nid.tip)), type="tip", match.data=TRUE), data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all)) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=1:5, row.names=rev(nid.tip)), type="tip"), data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all)) ## match on rownames (labels) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=c(1,3,4,5), row.names=rev(lab.tip[-2])), type="tip", match.data=TRUE), data.frame(a=c(5,5,4,3,1, rep(NA, 4)), row.names=nid.all)) ## match on rownames (mixed node numbers and labels) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=c(1,2,3,4,5), row.names=c(rev(lab.tip)[1:3], rev(nid.tip)[4:5])), type="tip", match.data=TRUE), data.frame(a=c(5,4,3,2,1, rep(NA, 4)), row.names=nid.all)) ## but fails if rownamesAsLabels is TRUE expect_error(phylobase:::formatData(phy.dup, data.frame(a=1:5, row.names=c(rev(lab.tip)[1:3], rev(nid.tip)[4:5])), type="tip", match.data=TRUE, rownamesAsLabels=TRUE)) ## ## label.type="column" and label.column=2 ## ## should ignore label (purely positional) and retain a label col expect_equal(phylobase:::formatData(phy.dup, data.frame(a=1:5, lab=rev(nid.tip)), type="tip", match.data=FALSE, label.type="column", label.column=2), data.frame(a=c(1:5, rep(NA, 4)), lab=c(rev(nid.tip), rep(NA, 4)), row.names=nid.all)) ## match on label column (node numbers) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=1:5, lab=rev(nid.tip)), type="tip", match.data=TRUE, label.type="column", label.column=2), data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all)) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=1:5, lab=rev(nid.tip)), type="tip", label.type="column", label.column=2), data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all)) ## match on label column (labels) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=1:4, lab=rev(lab.tip[-2])), type="tip", match.data=TRUE, label.type="column", label.column=2), data.frame(a=as.integer(c(4, 4:1, rep(NA, 4))), row.names=nid.all)) ## match on label column (mixed node numbers and labels) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=1:5, lab=c(rev(lab.tip)[1:3], rev(nid.tip)[4:5])), type="tip", match.data=TRUE, label.type="column", label.column=2), data.frame(a=c(5:1, rep(NA, 4)), row.names=nid.all)) ## but fails if rownamesAsLabels is TRUE expect_error(phylobase:::formatData(phy.dup, data.frame(a=1:5, lab=c(rev(lab.tip)[1:3], rev(nid.tip)[4:5])), type="tip", match.data=TRUE, rownamesAsLabels=TRUE, label.type="column", label.column=2)) ## try to match internal nodes when type='tips' expect_error(phylobase:::formatData(phy.dup, data.frame(a=1:5, row.names=4:8), type="tip")) ## and vice versa expect_error(phylobase:::formatData(phy.dup, data.frame(a=6:9, row.names=1:4), type="internal")) ## ## missing.data ## ## force error conditions expect_error(phylobase:::formatData(phy.dup, data.frame(a=1:3), type="tip")) expect_error(phylobase:::formatData(phy.dup, data.frame(a=1:3), type="tip", missing.data="fail")) expect_warning(phylobase:::formatData(phy.dup, data.frame(a=1:3), type="tip", missing.data="warn")) ## missing data with matching expect_equal(phylobase:::formatData(phy.dup, data.frame(a=rev(nid.tip)[-1], row.names=rev(nid.tip)[-1]), type="tip", missing.data="OK"), data.frame(a=c(nid.tip[-5], rep(NA, 5)))) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=rev(nid.int)[-1], row.names=rev(nid.int)[-1]), type="internal", missing.data="OK"), data.frame(a=c(rep(NA, 5), nid.int[-4], NA))) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=rev(nid.all)[-1], row.names=rev(nid.all)[-1]), type="all", missing.data="OK"), data.frame(a=c(nid.all[-9], NA))) ## missing data without matching expect_equal(phylobase:::formatData(phy.dup, data.frame(a=rev(nid.tip)[-1]), type="tip", match.data=FALSE, missing.data="OK"), data.frame(a=c(rev(nid.tip)[-1], rep(NA, 5)))) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=rev(nid.int)[-1]), type="internal", match.data=FALSE, missing.data="OK"), data.frame(a=c(rep(NA, 5), rev(nid.int)[-1], NA))) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=rev(nid.all)[-1]), type="all", match.data=FALSE, missing.data="OK"), data.frame(a=c(rev(nid.all)[-1], NA))) ## ## extra.data ## ## force error conditions expect_error(phylobase:::formatData(phy.dup, data.frame(a=1:3), type="tip", missing.data="fail")) expect_warning(phylobase:::formatData(phy.dup, data.frame(a=0:5, row.names=0:5), type="tip", missing="warn")) expect_warning(phylobase:::formatData(phy.dup, data.frame(a=0:5, row.names=0:5), type="tip")) ## extra data with matching expect_equal(phylobase:::formatData(phy.dup, data.frame(a=c(0L, rev(nid.tip)), row.names=c(0, rev(nid.tip))), type="tip", extra.data="OK"), data.frame(a=c(nid.tip, rep(NA, 4)))) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=c(0L, rev(nid.int)), row.names=c(0, rev(nid.int))), type="internal", extra.data="OK"), data.frame(a=c(rep(NA, 5), nid.int))) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=c(0L, rev(nid.all)), row.names=c(0, rev(nid.all))), type="all", extra.data="OK"), data.frame(a=nid.all)) ## extra data without matching expect_equal(phylobase:::formatData(phy.dup, data.frame(a=1:15), type="tip", match.data=FALSE, extra.data="OK"), data.frame(a=c(1:5, rep(NA, 4)))) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=1:15), type="internal", match.data=FALSE, extra.data="OK"), data.frame(a=c(rep(NA, 5), 1:4))) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=1:15), type="all", match.data=FALSE, extra.data="OK"), data.frame(a=c(1:9))) ## allow both extra.data and missing.data expect_equal(phylobase:::formatData(phy.dup, data.frame(a=0:3, row.names=0:3), type="tip", extra.data="OK", missing.data="OK"), data.frame(a=c(1:3, rep(NA, 6)))) ## ## keep.all ## ## keep all rows expect_equal(phylobase:::formatData(phy.dup, data.frame(a=1:5, row.names=nid.tip), type="tip", keep.all=TRUE), data.frame(a=c(1:5, rep(NA, 4)), row.names=nid.all)) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=1:5, row.names=nid.tip), type="tip"), data.frame(a=c(1:5, rep(NA, 4)), row.names=nid.all)) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=6:9, row.names=nid.int), type="internal", keep.all=TRUE), data.frame(a=c(rep(NA, 5), 6:9), row.names=nid.all)) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=6:9, row.names=nid.int), type="internal"), data.frame(a=c(rep(NA, 5), 6:9), row.names=nid.all)) ## only keep 'type' rows expect_equal(phylobase:::formatData(phy.dup, data.frame(a=1:5, row.names=nid.tip), type="tip", keep.all=FALSE), data.frame(a=c(1:5), row.names=nid.tip)) expect_equal(phylobase:::formatData(phy.dup, data.frame(a=6:9, row.names=nid.int), type="internal", keep.all=FALSE), data.frame(a=c(6:9), row.names=nid.int)) ## restoring default options phylobase.options(op) }) phylobase/tests/testthat/test.pdata.R0000644000176200001440000000052114553646170017445 0ustar liggesusers# # --- Test pdata.R --- # ## test.pdata <- function() { ## # function(data,type,comment,metadata) ## } ## test.check_pdata <- function() { ## } ## test.extract.pdata <- function() { ## # test "[" and "[[" ## } ## test.assign.pdata <- function() { ## # test "[<-" and "[[<-" ## } ## test.plot.pdata <- function() { ## } phylobase/tests/testthat/test.subset.R0000644000176200001440000001416214553646170017667 0ustar liggesusers## ## --- Test subset.R --- ## ## create phylo4 object with a full complement of valid slots ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9)) descendant <- as.integer(c(7,1,2,8,3,6,9,4,5)) edge <- cbind(ancestor, descendant) nid.tip <- 1:5 nid.int <- 6:9 nid.all <- c(nid.tip, nid.int) lab.tip <- paste("t", nid.tip, sep="") lab.int <- paste("n", nid.int, sep="") elen <- descendant/10 elab <- paste("e", ancestor, descendant, sep="-") phy <- phylo4(x=edge, tip.label=lab.tip, node.label=lab.int, edge.length=elen, edge.label=elab) ## create altered version such that each slot is out of order with ## respect to all others; methods should be able to handle this phy.alt <- phy phy.alt@label <- rev(phy@label) phy.alt@edge <- phy@edge[c(6:9, 1:5), ] phy.alt@edge.length <- phy@edge.length[c(7:9, 1:6)] phy.alt@edge.label <- phy@edge.label[c(8:9, 1:7)] ## now create phylo4d by adding data (with node IDs as row.names) phyd.alt <- as(phy.alt, "phylo4d") allDt <- data.frame(a=letters[nid.all], b=10*nid.all, row.names=nid.all) tdata(phyd.alt, "all") <- allDt ## create altered version such that data slots are out of order with ## respect to all others; methods should be able to handle this nid.tip.r <- c(2,5,4,3,1) nid.int.r <- c(8,7,9,6) nid.all.r <- c(nid.tip.r, nid.int.r) phyd.alt@data <- phyd.alt@data[rank(nid.all.r), ] #----------------------------------------------------------------------- context("subset and friends") ## Also be testing "[" phylo4 methods here test_that("subset on phylo4", { # subset 2 tips phy.sub2 <- subset(phy.alt, tips.include=c(2, 5)) expect_equal(tipLabels(phy.sub2), setNames(c("t2", "t5"), c("1", "2"))) expect_equal(nodeLabels(phy.sub2), setNames(c("n6"), c("3"))) expect_equal(edgeLength(phy.sub2), setNames(c(0.6, 0.9, 2.2), c("0-3", "3-1", "3-2"))) expect_equal(subset(phy.alt, tips.exclude=c(1, 3, 4)), phy.sub2) expect_equal(subset(phy.alt, tips.include=c("t2", "t5")), phy.sub2) expect_equal(subset(phy.alt, tips.exclude=c("t1", "t3", "t4")), phy.sub2) # subset 4 tips phy.sub4 <- subset(phy.alt, tips.include=c(1, 2, 4, 5)) expect_equal(tipLabels(phy.sub4), setNames(c("t1", "t2", "t4", "t5"), c("1", "2", "3", "4"))) expect_equal(nodeLabels(phy.sub4), setNames(c("n6", "n7", "n9"), c("5", "6", "7"))) expect_equal(edgeLength(phy.sub4), setNames(c(0.6, 0.4, 0.5, 0.7, 0.1, 0.2, 1.7), c("0-5", "7-3", "7-4", "5-6", "6-1", "6-2", "5-7"))) expect_equal(subset(phy.alt, tips.exclude=3), phy.sub4) expect_equal(subset(phy.alt, tips.include=c("t1", "t2", "t4", "t5")), phy.sub4) expect_equal(subset(phy.alt, tips.exclude="t3"), phy.sub4) # check variants that should all return the original object expect_equal(phy.alt, subset(phy.alt)) expect_equal(phy.alt, subset(phy.alt, tipLabels(phy.alt))) expect_equal(phy.alt, subset(phy.alt, seq_len(nTips(phy.alt)))) expect_equal(phy.alt, phy.alt[tipLabels(phy.alt)]) expect_equal(phy.alt, phy.alt[seq_len(nTips(phy.alt))]) expect_equal(phy.alt, phy.alt[TRUE]) # error if only one valid tip requested expect_error(subset(phy, tips.include="t1")) expect_error(suppressWarnings(subset(phy, tips.include=c("t1", "t999")))) # error if zero valid tips requested expect_error(suppressWarnings(subset(phy, tips.include="t999"))) # error if more than one subset criteria are supplied expect_error(subset(phyd, tips.include="t1", tips.exclude="t3")) }) ## Also testing "[" phylo4d methods here ##TODO get rid of some tests that are pretty much redundant with the ##above, and add tests focused more on tree data test_that("subset on phylo4d", { ## subset 2 tips phyd.sub2 <- subset(phyd.alt, tips.include=c(2, 5)) expect_equal(tipLabels(phyd.sub2), setNames(c("t2", "t5"), c("1", "2"))) expect_equal(nodeLabels(phyd.sub2), setNames(c("n6"), c("3"))) expect_equal(edgeLength(phyd.sub2), setNames(c(0.6, 0.9, 2.2), c("0-3", "3-1", "3-2"))) expect_equal(subset(phyd.alt, tips.exclude=c(1, 3, 4)), phyd.sub2) expect_equal(subset(phyd.alt, tips.include=c("t2", "t5")), phyd.sub2) expect_equal(subset(phyd.alt, tips.exclude=c("t1", "t3", "t4")), phyd.sub2) ## subset 4 tips phyd.sub4 <- subset(phyd.alt, tips.include=c(1, 2, 4, 5)) expect_equal(tipLabels(phyd.sub4), setNames(c("t1", "t2", "t4", "t5"), c("1", "2", "3", "4"))) expect_equal(nodeLabels(phyd.sub4), setNames(c("n6", "n7", "n9"), c("5", "6", "7"))) expect_equal(edgeLength(phyd.sub4), setNames(c(0.6, 0.4, 0.5, 0.7, 0.1, 0.2, 1.7), c("0-5", "7-3", "7-4", "5-6", "6-1", "6-2", "5-7"))) expect_equal(subset(phyd.alt, tips.exclude=3), phyd.sub4) expect_equal(subset(phyd.alt, tips.include=c("t1", "t2", "t4", "t5")), phyd.sub4) expect_equal(subset(phyd.alt, tips.exclude="t3"), phyd.sub4) ## check variants that should all return the original object expect_equal(phyd.alt, subset(phyd.alt)) expect_equal(phyd.alt, subset(phyd.alt, tipLabels(phyd.alt))) expect_equal(phyd.alt, subset(phyd.alt, seq_len(nTips(phyd.alt)))) expect_equal(phyd.alt, phyd.alt[tipLabels(phyd.alt)]) expect_equal(phyd.alt, phyd.alt[seq_len(nTips(phyd.alt))]) expect_equal(phyd.alt, phyd.alt[TRUE]) ## error if only one valid tip requested expect_error(subset(phyd.alt, tips.include="t1")) expect_error(suppressWarnings(subset(phyd.alt, tips.include=c("t1", "t999")))) ## error if zero valid tips requested expect_error(suppressWarnings(subset(phyd.alt, tips.include="t999"))) # subset tips that include an NA value ##TODO uncomment this after tdata is working right with scrambled order ## tdata(phyd.alt)["t5", "a"] <- NA ## tdata(phyd.sub2)["t5", "a"] <- NA ## expect_equal(phyd.sub2, subset(phyd.alt, tips.include=c(2, 5))) }) test_that("subset on extractTree", { # extract phylo4 from itself expect_equal(phy.alt, extractTree(phy.alt)) # extract phylo4 from phylo4d expect_equal(phy.alt, extractTree(phyd.alt)) }) phylobase/tests/testthat/test.checkdata.R0000644000176200001440000000402414553646170020265 0ustar liggesusers# # --- Test checkdata.R --- # if (is.na(Sys.getenv("R_CMD_CHECK", unset = NA))) { pth <- file.path(getwd(), "..", "inst", "nexusfiles") } else { pth <- system.file(package = "phylobase", "nexusfiles") } ## co1.nex -- typical output from MrBayes. Contains 2 identical trees, the first ## one having posterior probabilities as node labels co1File <- file.path(pth, "co1.nex") # create phylo4 object with a full complement of valid slots ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9)) descendant <- as.integer(c(7,1,2,8,3,6,9,4,5)) edge <- cbind(ancestor, descendant) nid.tip <- 1:5 nid.int <- 6:9 nid.all <- c(nid.tip, nid.int) lab.tip <- paste("t", nid.tip, sep="") lab.int <- paste("n", nid.int, sep="") lab.all <- c(lab.tip, lab.int) elen <- descendant/10 elab <- paste("e", ancestor, descendant, sep="-") phy <- phylo4(x=edge, tip.label=lab.tip, node.label=lab.int, edge.length=elen, edge.label=elab) op <- phylobase.options() context("test phylo4 validator/phylobase.options()") test_that("test polytomies", { phylobase.options(poly="fail") expect_error(readNexus(file=co1File, check.node.labels="drop")) phylobase.options(op) }) test_that("test retic", { phylobase.options(retic="fail") edgeRetic <- rbind(edge, c(6, 3)) expect_error(phy <- phylo4(x=edgeRetic)) phylobase.options(op) }) test_that("test multiroot", { phylobase.options(multiroot="fail") edgeMultiRoot <- rbind(edge, c(0, 7)) expect_error(phy <- phylo4(x=edgeMultiRoot)) phylobase.options(op) }) test_that("test singleton", { phylobase.options(singleton="fail") edgeSingleton <- cbind(c(9,7,7,6,6,8,8,10,10,0), 1:10) expect_error(phylo4(x=edgeSingleton)) phylobase.options(op) }) ## checkPhylo4Data <- function() { ## } ## formatData <- function() { ## # function(phy, dt, type=c("tip", "internal", "all"), ## # match.data=TRUE, label.type=c("rownames", "column"), ## # label.column=1, missing.data=c("fail", "warn", "OK"), ## # extra.data=c("warn", "OK", "fail"), rownamesAsLabels=FALSE) ## } phylobase/tests/testthat/test.methods-phylo4.R0000644000176200001440000006252414553646170021247 0ustar liggesusers## ## --- Test methods-phylo4.R --- ## # create ape::phylo version of a simple tree for testing nwk <- "((t1:0.1,t2:0.2)n7:0.7,(t3:0.3,(t4:0.4,t5:0.5)n9:0.9)n8:0.8)n6:0.6;" tr <- read.tree(text=nwk) # create analogous phylo4 object with a full complement of valid slots ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9)) descendant <- as.integer(c(7,1,2,8,3,6,9,4,5)) edge <- cbind(ancestor, descendant) nid.tip <- 1:5 nid.int <- 6:9 nid.all <- c(nid.tip, nid.int) lab.tip <- paste("t", nid.tip, sep="") lab.int <- paste("n", nid.int, sep="") lab.all <- c(lab.tip, lab.int) eid <- paste(ancestor, descendant, sep="-") elen <- descendant/10 elab <- paste("e", eid, sep="") phy <- phylo4(x=edge, tip.label=lab.tip, node.label=lab.int, edge.length=elen, edge.label=elab) # create altered version such that each slot is out of order with # respect to all others; methods should be able to handle this phy.alt <- phy phy.alt@label <- rev(phy@label) phy.alt@edge <- phy@edge[c(6:9, 1:5), ] phy.alt@edge.length <- phy@edge.length[c(7:9, 1:6)] phy.alt@edge.label <- phy@edge.label[c(8:9, 1:7)] # update test targets for edge-related slots ancestor <- ancestor[c(6:9, 1:5)] descendant <- descendant[c(6:9, 1:5)] edge <- cbind(ancestor, descendant) eid <- eid[c(6:9, 1:5)] elen <- elen[c(6:9, 1:5)] elab <- elab[c(6:9, 1:5)] op <- phylobase.options() #----------------------------------------------------------------------- context("nTips, depthTips, nNodes, nodeType") test_that("nTips works correctly", expect_that(nTips(phy.alt), equals(length(nid.tip))) ) test_that("depthTips works when there are edge lengths", { edgeLengthVec <- c(1.2, 1.8, 1.8, 2.1, 2.3) names(edgeLengthVec) <- tipLabels(phy.alt) expect_warning(depth_tips <- depthTips(phy.alt)) expect_that(depth_tips, equals(edgeLengthVec)) }) test_that("depthTips works when there are no edge lengths", { tmpPhy <- phy.alt edgeLength(tmpPhy) <- NA expect_warning(depth_tips <- depthTips(tmpPhy)) expect_true(is.null(depth_tips)) }) test_that("nTips works on ape objects", ## nTips phylo expect_equal(nTips(tr), 5)) test.nEdges.phylo4 <- function() { expect_identical(nEdges(phy.alt), nrow(edge)) } test_that("nNodes works as expected", expect_equal(nNodes(phy.alt), length(nid.int))) test_that("nodeType works as expected", expect_identical(nodeType(phy.alt), setNames(c(rep("tip", length(nid.tip)), "root", rep("internal", length(nid.int)-1)), c(nid.tip, nid.int)))) context("nodeId") test_that("nodeId works without arguments", expect_identical(nodeId(phy.alt), c(nid.tip, nid.int))) test_that("nodeId works with argument all", expect_identical(nodeId(phy.alt, "all"), c(nid.tip, nid.int))) test_that("nodeId works with argument tip", expect_identical(nodeId(phy.alt, "tip"), nid.tip)) test_that("nodeId works with argument internal", expect_identical(nodeId(phy.alt, "internal"), nid.int)) test_that("nodeId works woth argument root", expect_identical(nodeId(phy.alt, "root"), nid.int[1])) context("nodeDepth") allDepths <- c(1.2, 1.8, 1.8, 2.1, 2.3, 0.9, 1.0, 1.2, 1.6) names(allDepths) <- names(getNode(phy.alt)) test_that("nodeDepth works without arguments", { expect_warning(node_depth <- nodeDepth(phy.alt)) expect_equal(node_depth, allDepths) }) test_that("nodeDepth works with numeric argument", { expect_warning(node_depth <- nodeDepth(phy.alt, 1)) expect_equal(node_depth, allDepths[1]) }) test_that("nodeDepth works with character argument", { expect_warning(node_depth <- nodeDepth(phy.alt, "t1")) expect_equal(node_depth, allDepths[1]) }) test_that("nodeDepth works with no branch length", { tmpPhy <- phy.alt edgeLength(tmpPhy) <- NA expect_warning(node_depth <- nodeDepth(tmpPhy)) expect_true(is.null(node_depth)) }) ############################################################################ ## nodeHeight ## ############################################################################ context("nodeHeight") tmp_nd_hgt_tree <- tempfile() cat("(((A:1,B:1):2,(C:1,D:1):2):4,((E:10,F:1):2,(G:3,H:7):2):4);", file = tmp_nd_hgt_tree) nd_hgt_tree <- readNewick(file = tmp_nd_hgt_tree) unlink(tmp_nd_hgt_tree) test_that("nodeHeight with 1 node", { expect_equal(nodeHeight(nd_hgt_tree, MRCA(nd_hgt_tree, c("A", "D")), "all_tip"), setNames(c(3, 3, 3, 3), c("A", "B", "C", "D"))) expect_equal(nodeHeight(nd_hgt_tree, MRCA(nd_hgt_tree, c("E", "H")), "min_tip"), c("F" = 3)) expect_equal(nodeHeight(nd_hgt_tree, MRCA(nd_hgt_tree, c("E", "H")), "max_tip"), c("E" = 12)) expect_equal(nodeHeight(nd_hgt_tree, MRCA(nd_hgt_tree, c("A", "D")), "root"), 4) }) test_that("nodeHeight with several nodes", { expect_equal(nodeHeight(nd_hgt_tree, c( MRCA(nd_hgt_tree, c("A", "D")), MRCA(nd_hgt_tree, c("A", "B"))), "all_tip"), list("10" = setNames(c(3, 3, 3, 3), c("A", "B", "C", "D")), "11" = c("A" = 1, "B" = 1))) expect_equal(nodeHeight(nd_hgt_tree, c( MRCA(nd_hgt_tree, c("E", "H")), MRCA(nd_hgt_tree, c("E", "F"))), "min_tip"), list("13" = c("F" = 3), "14" = c("F" = 1))) expect_equal(nodeHeight(nd_hgt_tree, c( MRCA(nd_hgt_tree, c("E", "H")), MRCA(nd_hgt_tree, c("E", "F"))), "max_tip"), list("13" = c("E" = 12), "14" = c("E" = 10))) expect_equal(nodeHeight(nd_hgt_tree, c( MRCA(nd_hgt_tree, c("A", "D")), MRCA(nd_hgt_tree, c("E", "F"))), "root"), c("10" = 4, "14" = 6)) }) test_that("nodeHeight for tips", { res <- as.list(rep(0, nTips(nd_hgt_tree))) for (i in seq_len(nTips(nd_hgt_tree))) names(res[[i]]) <- LETTERS[i] names(res) <- seq_len(nTips(nd_hgt_tree)) expect_equal(nodeHeight(nd_hgt_tree, nodeId(nd_hgt_tree, "tip"), "all_tip"), res) expect_equal(nodeHeight(nd_hgt_tree, nodeId(nd_hgt_tree, "tip"), "min_tip"), res) expect_equal(nodeHeight(nd_hgt_tree, nodeId(nd_hgt_tree, "tip"), "max_tip"), res) }) test_that("nodeHeight for mix of tips and internal nodes", { expect_equal(nodeHeight(nd_hgt_tree, c(1, 10), "all_tip"), list("1" = c("A" = 0), "10" = c("A" = 3, "B" = 3, "C" = 3, "D" = 3))) expect_equal(nodeHeight(nd_hgt_tree, c(1, 14), "min_tip"), list("1" = c("A" = 0), "14" = c("F" = 1))) expect_equal(nodeHeight(nd_hgt_tree, c(1, 14), "max_tip"), list("1" = c("A" = 0), "14" = c("E" = 10))) expect_equal(nodeHeight(nd_hgt_tree, c(5, 14), "root"), c("5" = 16, "14" = 6)) }) ############################################################################ ## edges ## ############################################################################ context("edges") test_that("edges works", expect_identical(edges(phy.alt), edge)) test_that("edges work with drop.root=TRUE option", expect_identical(edges(phy.alt, drop.root=TRUE), edge[edge[,1] != 0,])) context("edge order") test_that("edgeOrder works as expected", { expect_identical(edgeOrder(phy.alt), "unknown") expect_identical(edgeOrder(reorder(phy.alt, "preorder")), "preorder") expect_identical(edgeOrder(reorder(phy.alt, "postorder")), "postorder") }) context("edgeId") test_that("edgeId works with no argument", expect_identical(edgeId(phy.alt), eid)) test_that("edgeId works with argument all", expect_identical(edgeId(phy.alt, "all"), eid)) test_that("edgeId works with argument tip", expect_identical(edgeId(phy.alt, "tip"), eid[descendant %in% nid.tip])) test_that("edgeId works with argument internal", expect_identical(edgeId(phy.alt, "internal"), eid[!descendant %in% nid.tip])) test_that("edgeId works with argument root", expect_identical(edgeId(phy.alt, "root"), eid[ancestor == 0])) context("hasEdgeLength") test_that("hasEdgeLength works when edge lengths are present", expect_true(hasEdgeLength(phy.alt))) test_that("hasEdgeLength works when no edge lengths are present", { phy.alt@edge.length <- NA_real_ expect_true(!hasEdgeLength(phy.alt)) }) context("edgeLength") test_that("default works (all edge lengths)", expect_identical(edgeLength(phy.alt), setNames(elen, eid))) test_that("one edge length, by label", expect_equal(edgeLength(phy.alt, "t1"), c(`7-1`=0.1))) test_that("one edge length, by node ID", expect_equal(edgeLength(phy.alt, 1), c(`7-1`=0.1))) test_that("non-existent edge, by label", { ans <- structure(NA_real_, .Names = NA_character_) expect_equal(suppressWarnings(edgeLength(phy.alt, "xxx")), ans) }) test_that("non-existent edge, by number", { ans <- structure(NA_real_, .Names = NA_character_) expect_equal(suppressWarnings(edgeLength(phy.alt, 999)), ans) }) test_that("wrong number of edge lengths", { phy.tmp1 <- phy.alt phy.tmp1@edge.length <- phy.alt@edge.length[-1] expect_true(nzchar(checkPhylo4(phy.tmp1))) phy.tmp1 <- phy.alt phy.tmp1@edge.length <- c(phy.alt@edge.length, 1) expect_true(nzchar(checkPhylo4(phy.tmp1))) }) test_that("negative edge lengths", { phy.tmp1 <- phy.alt phy.tmp1@edge.length[3] <- -1 expect_true(nzchar(checkPhylo4(phy.tmp1))) }) test_that("edge incorrectly labeled", { phy.tmp1 <- phy.alt names(phy.tmp1@edge.length)[1] <- "9-10" expect_true(nzchar(checkPhylo4(phy.tmp1))) }) context("edgeLength <-") emptyVec <- numeric() attributes(emptyVec) <- list(names=character(0)) test_that("dropping all should produce empty slot", { edgeLength(phy.alt) <- numeric() expect_identical(edgeLength(phy.alt), setNames(rep(NA_real_, 9), edgeId(phy.alt, "all"))) expect_identical(phy.alt@edge.length, emptyVec) edgeLength(phy.alt) <- NA_real_ expect_identical(edgeLength(phy.alt), setNames(rep(NA_real_, 9), edgeId(phy.alt, "all"))) expect_identical(phy.alt@edge.length, emptyVec) }) test_that("vector with reversed names, get matched by default (complete replacement)", { edgeLength(phy.alt) <- numeric() revElen <- setNames(elen, rev(eid)) edgeLength(phy.alt) <- revElen expect_identical(edgeLength(phy.alt), revElen[edgeId(phy.alt, "all")]) }) test_that("vector with reversed names, but specify no matching (complete replacement)", { edgeLength(phy.alt) <- numeric() revElen <- setNames(elen, rev(eid)) edgeLength(phy.alt, use.names=FALSE) <- revElen elen1 <- elen expect_identical(edgeLength(phy.alt), setNames(elen1, edgeId(phy.alt, "all"))) }) test_that("vector with no names, should match to edgeId order (complete replacement)", { edgeLength(phy.alt) <- numeric() edgeLength(phy.alt) <- elen elen2 <- elen expect_identical(edgeLength(phy.alt), setNames(elen2, edgeId(phy.alt, "all"))) }) test_that("recycling applies if fewer the nEdges elements are supplied, \ (duplicate edge length are okay), (complete replacement)", { edgeLength(phy.alt) <- 1 expect_identical(edgeLength(phy.alt), setNames(rep(1, 9), edgeId(phy.alt, "all"))) }) edgeLength(phy.alt) <- elen test_that("replace an edge length using numeric index (partial replacement)", { edgeLength(phy.alt)[9] <- 83 expect_identical(edgeLength(phy.alt), setNames(c(elen[1:8], 83), edgeId(phy.alt, "all"))) }) test_that("back again, now using character index (partial replacement)", { edgeLength(phy.alt)["8-3"] <- 0.3 elen3 <- elen expect_identical(edgeLength(phy.alt), setNames(elen3, edgeId(phy.alt, "all"))) }) test_that("error to add length for edges that don't exist (partial replacement)", { expect_error(edgeLength(phy.alt)["fake"] <- 999) expect_error(edgeLength(phy.alt)[999] <- 999) }) test_that("NAs permitted only for root edge (or for *all* edges)", { edgeLength(phy.alt)[edgeId(phy.alt, "root")] <- NA expect_identical(edgeLength(phy.alt), setNames(c(NA, elen[2:9]), edgeId(phy.alt, "all"))) edgeLength(phy.alt) <- elen expect_error(edgeLength(phy.alt)["8-3"] <- NA) }) ## TODO sumEdgeLength.phylo4 ## function(phy, node) context("isRooted") test_that("isRooted works as expected", expect_true(isRooted(phy.alt))) context("rootNode") test_that("rootNode works as expected", expect_identical(rootNode(phy.alt), getNode(phy, nid.int[1]))) context("rootNode <-") test_that("rootNode <- is not yet implemented", expect_error(rootNode(phy.alt) <- 7)) context("labels") test_that("labels works as expected with no argument", expect_identical(labels(phy.alt), setNames(c(lab.tip, lab.int), c(nid.tip, nid.int)))) test_that("labels works as expected with argument all", expect_identical(labels(phy.alt, "all"), setNames(c(lab.tip, lab.int), c(nid.tip, nid.int)))) test_that("labels works as expected with argument tip", expect_identical(labels(phy.alt, "tip"), setNames(lab.tip, nid.tip))) test_that("labels works as expected with argument internal", expect_identical(labels(phy.alt, "internal"), setNames(lab.int, nid.int))) context("labels <-") test_that("dropping all should produce default tip labels, no internal labels", { labels(phy.alt) <- character() expect_identical(labels(phy.alt), setNames(c(paste("T", 1:5, sep=""), rep(NA, 4)), nid.all)) }) ## # ## # complete replacement ## # ## with names, not used test_that("vector with reversed names, but names not used (all) - complete replacement", { labels(phy.alt) <- character() labels(phy.alt) <- setNames(lab.all, rev(nid.all)) expect_identical(labels(phy.alt), setNames(lab.all, nid.all)) }) test_that("vector with reversed names, but names not used (tips) - complete replacement", { labels(phy.alt) <- character() labels(phy.alt, "tip") <- setNames(lab.tip, rev(nid.tip)) expect_identical(tipLabels(phy.alt), setNames(lab.tip, nid.tip)) }) test_that("vector with reversed names, but names not used (internal) - complete replacement", { labels(phy.alt) <- character() labels(phy.alt, "internal") <- setNames(lab.int, rev(nid.int)) expect_identical(nodeLabels(phy.alt), setNames(lab.int, nid.int)) }) ## with names, used test_that("vector with reversed names, but names used (all) - complete replacement", { labels(phy.alt) <- character() labels(phy.alt, use.names=TRUE) <- setNames(lab.all, rev(nid.all)) expect_identical(labels(phy.alt), setNames(rev(lab.all), nid.all)) }) test_that("vector with reversed names, but names used (tips) - complete replacement", { labels(phy.alt) <- character() labels(phy.alt, "tip", use.names=TRUE) <- setNames(lab.tip, rev(nid.tip)) expect_identical(tipLabels(phy.alt), setNames(rev(lab.tip), nid.tip)) }) test_that("vector with reversed names, but names used (internal) - complete replacement", { labels(phy.alt) <- character() labels(phy.alt, "internal", use.names=TRUE) <- setNames(lab.int, rev(nid.int)) expect_identical(nodeLabels(phy.alt), setNames(rev(lab.int), nid.int)) }) ## no names test_that("vector with no names, should match to nodeId order (all) - complete replacement", { labels(phy.alt) <- character() labels(phy.alt) <- lab.all expect_identical(labels(phy.alt), setNames(lab.all, nid.all)) }) test_that("vector with no names, should match to nodeId order (all) - complete replacement", { labels(phy.alt) <- character() labels(phy.alt, type="tip") <- lab.tip expect_identical(tipLabels(phy.alt), setNames(lab.tip, nid.tip)) }) test_that("vector with no names, should match to nodeId order (all) - complete replacement", { labels(phy.alt) <- character() labels(phy.alt, type="internal") <- lab.int expect_identical(nodeLabels(phy.alt), setNames(lab.int, nid.int)) }) ## partial replacement labels(phy.alt) <- lab.all test_that("replace a tip using numeric index", { labels(phy.alt)[5] <- "t5a" expect_identical(tipLabels(phy.alt), setNames(c(lab.tip[1:4], "t5a"), nid.tip)) }) test_that("and back again, now using character index", { labels(phy.alt)["5"] <- "t5" expect_identical(labels(phy.alt), setNames(lab.all, nid.all)) }) test_that("replace an internal node using numeric index", { labels(phy.alt)[9] <- "n9a" expect_identical(nodeLabels(phy.alt), setNames(c(lab.int[1:3], "n9a"), nid.int)) }) test_that("and back again, now using character index", { labels(phy.alt)["9"] <- "n9" expect_identical(labels(phy.alt), setNames(lab.all, nid.all)) }) test_that("error to produce duplicate tip or internal label", { phylobase.options(allow.duplicated.labels="fail") expect_error(labels(phy.alt)[1] <- "t2") expect_error(labels(phy.alt)[6] <- "n7") }) test_that("no error in allow.duplicated.labels is ok", { phylobase.options(allow.duplicated.labels="ok") labels(phy.alt)[1] <- "t2" labels(phy.alt)[6] <- "n7" expect_identical(tipLabels(phy.alt), setNames(c("t2", "t2", "t3", "t4", "t5"), nid.tip)) expect_identical(nodeLabels(phy.alt), setNames(c("n7", "n7", "n8", "n9"), nid.int)) }) test_that("error to add labels for nodes that don't exist", { expect_error(labels(phy.alt)["fake"] <- "xxx") expect_error(labels(phy.alt)[999] <- "xxx") }) context("nodeLabels") test_that("nodeLabels works as expected", expect_identical(nodeLabels(phy.alt), setNames(lab.int, nid.int))) context("hasNodeLabels") test_that("hasNodeLabels works as expected", { expect_true(hasNodeLabels(phy.alt)) nodeLabels(phy.alt) <- NA_character_ expect_true(!hasNodeLabels(phy.alt)) }) context("nodeLabels <-") test_that("dropping all should produce no internal labels", { nodeLabels(phy.alt) <- character() expect_true(!any(nid.int %in% names(phy.alt@label))) expect_identical(nodeLabels(phy.alt), setNames(rep(NA_character_, 4), nid.int)) }) labels(phy.alt) <- lab.all test_that("replace an internal node using numeric index", { nodeLabels(phy.alt)[4] <- "n9a" expect_identical(nodeLabels(phy.alt), setNames(c(lab.int[1:3], "n9a"), nid.int)) }) test_that("and back again, now using character index", { nodeLabels(phy.alt)["9"] <- "n9" expect_identical(labels(phy.alt), setNames(lab.all, nid.all)) }) test_that("error to produce duplicate internal label", { phylobase.options(allow.duplicated.labels="fail") expect_error(nodeLabels(phy.alt)["6"] <- "n7") }) test_that("duplicated labels work as expected", { phylobase.options(op) phylobase.options(allow.duplicated.labels="ok") nodeLabels(phy.alt)["6"] <- "n7" expect_identical(nodeLabels(phy.alt), setNames(c("n7", "n7", "n8", "n9"), nid.int)) expect_true(hasDuplicatedLabels(phy.alt)) ## NAs are not considered duplicated nodeLabels(phy.alt)[1:2] <- NA expect_true(!hasDuplicatedLabels(phy.alt)) phylobase.options(op) ## error to add labels for nodes that don't exist expect_error(nodeLabels(phy.alt)["fake"] <- "xxx") expect_error(nodeLabels(phy.alt)[999] <- "xxx") }) context("tipLabels") test_that("tipLabels works as expected", expect_identical(tipLabels(phy.alt), setNames(lab.tip, nid.tip))) context("tipLabels <-") test_that("dropping all tip labels should produce default labels", { tipLabels(phy.alt) <- character() expect_identical(tipLabels(phy.alt), setNames(paste("T", 1:5, sep=""), nid.tip)) }) labels(phy.alt) <- lab.all test_that("replace a tip using numeric index", { tipLabels(phy.alt)[5] <- "t5a" expect_identical(tipLabels(phy.alt), setNames(c(lab.tip[1:4], "t5a"), nid.tip)) }) test_that("and back again, now using character index", { tipLabels(phy.alt)["5"] <- "t5" expect_identical(labels(phy.alt), setNames(lab.all, nid.all)) }) test_that("error to produce duplicate tip or internal label", { phylobase.options(allow.duplicated.labels="fail") expect_error(tipLabels(phy.alt)[1] <- "t2") }) test_that("duplicated labels works as expected on tips", { phylobase.options(op) phylobase.options(allow.duplicated.labels="ok") tipLabels(phy.alt)[1] <- "t2" expect_identical(tipLabels(phy.alt), setNames(c("t2", "t2", "t3", "t4", "t5"), nid.tip)) expect_true(hasDuplicatedLabels(phy.alt)) tipLabels(phy.alt)[1:2] <- NA expect_true(!hasDuplicatedLabels(phy.alt)) phylobase.options(op) }) test_that("error to add labels for nodes that don't exist", { expect_error(tipLabels(phy.alt)["fake"] <- "xxx") expect_error(tipLabels(phy.alt)[999] <- "xxx") }) test_that("hasEdgeLabels works as expected", { expect_true(hasEdgeLabels(phy.alt)) phy.alt@edge.label <- NA_character_ expect_true(!hasEdgeLabels(phy.alt)) }) context("edgeLabels") test_that("edgeLabels works as expected", { expect_identical(edgeLabels(phy.alt), setNames(elab, eid)) }) test_that("edgeLabels returns named vector of NAs if edge labels are missing or NA", { phy.alt@edge.label <- NA_character_ expect_identical(edgeLabels(phy.alt), setNames(rep(NA_character_, 9), eid)) phy.alt@edge.label <- character() expect_identical(edgeLabels(phy.alt), setNames(rep(NA_character_, 9), eid)) }) test_that("if only some labels exists, should fill in NA for the others", { phy.alt@edge.label <- setNames(elab[-1], eid[-1]) expect_identical(edgeLabels(phy.alt), setNames(c(NA, elab[-1]), eid)) }) context("edgeLabels <-") test_that(" dropping all should produce empty slot", { edgeLabels(phy.alt) <- character() expect_identical(edgeLabels(phy.alt), setNames(rep(NA_character_, 9), eid)) }) test_that("vector with reversed names, which always get matched - complete replacement", { edgeLabels(phy.alt) <- character() edgeLabels(phy.alt) <- setNames(elab, rev(eid)) expect_identical(edgeLabels(phy.alt), setNames(rev(elab), eid)) }) test_that("vector with no names, should match to edgeId order - complete replacement", { edgeLabels(phy.alt) <- character() edgeLabels(phy.alt) <- elab expect_identical(edgeLabels(phy.alt), setNames(elab, eid)) }) test_that("recycling applies if fewer the nEdges elements are supplied\\ (duplicate edge labels are okay) - complete replacement.", { edgeLabels(phy.alt) <- "x" expect_identical(edgeLabels(phy.alt), setNames(rep("x", 9), eid)) }) edgeLabels(phy.alt) <- elab test_that("replace an edge label using numeric index - partial replacement", { edgeLabels(phy.alt)[9] <- "e8-3a" expect_identical(edgeLabels(phy.alt), setNames(c(elab[1:8], "e8-3a"), eid)) }) test_that("and back again, now using character index", { edgeLabels(phy.alt)["8-3"] <- "e8-3" expect_identical(edgeLabels(phy.alt), setNames(elab, eid)) }) test_that("error to add labels for edges that don't exist", { expect_error(edgeLabels(phy.alt)["fake"] <- "xxx") expect_error(edgeLabels(phy.alt)[999] <- "xxx") }) ## this is also the print method ## this mostly just wraps .phylo4ToDataFrame, which is tested elsewhere ## test.show.phylo4 <- function() { ## } ## test.names.phylo4 <- function() { ## #TODO? ## } ## test.head.phylo4 <- function() { ## #TODO? ## } ## test.tail.phylo4 <- function() { ## #TODO? ## } context("summary") test_that("summary works as expected", { phy.sum <- summary(phy.alt, quiet=TRUE) expect_identical(phy.sum$name, "phy.alt") expect_identical(phy.sum$nb.tips, length(nid.tip)) expect_identical(phy.sum$nb.nodes, length(nid.int)) expect_identical(phy.sum$mean.el, mean(elen)) expect_identical(phy.sum$var.el, var(elen)) expect_identical(phy.sum$sumry.el, summary(elen)) }) test_that("summary works as expected when root edge as no length", { ## now make root edge length NA edgeLength(phy.alt)[edgeId(phy.alt, "root")] <- NA phy.sum2 <- summary(phy.alt, quiet=TRUE) expect_identical(phy.sum2$mean.el, mean(edgeLength(phy.alt), na.rm=TRUE)) expect_identical(phy.sum2$var.el, var(edgeLength(phy.alt), na.rm=TRUE)) expect_identical(phy.sum2$sumry.el, summary(stats::na.omit(edgeLength(phy.alt)))) }) test_that("now remove edge lengths altogether", { phy.alt@edge.length[] <- NA phy.sum3 <- summary(phy.alt, quiet=TRUE) expect_true(is.null(phy.sum3$mean.el)) expect_true(is.null(phy.sum3$var.el)) expect_true(is.null(phy.sum3$sumry.el)) }) ## not an exported function -- called internally by reorder("phylo4") ## test.orderIndex <- function() { ## } ## test.reorder.phylo4 <- function() { ## ## TODO ## } context("isUltrametric") test_that("isUltrametric works as expected", { expect_true(!isUltrametric(phy.alt)) tmpPhy <- as(rcoal(10), "phylo4") expect_true(isUltrametric(tmpPhy)) tmpPhy <- phy.alt edgeLength(tmpPhy) <- NA expect_error(isUltrametric(tmpPhy)) }) phylobase.options(op) phylobase/tests/testthat/test.treewalk.R0000644000176200001440000002552114553646170020201 0ustar liggesusers# # --- Test treewalk.R --- # # Create sample phylo4 tree for testing tr <- read.tree(text="(((spA:0.2,(spB:0.1,spC:0.1):0.15):0.5,spD:0.7):0.2,spE:1):0.4;") phytr <- as(tr, "phylo4") # create phylo4 object with a full complement of valid slots ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9)) descendant <- as.integer(c(7,1,2,8,3,6,9,4,5)) edge <- cbind(ancestor, descendant) nid.tip <- 1:5 nid.int <- 6:9 nid.all <- c(nid.tip, nid.int) lab.tip <- paste("t", nid.tip, sep="") lab.int <- paste("n", nid.int, sep="") lab.all <- c(lab.tip, lab.int) eid <- paste(ancestor, descendant, sep="-") elen <- descendant/10 elab <- paste("e", eid, sep="") phy <- phylo4(x=edge, tip.label=lab.tip, node.label=lab.int, edge.length=elen, edge.label=elab) # create altered version such that each slot is out of order with # respect to all others; methods should be able to handle this phy.alt <- phy phy.alt@label <- rev(phy@label) phy.alt@edge <- phy@edge[c(6:9, 1:5), ] phy.alt@edge.length <- phy@edge.length[c(7:9, 1:6)] phy.alt@edge.label <- phy@edge.label[c(8:9, 1:7)] # update test targets for edge-related slots ancestor <- ancestor[c(6:9, 1:5)] descendant <- descendant[c(6:9, 1:5)] edge <- cbind(ancestor, descendant) eid <- eid[c(6:9, 1:5)] elen <- elen[c(6:9, 1:5)] elab <- elab[c(6:9, 1:5)] #----------------------------------------------------------------------- ## Note: we're not explicitly testing missing="warn" condition below; ## however, if "OK" and "fail" both work as expected, then so must "warn" #test.getNode <- function() { context("getNode") test_that("getNode works when nodes provided only has valid characters", { expect_that(getNode(phytr, "spA"), equals(c(spA=1))) expect_that(getNode(phytr, c("spA", "spC")), equals(c(spA=1, spC=3))) }) test_that("getNode works when nodes provided only has valid integers", { ans <- 4 names(ans) <- "spD" expect_that(getNode(phytr, 4), equals(ans)) ans <- c(4,6) names(ans) <- c("spD", NA) expect_that(getNode(phytr, c(4,6)), equals(ans)) }) test_that("getNode works when node includes only missing characters (names), but missing=OK", { ans <- rep(NA_integer_, 2) # return values should be NA names(ans) <- rep(NA, 2) # return values should have NA names expect_that(getNode(phytr, c("xxx", "yyy"), missing="OK"), equals(ans)) # now missing = "fail" expect_error(getNode(phytr, c("xxx", "yyy"), missing="fail")) }) test_that("getNode works wehn node includes only missing numbers (IDs), but missing=OK", { ans <- rep(NA_integer_, 3) # return values should be NA names(ans) <- rep(NA, 3) # return values should have NA names expect_that(getNode(phytr, c(-9, 0, 50), missing="OK"), equals(ans)) # now missing = "fail" expect_error(getNode(phytr, c(-9, 0, 50), missing="fail")) }) test_that("getNode works when node includes NAs, but missing = \"OK\"", { expect_true(is.na(getNode(phytr, NA_integer_, missing="OK"))) expect_true(is.na(getNode(phytr, NA_character_, missing="OK"))) }) test_that("getNode works when node includes mixture of valid values and NAs", { ans <- c(2, NA) names(ans) <- c("spB", NA) expect_that(getNode(phytr, c("spB", NA), missing="OK"), equals(ans)) expect_that(getNode(phytr, c(2, NA), missing="OK"), equals(ans)) }) test_that("getNode throws exception when node is neither integer-like nor character", expect_error(getNode(phytr, 1.5))) test_that("getNode works even when a tip is labeled as \"0\"", { phyTmp <- phytr tipLabels(phyTmp)[1] <- "0" ans <- 1 names(ans) <- "0" expect_that(getNode(phyTmp, "0"), equals(ans)) }) ## TODO context("ancestor function") ## TODO context("children function") context("descendants function") phytr <- phylo4(read.tree(text="((t3,t4),(t1,(t2,t5)));")) test_that("descendants() works with tips", { expect_identical(descendants(phytr, 5), setNames(5L, "t5")) expect_identical(descendants(phytr, 5, "tips"), setNames(5L, "t5")) expect_identical(descendants(phytr, 5, "children"), setNames(integer(0), character(0))) expect_identical(descendants(phytr, 5, "all"), setNames(5L, "t5")) expect_identical(descendants(phytr, 5, "ALL"), setNames(5L, "t5")) }) test_that("descendants() works when provided with a vector of nodes", { expect_identical(descendants(phytr, 5:7), list("5" = c(t5 = 5L), "6" = c(t3 = 1L, t4 = 2L, t1 = 3L, t2 = 4L, t5 = 5L), "7" = c(t3 = 1L, t4 = 2L))) expect_identical(descendants(phytr, 5:7, "tips"), list("5" = c(t5 = 5L), "6" = c(t3 = 1L, t4 = 2L, t1 = 3L, t2 = 4L, t5 = 5L), "7" = c(t3 = 1L, t4 = 2L))) expect_identical(descendants(phytr, 5:7, "children"), list("5" = setNames(integer(0), character(0)), "6" = setNames(c(7L, 8L), c(NA, NA)), "7" = c(t3 = 1L, t4 = 2L)) ) expect_identical(descendants(phytr, 5:7, "ALL"), list("5" = c(t5 = 5L), "6" = setNames(c(6L, 7L, 1L, 2L, 8L, 3L, 9L, 4L, 5L), c(NA, NA, "t3", "t4", NA, "t1", NA, "t2", "t5")), "7" = setNames(c(7L, 1L, 2L), c(NA, "t3", "t4"))) ) }) test_that("descendants() works with internal nodes", { expect_identical(descendants(phytr, 8), setNames(c(3L, 4L, 5L), c("t1", "t2", "t5"))) expect_identical(descendants(phytr, 8, "tips"), setNames(c(3L, 4L, 5L), c("t1", "t2", "t5"))) expect_identical(descendants(phytr, 8, "children"), setNames(c(3L, 9L), c("t1", NA))) expect_identical(descendants(phytr, 8, "all"), setNames(c(3L, 9L, 4L, 5L), c("t1", NA, "t2", "t5"))) expect_identical(descendants(phytr, 8, "ALL"), setNames(c(8L, 3L, 9L, 4L, 5L), c(NA, "t1", NA, "t2", "t5"))) }) ## TODO siblings # function(phy, node, include.self=FALSE) ## TODO ancestors # function (phy, node, type=c("all","parent","ALL")) ## TODO MRCA # function(phy, ...) ## TODO shortestPath # function(phy, node1, node2) context("test on getEdge with nodes as descendants") ## function(phy, node, type=c("descendant", "ancestor"), ## missing=c("warn", "OK", "fail")) test_that("getEdge works when node only has valid descendants, as characters", { expect_identical(getEdge(phy.alt, "t1"), setNames("7-1", 1)) expect_identical(getEdge(phy.alt, c("t1", "t3")), setNames(c("7-1", "8-3"), c(1,3))) }) test_that("getEdge works when node only has valid descendants, as integers", { expect_identical(getEdge(phy.alt, 1), setNames("7-1", 1)) expect_identical(getEdge(phy.alt, c(1,3)), setNames(c("7-1", "8-3"), c(1,3))) }) test_that("node includes only missing characters (labels), missing=OK", { expect_identical(getEdge(phy.alt, c("x", "y", "z"), missing="OK"), setNames(rep(NA, 3), rep(NA, 3))) }) test_that("node includes only missing characters (labels), missing=fail", { expect_error(getEdge(phy.alt, c("x", "y", "z"), missing="fail")) }) test_that("node includes only missing numbers (IDs), but missing=OK", expect_identical(getEdge(phy.alt, c(-9, 0, 50), missing="OK"), setNames(rep(NA, 3), rep(NA, 3)))) test_that("node includes only missing numbers (IDs), but missing=fail", expect_error(getEdge(phy, c(-9, 0, 50), missing="fail"))) test_that("node includes NAs, but missing = OK", { expect_true(is.na(getEdge(phy, NA_integer_, missing="OK"))) expect_true(is.na(getEdge(phy, NA_character_, missing="OK"))) }) test_that("node includes mixture of valid values and NAs", { expect_identical(getEdge(phy, c("t3", NA), missing="OK"), setNames(c("8-3", NA), c(3, NA))) expect_identical(getEdge(phy, c(3, NA), missing="OK"), setNames(c("8-3", NA), c(3, NA))) }) test_that("node is neither integer-like nor character", { expect_error(getEdge(phy, 1.5)) }) context("test on getEdge with nodes as ancestors") test_that("node only has valid ancestors, as characters", { expect_identical(getEdge(phy.alt, "n6", type="ancestor"), setNames(c("6-7", "6-8"), c(6, 6))) expect_identical(getEdge(phy.alt, c("n6", "n8"), type="ancestor"), setNames(c("6-7", "6-8", "8-9", "8-3"), c(6, 6, 8, 8))) }) test_that("node only has valid ancestors, as integers", { expect_identical(getEdge(phy.alt, 6, type="ancestor"), setNames(c("6-7", "6-8"), c(6, 6))) expect_identical(getEdge(phy.alt, c(6, 8), type="ancestor"), setNames(c("6-7", "6-8", "8-9", "8-3"), c(6, 6, 8, 8))) }) test_that("node includes only missing characters (labels), but missing=OK", { expect_identical(getEdge(phy.alt, c("x", "y", "z"), type="ancestor", missing="OK"), setNames(rep(NA, 3), rep(NA, 3))) }) test_that("node includes only tips (labels), but missing=OK", { expect_identical( getEdge(phy.alt, c("t1", "t3"), type="ancestor", missing="OK"), setNames(rep(NA, 2), c(1, 3))) }) test_that("node includes only tips (labels), now missing = fail", { expect_error(getEdge(phy.alt, c("x", "y", "z"), missing="fail")) expect_error(getEdge(phy.alt, c("t1", "t3"), type="ancestor", missing="fail")) }) test_that("node includes only missing numbers (IDs), but missing=OK", { expect_identical( getEdge(phy.alt, c(-9, 0, 50), type="ancestor", missing="OK"), setNames(rep(NA, 3), rep(NA, 3))) }) test_that("node includes only tips (labels), but missing=OK", { expect_identical( getEdge(phy.alt, c(1, 3), type="ancestor", missing="OK"), setNames(rep(NA, 2), c(1, 3))) }) test_that("node includes only tips (labels), but missing=fail", { expect_error(getEdge(phy.alt, c(-9, 0, 50), missing="fail")) expect_error(getEdge(phy.alt, c(1, 3), type="ancestor", missing="fail")) }) test_that("node includes NAs, but missing = OK", { expect_true(is.na(getEdge(phy.alt, NA_integer_, type="ancestor", missing="OK"))) expect_true(is.na(getEdge(phy.alt, NA_character_, type="ancestor", missing="OK"))) }) test_that("node includes mixture of valid values and NAs", { expect_identical( getEdge(phy.alt, c("t3", "n8", NA), type="ancestor", missing="OK"), setNames(c(NA, "8-9", "8-3", NA), c(3, 8, 8, NA))) expect_identical( getEdge(phy.alt, c(3, 8, NA), type="ancestor", missing="OK"), setNames(c(NA, "8-9", "8-3", NA), c(3, 8, 8, NA))) }) phylobase/tests/testthat/test.class-phylo4.R0000644000176200001440000001012614553646170020700 0ustar liggesusers# # --- Test class-phylo4.R --- # ### Get all the test NEXML files if (is.na(Sys.getenv("R_CMD_CHECK", unset = NA))) { pth <- file.path(getwd(), "..", "inst", "nexmlfiles") } else { pth <- system.file(package = "phylobase", "nexmlfiles") } ## NeXML files compFile <- file.path(pth, "comp_analysis.xml") stopifnot(file.exists(compFile)) op <- phylobase.options() context("test phylo4 class") test_that("building from matrix works", { edge <- structure(c(6L, 7L, 8L, 8L, 9L, 9L, 7L, 6L, 7L, 8L, 1L, 9L, 2L, 3L, 4L, 5L), .Dim = c(8, 2)) edge.length <- c(0.2, 0.5, 0.2, 0.15, 0.1, 0.1, 0.7, 1) tip.label <- paste("t", 1:5, sep="") node.label <- paste("n", 1:4, sep="") edge.label <- paste("e", 1:8, sep="") order <- "preorder" annote <- list(x="annotation") phy <- phylo4(edge, edge.length=edge.length, tip.label=tip.label, node.label=node.label, edge.label=edge.label, order=order, annote=annote) ## test each slot expect_equal(edge, unname(edges(phy))) expect_equal(edge.length, unname(edgeLength(phy))) expect_equal(4L, nNodes(phy)) expect_equal(tip.label, unname(tipLabels(phy))) expect_equal(node.label, unname(nodeLabels(phy))) expect_equal(edge.label, unname(edgeLabels(phy))) expect_equal(order, edgeOrder(phy)) expect_equal(annote, phy@annote) ## test improper cases ## expect_error(phylo4(edge, edge.length=999)) # recycling is allowed? FM (20140506: yes) expect_error(phylo4(edge, tip.label=999)) expect_error(phylo4(edge, node.label=999)) ## expect_error(phylo4(edge, edge.label=999)) # recycling is allowed? FM (20140506: yes) expect_error(phylo4(edge, order="invalid order")) expect_error(phylo4(edge, annote="invalid annotation")) }) ## note: this method mostly just wraps phylo->phylo4 coercion, which is ## tested more thoroughly in runit.setAs-methods.R; focus here is on ## annote and check.node.labels arguments test_that("phylo4 can be built from phylo (tests on what's not done in setAs tests)", { tr <- ape::read.tree(text="(((t1:0.2,(t2:0.1,t3:0.1):0.15):0.5,t4:0.7):0.2,t5:1):0.4;") ## ## annote ## annote <- list(x="annotation") phy <- phylo4(tr, annote=annote) expect_equal(annote, phy@annote) ## ## check.node.labels ## # case 0: no node labels phy <- phylo4(tr) expect_true(!hasNodeLabels(phy)) # case 1: keep unique character labels tr$node.label <- paste("n", 1:4, sep="") phy <- phylo4(tr, check.node.labels="keep") expect_equal(tr$node.label, unname(nodeLabels(phy))) # keeping node labels should be the default expect_equal(phy, phylo4(tr)) # case 2: keep unique number-like character labels tr$node.label <- as.character(1:4) phy <- phylo4(tr, check.node.labels="keep") expect_equal(tr$node.label, unname(nodeLabels(phy))) # case 3: keep unique numeric labels, but convert to character tr$node.label <- as.numeric(1:4) phy <- phylo4(tr, check.node.labels="keep") expect_equal(as.character(tr$node.label), unname(nodeLabels(phy))) # case 4: must drop non-unique labels tr$node.label <- rep("x", 4) ## with options allow.duplicated.labels="fail" phylobase.options(allow.duplicated.labels="fail") expect_error(phylo4(tr)) expect_error(phylo4(tr, check.node.labels="keep")) phylobase.options(op) ## test dropping node labels phy <- phylo4(tr, check.node.labels="drop") expect_true(!hasNodeLabels(phy)) ## with options allow.duplicated.labels="ok" phylobase.options(allow.duplicated.labels="ok") phy <- phylo4(tr) expect_equal(unname(nodeLabels(phy)), tr$node.label) phy <- phylo4(tr, check.node.labels="keep") expect_equal(unname(nodeLabels(phy)), tr$node.label) phy <- phylo4(tr, check.node.labels="drop") expect_true(!hasNodeLabels(phy)) phylobase.options(op) }) test_that("nexml to phylo4", { nxml <- RNeXML::nexml_read(compFile) phy4 <- phylo4(nxml) expect_true(all(tipLabels(phy4) %in% paste("taxon", 1:10, sep="_"))) expect_equal(nEdges(phy4), 19) }) phylobase/tests/testthat/test.prune.R0000644000176200001440000000066714553646170017520 0ustar liggesusers# # --- Test prune.R --- # data(geospiza) gtree <- extractTree(geospiza) context("prune") test_that("prune works on phylo4 objects", { # function(phy, tip, trim.internal = TRUE, subtree = FALSE, ...) expect_equal(gtree, prune(gtree, character(0))) }) test_that("prune works on phylo4d objects", { # function(phy, tip, trim.internal = TRUE, subtree = FALSE, ...) expect_equal(geospiza, prune(geospiza, character(0))) }) phylobase/tests/testthat/test.treePlot.R0000644000176200001440000000175514553646170020164 0ustar liggesusers## ## --- Test treePlot.R --- ## context("check that treePlot returns warnings when providing incorrectly formatted phylo4d objects.") test_that("phylo4d gives warning when there is no data", { phyd <- phylo4d(ape::rcoal(5), tip.data=data.frame()) expect_warning(plot(phyd), "tree has no tip data to plot") }) test_that("phylo4d gives warning when there is data but they can't be plotted", { phyd <- phylo4d(ape::rcoal(5), tip.data=data.frame(letters[1:5], letters[6:10])) expect_warning(plot(phyd), "only numeric data can be plotted at this time") }) ## test.treePlot <- function() { ## } ## test.plotOneTree <- function() { ## } ## test.phyloXXYY <- function() { ## # function(phy, tip.order = NULL) ## } ## test..bubLegendGrob <- function() { ## } ## test.drawDetails.bubLegend <- function() { ## } ## test.phylobubbles <- function() { ## } ## test.tip.data.plot <- function() { ## } ## test.plot.phylo4 <- function() { ## # signature(x='phylo4', y='missing') ## } phylobase/tests/testthat/test.class-phylo4d.R0000644000176200001440000003123114553646170021044 0ustar liggesusers# # --- Test class-phylo4d.R --- # ### Get all the test files if (is.na(Sys.getenv("R_CMD_CHECK", unset = NA))) { pth <- file.path(getwd(), "..", "inst", "nexmlfiles") } else { pth <- system.file(package = "phylobase", "nexmlfiles") } ## create ape::phylo version of a simple tree for testing nwk <- "((t1:0.1,t2:0.2)n7:0.7,(t3:0.3,(t4:0.4,t5:0.5)n9:0.9)n8:0.8)n6:0.6;" tr <- ape::read.tree(text=nwk) # create analogous phylo4 object with a full complement of valid slots ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9)) descendant <- as.integer(c(7,1,2,8,3,6,9,4,5)) edge <- cbind(ancestor, descendant) nid.tip <- 1:5 nid.int <- 6:9 nid.all <- c(nid.tip, nid.int) lab.tip <- paste("t", nid.tip, sep="") lab.int <- paste("n", nid.int, sep="") lab.all <- c(lab.tip, lab.int) elen <- descendant/10 elab <- paste("e", ancestor, descendant, sep="-") phy <- phylo4(x=edge, tip.label=lab.tip, node.label=lab.int, edge.length=elen, edge.label=elab) # create altered version such that each slot is out of order with # respect to all others; methods should be able to handle this phy.alt <- phy phy.alt@label <- rev(phy@label) phy.alt@edge <- phy@edge[c(6:9, 1:5), ] phy.alt@edge.length <- phy@edge.length[c(7:9, 1:6)] phy.alt@edge.label <- phy@edge.label[c(8:9, 1:7)] # create data to add to phylo4 to create phylo4d, but with data rows out # of order set.seed(1) nid.tip.r <- sample(nid.tip) nid.int.r <- sample(nid.int) nid.all.r <- sample(c(nid.tip, nid.int)) allDt <- data.frame(a = letters[nid.all.r], b = 10 * nid.all.r, stringsAsFactors = TRUE) tipDt <- data.frame(c = letters[nid.tip.r], d = 10 * nid.tip.r, stringsAsFactors = TRUE) nodDt <- data.frame(c=letters[nid.int.r], e=10*nid.int.r, stringsAsFactors = TRUE) ## set row.names as numeric node IDs (may be changed in tests below) row.names(allDt) <- nid.all.r row.names(tipDt) <- nid.tip.r row.names(nodDt) <- nid.int.r ## NeXML files compFile <- file.path(pth, "comp_analysis.xml") stopifnot(file.exists(compFile)) #----------------------------------------------------------------------- context("test phylo4d class") test_that("phylo4d can be built from phylo4", { ## case 1: add data matching only on row position row.names(allDt) <- NULL row.names(tipDt) <- NULL row.names(nodDt) <- NULL ## these should fail because row.names don't match nodes expect_error(phylo4d(phy.alt, tip.data=tipDt, rownamesAsLabels=TRUE)) expect_error(phylo4d(phy.alt, node.data=nodDt)) ## brute force: no matching; with tip data phyd <- phylo4d(phy.alt, tip.data=tipDt, match.data=FALSE) expect_equal(phyd@data, data.frame(tipDt, row.names=nid.tip)) expect_equal(tdata(phyd, "tip"), data.frame(tipDt, row.names=lab.tip)) ## brute force: no matching; with node data phyd <- phylo4d(phy.alt, node.data=nodDt, match.data=FALSE) expect_equal(phyd@data, data.frame(nodDt, row.names=nid.int)) expect_equal(tdata(phyd, "internal"), data.frame(nodDt, row.names=lab.int)) ## brute force: no matching; with all.data phyd <- phylo4d(phy.alt, all.data=allDt, match.data=FALSE) expect_equal(phyd@data, data.frame(allDt, row.names=nid.all)) expect_equal(tdata(phyd, "all"), data.frame(allDt, row.names=lab.all)) ## brute force: no matching; with tip & node data ## no merging (data names don't match) phyd <- phylo4d(phy.alt, tip.data=tipDt["d"], node.data=nodDt["e"], match.data=FALSE) expect_equal(phyd@data, data.frame(rbind(data.frame(tipDt["d"], e=NA_real_), data.frame(d=NA_real_, nodDt["e"])), row.names=nid.all)) expect_equal(tdata(phyd, "tip"), data.frame(tipDt["d"], e=NA_real_, row.names=lab.tip)) expect_equal(tdata(phyd, "internal"), data.frame(d=NA_real_, nodDt["e"], row.names=lab.int)) ## brute force: no matching; with tip & node data ## merging (common data names) phyd <- phylo4d(phy.alt, tip.data=tipDt["c"], node.data=nodDt["c"], match.data=FALSE) expect_equal(phyd@data, data.frame(rbind(tipDt["c"], nodDt["c"]), row.names=nid.all)) expect_equal(tdata(phyd, "tip"), data.frame(c=factor(tipDt$c, levels=letters[nid.all]), row.names=lab.tip)) expect_equal(tdata(phyd, "internal"), data.frame(c=factor(nodDt$c, levels=letters[nid.all]), row.names=lab.int)) ## case 2: add data matching on numeric (node ID) row.names row.names(allDt) <- nid.all.r row.names(tipDt) <- nid.tip.r row.names(nodDt) <- nid.int.r ## match with node numbers, tip data phyd <- phylo4d(phy.alt, tip.data=tipDt) expect_equal(phyd@data, data.frame(tipDt[order(nid.tip.r),], row.names=nid.tip)) expect_equal(tdata(phyd, "tip"), data.frame(tipDt[order(nid.tip.r),], row.names=lab.tip)) ## match with node numbers, node data phyd <- phylo4d(phy.alt, node.data=nodDt) expect_equal(phyd@data, data.frame(nodDt[order(nid.int.r),], row.names=nid.int)) expect_equal(tdata(phyd, "internal"), data.frame(nodDt[order(nid.int.r),], row.names=lab.int)) ## match with node numbers, tip & node data, no merge phyd <- phylo4d(phy.alt, tip.data=tipDt["d"], node.data=nodDt["e"]) expect_equal(phyd@data, data.frame(rbind(data.frame( d=tipDt[order(nid.tip.r), "d"], e=NA_real_), data.frame(d=NA_real_, e=nodDt[order(nid.int.r), "e"])), row.names=nid.all)) expect_equal(tdata(phyd, "tip"), data.frame(d=tipDt[order(nid.tip.r), "d"], e=NA_real_, row.names=lab.tip)) expect_equal(tdata(phyd, "internal"), data.frame(d=NA_real_, e=nodDt[order(nid.int.r), "e"], row.names=lab.int)) ## match with node numbers, tip & all data phyd <- phylo4d(phy.alt, tip.data=tipDt, all.data=allDt) merged <- data.frame(merge(allDt[order(nid.all.r),], tipDt[order(nid.tip.r),], all=TRUE, by=0)[-1]) expect_equal(phyd@data, data.frame(merged, row.names=nid.all)) expect_equal(tdata(phyd, "all"), data.frame(merged, row.names=lab.all)) ## match with node numbers, node & all data phyd <- phylo4d(phy.alt, node.data=nodDt, all.data=allDt) merged <- data.frame(merge(allDt[order(nid.all.r),], nodDt[order(nid.int.r),], all=TRUE, by=0)[-1]) expect_equal(phyd@data, data.frame(merged, row.names=nid.all)) expect_equal(tdata(phyd, "all"), data.frame(merged, row.names=lab.all)) ## match with node numbers, tip, node & all data phyd <- phylo4d(phy.alt, tip.data=tipDt, node.data=nodDt, all.data=allDt) # merge alldata with common tip and node data m1 <- data.frame(merge(allDt, rbind(tipDt["c"], nodDt["c"]), all=TRUE, by=0)[-1]) # merge distinct columns of tipdata and nodedata m2 <- data.frame(merge(tipDt["d"], nodDt["e"], all=TRUE, by=0)[-1]) # ...now merge these together merged <- data.frame(merge(m1, m2, by=0)[-1]) expect_equal(phyd@data, data.frame(merged, row.names=nid.all)) expect_equal(tdata(phyd, "tip"), data.frame(merged[nid.tip,], row.names=lab.tip, check.names=FALSE)) expect_equal(tdata(phyd, "internal"), data.frame(merged[nid.int,], row.names=lab.int, check.names=FALSE)) expect_equal(tdata(phyd, "all"), data.frame(merged, row.names=lab.all)) ## as above, but without merging common tip and node column phyd <- phylo4d(phy.alt, tip.data=tipDt, node.data=nodDt, all.data=allDt, merge.data=FALSE) m3 <- data.frame(merge(tipDt, nodDt, all=TRUE, by=0, suffix=c(".tip", ".node"))[-1]) merged <- data.frame(merge(allDt, m3, by=0)[-1]) expect_equal(phyd@data, data.frame(merged, row.names=nid.all)) expect_equal(tdata(phyd, "tip"), data.frame(merged[nid.tip,], row.names=lab.tip, check.names=FALSE)) expect_equal(tdata(phyd, "internal"), data.frame(merged[nid.int,], row.names=lab.int, check.names=FALSE)) expect_equal(tdata(phyd, "all"), data.frame(merged, row.names=lab.all)) ## case 3: add data matching on character (label) row.names for tips row.names(tipDt) <- c(lab.tip, lab.int)[nid.tip.r] row.names(nodDt) <- c(lab.tip, lab.int)[nid.int.r] ## match with names, tip data phyd <- phylo4d(phy.alt, tip.data=tipDt) expect_equal(phyd@data, data.frame(tipDt[order(nid.tip.r),], row.names=nid.tip)) expect_equal(tdata(phyd, "tip"), data.frame(tipDt[order(nid.tip.r),], row.names=lab.tip)) ## case 4: add data matching on mixed rowname types (for tips and ## for internal nodes) row.names(allDt)[match(nid.tip.r, nid.all.r)] <- lab.tip[nid.tip.r] row.names(allDt)[match(nid.int.r, nid.all.r)] <- nid.int.r ## match with names for tips and numbers for nodes with all data phyd <- phylo4d(phy.alt, all.data=allDt) expect_equal(tdata(phyd, "all"), data.frame(allDt[match(nid.all, nid.all.r),], row.names=lab.all)) expect_equal(tdata(phyd, "tip"), data.frame(allDt[match(nid.tip, nid.all.r),], row.names=lab.tip)) expect_equal(tdata(phyd, "internal"), data.frame(allDt[match(nid.int, nid.all.r),], row.names=lab.int)) expect_equal(phyd@data, data.frame(allDt[match(nid.all, nid.all.r),], row.names=nid.all)) }) ## test.phylo4d.matrix <- function() { ## } # note: this method mostly does phylo4(phylo), then phylo4d(phylo4), # then addData methods, which are tested more thoroughly elsewhere; # focus here is on metadata and check.node.labels="asdata" arguments test_that("phylo4d can be built from phylo object", { # function(x, tip.data=NULL, node.data=NULL, all.data=NULL, # check.node.labels=c("keep", "drop", "asdata"), annote=list(), # metadata=list(), ...) ## show that method basically just wraps phylo4d("phylo4") phyd.tr <- phylo4d(tr, tip.data=tipDt, node.data=nodDt, all.data=allDt, match.data=TRUE, merge.data=TRUE) expect_true(class(phyd.tr)=="phylo4d") phyd.phy <- phylo4d(phy.alt, tip.data=tipDt, node.data=nodDt, all.data=allDt, match.data=TRUE, merge.data=TRUE) # reorder for edge order consistency, then test each slot (except # edge labels, b/c phylo object has none) phyd.tr <- reorder(phyd.tr) phyd.phy <- reorder(phyd.phy) expect_equal(edges(phyd.tr), edges(phyd.phy)) expect_equal(edgeLength(phyd.tr), edgeLength(phyd.phy)) expect_equal(nNodes(phyd.tr), nNodes(phyd.phy)) expect_equal(tipLabels(phyd.tr), tipLabels(phyd.phy)) expect_equal(nodeLabels(phyd.tr), nodeLabels(phyd.phy)) expect_equal(edgeOrder(phyd.tr), edgeOrder(phyd.phy)) expect_equal(phyd.tr@annote, phyd.phy@annote) # other misc checks expect_equal(phylo4d(phylo4(tr)), phylo4d(tr)) expect_equal(phylo4d(phylo4(tr, check.node.labels="drop")), phylo4d(tr, check.node.labels="drop")) ## ## metadata ## metadata <- list(x="metadata") phyd <- phylo4d(tr, metadata=metadata) expect_equal(metadata, phyd@metadata) ## ## check.node.labels ## # case 0: no node labels tr$node.label <- NULL phyd <- phylo4d(tr) expect_true(!hasNodeLabels(phyd)) # case 1: convert character labels as data tr$node.label <- paste("n", 1:4, sep="") phyd <- phylo4d(tr, check.node.labels="asdata") expect_true(!hasNodeLabels(phyd)) expect_equal(tdata(phyd, "internal")$labelValues, as.factor(tr$node.label)) # case 2: convert number-like characters labels to numeric data tr$node.label <- as.character(1:4) phyd <- phylo4d(tr, check.node.labels="asdata") expect_true(!hasNodeLabels(phyd)) expect_equal(tdata(phyd, "internal")$labelValues, as.numeric(tr$node.label)) # case 3: convert numeric labels to numeric data tr$node.label <- as.numeric(1:4) phyd <- phylo4d(tr, check.node.labels="asdata") expect_true(!hasNodeLabels(phyd)) expect_equal(tdata(phyd, "internal")$labelValues, tr$node.label) # case 4: non-unique labels can be converted to data tr$node.label <- rep(99, 4) phyd <- phylo4d(tr) expect_equal(unname(nodeLabels(phyd)), as.character(tr$node.label)) phyd <- phylo4d(tr, check.node.labels="asdata") expect_true(!hasNodeLabels(phyd)) expect_equal(tdata(phyd, "internal", label.type="column")$labelValues, tr$node.label) }) ## phylo4d->phylo4d is currently unallowed test_that("phylo4d to phylo4d throws error", { phyd <- phylo4d(phy) expect_error(phylo4d(phyd)) }) test_that("nexml to phylo4d", { nxml <- RNeXML::nexml_read(compFile) phy4d <- phylo4d(nxml) nxmldt <- RNeXML::get_characters(nxml) phy4d2 <- phylo4d(get_trees(nxml), nxmldt[sample(1:nrow(nxmldt)), ]) expect_true(all(tipLabels(phy4d) %in% paste("taxon", 1:10, sep="_"))) expect_equal(nEdges(phy4d), 19) expect_equal(phy4d, phy4d2) expect_equal(ncol(tdata(phy4d, "tip")), 2) expect_true(all(names(tdata(phy4d, "tip")) %in% c("log.snout.vent.length", "reef.dwelling"))) }) phylobase/tests/testthat/test.readNCL.R0000644000176200001440000007037014553646170017635 0ustar liggesusers# # --- Test readNCL.R --- # ### Get all the test files if (is.na(Sys.getenv("R_CMD_CHECK", unset = NA))) { pth <- file.path(getwd(), "..", "inst", "nexusfiles") } else { pth <- system.file(package = "phylobase", "nexusfiles") } ## co1.nex -- typical output from MrBayes. Contains 2 identical trees, the first ## one having posterior probabilities as node labels co1File <- file.path(pth, "co1.nex") ## MultiLineTrees.nex -- 2 identical trees stored on several lines multiLinesFile <- file.path(pth, "MultiLineTrees.nex") ## treeWithDiscreteData.nex -- Mesquite file with discrete data treeDiscDt <- file.path(pth, "treeWithDiscreteData.nex") ## treeWithPolyExcludedData.nex -- Mesquite file with polymorphic and excluded ## characters treePolyDt <- file.path(pth, "treeWithPolyExcludedData.nex") ## treeWithContinuousData.nex -- Mesquite file with continuous characters treeContDt <- file.path(pth, "treeWithContinuousData.nex") ## treeWithDiscAndContData.nex -- Mesquite file with both discrete and ## continuous data treeDiscCont <- file.path(pth, "treeWithDiscAndContData.nex") ## noStateLabels.nex -- Discrete characters with missing state labels noStateLabels <- file.path(pth, "noStateLabels.nex") ## Newick trees newick <- file.path(pth, "newick.tre") ## Test with trees that don't include all the taxa listed in TAXA block treeSubset <- file.path(pth, "testSubsetTaxa.nex") ## Contains representation of data associated with continuous data ExContDataFile <- file.path(pth, "ExContData.Rdata") stopifnot(file.exists(co1File)) stopifnot(file.exists(treeDiscDt)) stopifnot(file.exists(multiLinesFile)) stopifnot(file.exists(treePolyDt)) stopifnot(file.exists(treeContDt)) stopifnot(file.exists(treeDiscCont)) stopifnot(file.exists(ExContDataFile)) stopifnot(file.exists(noStateLabels)) stopifnot(file.exists(treeSubset)) op <- phylobase.options() ## function (file, simplify=TRUE, type=c("all", "tree", "data"), ## char.all=FALSE, polymorphic.convert=TRUE, levels.uniform=TRUE, ## check.node.labels=c("keep", "drop", "asdata")) ## ########### CO1 -- MrBayes file -- tree only ## Tree properties ## Labels labCo1 <- c("Cow", "Seal", "Carp", "Loach", "Frog", "Chicken", "Human", "Mouse", "Rat", "Whale", NA, NA, NA, NA, NA, NA, NA, NA) names(labCo1) <- 1:18 ## Edge lengths eLco1 <- c(0.143336, 0.225087, 0.047441, 0.055934, 0.124549, 0.204809, 0.073060, 0.194575, 0.171296, 0.222039, 0.237101, 0.546258, 0.533183, 0.154442, 0.134574, 0.113163, 0.145592) names(eLco1) <- c("11-1", "11-2", "11-12", "12-13", "13-14", "14-15", "15-16", "16-17", "17-3", "17-4", "16-5", "15-6", "14-7", "13-18", "18-8", "18-9", "12-10") ## Node types nTco1 <- c("tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "internal", "internal", "internal", "internal", "internal", "internal", "internal", "internal") names(nTco1) <- 1:18 ## Label values lVco1 <- c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 0.93, 0.88, 0.99, 1.00, 0.76, 1.00, 1.00) context("readNCL can deal with simple NEXUS files (tree only)") test_that("file with 2 trees (warning normal)", { ## Read trees co1 <- suppressWarnings(readNCL(file=co1File, check.node.labels="asdata")) ## Tree 1 co1Tree1 <- co1[[1]] edgeNm <- paste(edges(co1Tree1)[, "ancestor"], edges(co1Tree1)[, "descendant"], sep = "-") expect_equal(labels(co1Tree1), labCo1) # check labels expect_equal(edgeLength(co1Tree1), eLco1[edgeNm]) # check edge lengths expect_equal(nodeType(co1Tree1), nTco1) # check node types expect_equal(as(co1Tree1, "data.frame")$labelValues, lVco1) # check label value ## Tree 2 co1Tree2 <- co1[[2]] expect_equal(labels(co1Tree2), labCo1) # check labels expect_equal(edgeLength(co1Tree2), eLco1[edgeNm]) # check edge lengths expect_equal(nodeType(co1Tree2), nTco1) # check node types }) test_that("test option simplify", { ## Check option simplify co1 <- readNCL(file=co1File, check.node.labels="asdata", simplify=TRUE) edgeNm <- paste(edges(co1)[, "ancestor"], edges(co1)[, "descendant"], sep = "-") expect_equal(length(co1), as.integer(1)) # make sure there is only one tree expect_equal(labels(co1), labCo1) # check labels expect_equal(edgeLength(co1), eLco1[edgeNm]) # check edge lengths expect_equal(nodeType(co1), nTco1) # check node type expect_equal(as(co1, "data.frame")$labelValues, lVco1) # check label values }) test_that("test option check.node.labels", { ## Check option check.node.labels phylobase.options(allow.duplicated.labels="fail") expect_error(readNCL(file=co1File, check.node.labels="keep")) # fail because labels aren't unique phylobase.options(op) phylobase.options(allow.duplicated.labels="ok") co1 <- readNCL(file=co1File, check.node.labels="keep", simplify=TRUE) expect_equal(nodeLabels(co1), setNames(c(NA, "0.93", "0.88", "0.99", "1.00", "0.76", "1.00", "1.00"), 11:18)) phylobase.options(op) co1 <- readNCL(file=co1File, check.node.labels="drop", simplify=TRUE) edgeNm <- paste(edges(co1)[, "ancestor"], edges(co1)[, "descendant"], sep = "-") expect_equal(labels(co1), labCo1) # check labels expect_equal(edgeLength(co1), eLco1[edgeNm]) # check edge lengths expect_equal(nodeType(co1), nTco1) # check node type expect_equal(as(co1, "data.frame")$labelValues, NULL) # check label values don't exist }) test_that("labelled root", { tmp_file <- tempfile() cat("(A:0.1,B:0.2,(C:0.3,D:0.4)E:0.5)F;", file = tmp_file) ape_tree <- as(ape::read.tree(file = tmp_file), "phylo4") ph4_tree <- readNewick(file = tmp_file) expect_equal(tipLabels(ape_tree), tipLabels(ph4_tree)) expect_equal(nodeLabels(ape_tree), nodeLabels(ph4_tree)) expect_equal(sort(edgeLength(ape_tree)), sort(edgeLength(ape_tree))) }) test_that("readNCL can handle multi line files", { ## ########### Mutli Lines -- tree only multiLines <- readNCL(file=multiLinesFile) ## load correct representation and make sure that the trees read ## match it ml <- rncl::read_nexus_phylo(file = multiLinesFile) ml1 <- as(ml[[1]], "phylo4") ml2 <- as(ml[[2]], "phylo4") expect_equal(tipLabels(multiLines[[1]]), tipLabels(ml1)) expect_equal(tipLabels(multiLines[[2]]), tipLabels(ml2)) expect_equivalent(sort(edgeLength(multiLines[[1]])), sort(edgeLength(ml1))) expect_equivalent(sort(edgeLength(multiLines[[2]])), sort(edgeLength(ml2))) expect_equal(nodeType(multiLines[[1]]), nodeType(ml1)) expect_equal(nodeType(multiLines[[2]]), nodeType(ml2)) }) ## ########### Tree + data -- file from Mesquite context("readNCL can handle files with tree & data") ## tree properties labTr <- c("Myrmecocystussemirufus", "Myrmecocystusplacodops", "Myrmecocystusmendax", "Myrmecocystuskathjuli", "Myrmecocystuswheeleri", "Myrmecocystusmimicus", "Myrmecocystusdepilis", "Myrmecocystusromainei", "Myrmecocystusnequazcatl", "Myrmecocystusyuma", "Myrmecocystuskennedyi", "Myrmecocystuscreightoni", "Myrmecocystussnellingi", "Myrmecocystustenuinodis", "Myrmecocystustestaceus", "Myrmecocystusmexicanus", "Myrmecocystuscfnavajo", "Myrmecocystusnavajo", NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA) names(labTr) <- 1:35 eTr <- c(NA, 1.699299, 12.300701, 0.894820, 0.836689, 10.569191, 4.524387, 6.044804, 0.506099, 0.198842, 0.689044, 4.650818, 2.926053, 1.724765, 1.724765, 4.255993, 1.083870, 1.083870, 0.802512, 2.027251, 2.708942, 2.708942, 0.284767, 4.451425, 2.257581, 2.193845, 2.193845, 8.635503, 2.770378, 2.770378, 8.275077, 5.724923, 2.855375, 2.869547, 2.869547) names(eTr) <- c("0-19", "19-20", "20-15", "20-21", "21-22", "22-12", "22-23", "23-11", "23-24", "24-25", "25-26", "26-3", "26-27", "27-1", "27-2", "25-28", "28-4", "28-5", "24-29", "29-30", "30-6", "30-7", "29-31", "31-10", "31-32", "32-8", "32-9", "21-33", "33-13", "33-14", "19-34", "34-16", "34-35", "35-17", "35-18") nTtr <- c("tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "tip", "root", "internal", "internal", "internal", "internal", "internal", "internal", "internal", "internal", "internal", "internal", "internal", "internal", "internal", "internal", "internal", "internal") names(nTtr) <- 1:35 ## data to test against dtTest1 <- data.frame(time = factor(c(2,1,0,0,0,0,2,0,2,0,0,0,0,1,1,1,0,1)), subgenus = factor(c(2,1,0,0,0,0,2,0,2,0,0,0,0,1,1,2,0,1))) row.names(dtTest1) <- c("Myrmecocystuscfnavajo","Myrmecocystuscreightoni", "Myrmecocystusdepilis","Myrmecocystuskathjuli", "Myrmecocystuskennedyi","Myrmecocystusmendax", "Myrmecocystusmexicanus","Myrmecocystusmimicus", "Myrmecocystusnavajo","Myrmecocystusnequazcatl", "Myrmecocystusplacodops","Myrmecocystusromainei", "Myrmecocystussemirufus","Myrmecocystussnellingi", "Myrmecocystustenuinodis","Myrmecocystustestaceus", "Myrmecocystuswheeleri","Myrmecocystusyuma") dtTest2 <- dtTest1 levels(dtTest2$time) <- c("diurnal", "crepuscular", "nocturnal") levels(dtTest2$subgenus) <- c("Endiodioctes", "Eremnocystus", "Myrmecocystus") p4 <- "phylo4" p4d <- "phylo4d" attributes(p4) <- attributes(p4d) <- list(package="phylobase") test_that("readNCL can deal with the tree only", { ## Tree only tr <- readNCL(file=treeDiscDt, type="tree") tr2 <- rncl::read_nexus_phylo(file = treeDiscDt) tr2 <- as(tr2, "phylo4") expect_equal(labels(tr), labTr) # check labels expect_equal(nodeType(tr), nTtr) # check node types expect_equal(class(tr), p4) # check class expect_equal(edgeLength(tr), edgeLength(tr2)[names(edgeLength(tr))]) }) test_that("readNCL can deal with data only", { ## Data only dt1 <- readNCL(file=treeDiscDt, type="data", return.labels=FALSE, levels.uniform=FALSE) expect_equal(dt1, dtTest1) dt2 <- readNCL(file=treeDiscDt, type="data", return.labels=TRUE, levels.uniform=FALSE) expect_equal(dt2, dtTest2) }) test_that("readNCL can deal with tree + data", { ## Tree + Data trDt1 <- readNCL(file=treeDiscDt, type="all", return.labels=FALSE, levels.uniform=FALSE) expect_equal(labels(trDt1), labTr) # check labels expect_equivalent(sort(edgeLength(trDt1)), sort(eTr)) # check edge lengths expect_equal(nodeType(trDt1), nTtr) # check node types expect_equal(class(trDt1), p4d) # check class expect_equal(tdata(trDt1, type="tip")[rownames(dtTest1), ], dtTest1) trDt2 <- readNCL(file=treeDiscDt, type="all", return.labels=TRUE, levels.uniform=FALSE) expect_equal(labels(trDt2), labTr) # check labels expect_equivalent(sort(edgeLength(trDt2)), sort(eTr)) # check edge lengths expect_equal(nodeType(trDt2), nTtr) # check node types expect_equal(class(trDt2), p4d) # check class expect_equal(tdata(trDt2, type="tip")[rownames(dtTest2), ], dtTest2) }) ## ########## Tree + Data -- Test for polymorphic.convert, levels.uniform and char.all ## data to test against ## dtTest 3 -- levels.uniform=FALSE, return.labels=FALSE, polymorphic.convert=FALSE dtPoly1 <- data.frame(Test1=factor(c(0,0,1,1,0,NA,1,1,1,0,0,NA,1,1,NA,0,1, NA)), Test2=factor(c(0,0,0,0,0,NA,0,1,0,1,1,"{0,1}",NA,0,NA,0,"{0,1}",1)), Test3=factor(c(1,1,1,0,0,0,2,"{0,1,2}",0,NA,0,"{0,1}",0,1,0,0,"{0,1,2}",1)), row.names=c("Myrmecocystussemirufus","Myrmecocystusplacodops", "Myrmecocystusmendax","Myrmecocystuskathjuli", "Myrmecocystuswheeleri","Myrmecocystusmimicus", "Myrmecocystusdepilis","Myrmecocystusromainei", "Myrmecocystusnequazcatl","Myrmecocystusyuma", "Myrmecocystuskennedyi","Myrmecocystuscreightoni", "Myrmecocystussnellingi","Myrmecocystustenuinodis", "Myrmecocystustestaceus","Myrmecocystusmexicanus", "Myrmecocystuscfnavajo","Myrmecocystusnavajo")) ## dtPoly2 -- levels.uniform=FALSE, return.labels=FALSE, polymorphic.convert=TRUE dtPoly2 <- dtPoly1 dtPoly2[c(12,17),2] <- NA dtPoly2[c(8,12,17),3] <- NA dtPoly2$Test1 <- factor(dtPoly2$Test1) dtPoly2$Test2 <- factor(dtPoly2$Test2) dtPoly2$Test3 <- factor(dtPoly2$Test3) ## dtPoly3 -- levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=TRUE dtPoly3 <- dtPoly2 levels(dtPoly3$Test1) <- c("test1A", "test1B") levels(dtPoly3$Test2) <- c("test2A", "test2B") levels(dtPoly3$Test3) <- c("test3A", "test3B", "test3C") ## dtPoly4 -- levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=FALSE ## not yet implemented ## dtPoly5 -- levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=FALSE dtPoly5 <- dtPoly1 levels(dtPoly5$Test1) <- levels(dtPoly5$Test2) <- levels(dtPoly5$Test3) <- union(levels(dtPoly1$Test1), c(levels(dtPoly1$Test2), levels(dtPoly1$Test3))) ## dtPoly6 -- levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=TRUE dtPoly6 <- dtPoly2 levels(dtPoly6$Test1) <- levels(dtPoly6$Test2) <- levels(dtPoly6$Test3) <- union(levels(dtPoly2$Test1), c(levels(dtPoly2$Test2), levels(dtPoly2$Test3))) ## dtPoly7 -- levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=FALSE ## not yet implemented ## dtPoly8 -- levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=TRUE dtPoly8 <- dtPoly3 levels(dtPoly8$Test1) <- levels(dtPoly8$Test2) <- levels(dtPoly8$Test3) <- union(levels(dtPoly3$Test1), c(levels(dtPoly3$Test2), levels(dtPoly3$Test3))) ## dtPoly5F -- char.all=FALSE, levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=FALSE dtPoly5F <- dtPoly1[, 1:2] levels(dtPoly5F$Test1) <- levels(dtPoly5F$Test2) <- union(levels(dtPoly1$Test1), levels(dtPoly1$Test2)) ## dtPoly6F -- char.all=FALSE, levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=TRUE dtPoly6F <- dtPoly2[, 1:2] levels(dtPoly6F$Test1) <- levels(dtPoly6F$Test2) <- union(levels(dtPoly2$Test1), levels(dtPoly2$Test2)) ## dtPoly8F -- char.all=FALSE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=TRUE dtPoly8F <- dtPoly3[, 1:2] levels(dtPoly8F$Test1) <- levels(dtPoly8F$Test2) <- union(levels(dtPoly3$Test1), levels(dtPoly3$Test2)) test_that("char.all=TRUE, levels.uniform=FALSE, return.labels=FALSE, polymorphic.convert=FALSE", { trChr1 <- readNCL(file=treePolyDt, type="all", polymorphic.convert=FALSE, levels.uniform=FALSE, char.all=TRUE, return.labels=FALSE) expect_equal(labels(trChr1), labTr) # check labels expect_equivalent(sort(edgeLength(trChr1)), sort(eTr)) # check edge lengths expect_equal(nodeType(trChr1), nTtr) # check node types expect_equal(class(trChr1), p4d) # check class expect_equal(tdata(trChr1, "tip"), dtPoly1[tipLabels(trChr1), ]) }) test_that("char.all=TRUE, levels.uniform=FALSE, return.labels=FALSE, polymorphic.convert=TRUE", { trChr2 <- readNCL(file=treePolyDt, type="all", polymorphic.convert=TRUE, levels.uniform=FALSE, return.labels=FALSE, char.all=TRUE) expect_equal(labels(trChr2), labTr) # check labels expect_equivalent(sort(edgeLength(trChr2)), sort(eTr)) # check edge lengths expect_equal(nodeType(trChr2), nTtr) # check node types expect_equal(class(trChr2), p4d) # check class expect_equal(tdata(trChr2, "tip"), dtPoly2[tipLabels(trChr2), ]) }) test_that("char.all=TRUE, levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=TRUE", { trChr3 <- readNCL(file=treePolyDt, type="all", polymorphic.convert=TRUE, levels.uniform=FALSE, char.all=TRUE, return.labels=TRUE) expect_equal(labels(trChr3), labTr) # check labels expect_equivalent(sort(edgeLength(trChr3)), sort(eTr)) # check edge lengths expect_equal(nodeType(trChr3), nTtr) # check node types expect_equal(class(trChr3), p4d) # check class expect_equal(tdata(trChr3, "tip"), dtPoly3[tipLabels(trChr3), ]) }) test_that("char.all=TRUE, levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=FALSE is not yet implemented", { ## trChr4 <- expect_error(readNCL(file=treePolyDt, type="all", levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=FALSE)) }) test_that("char.all=TRUE, levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=FALSE", { trChr5 <- readNCL(file=treePolyDt, type="all", polymorphic.convert=FALSE, levels.uniform=TRUE, char.all=TRUE, return.labels=FALSE) expect_equal(labels(trChr5), labTr) # check labels expect_equivalent(sort(edgeLength(trChr5)), sort(eTr)) # check edge lengths expect_equal(nodeType(trChr5), nTtr) # check node types expect_equal(class(trChr5), p4d) # check class expect_equal(tdata(trChr5, "tip"), dtPoly5[tipLabels(trChr5), ]) }) test_that("char.all=TRUE, levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=TRUE", { trChr6 <- readNCL(file=treePolyDt, type="all", polymorphic.convert=TRUE, levels.uniform=TRUE, char.all=TRUE, return.labels=FALSE) expect_equal(labels(trChr6), labTr) # check labels expect_equivalent(sort(edgeLength(trChr6)), sort(eTr)) # check edge lengths expect_equal(nodeType(trChr6), nTtr) # check node types expect_equal(class(trChr6), p4d) # check class expect_equal(tdata(trChr6, "tip"), dtPoly6[tipLabels(trChr6), ]) }) test_that("char.all=TRUE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=FALSE is not yet implemented", { ## trChr7 <- expect_error(readNCL(file=treePolyDt, type="all", char.all=TRUE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=FALSE)) }) test_that("char.all=TRUE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=TRUE", { trChr8 <- readNCL(file=treePolyDt, type="all", char.all=TRUE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=TRUE) expect_equal(labels(trChr8), labTr) # check labels expect_equivalent(sort(edgeLength(trChr8)), sort(eTr)) # check edge lengths expect_equal(nodeType(trChr8), nTtr) # check node types expect_equal(class(trChr8), p4d) # check class expect_equal(tdata(trChr8, "tip"), dtPoly8[tipLabels(trChr8), ]) }) ## -- with char.all=FALSE test_that("char.all=FALSE, levels.uniform=FALSE, return.labels=FALSE, polymorphic.convert=FALSE", { trChr1F <- readNCL(file=treePolyDt, type="all", polymorphic.convert=FALSE, levels.uniform=FALSE, char.all=FALSE, return.labels=FALSE) expect_equal(labels(trChr1F), labTr) # check labels expect_equivalent(sort(edgeLength(trChr1F)), sort(eTr)) # check edge lengths expect_equal(nodeType(trChr1F), nTtr) # check node types expect_equal(class(trChr1F), p4d) # check class expect_equal(tdata(trChr1F, "tip"), dtPoly1[tipLabels(trChr1F), 1:2]) }) test_that("char.all=FALSE, levels.uniform=FALSE, return.labels=FALSE, polymorphic.convert=TRUE", { trChr2F <- readNCL(file=treePolyDt, type="all", polymorphic.convert=TRUE, levels.uniform=FALSE, return.labels=FALSE, char.all=FALSE) expect_equal(labels(trChr2F), labTr) # check labels expect_equivalent(sort(edgeLength(trChr2F)), sort(eTr)) # check edge lengths expect_equal(nodeType(trChr2F), nTtr) # check node types expect_equal(class(trChr2F), p4d) # check class expect_equal(tdata(trChr2F, "tip"), dtPoly2[tipLabels(trChr2F), 1:2]) }) test_that("char.all=FALSE, levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=TRUE", { trChr3F <- readNCL(file=treePolyDt, type="all", polymorphic.convert=TRUE, levels.uniform=FALSE, char.all=FALSE, return.labels=TRUE) expect_equal(labels(trChr3F), labTr) # check labels expect_equivalent(sort(edgeLength(trChr3F)), sort(eTr)) # check edge lengths expect_equal(nodeType(trChr3F), nTtr) # check node types expect_equal(class(trChr3F), p4d) # check class expect_equal(tdata(trChr3F, "tip"), dtPoly3[tipLabels(trChr3F), 1:2]) }) test_that("char.all=FALSE, levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=FALSE is not yet implemented", { ## trChr4F <- expect_error(readNCL(file=treePolyDt, type="all", levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=FALSE)) }) test_that("char.all=FALSE, levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=FALSE", { trChr5F <- readNCL(file=treePolyDt, type="all", polymorphic.convert=FALSE, levels.uniform=TRUE, char.all=FALSE, return.labels=FALSE) expect_equal(labels(trChr5F), labTr) # check labels expect_equivalent(sort(edgeLength(trChr5F)), sort(eTr)) # check edge lengths expect_equal(nodeType(trChr5F), nTtr) # check node types expect_equal(class(trChr5F), p4d) # check class expect_equal(tdata(trChr5F, "tip"), dtPoly5F[tipLabels(trChr5F), ]) }) test_that("char.all=FALSE, levels.uniform=TRUE, return.labels=FALSE, polymorphic.convert=TRUE", { trChr6F <- readNCL(file=treePolyDt, type="all", polymorphic.convert=TRUE, levels.uniform=TRUE, char.all=FALSE, return.labels=FALSE) expect_equal(labels(trChr6F), labTr) # check labels expect_equivalent(sort(edgeLength(trChr6F)), sort(eTr)) # check edge lengths expect_equal(nodeType(trChr6F), nTtr) # check node types expect_equal(class(trChr6F), p4d) # check class expect_equal(tdata(trChr6F, "tip"), dtPoly6F[tipLabels(trChr6F), ]) }) test_that("char.all=FALSE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=FALSE is not yet implemented", { ## trChr7F <- expect_error(readNCL(file=treePolyDt, type="all", char.all=FALSE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=FALSE)) }) test_that("char.all=FALSE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=TRUE", { trChr8F <- readNCL(file=treePolyDt, type="all", char.all=FALSE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=TRUE) expect_equal(labels(trChr8F), labTr) # check labels expect_equivalent(sort(edgeLength(trChr8F)), sort(eTr)) # check edge lengths expect_equal(nodeType(trChr8F), nTtr) # check node types expect_equal(class(trChr8F), p4d) # check class expect_equal(tdata(trChr8F, "tip"), dtPoly8F[tipLabels(trChr8F), ]) }) ## ########## Tree + Data -- test with continuous Characters test_that("test of readNCL with tree data, with continuous characters", { DtCont <- readNCL(file=treeContDt, type="data") trDtCont <- readNCL(file=treeContDt, type="all") load(ExContDataFile) expect_equal(DtCont, ExContData[rownames(DtCont), ]) expect_equal(tdata(trDtCont, "tip"), ExContData[tipLabels(trDtCont), ]) expect_equal(labels(trDtCont), labTr) # check labels expect_equivalent(sort(edgeLength(trDtCont)), sort(eTr)) # check edge lengths expect_equal(nodeType(trDtCont), nTtr) # check node types expect_equal(class(trDtCont), p4d) # check class }) ## ########## Tree + Data -- both types (Discrete & Continuous) test_that("tree + data for both types (discrete & continuous)", { dtDiscCont <- readNCL(file=treeDiscCont, type="data", levels.uniform=FALSE) trDtDiscCont <- readNCL(file=treeDiscCont, type="all", levels.uniform=FALSE) load(ExContDataFile) dtDiscContTest <- cbind(ExContData, dtTest2[rownames(ExContData), ]) expect_equal(dtDiscCont, dtDiscContTest[rownames(dtDiscCont), ]) expect_equal(tdata(trDtDiscCont, "tip"), dtDiscContTest[tipLabels(trDtDiscCont), ]) expect_equal(labels(trDtDiscCont), labTr) # check labels expect_equivalent(sort(edgeLength(trDtDiscCont)), sort(eTr)) # check edge lengths expect_equal(nodeType(trDtDiscCont), nTtr) # check node types expect_equal(class(trDtDiscCont), p4d) # check class }) ## ########### Check for proper handling of missing files test_that("readNCL can handle missing files", { expect_error(readNCL(file="foo.bar"), regexp="doesn't exist") }) ## ########### Check behavior in case of missing state labels test_that("readNCL warns in case of missing state labels", { expect_warning(readNCL(file=noStateLabels, return.labels=TRUE), regexp="state labels are missing") }) test_that("readNCL warns in case of missing state labels", { expect_warning(dtNoSt <- readNCL(file=noStateLabels, type="data", return.labels=TRUE), regexp="state labels are missing") expect_equal(dtNoSt$char1, factor(c(1,2,0,1))) }) ## ########### Newick files context("test with Newick files") ## Tree representation labNew <- c("a", "b", "c", NA, NA) names(labNew) <- 1:5 eLnew <- c(NA, 1, 4, 2, 3) names(eLnew) <- c("0-4", "4-1", "4-5", "5-2", "5-3") nTnew <- c("tip", "tip", "tip", "root", "internal") names(nTnew) <- 1:5 test_that("check.node.labels='drop' with readNCL", { newTr <- readNCL(file=newick, file.format="newick", check.node.labels="drop") expect_equal(labels(newTr), labNew) expect_equivalent(sort(edgeLength(newTr)), sort(eLnew)) expect_equal(nodeType(newTr), nTnew) }) test_that("check.node.labels='drop' with readNewick", { newTr <- readNewick(file=newick, check.node.labels="drop") expect_equal(labels(newTr), labNew) expect_equivalent(sort(edgeLength(newTr)), sort(eLnew)) expect_equal(nodeType(newTr), nTnew) }) test_that("check.node.labels='asdata' with readNCL", { newTr <- readNCL(file=newick, file.format="newick", check.node.labels="asdata") expect_equal(labels(newTr), labNew) expect_equal(tdata(newTr)$labelValues, factor(c(NA, NA, NA, "yy", "xx"))) }) test_that("check.node.labels='asdata' with readNewick", { newTr <- readNewick(file=newick, check.node.labels="asdata") expect_equal(labels(newTr), labNew) expect_equal(tdata(newTr)$labelValues, factor(c(NA, NA, NA, "yy", "xx"))) }) test_that("check.node.labels='keep' with readNCL", { labNew[4:5] <- c("yy", "xx") newTr <- readNCL(file=newick, file.format="newick", check.node.labels="keep") expect_equal(labels(newTr), labNew) }) test_that("check.node.labels='keep' with readNewick", { labNew[4:5] <- c("yy", "xx") newTr <- readNewick(file=newick, check.node.labels="keep") expect_equal(labels(newTr), labNew) }) ### Test with files where trees don't include all taxa ------------------------- context("Trees that don't contain all the taxa listed in the TAXA block") test_that("first tree is correct", { tr <- readNexus(file = treeSubset) expect_equivalent(rootNode(tr[[1]]), 6) expect_equivalent(rootNode(tr[[2]]), 6) expect_equivalent(rootNode(tr[[3]]), 7) expect_equivalent(tipLabels(tr[[1]]), c("porifera", "ctenophora", "cnidaria", "deuterostomia", "protostomia")) expect_equivalent(tipLabels(tr[[2]]), c("porifera", "ctenophora", "xeno", "deuterostomia", "protostomia")) expect_equivalent(tipLabels(tr[[3]]), c("deuterostomia", "protostomia", "porifera", "ctenophora", "cnidaria", "xeno")) } ) ### Test roundtrip with Myrmecus file ------------------------------------------ context("Compare output from rncl read file and phylobase") test_that("output from rncl::read_nexus_phylo and readNexus match", { tr_ape <- rncl::read_nexus_phylo(file = treeDiscDt) tr_ph4 <- readNexus(file = treeDiscDt, type = "tree") tr_ape <- as(tr_ape, "phylo4") expect_equal(edges(tr_ape)[order(edges(tr_ape)[, 1]), ], edges(tr_ph4)[order(edges(tr_ph4)[, 1]), ]) expect_equal(edgeLength(tr_ape), edgeLength(tr_ph4)[names(edgeLength(tr_ape))]) expect_equal(labels(tr_ape), labels(tr_ph4)) }) phylobase/tests/testthat/test.phylobase.options.R0000644000176200001440000000137114553646170022040 0ustar liggesusers ### ### phylobase.options ### context("phylobase.options()") test_that("test of match.arg", { op <- phylobase.options() ## test match.arg expect_error(phylobase.options(retic="test")) no <- phylobase.options(retic="f") expect_equal(no$retic, "fail") phylobase.options(op) }) test_that("test of multiple arguments", { op <- phylobase.options() ## test multiple args no <- phylobase.options(retic="f", poly="f") expect_equal(no$retic, "fail") expect_equal(no$poly, "fail") phylobase.options(op) }) test_that("test some failures", { op <- phylobase.options() ## check some failures expect_error(phylobase.options(1)) expect_error(phylobase.options("foobar"="foo")) phylobase.options(op) }) phylobase/tests/testthat/test.methods-oldclasses.R0000644000176200001440000000017114553646170022152 0ustar liggesusers# # --- Test methods-oldclasses.R --- # #test.reorder.phylo <- function() { # # function(x, order = 'cladewise') #} phylobase/tests/testthat/test.setAs-Methods.R0000644000176200001440000001460414553646170021043 0ustar liggesusers# # --- Test setAs-Methods.R --- # ### Get all the test files if (is.na(Sys.getenv("R_CMD_CHECK", unset = NA))) { pth <- file.path(getwd(), "..", "inst", "nexmlfiles") } else { pth <- system.file(package = "phylobase", "nexmlfiles") } ## create ape::phylo version of a simple tree for testing nwk <- "((t1:0.1,t2:0.2)n7:0.7,(t3:0.3,(t4:0.4,t5:0.5)n9:0.9)n8:0.8)n6:0.6;" tr <- ape::read.tree(text=nwk) # create analogous phylo4 object with a full complement of valid slots ancestor <- as.integer(c(6,7,7,6,8,0,8,9,9)) descendant <- as.integer(c(7,1,2,8,3,6,9,4,5)) edge <- cbind(ancestor, descendant) nid.tip <- 1:5 nid.int <- 6:9 lab.tip <- paste("t", nid.tip, sep="") lab.int <- paste("n", nid.int, sep="") elen <- descendant/10 elab <- paste("e", ancestor, descendant, sep="-") phy <- phylo4(x=edge, tip.label=lab.tip, node.label=lab.int, edge.length=elen, edge.label=elab) # create altered version such that each slot is out of order with # respect to all others; methods should be able to handle this phy.alt <- phy phy.alt@label <- rev(phy@label) phy.alt@edge <- phy@edge[c(6:9, 1:5), ] phy.alt@edge.length <- phy@edge.length[c(7:9, 1:6)] phy.alt@edge.label <- phy@edge.label[c(8:9, 1:7)] ## NeXML files compFile <- file.path(pth, "comp_analysis.xml") stopifnot(file.exists(compFile)) #----------------------------------------------------------------------- context("setAs methods") test_that("phylo to phylo4", { # simple case as.phy <- as(tr, "phylo4") expect_true(class(as.phy)=="phylo4") expect_equal(tr$edge, unname(edges(as.phy, drop.root=TRUE))) expect_equal(tr$tip.label, unname(tipLabels(as.phy))) expect_equal(tr$node.label, unname(nodeLabels(as.phy))) # TODO: ape keeps the root edge length in $root.edge #expect_equal(tr$edge.length, unname(edgeLength(as.phy))) expect_equal("preorder", edgeOrder(as.phy)) ## test preservation of order attribute as.phy <- as(reorder(tr, "cladewise"), "phylo4") expect_equal("preorder", edgeOrder(as.phy)) as.phy <- as(reorder(tr, "pruningwise"), "phylo4") expect_equal("postorder", edgeOrder(as.phy)) ## test phylo import when only 2 tips tr2 <- ape::drop.tip(tr, 3:ape::Ntip(tr)) expect_equal(nTips(as(tr2, "phylo4")), 2) expect_equal(nNodes(as(tr2, "phylo4")), 1) ## simple roundtrip test phy <- as(tr, "phylo4") expect_equal(tr, as(phy, "phylo")) }) # note: this method mostly just wraps phylo->phylo4 coercion (tested # above) and phylo4d("phylo4") method (tested in runit.class-phylo4d.R) test_that("phylo to phylo4d", { expect_equal(as(tr, "phylo4d"), phylo4d(tr)) phyd <- as(tr, "phylo4d") expect_true(class(phyd)=="phylo4d") # simple roundtrip test phyd <- as(tr, "phylo4d") expect_warning(phyo <- as(phyd, "phylo")) expect_equal(tr, phyo) }) ## test.multiPhylo.As.multiPhylo4 <- function() { ## } ## test.multiPhylo4.As.multiPhylo <- function() { ## } test_that("nexml to phylo4", { nxml <- RNeXML::nexml_read(compFile) phy4 <- as(nxml, "phylo4") expect_true(all(tipLabels(phy4) %in% paste("taxon", 1:10, sep="_"))) expect_equal(nEdges(phy4), 19) }) test_that("nexml to phylo4d", { nxml <- RNeXML::nexml_read(compFile) phy4d <- as(nxml, "phylo4d") nxmldt <- RNeXML::get_characters(nxml) phy4d2 <- phylo4d(get_trees(nxml), nxmldt[sample(1:nrow(nxmldt)), ]) expect_true(all(tipLabels(phy4d) %in% paste("taxon", 1:10, sep="_"))) expect_equal(nEdges(phy4d), 19) expect_equal(phy4d, phy4d2) expect_equal(ncol(tdata(phy4d, "tip")), 2) expect_true(all(names(tdata(phy4d, "tip")) %in% c("log.snout.vent.length", "reef.dwelling"))) }) test_that("phylo4 to phylo", { ## phylo tree in unknown order expect_equal(suppressWarnings(as(phy, "phylo")), tr) # ...now check for warning for unknown order expect_warning(as(phy, "phylo")) # phylo tree in cladewise order tr.cladewise <- reorder(tr, "cladewise") phy.c <- as(tr.cladewise, "phylo4") expect_equal(as(phy.c, "phylo"), tr.cladewise) # phylo tree in pruningwise order tr.pruningwise <- reorder(tr, "pruningwise") phy.p <- as(tr.pruningwise, "phylo4") expect_equal(suppressWarnings(as(phy.p, "phylo")), tr.pruningwise) # after transforming the jumbled tree to phylo and back, edge matrix # and edge slots should still be in the original order, but node slots # should be back in nodeId order phy.r <- reorder(phy.alt) phy.roundtrip.r <- reorder(as(suppressWarnings(as(phy.alt, "phylo")), "phylo4")) expect_equal(edges(phy.roundtrip.r), edges(phy.r)) expect_equal(edgeLength(phy.roundtrip.r), edgeLength(phy.r)) expect_equal(labels(phy.roundtrip.r), labels(phy.r)) }) ## this coerce method is defined implicitly test_that("phylo to phylo4d", { ## phylo tree in unknown order phyd <- as(tr, "phylo4d") tipData(phyd) <- data.frame(x=1:5, row.names=tipLabels(phyd)) expect_equal(suppressWarnings(as(phyd, "phylo")), tr) ## ...now check for warning for unknown order expect_warning(as(phyd, "phylo")) ## phylo tree in cladewise order tr.cladewise <- reorder(tr, "cladewise") phyd <- as(tr.cladewise, "phylo4d") tipData(phyd) <- data.frame(x=1:5, row.names=tipLabels(phyd)) expect_equal(suppressWarnings(as(phyd, "phylo")), tr.cladewise) ## ...now check for warning for dropping data expect_warning(as(phyd, "phylo")) ## phylo tree in pruningwise order tr.pruningwise <- reorder(tr, "pruningwise") phyd <- as(tr.pruningwise, "phylo4d") tipData(phyd) <- data.frame(x=1:5, row.names=tipLabels(phyd)) expect_equal(suppressWarnings(as(phyd, "phylo")), tr.pruningwise) }) ##test.phylo4.As.phylog <- function() { ##} test_that("phylo4 to data.frame", { phy.show <- phylobase:::.phylo4ToDataFrame(phy.alt, "pretty") expect_equal(phy.show$label, c(lab.tip, lab.int)) expect_equal(phy.show$node, c(nid.tip, nid.int)) expect_equal(phy.show$ancestor, ancestor[match(c(nid.tip, nid.int), descendant)]) expect_equal(phy.show$edge.length, sort(elen)) expect_equal(phy.show$node.type, factor(unname(nodeType(phy)))) }) ## core functionality is already tested in test..phylo4ToDataFrame() test_that("phylo4 to data.frame", { ## rooted tree expect_true(is.data.frame(as(phy, "data.frame"))) ## unrooted tree tru <- ape::unroot(tr) phyu <- as(tru, "phylo4") # should probably check that this coercion results in something # *correct*, not just that it produces a data.frame expect_true(is.data.frame(as(phyu, "data.frame"))) }) phylobase/tests/testthat/test.phylo4.R0000644000176200001440000000030014553646170017566 0ustar liggesusers# # --- Test phylo4.R --- # # phylo4.R is mostly used to set generics, so no testing needed # one non-exported method: ## test..genlab <- function() { ## # use phylobase:::.genlab ## } phylobase/tests/testthat/test.tbind.R0000644000176200001440000000016014553646170017453 0ustar liggesusers## # ## # --- Test tbind.R --- ## # ## test.tbind <- function() { ## # function(...,checkData=TRUE) ## } phylobase/tests/misctests.R0000644000176200001440000000566114553646170015566 0ustar liggesuserslibrary(phylobase) library(ape) set.seed(1) data(geospiza) ## make sure geospiza is properly formatted if(is.character(checkval <- checkPhylo4(geospiza))) stop(checkval) geospiza0 <- list(geospiza.tree=as(geospiza,"phylo"),geospiza.data=tipData(geospiza)) ## push data back into list form as in geiger t1 <- try(p1 <- phylo4d(geospiza0$geospiza.tree,geospiza0$geospiza.data)) ## Error in checkData(res, ...) : ## Tip data names are a subset of tree tip labels. p2 <- as(geospiza0$geospiza.tree,"phylo4") plot(p2) lab1 <- tipLabels(p2) lab2 <- rownames(geospiza0$geospiza.data) lab1[!lab1 %in% lab2] ## missing data lab2[!lab2 %in% lab1] ## extra data (none) p1 <- phylo4d(p2,geospiza0$geospiza.data, missing.data="warn") p1 <- phylo4d(p2,geospiza0$geospiza.data, missing.data="OK") plot(p1) plot(p1,show.node.label=TRUE) ## one way to deal with it: p1B <- prune(p1,tip="olivacea") ## or ... p1C <- stats::na.omit(p1) labels(p1C, "all") <- tolower(labels(p1C, "all")) ## trace("prune",browser,signature="phylo4d") r1 <- read.tree(text="((t4:0.3210275554,(t2:0.2724586465,t3:0.2724586465):0.0485689089):0.1397952619,(t5:0.07551818331,t1:0.07551818331):0.385304634);") ## trace("phylo4d", browser, signature = "phylo") ## untrace("phylo4d", signature = "phylo") tipdat <- data.frame(a=1:5, row.names=r1$tip.label) q1 <- phylo4d(r1,tip.data=tipdat, node.data=data.frame(a=6:9), match.data=FALSE) q2 <- prune(q1,1) summary(q2) tipdat2 <- tipdat row.names(tipdat2)[1] <- "s1" t1 <- try(q1 <- phylo4d(r1,tip.data=tipdat2)) plot(q2) plot(q2,type="cladogram") ## plot(p2,type="dotchart",labels.nodes=nodeLabels(p2)) ## trace("plot", browser, signature = c("phylo4d","missing")) tipLabels(q1) <- paste("q",1:5,sep="") nodeLabels(q1) <- paste("n",1:4,sep="") p3 <- phylo4d(r1,tip.data=tipdat,node.data=data.frame(b=6:9), match.data=FALSE) summary(p3) plot(p1) plot(subset(p1,tips.include=c("fuliginosa","fortis","magnirostris", "conirostris","scandens"))) ## better error? ## Error in phy$edge[, 2] : incorrect number of dimensions if(dev.cur() == 1) get(getOption("device"))() plot(subset(p2,tips.include=c("fuliginosa","fortis","magnirostris", "conirostris","scandens"))) plot(p2,show.node.label=TRUE) tree.owls <- read.tree(text="(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);") z <- as(tree.owls,"phylo4") example("phylo4d") obj1 <- obj2 <- obj3 <- phylo4d(z, data.frame(wing=1:4,color=factor(c("b","w","b","b")), tail=runif(4)*10), match.data=FALSE) obj2@data <- as.data.frame(obj2@data[,1]) obj3@data <- cbind(obj1@data,obj2@data) obj4 <- obj1 obj4@data[2,3] <- NA obj4@data[1,1] <- NA nodeLabels(obj4) <- character(0) obj5 <- obj1 tipData(obj4) <- subset(tipData(obj4),select=sapply(tipData(obj4),class)=="numeric") treePlot(obj4) E <- matrix(c( 8, 9, 9, 10, 10, 1, 10, 2, 9, 3, 9, 4, 8, 11, 11, 5, 11, 6, 11, 7, 0, 8), ncol=2,byrow=TRUE) P2 <- phylo4(E) phylobase/tests/phylotorture.R0000644000176200001440000000777614553646170016341 0ustar liggesusers## torture-testing phylo4 objects. library(phylobase) library(ape) set.seed(10101) n <- 200 p1 <- vector("list", n) ## don't want to slow down R CMD check by doing this every time: ## n <- 10000 for (i in 1:n) { if (i <= n/2) { e <- matrix(sample(1:10, replace=TRUE, size=10), ncol=2) } else { e <- cbind(sample(rep(11:19, 2)), sample(1:19)) e <- rbind(c(0, sample(11:19, 1)), e) } p1[[i]] <- try(phylo4(e), silent=TRUE) } OKvals <- sapply(p1, class) != "try-error" ## table(sapply(p1[!OKvals], as.character)) # I think this is causing issues with ## R check because of different width of terminal/output, trying something simpler: message(unique(sapply(p1[!OKvals], as.character))) sort(unname(table(sapply(p1[!OKvals], as.character)))) if (sum(OKvals)) message("There are ", sum(OKvals), " valid trees...") if (any(OKvals)) { p2 <- p1[OKvals] length(p2) has.poly <- sapply(p2, hasPoly) has.sing <- sapply(p2, hasSingle) has.retic <- sapply(p2, hasRetic) message("number of trees with polytomies: ", sum(has.poly)) message("number of trees with singletons: ", sum(has.sing)) message("number of trees with reticulation: ", sum(has.retic)) if (any(has.sing)) { p4 <- p2[has.sing] plot(p4[[1]]) ## gives descriptive error t2 <- try(plot(collapse.singles(as(p2[[1]],"phylo")))) ## "incorrect number of dimensions" } if (any(!has.sing)) { ## first tree without singles -- HANGS! ## don't try the plot in an R session you care about ... p3 <- p2[!has.sing] ## plot(p2[[13]]) } } ## elements 8 and 34 are ## what SHOULD the rules for trees be? ## (a) reduce node numbers to 1 ... N ? ## (b) check: irreducible, non-cyclic, ... ? ## convert to matrix format for checking? reduce_nodenums <- function(e) { matrix(as.numeric(factor(e)),ncol=2) } # make an illegal phylo4 object, does it pass checks? # a disconnected node: t1 <- read.tree (text="((a,b), (c,(d, e)));") plot(t1) broke1 <- t1 broke1$edge[broke1$edge[,2] ==9, 1] <- 9 # disconnect the node, two subtrees, ((a, b), c) and (d,e) try(as(broke1, "phylo4") -> tree, silent=TRUE) # makes a phylo4 object with no warning try(phylo4(broke1$edge), silent=TRUE) # constructor makes a phylo4 object with no warning ## error message comes from ape, not phylo? -- AND ## error is about singles, not disconnected nodes ## print(try(plot(tree), silent=TRUE )) ## pdc couldn't get this to work, so temporarily commenting # root node value != ntips + 1: broke2 <- t1 broke2$edge[broke2$edge==6] <- 10 ## warning, but no error ## plot(broke2) ## seems to hang R CMD check?? ## generates error, but it's about wrong number of tips, not wrong value at root. message(try(as(broke2, "phylo4"), silent=TRUE)) ## error regarding number of tip labels vs edges and nodes message(try(phylo4(broke2$edge), silent=TRUE)) # switch root node value (6) with next internal node (7): broke3 <- broke2 broke3$edge[broke3$edge==7] <- 6 broke3$edge[broke3$edge==10] <- 7 ## both of the following now fail with ## "root node is not at position (nTips+1) try(as(broke3,"phylo4") -> tree3) # works with no error message try(phylo4(broke3$edge)) # works with no error message ## plot(tree3) # would work if we could create it? # tips have larger numbers than root node: broke4 <- t1 broke4$edge[broke4$edge==1] <- 11 broke4$edge[broke4$edge==2] <- 12 broke4$edge[broke4$edge==3] <- 13 broke4$edge[broke4$edge==4] <- 14 broke4$edge[broke4$edge==5] <- 15 message(try(as(broke4, "phylo4"), silent=TRUE)) message(try(phylo4(broke4$edge), silent=TRUE)) # print(try(plot(broke4), TRUE)) ## CAUSES R TO HANG! ### foo <- new('phylo4') foo@edge <- rcoal(10)$edge message(try(plot(foo))) foo@label <- c(rep('blah',10), rep("",9)) ##### ## tree with only 2 tips: will fail under previous versions ## with "Error in if (which(nAncest == 0) != nTips + 1) { : ## argument is of length zero" edge <- matrix(c(3, 1, 3, 2), byrow=TRUE, ncol=2) try(p2 <- phylo4(edge), silent=TRUE) phylobase/src/0000755000176200001440000000000014555747152013046 5ustar liggesusersphylobase/src/checkPhylo4.cpp0000644000176200001440000003027314553646170015730 0ustar liggesusers// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; indent-tabs-mode: nil; -*- #include #include // std::count_if #include // std::vector #include // template std::string NumberToString ( T Number ) { std::ostringstream ss; ss << Number; return ss.str(); } bool isZero(int i) { return (i == 0); } bool isOne(int i) { return ( i == 1); } bool isSupTwo(int i) { return (i > 2); } bool isEqual(int i, int j) { return (i == j); } Rcpp::IntegerVector getAnces(Rcpp::IntegerMatrix obj) { // returns the first column (ancestors) of the edge matrix Rcpp::IntegerMatrix::Column out = obj( Rcpp::_ , 0); return out; } Rcpp::IntegerVector getDesc(Rcpp::IntegerMatrix obj) { // returns the second column (descendants) of the edge matrix Rcpp::IntegerMatrix::Column out = obj( Rcpp::_ , 1); return out; } //[[Rcpp::export]] bool isLabelName(Rcpp::CharacterVector lblToCheck, Rcpp::CharacterVector lbl ) { Rcpp::CharacterVector noLbl = Rcpp::setdiff(lblToCheck, lbl); return noLbl.size() == 0; } //[[Rcpp::export]] int nRoots (Rcpp::IntegerVector ances) { int ans = std::count (ances.begin(), ances.end(), 0); return ans; } //[[Rcpp::export]] std::vector tabulateTips (Rcpp::IntegerVector ances) { // tabulates ancestor nodes that are not the root. int n = Rcpp::max(ances); std::vector ans(n); for (int i=0; i < ances.size(); i++) { int j = ances[i]; if (j > 0) { ans[j - 1]++; } } return ans; } //[[Rcpp::export]] int nTipsSafe (Rcpp::IntegerVector ances) { // count how many zeros are in the tabulated vector of ancestors // this gives the number of tips std::vector tabTips = tabulateTips(ances); int j = count_if (tabTips.begin(), tabTips.end(), isZero); return j; } //[[Rcpp::export]] int nTipsFastCpp (Rcpp::IntegerVector ances) { // if nodes are correctly numbered min(ances) - 1 = nb of tips // (after removing the root, which is equal to 0). int nroots = nRoots(ances); if (nroots > 0) { int whichRoot = Rcpp::which_min(ances); ances.erase(whichRoot); } int tmp = Rcpp::min(ances); return tmp - 1; } //[[Rcpp::export]] bool hasSingleton (Rcpp::IntegerVector ances) { std::vector tabTips = tabulateTips(ances); int j = count_if (tabTips.begin(), tabTips.end(), isOne); return j > 0; } //[[Rcpp::export]] bool hasPolytomy (Rcpp::IntegerVector ances) { std::vector tabTips = tabulateTips(ances); int j = count_if (tabTips.begin(), tabTips.end(), isSupTwo); return j > 0; } //[[Rcpp::export]] Rcpp::IntegerVector tipsSafe (Rcpp::IntegerVector ances, Rcpp::IntegerVector desc) { Rcpp::IntegerVector res = Rcpp::match(desc, ances); Rcpp::LogicalVector istip = Rcpp::is_na(res); int nedge = ances.size(); std::vector y(nedge); int j = 0; for(int i = 0; i < nedge; i++) { if (istip[i]) { y[j] = desc[i]; j++; } } Rcpp::IntegerVector ans(j); std::copy (y.begin(), y.begin()+j, ans.begin()); std::sort (ans.begin(), ans.end()); return ans; } //[[Rcpp::export]] Rcpp::IntegerVector tipsFast (Rcpp::IntegerVector ances) { int ntips = nTipsFastCpp(ances); Rcpp::IntegerVector ans = Rcpp::seq_len(ntips); return ans; } //[[Rcpp::export]] Rcpp::IntegerVector getAllNodesSafe (Rcpp::IntegerMatrix edge) { Rcpp::IntegerVector ans = Rcpp::as_vector(edge); Rcpp::IntegerVector tmp = Rcpp::unique(ans); std::sort(tmp.begin(), tmp.end()); return tmp; } //[[Rcpp::export]] Rcpp::IntegerVector getAllNodesFast (Rcpp::IntegerMatrix edge) { Rcpp::IntegerVector tmp = Rcpp::as_vector(edge); Rcpp::IntegerVector maxN = Rcpp::range(tmp); Rcpp::IntegerVector ans; if (maxN[0] == 0) { ans = Rcpp::seq_len(maxN[1] + 1); ans = ans - 1; } else { ans = Rcpp::seq_len(maxN[1]); } return ans; } // Rcpp::List testNodes (Rcpp::IntegerMatrix edge, bool rooted) { // Rcpp::IntegerVector allNodes = Rcpp::as_vector(edge); // allNodes = Rcpp::unique(allNodes); // std::sort (allNodes.begin(), allNodes.end()); // Rcpp::IntegerVector supposedNodes = getAllNodesFast(edge, rooted); // Rcpp::IntegerVector test = Rcpp::setdiff(supposedNodes, allNodes); // Rcpp::LogicalVector res = supposedNodes == allNodes; // return Rcpp::List::create(supposedNodes, allNodes, test, res); // } //[[Rcpp::export]] Rcpp::List testEqInt (Rcpp::IntegerVector x, Rcpp::IntegerVector y) { Rcpp::LogicalVector xy = x == y; Rcpp::LogicalVector yx = y == x; return Rcpp::List::create(xy, yx); } // Rcpp::IntegerVector getInternalNodes (Rcpp::IntegerMatrix edge, bool rooted) { // Rcpp::IntegerVector ances = getAnces(edge); // Rcpp::IntegerVector allNodes = getAllNodesFast(edge, rooted); // Rcpp::IntegerVector tips = tipsFast(ances); // Rcpp::IntegerVector intNodes = Rcpp::setdiff(allNodes, tips); // intNodes.erase(intNodes.begin()); // return intNodes; // } //[[Rcpp::export]] bool all_naC (Rcpp::NumericVector x) { return is_true(all(is_na(x))); } //[[Rcpp::export]] bool any_naC (Rcpp::NumericVector x) { return is_true(any(is_na(x))); } //[[Rcpp::export]] int nb_naC (Rcpp::NumericVector x) { return sum(is_na(x)); } //[[Rcpp::export]] Rcpp::NumericVector getRange(Rcpp::NumericVector x, const bool na_rm) { Rcpp::NumericVector out(2); out[0] = R_PosInf; out[1] = R_NegInf; int n = x.length(); for(int i = 0; i < n; ++i) { if (!na_rm && R_IsNA(x[i])) { out[0] = NA_REAL; out[1] = NA_REAL; return(out); } if (x[i] < out[0]) out[0] = x[i]; if (x[i] > out[1]) out[1] = x[i]; } return(out); } //[[Rcpp::export]] bool hasDuplicatedLabelsCpp (Rcpp::CharacterVector label) { return is_true(any(Rcpp::duplicated(na_omit(label)))); } Rcpp::CharacterVector edgeIdCppInternal (Rcpp::IntegerVector tmp1, Rcpp::IntegerVector tmp2) { Rcpp::CharacterVector tmpV1 = Rcpp::as< Rcpp::CharacterVector >(tmp1); Rcpp::CharacterVector tmpV2 = Rcpp::as< Rcpp::CharacterVector >(tmp2); int Ne = tmp1.size(); Rcpp::CharacterVector res(Ne); for (int i = 0; i < Ne; i++) { std::string tmpS1; tmpS1 = tmpV1[i]; std::string tmpS2; tmpS2 = tmpV2[i]; std::string tmpS; tmpS = tmpS1.append("-"); tmpS = tmpS.append(tmpS2); res[i] = tmpS; } return res; } //[[Rcpp::export]] Rcpp::CharacterVector edgeIdCpp (Rcpp::IntegerMatrix edge, std::string type) { Rcpp::IntegerVector ances = getAnces(edge); Rcpp::IntegerVector desc = getDesc(edge); int nedge; if (type == "tip" || type == "internal") { Rcpp::IntegerVector tips = tipsFast(ances); nedge = tips.size(); Rcpp::IntegerVector ans = match(tips, desc); if (type == "tip") { Rcpp::IntegerVector tmpAnces(nedge); Rcpp::IntegerVector tmpDesc(nedge); for (int j = 0; j < nedge; j++) { tmpAnces[j] = ances[ans[j]-1]; tmpDesc[j] = desc[ans[j]-1]; } Rcpp::CharacterVector c1(nedge); c1 = edgeIdCppInternal(tmpAnces, tmpDesc); return c1; } else if (type == "internal") { int allEdges = ances.size(); Rcpp::IntegerVector idEdge = Rcpp::seq_len(allEdges); Rcpp::IntegerVector intnd = Rcpp::setdiff(idEdge, ans); nedge = intnd.size(); Rcpp::IntegerVector tmpAnces(nedge); Rcpp::IntegerVector tmpDesc(nedge); for (int j = 0; j < nedge; j++) { tmpAnces[j] = ances[intnd[j]-1]; tmpDesc[j] = desc[intnd[j]-1]; } Rcpp::CharacterVector c1(nedge); c1 = edgeIdCppInternal(tmpAnces, tmpDesc); return c1; } } else { nedge = ances.size(); Rcpp::IntegerVector tmpAnces = ances; Rcpp::IntegerVector tmpDesc = desc; Rcpp::CharacterVector c1(nedge); c1 = edgeIdCppInternal(tmpAnces, tmpDesc); return c1; } return ""; } //[[Rcpp::export]] Rcpp::List checkTreeCpp(Rcpp::S4 obj, Rcpp::List opts) { std::string err, wrn; Rcpp::IntegerMatrix ed = obj.slot("edge"); int nrow = ed.nrow(); Rcpp::IntegerVector ances = getAnces(ed); //Rcpp::IntegerVector desc = getDesc(ed); int nroots = nRoots(ances); //bool rooted = nroots > 0; Rcpp::NumericVector edLength = obj.slot("edge.length"); Rcpp::CharacterVector edLengthNm = edLength.names(); Rcpp::CharacterVector label = obj.slot("label"); Rcpp::CharacterVector labelNm = label.names(); Rcpp::CharacterVector edLabel = obj.slot("edge.label"); Rcpp::CharacterVector edLabelNm = edLabel.names(); Rcpp::IntegerVector allnodesSafe = getAllNodesSafe(ed); Rcpp::IntegerVector allnodesFast = getAllNodesFast(ed); int nEdLength = edLength.size(); //int nLabel = label.size(); //int nEdLabel = edLabel.size(); int nEdges = nrow; bool hasEdgeLength = !all_naC(edLength); // check tips int ntipsSafe = nTipsSafe(ances); int ntipsFast = nTipsFastCpp(ances); bool testnTips = ntipsFast == ntipsSafe; if (! testnTips) { err.append("Tips incorrectly labeled. "); } //check internal nodes bool testNodes = Rcpp::all(allnodesSafe == allnodesFast).is_true() && // is both ways comparison needed? Rcpp::all(allnodesFast == allnodesSafe).is_true(); if (! testNodes) { err.append("Nodes incorrectly labeled. "); } // check edge lengths if (hasEdgeLength) { if (nEdLength != nEdges) { err.append("Number of edge lengths do not match number of edges. "); } // if (nb_naC(edLength) > nroots) { // not enough! -- best done in R // err.append("Only the root should have NA as an edge length. "); // } if (getRange(edLength, TRUE)[0] < 0) { err.append("Edge lengths must be non-negative. "); } Rcpp::CharacterVector edgeLblSupp = edgeIdCpp(ed, "all"); Rcpp::CharacterVector edgeLblDiff = Rcpp::setdiff(edLengthNm, edgeLblSupp); if ( edgeLblDiff.size() != 0 ) { err.append("Edge lengths incorrectly labeled. "); } } // check label names Rcpp::CharacterVector chrLabelNm = Rcpp::as(allnodesFast); int j = 0; while (j < nroots) { //remove root(s) chrLabelNm.erase(0); j++; } bool testLabelNm = isLabelName(labelNm, chrLabelNm); if (!testLabelNm) { err.append("Tip and node labels must be a named vector, the names must match the node IDs. "); err.append("Use tipLabels<- and/or nodeLabels<- to update them. "); } // check that tips have labels Rcpp::CharacterVector tiplabel(ntipsFast); std::copy (label.begin(), label.begin()+ntipsFast, tiplabel.begin()); bool emptyTipLabel = is_true(any(Rcpp::is_na(tiplabel))); if ( emptyTipLabel ) { err.append("All tips must have a label."); } // check edgeLabels Rcpp::CharacterVector chrEdgeLblNm = edgeIdCpp(ed, "all"); bool testEdgeLblNm = isLabelName(edLabelNm, chrEdgeLblNm); if (!testEdgeLblNm) { err.append("Edge labels are not labelled correctly. Use the function edgeLabels<- to update them. "); } // make sure that tips and node labels are unique if (hasDuplicatedLabelsCpp(label)) { std::string labOpt = opts["allow.duplicated.labels"]; if (labOpt == "fail") { err.append("Labels are not unique. "); } if (labOpt == "warn") { wrn.append("Labels are not unique. "); } } // check for polytomies if (hasPolytomy(ances)) { std::string msgPoly = "Tree includes polytomies. "; std::string polyOpt = opts["poly"]; if (polyOpt == "fail") { err.append(msgPoly); } if (polyOpt == "warn") { wrn.append(msgPoly); } } // check number of roots if (nroots > 1) { std::string msgRoot = "Tree has more than one root. "; std::string rootOpt = opts["multiroot"]; if (rootOpt == "fail") { err.append(msgRoot); } if (rootOpt == "warn") { wrn.append(msgRoot); } } // check for singletons if (hasSingleton(ances)) { std::string msgSing = "Tree contains singleton nodes. "; std::string singOpt = opts["singleton"]; if (singOpt == "fail") { err.append(msgSing); } if (singOpt == "warn") { wrn.append(msgSing); } } return Rcpp::List::create(err, wrn); } phylobase/src/reorderBinary.c0000644000176200001440000000323514553646170016020 0ustar liggesusers/* reorderBinary.c: Given a root node, reorder a tree either as postorder or preorder. Works only on binary trees, in which each internal node has exactly 2 descendants. Function inputs are derived from a phylo4 edge matrix. The new descendant node ordering is stored in descendantNew. */ #include typedef struct { int *descendantNew; int *ancestor; int *left; int *right; int nEdges; int index; } tree; void postorderBinary(tree*, int node); void preorderBinary(tree*, int node); void reorderBinary(int *descendantNew, int *root, int *ancestor, int *left, int *right, int *nEdges, int *order) { tree tr; tr.ancestor = ancestor; tr.left = left; tr.right = right; tr.descendantNew = descendantNew; tr.nEdges = *nEdges; tr.index = 0; if (*order==0) { postorderBinary(&tr, *root); } else if (*order==1) { preorderBinary(&tr, *root); } else { error("invalid order type"); } } // postorder: continue traversing to the end, then record node void postorderBinary(tree *tr, int node) { for (int i=0; inEdges; i++) { if (tr->ancestor[i]==node) { postorderBinary(tr, tr->left[i]); postorderBinary(tr, tr->right[i]); } } tr->descendantNew[tr->index] = node; tr->index += 1; } // preorder: record node first, then continue traversing void preorderBinary(tree *tr, int node) { tr->descendantNew[tr->index] = node; tr->index += 1; for (int i=0; inEdges; i++) { if (tr->ancestor[i]==node) { preorderBinary(tr, tr->left[i]); preorderBinary(tr, tr->right[i]); } } } phylobase/src/phylobase_init.c0000644000176200001440000000720114553653674016226 0ustar liggesusers#include #include #include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .C calls */ extern void phyloxx(void *, void *, void *, void *, void *, void *); extern void reorderBinary(void *, void *, void *, void *, void *, void *, void *); extern void reorderRobust(void *, void *, void *, void *, void *, void *); /* .Call calls */ extern SEXP ancestors_c(SEXP, SEXP, SEXP); extern SEXP descendants_c(SEXP, SEXP, SEXP); extern SEXP _phylobase_all_naC(SEXP); extern SEXP _phylobase_any_naC(SEXP); extern SEXP _phylobase_checkTreeCpp(SEXP, SEXP); extern SEXP _phylobase_edgeIdCpp(SEXP, SEXP); extern SEXP _phylobase_getAllNodesFast(SEXP); extern SEXP _phylobase_getAllNodesSafe(SEXP); extern SEXP _phylobase_getRange(SEXP, SEXP); extern SEXP _phylobase_hasDuplicatedLabelsCpp(SEXP); extern SEXP _phylobase_hasPolytomy(SEXP); extern SEXP _phylobase_hasSingleton(SEXP); extern SEXP _phylobase_isLabelName(SEXP, SEXP); extern SEXP _phylobase_nb_naC(SEXP); extern SEXP _phylobase_nRoots(SEXP); extern SEXP _phylobase_nTipsFastCpp(SEXP); extern SEXP _phylobase_nTipsSafe(SEXP); extern SEXP _phylobase_tabulateTips(SEXP); extern SEXP _phylobase_testEqInt(SEXP, SEXP); extern SEXP _phylobase_tipsFast(SEXP); extern SEXP _phylobase_tipsSafe(SEXP, SEXP); static const R_CMethodDef CEntries[] = { {"phyloxx", (DL_FUNC) &phyloxx, 6}, {"reorderBinary", (DL_FUNC) &reorderBinary, 7}, {"reorderRobust", (DL_FUNC) &reorderRobust, 6}, {NULL, NULL, 0} }; static const R_CallMethodDef CallEntries[] = { {"ancestors_c", (DL_FUNC) &ancestors_c, 3}, {"descendants_c", (DL_FUNC) &descendants_c, 3}, {"_phylobase_all_naC", (DL_FUNC) &_phylobase_all_naC, 1}, {"_phylobase_any_naC", (DL_FUNC) &_phylobase_any_naC, 1}, {"_phylobase_checkTreeCpp", (DL_FUNC) &_phylobase_checkTreeCpp, 2}, {"_phylobase_edgeIdCpp", (DL_FUNC) &_phylobase_edgeIdCpp, 2}, {"_phylobase_getAllNodesFast", (DL_FUNC) &_phylobase_getAllNodesFast, 1}, {"_phylobase_getAllNodesSafe", (DL_FUNC) &_phylobase_getAllNodesSafe, 1}, {"_phylobase_getRange", (DL_FUNC) &_phylobase_getRange, 2}, {"_phylobase_hasDuplicatedLabelsCpp", (DL_FUNC) &_phylobase_hasDuplicatedLabelsCpp, 1}, {"_phylobase_hasPolytomy", (DL_FUNC) &_phylobase_hasPolytomy, 1}, {"_phylobase_hasSingleton", (DL_FUNC) &_phylobase_hasSingleton, 1}, {"_phylobase_isLabelName", (DL_FUNC) &_phylobase_isLabelName, 2}, {"_phylobase_nb_naC", (DL_FUNC) &_phylobase_nb_naC, 1}, {"_phylobase_nRoots", (DL_FUNC) &_phylobase_nRoots, 1}, {"_phylobase_nTipsFastCpp", (DL_FUNC) &_phylobase_nTipsFastCpp, 1}, {"_phylobase_nTipsSafe", (DL_FUNC) &_phylobase_nTipsSafe, 1}, {"_phylobase_tabulateTips", (DL_FUNC) &_phylobase_tabulateTips, 1}, {"_phylobase_testEqInt", (DL_FUNC) &_phylobase_testEqInt, 2}, {"_phylobase_tipsFast", (DL_FUNC) &_phylobase_tipsFast, 1}, {"_phylobase_tipsSafe", (DL_FUNC) &_phylobase_tipsSafe, 2}, {NULL, NULL, 0} }; void R_init_phylobase(DllInfo *dll) { R_registerRoutines(dll, CEntries, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } phylobase/src/Makevars0000644000176200001440000000016714553646170014542 0ustar liggesusersPKG_CPPFLAGS=-I. -DHAVE_INTTYPES_H -DASSERTS_TO_EXCEPTIONS ## PKG_LIBS = `$(R_HOME)/bin/Rscript -e "Rcpp:::LdFlags()"` phylobase/src/Makevars.win0000644000176200001440000000042014553646170015326 0ustar liggesusers## PKG_LIBS = -s $(shell Rscript -e 'Rcpp:::LdFlags()') -L"$(RHOME)/bin" -lR --no-export-all-symbols --add-stdcall-alias PKG_CXXFLAGS = -I. -DHAVE_INTTYPES_H -DASSERTS_TO_EXCEPTIONS ## PKG_LIBS = $(shell "${R_HOME}/bin${R_ARCH_BIN}/Rscript.exe" -e "Rcpp:::LdFlags()") phylobase/src/reorderRobust.c0000644000176200001440000000306114553646170016047 0ustar liggesusers/* reorderRobust.c: Given a root node, reorder a tree either as postorder or preorder. Works on any valid tree, including those with singleton nodes and/or polytomies. Function inputs are derived from a phylo4 edge matrix. The new descendant node ordering is stored in descendantNew. */ #include typedef struct { int *descendantNew; int *ancestor; int *descendant; int nEdges; int index; } tree; void postorderRobust(tree*, int node); void preorderRobust(tree*, int node); void reorderRobust(int *descendantNew, int *root, int *ancestor, int *descendant, int *nEdges, int *order) { tree tr; tr.ancestor = ancestor; tr.descendant = descendant; tr.descendantNew = descendantNew; tr.nEdges = *nEdges; tr.index = 0; if (*order==0) { postorderRobust(&tr, *root); } else if (*order==1) { preorderRobust(&tr, *root); } else { error("invalid order type"); } } // postorder: continue traversing to the end, then record node void postorderRobust(tree *tr, int node) { for (int i=0; inEdges; i++) { if (tr->ancestor[i]==node) { postorderRobust(tr, tr->descendant[i]); } } tr->descendantNew[tr->index] = node; tr->index += 1; } // preorder: record node before continuing traversal void preorderRobust(tree *tr, int node) { tr->descendantNew[tr->index] = node; tr->index += 1; for (int i=0; inEdges; i++) { if (tr->ancestor[i]==node) { preorderRobust(tr, tr->descendant[i]); } } } phylobase/src/descendants.c0000644000176200001440000000311714553646170015503 0ustar liggesusers/* descendants.c: Identify all descendants of each node in the input vector. Function inputs are derived from a phylo4 edge matrix, which *must* be in preorder order. The isDescendant output is an indicator matrix of which nodes (rows, corresponding to the decendant vector) are descendants of each input node (columns, corresponding to the nodes vector). It will contain 1 for each descendant of the node, *including itself*, and 0 for all other nodes. Jim Regetz (NCEAS) */ #include #include SEXP descendants_c(SEXP nod, SEXP anc, SEXP des) { int numEdges = length(anc); int numNodes = length(nod); int* nodes = INTEGER(nod); int* ancestor = INTEGER(anc); int* descendant = INTEGER(des); int child = 0; SEXP isDescendant; PROTECT(isDescendant = allocMatrix(INTSXP, numEdges, numNodes)); for (int n=0; n #include SEXP ancestors_c(SEXP nod, SEXP anc, SEXP des) { int numEdges = length(anc); int numNodes = length(nod); int* nodes = INTEGER(nod); int* ancestor = INTEGER(anc); int* descendant = INTEGER(des); int parent = 0; SEXP isAncestor; PROTECT(isAncestor = allocMatrix(INTSXP, numEdges, numNodes)); for (int n=0; n do not edit by hand // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #include using namespace Rcpp; #ifdef RCPP_USE_GLOBAL_ROSTREAM Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); #endif // isLabelName bool isLabelName(Rcpp::CharacterVector lblToCheck, Rcpp::CharacterVector lbl); RcppExport SEXP _phylobase_isLabelName(SEXP lblToCheckSEXP, SEXP lblSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::CharacterVector >::type lblToCheck(lblToCheckSEXP); Rcpp::traits::input_parameter< Rcpp::CharacterVector >::type lbl(lblSEXP); rcpp_result_gen = Rcpp::wrap(isLabelName(lblToCheck, lbl)); return rcpp_result_gen; END_RCPP } // nRoots int nRoots(Rcpp::IntegerVector ances); RcppExport SEXP _phylobase_nRoots(SEXP ancesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP); rcpp_result_gen = Rcpp::wrap(nRoots(ances)); return rcpp_result_gen; END_RCPP } // tabulateTips std::vector tabulateTips(Rcpp::IntegerVector ances); RcppExport SEXP _phylobase_tabulateTips(SEXP ancesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP); rcpp_result_gen = Rcpp::wrap(tabulateTips(ances)); return rcpp_result_gen; END_RCPP } // nTipsSafe int nTipsSafe(Rcpp::IntegerVector ances); RcppExport SEXP _phylobase_nTipsSafe(SEXP ancesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP); rcpp_result_gen = Rcpp::wrap(nTipsSafe(ances)); return rcpp_result_gen; END_RCPP } // nTipsFastCpp int nTipsFastCpp(Rcpp::IntegerVector ances); RcppExport SEXP _phylobase_nTipsFastCpp(SEXP ancesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP); rcpp_result_gen = Rcpp::wrap(nTipsFastCpp(ances)); return rcpp_result_gen; END_RCPP } // hasSingleton bool hasSingleton(Rcpp::IntegerVector ances); RcppExport SEXP _phylobase_hasSingleton(SEXP ancesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP); rcpp_result_gen = Rcpp::wrap(hasSingleton(ances)); return rcpp_result_gen; END_RCPP } // hasPolytomy bool hasPolytomy(Rcpp::IntegerVector ances); RcppExport SEXP _phylobase_hasPolytomy(SEXP ancesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP); rcpp_result_gen = Rcpp::wrap(hasPolytomy(ances)); return rcpp_result_gen; END_RCPP } // tipsSafe Rcpp::IntegerVector tipsSafe(Rcpp::IntegerVector ances, Rcpp::IntegerVector desc); RcppExport SEXP _phylobase_tipsSafe(SEXP ancesSEXP, SEXP descSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type desc(descSEXP); rcpp_result_gen = Rcpp::wrap(tipsSafe(ances, desc)); return rcpp_result_gen; END_RCPP } // tipsFast Rcpp::IntegerVector tipsFast(Rcpp::IntegerVector ances); RcppExport SEXP _phylobase_tipsFast(SEXP ancesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP); rcpp_result_gen = Rcpp::wrap(tipsFast(ances)); return rcpp_result_gen; END_RCPP } // getAllNodesSafe Rcpp::IntegerVector getAllNodesSafe(Rcpp::IntegerMatrix edge); RcppExport SEXP _phylobase_getAllNodesSafe(SEXP edgeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::IntegerMatrix >::type edge(edgeSEXP); rcpp_result_gen = Rcpp::wrap(getAllNodesSafe(edge)); return rcpp_result_gen; END_RCPP } // getAllNodesFast Rcpp::IntegerVector getAllNodesFast(Rcpp::IntegerMatrix edge); RcppExport SEXP _phylobase_getAllNodesFast(SEXP edgeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::IntegerMatrix >::type edge(edgeSEXP); rcpp_result_gen = Rcpp::wrap(getAllNodesFast(edge)); return rcpp_result_gen; END_RCPP } // testEqInt Rcpp::List testEqInt(Rcpp::IntegerVector x, Rcpp::IntegerVector y); RcppExport SEXP _phylobase_testEqInt(SEXP xSEXP, SEXP ySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type x(xSEXP); Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type y(ySEXP); rcpp_result_gen = Rcpp::wrap(testEqInt(x, y)); return rcpp_result_gen; END_RCPP } // all_naC bool all_naC(Rcpp::NumericVector x); RcppExport SEXP _phylobase_all_naC(SEXP xSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericVector >::type x(xSEXP); rcpp_result_gen = Rcpp::wrap(all_naC(x)); return rcpp_result_gen; END_RCPP } // any_naC bool any_naC(Rcpp::NumericVector x); RcppExport SEXP _phylobase_any_naC(SEXP xSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericVector >::type x(xSEXP); rcpp_result_gen = Rcpp::wrap(any_naC(x)); return rcpp_result_gen; END_RCPP } // nb_naC int nb_naC(Rcpp::NumericVector x); RcppExport SEXP _phylobase_nb_naC(SEXP xSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericVector >::type x(xSEXP); rcpp_result_gen = Rcpp::wrap(nb_naC(x)); return rcpp_result_gen; END_RCPP } // getRange Rcpp::NumericVector getRange(Rcpp::NumericVector x, const bool na_rm); RcppExport SEXP _phylobase_getRange(SEXP xSEXP, SEXP na_rmSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< const bool >::type na_rm(na_rmSEXP); rcpp_result_gen = Rcpp::wrap(getRange(x, na_rm)); return rcpp_result_gen; END_RCPP } // hasDuplicatedLabelsCpp bool hasDuplicatedLabelsCpp(Rcpp::CharacterVector label); RcppExport SEXP _phylobase_hasDuplicatedLabelsCpp(SEXP labelSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::CharacterVector >::type label(labelSEXP); rcpp_result_gen = Rcpp::wrap(hasDuplicatedLabelsCpp(label)); return rcpp_result_gen; END_RCPP } // edgeIdCpp Rcpp::CharacterVector edgeIdCpp(Rcpp::IntegerMatrix edge, std::string type); RcppExport SEXP _phylobase_edgeIdCpp(SEXP edgeSEXP, SEXP typeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::IntegerMatrix >::type edge(edgeSEXP); Rcpp::traits::input_parameter< std::string >::type type(typeSEXP); rcpp_result_gen = Rcpp::wrap(edgeIdCpp(edge, type)); return rcpp_result_gen; END_RCPP } // checkTreeCpp Rcpp::List checkTreeCpp(Rcpp::S4 obj, Rcpp::List opts); RcppExport SEXP _phylobase_checkTreeCpp(SEXP objSEXP, SEXP optsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< Rcpp::S4 >::type obj(objSEXP); Rcpp::traits::input_parameter< Rcpp::List >::type opts(optsSEXP); rcpp_result_gen = Rcpp::wrap(checkTreeCpp(obj, opts)); return rcpp_result_gen; END_RCPP } phylobase/src/phyloXX.c0000644000176200001440000000471014553646170014623 0ustar liggesusers/* descendants.c: Identify all descendants of a given node. Function inputs are derived from a phylo4 edge matrix, which *must* be in preorder order. The isDescendant input vector should contain 1 for the immediate children of the node, and 0 otherwise. The function returns this vector updated to include all further descendants. */ // test1 <- function() { // for (i in edge[, 2]) { // dex <- edge[, 1] == i // cur <- edge[, 2] == i // xx[dex] <- phy@edge.length[dex] + xx[cur] // segs$v0x[dex] <- xx[cur] // } // return(list(segs=segs, xx=xx)) // } // test1out <- test1() // segs <- test1out$segs // xx <- test1out$xx // test2 <- function() { // for(i in rev((Ntips + 1):nEdges(phy))) { // dex <- edge[, 1] == i // cur <- edge[, 2] == i // yy[cur] <- segs$v0y[dex] <- mean(yy[dex]) // } // return(list(segs=segs, yy=yy)) // } // test2out <- test2() // segs <- test2out$segs // yy <- test2out$yy // segs$h0y <- segs$h1y <- segs$v1y <- yy #include // // void phyloyy(int *edge1, int *edge2, int *ntips, // int *numEdges, double *yy, double *v0y) // { // int i; // int k; // int j; // int cur; // int des; // int count; // double tmp; // double theMean; // Rprintf("test\n"); // for (i=*numEdges; i > *ntips ; i--) { // for (k=0; k<*numEdges; k++) { // if(i == edge2[k]) { // cur = k; // } // } // tmp=0; // count=0; // for (j=0; j<*numEdges; j++) { // if(i == edge1[j]) { // des = j; // tmp += yy[j]; // count += 1; // } // } // theMean = tmp / count; // yy[cur] = theMean; // for (j=0; j<*numEdges; j++) { // if(i == edge1[j]) { // v0y[j] = theMean; // } // } // // } // } void phyloxx(int *edge1, int *edge2, double *edgeLengths, int *numEdges, double *xx, double *v0x) { int j; int i; int k; int cur=0; for (i=0; i <*numEdges; i++) { for (k=0; k<*numEdges; k++) { if(edge2[i] == edge2[k]) { cur = k; } } for (j=0; j<*numEdges; j++) { if(edge2[i] == edge1[j]) { xx[j] = edgeLengths[j] + xx[cur]; v0x[j] = xx[cur]; } } } } phylobase/vignettes/0000755000176200001440000000000014555747152014267 5ustar liggesusersphylobase/vignettes/phylobase.Rmd0000644000176200001440000006360214555745776016742 0ustar liggesusers--- title: "The phylo4 classes and methods" author: ["Ben Bolker", "Peter Cowan", "François Michonneau"] output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{The phylo4 classes and methods} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```r library(phylobase) ``` ## Introduction This document describes the new 'phylo4' S4 classes and methods, which are intended to provide a unifying standard for the representation of phylogenetic trees and comparative data in R. The `phylobase` package was developed to help both end users and package developers by providing a common suite of tools likely to be shared by all packages designed for phylogenetic analysis, facilities for data and tree manipulation, and standardization of formats. This standardization will benefit *end-users* by making it easier to move data and compare analyses across packages, and to keep comparative data synchronized with phylogenetic trees. Users will also benefit from a repository of functions for tree manipulation, for example tools for including or excluding subtrees (and associated phenotypic data) or improved tree and data plotting facilities. `phylobase` will benefit *developers* by freeing them to put their programming effort into developing new methods rather than into re-coding base tools. We (the `phylobase` developers) hope `phylobase` will also facilitate code validation by providing a repository for benchmark tests, and more generally that it will help catalyze community development of comparative methods in R. A more abstract motivation for developing `phylobase` was to improve data checking and abstraction of the tree data formats. `phylobase` can check that data and trees are associated in the proper fashion, and protects users and developers from accidently reordering one, but not the other. It also seeks to abstract the data format so that commonly used information (for example, branch length information or the ancestor of a particular node) can be accessed without knowledge of the underlying data structure (i.e., whether the tree is stored as a matrix, or a list, or a parenthesis-based format). This is achieved through generic `phylobase` functions which which retrieve the relevant information from the data structures. The benefits of such abstraction are multiple: (1) *easier access to the relevant information* via a simple function call (this frees both users and developers from learning details of complex data structures), (2) *freedom to optimize data structures in the future without breaking code.* Having the generic functions in place to "translate" between the data structures and the rest of the program code allows program and data structure development to proceed somewhat independently. The alternative is code written for specific data structures, in which modifications to the data structure requires rewriting the entire package code (often exacting too high a price, which results in the persistence of less-optimal data structures). (3) *providing broader access to the range of tools in `phylobase`*. Developers of specific packages can use these new tools based on S4 objects without knowing the details of S4 programming. The base 'phylo4' class is modeled on the the `phylo` class in `ape`. and extend the 'phylo4' class to include data or multiple trees respectively. In addition to describing the classes and methods, this vignette gives examples of how they might be used. ## Package overview The phylobase package currently implements the following functions and data structures: - Data structures for storing a single tree and multiple trees: and ? - A data structure for storing a tree with associated tip and node data: - A data structure for storing multiple trees with one set of tip data: - Functions for reading nexus files into the above data structures - Functions for converting between the above data structures and objects as well as `phylog` objects (although the latter are now deprecated ...) - Functions for editing trees and data (i.e., subsetting and replacing) - Functions for plotting trees and trees with data ## Using the S4 help system The help system works similarly to the help system with some small differences relating to how methods are written. The function is a good example. When we type we are provided the help for the default plotting function which expects `x` and `y`. `R` also provides a way to smartly dispatch the right type of plotting function. In the case of an object (a class object) `R` evaluates the class of the object and finds the correct functions, so the following works correctly. ```r library(ape) set.seed(1) ## set random-number seed rand_tree <- rcoal(10) ## Make a random tree with 10 tips plot(rand_tree) ``` However, typing still takes us to the default `plot` help. We have to type to find what we are looking for. This is because generics are simply functions with a dot and the class name added. The generic system is too complicated to describe here, but doesn't include the same dot notation. As a result doesn't work, `R` still finds the right plotting function. ```r library(phylobase) # convert rand_tree to a phylo4 object rand_p4_tree <- as(rand_tree, "phylo4") plot(rand_p4_tree) ``` All fine and good, but how to we find out about all the great features of the `phylobase` plotting function? `R` has two nifty ways to find it, the first is to simply put a question mark in front of the whole call: ```r `?`(plot(rand_p4_tree)) ``` `R` looks at the class of the object and takes us to the correct help file (note: this only works with objects). The second ways is handy if you already know the class of your object, or want to compare to generics for different classes: ```r `?`(method, plot("phylo4")) ``` More information about how documentation works can be found in the methods package, by running the following command. ```r help('Documentation', package="methods") ``` ## Trees without data You can start with a tree --- an object of class `phylo` from the `ape` package (e.g., read in using the `read.tree()` or `read.nexus()` functions), and convert it to a `phylo4` object. For example, load the raw *Geospiza* data: ```r library(phylobase) data(geospiza_raw) # what does it contain? names(geospiza_raw) #> [1] "tree" "data" ``` Convert the `S3` tree to a `S4 phylo4` object using the `as()` function: ```r (g1 <- as(geospiza_raw$tree, "phylo4")) #> label node ancestor edge.length node.type #> 1 fuliginosa 1 24 0.05500 tip #> 2 fortis 2 24 0.05500 tip #> 3 magnirostris 3 23 0.11000 tip #> 4 conirostris 4 22 0.18333 tip #> 5 scandens 5 21 0.19250 tip #> 6 difficilis 6 20 0.22800 tip #> 7 pallida 7 25 0.08667 tip #> 8 parvulus 8 27 0.02000 tip #> 9 psittacula 9 27 0.02000 tip #> 10 pauper 10 26 0.03500 tip #> 11 Platyspiza 11 18 0.46550 tip #> 12 fusca 12 17 0.53409 tip #> 13 Pinaroloxias 13 16 0.58333 tip #> 14 olivacea 14 15 0.88077 tip #> 15 15 0 NA root #> 16 16 15 0.29744 internal #> 17 17 16 0.04924 internal #> 18 18 17 0.06859 internal #> 19 19 18 0.13404 internal #> 20 20 19 0.10346 internal #> [ reached 'max' / getOption("max.print") -- omitted 7 rows ] ``` The (internal) nodes appear with labels \verb++ because they are not defined: ```r nodeLabels(g1) #> 15 16 17 18 19 20 21 22 23 24 25 26 27 #> NA NA NA NA NA NA NA NA NA NA NA NA NA ``` You can also retrieve the node labels with \texttt{labels(g1,"internal")}. A simple way to assign the node numbers as labels (useful for various checks) is ```r nodeLabels(g1) <- paste("N", nodeId(g1, "internal"), sep="") head(g1, 5) #> label node ancestor edge.length node.type #> 1 fuliginosa 1 24 0.05500 tip #> 2 fortis 2 24 0.05500 tip #> 3 magnirostris 3 23 0.11000 tip #> 4 conirostris 4 22 0.18333 tip #> 5 scandens 5 21 0.19250 tip ``` The \texttt{summary} method gives a little extra information, including information on the distribution of branch lengths: ```r summary(g1) #> #> Phylogenetic tree : g1 #> #> Number of tips : 14 #> Number of nodes : 13 #> Branch lengths: #> mean : 0.1764008 #> variance : 0.04624379 #> distribution : #> Min. 1st Qu. Median Mean 3rd Qu. Max. #> 0.00917 0.04985 0.08000 0.17640 0.21912 0.88077 ``` Print tip labels: ```r tipLabels(g1) #> 1 2 3 4 5 6 #> "fuliginosa" "fortis" "magnirostris" "conirostris" "scandens" "difficilis" #> 7 8 9 10 11 12 #> "pallida" "parvulus" "psittacula" "pauper" "Platyspiza" "fusca" #> 13 14 #> "Pinaroloxias" "olivacea" ``` (`labels(g1,"tip")` would also work.) You can modify labels and other aspects of the tree --- for example, to convert all the labels to lower case: ```r tipLabels(g1) <- tolower(tipLabels(g1)) ``` You could also modify selected labels, e.g. to modify the labels in positions 11 and 13 (which happen to be the only labels with uppercase letters): ```r tipLabels(g1)[c(11, 13)] <- c("platyspiza", "pinaroloxias") ``` Note that for a given tree, `phylobase` always return the `tipLabels` in the same order. Print node numbers (in edge matrix order): ```r nodeId(g1, type='all') #> [1] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 ``` Does it have information on branch lengths? ```r hasEdgeLength(g1) #> [1] TRUE ``` It does! What do they look like? ```r edgeLength(g1) #> 15-16 16-17 17-18 18-19 19-20 20-21 21-22 22-23 23-24 24-1 24-2 #> 0.29744 0.04924 0.06859 0.13404 0.10346 0.03550 0.00917 0.07333 0.05500 0.05500 0.05500 #> 23-3 22-4 21-5 0-15 20-6 19-25 25-7 25-26 26-27 27-8 27-9 #> 0.11000 0.18333 0.19250 NA 0.22800 0.24479 0.08667 0.05167 0.01500 0.02000 0.02000 #> 26-10 18-11 17-12 16-13 15-14 #> 0.03500 0.46550 0.53409 0.58333 0.88077 ``` Note that the root has `` as its length. Print edge labels (also empty in this case --- therefore all `NA`): ```r edgeLabels(g1) #> 15-16 16-17 17-18 18-19 19-20 20-21 21-22 22-23 23-24 24-1 24-2 23-3 22-4 21-5 0-15 #> NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA #> 20-6 19-25 25-7 25-26 26-27 27-8 27-9 26-10 18-11 17-12 16-13 15-14 #> NA NA NA NA NA NA NA NA NA NA NA NA ``` You can also use this function to label specific edges: ```r edgeLabels(g1)["23-24"] <- "an edge" edgeLabels(g1) #> 15-16 16-17 17-18 18-19 19-20 20-21 21-22 22-23 23-24 #> NA NA NA NA NA NA NA NA "an edge" #> 24-1 24-2 23-3 22-4 21-5 0-15 20-6 19-25 25-7 #> NA NA NA NA NA NA NA NA NA #> 25-26 26-27 27-8 27-9 26-10 18-11 17-12 16-13 15-14 #> NA NA NA NA NA NA NA NA NA ``` The edge labels are named according to the nodes they connect (ancestor-descendant). You can get the edge(s) associated with a particular node: ```r getEdge(g1, 24) # default uses descendant node #> 24 #> "23-24" getEdge(g1, 24, type="ancestor") # edges using ancestor node #> 24 24 #> "24-1" "24-2" ``` These results can in turn be passed to the function \texttt{edgeLength} to retrieve the length of a given set of edges: ```r edgeLength(g1)[getEdge(g1, 24)] #> 23-24 #> 0.055 edgeLength(g1)[getEdge(g1, 24, "ancestor")] #> 24-1 24-2 #> 0.055 0.055 ``` Is it rooted? ```r isRooted(g1) #> [1] TRUE ``` Which node is the root? ```r rootNode(g1) #> N15 #> 15 ``` Does it contain any polytomies? ```r hasPoly(g1) #> [1] FALSE ``` Is the tree ultrametric? ```r isUltrametric(g1) #> [1] TRUE ``` You can also get the depth (distance from the root) of any given node or the tips: ```r nodeDepth(g1, 23) #> Warning: 'nodeDepth' is deprecated. #> Use 'nodeHeight' instead. #> See help("Deprecated") #> N23 #> 0.77077 depthTips(g1) #> Warning: 'depthTips' is deprecated. #> Use 'nodeHeight' instead. #> See help("Deprecated") #> Warning: 'nodeDepth' is deprecated. #> Use 'nodeHeight' instead. #> See help("Deprecated") #> fuliginosa fortis magnirostris conirostris scandens difficilis #> 0.88077 0.88077 0.88077 0.88077 0.88077 0.88077 #> pallida parvulus psittacula pauper platyspiza fusca #> 0.88077 0.88077 0.88077 0.88077 0.88077 0.88077 #> pinaroloxias olivacea #> 0.88077 0.88077 ``` ## Trees with data The `phylo4d` class matches trees with data, or combines them with a data frame to make a `phylo4d` (tree-with-data) object. Now we'll take the _Geospiza_ data from `geospiza_raw$data` and merge it with the tree. First, let's prepare the data: ```r g1 <- as(geospiza_raw$tree, "phylo4") geodata <- geospiza_raw$data ``` However, since *G. olivacea* is included in the tree but not in the data set, we will initially run into some trouble: ```r g2 <- phylo4d(g1, geodata) #> Error in formatData(phy = x, dt = tip.data, type = "tip", ...): The following nodes are not found in the dataset: olivacea ``` To deal with *G. olivacea* missing from the data, we have a few choices. The easiest is to use to allow to create the new object with a warning (you can also use to proceed without warnings): ```r g2 <- phylo4d(g1, geodata, missing.data="warn") #> Warning in formatData(phy = x, dt = tip.data, type = "tip", ...): The following nodes are #> not found in the dataset: olivacea ``` Another way to deal with this would be to use `prune()` to drop the offending tip from the tree first: ```r g1sub <- prune(g1, "olivacea") g1B <- phylo4d(g1sub, geodata) ``` The difference between the two objects is that the species *G. olivacea* is still present in the tree but has no data (i.e., `NA`) associated with it. In the other case, *G. olivacea* is not included in the tree anymore. The approach you choose depends on the goal of your analysis. You can summarize the new object with the function `summary`. It breaks down the statistics about the traits based on whether it is associated with the tips for the internal nodes: \<\\>= summary(g2) @ Or use `tdata()` to extract the data (i.e., `tdata(g2)`). By default, `tdata()` will retrieve tip data, but you can also get internal node data only () or --- if the tip and node data have the same format --- all the data combined (). If you want to plot the data (e.g. for checking the input), `plot(tdata(g2))` will create the default plot for the data --- in this case, since it is a data frame, this will be a `pairs` plot of the data. ## Subsetting The `subset` command offers a variety of ways of extracting portions of a `phylo4` or `phylo4d` tree, keeping any tip/node data consistent. tips.include : give a vector of tips (names or numbers) to retain tips.exclude : give a vector of tips (names or numbers) to drop mrca : give a vector of node or tip names or numbers; extract the clade containing these taxa node.subtree : give a node (name or number); extract the subtree starting from this node Different ways to extract the *fuliginosa*-*scandens* clade: ```r subset(g2, tips.include=c("fuliginosa", "fortis", "magnirostris", "conirostris", "scandens")) subset(g2, node.subtree=21) subset(g2, mrca=c("scandens", "fortis")) ``` One could drop the clade by doing ```r subset(g2, tips.exclude=c("fuliginosa", "fortis", "magnirostris", "conirostris", "scandens")) subset(g2, tips.exclude=names(descendants(g2, MRCA(g2, c("difficilis", "fortis"))))) ``` ## Tree-walking `phylobase` provides many functions that allows users to explore relationships between nodes on a tree (tree-walking and tree traversal). Most functions work by specifying the `phylo4` (or `phylo4d`) object as the first argument, the node numbers/labels as the second argument (followed by some additional arguments). `getNode` allows you to find a node based on its node number or its label. It returns a vector with node numbers as values and labels as names: ```r data(geospiza) getNode(geospiza, 10) #> pauper #> 10 getNode(geospiza, "pauper") #> pauper #> 10 ``` If no node is specified, they are all returned, and if a node can't be found it's returned as a `NA`. It is possible to control what happens when a node can't be found: ```r getNode(geospiza) #> fuliginosa fortis magnirostris conirostris scandens difficilis #> 1 2 3 4 5 6 #> pallida parvulus psittacula pauper Platyspiza fusca #> 7 8 9 10 11 12 #> Pinaroloxias olivacea N15 N16 N17 N18 #> 13 14 15 16 17 18 #> N19 N20 N21 N22 N23 N24 #> 19 20 21 22 23 24 #> N25 N26 N27 #> 25 26 27 getNode(geospiza, 10:14) #> pauper Platyspiza fusca Pinaroloxias olivacea #> 10 11 12 13 14 getNode(geospiza, "melanogaster", missing="OK") # no warning #> #> NA getNode(geospiza, "melanogaster", missing="warn") # warning! #> Warning in getNode(geospiza, "melanogaster", missing = "warn"): Some nodes not found #> among all nodes in tree: melanogaster #> #> NA ``` `children` and `ancestor` give the immediate neighboring nodes: ```r children(geospiza, 16) #> N17 Pinaroloxias #> 17 13 ancestor(geospiza, 16) #> N15 #> 15 ``` while `descendants` and `ancestors` can traverse the tree up to the tips or root respectively: ```r descendants(geospiza, 16) # by default returns only the tips #> Pinaroloxias fusca Platyspiza difficilis scandens conirostris #> 13 12 11 6 5 4 #> magnirostris fuliginosa fortis pallida pauper parvulus #> 3 1 2 7 10 8 #> psittacula #> 9 descendants(geospiza, "all") # also include the internal nodes #> Warning in getNode(phy, node, missing = "warn"): Some nodes not found among all nodes in #> tree: all #> named list() ancestors(geospiza, 20) #> N19 N18 N17 N16 N15 #> 19 18 17 16 15 ancestors(geospiza, 20, "ALL") # uppercase ALL includes self #> N20 N19 N18 N17 N16 N15 #> 20 19 18 17 16 15 ``` `siblings` returns the other node(s) associated with the same ancestor: ```r siblings(geospiza, 20) #> N25 #> 25 siblings(geospiza, 20, include.self=TRUE) #> N20 N25 #> 20 25 ``` `MRCA` returns the most common recent ancestor for a set of tips, and shortest path returns the nodes connecting 2 nodes: ```r MRCA(geospiza, 1:6) #> N20 #> 20 shortestPath(geospiza, 4, "pauper") #> N19 N20 N21 N22 N25 N26 #> 19 20 21 22 25 26 ``` ## multiPhylo4 classes `multiPhylo4` classes are not yet implemented but will be coming soon. ## Examples ### Constructing a Brownian motion trait simulator This section will describe a way of constructing a simulator that generates trait values for extant species (tips) given a tree with branch lengths, assuming a model of Brownian motion. We can use to coerce the tree into a variance-covariance matrix form, and then use `mvrnorm` from the `MASS` package to generate a set of multivariate normally distributed values for the tips. (A benefit of this approach is that we can very quickly generate a very large number of replicates.) This example illustrates a common feature of working with `phylobase` --- combining tools from several different packages to operate on phylogenetic trees with data. We start with a randomly generated tree using `rcoal()` from `ape` to generate the tree topology and branch lengths: ```r set.seed(1001) tree <- as(rcoal(12), "phylo4") ``` Next we generate the phylogenetic variance-covariance matrix (by coercing the tree to a `phylo4vcov` object) and pick a single set of normally distributed traits (using to pick a multivariate normal deviate with a variance-covariance matrix that matches the structure of the tree). ```r vmat <- as(tree, "phylo4vcov") vmat <- cov2cor(vmat) library(MASS) trvec <- mvrnorm(1, mu=rep(0, 12), Sigma=vmat) ``` The last step (easy) is to convert the `phylo4vcov` object back to a `phylo4d` object: ```r treed <- phylo4d(tree, tip.data=as.data.frame(trvec)) plot(treed) ``` ![plot of chunk plotvcvphylo](fig-vignettes-plotvcvphylo-1.png) ## Definitions/slots This section details the internal structure of the `phylo4`, `multiphylo4` (coming soon!), `phylo4d`, and `multiphylo4d` (coming soon!) classes. The basic building blocks of these classes are the `phylo4` object and a dataframe. The `phylo4` tree format is largely similar to the one used by `phylo` class in the package `ape`[^1]. We use "edge" for ancestor-descendant relationships in the phylogeny (sometimes called "branches") and "edge lengths" for their lengths ("branch lengths"). Most generally, "nodes" are all species in the tree; species with descendants are "internal nodes" (we often refer to these just as "nodes", meaning clear from context); "tips" are species with no descendants. The "root node" is the node with no ancestor (if one exists). ### phylo4 Like `phylo`, the main components of the `phylo4` class are: edge : a 2-column matrix of integers, with $N$ rows for a rooted tree or $N-1$ rows for an unrooted tree and column names `ancestor` and `descendant`. Each row contains information on one edge in the tree. See below for further constraints on the edge matrix. edge.length : numeric list of edge lengths (length $N$ (rooted) or $N-1$ (unrooted) or empty (length 0)) tip.label : character vector of tip labels (required), with length=# of tips. Tip labels need not be unique, but data-tree matching with non-unique labels will cause an error node.label : character vector of node labels, length=# of internal nodes or 0 (if empty). Node labels need not be unique, but data-tree matching with non-unique labels will cause an error order : character: "preorder", "postorder", or "unknown" (default), describing the order of rows in the edge matrix. , "pruningwise" and "cladewise" are accepted for compatibility with `ape` The edge matrix must not contain `NA`s, with the exception of the root node, which has an `NA` for `ancestor`. `phylobase` does not enforce an order on the rows of the edge matrix, but it stores information on the current ordering in the slot --- current allowable values are "unknown" (the default), "preorder" (equivalent to "cladewise" in `ape`) or "postorder" [^2]. The basic criteria for the edge matrix are similar to those of `ape`, as documented it's tree specification[^3]. This is a modified version of those rules, for a tree with $n$ tips and $m$ internal nodes: - Tips (no descendants) are coded $1,\ldots, n$, and internal nodes ($\ge 1$ descendant) are coded $n + 1, \ldots , n + m$ ($n + 1$ is the root). Both series are numbered with no gaps. - The first (ancestor) column has only values $> n$ (internal nodes): thus, values $\le n$ (tips) appear only in the second (descendant) column - all internal nodes (not including the root) must appear in the first (ancestor) column at least once [unlike `ape`, which nominally requires each internal node to have at least two descendants (although it doesn't absolutely prohibit them and has a function to get rid of them), `phylobase` does allow these "singleton nodes" and has a method `hasSingle` for detecting them]. Singleton nodes can be useful as a way of representing changes along a lineage; they are used this way in the `ouch` package. - the number of occurrences of a node in the first column is related to the nature of the node: once if it is a singleton, twice if it is dichotomous (i.e., of degree 3 [counting ancestor as well as descendants]), three times if it is trichotomous (degree 4), and so on. `phylobase` does not technically prohibit reticulations (nodes or tips that appear more than once in the descendant column), but they will probably break most of the methods. Disconnected trees, cycles, and other exotica are not tested for, but will certainly break the methods. We have defined basic methods for `phylo4`:`show`, `print`, and a variety of accessor functions (see help files). `summary` does not seem to be terribly useful in the context of a "raw" tree, because there is not much to compute. ### phylo4d The `phylo4d` class extends `phylo4` with data. Tip data, and (internal) node data are stored separately, but can be retrieved together or separately with `tdata(x,"tip")`, `tdata(x,"internal")` or `tdata(x,"all")`. There is no separate slot for edge data, but these can be stored as node data associated with the descendant node. [^1]: [^2]: see for more information on orderings. (`ape`'s "pruningwise" is "bottom-up" ordering). [^3]: phylobase/vignettes/auto/0000755000176200001440000000000014554216242015225 5ustar liggesusersphylobase/vignettes/auto/developer.el0000644000176200001440000000156014554216242017536 0ustar liggesusers(TeX-add-style-hook "developer" (lambda () (TeX-add-to-alist 'LaTeX-provided-package-options '(("inputenc" "utf8") ("hyperref" "colorlinks=true" "bookmarks=true"))) (add-to-list 'LaTeX-verbatim-macros-with-braces-local "href") (add-to-list 'LaTeX-verbatim-macros-with-braces-local "hyperimage") (add-to-list 'LaTeX-verbatim-macros-with-braces-local "hyperbaseurl") (add-to-list 'LaTeX-verbatim-macros-with-braces-local "nolinkurl") (add-to-list 'LaTeX-verbatim-macros-with-braces-local "url") (add-to-list 'LaTeX-verbatim-macros-with-braces-local "path") (add-to-list 'LaTeX-verbatim-macros-with-delims-local "path") (TeX-run-style-hooks "latex2e" "article" "art10" "inputenc" "graphicx" "hyperref" "url") (TeX-add-symbols '("code" 1) "pb") (LaTeX-add-labels "subversion")) :latex) phylobase/vignettes/fig-vignettes-plotvcvphylo-1.png0000644000176200001440000004233214555745776022473 0ustar liggesusersPNG  IHDR)Jh( pHYs  ~ IDATxw@{iFBF* dWDvnd+kf\{DRV Eei)mS9~yf@]t~78=!(A@qzCP8=@cG1}q?œ56d2[>H9sƷ=~ZǓK. 0ܽ{7Ĕ\=r m3B҄hNWrrrm+**bݍW'qȒ!QxìKsXӞh8=DfΜ)--ehhX]u.W\qqq%N{{{>}ZQQ}u b24)yIa}:===;;ߍtYnC@)))A@qzCP8=!(A@qzCP8=!(A@qzCP8=@!~ε?x4ݱb;<3zâ6FQ]3fIIIΆmOw-\R2)8(BΚgbFYjgllƍ͛v:!Y'7ˎr?dO%4ƌ(+***!!N:hbbR߿o:M6a``PZZ:55vAdjjɑJw1k֬.]ۗA tYhQ]]=zvew,Y2bccc~ҙkjjB=BCRXX')):>}"^瑟tɤ=mx>.]?Naa!)@/9~BCBn4=t mCR| @qzCP8=!(A@qzCP8=!(A@qzCP8=!(A@qzCP\t!>TGo]s.y0e>}]w#݋MžL$$4+ƃZވޓ]!OtȦ<AT]]ɓF_bbb{ FUUU{F偁񇎎{dDEEz~rfGN=ʔCY+Adddt̙^իWfeeeAAAEwy𡸸8{ddddbUeL&3풷Y<((hϞ=,-----ͻf({&&&nKHrs&L@,n$z]>ÁGuuuNǥmGSKLBJ`g+ʐrenݺ̌>HOOwNgzSmG(?tVۋ߸ͨ?zNhwBf3Un{߲? >a[{y?ݚv_~]v!OGeq?=!(A@qzCP8=!(A@qzCP8=!(A@qzCP8= LX,ֵk׮_ŋ=zXZZ:;; /hf7o ><..m߾}SN:tÇZg.zgU9kV@G>gϞu֙jjj-Z(<<|…iiinSLj1!H1zWitg #˗/k_IIiϞ=˗/KW+澳ɕ)gN>.?7~7ug7 w:884aYYYyyy;YĔkhviaߥ1mc)))y޽{y:Vfeeeqq1OG!..Nњ:@OOѣGUg$)))--LK8BK Zz$tzz@,,,x:t:]P#f7|XG t ݻw1cF;******΃vF,JKK'!!]'F:thXXX/%&&***";,=pd…۶mKLLl?++k֬Y6lKW0]W_sYM t>}OW--?^vۻwwgy^)0o3Fw XXdYNIII|8=p"!!ؘ߽G{8=!(A@qzCP8=!(A@qzCP8=!(N @ӧgFFFX,:.""2|kkk;hZ`06nxooPEE//_)@sjkk]]]WX1dȐfsvv600pwwPPPh@s.]|i&v &edd$''sxUUUy0#BӘӳm}g1H K7Ф={,^S-[6oYT+@!׳[N6 R\\c33=?~=[X,@+NTRRsNIo՛=]YY%.%%iRʊJ6!Ekz<~yyyyyy41Vӧ֢UW|YbWZnl6zy8;;C}#|gCW{$`ITo[ERJ0`@\\Wdggn®ic }3!lQc۶]߹s۷m:ww;wruʎ;yuxzxycJm88!{y7]gVqxѸ:¢[nm:={JJJFGG[[[sr|zzǏxX'F_А7߽LSd]0#lݺuȑ]vm*"ooCK_@s:qfKKK9rdPPnB@ z2yfff.X`Μ9G4h_:a)Zpԩ$''+((jiiyzzn޼=B)33/7WTT4HVVMA˰t\@wzCP8=!(A@qzCPP3HEEիW/_. d2i41b<{!^ ˳ӣӿ-dff^|CPPpc(=4tɒ%YYY֭ӧO̘1cƌ+Wۼyf; =4͛7Mtttq=x:!= uttDSSӋ/aaa< h(++/<<\II+))EDD8::jiip 3zAUU޽{[_;vlܹyyy$l߾ӳwmqe˖)**r劗),--KJJIom UpdUA7111$400ͭ$ρUQ|BW_$b<rkvz54jd:3eԟi7#^v m!ׯڒ^.::"且+Xp}qHر$Lgq7'zpݕ6 RSS I/khhNzN]rAVwՖ^}YLVVzO#'8 &c1owE ⊋lv&F6d2sϨ@YY╕ F(B@@Ft\}lћmnͽ_~iXҦI9,22r޼y]v~gPPIfQQ۽@DD+**yQQQQQSSHvًSg,:+:6 *0aڵk9F^^RBCC\QQ}%,uK5yƬ!NOPnծzJSS:::Ŋ O{'6 W}y)eH/Wr{~_苘W^z6 =|ekkGn3f[2sg>ӫMė oX,%=t4iMkh>}RPP &NNNƌ!ݚv}@OߣѾFf1wq;{iF۵kIVWWm6RA!:l2"u &HKKR Z A?1b:ׯ_9s&)]A[ M6EEEEEEBRRR@@I|=!߭[Hx4A䝑=<<޼y3gnOpŸy))))^BГo̙NNNCHIIl'%%%tR N*..^vmNNNTT8!ɧ.:(<ʪqqq^^^]ti#G?~Fj>EzhΠA#""-Z?d###---qq񚚚X111cܼy/_ ɩݻϟ?uݕ̙#))IzA 8+(3z4!Çr~A :mllߓ@uteϞ=z* F@qz p*;;;***###;;͛7]vUUUҥˈ#zIzhA]]݁N:8rH''' ✜kfddϛ7OBBBCzhNXX͛]]]/_,**KǏg0N6me81w+W̛7A7 ((8iҤA5jT޽wEDDVXsXl)S\\\ZqʤI"##wݻu)/]A!_{eXgܸqbbb7n +h =`Ŋ֭hm/f͚Rz&-- R))) :4**jjz&,,lĉ$ # v횵5{葖`0HI5'*![ ~?iվô:.-kll ###rvj7MLa6<24U{K>LM 3z*??_MM^"l]KFPF˰frVATUU Ȉ)xCeddDGGDY IDATNN~[y >|(**"rg$***&&LK8٢у nN\}k?WDpECCCVVɓ'ҥK/++k:_K  5v WnY{嘛:K-z2==c$%%%%%ۧ`\t]v&r.|.a>aUSn8}F_^͛7ݺu#,%.,xˣ>22 A+++c2}/BnOX®h3\2{ݦ@BͱnC=|3pwX0??_VVK6;=+]W:>=EXb^GciXoFuĉUٳNNNdU3Agt0 /_feeRѣǏ'~vիWRj۶mӧOǺ !浵m7nxxx355LNNc3Tw^GGnݺj3f :1IIׯo6PÇ]]]s{۷ovܩ[XFhii]pahOO׏G8ee/^>|ƍwH==v8hpppwVZbŊ#F899LVVVdddDDիqltСCW\ ~ AuuuA9rDAAߝB 1cƌ3fBB1[a8=XHee{?~VXXXPP //УGcccKKG Z?^QQQZZ?޹sט1ct,t,zhݻwW\ٷow޽ZZZÇ_xq^^---.\8j(4 /^hDuuٳwuر[7KUUuŊ/_uָq>}'P^^A;չ۶m={ȑ#_x+zAvvѣ7o"C 9y򤏏ӧOI ZAߔ޽ĤϞ=;{쌌 RzVC7ӧO_r)BCC'O\SSCJAh=|uqmmm[[[kxzzX+ rǎ7n ɓGCzqf@wީS^Flܸ!=l6̙3YYي ]񃒒---99vI uuCFYMGh4l233aN2umBAܧO,jfWWW7ps=+J|,[Poɦ$ShhyT?))G6yf־8bhhȻ㡏AC2Fc:„ 555JJJk Oaذa RSS׭[wQ v>}민݌>888??Ny [AnnnQQ>)e2/_^d /C zmmmmmmB?cIر?Eg:88 Fh@1f̘7n^zs!2pAAt:=((hܹW^6=|eaaѳg۷X˙$n!UVݾ}oyqpp޽{Io=K-o޼9SNCbbbkkk[Qfo۶mӦM***wB@C¡FFFVVV7n܄[[۪YYYu\#q^^^k֬ 2eXS3k׮߿_LLlݻwoVyzh_Q{{{II+))|Ζ?ZYYmڴ qnV'OdffjkkWMMA0NY[[[[[`ll#08=XNMMM~~˗/՛:=f]pÇjjj7n+**_mmm)Vo0227nܦMeIIIϟ_~ FK=4v֬Y,ȑ#M֧O>}:tȑ#xMcq#G2dȁIzAAAwtt|U;tB@#jjjVZՉÆ ;r䈗WAAzn!>>>lŹݻwߺuIZ8{ |k+;99ڵĮr6֙1cƙ3gH A?tСCXGPPp'+h = ,,lĉ5jիWI)E54&AD N#'^'!&k}}}RIKKRR)' XY' ]c|0~xnZxIfQQǏH,BbNMAAAUUULFR&"%/cϸfŅ{%T8uI`q"aAzĞQ:C[gb WvJbA aXD]z_IuzztQ䏄_@QQ\۫޽{%{lQ.a?eCWLIW >QO<1114BhHH HhXݻ"͍7~hggw6}!+h ,@C~~~666i]R'NfАxhhĉKKK[q:Z|A+ 6\VV6n8{{{B@lllm6f̘7npxJRR>PФ}^x̙3O5[z JJJ?~<'//+@e˖EҥK7mģ"==Q]h,Շ!1bFnnnaaa@kcc!hon#yafbY ADRR9h%%"љbX+wHh1ő< ADMMG(N[ OL|h=AgYLCz ?n:Y'7ˎr?d*/}vXUWW׏]@ܗ2ŧO222RG>A/..üvRWWWWWߤ);-2tA v{$x0(|w ~wgyɱK;ĻW~(~9٫hX ˷@3= B!,;Az ūx=JeeG4555rj]Lɏe=Ə=my=fb0Vเ<  Dtttlly7ġCf̘!)1tИNΜ9» =Æ QTqqqUUUՇa ]]]cccyqMyh f@2|^֭[Hy>Œ>x𠮮.Y5Õɪ ŒٿɓI)XWW/=|nݺ1c4V_IwV/jfM#Gzzz;vذak8 2dʕNNNo޼ies* MVW_L /),,5jW{4 }GQRRUYY) ..ŁRSS}||Lu8Q=BmNwO7{ZvM ԮMCJ~*))9wիWsrrdee SVVVEEȑ#G_ =ׯY[[/^ 4)usi_~_~zTT_:Œ?2337nܘ:n8'''MMFKKK;|DD?h999[nq!Wչ]E6'ұL(]h> [mmm``{V\iii),+<<|͓'O2eJ|Gjkkoܸq$SQyy5VPbalmeegg'))Nvm^֮_>99-KL9eWpU7'11qҤIvjݬ\XX8 `̙NNN999wu#֊aan =rrr㳳544͕8<˗SN=s_:III3g WTTlc)>u8jzԿhC;<&Ŏ~ΠIѷ`ݻjܹIOO2e[)S?~)OD>}6ov^_VVZYYmٲg6M>}]t!1 kגU#Z)uGUb K7Mڽ{wTTÇ[877l߾lbhhHze#z_{A.!E?cqwc$}{nNqww0aѣb)##Cz/_\rٳgI м쇑o>ϩTa1rȰtӈ;w\x… wܹsG1bĈs޻ךLe>,(oA11Ѕ ~СCSLiE9t4$ոgUC͞SF "K7>>>ӦM_x޽{z_hQ:Y`AeeecǎzjJqbYZZ޽{wC4:/1&"B4_/9A0;vמ={LLLw^wwqq^3fhu3~~~S츸'tz.]޽{QKT^S[77q1InC߹s_rpp9,'))V7j >}گ_VP~y= WMݲʎQs-h̙3M:sӧOsXӧfffm˗A~Gm"==W^z.Iws!kjj9RVVFJmmm!&KZvvFWW,"6VkBQQG,]QQϜT+))i!$ouuhHLLף|%4q߾geTgn߾m?|I5%%6ojjJxee% x~?jk+I~Ջxx3!i41Yʚ%uu6ggg yj?~c,un݆`J!h> hիWϚ5RomV{[UXEzzz+gE =p AZ\\y7͛7;R~rۨ==/N055}AKqp'A$$N=\m,*̨ }4 AO޽{lll|L&ĉ˗/K[ÇY,VZDDK.)))(šK.}y@;L=NEuCtoo﨨(ii.>bwqq9wZ;w8w͛=<<9yqQQQHHHLL̆   ǎ_G ƞ?>??ƌG/0?~|ʕwVVVh4)))&Y]]d2GXPّ8tIDAT @qz#;c/?t1Ԗhn͚{*$=zU" h:&"ݧWz_re! hBj+>zSe}kPOEOܼ #7/v̸g\(o?ǽtL~SuWyk˅5.a饬#7qWl믑DmMA_A!tD~}S__&FfUI|y`KBUg.ge28|ZF0k>xnL5]zaIuMl;wlvW>{+'jr0V>瑻lƋ ֓N}"fg3O~"퟉U` &'̸{+5қ22٥J)L={߼a4uя~~&~Ya9mIӷ22K{RzwMf֏m%lFxx\MzƩq=/8aM]+6l- -#5++EEhAWW7sØt1))"DAQysGt2!,B#&,TW^Q@ߩ;OoYA2/mКTߕsIT^C[MF2 -#3%,`((7_YMۼl; Q},blf?@+) | 𳨲ҿО24Bk޵rL?!lй7e^^)ai-s|juulͅWg{||YqEW]Qu~= ºhӫ߼/fԐf~u`OA-m3T?Qxw 8{ZFjԽS{A]diw {l̯67ma"B0s>X[li*+<`7~\o_A/k ]EFT4p4oKӕ hwۂ&GON;Fp&@8 @qzCP8=!(A@qz?{4yUNIENDB`phylobase/R/0000755000176200001440000000000014554224462012451 5ustar liggesusersphylobase/R/extractTree.R0000644000176200001440000000250714553646170015075 0ustar liggesusers## extract the phylo4 part of phylo4d; relies on implicit coerce method ##' Get tree from tree+data object ##' ##' Extracts a \code{phylo4} tree object from a \code{phylo4d} ##' tree+data object. ##' ##' \code{extractTree} extracts just the phylogeny from a tree+data ##' object. The phylogeny contains the topology (how the nodes are ##' linked together), the branch lengths (if any), and any tip and/or ##' node labels. This may be useful for extracting a tree from a ##' \code{phylo4d} object, and associating with another phenotypic ##' dataset, or to convert the tree to another format. ##' ##' @param from a \code{phylo4d} object, containing a phylogenetic ##' tree plus associated phenotypic data. Created by the ##' \code{phylo4d()} function. ##' @author Ben Bolker ##' @seealso \code{\link{phylo4-methods}}, ##' \code{\link{phylo4d-methods}}, \code{\link{coerce-methods}} for ##' translation functions. ##' @keywords methods ##' @export ##' @include setAs-methods.R ##' @examples ##' tree.phylo <- ape::read.tree(text = "((a,b),c);") ##' tree <- as(tree.phylo, "phylo4") ##' plot(tree) ##' tip.data <- data.frame(size = c(1, 2, 3), row.names = c("a", "b", "c")) ##' (treedata <- phylo4d(tree, tip.data)) ##' plot(treedata) ##' (tree1 <- extractTree(treedata)) ##' plot(tree1) ##' extractTree <- function(from) { as(from, "phylo4") } phylobase/R/checkdata.R0000644000176200001440000002724114554224462014511 0ustar liggesusers## REQUIRED for all trees ##' Validity checking for phylo4 objects ##' ##' Basic checks on the validity of S4 phylogenetic objects ##' ##' ##' @aliases checkPhylo4 checkTree checkPhylo4Data ##' @param object A prospective phylo4 or phylo4d object ##' @return As required by \code{\link[methods]{validObject}}, returns an error ##' string (describing problems) or TRUE if everything is OK. ##' @note ##' ##' These functions are only intended to be called by other phylobase functions. ##' ##' \code{checkPhylo4} is an (inflexible) wrapper for ##' \code{checkTree}. The rules for \code{phylo4} objects essentially ##' follow those for \code{phylo} objects from the \code{ape} package, ##' which are in turn defined in ##' \url{https://emmanuelparadis.github.io/misc/FormatTreeR.pdf}. ##' These are essentially that: \itemize{ \item if the tree has edge ##' lengths defined, the number of edge lengths must match the number ##' of edges; \item the number of tip labels must match the number of ##' tips; \item in a tree with \code{ntips} tips and \code{nnodes} ##' (total) nodes, nodes 1 to \code{ntips} must be tips \item if the ##' tree is rooted, the root must be node number \code{ntips+1} and ##' the root node must be the first row of the edge matrix \item tip ##' labels, node labels, edge labels, edge lengths must have proper ##' internal names (i.e. internal names that match the node numbers ##' they document) \item tip and node labels must be unique } ##' ##' You can alter some of the default options by using the function ##' \code{phylobase.options}. ##' ##' For \code{phylo4d} objects, \code{checkTree} also calls ##' \code{checkPhylo4Data} to check the validity of the data associated with the ##' tree. It ensures that (1) the data associated with the tree have the correct ##' dimensions, (2) that the row names for the data are correct. ##' @author Ben Bolker, Steven Kembel, Francois Michonneau ##' @seealso the \code{\link{phylo4}} constructor and ##' \linkS4class{phylo4} class; the \code{\link{phylo4d-methods}} constructor ##' and the \linkS4class{phylo4d} class do checks for the data ##' associated with trees. See \code{\link{coerce-methods}} for ##' translation functions and \code{\link{phylobase.options} to change ##' some of the default options of the validator.} ##' @include RcppExports.R ##' @include phylo4-class.R ##' @include phylo4-methods.R ##' @export ##' @keywords misc checkPhylo4 <- function(object) { ct <- checkTree(object) if (inherits(object, "phylo4d")) { ## checkPhyo4Data returns TRUE or fail cd <- checkPhylo4Data(object) } return(ct) } checkTree <- function(object) { ## case of empty phylo4 object if(nrow(object@edge) == 0 && length(object@edge.length) == 0 && length(object@label) == 0 && length(object@edge.label) == 0) return(TRUE) ## get options opt <- phylobase.options() ## Storage of error/warning messages err <- wrn <- character(0) ## Matrix is integer if (!is.integer(object@edge)) { err <- c(err, "Edge matrix needs to be integer.") } ## Matrix doesn't have NAs if (any(is.na(object@edge))) { err <- c(err, "Edge matrix cannot have NAs at this time.", "This could only happen if singletons were allowed", "but this is not supported by phylobase yet.") } ## Having non-integer or NAs cause cryptic messages, so stop here ## if it's the case if (length(err)) return(err) ## Named slots if (is.null(attributes(object@label)$names)) { err <- c(err, "The label slot needs to be a named vector.") attributes(object@label) <- list(names=character(0)) } if (is.null(attributes(object@edge.length)$names)) { err <- c(err, "The edge.length slot needs to be a named vector.") attributes(object@edge.length) <- list(names=character(0)) } if (is.null(attributes(object@edge.label)$names)) { err <- c(err, "The edge.label slot needs to be a named vector.") attributes(object@edge.label) <- list(names=character(0)) } res <- checkTreeCpp(object, opts=opt) if (hasRetic(object)) { msg <- "Tree is reticulated." if (identical(opt$retic, "fail")) { err <- c(err, msg) } if (identical(opt$retic, "warn")) { wrn <- c(wrn, msg) } } if (hasEdgeLength(object) && any(is.na(edgeLength(object)))) { naElen <- names(which(is.na(object@edge.length))) if (! identical(naElen, edgeId(object, "root"))) err <- c(err, "Only the root can have NA as edge length. ") } if (!object@order %in% phylo4_orderings) { err <- c(err, paste("unknown order: allowed values are", paste(phylo4_orderings,collapse=","))) } err <- ifelse(nzchar(res[[1]]), c(err, res[[1]]), err) wrn <- ifelse(nzchar(res[[2]]), c(wrn, res[[2]]), wrn) if (!is.na(wrn)) { wrn <- paste(wrn, collapse=", ") warning(wrn) } if (!is.na(err)) { err <- paste(err, collapse=", ") return(err) #failures are returned as text } else { return(TRUE) } } ## checkTreeOld <- function(object) { ## ## case of empty phylo4 object ## if(nrow(object@edge) == 0 && length(object@edge.length) == 0 && ## length(object@label) == 0 && length(object@edge.label) == 0) ## return(TRUE) ## ## get options ## opt <- phylobase.options() ## ## Storage of error/warning messages ## err <- wrn <- character(0) ## ## Define variables ## nedges <- nEdges(object) ## ntips <- nTips(object) ## E <- edges(object) ## tips <- unique(sort(E[,2][!E[,2] %in% E[,1]])) ## nodes <- unique(sort(c(E))) ## intnodes <- nodes[!nodes %in% tips] ## nRoots <- length(which(E[,1] == 0)) ## ## Check edge lengths ## if (hasEdgeLength(object)) { ## if (length(object@edge.length) != nedges) ## err <- c(err, "edge lengths do not match number of edges") ## ##if(!is.numeric(object@edge.length)) # not needed ## ## err <- c(err, "edge lengths are not numeric") ## ## presumably we shouldn't allow NAs mixed ## ## with numeric branch lengths except at the root ## if (sum(is.na(object@edge.length)) > (nRoots + 1)) ## err <- c(err, "NAs in edge lengths") ## ## Strip root edge branch length (if set to NA) ## if (any(object@edge.length[!is.na(object@edge.length)] < 0)) ## err <- c(err, "edge lengths must be non-negative") ## ## Check edge length labels ## elen.msg <- "Use edgeLength<- to update them." ## if (is.null(names(object@edge.length))) { ## err <- c(err, paste("Edge lengths must have names matching edge IDs.", ## elen.msg)) ## } ## if (!all(names(object@edge.length) %in% edgeId(object, "all"))) { ## err <- c(err, paste("One or more edge lengths has an unmatched ID name.", ## elen.msg)) ## } ## } ## ## Make sure tips and ## if (!(all(tips==1:ntips) && all(nodes=(ntips+1):(ntips+length(intnodes))))) ## err <- c(err, "tips and nodes incorrectly numbered") ## ##careful - nAncest does not work for counting nRoots in unrooted trees ## nAncest <- tabulate(na.omit(E)[, 2],nbins=max(nodes)) ## bug fix from Jim Regetz ## nDesc <- tabulate(na.omit(E[,1])) ## nTips <- sum(nDesc==0) ## if (!all(nDesc[1:nTips]==0)) ## err <- c(err, "nodes 1 to nTips must all be tips") ## if (nRoots > 0) { ## if (sum(E[, 1] == 0) != 1) { ## err <- c(err, "for a rooted tree, edge matrix must contain (exactly one) explicit root edge with ancestor==0") ## } ## root.node <- unname(E[which(E[,1] == 0), 2]) ## } ## ## Check that nodes are correctly numbered ## if (!all(nDesc[(nTips+1):(nTips+nNodes(object))]>0)) ## err <- c(err, "nodes (nTips+1) to (nTips+nNodes) must all be internal nodes") ## ## how do we identify loops??? ## ## EXPERIMENTAL: could be time-consuming for large trees? ## if (FALSE) { ## Emat <- matrix(0,nrow=max(E),ncol=max(E)) ## Emat[E] <- 1 ## } ## if (!object@order %in% phylo4_orderings) { ## err <- c(err, paste("unknown order: allowed values are", ## paste(phylo4_orderings,collapse=","))) ## } ## ## make sure tip/node labels have internal names that match node IDs ## lab.msg <- "Use tipLabels<- (and nodeLabels<- if needed) to update them." ## if (is.null(names(object@label))) { ## err <- c(err, paste("Tip and node labels must have names matching node IDs.", ## lab.msg)) ## } else { ## if (!all(tips %in% names(na.omit(object@label)))) { ## err <- c(err, paste("All tips must have associated tip labels.", ## lab.msg)) ## } ## if (!all(names(object@label) %in% nodeId(object, "all"))) { ## err <- c(err, paste("One or more tip/node label has an unmatched ID name", ## lab.msg)) ## } ## } ## ## make sure edge labels have internal names that match the edges ## elab.msg <- "Use edgeLabels<- to update them." ## if(hasEdgeLabels(object)) { ## if (is.null(names(object@edge.label))) { ## err <- c(err, paste("Edge labels must have names matching edge IDs.", ## elab.msg)) ## } ## if (!all(names(object@edge.label) %in% edgeId(object, "all"))) { ## err <- c(err, paste("One or more edge labels has an unmatched ID name.", ## elab.msg)) ## } ## } ## ## make sure that tip and node labels are unique ## if (hasDuplicatedLabels(object)) { ## currmsg <- "Labels are not unique" ## if (opt$allow.duplicated.labels == "fail") ## err <- c(err, currmsg) ## if (opt$allow.duplicated.labels == "warn") ## wrn <- c(wrn, currmsg) ## } ## if (any(nDesc>2)) { ## currmsg <- "tree includes polytomies" ## if (opt$poly == "fail") ## err <- c(err, currmsg) ## if (opt$poly == "warn") ## wrn <- c(wrn, currmsg) ## } ## if (nRoots>1) { ## currmsg <- "tree has more than one root" ## if (opt$multiroot == "fail") ## err <- c(err, currmsg) ## if (opt$multiroot == "warn") ## wrn <- c(wrn,currmsg) ## } ## if (any(nDesc==1)) { ## currmsg <- "tree contains singleton nodes" ## if (opt$singleton == "fail") ## err <- c(err, currmsg) ## if (opt$singleton == "warn") ## wrn <- c(wrn, currmsg) ## } ## if (any(nAncest>1)) { ## currmsg <- paste("tree is reticulated [most functions in phylobase haven't", ## "been tested with reticulated trees]") ## if (opt$retic == "fail") ## err <- c(err, currmsg) ## if (opt$retic == "warn") ## wrn <- c(wrn, currmsg) ## } ## if (length(wrn) > 0) { ## wrn <- paste(wrn, collapse=", ") ## warning(wrn) ## } ## if (length(err) > 0) { ## err <- paste(err, collapse=", ") ## return(err) #failures are returned as text ## } ## else { ## return(TRUE) ## } ## } checkPhylo4Data <- function(object) { ## These are just some basic tests to make sure that the user does not ## alter the object in a significant way ## Check rownames if (nrow(object@data) > 0 && !all(row.names(object@data) %in% nodeId(object, "all"))) stop("The row names of tree data do not match the node numbers") return(TRUE) } phylobase/R/addData-methods.R0000644000176200001440000000755114553715747015601 0ustar liggesusers##' Adding data to a phylo4 or a phylo4d object ##' ##' \code{addData} adds data to a \code{phylo4} (converting it in a ##' \code{phylo4d} object) or to a \code{phylo4d} object ##' ##' Rules for matching data to tree nodes are identical to those used ##' by the \code{\link{phylo4d-methods}} constructor. ##' ##' If any column names in the original data are the same as columns ##' in the new data, ".old" is appended to the former column names and ##' ".new" is appended to the new column names. ##' ##' The option \code{pos} is ignored (silently) if \code{x} is a ##' \code{phylo4} object. It is provided for compatibility reasons. ##' ##' @param x a phylo4 or a phylo4d object ##' @param tip.data a data frame (or object to be coerced to one) ##' containing only tip data ##' @param node.data a data frame (or object to be coerced to one) ##' containing only node data ##' @param all.data a data frame (or object to be coerced to one) ##' containing both tip and node data ##' @param merge.data if both \code{tip.data} and \code{node.data} are ##' provided, it determines whether columns with common names will be ##' merged together (default TRUE). If FALSE, columns with common ##' names will be preserved separately, with ".tip" and ".node" ##' appended to the names. This argument has no effect if ##' \code{tip.data} and \code{node.data} have no column names in ##' common. ##' @param pos should the new data provided be bound \code{before} or ##' \code{after} the pre-existing data? ##' @param \dots additional arguments to control how matching between ##' data and tree (see Details section of ##' \code{\link{phylo4d-methods}} for more details). ##' @return \code{addData} returns a \code{phylo4d} object. ##' @author Francois Michonneau ##' @seealso \code{\link{tdata}} for extracting or updating data and ##' \code{\link{phylo4d-methods}} constructor. ##' @keywords methods ##' @rdname addData-methods ##' @include phylo4d-class.R ##' @export ##' @examples ##' data(geospiza) ##' nDt <- data.frame(a=rnorm(nNodes(geospiza)), b=1:nNodes(geospiza), ##' row.names=nodeId(geospiza, "internal")) ##' t1 <- addData(geospiza, node.data=nDt) setGeneric("addData", function(x, ...) { standardGeneric("addData") }) ##' @rdname addData-methods ##' @aliases addData-methods addData,phylo4-method setMethod("addData", signature(x="phylo4d"), function(x, tip.data=NULL, node.data=NULL, all.data=NULL, merge.data=TRUE, pos=c("after", "before"), ...) { pos <- match.arg(pos) ## apply formatData to ensure data have node number rownames and ## correct dimensions tip.data <- formatData(phy=x, dt=tip.data, type="tip", ...) node.data <- formatData(phy=x, dt=node.data, type="internal", ...) all.data <- formatData(phy=x, dt=all.data, type="all", ...) ## combine data as needed new.data <- .phylo4Data(x=x, tip.data=tip.data, node.data=node.data, all.data=all.data, merge.data=merge.data) if (all(dim(new.data) == 0)) { return(x) } if (all(dim(x@data) == 0)) { x@data <- new.data return(x) } if (identical(pos, "after")) { new.data <- merge(x@data, new.data, by=0, all=TRUE, sort=FALSE, suffixes=c(".old", ".new")) } else { new.data <- merge(new.data, x@data, by=0, all=TRUE, sort=FALSE, suffixes=c(".new", ".old")) } row.names(new.data) <- new.data[["Row.names"]] x@data <- new.data[, -match("Row.names", names(new.data)), drop = FALSE] x }) ##' @rdname addData-methods ##' @aliases addData,phylo4d-method setMethod("addData", signature(x="phylo4"), function(x, tip.data=NULL, node.data=NULL, all.data=NULL, merge.data=TRUE, pos=c("after", "before"), ...) { phylo4d(x, tip.data=tip.data, node.data=node.data, all.data=all.data, merge.data=merge.data, ...) }) phylobase/R/zzz.R0000644000176200001440000000047614553646170013443 0ustar liggesusers ".phylobase.Options" <- list(retic = "fail", singleton = "warn", multiroot = "warn", poly = "ok", allow.duplicated.labels = "warn") .onAttach <- function(library, pkg) { ## we can't do this in .onLoad unlockBinding(".phylobase.Options", asNamespace("phylobase")) } phylobase/R/formatData.R0000644000176200001440000002150514553646170014664 0ustar liggesusers##' Format data for use in phylo4d objects ##' ##' Associates data with tree nodes and applies consistent formatting ##' rules. ##' ##' ##' \code{formatData} is an internal function that should not be ##' called directly by the user. It is used to format data provided by ##' the user before associating it with a tree, and is called ##' internally by the \code{phylo4d}, \code{tdata}, and \code{addData} ##' methods. However, users may pass additional arguments to these ##' methods in order to control how the data are matched to nodes. ##' ##' Rules for matching rows of data to tree nodes are determined ##' jointly by the \code{match.data} and \code{rownamesAsLabels} ##' arguments. If \code{match.data} is TRUE, data frame rows will be ##' matched exclusively against tip and node labels if ##' \code{rownamesAsLabels} is also TRUE, whereas any all-digit row ##' names will be matched against tip and node numbers if ##' \code{rownamesAsLabels} is FALSE (the default). If ##' \code{match.data} is FALSE, \code{rownamesAsLabels} has no effect, ##' and row matching is purely positional with respect to the order ##' returned by \code{nodeId(phy, type)}. ##' ##' \code{formatData} (1) converts labels provided in the data into ##' node numbers, (2) makes sure that the data are appropriately ##' matched against tip and/or internal nodes, (3) checks for ##' differences between data and tree, (4) creates a data frame with ##' the correct dimensions given a tree. ##' ##' @param phy a valid \code{phylo4} object ##' @param dt a data frame, matrix, vector, or factor ##' @param type type of data to attach ##' @param match.data (logical) should the rownames of the data frame ##' be used to be matched against tip and internal node identifiers? ##' See details. ##' @param rownamesAsLabels (logical), should the row names of the ##' data provided be matched only to labels (TRUE), or should any ##' number-like row names be matched to node numbers (FALSE and ##' default) ##' @param label.type character, \code{rownames} or \code{column}: ##' should the labels be taken from the row names of \code{dt} or from ##' the \code{label.column} column of \code{dt}? ##' @param label.column if \code{label.type=="column"}, column ##' specifier (number or name) of the column containing tip labels ##' @param missing.data action to take if there are missing data or if ##' there are data labels that don't match ##' @param extra.data action to take if there are extra data or if ##' there are labels that don't match ##' @param keep.all (logical), should the returned data have rows for ##' all nodes (with NA values for internal rows when type='tip', and ##' vice versa) (TRUE and default) or only rows corresponding to the ##' type argument ##' @return \code{formatData} returns a data frame having node numbers ##' as row names. The data frame is also formatted to have the correct ##' dimension given the \code{phylo4} object provided. ##' @author Francois Michonneau ##' @seealso the \code{\link{phylo4d-methods}} constructor, the ##' \linkS4class{phylo4d} class. See \code{\link{coerce-methods}} for ##' translation functions. ##' @keywords misc formatData <- function(phy, dt, type=c("tip", "internal", "all"), match.data=TRUE, rownamesAsLabels=FALSE, label.type=c("rownames", "column"), label.column=1, missing.data=c("fail", "warn", "OK"), extra.data=c("warn", "OK", "fail"), keep.all=TRUE ) { ## determine whether to return rows for all nodes, or just 'type' type <- match.arg(type) if (keep.all) { ids.out <- nodeId(phy, "all") } else { ids.out <- nodeId(phy, type) } ## if null, return empty data frame with node numbers as row names if (is.null(dt)) { return(data.frame(row.names=ids.out)) } ## if vector, coerce to data.frame if (is.vector(dt) || is.factor(dt) || is.matrix(dt)) { dt <- as.data.frame(dt, stringsAsFactors = TRUE) } ## before proceeding, make sure that data provided are a data frame if (!is.data.frame(dt)) { stop(paste(deparse(substitute(dt)), "must be a vector, factor, matrix, or data frame")) } ## if lacking rows or columns, return a placeholder data frame with ## node numbers as row names if (any(dim(dt)==0)) { return(data.frame(row.names=ids.out)) } label.type <- match.arg(label.type) ## Make sure the column specified for the labels is appropriate if (label.type == "column") { if (is.numeric(label.column)) stopifnot(label.column %in% 1:ncol(dt)) else stopifnot(label.column %in% names(dt)) } missing.data <- match.arg(missing.data) extra.data <- match.arg(extra.data) if(match.data) { ## extract values to be matched to nodes ndNames <- switch(label.type, rownames = rownames(dt), column = dt[,label.column]) if (rownamesAsLabels) { ids.in <- lapply(ndNames, function(ndnm) { getNode(phy, as.character(ndnm), missing="OK") }) } else { ids.in <- lapply(ndNames, function(ndnm) { if (nchar(gsub("[0-9]", "", ndnm)) == 0) { getNode(phy, as.integer(ndnm), missing="OK") } else { getNode(phy, as.character(ndnm), missing="OK") } }) } ids.list <- ids.in ids.in <- unlist(ids.in) ## Make sure that data are matched to appropriate nodes if (type=="tip" && any(stats::na.omit(ids.in) %in% nodeId(phy, "internal"))) { stop("Your tip data are being matched to internal ", "nodes. Make sure that your data identifiers ", "are correct.") } if (type=="internal" && any(stats::na.omit(ids.in) %in% nodeId(phy, "tip"))) { stop("Your node data are being matched to tip ", "nodes. Make sure that your data identifiers ", "are correct.") } ## Check differences between tree and data mssng <- setdiff(nodeId(phy, type), ids.in) if(length(mssng) > 0 && missing.data != "OK") { ## provide label if it exists and node number otherwise mssng <- getNode(phy, mssng) mssng <- ifelse(is.na(names(mssng)), mssng, names(mssng)) msg <- "The following nodes are not found in the dataset: " msg <- paste(msg, paste(mssng, collapse=", ")) switch(missing.data, warn = warning(msg), fail = stop(msg)) } extra <- ndNames[is.na(ids.in)] if(length(extra) > 0 && extra.data != "OK") { msg <- "The following names are not found in the tree: " msg <- paste(msg, paste(extra, collapse=", ")) switch(extra.data, warn = warning(msg), fail = stop(msg)) } ## Format data to have correct dimensions ids.list <- ids.list[!is.na(ids.list)] dt <- dt[!is.na(ids.in), , drop=FALSE] if (hasDuplicatedLabels(phy)) { dtTmp <- array(, dim=c(length(ids.in[!is.na(ids.in)]), ncol(dt)), dimnames=list(ids.in[!is.na(ids.in)], names(dt))) dtTmp <- data.frame(dtTmp) j <- 1 for (i in 1:length(ids.list)) { for (k in 1:length(ids.list[[i]])) { dtTmp[j, ] <- dt[i, , drop=FALSE] j <- j + 1 } } dt <- dtTmp } rownames(dt) <- ids.in[!is.na(ids.in)] dt.out <- dt[match(ids.out, rownames(dt)), , drop=FALSE] rownames(dt.out) <- ids.out if(label.type == "column") { dt.out <- subset(dt.out, select=-eval(parse(text=label.column))) } } else { ## Check if too many or not enough rows in input data expected.nrow <- length(nodeId(phy, type)) diffNr <- nrow(dt) - expected.nrow if(nrow(dt) > expected.nrow && extra.data != "OK") { msg <- paste("There are", diffNr, "extra rows.") switch(extra.data, warn = warning(msg), fail = stop(msg)) } if(nrow(dt) < expected.nrow && missing.data != "OK") { msg <- paste("There are", abs(diffNr), "missing rows.") switch(missing.data, warn = warning(msg), fail = stop(msg)) } ## truncate rows of input data frame if necessary dt <- dt[1:min(nrow(dt), expected.nrow) ,, drop = FALSE] rownames(dt) <- nodeId(phy, type)[seq_len(nrow(dt))] dt.out <- dt[match(ids.out, rownames(dt)) ,, drop=FALSE] rownames(dt.out) <- ids.out } dt.out } phylobase/R/phylo4-methods.R0000644000176200001440000001576114553646170015471 0ustar liggesusers ##' Create a phylogenetic tree ##' ##' \code{phylo4} is a generic constructor that creates a phylogenetic tree ##' object for use in phylobase methods. Phylobase contains functions for input ##' of phylogenetic trees and data, manipulation of these objects including ##' pruning and subsetting, and plotting. The phylobase package also contains ##' translation functions to forms used in other comparative phylogenetic method ##' packages. ##' ##' The minimum information necessary to create a phylobase tree object is a ##' valid edge matrix. The edge matrix describes the topology of the phylogeny. ##' Each row describes a branch of the phylogeny, with the (descendant) node ##' number in column 2 and its ancestor's node number in column 1. These numbers ##' are used internally and must be unique for each node. ##' ##' The labels designate either nodes or edges. The vector \code{node.label} ##' names internal nodes, and together with \code{tip.label}, name all nodes in ##' the tree. The vector \code{edge.label} names all branches in the tree. All ##' label vectors are optional, and if they are not given, internally-generated ##' labels will be assigned. The labels, whether user-specified or internally ##' generated, must be unique as they are used to join species data with ##' phylogenetic trees. ##' ##' \code{phylobase} also allows to create \code{phylo4} objects using ##' the function \code{phylo4()} from objects of the classes: ##' \code{phylo} (from \code{ape}), and \code{nexml} (from \code{RNeXML}). ##' ##' @name phylo4-methods ##' @docType methods ##' @param x a matrix of edges or an object of class \code{phylo} (see above) ##' @param edge A numeric, two-column matrix with as many rows as branches in ##' the phylogeny. ##' @param edge.length Edge (branch) length. (Optional) ##' @param tip.label A character vector of species names (names of "tip" nodes). ##' (Optional) ##' @param node.label A character vector of internal node names. (Optional) ##' @param edge.label A character vector of edge (branch) names. (Optional) ##' @param order character: tree ordering (allowable values are listed in ##' \code{phylo4_orderings}, currently "unknown", "preorder" (="cladewise" in ##' \code{ape}), and "postorder", with "cladewise" and "pruningwise" also ##' allowed for compatibility with \code{ape}) ##' @param check.node.labels if \code{x} is of class \code{phylo}, either "keep" ##' (the default) or "drop" node labels. This argument is useful if the ##' \code{phylo} object has non-unique node labels. ##' @param annote any additional annotation data to be passed to the new object ##' @param \dots optional arguments (none used at present). ##' @note Translation functions are available from many valid tree formats. See ##' \link{coerce-methods}. ##' @author phylobase team ##' @seealso \code{\link{coerce-methods}} for translation ##' functions. The \linkS4class{phylo4} class. See also the ##' \code{\link{phylo4d-methods}} constructor, and ##' \linkS4class{phylo4d} class. ##' @export ##' @aliases phylo4 ##' @rdname phylo4-methods ##' @include internal-constructors.R phylo4-class.R oldclasses-class.R ##' @examples ##' ##' # a three species tree: ##' mytree <- phylo4(x=matrix(data=c(4,1, 4,5, 5,2, 5,3, 0,4), ncol=2, ##' byrow=TRUE), tip.label=c("speciesA", "speciesB", "speciesC")) ##' mytree ##' plot(mytree) ##' ##' # another way to specify the same tree: ##' mytree <- phylo4(x=cbind(c(4, 4, 5, 5, 0), c(1, 5, 2, 3, 4)), ##' tip.label=c("speciesA", "speciesB", "speciesC")) ##' ##' # another way: ##' mytree <- phylo4(x=rbind(c(4, 1), c(4, 5), c(5, 2), c(5, 3), c(0, 4)), ##' tip.label=c("speciesA", "speciesB", "speciesC")) ##' ##' # with branch lengths: ##' mytree <- phylo4(x=rbind(c(4, 1), c(4, 5), c(5, 2), c(5, 3), c(0, 4)), ##' tip.label=c("speciesA", "speciesB", "speciesC"), edge.length=c(1, .2, ##' .8, .8, NA)) ##' plot(mytree) ##' setGeneric("phylo4", function(x, ...) { standardGeneric("phylo4")} ) ## ape orderings should be allowed for so we can import trees from ape ## e.g. during subsetting ##' @rdname phylo4-methods ##' @aliases phylo4_orderings phylo4_orderings <- c("unknown", "preorder", "postorder", "pruningwise", "cladewise") ##' @rdname phylo4-methods ##' @aliases phylo4,matrix-method setMethod("phylo4", "matrix", function(x, edge.length = NULL, tip.label = NULL, node.label = NULL, edge.label = NULL, order="unknown", annote = list()) { ## edge edge <- x mode(edge) <- "integer" if(ncol(edge) > 2) warning("The edge matrix has more than two columns, ", "only the first two columns are considered.") edge <- as.matrix(edge[, 1:2]) colnames(edge) <- c("ancestor", "descendant") ## create new phylo4 object and insert edge matrix res <- new("phylo4") res@edge <- edge ## get number of tips and number of nodes ## (these accessors work fine now that edge matrix exists) ntips <- nTips(res) nnodes <- nNodes(res) ## edge.length (drop elements if all are NA but keep the vector named) edge.length <- .createEdge(value=edge.length, edgeMat=edge, type="lengths", use.names=FALSE) if (all(is.na(edge.length))) { edge.length <- numeric() attributes(edge.length) <- list(names=character(0)) } ## edge.label (drop NA elements) edge.label <- .createEdge(value=edge.label, edgeMat=edge, type="labels", use.names=FALSE) edge.label <- edge.label[!is.na(edge.label)] ## tip.label (leave NA elements; let checkTree complain about it) tip.label <- .createLabels(value=tip.label, ntips=ntips, nnodes=nnodes, type="tip") ## node.label (drop NA elements) node.label <- .createLabels(node.label, ntips=ntips, nnodes=nnodes, type="internal") node.label <- node.label[!is.na(node.label)] ## populate the slots res@edge.length <- edge.length res@label <- c(tip.label, node.label) res@edge.label <- edge.label res@order <- order res@annote <- annote ## checkPhylo4 will return a character string if object is ## bad, otherwise TRUE if (is.character(checkval <- checkPhylo4(res))) stop(checkval) return(res) }) ##' @rdname phylo4-methods ##' @aliases phylo4,phylo-method setMethod("phylo4", c("phylo"), function(x, check.node.labels=c("keep", "drop"), annote=list()){ check.node.labels <- match.arg(check.node.labels) if (check.node.labels == "drop") x$node.label <- NULL res <- as(x, "phylo4") #TODO?: make default annote arg NULL, and only assign if !is.null; # then update phylo4d methods accordingly (same thing with metadata?) res@annote <- annote return(res) }) ##' @rdname phylo4-methods ##' @aliases nexml,phylo4-method setMethod("phylo4", c("nexml"), function(x) { tr <- RNeXML::get_trees_list(x) if (is.null(tr)) { new("phylo4") } else { if (length(tr) > 1) { warning("Only the first tree has been imported.") } phylo4(x=tr[[1]][[1]]) } }) phylobase/R/nodeId-methods.R0000644000176200001440000000625114553646170015446 0ustar liggesusers ##' nodeId methods ##' ##' These functions gives the node (\code{nodeId}) or edge ##' (\code{edgeId}) identity. ##' ##' \code{nodeId} returns the node in ascending order, and ##' \code{edgeId} in the same order as the edges are stored in the ##' edge matrix. ##' ##' @param x a \code{phylo4} or \code{phylo4d} object. ##' @param type a character vector indicating which subset of the ##' nodes or edges you are interested in. ##' @return \describe{ ##' \item{nodeId}{an integer vector indicating node numbers} ##' \item{edgeId}{a character vector indicating the edge identity} ##' } ##' @export ##' @docType methods ##' @rdname nodeId-methods ##' @include phylo4-class.R phylo4-methods.R phylo4-accessors.R root-methods.R ##' @examples ##' data(geospiza) ##' identical(nodeId(geospiza, "tip"), 1:nTips(geospiza)) ##' nodeId(geospiza, "internal") ##' edgeId(geospiza, "internal") ##' nodeId(geospiza, "root") setGeneric("nodeId", function(x, type=c("all", "tip", "internal", "root")) { standardGeneric("nodeId") }) ##' @rdname nodeId-methods ##' @aliases nodeId,phylo4-method setMethod("nodeId", signature(x="phylo4"), function(x, type=c("all", "tip","internal","root")) { type <- match.arg(type) E <- edges(x) ## Note: this implementation will still work even if tips are not ## 1:nTips and nodes are not (nTips+1):nNodes nid <- switch(type, ## all nodes appear at least once in the edge matrix ## twice slower: all = unique(as.vector(E)[as.vector(E) != 0]), ## but maybe should be used if tree is not "normal" all = { if (isRooted(x)) { res <- getAllNodesFast(x@edge)[-1] } else { res <- getAllNodesFast(x@edge) } res }, ## tips are nodes that do not appear in the ancestor column ## three times slower: setdiff(E[, 2], E[, 1]), tip = tipsFast(x@edge[,1]), ## internals are nodes that *do* appear in the ancestor column ## about 0.5 faster than: setdiff(getAllNodesFast(x@edge, isRooted(x)), tipsFast(x@edge[,1])), internal = unique(E[E[, 1] != 0, 1]), ## roots are nodes that have NA as ancestor root = if (!isRooted(x)) return(NA) else unname(E[E[, 1] == 0, 2])) return(sort(nid)) }) #### ----- edgeId ##' @rdname nodeId-methods ##' @aliases edgeId ##' @export setGeneric("edgeId", function(x, type=c("all", "tip", "internal", "root")) { standardGeneric("edgeId") }) ##' @rdname nodeId-methods ##' @aliases edgeId,phylo4-method setMethod("edgeId", signature(x="phylo4"), function(x, type=c("all", "tip", "internal", "root")) { type <- match.arg(type) edge <- edges(x) if (type=="tip") { isTip <- !(edge[, 2] %in% edge[, 1]) edge <- edge[isTip, , drop=FALSE] } else if (type=="internal") { isInt <- (edge[, 2] %in% edge[, 1]) edge <- edge[isInt, , drop=FALSE] } else if (type=="root") { isRoot <- edge[, 1] == 0 edge <- edge[isRoot, , drop=FALSE] } # else just use complete edge matrix if type is "all" id <- paste(edge[, 1], edge[, 2], sep="-") return(id) }) phylobase/R/phylomats-class.R0000644000176200001440000001204114553646170015720 0ustar liggesusers ##' matrix classes for phylobase ##' ##' Classes representing phylogenies as matrices ##' ##' ##' @name phylomat-class ##' @aliases phylo4vcov-class as_phylo4vcov ##' @docType class ##' @param from a \code{phylo4} object ##' @param \dots optional arguments, to be passed to \code{vcov.phylo} in ##' \code{ape} (the main useful option is \code{cor}, which can be set to ##' \code{TRUE} to compute a correlation rather than a variance-covariance ##' matrix) ##' @section Objects from the Class: These are square matrices (with rows and ##' columns corresponding to tips, and internal nodes implicit) with different ##' meanings depending on the type (variance-covariance matrix, distance matrix, ##' etc.). ##' @author Ben Bolker ##' @rdname phylomat-class ##' @keywords classes ##' @export ##' @examples ##' tree_string <- "(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);" ##' tree.owls <- ape::read.tree(text=tree_string) ##' o2 <- as(tree.owls,"phylo4") ##' ov <- as(o2,"phylo4vcov") ##' o3 <- as(ov,"phylo4") ##' ## these are not completely identical, but are ##' ## topologically identical ... ##' ##' ## edge matrices are in a different order: ##' ## cf. edges(o2) and edges(o3) ##' ## BUT the edge matrices are otherwise identical ##' o2edges <- edges(o2) ##' o3edges <- edges(o3) ##' identical(o2edges[order(o2edges[,2]),], ##' o3edges[order(o3edges[,2]),]) ##' ##' ## There is left/right ambiguity here in the tree orders: ##' ## in o2 the 5->6->7->1 lineage ##' ## (terminating in Strix aluco) ##' ## is first, in o3 the 5->6->3 lineage ##' ## (terminating in Athene noctua) is first. ##' ##' ## define class for phylogenetic var-cov matrices setClass("phylo4vcov", representation("matrix", edge.label="character", order="character")) ## phylo4 -> var-cov: simply wrap ape::vcv.phylo ## and add other slots as_phylo4vcov <- function(from,...) { m <- ape::vcv.phylo(as(from,"phylo"),...) new("phylo4vcov", m, edge.label=from@edge.label, order=from@order) } ##' @name phylomat-setAs ##' @rdname phylomat-class ##' @aliases setAs,phylo,phylo4vcov-method setAs("phylo4","phylo4vcov", function(from,to) { as_phylo4vcov(from)}) ##' @name phylomat-setAs ##' @rdname phylomat-class ##' @aliases setAs,phylo4vcov,phylo4-method setAs("phylo4vcov","phylo4", function(from,to) { matrix2tree <- function(v,reorder=TRUE) { ## no polytomies allowed va <- v tipnames <- rownames(v) ntip <- nrow(v) dimnames(v) <- list(as.character(1:ntip), as.character(1:ntip)) diag(va) <- 0 edgemat <- matrix(ncol=2,nrow=0) ## termlens <- diag(v)-colSums(va) edgelens <- numeric(0) ## maxnode <- ntip curnode <- 2*ntip ## one greater than total number of nodes ## can we do this in a different order? while (nrow(v)>1) { mva <- max(va) ## find pair with max shared evolution nextpr <- if (nrow(v)==2) c(1,2) else which(va==mva,arr.ind=TRUE)[1,] ## maxnode <- maxnode+1 ## new node curnode <- curnode-1 ## points to both of current identified nodes ## (indexed by names) edgemat <- rbind(edgemat, c(curnode,as.numeric(rownames(v)[nextpr[1]])), c(curnode,as.numeric(rownames(v)[nextpr[2]]))) ## descending edges are amount of *unshared* evolution edgelens <- c(edgelens, diag(v)[nextpr]-mva) ## this clade has total evolution = shared evolution diag(v)[nextpr] <- mva ## assign new node name rownames(v)[nextpr[1]] <- colnames(v)[nextpr[1]] <- curnode ## drop rows/cols from matrix v <- v[-nextpr[2],-nextpr[2],drop=FALSE] va <- va[-nextpr[2],-nextpr[2],drop=FALSE] } ## switch order of node numbers to put root in the right place: ## much plotting code seems to assume root = node # (ntips+1) ## browser() reorder <- FALSE if (reorder) { nn <- nrow(edgemat) nnode <- nn-ntip+1 newedge <- edgemat for (i in 2:nnode) { newedge[edgemat==(ntip+i)] <- nn-i+2 } edgemat <- newedge } list(edgemat=edgemat, edgelens=edgelens) } temptree <- matrix2tree(from) ## browser() ## add explicit root rootnode <- which(tabulate(temptree$edgemat[,2])==0) ## add root node to edge matrix and branch lengths temptree$edgemat <- rbind(temptree$edgemat, c(0, rootnode)) temptree$edgelens <- c(temptree$edgelens,NA) reorder(phylo4(temptree$edgemat,edge.length=temptree$edgelens, tip.label=rownames(from), edge.label=from@edge.label,order="unknown"), "preorder") }) phylobase/R/pdata.R0000644000176200001440000001041514553646170013671 0ustar liggesusers## define class for traits ptypes <- c("multitype","binary","continuous","DNA","RNA","aacid", "other","unknown") ##' Class "pdata" ##' ##' Data class for phylo4d objects ##' ##' ##' @name pdata-class ##' @aliases ptypes pdata-class [<-,pdata-method [,pdata-method ##' [,pdata,ANY,ANY,ANY-method [[,pdata-method [[<-,pdata-method ##' [[,pdata,ANY,ANY-method [[,pdata,ANY,missing-method ##' @docType class ##' @section Objects from the Class: Objects can be created by calls of the form ##' \code{new("pdata", ...)}. ##' @author Ben Bolker ##' @keywords classes #### @export setClass("pdata", representation(data="data.frame", type="factor", comment="character", metadata="list"), prototype=list(data=data.frame(),type=factor(), comment=character(0),metadata=list())) ## pdata constructor ##' Constructor for pdata (phylogenetic data) class ##' ##' Combine data, type, comments, and metadata information to create a new pdata ##' object, or check such an object for consistency ##' ##' ##' @aliases pdata check_pdata ##' @param data a data frame ##' @param type a factor with levels as specified by \linkS4class{pdata}, the ##' same length as \code{ncol(data)} ##' @param comment a character vector, the same length as \code{ncol(data)} ##' @param metadata an arbitrary list ## @param object an object of class \code{pdata} ##' @return An object of class \code{pdata} ##' @author Ben Bolker ##' @seealso \linkS4class{pdata} ##' @keywords misc pdata <- function(data,type,comment,metadata) { nvar <- ncol(data) if (missing(type)) { type <- factor(rep("unknown",nvar),levels=ptypes) } if (length(type)==1) type <- rep(type,length.out=nvar) type <- factor(as.character(type),levels=ptypes) if (length(comment)==1) comment <- rep(comment,length.out=nvar) obj <- new("pdata",data=data,type=type,comment=comment,metadata) check_pdata(obj) obj } check_pdata <- function(object) { nvar <- ncol(object@data) badlevels <- levels(object@type)[!levels(object@type) %in% ptypes] if (length(badlevels)>0) stop(paste("bad levels in types:",paste(badlevels,collapse=","))) if (length(object@comment)>1 && length(object@comment)!=nvar) { stop("wrong number of comments") } if (length(object@type)>1 && length(object@type)!=nvar) { stop("wrong number of types") } } ## setMethod("[","pdata",function(x,i, j,...,drop=FALSE) { ## xd <- x@data[i,j,...,drop=drop] ## xd2 <- as.data.frame(xd) ## xd2 ## }) ## #### @exportMethod [<- ## setGeneric("[<-") ## setMethod("[<-","pdata",function(x,i, j,...,drop=FALSE,value) { ## "[<-"(x@data,i,j,...,drop=drop,value) ## }) ## ### @exportMethod [[ ## setGeneric("[[") ## setMethod("[[","pdata", ## function(x,i,j,...,exact=NA) { ## x@data[[i,j,...,exact=exact]] ## }) ## #### @exportMethod [[<- ## setGeneric("[[<-") ## setMethod("[[<-","pdata", ## function(x,i,j,...,exact=NA,value) { ## "[[<-"(x@data,i,j,...,exact=exact,value) ## }) ## setMethod("plot",signature(x="pdata",y="missing"), function(x,...){ ## return(plot(x@data, ...)) ## }) # end plot phylo4 ## od = data.frame(a=1:3,b=4:6) ## z = new("pdata", ## data=od,type=factor("a","b"), ## comment=c("",""),metadata=list()) ## z[2,] ## z[,"a"] ## z[[2]] ## test conflict resolution error ####### ### old code retrieved from misc/ folder ## setClass("pdata", representation(x="vector", y="vector")) ## setMethod("[","pdata",function(x,i, j,...,drop=TRUE)new("pdata",x=x@x[i],y=x@y[i])) # x <- new("pdata", x=c("a","b", "c", "d", "3"), y=c(1:5)) #>x[c(2,4)] #An object of class pdata #Slot "x": #[1] "b" "d" # #Slot "y": #[1] 2 4 # doesn't work #setClass("track", representation("list", comment="character", metadata="vector"), contains="list", prototype(list(), comment="", metadata=NA)) #setMethod("[","track",function(x,i, j,...,drop=TRUE)new("track", list(lapply(x, function(x, i, j, ..., drop=TRUE) x@.Data[i])))) # this works, how to incorporate into method above? #> lapply(x, function(x, i=2, j, ..., drop=TRUE) x@.Data[i]) #$x #[1] "b" #$y #[1] 2 # this works, but list structure is destroyed #> mapply(function(x, i, j, ..., drop=TRUE) x@.Data[i], x, 2) # x y #"b" "2" phylobase/R/phylo4d-class.R0000644000176200001440000000235114553646170015266 0ustar liggesusers################################### ## phylo4d class ## extend: phylo with data ##' phylo4d class ##' ##' S4 class for phylogenetic tree and data. ##' ##' ##' @name phylo4d-class ##' @docType class ##' @section Objects from the Class: Objects can be created from various trees ##' and a data.frame using the constructor \code{phylo4d}, or using ##' \code{new("phylo4d", \dots{})} for empty objects. ##' @author Ben Bolker, Thibaut Jombart ##' @seealso \code{\link{coerce-methods}} for translation ##' functions. The \code{\link{phylo4d-methods}} constructor. See also ##' the \code{\link{phylo4-methods}} constructor, the ##' \linkS4class{phylo4} class, and the \code{\link{checkPhylo4}} ##' function to check the validity of \code{phylo4} trees. ##' @keywords classes ##' @export ##' @include phylo4-methods.R formatData.R ##' @examples ##' example(read.tree, "ape") ##' obj <- phylo4d(as(tree.owls.bis,"phylo4"), data.frame(wing=1:3)) ##' obj ##' names(obj) ##' summary(obj) setClass("phylo4d", representation(data="data.frame", metadata = "list"), prototype = list( data = data.frame(NULL), metadata = list()), validity = checkPhylo4, contains = "phylo4") phylobase/R/treePlot.R0000644000176200001440000007652114553655652014415 0ustar liggesusers##' Phylogeny plotting ##' ##' Plot \code{phylo4} or \code{phylo4d} objects, including associated data. ##' ##' ##' @name treePlot-methods ##' @aliases treePlot plot,ANY,ANY-method plot,pdata,missing-method ##' plot,phylo4,missing-method treePlot-method treePlot,phylo4,phylo4d-method ##' @docType methods ##' @details Currently, \code{treePlot} can only plot numeric values ##' for tree-associated data. The dataset will be subset to only ##' include columns of class \code{numeric}, \code{integer} or ##' \code{double}. If a \code{phylo4d} object is passed to the ##' function and it contains no data, or if the data is in a format ##' that cannot be plotted, the function will produce a warning. You ##' can avoid this by using the argument \code{plot.data=FALSE}. ##' @param phy A \code{phylo4} or \code{phylo4d} object ##' @param x A \code{phylo4} or \code{phylo4d} object ##' @param y (only here for compatibility) ##' @param type A character string indicating the shape of plotted tree ##' @param show.tip.label Logical, indicating whether tip labels should be shown ##' @param show.node.label Logical, indicating whether node labels should be ##' shown ##' @param tip.order If NULL the tree is plotted with tips in preorder, if "rev" ##' this is reversed. Otherwise, it is a character vector of tip labels, ##' indicating their order along the y axis (from top to bottom). Or, a numeric ##' vector of tip node IDs indicating the order. ##' @param plot.data Logical indicating whether \code{phylo4d} data should be ##' plotted ##' @param rot Numeric indicating the rotation of the plot in degrees ##' @param tip.plot.fun A function used to generate plot at the each tip of the ##' phylogenetic trees ##' @param edge.color A vector of colors in the order of \code{edges(phy)} ##' @param node.color A vector of colors indicating the colors of the node ##' labels ##' @param tip.color A vector of colors indicating the colors of the tip labels ##' @param edge.width A vector in the order of \code{edges(phy)} indicating the ##' widths of edge lines ##' @param newpage Logical indicating whether the page should be cleared before ##' plotting ##' @param plot.at.tip should the data plots be at the tip? (logical) ##' @param margins number of lines around the plot (similar to \code{par(mar)}). ##' @param \dots additional arguments ##' @return No return value, function invoked for plotting side effect ##' @section Methods: \describe{ \item{phy = "phylo4"}{plots a tree of class ##' \linkS4class{phylo4}} \item{phy = "phylo4d"}{plots a tree with one or more ##' quantitative traits contained in a \linkS4class{phylo4d} object.} } ##' @author Peter Cowan \email{pdc@@berkeley.edu}, Francois Michonneau ##' @seealso \code{\link{phylobubbles}} ##' @keywords methods ##' @export ##' @examples ##' ##' ## example of plotting two grid plots on the same page ##' library(grid) ##' data(geospiza) ##' geotree <- extractTree(geospiza) ##' grid.newpage() ##' pushViewport(viewport(layout=grid.layout(nrow=1, ncol=2), name="base")) ##' pushViewport(viewport(layout.pos.col=1, name="plot1")) ##' treePlot(geotree, newpage=FALSE) ##' popViewport() ##' ##' pushViewport(viewport(layout.pos.col=2, name="plot2")) ##' treePlot(geotree, newpage=FALSE, rot=180) ##' popViewport(2) `treePlot` <- function(phy, type = c('phylogram', 'cladogram', 'fan'), show.tip.label = TRUE, show.node.label = FALSE, tip.order = NULL, plot.data = is(phy, 'phylo4d'), rot = 0, tip.plot.fun = 'bubbles', plot.at.tip = TRUE, edge.color = 'black', node.color = 'black', # TODO what do with node.color parameter tip.color = 'black', edge.width = 1, # TODO line-type modification hack newpage = TRUE, margins = c(1.1, 1.1, 1.1, 1.1), # number of lines, same as par(mar) ... ) { ## TODO three dimensional histogram as example, compute values on full dataset ## then generate phylo4d object with summary data and plot ## TODO factors not handled in data plots ## TODO add symbols at the nodes, allow coloirng and sizing downViewport approach? ## TODO cladogram methods incorrect ## because we may reoder the tip, we need to update the phy objec if (!inherits(phy, 'phylo4')) stop('treePlot requires a phylo4 or phylo4d object') if (!isRooted(phy)) stop("treePlot function requires a rooted tree.") if (plot.data) { if (!hasTipData(phy)) { warning("tree has no tip data to plot") plot.data <- FALSE } else { ## if new plotting functions are developped that allow users to plot other type of data ## this needs to be removed/adjusted ## other checks are being made in phylobubbles() if (!any(sapply(tdata(phy, "tip"), function(x) class(x) %in% c("numeric", "double", "integer")))) { warning("only numeric data can be plotted at this time") plot.data <- FALSE } } } if (hasRetic(phy)) stop("treePlot requires non-reticulated trees.") if(newpage) grid::grid.newpage() type <- match.arg(type) Nedges <- nEdges(phy) Ntips <- nTips(phy) if(!is.null(tip.order) && length(tip.order) > 1) { ## if length of tip.order is more than 1 it can't be "rev" if(length(tip.order) != Ntips) {stop('tip.order must be the same length as nTips(phy)')} if(is.numeric(tip.order)) { tip.order <- tip.order } else { if(is.character(tip.order)) { tip.order <- as.numeric(names(tipLabels(phy))[match(tip.order, tipLabels(phy))]) } } tip.order <- rev(tip.order) } ## TODO remove the false cladogram option? if(!hasEdgeLength(phy) || type == 'cladogram') { edgeLength(phy) <- rep(1, Nedges) } xxyy <- phyloXXYY(phy, tip.order) if(type == 'cladogram') { xxyy$xx[edges(xxyy$phy)[, 2] <= Ntips] <- 1 } ## plotViewport is a convience function that provides margins in lines grid::pushViewport(grid::plotViewport(margins=margins)) if(!plot.data) { plotOneTree(xxyy, type, show.tip.label, show.node.label, edge.color, node.color, tip.color, edge.width, rot) } else { if(!is.function(tip.plot.fun)) { if(tip.plot.fun == "bubbles") { phylobubbles( type = type, show.node.label = show.node.label, rot = 0, edge.color = edge.color, node.color = node.color, # TODO what do with node.color parameter tip.color = tip.color, edge.width = edge.width, # TODO line-type modification hack newpage = TRUE, ..., XXYY = xxyy ) } else { stop(paste(tip.plot.fun, 'is neither a function or a recognized plot type')) } } else { ## from -- if(tip.plot.fun == "bubbles") ## plot.at.tip <- TRUE if (plot.at.tip) { tip.data.plot( xxyy = xxyy, type = type, show.tip.label = show.tip.label, show.node.label = show.node.label, rot = 0, tip.plot.fun = tip.plot.fun, edge.color = edge.color, node.color = node.color, # TODO what do with node.color parameter tip.color = tip.color, edge.width = edge.width, # TODO line-type modification hack newpage = TRUE, ... ) return(invisible()) } ## if (plot.at.tip) } ## else } ## else grid::upViewport() # margins } ##' Plot a phylo4 object ##' ##' Plots the phylogenetic tree contained in a \code{phylo4} or \code{phylo4d} ##' object. ##' ##' ##' @param xxyy A list created by the \code{\link{phyloXXYY}} function ##' @param type A character string indicating the shape of plotted tree ##' @param show.tip.label Logical, indicating whether tip labels should be shown ##' @param show.node.label Logical, indicating whether node labels should be ##' shown ##' @param edge.color A vector of colors in the order of \code{edges(phy)} ##' @param node.color A vector of colors indicating the colors of the node ##' labels ##' @param tip.color A vector of colors indicating the colors of the tip labels ##' @param edge.width A vector in the order of \code{edges(phy)} indicating the ##' widths of edge lines ##' @param rot Numeric indicating the rotation of the plot in degrees ##' @return Returns no values, function invoked for the plotting side effect. ##' @author Peter Cowan \email{pdc@@berkeley.edu} ##' @seealso \code{treePlot}, \code{\link{phyloXXYY}} ##' @export ##' @keywords methods ##' @examples ##' library(grid) ##' data(geospiza) ##' grid.newpage() ##' xxyy <- phyloXXYY(geospiza) ##' plotOneTree(xxyy, type = 'phylogram', ##' show.tip.label = TRUE, show.node.label = TRUE, ##' edge.color = 'black', node.color = 'orange', tip.color = 'blue', ##' edge.width = 1, rot = 0 ##' ) ##' ##' grid.newpage() ##' pushViewport(viewport(w = 0.8, h = 0.8)) ##' plotOneTree(xxyy, type = 'phylogram', ##' show.tip.label = TRUE, show.node.label = TRUE, ##' edge.color = 'black', node.color = 'orange', tip.color = 'blue', ##' edge.width = 1, rot = 0 ##' ) ##' popViewport() ##' plotOneTree <- function(xxyy, type, show.tip.label, show.node.label, edge.color, node.color, tip.color, edge.width, rot) { # TODO switch to phylobase abstractions phy <- xxyy$phy Nedges <- nEdges(phy) Nnodes <- nNodes(phy) Ntips <- nTips(phy) pedges <- edges(phy) tindex <- pedges[pedges[, 2] <= Ntips, 2] eindex <- xxyy$eorder segs <- xxyy$segs ## TODO check that colors are valid? if(length(edge.color) != Nedges) { edge.color <- rep(edge.color, length.out = Nedges) } edge.color <- edge.color[eindex] if(length(edge.width) != Nedges) { edge.width <- rep(edge.width, length.out = Nedges) } edge.width <- edge.width[eindex] ## TODO check that colors are valid? if(length(node.color) != Nnodes) { node.color <- rep(node.color, length.out = Nnodes) } if(show.tip.label) { ## calculate several lab dimesisions ## labw -- a vector of string widths ## adjlabw -- the max width for adjusting the size of viewports ## laboff -- a vector of half string widths for ## offsetting center justified labels, handy for vp rotation labw <- grid::stringWidth(tipLabels(phy)) adjlabw <- max(labw) + grid::unit(0.1, 'inches') laboff <- labw * 0.5 + grid::unit(0.1, 'inches') ## print(foo <<- laboff) treelayout <- grid.layout(nrow = 1, ncol = 2, widths = grid::unit.c(grid::unit(1, 'null', NULL), grid::convertUnit(adjlabw, 'inches')) ) tindex <- pedges[pedges[, 2] <= Ntips, 2] if(length(tip.color) != Ntips) { tip.color <- rep(tip.color, length.out = Ntips) } # keep labels horizontal unless plot is upwards or downwards lrot <- ifelse(rot %% 360 %in% c(90, 270), 0, -rot) } else { treelayout <- grid::grid.layout(nrow = 1, ncol = 1) } # grid.show.layout(treelayout) grid::pushViewport(grid::viewport( x = 0.5, y = 0.5, width = 1, height = 1, layout = treelayout, angle = rot, name = 'treelayout')) grid::pushViewport(grid::viewport( layout.pos.col = 1, name = 'tree')) if (type == "fan") { dseg <- grid::grid.segments( # draws diag lines x0 = segs$v0x, y0 = segs$v0y, x1 = segs$h1x, y1 = segs$h1y, name = "diag", gp = grid::gpar(col = edge.color, lwd = edge.width)) } else { vseg <- grid::grid.segments( # draws vertical lines x0 = segs$v0x, y0 = segs$v0y, x1 = segs$v1x, y1 = segs$v1y, name = "vert", gp = grid::gpar(col = edge.color, lwd = edge.width)) hseg <- grid::grid.segments( # draws horizontal lines x0 = segs$h0x, y0 = segs$h0y, x1 = segs$h1x, y1 = segs$h1y, name = "horz", gp = grid::gpar(col = edge.color, lwd = edge.width)) } grid::upViewport() # tree if(show.tip.label) { grid::pushViewport(grid::viewport(layout.pos.col = 1, name = 'tiplabelvp')) labtext <- grid::grid.text( tipLabels(phy)[tindex], x = grid::unit(xxyy$xx[pedges[, 2] %in% tindex], "native") + laboff[tindex], y = xxyy$yy[pedges[, 2] %in% tindex], rot = lrot, default.units = 'native', name = 'tiplabels', just = 'center', gp = grid::gpar(col = tip.color[tindex]) ) grid::upViewport() #tiplabelvp } # TODO probably want to be able to adjust the location of these guys if(show.node.label) { grid::pushViewport(grid::viewport(layout = treelayout, layout.pos.col = 1, name = 'nodelabelvp')) theLabels <- nodeLabels(phy)[match(pedges[pedges[, 2] > Ntips, 2], names(nodeLabels(phy)))] ## don't plot NAs theLabels[is.na(theLabels)] <- "" labtext <- grid::grid.text( theLabels, x = c(xxyy$xx[pedges[, 2] > Ntips]), y = c(xxyy$yy[pedges[, 2] > Ntips]), default.units = 'npc', name = 'nodelabels', rot = -rot, just = 'center', gp = grid::gpar(col = node.color) ) grid::upViewport() #nodelabelvp } grid::upViewport() # treelayout # grobTree(vseg, hseg, labtext) } ##' Calculate node x and y coordinates ##' ##' Calculates the node x and y locations for plotting a phylogenetic tree. ##' ##' The y coordinates of the tips are evenly spaced from 0 to 1 in pruningwise ##' order. Ancestor y nodes are given the mean value of immediate descendants. ##' The root is given the x coordinate 0 and descendant nodes are placed ##' according to the cumulative branch length from the root, with a maximum x ##' value of 1. ##' ##' @param phy A \code{phylo4} or \code{phylo4d} object. ##' @param tip.order A character vector of tip labels, indicating their order ##' along the y axis (from top to bottom). Or, a numeric vector of tip node IDs ##' indicating the order. ##' @return \item{yy}{Internal node and tip y coordinates} \item{xx}{Internal ##' node and tip x coordinates} \item{phy}{A \code{phylo4} or \code{phylo4d} ##' object} \item{segs}{A list of \code{h0x, h1x, v0x, v1x} and \code{h0y, h1y, ##' v0y, v1y} describing the start and end points for the plot line segments} ##' \item{torder}{The tip order provided as \code{tip.order} or if NULL the ##' preoder tip order} \item{eorder}{The an index of the reordered edges ##' compared to the result of \code{edges(phy)}} ##' @author Peter Cowan \email{pdc@@berkeley.edu} ##' @seealso \code{treePlot}, \code{\link{plotOneTree}} ##' @export ##' @keywords methods ##' @examples ##' ##' ##' data(geospiza) ##' coor <- phyloXXYY(geospiza) ##' plot(coor$xx, coor$yy, pch = 20) ##' ##' phyloXXYY <- function(phy, tip.order=NULL) { phy.orig <- phy ## initalize the output phy <- reorder(phy, 'preorder') pedges <- edges(phy) eindex <- match(pedges[,2], edges(phy.orig)[,2]) Nedges <- nrow(pedges) ## TODO switch to the accessor once stablized Ntips <- nTips(phy) tips <- pedges[, 2] <= Ntips xx <- numeric(Nedges) yy <- numeric(Nedges) treelen <- rep(NA, nEdges(phy)) segs <- list(v0x = treelen, v0y = treelen, v1x = treelen, v1y = treelen, h0x = treelen, h0y = treelen, h1x = treelen, h1y = treelen) ## Set root x value to zero and calculate x positions xx[1] <- 0 segs$v0x[1] <- segs$v1x[1] <- segs$h0x[1] <- 0 edge1 <- as.integer(pedges[,1]) edge2 <- as.integer(pedges[,2]) edgeLen <- edgeLength(phy) edgeLen[is.na(edgeLen)] <- 0 edgeLen <- as.numeric(edgeLen) nedges <- as.integer(nEdges(phy)) segsv0x <- as.numeric(rep.int(0, Nedges)) xPos <- .C("phyloxx", edge1, edge2, edgeLen, nedges, xx, segsv0x, PACKAGE = "phylobase") xx <- xPos[[5]] segs$v0x <- xPos[[6]] ## Set y positions for terminal nodes and calculate remaining y positions if(!is.null(tip.order)) { if(length(tip.order) == 1 && tip.order == "rev") { yy[tips] <- seq(1, 0, length.out = Ntips) tip.order <- rev(edge2[edge2 <= Ntips]) } else { yy[tips][match(tip.order, edge2[tips])] <- seq(0, 1, length.out = Ntips) } } else { yy[tips] <- seq(0, 1, length.out = Ntips) tip.order <- edge2[edge2 <= Ntips] } segs$h0y[tips] <- segs$h1y[tips] <- yy[tips] segs$v1y[tips] <- segs$v0y[tips] <- yy[tips] phyloyy <- function() { for(i in rev((Ntips + 1):nEdges(phy))) { dex <- pedges[, 1] == i cur <- pedges[, 2] == i yy[cur] <- segs$v0y[dex] <- mean(yy[dex]) } return(list(segs=segs, yy=yy)) } yPos <- phyloyy() segs <- yPos$segs yy <- yPos$yy ## edgeLen[is.na(edgeLen)] <- 0 ## edgeLen <- as.numeric(edgeLen) ## ntips <- as.integer(nTips(phy)) ## yy <- as.numeric(yy) ## segsv0y <- as.numeric(yy) ## yPos <- .C("phyloyy", edge1, edge2, ## ntips, nedges, yy, segsv0y) segs$h0y <- segs$h1y <- segs$v1y <- yy ## scale the x values so they range from 0 to 1 Xmax <- max(xx) segs$v0x <- segs$v0x / Xmax xx <- xx / Xmax segs$h1x <- xx segs$v1x <- segs$h0x <- segs$v0x # TODO return an index vector instead of a second phy object list(xx = xx, yy = yy, phy = phy, segs = segs, torder=tip.order, eorder=eindex) } .bubLegendGrob <- function(tipdata, tipdataS) { grid::grob(tipdata=tipdata, tipdataS=tipdataS, cl='bubLegend') } ##' @export drawDetails.bubLegend <- function(x, ...) { ## number of bubbles in legend leglen <- 4 ## the raw tip data tipdata <- x$tipdata ## the tip data as scaled for bubble plot ts <- x$tipdataS ## return to the bubble plot viewport to get properly scaled values ## this relies on having well named unique viewports grid::seekViewport("bubble_plots") ## retreive the min and max non-zero bubbles as numerics not units bubrange <- grid::convertUnit( grid::unit(c(min(ts[ts != 0], na.rm=TRUE), max(ts[ts != 0], na.rm=TRUE)), "native"), "mm", valueOnly=TRUE) grid::seekViewport("bubblelegend") ## grid.rect() ## Generate the sequence of legend bubble sizes and convert to grid mm units legcirS <- grid::unit(seq(bubrange[1], bubrange[2], length.out=leglen), "mm") ## get the corresponding sequence of actual data values legcir <- seq(min(tipdata[tipdata != 0], na.rm=TRUE), max(tipdata[tipdata != 0], na.rm=TRUE), length.out=leglen) ccol <- ifelse(legcir < 0, 'black', 'white') leftedge <- abs(grid::convertUnit(legcirS[1], 'npc', valueOnly=TRUE)) + 0.1 xloc <- seq(leftedge, 0.5, length.out=leglen) textsp <- grid::convertUnit(max(abs(legcirS)), axisFrom="y", axisTo="y", 'npc', valueOnly=TRUE) strsp <- grid::convertUnit(unit(1, "strheight", "TTT"), axisFrom="y", 'npc', valueOnly=TRUE) grid::grid.circle(x=xloc, y=0.9 - textsp - strsp, r=legcirS, gp = grid::gpar(fill=ccol), default.units = 'npc') grid::grid.text(as.character(signif(legcir, digits = 2)), x=xloc, y=0.75 - 2 * textsp - strsp, gp=grid::gpar(cex=0.75), default.units='npc' ) } ##' Bubble plots for phylo4d objects ##' ##' Plots either circles or squares corresponding to the magnitude of each cell ##' of a \code{phylo4d} object. ##' ##' ##' @param type the type of plot ##' @param place.tip.label A string indicating whether labels should be plotted ##' to the right or to the left of the bubble plot ##' @param show.node.label A logical indicating whether internal node labels ##' should be plotted ##' @param rot The number of degrees that the plot should be rotated ##' @param edge.color A vector of colors for the tree edge segments ##' @param node.color A vector of colors for the coloring the nodes ##' @param tip.color A vector of colors for the coloring the tip labels ##' @param edge.width A vector of line widths for the tree edges ##' @param newpage Logical to control whether the device is cleared before ##' plotting, useful for adding plot inside other plots ##' @param \dots Additional parameters passed to the bubble plotting functions ##' @param XXYY The out put from the phyloXXYY function ##' @param square Logical indicating whether the plot 'bubbles' should be ##' squares ##' @param grid A logical indicating whether a grey grid should be plotted ##' behind the bubbles ##' @author Peter Cowan \email{pdc@@berkeley.edu} ##' @export ##' @seealso \code{\link{phyloXXYY}}, \code{treePlot} ##' @keywords methods ##' @examples ##' ##' ##---- Should be DIRECTLY executable !! ---- ##' ##-- ==> Define data, use random, ##' ##-- or do help(data=index) for the standard data sets. ##' phylobubbles <- function(type = type, place.tip.label = "right", show.node.label = show.node.label, rot = 0, edge.color = edge.color, node.color = node.color, # TODO what do with node.color parameter tip.color = tip.color, edge.width = edge.width, # TODO line-type modification hack newpage = TRUE, ..., XXYY, square = FALSE, grid = TRUE) { ## TODO add legend command ## tys -- tip y coordinates ## nVars -- number of traits/characters ## maxr -- maximum circle radius, based on nVars or nTips ## torder -- the order of tips in the reordered edge matrix if(rot != 0) {stop("Rotation of bubble plots not yet implemented")} lab.right <- ifelse(place.tip.label %in% c("right", "both"), TRUE, FALSE) lab.left <- ifelse(place.tip.label %in% c("left", "both"), TRUE, FALSE) phy <- XXYY$phy tip.order <- XXYY$torder tipdata <- tdata(phy, type = "tip")[tip.order,, drop=FALSE] tipClass <- sapply(tipdata, function(x) class(x) %in% c("double", "integer", "numeric")) tipdata <- tipdata[, tipClass, drop=FALSE] tmin <- min(tipdata, na.rm = TRUE) tmax <- max(tipdata, na.rm = TRUE) pedges <- edges(phy) nVars <- ncol(tipdata) # number of bubble columns dlabwdth <- max(grid::stringWidth(colnames(tipdata))) * 1.2 if(grid::convertWidth(dlabwdth, 'cm', valueOnly=TRUE) < 2) {dlabwdth <- grid::unit(2, 'cm')} phyplotlayout <- grid::grid.layout(nrow = 2, ncol = 2, heights = grid::unit.c(grid::unit(1, 'null'), dlabwdth), widths = grid::unit(c(1, 1), c('null', 'null'), list(NULL, NULL))) grid::pushViewport(viewport(layout = phyplotlayout, name = 'phyplotlayout')) grid::pushViewport(viewport(layout.pos.row = 1:2, layout.pos.col = 2, height = grid::unit(1, 'npc') + grid::convertUnit(dlabwdth, 'npc'), name = 'bubbleplots', default.units = 'native')) # tip y coordinates tys <- XXYY$yy[pedges[, 2] <= nTips(phy)] tys <- tys[match(names(tipLabels(phy))[tip.order], XXYY$torder)] maxr <- ifelse(ncol(tipdata) > nTips(phy), 1 / ncol(tipdata), 1 / nTips(phy)) tipdataS <- apply(tipdata, 2, function(x) (maxr * x) / max(abs(x), na.rm = TRUE)) if(nVars == 1) { xpos <- 0.5 } else { xpos <- seq(0 + maxr + 0.02, 1 - maxr - 0.02, length.out = nVars) } ## rep coordinates for filling a matrix columnwise xrep <- rep(xpos, each = length(tys)) yrep <- rep(tys, nVars) ## color bubbles ccol <- ifelse(tipdata < 0, 'black', 'white') ## generate matrices of every x and y by filling the repd value columnwise ## then subset for datapoints that are NA naxs <- matrix(xrep, ncol = nVars) nays <- matrix(yrep, ncol = nVars) dnas <- is.na(tipdataS) naxs <- naxs[dnas] nays <- nays[dnas] ## set the NA points to zero so that grid.circle doesn't crash tipdataS[is.na(tipdataS)] <- 0 + 0.001 # workaround negative circles on PDF ## get label widths if(lab.right) { tiplabwidth <- max(grid::stringWidth(tipLabels(phy))) } else {tiplabwidth <- grid::unit(0, 'null', NULL)} ## 2x2 layout -- room at the bottom for data labels, and legend bublayout <- grid::grid.layout(nrow = 2, ncol = 2, widths = grid::unit.c(grid::unit(1, 'null', NULL), tiplabwidth), heights = grid::unit.c(grid::unit(1, 'null', NULL), dlabwdth)) grid::pushViewport(viewport( x = 0.5, y = 0.5, width = 0.95, height = 1, layout = bublayout, name = 'bublayout' )) grid::pushViewport(viewport( name = 'bubble_plots', layout = bublayout, layout.pos.col = 1, layout.pos.row = 1 )) if(grid) { ## draw light grey grid behind bubbles grid::grid.segments(x0 = 0, x1 = 1, y0 = tys, y1 = tys, gp = grid::gpar(col = 'grey')) grid::grid.segments(x0 = xpos, x1 = xpos, y0 = 0, y1 = 1, gp = grid::gpar(col = 'grey')) } if (length(naxs) > 0) { ## if ther are missing values plot Xs grid::grid.points(naxs, nays, pch = 4) } if(square) { ## alternative to circles ## to keep the squares square, yet resize nicely use the square npc sqedge <- grid::unit(unlist(tipdataS), 'snpc') grid::grid.rect(x = xrep, y = yrep, width = sqedge, height = sqedge, gp=grid::gpar(fill = ccol)) } else { ## plot bubbles grid::grid.circle(xrep, yrep, r = unlist(tipdataS), gp = grid::gpar(fill = ccol)) } grid::upViewport() ## push view ports for tip and data labels fixed locations if(lab.right) { grid::pushViewport(viewport( name = 'bubble_tip_labels', layout = bublayout, layout.pos.col = 2, layout.pos.row = 1 )) tt <- tipLabels(phy)[tip.order] # phy@tip.label grid::grid.text(tt, 0.1, tys, just = 'left') grid::upViewport() } grid::pushViewport(viewport( name = 'bubble_data_labels', layout = bublayout, layout.pos.col = 1, layout.pos.row = 2 )) ## ideas, for nicer sizing of the data labels ## data.label.space <- convertX(unit(1, 'npc'), "points", valueOnly = TRUE) ## data.label.fontsize <- data.label.space / ncol(tipdata) ## , gp=gpar(fontsize=data.label.fontsize)) ## offset the data labels from the bottom bubble datalaboffset <- grid::convertUnit(grid::unit(15, "mm"), 'npc', valueOnly=TRUE) grid::grid.text(colnames(tipdata), xpos, 1-datalaboffset, rot = 90, just = 'right') grid::upViewport(3) grid::pushViewport(viewport(layout.pos.row=2, layout.pos.col=1, name='bubblelegend')) yyy <- .bubLegendGrob(tipdata, tipdataS) grid::grid.draw(yyy) grid::upViewport() grid::pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 1, name = 'tree')) plotOneTree(XXYY, type, show.tip.label=lab.left, show.node.label, edge.color, node.color, tip.color, edge.width, rot) grid::upViewport(2) # to make a nice legend, return the biggest smallest and a scaling factor # translate the scale of the current vp to a fixed value ## ensure the min is not a zero (or NA) that's replaced by a zero ## print(convertUnit(bubscale, 'inches', valueOnly = TRUE)) ## return(list(max = max(tipdata, na.rm = TRUE), ## min = min(tipdata[tipdata != 0], na.rm = TRUE), ## has.na = length(naxs) > 0, ## bubscale = bubscale)) } ##' Plotting trees and associated data ##' ##' Plotting phylogenetic trees and associated data ##' ##' ##' @param xxyy A list created by the \code{\link{phyloXXYY}} function ##' @param type A character string indicating the shape of plotted tree ##' @param show.tip.label Logical, indicating whether tip labels should be shown ##' @param show.node.label Logical, indicating whether node labels should be ##' shown ##' @param rot Numeric indicating the rotation of the plot in degrees ##' @param tip.plot.fun A function used to plot the data elements of a ##' \code{phylo4d} object ##' @param edge.color A vector of colors in the order of \code{edges(phy)} ##' @param node.color A vector of colors indicating the colors of the node ##' labels ##' @param tip.color A vector of colors indicating the colors of the tip labels ##' @param edge.width A vector in the order of \code{edges(phy)} indicating the ##' widths of edge lines ##' @param \dots Additional parameters passed to \code{tip.plot.fun} ##' @return creates a plot on the current graphics device. ##' @author Peter Cowan ##' @export ##' @keywords methods tip.data.plot <- function( xxyy, type = c('phylogram', 'cladogram', 'fan'), show.tip.label = TRUE, show.node.label = FALSE, rot = 0, tip.plot.fun = grid.points, edge.color = 'black', node.color = 'black', # TODO what do with node.color parameter tip.color = 'black', edge.width = 1, # TODO line-type modification hack ...) { phy <- xxyy$phy tip.order <- xxyy$torder pedges <- edges(phy) Ntips <- nTips(phy) datalayout <- grid::grid.layout(ncol = 2, widths = grid::unit(c(1, 1/Ntips), c('null', 'null'))) # TODO this is done multiple times, grid::pushViewport(viewport(layout = datalayout, angle = rot, name = 'datalayout')) grid::pushViewport(viewport( yscale = c(-0.5 / Ntips, 1 + 0.5 / Ntips), xscale = c(0, 1 + 1 / Ntips), layout.pos.col = 1, name = 'data_plots')) ## TODO should plots float at tips, or only along edge? hc <- grid::convertY(grid::unit(1 / Ntips, 'snpc'), 'npc') for(i in 1:Ntips) { grid::pushViewport(viewport( y = xxyy$yy[pedges[, 2] == i], x = 1 + 1 / (2 * Ntips), # xxyy$xx[phy@edge[, 2] == i], height = hc, width = hc, # default.units = 'native', name = paste('data_plot', i), just = "center", angle = -rot )) #grid.rect() tvals <- tdata(phy, type = 'tip')[nodeId(phy,'tip'), , drop=FALSE] vals = t(tvals[i, ]) if (!all(is.na(vals))) tip.plot.fun(vals, ...) grid::upViewport() # loop viewports } plotOneTree(xxyy, type, show.tip.label, show.node.label, edge.color, node.color, tip.color, edge.width, rot) grid::upViewport(2) ## data_plot & datalayout } # phyloStripchart <- function() ##' @rdname treePlot-methods ##' @aliases plot ##' @exportMethod plot setGeneric('plot') ##' @rdname treePlot-methods ##' @aliases plot,phylo4-method setMethod('plot', signature(x='phylo4', y='missing'), function(x, y, ...) { treePlot(x, ...) }) phylobase/R/edgeLength-methods.R0000644000176200001440000002555214553646170016317 0ustar liggesusers ## TODO -- the behavior of edgeLength needs to be made more consistent ## with other functions like MRCA. The user should be able to specify a ## vector of nodes, of edges, or both. ##### This file contains ## hasEdgeLength ## edgeLength and edgeLength<- ## isUltrametric ## nodeDepth ## sumEdgeLength ##' edgeLength methods ##' ##' These functions give information about and allow replacement of edge lengths. ##' ##' The \code{edgeLength} function returns the edge length in the same ##' order as the edges in the matrix. ##' ##' @param x a \code{phylo4} or \code{phylo4d} object. ##' @param value a numeric vector indicating the new values for the edge lengths ##' @param node optional numeric or character vector indicating the ##' nodes for which edge ##' @param use.names should the the name attributes of \code{value} be ##' used to match the length to a given edge. ##' @param tol the tolerance to decide whether all the tips have the ##' same depth to test if the tree is ultrametric. Default is ##' \code{.Machine$double.eps^0.5}. ##' @param \dots optional arguments (none used at present). ##' @return \describe{ ##' ##' \item{hasEdgeLength}{whether or not the object has edge lengths ##' (logical)} ##' ##' \item{edgeLength}{a named vector of the edge length for the ##' object} ##' ##' \item{isUltrametric}{whether or not the tree is ultrametric (all ##' the tips are have the same depth (distance from the root) (logical)} ##' ##' \item{sumEdgeLength}{the sum of the edge lengths for a set of ##' nodes (intended to be used with \code{ancestors} or \code{descendants})} ##' ##' \item{nodeHeight}{the distance between a node and the root or the ##' tips. The format of the result will depend on the options and the ##' number of nodes provided, either a vector or a list.} ##' ##' \item{nodeDepth}{Deprecated, now replaced by \code{nodeHeight}. A ##' named vector indicating the \dQuote{depth} (the distance between ##' the root and a given node).} ##' ##' \item{depthTip}{Deprecated, now replaced by \code{nodeHeight}.} ##' ##' } ##' @seealso \code{ancestors}, \code{descendants}, \code{.Machine} for ##' more information about tolerance. ##' @export ##' @docType methods ##' @aliases hasEdgeLength ##' @rdname edgeLength-methods ##' @include phylo4-class.R ##' @include phylo4-methods.R ##' @include nodeId-methods.R ##' @examples ##' data(geospiza) ##' hasEdgeLength(geospiza) # TRUE ##' topoGeo <- geospiza ##' edgeLength(topoGeo) <- NULL ##' hasEdgeLength(topoGeo) # FALSE ##' ##' edgeLength(geospiza)[2] # use the position in vector ##' edgeLength(geospiza)["16-17"] # or the name of the edge ##' edgeLength(geospiza, 17) # or the descendant node of the edge ##' ##' ## The same methods can be used to update an edge length ##' edgeLength(geospiza)[2] <- 0.33 ##' edgeLength(geospiza)["16-17"] <- 0.34 ##' edgeLength(geospiza, 17) <- 0.35 ##' ##' ## Test if tree is ultrametric ##' isUltrametric(geospiza) # TRUE ##' ## indeed all tips are at the same distance from the root ##' nodeHeight(geospiza, nodeId(geospiza, "tip"), from="root") ##' ## compare distances from tips of two MRCA ##' nodeHeight(geospiza, MRCA(geospiza, c("pallida", "psittacula")), from="min_tip") ##' nodeHeight(geospiza, MRCA(geospiza, c("fortis", "difficilis")), from="min_tip") ##' ## or the same but from the root ##' nodeHeight(geospiza, MRCA(geospiza, c("pallida", "psittacula")), from="root") ##' nodeHeight(geospiza, MRCA(geospiza, c("fortis", "difficilis")), from="root") setGeneric("hasEdgeLength", function(x) { standardGeneric("hasEdgeLength") }) ##' @rdname edgeLength-methods ##' @aliases hasEdgeLength,phylo4-method setMethod("hasEdgeLength", signature(x="phylo4"), function(x) { !all(is.na(x@edge.length)) }) #### ----- edgeLength ##' @rdname edgeLength-methods ##' @aliases edgeLength ##' @export setGeneric("edgeLength", function(x, ...) { standardGeneric("edgeLength") }) ##' @rdname edgeLength-methods ##' @aliases edgeLength,phylo4-method setMethod("edgeLength", signature(x="phylo4"), function(x, node) { ## [JR: below, using match for ordering rather than direct character ## indexing b/c the latter is slow for vectors of a certain size] if (!missing(node)) { id <- getEdge(x, node) } else { id <- edgeId(x, "all") } elen <- x@edge.length[match(id, names(x@edge.length))] names(elen) <- id return(elen) }) ##' @rdname edgeLength-methods ##' @aliases edgeLength<- ##' @export setGeneric("edgeLength<-", function(x, use.names=TRUE, ..., value) { standardGeneric("edgeLength<-") }) ##' @name edgeLength<- ##' @rdname edgeLength-methods ##' @aliases edgeLength<-,phylo4-method edgeLength<-,phylo4,ANY-method setReplaceMethod("edgeLength", signature(x="phylo4", value="ANY"), function(x, use.names=TRUE, ..., value) { len <- .createEdge(value, x@edge, type="lengths", use.names) ## return empty vector if all values are NA if (all(is.na(len))) { emptyVec <- numeric() attributes(emptyVec) <- list(names=character(0)) x@edge.length <- emptyVec } else { x@edge.length <- len } if(is.character(checkval <- checkPhylo4(x))) stop(checkval) x }) ##### ------ depthTips ##' @rdname edgeLength-methods ##' @aliases depthTips ##' @export setGeneric("depthTips", function(x) { standardGeneric("depthTips") }) ##' @rdname edgeLength-methods ##' @aliases depthTips,phylo4-methods setMethod("depthTips", signature(x="phylo4"), function(x) { .Deprecated("nodeHeight") nodeDepth(x, 1:nTips(x)) }) ##### ----- nodeDepth ##' @rdname edgeLength-methods ##' @aliases nodeDepth ##' @export setGeneric("nodeDepth", function(x, node) { standardGeneric("nodeDepth") }) ##' @rdname edgeLength-methods ##' @aliases nodeDepth,phylo4-method setMethod("nodeDepth", signature(x="phylo4"), function(x, node) { .Deprecated("nodeHeight") if (!hasEdgeLength(x)) return(NULL) else { node <- getNode(x, node, missing="warn") node <- node[!is.na(node)] res <- sapply(node, function(n) sumEdgeLength(x, ancestors(x, n, "ALL"))) if (length(res) == 1) { res <- res[[1]] names(res) <- names(node) } res } }) ###### ----- nodeHeight ##' @param from The point of reference for calculating the height of ##' the node. \code{root} calculates the distance between the root of ##' the tree and the node. \code{all_tip} return the distance between ##' the node and all the tips descending from it. \code{min_tip} the ##' distance between the node and its closest tip. \code{max_tip} the ##' distance between the node and its farther tip. \code{min_tip} and ##' \code{max_tip} will be identical if the tree is ultrametric. If ##' more than one tip is equidistant from the node, the tip with the ##' lowest node id will be returned. ##' @rdname edgeLength-methods ##' @aliases nodeHeight ##' @export setGeneric("nodeHeight", function(x, node, from) { standardGeneric("nodeHeight") }) ##' @rdname edgeLength-methods ##' @aliases nodeHeight,phylo4-method setMethod("nodeHeight", signature(x = "phylo4"), function(x, node, from = c("root", "all_tip", "min_tip", "max_tip")) { from <- match.arg(from) if (!hasEdgeLength(x)) return(NULL) else { node <- getNode(x, node, missing = "warn") node <- node[!is.na(node)] tip_id <- nodeId(x, "tip") if (from != "root") { ## Get the full paths to the tips from the node res <- lapply(node, function(n) { if (n %in% tip_id) { ## tips are always at 0 tmp_res <- stats::setNames(0, tipLabels(x)[n]) } else { desc_pths <- descendants(x, n, "all") ## Get the paths in the other direction anc_pths <- lapply(desc_pths[desc_pths %in% tip_id], function(n) { ancestors(x, n, "ALL") }) ## Shortest paths for each tip pths <- lapply(anc_pths, function(anc_pth) { intersect(desc_pths, anc_pth) }) tmp_res <- sapply(pths, function(n) { sumEdgeLength(x, n) }) tmp_res <- switch(from, "all_tip" = tmp_res, "min_tip" = tmp_res[which.min(tmp_res)], "max_tip" = tmp_res[which.max(tmp_res)]) } tmp_res }) } else { res <- sapply(node, function(n) { sumEdgeLength(x, ancestors(x, n, "ALL")) }) } names(res) <- node if (length(res) == 1) { res <- res[[1]] } } res }) ###### ----- sumEdgeLength ##' @rdname edgeLength-methods ##' @aliases sumEdgeLength ##' @export setGeneric("sumEdgeLength", function(x, node) { standardGeneric("sumEdgeLength") }) ##' @rdname edgeLength-methods ##' @aliases sumEdgeLength,phylo4-method setMethod("sumEdgeLength", signature(x="phylo4"), function(x, node) { if(!hasEdgeLength(x)) NULL else { nd <- getNode(x, node) iEdges <- which(x@edge[,2] %in% nd) sumEdges <- sum(x@edge.length[iEdges], na.rm=TRUE) sumEdges } }) ###### ----- isUltrametric ##' @rdname edgeLength-methods ##' @aliases isUltrametric ##' @export setGeneric("isUltrametric", function(x, tol=.Machine$double.eps^.5) { standardGeneric("isUltrametric") }) ##' @rdname edgeLength-methods ##' @aliases isUltrametric,phylo4-method setMethod("isUltrametric", signature(x="phylo4"), function(x, tol=.Machine$double.eps^.5) { if (!hasEdgeLength(x)) { stop("The tree has no edge lengths.") } if (identical(all.equal.numeric(stats::var(nodeHeight(x, nodeId(x, "tip"), "root")), 0, tolerance=tol), TRUE)) { TRUE } else FALSE }) phylobase/R/treestruc.R0000644000176200001440000000555314553646170014627 0ustar liggesusers ##' Test trees for polytomies, inline nodes (singletons), or reticulation ##' ##' Methods to test whether trees have (structural) polytomies, inline ##' nodes (i.e., nodes with a single descendant), or reticulation ##' (i.e., nodes with more than one ancestor). \code{hasPoly} only ##' check for structural polytomies (1 node has more than 2 ##' descendants) and not polytomies that result from having edges with ##' a length of 0. ##' ##' @aliases hasSingle ##' @param object an object inheriting from class \code{phylo4} ##' @return Logical value ##' @note Some algorithms are unhappy with structural polytomies (i.e., >2 ##' descendants from a node), with single-descendant nodes, or with ##' reticulation; these functions check those properties. We haven't bothered ##' to check for zero branch lengths: the consensus is that it doesn't come up ##' much, and that it's simple enough to test \code{any(edgeLength(x) == 0)} in ##' these cases. (Single-descendant nodes are used e.g. in OUCH, or in other ##' cases to represent events occurring along a branch.) ##' @author Ben Bolker ##' @rdname treeStructure-methods ##' @export ##' @keywords misc ##' @examples ##' ##' tree.owls.bis <- ape::read.tree(text="((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3);") ##' owls4 <- as(tree.owls.bis, "phylo4") ##' hasPoly(owls4) ##' hasSingle(owls4) ##' setGeneric("hasSingle", function(object) { standardGeneric("hasSingle") }) ##' @rdname treeStructure-methods ##' @aliases hasSingle,phylo4-method setMethod("hasSingle", signature(object="phylo4"), function(object) { if (nEdges(object) == 0) { return(FALSE) } ## This is about 3 times slower than using the C++ ## function tabulateTips ## degree <- tabulate(edges(object, drop.root=TRUE)[, 1]) degree <- tabulateTips(object@edge[, 1]) any(degree == 1) }) ##' @rdname treeStructure-methods ##' @aliases hasRetic ##' @export setGeneric("hasRetic", function(object) { standardGeneric("hasRetic") }) ##' @rdname treeStructure-methods ##' @aliases hasRetic,phylo4-method setMethod("hasRetic", signature(object="phylo4"), function(object) { if (nEdges(object)==0) { return(FALSE) } ## this is about the same (slightly faster on 10,000 tips) ## than using the C++ function ancest <- tabulate(edges(object)[, 2]) any(ancest > 1) }) ##' @rdname treeStructure-methods ##' @aliases hasPoly ##' @export setGeneric("hasPoly", function(object) { standardGeneric("hasPoly") }) ##' @rdname treeStructure-methods ##' @aliases hasPoly,phylo4-method setMethod("hasPoly", signature(object="phylo4"), function(object) { if (nEdges(object)==0) { return(FALSE) } ## This is about 3 times slower than using the C++ ## function tabulateTips ## degree <- tabulate(edges(object, drop.root=TRUE)[, 1]) degree <- tabulateTips(object@edge[, 1]) any(degree > 2) }) phylobase/R/phylo4-accessors.R0000644000176200001440000001111014553646170015773 0ustar liggesusers ##' Number of tips, nodes and edges found in a tree. ##' ##' Function to return the number of tips, nodes and edges found in a ##' tree in the \code{phylo4} or \code{phylo4d} format. ##' @title nTips, nNodes, nEdges ##' @aliases nTips ##' @param x a \code{phylo4} or \code{phylo4d} object ##' @return a numeric vector indicating the number of tips, nodes or ##' edge respectively. ##' @docType methods ##' @export ##' @include phylo4-class.R phylo4-methods.R ##' @include oldclasses-class.R ##' @rdname nTips-methods setGeneric("nTips", function(x) { standardGeneric("nTips") }) ##' @rdname nTips-methods ##' @aliases nTips,phylo4-method setMethod("nTips", signature(x="phylo4"), function(x) { E <- edges(x) if(nrow(E) == 0) return(0) else { ## at this time NAs are not allowed in edge matrix ## sum(tabulate(E[, 1]) == 0) nTipsFastCpp(E[, 1]) } }) ##' @rdname nTips-methods ##' @aliases nTips,phylo-method setMethod("nTips", signature(x="phylo"), function(x) { Ntip(x) }) ##' @rdname nTips-methods ##' @aliases nNodes ##' @export setGeneric("nNodes", function(x) { standardGeneric("nNodes") }) ##' @rdname nTips-methods ##' @aliases nNodes,phylo4-method setMethod("nNodes", signature(x="phylo4"), function(x) { E <- edges(x, drop.root=TRUE) if(nrow(E) == 0) { return(0) } else { return(length(unique(E[, 1]))) } }) ##' @rdname nTips-methods ##' @aliases nEdges ##' @export setGeneric("nEdges", function(x) { standardGeneric("nEdges") }) ##' @rdname nTips-methods ##' @aliases nEdges,phylo4-method setMethod("nEdges", signature(x="phylo4"), function(x) { nrow(x@edge) }) ######################################################### ### Edge accessors ######################################################### ##' Edges accessors ##' ##' Access or modify information about the edges. ##' ##' @param x a \code{phylo4} or \code{phylo4d} object. ##' @param drop.root logical (default FALSE), should the edge ##' connecting the root be included in the edge matrix? ##' @param \dots Optional arguments used by specific methods. (None ##' used at present). ##' @return \describe{ ##' \item{\code{edges}}{returns the edge matrix that represent the ##' ancestor-descendant relationships among the nodes of the tree.} ##' ##' \item{\code{edgeOrder}}{returns the order in which the edge matrix ##' is in.} ##' ##' \item{\code{internalEdges}}{returns a logical vector indicating ##' internal edges (edges that connect an internal node to ##' another). This vector is named with the \code{edgeId}}. ##' ##' \item{\code{terminalEdges}}{returns a logical vector indicating ##' terminal edges (edges that connect an internal node to a ##' tip). This vector is named with the \code{edgeId} }} ##' @author Ben Bolker, Francois Michonneau, Thibaut Jombart ##' @seealso reorder, edgeId ##' @examples ##' data(geospiza) ##' edges(geospiza) ##' edgeOrder(geospiza) ##' geoPost <- reorder(geospiza, "postorder") ##' edgeOrder(geoPost) ##' ## with a binary tree this should always be true ##' identical(!terminalEdges(geospiza), internalEdges(geospiza)) ##' @export ##' @docType methods ##' @rdname edges-accessors ##' @include phylo4-methods.R setGeneric("edges", function(x, ...) { standardGeneric("edges") }) ##' @rdname edges-accessors ##' @aliases edges,phylo4-method setMethod("edges", signature(x="phylo4"), function(x, drop.root=FALSE) { e <- x@edge if (drop.root) e <- e[e[, 1] != 0, ] e }) ##### -------- edgeOrder ##' @rdname edges-accessors ##' @aliases edgeOrder ##' @export setGeneric("edgeOrder", function(x, ...) { standardGeneric("edgeOrder") }) ##' @rdname edges-accessors ##' @aliases edgeOrder,phylo4-method setMethod("edgeOrder", signature(x="phylo4"), function(x) { x@order }) ##### -------- internalEdges ##' @rdname edges-accessors ##' @aliases internalEdges ##' @export setGeneric("internalEdges", function(x) { standardGeneric("internalEdges") }) ##' @rdname edges-accessors ##' @aliases internalEdges,phylo4-method setMethod("internalEdges", signature(x="phylo4"), function(x) { res <- edges(x)[, 2] %in% nodeId(x, "internal") names(res) <- edgeId(x, "all") res }) ##### -------- terminalEdges ##' @rdname edges-accessors ##' @aliases terminalEdges ##' @export setGeneric("terminalEdges", function(x) { standardGeneric("terminalEdges") }) ##' @rdname edges-accessors ##' @aliases terminalEdges,phylo4-method setMethod("terminalEdges", signature(x="phylo4"), function(x) { res <- edges(x)[, 2] %in% nodeId(x, "tip") names(res) <- edgeId(x, "all") res }) phylobase/R/getNode-methods.R0000644000176200001440000001671214553646170015634 0ustar liggesusers## matching node labels with node numbers ... ## e.g. ## 14 tips, 13 int nodes ## N04 = nodeLabels[4] ## <-> node 18 ## x = n-nTips(phy) ## so: n = x+nTips(phy) ##' Node and Edge look-up functions ##' ##' Functions for retrieving node and edge IDs (possibly with corresponding ##' labels) from a phylogenetic tree. ##' ##' \code{getNode} and \code{getEdge} are primarily intended for looking up the ##' IDs either of nodes themselves or of edges associated with those nodes. Note ##' that they behave quite differently. With \code{getNode}, any input nodes are ##' looked up against tree nodes of the specified type, and those that match are ##' returned as numeric node IDs with node labels (if they exist) as element ##' names. With \code{getEdge}, any input nodes are looked up against edge ends ##' of the specified type, and those that match are returned as character edge ##' IDs with the corresponding node ID as element names. ##' ##' If \code{missing} is \dQuote{warn} or \dQuote{OK}, \code{NA} is returned for ##' any nodes that are unmatched for the specified type. This can provide a ##' mechanism for filtering a set of nodes or edges. ##' ##' \code{nodeId} provides similar output to \code{getNode} in the case when no ##' node is supplied, but it is faster and returns an unnamed vector of the ##' numeric IDs of all nodes of the specified node type. Similarly, ##' \code{edgeId} simply returns an unnamed vector of the character IDs of all ##' edges for which the descendant node is of the specified node type. ##' ##' @param x a \linkS4class{phylo4} object (or one inheriting from ##' \linkS4class{phylo4}, e.g. a \linkS4class{phylo4d} object) ##' @param node either an integer vector corresponding to node ID numbers, or a ##' character vector corresponding to node labels; if missing, all nodes ##' appropriate to the specified type will be returned by \code{getNode}, and ##' all edges appropriate to the specified type will be returned by ##' \code{getEdge}. ##' @param type (\code{getNode}) specify whether to return nodes matching "all" ##' tree nodes (default), only "tip" nodes, or only "internal" nodes; ##' (\code{nodeId, edgeId}) specify whether to return "all" tree nodes, or only ##' those corresponding to "tip", "internal", or "root" nodes; (\code{getEdge}) ##' specify whether to look up edges based on their descendant node ##' ("descendant") or ancestral node ("ancestor") ##' @param missing what to do if some requested node IDs or names are not in the ##' tree: warn, do nothing, or stop with an error ##' @return \item{list("getNode")}{returns a named integer vector of node IDs, ##' in the order of input nodes if provided, otherwise in nodeId order} ##' \item{list("getEdge")}{returns a named character vector of edge IDs, in the ##' order of input nodes if provide, otherwise in nodeId order} ##' \item{list("nodeId")}{returns an unnamed integer vector of node IDs, in ##' ascending order} \item{list("getEdge")}{returns an unnamed character vector ##' of edge IDs, in edge matrix order} ##' @keywords misc ##' @export ##' @rdname getNode-methods ##' @include phylo4-class.R ##' @examples ##' ##' data(geospiza) ##' nodeLabels(geospiza) <- LETTERS[1:nNodes(geospiza)] ##' plot(as(geospiza, "phylo4"), show.node.label=TRUE) ##' getNode(geospiza, 18) ##' getNode(geospiza, "D") ##' getEdge(geospiza, "D") ##' getEdge(geospiza, "D", type="ancestor") ##' ##' ## match nodes only to tip nodes, flagging invalid cases as NA ##' getNode(geospiza, c(1, 18, 999), type="tip", missing="OK") ##' ##' ## get all edges that descend from internal nodes ##' getEdge(geospiza, type="ancestor") ##' ##' ## identify an edge from its terminal node ##' getEdge(geospiza, c("olivacea", "B", "fortis")) ##' getNode(geospiza, c("olivacea", "B", "fortis")) ##' edges(geospiza)[c(26, 1, 11),] ##' ##' ## quickly get all tip node IDs and tip edge IDs ##' nodeId(geospiza, "tip") ##' edgeId(geospiza, "tip") ##' setGeneric("getNode", function(x, node, type=c("all", "tip", "internal"), missing=c("warn", "OK", "fail")) { standardGeneric("getNode") }) ##' @rdname getNode-methods ##' @aliases getNode,phylo4-method setMethod("getNode", signature(x="phylo4", node="ANY"), function(x, node, type=c("all", "tip", "internal"), missing=c("warn","OK","fail")) { type <- match.arg(type) missing <- match.arg(missing) ## if missing node arg, get all nodes of specified type if (missing(node)) { node <- nodeId(x, type) } if (length(node) == 0) { rval <- integer(0) names(rval) <- character(0) return(rval) } lblTmp <- labels(x, type) ## match node to tree if (is.character(node)) { ndTmp <- paste("^\\Q", node, "\\E$", sep="") irval <- lapply(ndTmp, function(ND) { grep(ND, lblTmp, perl=TRUE) }) irvalL <- sapply(irval, length) irval[irvalL == 0] <- 0 irval <- unlist(irval) } else if (is.numeric(node) && all(floor(node) == node, na.rm=TRUE)) { irval <- match(as.character(node), names(lblTmp)) } else { stop("Node must be a vector of class \'integer\' or \'character\'.") } ## node numbers rval <- names(lblTmp)[irval] rval[is.na(node)] <- NA # return NA for any NA_character_ inputs, not needed but ensure rval has correct length rval <- as.integer(rval) ## node labels nmNd <- lblTmp[irval] names(rval) <- nmNd ## deal with nodes that don't match if (any(is.na(rval))) { missnodes <- node[is.na(rval)] msg <- paste("Some nodes not found among", type, "nodes in tree:", paste(missnodes,collapse=", ")) if (missing=="fail") { stop(msg) } else if (missing=="warn") { warning(msg) } } return(rval) }) ##' @rdname getNode-methods ##' @aliases getEdge-methods ##' @export setGeneric("getEdge", function(x, node, type=c("descendant", "ancestor"), missing=c("warn", "OK", "fail")) { standardGeneric("getEdge") }) ##' @name getEdge ##' @rdname getNode-methods ##' @aliases getEdge,phylo4-method setMethod("getEdge", signature(x="phylo4", node="ANY"), function(x, node, type=c("descendant", "ancestor"), missing=c("warn", "OK", "fail")) { type <- match.arg(type) missing <- match.arg(missing) if (missing(node)) { if (type=="descendant") { node <- nodeId(x, "all") } else if (type=="ancestor") { node <- nodeId(x, "internal") } } node.id <- getNode(x, node, missing="OK") nd <- lapply(node.id, function(nid) { if (is.na(nid)) { res <- NA } else { res <- switch(type, descendant = edgeId(x)[edges(x)[,2] %in% nid], ancestor = edgeId(x)[edges(x)[,1] %in% nid]) ## hack to return NA for tip nodes when type='ancestor' if(length(res)==0) res <- NA names(res) <- rep(nid, length(res)) } names(res) <- rep(nid, length(res)) res }) ## warn or stop if necessary is.missing <- is.na(nd) if (missing!="OK" && any(is.missing)) { msg <- paste("Not all nodes are ", type, "s in this tree: ", paste(node[is.missing], collapse=", "), sep="") if (missing=="fail") { stop(msg) } else if (missing=="warn") { warning(msg) } } return(unlist(unname(nd))) }) phylobase/R/labels-methods.R0000644000176200001440000002115514553646170015506 0ustar liggesusers ######################################################### ### Label accessors ######################################################### ##' Labels for phylo4/phylo4d objects ##' ##' Methods for creating, accessing and updating labels in ##' phylo4/phylo4d objects ##' ##' In phylo4/phylo4d objects, tips must have labels (that's why there ##' is no method for hasTipLabels), internal nodes and edges can have ##' labels. ##' ##' Labels must be provided as a vector of class \code{character}. The ##' length of the vector must match the number of elements they label. ##' ##' The option \code{use.names} allows the user to match a label to a ##' particular node. In this case, the vector must have names that ##' match the node numbers. ##' ##' The function \code{labels} is mostly intended to be used ##' internally. ##' ##' @name phylo4-labels ##' @aliases labels ##' @docType methods ##' @param x a phylo4 or phylo4d object. ##' @param object a phylo4 or phylo4d object. ##' @param type which type of labels: \code{all} (tips and internal nodes), ##' \code{tip} (tips only), \code{internal} (internal nodes only). ##' @param \dots additional optional arguments (not in use) ##' @param value a vector of class \code{character}, see Details for more ##' information. ##' @param use.names should the names of the vector used to create/update labels ##' be used to match the labels? See Details for more information. ##' @section Methods: \describe{ \item{labels}{\code{signature(object = ##' "phylo4")}: tip and/or internal node labels, ordered by node ID} ##' ##' \item{hasDuplicatedLabels}{\code{signature(object = "phylo4")}: are any ##' labels duplicated?} ##' ##' \item{tipLabels}{\code{signature(object = "phylo4")}: tip labels, ordered by ##' node ID} ##' ##' \item{hasNodeLabels}{\code{signature(object = "phylo4")}: whether tree has ##' (internal) node labels} \item{nodeLabels}{\code{signature(object = ##' "phylo4")}: internal node labels, ordered by node ID} ##' ##' \item{hasEdgeLabels}{\code{signature(object = "phylo4")}: whether tree has ##' (internal) edge labels} \item{edgeLabels}{\code{signature(object = ##' "phylo4")}: internal edge labels, ordered according to the edge matrix} } ##' @exportMethod labels ##' @rdname labels-methods ##' @include phylo4-class.R phylo4-methods.R phylo4-accessors.R nodeId-methods.R ##' @author Ben Bolker, Peter Cowan, Steve Kembel, Francois Michonneau ##' @return labels in ascending order. ##' @examples ##' ##' data(geospiza) ##' ##' ## Return labels from geospiza ##' tipLabels(geospiza) ##' ##' ## Internal node labels in geospiza are empty ##' nodeLabels(geospiza) ##' ##' ## Creating internal node labels ##' ndLbl <- paste("n", 1:nNodes(geospiza), sep="") ##' nodeLabels(geospiza) <- ndLbl ##' nodeLabels(geospiza) ##' ##' ## naming the labels ##' names(ndLbl) <- nodeId(geospiza, "internal") ##' ##' ## shuffling the labels ##' (ndLbl <- sample(ndLbl)) ##' ##' ## by default, the labels are attributed in the order ##' ## they are given: ##' nodeLabels(geospiza) <- ndLbl ##' nodeLabels(geospiza) ##' ##' ## but use.names puts them in the correct order ##' labels(geospiza, "internal", use.names=TRUE) <- ndLbl ##' nodeLabels(geospiza) setGeneric("labels") ##' @rdname labels-methods ##' @aliases labels,phylo4-method setMethod("labels", signature(object="phylo4"), function(object, type = c("all", "tip", "internal")) { type <- match.arg(type) ## [JR: below, using match for ordering rather than direct character ## indexing b/c the latter is slow for vectors of a certain size] label <- object@label id <- nodeId(object, type) lbl <- label[match(id, names(label))] # reassign names b/c any unmatched will be NA (could instead assign # names only to the unmatched ones, but this seems simpler) names(lbl) <- id return(lbl) }) ##' @rdname labels-methods ##' @export setGeneric("labels<-", function(x, type, use.names, ..., value) { standardGeneric("labels<-") }) ##' @rdname labels-methods setReplaceMethod("labels", signature(x="phylo4", type="ANY", use.names="ANY", value="ANY"), function(x, type = c("all", "tip", "internal"), use.names, ..., value) { ## Default options if(missing(type)) type <- "all" if (missing(use.names)) use.names <- FALSE type <- match.arg(type) ## generate new labels of the desired type new.label <- .createLabels(value, nTips(x), nNodes(x), use.names, type=type) ## replace existing labels and add new ones as needed old.label <- x@label old.index <- match(names(new.label), names(old.label)) isNew <- is.na(old.index) old.label[old.index[!isNew]] <- new.label[!isNew] updated.label <- c(old.label, new.label[isNew]) ## for efficiency, drop any NA labels x@label <- updated.label[!is.na(updated.label)] if(is.character(checkval <- checkPhylo4(x))) stop(checkval) else return(x) }) ##### -------- hasDuplicatedLabels ##' @rdname labels-methods ##' @aliases hasDuplicatedLabels ##' @export setGeneric("hasDuplicatedLabels", function(x, type) { standardGeneric("hasDuplicatedLabels") }) ##' @rdname labels-methods ##' @aliases hasDuplicatedLabels,phylo4,ANY-method setMethod("hasDuplicatedLabels", signature(x="phylo4", type="ANY"), function(x, type=c("all", "tip", "internal")) { ## Default options if (missing(type)) { type <- "all" } type <- match.arg(type) hasDuplicatedLabelsCpp(labels(x, type)) }) ##### --------- hasNodeLabels ##' @rdname labels-methods ##' @aliases hasNodeLabels ##' @export setGeneric("hasNodeLabels", function(x) { standardGeneric("hasNodeLabels") }) ##' @rdname labels-methods ##' @aliases hasNodeLabels,phylo4-method setMethod("hasNodeLabels", signature(x="phylo4"), function(x) { !all(is.na(nodeLabels(x))) }) ##### ---------- nodeLabels ##' @rdname labels-methods ##' @aliases nodeLabels ##' @export setGeneric("nodeLabels", function(x) { standardGeneric("nodeLabels") }) ##' @rdname labels-methods ##' @aliases nodeLabels,phylo4-method setMethod("nodeLabels", signature(x="phylo4"), function(x) { labels(x, type="internal") }) ##' @rdname labels-methods ##' @export setGeneric("nodeLabels<-", function(x, ..., value) { standardGeneric("nodeLabels<-") }) ##' @rdname labels-methods setReplaceMethod("nodeLabels", signature(x="phylo4", value="ANY"), function(x, ..., value) { labels(x, type="internal", ...) <- value if(is.character(checkval <- checkPhylo4(x))) stop(checkval) x }) ##### ---------- tipLabels ##' @rdname labels-methods ##' @aliases tipLabels ##' @export setGeneric("tipLabels", function(x) { standardGeneric("tipLabels") }) ##' @rdname labels-methods setMethod("tipLabels", signature(x="phylo4"), function(x) { labels(x, type="tip") }) ##' @rdname labels-methods ##' @export setGeneric("tipLabels<-", function(x, ..., value) { standardGeneric("tipLabels<-") }) ##' @rdname labels-methods setReplaceMethod("tipLabels", signature(x="phylo4", value="ANY"), function(x, ..., value) { labels(x, type="tip", ...) <- value if(is.character(checkval <- checkPhylo4(x))) stop(checkval) return(x) }) ##### ---------- hasEdgeLabels ##' @rdname labels-methods ##' @aliases hasEdgeLabels ##' @export setGeneric("hasEdgeLabels", function(x) { standardGeneric("hasEdgeLabels") }) ##' @rdname labels-methods setMethod("hasEdgeLabels", signature(x="phylo4"), function(x) { !all(is.na(x@edge.label)) }) ##### ---------- edgeLabels ##' @rdname labels-methods ##' @aliases edgeLabels ##' @export setGeneric("edgeLabels", function(x) { standardGeneric("edgeLabels") }) ##' @rdname labels-methods ##' @aliases edgeLabels,phylo4-method setMethod("edgeLabels", signature(x="phylo4"), function(x) { ## [JR: below, using match for ordering rather than direct character ## indexing b/c the latter is slow for vectors of a certain size] id <- edgeId(x, "all") lbl <- x@edge.label[match(id, names(x@edge.label))] names(lbl) <- id return(lbl) }) ##' @rdname labels-methods ##' @aliases edgeLabels<- ##' @export setGeneric("edgeLabels<-", function(x, ..., value) { standardGeneric("edgeLabels<-") }) ##' @rdname labels-methods setReplaceMethod("edgeLabels", signature(x="phylo4", value="ANY"), function(x, ..., value) { lbl <- .createEdge(value, x@edge, type="labels") x@edge.label <- lbl[!is.na(lbl)] if(is.character(checkval <- checkPhylo4(x))) stop(checkval) x }) phylobase/R/RcppExports.R0000644000176200001440000000314214553653721015070 0ustar liggesusers# Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 isLabelName <- function(lblToCheck, lbl) { .Call(`_phylobase_isLabelName`, lblToCheck, lbl) } nRoots <- function(ances) { .Call(`_phylobase_nRoots`, ances) } tabulateTips <- function(ances) { .Call(`_phylobase_tabulateTips`, ances) } nTipsSafe <- function(ances) { .Call(`_phylobase_nTipsSafe`, ances) } nTipsFastCpp <- function(ances) { .Call(`_phylobase_nTipsFastCpp`, ances) } hasSingleton <- function(ances) { .Call(`_phylobase_hasSingleton`, ances) } hasPolytomy <- function(ances) { .Call(`_phylobase_hasPolytomy`, ances) } tipsSafe <- function(ances, desc) { .Call(`_phylobase_tipsSafe`, ances, desc) } tipsFast <- function(ances) { .Call(`_phylobase_tipsFast`, ances) } getAllNodesSafe <- function(edge) { .Call(`_phylobase_getAllNodesSafe`, edge) } getAllNodesFast <- function(edge) { .Call(`_phylobase_getAllNodesFast`, edge) } testEqInt <- function(x, y) { .Call(`_phylobase_testEqInt`, x, y) } all_naC <- function(x) { .Call(`_phylobase_all_naC`, x) } any_naC <- function(x) { .Call(`_phylobase_any_naC`, x) } nb_naC <- function(x) { .Call(`_phylobase_nb_naC`, x) } getRange <- function(x, na_rm) { .Call(`_phylobase_getRange`, x, na_rm) } hasDuplicatedLabelsCpp <- function(label) { .Call(`_phylobase_hasDuplicatedLabelsCpp`, label) } edgeIdCpp <- function(edge, type) { .Call(`_phylobase_edgeIdCpp`, edge, type) } checkTreeCpp <- function(obj, opts) { .Call(`_phylobase_checkTreeCpp`, obj, opts) } phylobase/R/summary-methods.R0000644000176200001440000001742514553646170015746 0ustar liggesusers ##' Summary for phylo4/phylo4d objects ##' ##' Summary of information for the tree (\code{phylo4} only) and/or the ##' associated data (\code{phylo4d}). ##' ##' @name summary-methods ##' @docType methods ##' @param object a phylo4d object ##' @param quiet Should the summary be displayed on screen? ##' @param \dots optional additional elements (not in use) ##' ##' @return The \code{nodeType} method returns named vector which has ##' the type of node (internal, tip, root) for value, and the node number ##' for name ##' ##' The \code{summary} method invisibly returns a list with the ##' following components: \item{list("name")}{the name of the object} ##' ##' \item{list("nb.tips")}{the number of tips} ##' ##' \item{list("nb.nodes")}{the number of nodes} ##' ##' \item{list("mean.el")}{mean of edge lengths} ##' ##' \item{list("var.el")}{variance of edge lengths (estimate for population) } ##' ##' \item{list("sumry.el")}{summary (i.e. range and quartiles) of the ##' edge lengths} ##' ##' \item{list("degree")}{(optional) type of polytomy for each node: ##' \sQuote{node}, \sQuote{terminal} (all descendants are tips) or ##' \sQuote{internal} (at least one descendant is an internal node); ##' displayed only when there are polytomies} ##' ##' \item{list("sumry.tips")}{(optional) summary for the data ##' associated with the tips} ##' ##' \item{list("sumry.nodes")}{(optional) summary for the data ##' associated with the internal nodes} ##' ##' @author Ben Bolker, Thibaut Jombart, Francois Michonneau ##' @seealso \code{\link{phylo4d-methods}} constructor and ##' \code{\linkS4class{phylo4d}} class. ##' @keywords methods ##' @aliases summary ##' @include phylo4-methods.R ##' @include phylo4d-methods.R ##' @exportMethod summary ##' @examples ##' tOwls <- "(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);" ##' tree.owls <- ape::read.tree(text=tOwls) ##' P1 <- as(tree.owls, "phylo4") ##' P1 ##' summary(P1) ##' nodeType(P1) ##' ##' ## summary of a polytomous tree ##' E <- matrix(c( ##' 8, 9, ##' 9, 10, ##' 10, 1, ##' 10, 2, ##' 9, 3, ##' 9, 4, ##' 8, 11, ##' 11, 5, ##' 11, 6, ##' 11, 7, ##' 0, 8), ncol=2, byrow=TRUE) ##' ##' P2 <- phylo4(E) ##' nodeLabels(P2) <- as.character(nodeId(P2, "internal")) ##' plot(P2, show.node.label=TRUE) ##' sumryP2 <- summary(P2) ##' sumryP2 ##' setGeneric("summary") ##' @rdname summary-methods ##' @aliases summary,phylo4-method setMethod("summary", signature(object="phylo4"), function(object, quiet=FALSE) { res <- list() ## build the result object res$name <- deparse(substitute(object, sys.frame(-1))) res$nb.tips <- nTips(object) res$nb.nodes <- nNodes(object) if(hasEdgeLength(object)) { edge.length <- edgeLength(object) res$mean.el <- mean(edge.length, na.rm=TRUE) res$var.el <- stats::var(edge.length, na.rm=TRUE) if (isRooted(object) && is.na(edgeLength(object, rootNode(object)))) { root.index <- match(edgeId(object, "root"), names(edge.length)) res$sumry.el <- summary(edge.length[-root.index]) } else { res$sumry.el <- summary(edge.length) } } ## check for polytomies if (hasPoly(object)) { E <- edges(object) temp <- tabulate(E[,1][!is.na(E[, 1])]) degree <- temp[E[,1][!is.na(E[, 1])]] # contains the degree of the ancestor for all edges endsAtATip <- !(E[,2] %in% E[,1]) terminPoly <- (degree>2) & endsAtATip internPoly <- (degree>2) & !endsAtATip res$degree <- degree res$polytomy <- rep("none",nrow(E)) res$polytomy[terminPoly] <- "terminal" res$polytomy[internPoly] <- "internal" ## now just keep information about nodes (not all edges) nod <- unique(E[,1]) idx <- match(nod,E[,1]) res$degree <- res$degree[idx] names(res$degree) <- nodeLabels(object) res$polytomy <- res$polytomy[idx] names(res$polytomy) <- nodeLabels(object) } ## model info res$loglik <- attr(object, "loglik") res$para <- attr(object, "para") res$xi <- attr(object, "xi") ## if quiet, stop here if(quiet) return(invisible(res)) ## now, print to screen is !quiet cat("\n Phylogenetic tree :", res$name, "\n\n") cat(" Number of tips :", res$nb.tips, "\n") cat(" Number of nodes :", res$nb.nodes, "\n") ## cat(" ") if(hasEdgeLength(object)) { cat(" Branch lengths:\n") cat(" mean :", res$mean.el, "\n") cat(" variance :", res$var.el, "\n") cat(" distribution :\n") print(res$sumry.el) } else { cat(" Branch lengths : No branch lengths.\n") } if (hasPoly(object)) { cat("\nDegree of the nodes :\n") print(res$degree) cat("\n") cat("Types of polytomy:\n") print(res$polytomy) cat("\n") } if (!is.null(attr(object, "loglik"))) { cat("Phylogeny estimated by maximum likelihood.\n") cat(" log-likelihood:", attr(object, "loglik"), "\n\n") npart <- length(attr(object, "para")) for (i in 1:npart) { cat("partition ", i, ":\n", sep = "") print(attr(object, "para")[[i]]) if (i == 1) next else cat(" contrast parameter (xi):", attr(object,"xi")[i - 1], "\n") } } return(invisible(res)) }) ##' @rdname summary-methods ##' @aliases summary,phylo4d-method setMethod("summary", signature(object="phylo4d"), function(object, quiet=FALSE) { x <- object res <- summary(as(x, "phylo4"), quiet=quiet) res$name <- deparse(substitute(object, sys.frame(-1))) tips <- tdata(object, "tip") nodes <- tdata(object, "internal") if (!quiet) cat("\nComparative data:\n") if (nrow(tips) > 0) { if(!quiet) { cat("\nTips: data.frame with", nTips(object), "taxa and", ncol(tips), "variable(s) \n\n") } sumry.tips <- summary(tips) res$sumry.tips <- sumry.tips if (!quiet) print(sumry.tips) } else { if (!quiet) cat("\nObject contains no tip data.") } if (nrow(nodes) > 0) { if (!quiet) { cat("\nNodes: data.frame with", nNodes(object), "internal nodes and", ncol(nodes), "variables \n\n") } sumry.nodes <- summary(nodes) res$sumry.nodes <- sumry.nodes if (!quiet) print(sumry.nodes) } else { if(!quiet) cat("\nObject contains no node data.\n") } invisible(res) }) ##' @rdname summary-methods ##' @aliases nodeType ##' @export setGeneric("nodeType", function(object) { standardGeneric("nodeType") }) ##' @rdname summary-methods ##' @aliases nodeType,phylo4-method setMethod("nodeType", signature(object="phylo4"), function(object) { if(nTips(object) == 0) return(NULL) else { ## strip out the root ancestor nodesVect <- as.vector(edges(object)) nodesVect <- nodesVect[nodesVect != 0] ## get a sorted list of the unique nodes listNodes <- sort(unique(nodesVect)) t <- rep("internal", length(listNodes)) # FM: internal is default (I think it's safer) names(t) <- listNodes ## node number of real internal nodes iN <- names(table(edges(object)[,1])) ## node number that are not internal nodes (ie that are tips) tN <- names(t)[!names(t) %in% iN] t[tN] <- "tip" ## if the tree is rooted if(isRooted(object)) t[rootNode(object)] <- "root" return(t) } }) phylobase/R/phylo4d-accessors.R0000644000176200001440000000527114553646170016152 0ustar liggesusers ##' Tests for presence of data associated with trees stored as phylo4d objects ##' ##' Methods that test for the presence of data associated with trees stored as ##' \code{phylo4d} objects. ##' ##' \code{nData} tests for the presence of data associated with the object. ##' ##' \code{hasTipData} and \code{hasNodeData} tests for the presence of ##' data associated with the tips and the internal nodes ##' respectively. The outcome of the test is based on row names of the ##' data frame stored in the \code{data} slot. If no rows have names ##' from the set \code{nodeId(x, "tip")}, then \code{hasTipData} ##' returns FALSE. Likewise, if no rows have names from the set ##' \code{nodeId(x, "internal")}, then \code{hasNodeData} returns ##' FALSE. ##' ##' @param x a \code{phylo4d} object ##' @return \describe{ ##' ##' \item{\code{nData}}{returns the number of datasets (i.e., ##' columns) associated with the object.} ##' ##' \item{\code{hasTipData}, \code{hasNodeData}}{return \code{TRUE} ##' or \code{FALSE} depending whether data associated with the ##' tree are associated with either tips or internal nodes respectively.}} ##' @section Methods: \describe{ \item{hasNodeData}{\code{signature(object = ##' "phylo4d")}: whether tree has internal node data} ##' \item{hasTipData}{\code{signature(object = "phylo4d")}: whether tree has ##' data associated with its tips} } ##' @author Ben Bolker, Thibault Jombart, Francois Michonneau ##' @seealso \code{\link{phylo4d-methods}} constructor and ##' \code{\linkS4class{phylo4d}} class. ##' @rdname phylo4d-accessors ##' @aliases hasTipData ##' @keywords methods ##' @docType methods ##' @include phylo4d-class.R phylo4d-methods.R ##' @export ##' @examples ##' data(geospiza) ##' nData(geospiza) ## 5 ##' hasTipData(geospiza) ## TRUE ##' hasNodeData(geospiza) ## FALSE ##' setGeneric("hasTipData", function(x) { standardGeneric("hasTipData") }) ##' @rdname phylo4d-accessors ##' @aliases hasTipData-method,phylo4d-method setMethod("hasTipData", signature(x="phylo4d"), function(x) { ncol(tdata(x, type="tip", empty.columns=FALSE)) > 0 }) ##' @rdname phylo4d-accessors ##' @aliases hasNodeData-methods ##' @export setGeneric("hasNodeData", function(x) { standardGeneric("hasNodeData") }) ##' @rdname phylo4d-accessors ##' @aliases hasNodeData,phylo4d-method setMethod("hasNodeData", signature(x="phylo4d"), function(x) { ncol(tdata(x, type="internal", empty.columns=FALSE)) > 0 }) ##' @rdname phylo4d-accessors ##' @aliases nData ##' @export setGeneric("nData", function(x) { standardGeneric("nData") }) ##' @rdname phylo4d-accessors ##' @aliases nData,phylo4d-method setMethod("nData", signature(x="phylo4d"), function(x) { ncol(x@data) }) phylobase/R/setAs-methods.R0000644000176200001440000002443214553655024015322 0ustar liggesusers ##' Converting between phylo4/phylo4d and other phylogenetic tree ##' formats ##' ##' Translation functions to convert between phylobase objects ##' (\code{phylo4} or \code{phylo4d}), and objects used by other ##' comparative methods packages in R: \code{ape} objects ##' (\code{phylo}, \code{multiPhylo}), \code{RNeXML} object ##' (\code{nexml}), \code{ade4} objects (\code{phylog}, \emph{now ##' deprecated}), and to \code{data.frame} representation. ##' ##' @name setAs ##' @docType methods ##' @section Usage: \code{as(object, class)} ##' @author Ben Bolker, Thibaut Jombart, Marguerite Butler, Steve ##' Kembel, Francois Michonneau ##' @seealso generic \code{\link[methods]{as}}, ##' \code{\link{phylo4-methods}}, \code{\link{phylo4d-methods}}, ##' \code{\link{extractTree}}, \code{nexml} class from the ##' \code{RNeXML} package, \code{\link[ade4]{phylog}} from the ##' \code{ade4} package and \code{\link[ape]{as.phylo}} from the ##' \code{ape} package. ##' @keywords methods ##' @rdname setAs-methods ##' @aliases as as-method as,phylo,phylo4-method ##' @include phylo4-methods.R ##' @include phylo4d-methods.R ##' @include oldclasses-class.R ##' @examples ##' tree_string <- "(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);" ##' tree.owls <- ape::read.tree(text=tree_string) ##' ## round trip conversion ##' tree_in_phylo <- tree.owls # tree is a phylo object ##' (tree_in_phylo4 <- as(tree.owls,"phylo4")) # phylo converted to phylo4 ##' identical(tree_in_phylo,as(tree_in_phylo4,"phylo")) ##' ## test if phylo, and phylo4 converted to phylo are identical ##' ## (no, because of dimnames) ##' ##' ## Conversion to phylog (ade4) ##' as(tree_in_phylo4, "phylog") ##' ##' ## Conversion to data.frame ##' as(tree_in_phylo4, "data.frame") ##' ##' ## Conversion to phylo (ape) ##' as(tree_in_phylo4, "phylo") ##' ##' ## Conversion to phylo4d, (data slots empty) ##' as(tree_in_phylo4, "phylo4d") setAs("phylo", "phylo4", function(from, to) { ## fixme SWK kludgy fix may not work well with unrooted trees ## TODO should we also attempt to get order information? ## BMB horrible kludge to avoid requiring ape explicitly ape_is.rooted <- function(phy) { if (!is.null(phy$root.edge)) TRUE else if (tabulate(phy$edge[, 1])[length(phy$tip.label) + 1] > 2) FALSE else TRUE } if (ape_is.rooted(from)) { tip.idx <- 1:nTips(from) if (nTips(from) < nrow(from$edge)) { int.idx <- (nTips(from)+1):dim(from$edge)[1] } else { int.idx <- NULL } root.node <- as.numeric(setdiff(unique(from$edge[,1]), unique(from$edge[,2]))) from$edge <- rbind(from$edge[tip.idx,],c(0,root.node), from$edge[int.idx,]) if (!is.null(from$edge.length)) { if (is.null(from$root.edge)) { from$edge.length <- c(from$edge.length[tip.idx], as.numeric(NA),from$edge.length[int.idx]) } else { from$edge.length <- c(from$edge.length[tip.idx], from$root.edge,from$edge.length[int.idx]) } } if (!is.null(from$edge.label)) { from$edge.label <- c(from$edge.label[tip.idx], NA, from$edge.label[int.idx]) } } newobj <- phylo4(from$edge, from$edge.length, unname(from$tip.label), node.label = from$node.label, edge.label = from$edge.label, order = "unknown") oldorder <- attr(from,"order") neworder <- if (is.null(oldorder)) { "unknown" } else if (!oldorder %in% phylo4_orderings) { stop("unknown ordering '", oldorder, "' in ape object") } else if (oldorder == "cladewise" || oldorder == "preorder") { "preorder" } else if (oldorder == "pruningwise" || oldorder == "postorder") { "postorder" } if (isRooted(newobj)) { if (neworder == "preorder") { newobj <- reorder(newobj, order="preorder") } if (neworder == "postorder") { newobj <- reorder(newobj, order="postorder") } } newobj@order <- neworder attr(from,"order") <- NULL attribs <- attributes(from) attribs$names <- NULL knownattr <- c("logLik", "origin", "para", "xi") known <- names(attribs)[names(attribs) %in% knownattr] unknown <- names(attribs)[!names(attribs) %in% c(knownattr, "class", "names")] if (length(unknown) > 0) { warning(paste("unknown attributes ignored: ", unknown, collapse = " ")) } for (i in known) attr(newobj, i) <- attr(from, i) newobj }) ##' @name setAs ##' @rdname setAs-methods ##' @aliases as,phylo,phylo4d-method setAs("phylo", "phylo4d", function(from, to) { phylo4d(as(from, "phylo4"), tip.data = data.frame()) }) ##' @name setAs ##' @rdname setAs-methods ##' @aliases as,nexml,phylo4-method setAs("nexml", "phylo4", function(from, to) { phylo4(from) }) ##' @name setAs ##' @rdname setAs-methods ##' @aliases as,nexml,phylo4d-method setAs("nexml", "phylo4d", function(from, to) { phylo4d(from) }) ####################################################### ## Exporting to ape ## BMB: adding an explicit as method, and the warning, ## here is a very bad idea, because ## even implicit conversions from phylo4d to phylo4 (e.g. ## to use inherited methods) will produce the warning ## setAs("phylo4d", "phylo4",function(from,to) { ## warning("losing data while coercing phylo4d to phylo") ## phylo4(from@edge, from@edge.length, from@tip.label, ## from@node.label,from@edge.label,from@order) ## }) ##' @name setAs ##' @rdname setAs-methods ##' @aliases as,phylo4,phylo-method setAs("phylo4", "phylo", function(from, to) { if(is.character(checkval <- checkPhylo4(from))) { stop(checkval) } if (inherits(from, "phylo4d")) warning("losing data while coercing phylo4d to phylo") phy <- list() ## Edge matrix (dropping root edge if it exists) edgemat <- unname(edges(from, drop.root=TRUE)) storage.mode(edgemat) <- "integer" phy$edge <- edgemat ## Edge lengths if(hasEdgeLength(from)) { edge.length <- edgeLength(from) if(isRooted(from)) { iRoot <- match(edgeId(from, "root"), names(edge.length)) phy$edge.length <- unname(edge.length[-iRoot]) } else { phy$edge.length <- unname(edge.length) } } ## Tip labels phy$tip.label <- unname(tipLabels(from)) ## nNodes phy$Nnode <- as.integer(nNodes(from)) ## Node labels if(hasNodeLabels(from)) { phy$node.label <- unname(nodeLabels(from)) } ## Root edge if(isRooted(from) && hasEdgeLength(from)) { root.edge <- unname(edgeLength(from,rootNode(from))) if(!is.na(root.edge)) { phy$root.edge <- root.edge } } ## Converting to class phylo class(phy) <- "phylo" ## Tree order ## TODO postorder != pruningwise -- though quite similar if (edgeOrder(from) == "unknown") { warning("trees with unknown order may be", " unsafe in ape") } else { attr(phy, "order") <- switch(edgeOrder(from), postorder = "unknown", preorder = "cladewise", pruningwise = "pruningwise") } phy }) ## BMB: redundant???? ## JR: updated (but untested) to reflect slot changes, in case this ever ## needs to come out of its commented hibernation ## setAs("phylo4d", "phylo", function(from, to) { ## y <- list(edge = edges(from, drop.root=TRUE), ## Nnode = nNodes(from), tip.label = tipLabels(from)) ## class(y) <- "phylo" ## if (hasEdgeLength(from)) ## y$edge.length <- edgeLength(from) ## if (hasNodeLabels(from)) ## y$node.label <- nodeLabels(from) ## #if (!is.na(from@root.edge)) ## # y$root.edge <- from@root.edge ## warning("losing data while coercing phylo4d to phylo") ## y ##}) ####################################################### ## Exporting to ade4 ##' @name setAs ##' @rdname setAs-methods ##' @aliases setAs,phylo4,phylog-method setAs("phylo4", "phylog", function(from, to) { x <- as(from, "phylo") xstring <- write.tree(x, file = "") warning("ade4::phylog objects are deprecated, please use the adephylo package instead") ade4::newick2phylog(xstring) }) ####################################################### ## Exporting to dataframe .phylo4ToDataFrame <- function(from, edgeOrder=c("pretty", "real")) { edgeOrder <- match.arg(edgeOrder) ## Check the phylo4 if (is.character(checkval <- checkPhylo4(from))) stop(checkval) ## The order of 'node' defines the order of all other elements if (edgeOrder == "pretty") { node <- nodeId(from, "all") ancestr <- ancestor(from, node) # ancestor returns an NA, replace this w/ 0 to construct names correctly ancestr[is.na(ancestr)] <- as.integer(0) } else { E <- edges(from) node <- E[, 2] ancestr <- E[, 1] } ## extract and reorder (as needed) other object slots nmE <- paste(ancestr, node, sep="-") edge.length <- edgeLength(from) edge.length <- edge.length[match(nmE, names(edge.length))] ndType <- nodeType(from) ndType <- ndType[match(node, names(ndType))] label <- labels(from, type="all") label <- label[match(node, names(label))] tDf <- data.frame(label, node, ancestor=ancestr, edge.length, node.type=ndType, row.names=node, stringsAsFactors = TRUE) tDf$label <- as.character(tDf$label) if (inherits(from, "phylo4d")) { dat <- tdata(from, "all", label.type="column") # get data ## reorder data to edge matrix order, drop labels (first column) if(nrow(dat) > 0 && ncol(dat) > 1) { dat <- dat[match(rownames(tDf), rownames(dat)), ] tDf <- cbind(tDf, dat[ ,-1 , drop=FALSE]) } else { cat("No data associated with the tree\n") } } tDf } ##' @name setAs ##' @rdname setAs-methods ##' @aliases setAs,phylo4,data.frame-method setAs(from = "phylo4", to = "data.frame", def=function(from) { d <- .phylo4ToDataFrame(from, edgeOrder="pretty") d }) phylobase/R/tbind.R0000644000176200001440000000337514553646170013707 0ustar liggesusers## appropriate behavior ??? ## IF all missing data -- create multiPhylo4 ## IF some have data -- create multiPhylo4d (user can coerce to multiPhylo4) ## IF (checkData) then stop if all data not identical to first data ## ## need constructors for multiPhylo4, multiPhylo4d!! ## FIXME: need code to construct tree.names ... ## function to bind trees together into a multi-tree object tbind <- function(...,checkData=TRUE) { L <- list(...) namevec <- names(L) treeclasses <- c("multiPhylo4d","multiPhylo4","phylo4","phylo4d") tdataclasses <- c("multiPhylo4d","phylo4d") classes <- sapply(L,class) if (!all(classes %in% treeclasses)) { stop("all elements must be trees or multitrees") } hasData <- any(classes %in% tdataclasses) allData <- all(classes %in% tdataclasses) xfun <- function(x) { switch(class(x), phylo4=x, phylo4d=extractTree(x), multiPhylo4=x@phylolist, multiPhylo4d=suppressWarnings(as("multiPhylo4",x)@phylolist))} ## decompose multi-trees into lists treelist <- unlist(lapply(L,xfun)) if (hasData) alldat <- lapply(L[classes %in% tdataclasses], tdata, type="tip") hasNodeData <- sapply(L[classes %in% tdataclasses], hasNodeData) if (any(hasNodeData)) warning("internal node data discarded") if (checkData) { ident <- sapply(alldat,identical,y=alldat[[1]]) if (!all(ident)) stop(paste("tip data sets differ")) } ## ?? implement code to check which ones differ (taking ## null/multiple values in original set into account) if (hasData) return(new("multiPhylo4d",phylolist=treelist, tip.data=alldat[[1]])) return(new("multiPhylo4",phylolist=treelist)) } phylobase/R/phylo4d-methods.R0000644000176200001440000004230514553715034015623 0ustar liggesusers###################### ## phylo4d constructor ###################### ## TEST ME ## '...' recognized args for data are tipdata and nodedata. ## other recognized options are those known by the phylo4 constructor ##' Combine a phylogenetic tree with data ##' ##' \code{phylo4d} is a generic constructor which merges a ##' phylogenetic tree with data frames to create a combined object of ##' class \code{phylo4d} ##' ##' You can provide several data frames to define traits associated ##' with tip and/or internal nodes. By default, data row names are ##' used to link data to nodes in the tree, with any number-like names ##' (e.g., \dQuote{10}) matched against node ID numbers, and any ##' non-number-like names (e.g., \dQuote{n10}) matched against node ##' labels. Alternative matching rules can be specified by passing ##' additional arguments (listed in the Details section); these ##' include positional matching, matching exclusively on node labels, ##' and matching based on a column of data rather than on row ##' names. ##' ##' Matching rules will apply the same way to all supplied data ##' frames. This means that you need to be consistent with the row ##' names of your data frames. It is good practice to use tip and ##' node labels (or node numbers if you use duplicated labels) when ##' you combine data with a tree. ##' ##' If you provide both \code{tip.data} and \code{node.data}, the ##' treatment of columns with common names will depend on the ##' \code{merge.data} argument. If TRUE, columns with the same name in ##' both data frames will be merged; when merging columns of different ##' data types, coercion to a common type will follow standard R ##' rules. If \code{merge.data} is FALSE, columns with common names ##' will be preserved independently, with \dQuote{.tip} and ##' \dQuote{.node} appended to the names. This argument has no effect ##' if \code{tip.data} and \code{node.data} have no column names in ##' common. ##' ##' If you provide \code{all.data} along with either of ##' \code{tip.data} and \code{node.data}, it must have distinct column ##' names, otherwise an error will result. Additionally, although ##' supplying columns with the same names \emph{within} data frames is ##' not illegal, automatic renaming for uniqeness may lead to ##' surprising results, so this practice should be avoided. ##' ##' @name phylo4d-methods ##' @aliases phylo4d ##' @param x an object of class \code{phylo4}, \code{phylo}, ##' \code{nexml} or a matrix of edges (see above) ##' @param tip.data a data frame (or object to be coerced to one) ##' containing only tip data (Optional) ##' @param node.data a data frame (or object to be coerced to one) ##' containing only node data (Optional) ##' @param all.data a data frame (or object to be coerced to one) ##' containing both tip and node data (Optional) ##' @param merge.data if both \code{tip.data} and \code{node.data} are ##' provided, should columns with common names will be merged together ##' (default TRUE) or not (FALSE)? See details. ##' @param metadata any additional metadata to be passed to the new object ##' @param edge.length Edge (branch) length. (Optional) ##' @param tip.label A character vector of species names (names of ##' "tip" nodes). (Optional) ##' @param node.label A character vector of internal node ##' names. (Optional) ##' @param edge.label A character vector of edge (branch) ##' names. (Optional) ##' @param order character: tree ordering (allowable values are listed ##' in \code{phylo4_orderings}, currently "unknown", "preorder" ##' (="cladewise" in \code{ape}), and "postorder", with "cladewise" ##' and "pruningwise" also allowed for compatibility with \code{ape}) ##' @param annote any additional annotation data to be passed to the ##' new object ##' @param check.node.labels if \code{x} is of class \code{phylo}, use ##' either \dQuote{keep} (the default) to retain internal node labels, ##' \dQuote{drop} to drop them, or \dQuote{asdata} to convert them to ##' numeric tree data. This argument is useful if the \code{phylo} ##' object has non-unique node labels or node labels with informative ##' data (e.g., posterior probabilities). ##' @param \dots further arguments to control the behavior of the ##' constructor in the case of missing/extra data and where to look ##' for labels in the case of non-unique labels that cannot be stored ##' as row names in a data frame (see Details). ##' @details This is the list of additional arguments that can be used ##' to control matching between the tree and the data: ##' ##' \describe{ ##' ##' \item{match.data}{(logical) should the rownames of the data frame ##' be used to be matched against tip and internal node identifiers?} ##' ##' \item{rownamesAsLabels}{(logical), should the row names of the ##' data provided be matched only to labels (TRUE), or should any ##' number-like row names be matched to node numbers (FALSE and ##' default)} ##' ##' \item{label.type}{character, \code{rownames} or \code{column}: ##' should the labels be taken from the row names of \code{dt} or from ##' the \code{label.column} column of \code{dt}?} ##' ##' \item{label.column}{iff \code{label.type=="column"}, column ##' specifier (number or name) of the column containing tip labels} ##' ##' \item{missing.data}{action to take if there are missing data or if ##' there are data labels that don't match} ##' ##' \item{extra.data}{action to take if there are extra data or if ##' there are labels that don't match} ##' ##' \item{keep.all}{(logical), should the returned data have rows for ##' all nodes (with NA values for internal rows when type='tip', and ##' vice versa) (TRUE and default) or only rows corresponding to the ##' type argument} ##' ##' } ##' ##' Rules for matching rows of data to tree nodes are determined ##' jointly by the \code{match.data} and \code{rownamesAsLabels} ##' arguments. If \code{match.data} is TRUE, data frame rows will be ##' matched exclusively against tip and node labels if ##' \code{rownamesAsLabels} is also TRUE, whereas any all-digit row ##' names will be matched against tip and node numbers if ##' \code{rownamesAsLabels} is FALSE (the default). If ##' \code{match.data} is FALSE, \code{rownamesAsLabels} has no effect, ##' and row matching is purely positional with respect to the order ##' returned by \code{nodeId(phy, type)}. ##' ##' @return An object of class \linkS4class{phylo4d}. ##' @note Checking on matches between the tree and the data will be ##' done by the validity checker (label matches between data and tree ##' tips, number of rows of data vs. number of nodes/tips/etc.) ##' @section Methods: \describe{ \item{x = "phylo4"}{merges a tree of ##' class \code{phylo4} with a data.frame into a \code{phylo4d} ##' object} \item{x = "matrix"}{merges a matrix of tree edges similar ##' to the edge slot of a \code{phylo4} object (or to \code{$edge} of a ##' \code{phylo} object) with a data.frame into a \code{phylo4d} ##' object} \item{x = "phylo"}{merges a tree of class \code{phylo} ##' with a data.frame into a \code{phylo4d} object } } ##' @author Ben Bolker, Thibaut Jombart, Steve Kembel, Francois ##' Michonneau, Jim Regetz ##' @seealso \code{\link{coerce-methods}} for translation ##' functions. The \linkS4class{phylo4d} class; \linkS4class{phylo4} ##' class and \link{phylo4} constructor. ##' @keywords misc ##' @export ##' @docType methods ##' @rdname phylo4d-methods ##' @include phylo4d-class.R ##' @include oldclasses-class.R ##' @examples ##' ##' treeOwls <- "((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3);" ##' tree.owls.bis <- ape::read.tree(text=treeOwls) ##' try(phylo4d(as(tree.owls.bis,"phylo4"),data.frame(wing=1:3)), silent=TRUE) ##' obj <- phylo4d(as(tree.owls.bis,"phylo4"),data.frame(wing=1:3), match.data=FALSE) ##' obj ##' print(obj) ##' ##' #### ##' ##' data(geospiza_raw) ##' geoTree <- geospiza_raw$tree ##' geoData <- geospiza_raw$data ##' ##' ## fix differences in tip names between the tree and the data ##' geoData <- rbind(geoData, array(, dim = c(1,ncol(geoData)), ##' dimnames = list("olivacea", colnames(geoData)))) ##' ##' ### Example using a tree of class 'phylo' ##' exGeo1 <- phylo4d(geoTree, tip.data = geoData) ##' ##' ### Example using a tree of class 'phylo4' ##' geoTree <- as(geoTree, "phylo4") ##' ##' ## some random node data ##' rNodeData <- data.frame(randomTrait = rnorm(nNodes(geoTree)), ##' row.names = nodeId(geoTree, "internal")) ##' ##' exGeo2 <- phylo4d(geoTree, tip.data = geoData, node.data = rNodeData) ##' ##' ### Example using 'merge.data' ##' data(geospiza) ##' trGeo <- extractTree(geospiza) ##' tDt <- data.frame(a=rnorm(nTips(trGeo)), row.names=nodeId(trGeo, "tip")) ##' nDt <- data.frame(a=rnorm(nNodes(trGeo)), row.names=nodeId(trGeo, "internal")) ##' ##' (matchData1 <- phylo4d(trGeo, tip.data=tDt, node.data=nDt, merge.data=FALSE)) ##' (matchData2 <- phylo4d(trGeo, tip.data=tDt, node.data=nDt, merge.data=TRUE)) ##' ##' ## Example with 'all.data' ##' nodeLabels(geoTree) <- as.character(nodeId(geoTree, "internal")) ##' rAllData <- data.frame(randomTrait = rnorm(nTips(geoTree) + nNodes(geoTree)), ##' row.names = labels(geoTree, 'all')) ##' ##' exGeo5 <- phylo4d(geoTree, all.data = rAllData) ##' ##' ## Examples using 'rownamesAsLabels' and comparing with match.data=FALSE ##' tDt <- data.frame(x=letters[1:nTips(trGeo)], ##' row.names=sample(nodeId(trGeo, "tip"))) ##' tipLabels(trGeo) <- as.character(sample(1:nTips(trGeo))) ##' (exGeo6 <- phylo4d(trGeo, tip.data=tDt, rownamesAsLabels=TRUE)) ##' (exGeo7 <- phylo4d(trGeo, tip.data=tDt, rownamesAsLabels=FALSE)) ##' (exGeo8 <- phylo4d(trGeo, tip.data=tDt, match.data=FALSE)) ##' ##' ## generate a tree and some data ##' set.seed(1) ##' p3 <- ape::rcoal(5) ##' dat <- data.frame(a = rnorm(5), b = rnorm(5), row.names = p3$tip.label) ##' dat.defaultnames <- dat ##' row.names(dat.defaultnames) <- NULL ##' dat.superset <- rbind(dat, rnorm(2)) ##' dat.subset <- dat[-1, ] ##' ##' ## create a phylo4 object from a phylo object ##' p4 <- as(p3, "phylo4") ##' ##' ## create phylo4d objects with tip data ##' p4d <- phylo4d(p4, dat) ##' ###checkData(p4d) ##' p4d.sorted <- phylo4d(p4, dat[5:1, ]) ##' try(p4d.nonames <- phylo4d(p4, dat.defaultnames)) ##' p4d.nonames <- phylo4d(p4, dat.defaultnames, match.data=FALSE) ##' ##' \dontrun{ ##' p4d.subset <- phylo4d(p4, dat.subset) ##' p4d.subset <- phylo4d(p4, dat.subset) ##' try(p4d.superset <- phylo4d(p4, dat.superset)) ##' p4d.superset <- phylo4d(p4, dat.superset) ##' } ##' ##' ## create phylo4d objects with node data ##' nod.dat <- data.frame(a = rnorm(4), b = rnorm(4)) ##' p4d.nod <- phylo4d(p4, node.data = nod.dat, match.data=FALSE) ##' ##' ##' ## create phylo4 objects with node and tip data ##' p4d.all1 <- phylo4d(p4, node.data = nod.dat, tip.data = dat, match.data=FALSE) ##' nodeLabels(p4) <- as.character(nodeId(p4, "internal")) ##' p4d.all2 <- phylo4d(p4, all.data = rbind(dat, nod.dat), match.data=FALSE) setGeneric("phylo4d", function(x, ...) { standardGeneric("phylo4d") }) ## first arg is a phylo4 ##' @rdname phylo4d-methods ##' @aliases phylo4d,phylo4,phylo4-method setMethod("phylo4d", "phylo4", function(x, tip.data=NULL, node.data=NULL, all.data=NULL, merge.data=TRUE, metadata = list(), ...) { ## coerce tree to phylo4d res <- as(x, "phylo4d") ## apply formatData to ensure data have node number rownames and ## correct dimensions tip.data <- formatData(phy=x, dt=tip.data, type="tip", ...) node.data <- formatData(phy=x, dt=node.data, type="internal", ...) all.data <- formatData(phy=x, dt=all.data, type="all", ...) ## add any data res@data <- .phylo4Data(x=x, tip.data=tip.data, node.data=node.data, all.data=all.data, merge.data=merge.data) ## add any metadata res@metadata <- metadata return(res) }) ### first arg is a matrix of edges ##' @rdname phylo4d-methods ##' @aliases phylo4d,matrix,matrix-method setMethod("phylo4d", "matrix", function(x, tip.data=NULL, node.data=NULL, all.data=NULL, merge.data=TRUE, metadata=list(), edge.length=NULL, tip.label=NULL, node.label=NULL, edge.label=NULL, order="unknown", annote=list(), ...) { tree <- phylo4(x, edge.length=edge.length, tip.label=tip.label, node.label=node.label, edge.label=edge.label, order=order, annote=annote) res <- phylo4d(tree, tip.data, node.data, all.data, merge.data=merge.data, metadata=metadata, ...) return(res) }) label_to_data <- function(nlab.data, ...) { ## convert number-like labels to numeric, other keep as it is nlab.data.test <- gsub("[0-9]|\\.", "", nlab.data[!is.na(nlab.data)]) if (all(nchar(nlab.data.test) == 0 )) { nlab.data <- data.frame(labelValues = as.numeric(nlab.data), ..., stringsAsFactors = TRUE) } else { nlab.data <- data.frame(labelValues = nlab.data, ..., stringsAsFactors =TRUE) } nlab.data } ### first arg is a phylo ##' @rdname phylo4d-methods ##' @aliases phylo4d,phylo,phylo-method setMethod("phylo4d", "phylo", function(x, tip.data=NULL, node.data=NULL, all.data=NULL, check.node.labels=c("keep", "drop", "asdata"), annote=list(), metadata=list(), ...) { check.node.labels <- match.arg(check.node.labels) if (check.node.labels == "asdata") { # FIXME? use.node.names=TRUE won't work with this option b/c # node labels are dropped; assumes node.data (if any), phylo # node.label, and phylo4 internal nodes are in the same order? nlab.data <- x$node.label x$node.label <- NULL nlab.data[!nzchar(nlab.data)] <- NA ## convert number-like labels to numeric, other keep as it is nlab.data <- label_to_data(nlab.data) tree <- phylo4(x, check.node.labels="drop", annote=annote) res <- phylo4d(tree, tip.data=tip.data, node.data=node.data, all.data=all.data, metadata=metadata, ...) res <- addData(res, node.data=nlab.data, pos="before", match.data=FALSE) } else { tree <- phylo4(x, check.node.labels=check.node.labels, annote=annote) res <- phylo4d(tree, tip.data=tip.data, node.data=node.data, all.data=all.data, metadata=metadata, ...) } return(res) }) ### first arg is a phylo4d ##' @rdname phylo4d-methods ##' @aliases phylo4d,phylo4d,phylo4d-method setMethod("phylo4d", c("phylo4d"), function(x, ...) { stop("Your object is already a phylo4d object. If you want to modify", " the data attached to it look at the help for tdata()<-,") }) ### first arg is nexml ##' @rdname phylo4d-methods ##' @aliases nexml,phylo4d-method setMethod("phylo4d", c("nexml"), function(x) { tr <- RNeXML::get_trees_list(x) chr <- RNeXML::get_characters(x) if (is.null(tr[[1]])) { new("phylo4d") } else { if (length(tr) > 1) { warning("Only the first tree has been imported.") } phylo4d(x=tr[[1]][[1]], chr) } }) ### Core function that takes care of the data .phylo4Data <- function(x, tip.data=NULL, node.data=NULL, all.data=NULL, merge.data=TRUE) { ## Check validity of phylo4 object if (is.character(checkval <- checkPhylo4(x))) stop(checkval) ## Create placeholder data frames for any null data arguments if (is.null(tip.data)) tip.data <- formatData(x, NULL, "tip") if (is.null(node.data)) node.data <- formatData(x, NULL, "internal") if (is.null(all.data)) all.data <- formatData(x, NULL, "all") # don't allow all.data columns of same name as tip.data or node.data colnamesTipOrNode <- union(names(tip.data), names(node.data)) if (any(names(all.data) %in% colnamesTipOrNode)) { stop("all.data column names must be distinct from ", "tip.data and node.data column names") } ## combine common columns and move into all.data if merging, ## otherwise rename them colsToMerge <- intersect(names(tip.data), names(node.data)) if (merge.data && length(colsToMerge)>0) { ##TODO could really just index rows directly on 1:nTip and ## (nTip+1):(nTip+nNode) in the next two statements for speed, ## but this is more robust to changes in node numbering rules tip.rows <- tip.data[match(nodeId(x, "tip"), row.names(tip.data)), colsToMerge, drop=FALSE] node.rows <- node.data[match(nodeId(x, "internal"), row.names(tip.data)), colsToMerge, drop=FALSE] merge.data <- rbind(tip.rows, node.rows) all.data <- data.frame(all.data, merge.data, stringsAsFactors = TRUE) } else { names(tip.data)[names(tip.data) %in% colsToMerge] <- paste(colsToMerge, "tip", sep = ".") names(node.data)[names(node.data) %in% colsToMerge] <- paste(colsToMerge, "node", sep=".") } ## now separate tips-only and nodes-only data tip.only.data <- tip.data[setdiff(names(tip.data), names(node.data))] node.only.data <- node.data[setdiff(names(node.data), names(tip.data))] ## combine all data complete.data <- data.frame(all.data, tip.only.data, node.only.data, stringsAsFactors = TRUE) ## drop any rows that only contain NAs if (ncol(complete.data)==0) { return(data.frame()) } else { empty.rows <- as.logical(rowSums(!is.na(complete.data))) return(complete.data[empty.rows, , drop=FALSE]) } } phylobase/R/print-methods.R0000644000176200001440000001050014553714335015367 0ustar liggesusers ##' print a phylogeny ##' ##' Prints a phylo4 or phylo4d object in data.frame format with user-friendly ##' column names ##' ##' This is a user-friendly version of the tree representation, useful for ##' checking that objects were read in completely and translated correctly. The ##' phylogenetic tree is represented as a list of numbered nodes, linked in a ##' particular way through time (or rates of evolutionary change). The topology ##' is given by the pattern of links from each node to its ancestor. Also given ##' are the taxon names, node type (root/internal/tip) and phenotypic data (if ##' any) associated with the node, and the branch length from the node to its ##' ancestor. A list of nodes (descendants) and ancestors is minimally required ##' for a phylo4 object. ##' ##' @param x a \code{phylo4} tree or \code{phylo4d} tree+data object ##' @param object a \code{phylo4} or \code{phylo4d} object ##' @param edgeOrder in the data frame returned, the option 'pretty' returns the ##' internal nodes followed by the tips, the option 'real' returns the nodes in ##' the order they are stored in the edge matrix. ##' @param printall default prints entire tree. printall=FALSE returns the first ##' 6 rows ##' @param n for head() and tail(), the number of lines to print ##' @param \dots optional additional arguments (not in use) ##' @return A data.frame with a row for each node (descendant), sorted as ##' follows: root first, then other internal nodes, and finally tips.\cr The ##' returned data.frame has the following columns:\cr \item{label}{Label for the ##' taxon at the node (usually species name).} \item{node}{Node number, i.e. the ##' number identifying the node in edge matrix.} \item{ancestor}{Node number ##' of the node's ancestor.} \item{branch.length}{The branch length connecting ##' the node to its ancestor (NAs if missing).} \item{node.type}{"root", ##' "internal", or "tip". (internally generated)} \item{data}{phenotypic data ##' associated with the nodes, with separate columns for each variable.} ##' @note This is the default show() method for phylo4, phylo4d. It prints the ##' user-supplied information for building a phylo4 object. For a full ##' description of the phylo4 S4 object and slots, see \code{\link{phylo4}}. ##' @author Marguerite Butler, Thibaut Jombart \email{jombart@@biomserv.univ-lyon1.fr}, Steve Kembel ##' @include setAs-methods.R ##' @keywords methods ##' @examples ##' ##' ##' tree.phylo <- ape::read.tree(text="((a,b),c);") ##' tree <- as(tree.phylo, "phylo4") ##' ##plot(tree,show.node=TRUE) ## plotting broken with empty node labels: FIXME ##' tip.data <- data.frame(size=c(1,2,3), row.names=c("a", "b", "c")) ##' treedata <- phylo4d(tree, tip.data) ##' plot(treedata) ##' print(treedata) ##' ##' ##' @aliases print ##' @rdname print-methods setGeneric("print") ##' @rdname print-methods ##' @aliases print,phylo4-method ##' @exportMethod print setMethod("print", signature(x="phylo4"), function(x, edgeOrder=c("pretty", "real"), printall=TRUE) { if(!nrow(edges(x))) { msg <- paste("Empty \'", class(x), "\' object\n", sep="") cat(msg) } else { toRet <- .phylo4ToDataFrame(x, edgeOrder) if (printall) { print(toRet) } else { print(head(toRet)) } } }) ##' @rdname print-methods ##' @aliases show ##' @exportMethod show setGeneric("show") ##' @rdname print-methods ##' @aliases show,phylo4-method setMethod("show", signature(object="phylo4"), function(object) { print(object) }) ##' @rdname print-methods ##' @aliases names ##' @exportMethod names ##' @export setGeneric("names") ##' @rdname print-methods ##' @aliases names,phylo4-method setMethod("names", signature(x="phylo4"), function(x) { temp <- rev(names(attributes(x)))[-1] return(rev(temp)) }) ##' @rdname print-methods ##' @aliases head ##' @exportMethod head setGeneric("head") ##' @rdname print-methods ##' @aliases head,phylo4-method setMethod("head", signature(x="phylo4"), function(x, n=20) { head(as(x,"data.frame"),n=n) }) ##' @rdname print-methods ##' @aliases tail ##' @exportMethod tail setGeneric("tail") ##' @rdname print-methods ##' @aliases tail,phylo4-method setMethod("tail", signature(x="phylo4"), function(x, n=20) { tail(as(x, "data.frame"), n=n) }) phylobase/R/phylobase-package.R0000644000176200001440000001045114553736432016160 0ustar liggesusers ##' Utilities and Tools for Phylogenetics ##' ##' Base package for phylogenetic structures and comparative data. ##' ##' \code{phylobase} provides a set of functions to associate and ##' manipulate phylogenetic information and data about the ##' species/individuals that are in the tree. ##' ##' \code{phylobase} intends to be robust, fast and efficient. We hope ##' other people use the data structure it provides to develop new ##' comparative methods in R. ##' ##' With \code{phylobase} it is easy to ensure that all your data are ##' represented and associated with the tips or the internal nodes of ##' your tree. \code{phylobase} provides functions to: ##' \itemize{ ##' ##' \item prune (subset) your trees, find ancestor(s) a ##' descendant(s) ##' ##' \item find the most common recent ancestor of 2 nodes (MRCA) ##' ##' \item calculate the distance of a given node from the tip or ##' between two nodes in your tree ##' ##' \item robust functions to import data from NEXUS and Newick files ##' using the NEXUS Class Library (\url{https://github.com/mtholder/ncl/}) ##' } ##' ##' @section History: ##' ##' \code{phylobase} was started during a Hackathlon at NESCent on ##' December 10-14 2007. ##' ##' Peter Cowan was a Google Summer of Code fellow in 2008 and ##' developed all the code for plotting. ##' ##' In December 2008, a mini-virtual Hackathlon was organized to clean ##' up and make the code more robust. ##' ##' In the spring and summer of 2009, Jim Regetz made several ##' contributions that made the code faster (in particular with the ##' re-ordering parts), found many bugs, and wrote most of the testing ##' code. ##' ##' \code{phylobase} was first released on CRAN on November 1st, 2009 ##' with version 0.5. ##' ##' Since then, several releases have followed adding new ##' functionalities: better support of NEXUS files, creation of ##' \code{phylobase.options()} function that controls the \code{phylo4} ##' validator, rewrite of the validator in C++. ##' ##' Starting with 0.6.8, Francois Michonneau succeeds to Ben Bolker as ##' the maintainer of the package. ##' ##' @name phylobase-package ##' @aliases phylobase-package phylobase ##' @section More Info: ##' See the help index \code{help(package="phylobase")} and run ##' \code{vignette("phylobase", "phylobase")} for further details and ##' examples about how to use \code{phylobase}. ##' @keywords package ##' ##' @useDynLib phylobase, .registration = TRUE ##' @importFrom methods show as is new ##' @import ape ##' @import RNeXML ##' @import grid ##' @import stats ##' @importFrom Rcpp evalCpp ##' @importFrom graphics plot ##' @importFrom utils head tail ##' @importFrom ade4 newick2phylog ##' @importFrom rncl rncl ##' ##' @exportMethod print head tail reorder plot summary ##' ## exportMethod should only be used for generics defined outside the package! ## @exportMethod phylo4 phylo4d ## @exportMethod edges edgeId hasEdgeLength edgeLength edgeLength<- sumEdgeLength edgeOrder ## @exportMethod isRooted rootNode rootNode<- ## @exportMethod isUltrametric ## @exportMethod subset prune [ ## @exportMethod [<- [[ [[<- ## @exportMethod labels labels<- nodeLabels nodeLabels<- tipLabels tipLabels<- edgeLabels edgeLabels<- ## @exportMethod hasNodeLabels hasEdgeLabels hasDuplicatedLabels "_PACKAGE" ##' Data from Darwin's finches ##' ##' Phylogenetic tree and morphological data for Darwin's finches, in different ##' formats ##' ##' ##' @name geospiza ##' @aliases geospiza geospiza_raw ##' @docType data ##' @format \code{geospiza} is a \code{phylo4d} object; \code{geospiza_raw} is a ##' list containing \code{tree}, a \code{phylo} object (the tree), \code{data}, ##' and a data frame with the data (for showing examples of how to merge tree ##' and data) ##' @note Stolen from Luke Harmon's Geiger package, to avoid unnecessary ##' dependencies ##' @source Dolph Schluter via Luke Harmon ##' @keywords datasets ##' @examples ##' ##' data(geospiza) ##' plot(geospiza) ##' NULL ##' 'Owls' data from ape ##' ##' A tiny tree, for testing/example purposes, using one of the examples from ##' the \code{ape} package ##' ##' ##' @name owls4 ##' @docType data ##' @format This is the standard 'owls' tree from the \code{ape} package, in ##' \code{phylo4} format. ##' @source From various examples in the \code{ape} package ##' @keywords datasets ##' @examples ##' ##' data(owls4) ##' plot(owls4) ##' NULL phylobase/R/ancestors.R0000644000176200001440000001745314553646170014612 0ustar liggesusers ##' Tree traversal and utility functions ##' ##' Functions for describing relationships among phylogenetic nodes (i.e. ##' internal nodes or tips). ##' ##' \code{ancestors} and \code{descendants} can take \code{node} vectors of ##' arbitrary length, returning a list of output vectors if the number of valid ##' input nodes is greater than one. List element names are taken directly from ##' the input node vector. ##' ##' If any supplied nodes are not found in the tree, the behavior currently ##' varies across functions. ##' \itemize{ ##' \item Invalid nodes are automatically omitted by \code{ancestors} ##' and \code{descendants}, with a warning. ##' ##' \item \code{ancestor} ##' will return \code{NA} for any invalid nodes, with a warning. ##' ##' \item Both \code{children} and \code{siblings} will return an empty ##' vector, again with a warning. ##' } ##' @param phy a \linkS4class{phylo4} object (or one inheriting from ##' \linkS4class{phylo4}, e.g. a \linkS4class{phylo4d} object) ##' @param node either an integer corresponding to a node ID number, or a ##' character corresponding to a node label; for \code{ancestors} and ##' \code{descendants}, this may be a vector of multiple node numbers or names ##' @param type (\code{ancestors}) specify whether to return just direct ##' ancestor ("parent"), all ancestor nodes ("all"), or all ancestor nodes ##' including self ("ALL"); (\code{descendants}) specify whether to return just ##' direct descendants ("children"), all extant descendants ("tips"), or all ##' descendant nodes ("all") or all descendant nodes including self ("ALL"). ##' @param include.self whether to include self in list of siblings ##' @return \describe{ ##' \item{\code{ancestors}}{ return a named vector (or a list ##' of such vectors in the case of multiple input nodes) of the ##' ancestors and descendants of a node} ##' ##' \item{\code{descendants}}{ return a named vector (or a list of ##' such vectors in the case of multiple input nodes) of the ancestors ##' and descendants of a node} ##' ##' \item{\code{ancestor}}{ \code{ancestor} is analogous to ##' \code{ancestors(\dots{}, type="parent")} (i.e. direct ancestor ##' only), but returns a single concatenated vector in the case of ##' multiple input nodes} ##' ##' \item{\code{children}}{is analogous to \code{descendants(\dots{}, ##' type="children")} (i.e. direct descendants only), but is not ##' currently intended to be used with multiple input nodes } ##' ##' \item{\code{siblings}}{ returns sibling nodes (children of the same ##' parent)} ##' } ##' @seealso \code{\link[ape]{mrca}}, in the ape package, gives a list of all ##' subtrees ##' @export ##' @rdname ancestors ##' @include phylo4-class.R ##' @include phylo4-methods.R ##' @include getNode-methods.R ##' @examples ##' ##' data(geospiza) ##' nodeLabels(geospiza) <- LETTERS[1:nNodes(geospiza)] ##' plot(as(geospiza, "phylo4"), show.node.label=TRUE) ##' ancestor(geospiza, "E") ##' children(geospiza, "C") ##' descendants(geospiza, "D", type="tips") ##' descendants(geospiza, "D", type="all") ##' ancestors(geospiza, "D") ##' MRCA(geospiza, "conirostris", "difficilis", "fuliginosa") ##' MRCA(geospiza, "olivacea", "conirostris") ##' ##' ## shortest path between 2 nodes ##' shortestPath(geospiza, "fortis", "fuliginosa") ##' shortestPath(geospiza, "F", "L") ##' ##' ## branch length from a tip to the root ##' sumEdgeLength(geospiza, ancestors(geospiza, "fortis", type="ALL")) ancestor <- function(phy,node) { node2 <- getNode(phy,node) ## r <- which(edges(phy)[,2]==node) r <- match(node2,edges(phy)[,2]) return(getNode(phy,edges(phy)[r,1],missing="OK")) } ##' @rdname ancestors ##' @aliases children ##' @export children <- function(phy,node) { node2 <- getNode(phy,node) r <- which(edges(phy)[,1]==node2) getNode(phy,edges(phy)[r,2]) } ##' @rdname ancestors ##' @aliases descendants ##' @export descendants <- function (phy, node, type=c("tips","children","all", "ALL")) { type <- match.arg(type) ## look up nodes, warning about and excluding invalid nodes oNode <- node node <- getNode(phy, node, missing="warn") isValid <- !is.na(node) node <- as.integer(node[isValid]) if (type == "children") { res <- lapply(node, function(x) children(phy, x)) names(res) <- node } else { ## edge matrix must be in preorder for the C function! if (phy@order=="preorder") { edge <- phy@edge } else { edge <- reorder(phy, order="preorder")@edge } ## extract edge columns ancestor <- as.integer(edge[, 1]) descendant <- as.integer(edge[, 2]) ## return indicator matrix of ALL descendants (including self) isDes <- .Call("descendants_c", node, ancestor, descendant, PACKAGE = "phylobase") storage.mode(isDes) <- "logical" if (type == "all") { i <- match(intersect(node, nodeId(phy, "internal")), descendant) isDes[i, seq_along(node)] <- FALSE } ## if only tips desired, drop internal nodes if (type=="tips") { isDes[descendant %in% nodeId(phy, "internal"),] <- FALSE } res <- lapply(seq_along(node), function(n) { getNode(phy, descendant[isDes[,n]]) }) names(res) <- node } ## if just a single node, return as a single vector if (length(res)==1) res <- res[[1]] res ## Original pure R implementation of the above ## (note that it does not require preorder ordering) ##n <- nTips(phy) ##if (node <= n) { ## return(node) ##} ##l <- numeric() ##d <- children(phy, node) ##for (j in d) { ## if (j <= n) ## l <- c(l,j) ## else if (type=="all") l <- c(l,j, ## descendants(phy,j,type="all")) ## else l <- c(l, descendants(phy,j,type=type)) ##} } ##' @rdname ancestors ##' @aliases siblings ##' @export siblings <- function(phy, node, include.self=FALSE) { v <- children(phy,ancestor(phy,node)) if (!include.self) v <- v[v!=getNode(phy,node)] v } ##' @rdname ancestors ##' @aliases siblings ##' @export ancestors <- function (phy, node, type=c("all","parent","ALL")) { type <- match.arg(type) ## look up nodes, warning about and excluding invalid nodes oNode <- node node <- getNode(phy, node, missing="warn") isValid <- !is.na(node) node <- as.integer(node[isValid]) if (length(node) == 0) { return(NA) } if (type == "parent") { res <- lapply(node, function(x) ancestor(phy, x)) } else { ## edge matrix must be in postorder for the C function! if (phy@order=="postorder") { edge <- phy@edge } else { edge <- reorder(phy, order="postorder")@edge } ## extract edge columns ancestor <- as.integer(edge[, 1]) descendant <- as.integer(edge[, 2]) ## return indicator matrix of ALL ancestors (including self) isAnc <- .Call("ancestors_c", node, ancestor, descendant, PACKAGE = "phylobase") storage.mode(isAnc) <- "logical" ## drop self if needed if (type=="all") { isAnc[cbind(match(node, descendant), seq_along(node))] <- FALSE } res <- lapply(seq_along(node), function(n) getNode(phy, descendant[isAnc[,n]])) } names(res) <- as.character(oNode[isValid]) ## if just a single node, return as a single vector if (length(res)==1) res <- res[[1]] res ## Original pure R implementation of the above ## (note that it does not require preorder ordering) ##if (node == rootNode(phy)) ## return(NULL) ##repeat { ## anc <- ancestor(phy, node) ## res <- c(res, anc) ## node <- anc ## if (anc == n + 1) ## break ##} } phylobase/R/subset-methods.R0000644000176200001440000003773514553736417015570 0ustar liggesusers################ ## subset phylo4 ################ ##' Methods for creating subsets of phylogenies ##' ##' Methods for creating subsets of phylogenies, based on pruning a ##' tree to include or exclude a set of terminal taxa, to include all ##' descendants of the MRCA of multiple taxa, or to return a subtree ##' rooted at a given node. ##' ##' The \code{subset} methods must be called using no more than one of ##' the four main subsetting criteria arguments (\code{tips.include}, ##' \code{tips.exclude}, \code{mrca}, or \code{node.subtree}). Each ##' of these arguments can be either character or numeric. In the ##' first case, they are treated as node labels; in the second case, ##' they are treated as node numbers. For the first two arguments, ##' any supplied tips not found in the tree (\code{tipLabels(x)}) will ##' be ignored, with a warning. Similarly, for the \code{mrca} ##' argument, any supplied tips or internal nodes not found in the ##' tree will be ignored, with a warning. For the \code{node.subtree} ##' argument, failure to provide a single, valid internal node will ##' result in an error. ##' ##' Although \code{prune} is mainly intended as the workhorse function ##' called by \code{subset}, it may also be called directly. In ##' general it should be equivalent to the \code{tips.exclude} form of ##' \code{subset} (although perhaps with less up-front error ##' checking). ##' ##' The "[" operator, when used as \code{x[i]}, is similar to the ##' \code{tips.include} form of \code{subset}. However, the indices ##' used with this operator can also be logical, in which case the ##' corresponding tips are assumed to be ordered as in \code{nodeId(x, ##' "tip")}, and recycling rules will apply (just like with a vector ##' or a matrix). With a \linkS4class{phylo4d} object 'x', ##' \code{x[i,j]} creates a subset of \code{x} taking \code{i} for a ##' tip index and \code{j} for the index of data variables in ##' \code{tdata(geospiza, "all")}. Note that the second index is ##' optional: \code{x[i, TRUE]}, \code{x[i,]}, and \code{x[i]} are all ##' equivalent. ##' ##' Regardless of which approach to subsetting is used, the argument ##' values must be such that at least two tips are retained. ##' ##' If the most recent common ancestor of the retained tips is not the ##' original root node, then the root node of the subset tree will be ##' a descendant of the original root. For rooted trees with non-NA ##' root edge length, this has implications for the new root edge ##' length. In particular, the new length will be the summed edge ##' length from the new root node back to the original root (including ##' the original root edge). As an alternative, see the examples for ##' a way to determine the length of the edge that was immediately ##' ancestral to the new root node in the original tree. ##' ##' Note that the correspondance between nodes and labels (and data in ##' the case of \linkS4class{phylo4d}) will be retained after all ##' forms of subsetting. Beware, however, that the node numbers (IDs) ##' will likely be altered to reflect the new tree topology, and ##' therefore cannot be compared directly between the original tree ##' and the subset tree. ##' ##' @name subset-methods ##' @docType methods ##' @param x an object of class \code{"phylo4"} or \code{"phylo4d"} ##' @param tips.include A vector of tips to include in the subset tree ##' @param tips.exclude A vector of tips to exclude from the subset ##' tree ##' @param mrca A vector of nodes for determining the most recent ##' common ancestor, which is then used as the root of the subset tree ##' @param node.subtree A single internal node specifying the root of ##' the subset tree ##' @param trim.internal A logical specifying whether to remove ##' internal nodes that no longer have tip descendants in the subset ##' tree ##' @param i (\code{[} method) An index vector indicating tips to ##' include ##' @param j (\code{[} method, phylo4d only) An index vector ##' indicating columns of node/tip data to include ##' @param drop (not in use: for compatibility with the generic method) ##' @param \dots optional additional parameters (not in use) ##' @return an object of class \code{"phylo4"} or \code{"phylo4d"} ##' @section Methods: \describe{ \item{x = "phylo4"}{subset tree} ##' \item{x = "phylo4d"}{subset tree and corresponding node and tip ##' data} } ##' @author Jim Regetz \email{regetz@@nceas.ucsb.edu}\cr Steven Kembel ##' \email{skembel@@berkeley.edu}\cr Damien de Vienne ##' \email{damien.de-vienne@@u-psud.fr}\cr Thibaut Jombart ##' \email{jombart@@biomserv.univ-lyon1.fr} ##' @keywords methods ##' @rdname subset-methods ##' @aliases subset ##' @examples ##' data(geospiza) ##' nodeLabels(geospiza) <- paste("N", nodeId(geospiza, "internal"), sep="") ##' geotree <- extractTree(geospiza) ##' ##' ## "subset" examples ##' tips <- c("difficilis", "fortis", "fuliginosa", "fusca", "olivacea", ##' "pallida", "parvulus", "scandens") ##' plot(subset(geotree, tips.include=tips)) ##' plot(subset(geotree, tips.include=tips, trim.internal=FALSE)) ##' plot(subset(geotree, tips.exclude="scandens")) ##' plot(subset(geotree, mrca=c("scandens","fortis","pauper"))) ##' plot(subset(geotree, node.subtree=18)) ##' ##' ## "prune" examples (equivalent to subset using tips.exclude) ##' plot(prune(geotree, tips)) ##' ##' ## "[" examples (equivalent to subset using tips.include) ##' plot(geotree[c(1:6,14)]) ##' plot(geospiza[c(1:6,14)]) ##' ##' ## for phylo4d, subset both tips and data columns ##' geospiza[c(1:6,14), c("wingL", "beakD")] ##' ##' ## note handling of root edge length: ##' edgeLength(geotree)['0-15'] <- 0.1 ##' geotree2 <- geotree[1:2] ##' ## in subset tree, edge of new root extends back to the original root ##' edgeLength(geotree2)['0-3'] ##' ## edge length immediately ancestral to this node in the original tree ##' edgeLength(geotree, MRCA(geotree, tipLabels(geotree2))) ##' @exportMethod subset setGeneric("subset") ##' @rdname subset-methods ## @aliases subset,phylo4-method setMethod("subset", "phylo4", function(x, tips.include=NULL, tips.exclude=NULL, mrca=NULL, node.subtree=NULL, ...) { ## FIXME: could eliminate NULL and make the test ## if (!missing) rather than if (!is.null) ## (might have to change next line?) if (sum(!sapply(list(tips.include, tips.exclude, mrca, node.subtree), is.null))>1) { stop("must specify at most one criterion for subsetting") } all.tips <- nodeId(x, "tip") if (!is.null(tips.include)) { nodes <- getNode(x, tips.include, missing="OK") is.valid.tip <- nodes %in% all.tips kept <- nodes[is.valid.tip] dropped <- setdiff(all.tips, kept) unknown <- tips.include[!is.valid.tip] } else if (!is.null(tips.exclude)) { nodes <- getNode(x, tips.exclude, missing="OK") is.valid.tip <- nodes %in% all.tips dropped <- nodes[is.valid.tip] kept <- setdiff(all.tips, dropped) unknown <- tips.exclude[!is.valid.tip] } else if (!is.null(mrca)) { nodes <- getNode(x, mrca, missing="OK") is.valid.node <- nodes %in% nodeId(x, "all") mnode <- MRCA(x, nodes[is.valid.node]) if (length(mnode)!=1) { stop("mrca must include at least one valid node") } kept <- descendants(x, mnode) dropped <- setdiff(all.tips, kept) unknown <- mrca[!is.valid.node] } else if (!is.null(node.subtree)) { node <- getNode(x, node.subtree, missing="OK") if (length(node)!=1 || !(node %in% nodeId(x, "internal"))) { stop("node.subtree must be a single valid internal node") } kept <- descendants(x, node) dropped <- setdiff(all.tips, kept) unknown <- numeric(0) } else { kept <- getNode(x, nodeId(x, "tip")) dropped <- numeric(0) unknown <- numeric(0) } if (length(unknown)>0) { warning("invalid nodes ignored: ", paste(unknown, collapse=", ")) } if (length(kept)<2) { stop("0 or 1 tips would remain after subsetting") } if (length(dropped)==0) return(x) return(prune(x, dropped, ...)) }) ############### # '[' operator ############### ## Consider using some combination of these for stricter argument ## checking? Not implementing now because extra arguments are just ## ignored, which is fairly common S4 method behavior: ## * in "[" methods for phylo4: ## if (nargs()>2) stop("unused arguments") ## * in "[" methods for both phylo4 and phylo4d: ## if (!missing(...)) stop("unused argument(s)") ##' @rdname subset-methods ##' @exportMethod "[" ##' @export setGeneric("[") ##### -------- phylo4 '[' methods ##' @rdname subset-methods ## @aliases [,phylo4,character,missing-method setMethod("[", signature(x="phylo4", i="character", j="missing", drop="missing"), function(x, i, j, ..., drop) { subset(x, tips.include=i) }) ##' @rdname subset-methods ## @aliases [,phylo4,numeric,missing-method setMethod("[", signature(x="phylo4", i="numeric", j="missing", drop="missing"), function(x, i, j, ..., drop) { subset(x, tips.include=i) }) ##' @rdname subset-methods ## @aliases [,phylo4,logical,missing-method setMethod("[", signature(x="phylo4", i="logical", j="missing", drop="missing"), function(x, i, j, ..., drop) { subset(x, tips.include=nodeId(x, "tip")[i]) }) ##' @rdname subset-methods ## @aliases [,phylo4,missing,missing-method setMethod("[", signature(x="phylo4", i="missing", j="missing", drop="missing"), function(x, i, j, ..., drop) { return(x) }) ##### -------- phylo4d '[' methods ##' @rdname subset-methods ## @aliases [,phylo4d,ANY,character,missing-method setMethod("[", signature(x="phylo4d", i="ANY", j="character", drop="missing"), function(x, i, j, ..., drop) { if (!missing(i)) x <- x[i] tdata(x, type="all") <- tdata(x, type="all")[j] return(x) }) ##' @rdname subset-methods ## @aliases [,phylo4d,ANY,numeric,missing-method setMethod("[", signature(x="phylo4d", i="ANY", j="numeric", drop="missing"), function(x, i, j, ..., drop) { if (!missing(i)) x <- x[i] tdata(x, type="all") <- tdata(x, type="all")[j] return(x) }) ##' @rdname subset-methods ## @aliases [,phylo4d,ANY,logical,missing-method setMethod("[", signature(x="phylo4d", i="ANY", j="logical", drop="missing"), function(x, i, j, ..., drop) { if (!missing(i)) x <- x[i] tdata(x, type="all") <- tdata(x, type="all")[j] return(x) }) ## borrow from Matrix package approach of trapping invalid usage ##' @rdname subset-methods ## @aliases [,phylo4,ANY,ANY,ANY-method setMethod("[", signature(x="phylo4", i="ANY", j="ANY", drop="ANY"), function(x, i, j, ..., drop) { stop("invalid argument(s)") }) ##### -------- prune ##' @rdname subset-methods ## @aliases prune ##' @export setGeneric("prune", function(x, ...) { standardGeneric("prune") }) ## return characters, sorted in NUMERIC order .chnumsort <- function(x) { as.character(sort(as.numeric(x))) } ##' @rdname subset-methods ## @aliases prune,phylo4-method setMethod("prune", "phylo4", function(x, tips.exclude, trim.internal=TRUE) { makeEdgeNames <- function(edge) { paste(edge[,1], edge[,2], sep="-") } ## drop tips and obsolete internal nodes from edge matrix tip.drop <- getNode(x, tips.exclude, missing="fail") tip.keep <- setdiff(nodeId(x, "tip"), tip.drop) nodes <- nodeId(x, "all") node.keep <- rep(FALSE, length(nodes)) node.keep[tip.keep] <- TRUE if (trim.internal) { if (edgeOrder(x) == "postorder") { edge.post <- edges(x) } else { edge.post <- edges(reorder(x, "postorder")) } for (i in seq_along(edge.post[,2])) { if (node.keep[edge.post[i,2]]) { node.keep[edge.post[i,1]] <- TRUE } } } else { node.keep[nodeId(x, "internal")] <- TRUE } edge.new <- edges(x)[edges(x)[,2] %in% nodes[node.keep], ] ## remove singletons edge.length.new <- edgeLength(x) edge.label.new <- edgeLabels(x) singletons <- which(tabulate(edge.new[edge.new[, 1] != 0, 1])==1) while (length(singletons)>0) { sing.node <- singletons[1] ## update edge matrix edges.drop <- which(edge.new==sing.node, arr.ind=TRUE)[,"row"] sing.edges <- edge.new[edges.drop,] edge.new[edges.drop[2], ] <- c(sing.edges[2,1], sing.edges[1,2]) edge.new <- edge.new[-edges.drop[1], ] ## update edge lengths and edge labels edge.names.drop <- makeEdgeNames(sing.edges) edge.name.new <- paste(sing.edges[2,1], sing.edges[1,2], sep="-") edge.length.new[edge.name.new] <- sum(edge.length.new[edge.names.drop]) edge.length.new <- edge.length.new[-match(edge.names.drop, names(edge.length.new))] edge.label.new[edge.name.new] <- NA edge.label.new <- edge.label.new[-match(edge.names.drop, names(edge.label.new))] singletons <- which(tabulate(edge.new[edge.new[, 1] != 0, 1])==1) } ## remove dropped elements from labels label.new <- labels(x)[names(labels(x)) %in% edge.new] ## subset and order edge.length and edge.label with respect to edge edge.names <- makeEdgeNames(edge.new) edge.length.new <- edge.length.new[edge.names] edge.label.new <- edge.label.new[edge.names] if (!trim.internal) { ## make sure now-terminal internal nodes are treated as tips tip.now <- setdiff(edge.new[,2], edge.new[,1]) tip.add <- tip.now[tip.now>nTips(x)] if (length(tip.add)>0) { ind <- match(tip.add, names(label.new)) ## node renumbering workaround to satisfy plot method newid <- sapply(tip.add, function(tip) descendants(x, tip)[1]) names(label.new)[ind] <- newid edge.new[match(tip.add, edge.new)] <- newid tip.now[match(tip.add, tip.now)] <- newid isTip <- edge.new %in% tip.now edge.new[isTip] <- match(edge.new[isTip], sort(unique.default(edge.new[isTip]))) } } ## renumber nodes in the edge matrix edge.new[] <- match(edge.new, sort(unique.default(edge.new))) - 1L ## update corresponding element names in the other slots edge.names <- makeEdgeNames(edge.new) names(edge.length.new) <- edge.names names(edge.label.new) <- edge.names label.new <- label.new[order(as.numeric(names(label.new)))] names(label.new) <- seq_along(label.new) ## update, check, then return the pruned phylo4 object x@edge <- edge.new ##TODO would prefer to leave out NA from edge.length slot, but can't x@edge.length <- edge.length.new x@edge.label <- edge.label.new[!is.na(edge.label.new)] x@label <- label.new[!is.na(label.new)] if(is.character(checkval <- checkPhylo4(x))) { stop(checkval) } else { return(x) } }) ##' @rdname subset-methods ## @aliases prune,phylo4d-method setMethod("prune", "phylo4d", function(x, tips.exclude, trim.internal=TRUE) { tree <- extractTree(x) phytr <- prune(tree, tips.exclude, trim.internal) ## create temporary phylo4 object with complete and unique labels tmpLbl <- .genlab("n", nTips(x)+nNodes(x)) tmpPhy <- tree labels(tmpPhy, "all") <- tmpLbl tmpPhytr <- prune(tmpPhy, getNode(x, tips.exclude), trim.internal) ## get node numbers to keep oldLbl <- labels(tmpPhy, "all") newLbl <- labels(tmpPhytr, "all") wasKept <- oldLbl %in% newLbl nodesToKeep <- as.numeric(names(oldLbl[wasKept])) ## subset original data, and update names allDt <- x@data[match(nodesToKeep, rownames(x@data)), , drop=FALSE] rownames(allDt) <- match(newLbl, oldLbl[wasKept]) phytr <- phylo4d(phytr, all.data=allDt, match.data=TRUE) phytr }) ## setMethod("prune","ANY", ## function(phy, tip, trim.internal = TRUE, subtree = FALSE, ## ,...) { ## if (class(phy)=="phylo") { ## ape::prune(phy, tip, trim.internal, subtree) ## } else stop("no prune method available for", ## deparse(substitute(phy)), ## "(class",class(phy),")") ## }) phylobase/R/root-methods.R0000644000176200001440000000320114553646170015217 0ustar liggesusers ##' Methods to test, access (and modify) the root of a phylo4 object. ##' ##' @rdname root-methods ##' @aliases isRooted ##' @docType methods ##' @param x a \code{phylo4} or \code{phylo4d} object. ##' @param value a character string or a numeric giving the new root. ##' @return \describe{ ##' \item{isRooted}{logical whether the tree is rooted} ##' \item{rootNode}{the node corresponding to the root} ##' } ##' @include phylo4-class.R phylo4-methods.R phylo4-accessors.R ##' @export ##' @author Ben Bolker, Francois Michonneau ##' @examples ##' data(geospiza) ##' isRooted(geospiza) ##' rootNode(geospiza) setGeneric("isRooted", function(x) { standardGeneric("isRooted") }) ##' @rdname root-methods ##' @aliases isRooted,phylo4-method setMethod("isRooted", signature(x="phylo4"), function(x) { ## hack to avoid failure on an empty object if(nTips(x) == 0) return(FALSE) any(edges(x)[, 1] == 0) }) ##' @rdname root-methods ##' @aliases rootNode ##' @export setGeneric("rootNode", function(x) { standardGeneric("rootNode") }) ##' @rdname root-methods ##' @aliases rootNode,phylo4-method setMethod("rootNode", signature(x="phylo4"), function(x) { if (!isRooted(x)) return(NA) rootnd <- unname(edges(x)[which(edges(x)[, 1] == 0), 2]) getNode(x, rootnd) }) ##' @rdname root-methods ##' @aliases rootNode<- ##' @export setGeneric("rootNode<-", function(x, value) { standardGeneric("rootNode<-") }) ##' @name rootNode<- ##' @rdname root-methods ##' @aliases rootNode<-,phylo4-method setReplaceMethod("rootNode", signature(x="phylo4"), function(x, value) { stop("Root node replacement not implemented yet") }) phylobase/R/readNCL.R0000644000176200001440000004216014553646170014052 0ustar liggesusers### This file contains the source code for the functions: ### - readNCL (generic function) ### - readNexus (wrapper for readNCL importing Nexus files) ### - readNewick (wrapper for readNCL importing Newick files) ##' Create a \code{phylo4}, \code{phylo4d} or \code{data.frame} object ##' from a NEXUS or a Newick file ##' ##' \code{readNexus} reads a NEXUS file and outputs a \code{phylo4}, ##' \code{phylo4d} or \code{data.frame} object. ##' ##' \code{readNewick} reads a Newick file and outputs a \code{phylo4} ##' or \code{phylo4d} object. ##' ##' \code{readNexus} is used internally by both \code{readNexus} and ##' \code{readNewick} to extract data held in a tree files, ##' specifically in NEXUS files from DATA, CHARACTER or TREES ##' blocks. ##' ##' The \code{type} argument specifies which of these is returned: ##' ##' \describe{ ##' ##' \item{data}{will only return a \code{data.frame} of the contents ##' of all DATA and CHARACTER blocks.} ##' ##' \item{tree}{will only return a \code{phylo4} object of the ##' contents of the TREES block.} ##' ##' \item{all}{if only data or a tree are present in the file, this ##' option will act as the options above, returning either a ##' \code{data.frame} or a \code{phylo4} object respectively. If both ##' are present then a \code{phylo4d} object is returned containing ##' both.} ##' ##' } ##' ##' The function returns \code{NULL} if the \code{type} of ##' data requested is not present in the file, or if neither data nor ##' tree blocks are present. ##' ##' Depending on the context \code{readNexus} will call either the ##' \code{phylo4} or \code{phylo4d} constructor. The \code{phylo4d} ##' constructor will be used with \code{type="all"}, or if the option ##' \code{check.node.labels="asdata"} is invoked. ##' ##' \code{readNewick} imports Newick formatted tree files and will ##' return a \code{phylo4} or a \code{phylo4d} object if the option ##' \code{check.node.labels="asdata"} is invoked. ##' ##' For both \code{readNexus} and \code{readNewick}, the options for ##' \code{check.node.labels} can take the values: ##' ##' \describe{ ##' ##' \item{keep}{the node labels of the trees will be passed as node ##' labels in the \code{phylo4} object} ##' ##' \item{drop}{the node labels of the trees will be ignored in the ##' \code{phylo4} object} ##' ##' \item{asdata}{the node labels will be passed as data and a ##' \code{phylo4d} object will be returned.} ##' ##' } ##' ##' If you use the option \code{asdata} on a file with no node labels, ##' a warning message is issued, and is thus equivalent to the value ##' \code{drop}. ##' ##' For both \code{readNexus} and \code{readNewick}, additional ##' arguments can be passed to the constructors such as \code{annote}, ##' \code{missing.data} or \code{extra.data}. See the \sQuote{Details} ##' section of \code{\link{phylo4d-methods}} for the complete list of ##' options. ##' ##' @name Import Nexus and Newick files ##' @docType methods ##' @param file a NEXUS file for \code{readNexus} or a file that ##' contains Newick formatted trees for \code{readNewick}. ##' @param simplify If TRUE, if there are multiple trees in the file, ##' only the first one is returned; otherwise a list of ##' \code{phylo4(d)} objects is returned if the file contains multiple ##' trees. ##' @param type Determines which type of objects to return, if present ##' in the file (see Details). ##' @param spacesAsUnderscores In the NEXUS file format white spaces ##' are not allowed in taxa labels and are represented by ##' underscores. Therefore, NCL converts underscores found in taxa ##' labels in the NEXUS file into white spaces ##' (e.g. \code{species_1} will become \code{"species 1"}. If you ##' want to preserve the underscores, set as TRUE, the default). ##' @param char.all If \code{TRUE}, returns all characters, even those ##' excluded in the NEXUS file ##' @param polymorphic.convert If \code{TRUE}, converts polymorphic ##' characters to missing data ##' @param levels.uniform If \code{TRUE}, uses the same levels for all ##' characters ##' @param quiet If \code{FALSE} the output of the NCL interface is ##' printed. This is mainly for debugging purposes. This option ##' can considerably slow down the process if the tree is big or ##' there are many trees in the file. ##' @param check.node.labels Determines how the node labels in the ##' NEXUS or Newick files should be treated in the phylo4 object, ##' see Details for more information. ##' @param return.labels Determines whether state names (if ##' \code{TRUE}) or state codes should be returned. ##' @param file.format character indicating the format of the ##' specified file (either \dQuote{\code{newick}} or ##' \dQuote{\code{nexus}}). It's more convenient to just use ##' \code{readNexus} or \code{readNewick}. ##' @param check.names logical. If \sQuote{TRUE} then the names of the ##' characters from the NEXUS file are checked to ensure that they ##' are syntactically valid variable names and are not duplicated. ##' If necessary they are adjusted using \sQuote{make.names}. ##' @param convert.edge.length logical. If \code{TRUE} negative edge ##' lengths are replaced with 0. At this time \code{phylobase} ##' does not accept objects with negative branch lengths, this ##' workaround allows to import trees with negative branch ##' lengths. ##' @param \dots Additional arguments to be passed to phylo4 or ##' phylo4d constructor (see Details) ##' @return Depending on the value of \code{type} and the contents of ##' the file, one of: a \code{data.frame}, a \linkS4class{phylo4} ##' object, a \linkS4class{phylo4d} object or \code{NULL}. If ##' several trees are included in the NEXUS file and the option ##' \code{simplify=FALSE} a list of \linkS4class{phylo4} or ##' \linkS4class{phylo4d} objects is returned. ##' @note Underscores in state labels (i.e. trait or taxon names) will ##' be translated to spaces. Unless \code{check.names=FALSE}, trait ##' names will be converted to valid R names (see ##' \code{\link{make.names}}) on input to R, so spaces will be ##' translated to periods. ##' @author Brian O'Meara, Francois Michonneau, Derrick Zwickl ##' @seealso the \linkS4class{phylo4d} class, the \linkS4class{phylo4} ##' class ##' @export ##' @rdname readNexus ##' @aliases readNCL ##' @keywords misc readNCL <- function(file, simplify=FALSE, type=c("all", "tree","data"), spacesAsUnderscores = TRUE, char.all=FALSE, polymorphic.convert=TRUE, levels.uniform=FALSE, quiet=TRUE, check.node.labels=c("keep", "drop", "asdata"), return.labels=TRUE, file.format=c("nexus", "newick"), check.names=TRUE, convert.edge.length=FALSE, ...) { type <- match.arg(type) file.format <- match.arg(file.format) check.node.labels <- match.arg(check.node.labels) if (type == "all" || type == "data") { returnData <- TRUE } else { returnData <- FALSE } if (type == "all" || type == "tree") { returnTrees <- TRUE } else { returnTrees <- FALSE } ## GetNCL returns a list containing: ## $taxaNames: names of the taxa (from taxa block, implied or declared) ## $treeNames: the names of the trees ## $trees: a vector of (untranslated) Newick strings ## $dataTypes: data type for each character block of the nexus file (length = number of chr blocks) ## $nbCharacters: number of characters in each block (length = number of chr blocks) ## $charLabels: the labels for the characters, i.e. the headers of the data frame to be returned ## (length = number of chr blocks * sum of number of characters in each block) ## $nbStates: the number of states of each character (equals 0 for non-standard types, length = number ## of characters) ## $stateLabels: the labels for the states of the characters, i.e. the levels of the factors to be returned ## $dataChr: string that contains the data to be returned ncl <- rncl::rncl(file = file, file.format = file.format, spacesAsUnderscores = spacesAsUnderscores, char.all = char.all, polymorphic.convert = polymorphic.convert, levels.uniform = levels.uniform) ## Return Error message if (length(ncl) == 1 && names(ncl) == "ErrorMsg") { stop(ncl$ErrorMsg) } if (!quiet) message(ncl) ## Disclaimer if (!length(grep("\\{", ncl$dataChr)) && return.labels && !polymorphic.convert) { stop("At this stage, it's not possible to use the combination: ", "return.labels=TRUE and polymorphic.convert=FALSE for datasets ", "that contain polymorphic characters.") } if (returnData && length(ncl$dataChr)) { tipData <- vector("list", length(ncl$dataChr)) for (iBlock in 1:length(ncl$dataTypes)) { chrCounter <- ifelse(iBlock == 1, 0, sum(ncl$nbCharacters[1:(iBlock-1)])) if (ncl$dataTypes[iBlock] == "Continuous") { for (iChar in 1:ncl$nbCharacters[iBlock]) { i <- chrCounter + iChar tipData[[i]] <- eval(parse(text=ncl$dataChr[i])) names(tipData)[i] <- ncl$charLabels[i] } } else { if (ncl$dataTypes[iBlock] == "Standard") { iForBlock <- integer(0) for (iChar in 1:ncl$nbCharacters[iBlock]) { i <- chrCounter + iChar iForBlock <- c(iForBlock, i) lblCounterMin <- ifelse(i == 1, 1, sum(ncl$nbStates[1:(i-1)]) + 1) lblCounter <- seq(lblCounterMin, length.out=ncl$nbStates[i]) tipData[[i]] <- eval(parse(text=ncl$dataChr[i])) names(tipData)[i] <- ncl$charLabels[i] tipData[[i]] <- as.factor(tipData[[i]]) lbl <- ncl$stateLabels[lblCounter] if (return.labels) { if (any(nchar(gsub("\\s|_", "", lbl)) == 0)) { warning("state labels are missing for \'", ncl$charLabels[i], "\', the option return.labels is thus ignored.") } else { levels(tipData[[i]]) <- lbl } } } if (levels.uniform) { allLevels <- character(0) for (j in iForBlock) { allLevels <- union(allLevels, levels(tipData[[j]])) } for (j in iForBlock) { levels(tipData[[j]]) <- allLevels } } } else { warning("This datatype is not currently supported by phylobase") next ## FIXME: different datatypes in a same file isn't going to work } } } tipData <- data.frame(tipData, check.names=check.names) if (length(ncl$taxaNames) == nrow(tipData)) { rownames(tipData) <- ncl$taxaNames } else stop("phylobase doesn't deal with multiple taxa block at this time.") } else { tipData <- NULL } if (returnTrees && length(ncl$trees) > 0) { listTrees <- vector("list", length(ncl$trees)) for (i in 1:length(ncl$trees)) { isRooted <- is_rooted(ncl$parentVector[[i]]) edgeMat <- get_edge_matrix(ncl$parentVector[[i]], isRooted) edgeLgth <- get_edge_length(ncl$branchLengthVector[[i]], ncl$parentVector[[i]], isRooted) tipLbl <- ncl$taxonLabelVector[[i]] if (convert.edge.length) { edgeLgth[edgeLgth < 0] <- 0 } if (check.node.labels == "asdata" && !has_node_labels(ncl$nodeLabelsVector[[i]])) { warning("Could not use value \"asdata\" for ", "check.node.labels because there are no ", "labels associated with the tree") check.node.labels <- "drop" } if (has_node_labels(ncl$nodeLabelsVector[[i]]) && !identical(check.node.labels, "drop")) { nodeLbl <- ncl$nodeLabelsVector[[i]] rootNd <- attr(edgeMat, "root") nodeLbl[rootNd] <- nodeLbl[1] node_pos <- (length(tipLbl)+1):length(nodeLbl) nodeLbl <- nodeLbl[node_pos] if (identical(check.node.labels, "asdata")) { tr <- phylo4(x = edgeMat, edge.length = edgeLgth, tip.label = tipLbl) nodeDt <- label_to_data(nodeLbl, row.names = node_pos) tr <- phylo4d(tr, node.data = nodeDt) } else { tr <- phylo4(x = edgeMat, edge.length = edgeLgth, tip.label = tipLbl, node.label = nodeLbl) } } else { tr <- phylo4(x = edgeMat, edge.length = edgeLgth, tip.label = tipLbl) } listTrees[[i]] <- tr if (simplify) break } if (length(listTrees) == 1 || simplify) listTrees <- listTrees[[1]] } else { listTrees <- NULL } ### switch(type, "data" = { if (is.null(tipData)) { toRet <- NULL } else { toRet <- tipData } }, "tree" = { if (is.null(listTrees)) { toRet <- NULL } else { toRet <- listTrees } }, "all" = { if (is.null(tipData) && is.null(listTrees)) { toRet <- NULL } else if (is.null(tipData)) { toRet <- listTrees } else if (is.null(listTrees)) { toRet <- tipData } else { if (length(listTrees) > 1) { toRet <- lapply(listTrees, function(tr) addData(tr, tip.data=tipData, ...)) } else toRet <- addData(listTrees, tip.data=tipData, ...) } }) toRet } ## check if the implicit root is dichotomous is_rooted <- function(parentVector) { tab_edg <- table(parentVector) if (tabulate(parentVector)[which(parentVector == 0)] > 2) FALSE else TRUE } ## Returns the edge matrix from the parentVector (the i^th element is ## the descendant element of node i) get_edge_matrix <- function(parentVector, isRooted) { edgeMat <- cbind(ancestor = parentVector, descendant = 1:length(parentVector)) rootNd <- edgeMat[which(edgeMat[, 1] == 0), 2] if (!isRooted) { edgeMat <- edgeMat[-which(edgeMat[, 1] == 0), ] } attr(edgeMat, "root") <- rootNd edgeMat } ## Returns the edge lengths (missing are represented by -999) get_edge_length <- function(branchLengthVector, parentVector, isRooted) { edgeLgth <- branchLengthVector if (isRooted) { edgeLgth[which(parentVector == 0)] <- NA } else { edgeLgth <- edgeLgth[which(parentVector != 0)] } edgeLgth[edgeLgth == -999] <- NA edgeLgth } ## Tests whether there are node labels has_node_labels <- function(nodeLabelsVector) { any(nzchar(nodeLabelsVector)) } ##' @rdname readNexus ##' @aliases readNexus ##' @export readNexus <- function (file, simplify=FALSE, type=c("all", "tree", "data"), char.all=FALSE, polymorphic.convert=TRUE, levels.uniform=FALSE, quiet=TRUE, check.node.labels=c("keep", "drop", "asdata"), return.labels=TRUE, check.names=TRUE, convert.edge.length=FALSE, ...) { return(readNCL(file=file, simplify=simplify, type=type, char.all=char.all, polymorphic.convert=polymorphic.convert, levels.uniform=levels.uniform, quiet=quiet, check.node.labels=check.node.labels, return.labels=return.labels, file.format="nexus", check.names=check.names, convert.edge.length=convert.edge.length, ...)) } ##' @rdname readNexus ##' @aliases readNewick ##' @export readNewick <- function(file, simplify=FALSE, quiet=TRUE, check.node.labels=c("keep", "drop", "asdata"), convert.edge.length=FALSE, ...) { return(readNCL(file=file, simplify=simplify, quiet=quiet, check.node.labels=check.node.labels, file.format="newick", convert.edge.length=convert.edge.length, ...)) } phylobase/R/multiphylo4-class.R0000644000176200001440000000325514553646170016201 0ustar liggesusers## classes for holding multiple tree objects ##' multiPhylo4 and extended classes ##' ##' Classes for lists of phylogenetic trees. These classes and methods are ##' planned for a future version of \code{phylobase}. ##' ##' ##' @name multiPhylo-class ##' @aliases multiPhylo-class multiPhylo4-class multiPhylo4d-class tbind ##' @docType class ##' @keywords classes ## @export setClass("multiPhylo4", representation(phylolist = "list", tree.names = "character"), prototype = list(phylolist = list(), tree.names = character(0))) setClass("multiPhylo4d", representation(tip.data = "data.frame"), contains = "multiPhylo4") setMethod("initialize", "multiPhylo4", function(.Object, ...) { message("multiPhylo and multiphylo4d not yet implemented", "Try using a list of phylo4(d) objects and lapply().") }) ##' multiPhylo4 and extended classes ##' ##' Classes for lists of phylogenetic trees. These classes and methods are ##' planned for a future version of \code{phylobase}. ##' ##' ##' @name multiPhylo-class ##' @aliases multiPhylo-class multiPhylo4-class multiPhylo4d-class tbind ##' @docType class ##' @keywords classes setAs("multiPhylo", "multiPhylo4", function(from, to) { trNm <- names(from) if(is.null(trNm)) trNm <- character(0) newobj <- new("multiPhylo4", phylolist = lapply(from, function(x) as(x, "phylo4")), tree.names = trNm) newobj }) setAs("multiPhylo4", "multiPhylo", function(from, to) { y <- lapply(from@phylolist, function(x) as(x, "phylo")) names(y) <- from@tree.names if (hasTipData(from)) warning("discarded tip data") class(y) <- "multiPhylo" y }) phylobase/R/shortestPath-methods.R0000644000176200001440000000445214553646170016735 0ustar liggesusers .shortestPathInt <- function(phy, node1, node2){ ## some checks ## if (is.character(checkval <- checkPhylo4(x))) stop(checkval) # no need t1 <- getNode(phy, node1) t2 <- getNode(phy, node2) if(any(is.na(c(t1,t2)))) stop("wrong node specified") if(t1==t2) return(NULL) ## main computations comAnc <- MRCA(phy, t1, t2) # common ancestor desComAnc <- descendants(phy, comAnc, type="all") ancT1 <- ancestors(phy, t1, type="all") path1 <- intersect(desComAnc, ancT1) # path: common anc -> t1 ancT2 <- ancestors(phy, t2, type="all") path2 <- intersect(desComAnc, ancT2) # path: common anc -> t2 res <- union(path1, path2) # union of the path ## add the common ancestor if it differs from t1 or t2 if(!comAnc %in% c(t1,t2)){ res <- c(comAnc,res) } res <- getNode(phy, res) return(res) } ##' Finds the shortest path between two nodes in a tree ##' ##' Given two nodes (i.e, tips or internal nodes), this function ##' returns the shortest path between them (excluding \code{node1} and ##' \code{node2} as a vector of nodes. ##' @title shortestPath-methods ##' @param x a tree in the phylo4, phylo4d or phylo format ##' @param node1 a numeric or character (passed to \code{getNode}) ##' indicating the beginning from which the path should be calculated. ##' @param node2 a numeric or character (passed to \code{getNode}) ##' indicating the end of the path. ##' @return a vector of nodes indcating the shortest path between 2 nodes ##' @seealso getNode ##' @rdname shortestPath-methods ##' @docType methods ##' @include MRCA-methods.R ##' @export setGeneric("shortestPath", function(x, node1, node2) { standardGeneric("shortestPath") }) ##' @name shortestPath-phylo4 ##' @rdname shortestPath-methods ##' @aliases shortestPath,phylo4-method setMethod("shortestPath", signature(x="phylo4", node1="ANY", node2="ANY"), function(x, node1, node2) { .shortestPathInt(phy=x, node1=node1, node2=node2) }) ##' @name shortestPath-phylo ##' @rdname shortestPath-methods ##' @aliases shortestPath,phylo-method setMethod("shortestPath", signature(x="phylo", node1="ANY", node2="ANY"), function(x, node1, node2) { phy <- as(x, "phylo4") .shortestPathInt(phy=phy, node1=node1, node2=node2) }) phylobase/R/reorder-methods.R0000644000176200001440000001324314553646170015705 0ustar liggesusers ######################################################### ### Ordering ######################################################### ##' reordering trees within phylobase objects ##' ##' Methods for reordering trees into various traversal orders ##' ##' The \code{reorder} method takes a \code{phylo4} or \code{phylo4d} ##' tree and orders the edge matrix (i.e. \code{edges(x)}) in the ##' requested traversal order. Currently only two orderings are ##' permitted, and both require rooted trees. In \code{postorder}, a ##' node's descendants come before that node, thus the root, which is ##' ancestral to all nodes, comes last. In \code{preorder}, a node is ##' visited before its descendants, thus the root comes first. ##' ##' @name reorder-methods ##' @docType methods ##' @param x a \code{phylo4} or \code{phylo4d} object ##' @param order The desired traversal order; currently only ##' \dQuote{preorder} and \dQuote{postorder} are allowed for ##' \code{phylo4} and \code{phylo4d} objects. ##' @param \dots additional optional elements (not in use) ##' @return A \code{phylo4} or \code{phylo4d} object with the edge, ##' label, length and data slots ordered as \code{order}, which is ##' itself recorded in the order slot. ##' @note The \code{preorder} parameter corresponds to ##' \code{cladewise} in the \code{ape} package, and \code{postorder} ##' corresponds (almost) to \code{pruningwise}. ##' ##' @author Peter Cowan, Jim Regetz ##' @seealso \code{\link[ape]{reorder.phylo}} in the \code{ape} package. ##' \code{\link{ancestors}} \code{\link{ancestor}} \code{\link{siblings}} ##' \code{\link{children}} \code{\link{descendants}} ##' @keywords methods ##' @include phylo4-class.R ##' @include phylo4-methods.R ##' @exportMethod reorder ##' @aliases reorder ##' @examples ##' phy <- phylo4(ape::rtree(5)) ##' edges(reorder(phy, "preorder")) ##' edges(reorder(phy, "postorder")) setGeneric("reorder") ##' @rdname reorder-methods ##' @aliases reorder,phylo4-method setMethod("reorder", signature(x="phylo4"), function(x, order=c("preorder", "postorder")) { ## call orderIndex and use that index to order edges, labels and lengths order <- match.arg(order) index <- orderIndex(x, order) x@order <- order x@edge <- edges(x)[index, ] if(hasEdgeLabels(x)) { x@edge.label <- x@edge.label[index] } if(hasEdgeLength(x)) { x@edge.length <- x@edge.length[index] } x }) ## non exported function orderIndex <- function(x, order=c("preorder", "postorder")) { order <- match.arg(order) if(!isRooted(x)){ stop("Tree must be rooted to reorder") } ## get a root node free edge matrix edge <- edges(x, drop.root=TRUE) ## Sort edges -- ensures that starting order of edge matrix doesn't ## affect the order of reordered trees edge <- edge[order(edge[, 2]), ] # recast order argument as integer to pass to C if(order == 'postorder') { iOrder <- 0L } else if(order == 'preorder') { iOrder <- 1L } else {stop(paste("Method for", order, "not implemented"))} if (!hasPoly(x) & !hasSingle(x)) { # method 1: faster, but only works if all internal nodes have # exactly two children (true binary tree) # extract nodes, separating descendants into left (first # encountered) and right (second encountered) for each ancestor isFirst <- !duplicated(edge[, 1]) ancestor <- as.integer(edge[isFirst, 1]) left <- as.integer(edge[isFirst, 2]) right <- as.integer(edge[!isFirst, 2])[match(ancestor, edge[!isFirst, 1])] descendantNew <- rep(0L, nEdges(x)) root <- as.integer(rootNode(x)) nEdge <- as.integer(length(ancestor)) descendantReord <- .C("reorderBinary", descendantNew, root, ancestor, left, right, nEdge, iOrder, PACKAGE = "phylobase")[[1]] } else { ## method 2: not as fast, but robust to singletons and polytomies ## extract ancestors and descendants ancestor <- as.integer(edge[,1]) descendant <- as.integer(edge[,2]) descendantNew <- rep(0L, nEdges(x)) root <- as.integer(rootNode(x)) nEdge <- as.integer(nrow(edge)) descendantReord <- .C("reorderRobust", descendantNew, root, ancestor, descendant, nEdge, iOrder, PACKAGE = "phylobase")[[1]] } ## Original pure R implementation of the above: #### recursive functions are placed first and calls to those functions below ##postOrder <- function(node) { ## ## this function returns a vector of nodes in the post order traversal ## ## get the descendants ## traversal <- NULL ## ## edge -- defined above, outside this function ## ## extensive testing found this loop to be faster than apply() etc. ## for(i in edge[edge[, 1] == node, 2]) { ## traversal <- c(traversal, postOrder(i)) ## } ## c(traversal, node) ##} ##preOrder <- function(node) { ## ## see expanded code in comments of postOrder() ## ## only difference here is that we record current node, then descendants ## traversal <- NULL ## for(i in edge[edge[, 1] == node, 2]) { ## traversal <- c(traversal, preOrder(i)) ## } ## c(node, traversal) ##} ##if(order == 'postorder') { ## descendantReord <- postOrder(rootNode(x)) ##} else if(order == 'preorder') { ## descendantReord <- preOrder(rootNode(x)) ##} else {stop(paste("Method for", order, "not implemented"))} ## match the new node order to the old order to get an index index <- match(descendantReord, edges(x)[, 2]) } phylobase/R/internal-constructors.R0000644000176200001440000000510114553646170017156 0ustar liggesusers ##################### ## Labels constructor ##################### ## (formerly) recursive function to have labels of constant length ## base = a character string ## n = number of labels .genlab <- function(base, n) { if(n <= 0) return("") s <- seq(length.out=n) fw <- max(nchar(as.character(s))) numstr <- formatC(s, flag="0", width=fw) paste(base, numstr, sep="") } .createLabels <- function(value, ntips, nnodes, use.names = TRUE, type = c("all", "tip", "internal")) { type <- match.arg(type) ## set up final length of object to return lgthRes <- switch(type, tip=ntips, internal=nnodes, all=ntips+nnodes) ## create NA character vector of node labels res <- character(lgthRes) is.na(res) <- TRUE ## create internal names names(res) <- switch(type, tip = 1:ntips, internal = seq(from=ntips+1, length.out=lgthRes), all = 1:(ntips+nnodes)) ## Convert empty labels to NA value[!nzchar(value)] <- NA ## if no values are provided if(missing(value) || is.null(value) || all(is.na(value))) { ## tip labels can't be NULL if(!identical(type, "internal")) { tipLbl <- .genlab("T", ntips) res[1:ntips] <- tipLbl } } ## if labels are provided else { ## check that lengths match if(length(value) != lgthRes) stop("Number of labels does not match number of nodes.") ## check if vector 'value' has name, and if so match with node.label names if(use.names && !is.null(names(value))) { if(!all(names(value) %in% names(res))) stop("Names provided don't match internal labels names.") res[match(names(value), names(res))] <- value } else res[1:lgthRes] <- value } res } .createEdge <- function(value, edgeMat, type=c("lengths", "labels"), use.names=TRUE) { type <- match.arg(type) lgthRes <- nrow(edgeMat) res <- switch(type, lengths=numeric(lgthRes), labels=character(lgthRes)) is.na(res) <- TRUE names(res) <- paste(edgeMat[,1], edgeMat[,2], sep="-") if(!(missing(value) || is.null(value) || all(is.na(value)))) { if(use.names && !is.null(names(value))) { if(!all(names(value) %in% names(res))) stop("Names provided don't match internal edge labels names.") res[match(names(value), names(res))] <- value } else res[1:lgthRes] <- value } res } phylobase/R/tdata-methods.R0000644000176200001440000001663414553646170015347 0ustar liggesusers##' Retrieving or updating tip and node data in phylo4d objects ##' ##' Methods to retrieve or update tip, node or all data associated with a ##' phylogenetic tree stored as a phylo4d object ##' ##' @param x A \code{phylo4d} object ##' @param type The type of data to retrieve or update: \dQuote{\code{all}} ##' (default) for data associated with both tip and internal nodes, ##' \dQuote{\code{tip}} for data associated with tips only, ##' \dQuote{\code{internal}} for data associated with internal nodes only. ##' @param label.type How should the tip/node labels from the tree be returned? ##' \dQuote{\code{row.names}} returns them as row names of the data frame, ##' \dQuote{\code{column}} returns them in the first column of the data frame. ##' This options is useful in the case of missing (\code{NA}) or non-unique ##' labels. ##' @param empty.columns Should columns filled with \code{NA} be returned? ##' @param merge.data if tip or internal node data are provided and data already ##' exists for the other type, this determines whether columns with common names ##' will be merged together (default TRUE). If FALSE, columns with common names ##' will be preserved separately, with \dQuote{.tip} and \dQuote{.node} appended ##' to the names. This argument has no effect if tip and node data have no ##' column names in common, or if type=\dQuote{all}. ##' @param clear.all If only tip or internal node data are to be replaced, ##' should data of the other type be dropped? ##' @param \dots For the \code{tipData} and \code{nodeData} accessors, ##' further arguments to be used by \code{tdata}. For the replacement ##' forms, further arguments to be used to control matching between ##' tree and data (see Details section of \code{\link{phylo4d-methods}}). ##' @param value a data frame (or object to be coerced to one) to replace the ##' values associated with the nodes specified by the argument \code{type} ##' @return \code{tdata} returns a data frame ##' @section Methods: \describe{ ##' \item{tdata}{\code{signature(object="phylo4d")}: retrieve or update data ##' associated with a tree in a \code{phylo4d} object} } ##' @author Ben Bolker, Thibaut Jombart, Francois Michonneau ##' @seealso \code{\link{phylo4d-methods}}, \code{\linkS4class{phylo4d}} ##' @export ##' @keywords methods ##' @include phylo4d-methods.R ##' @rdname tdata-methods ##' @examples ##' data(geospiza) ##' tdata(geospiza) ##' tipData(geospiza) <- 1:nTips(geospiza) ##' tdata(geospiza) setGeneric("tdata", function(x, ...) { standardGeneric("tdata") }) ##' @rdname tdata-methods ##' @aliases tdata,phylo4d-method setMethod("tdata", signature(x="phylo4d"), function(x, type=c("all", "tip", "internal"), label.type=c("row.names","column"), empty.columns=TRUE) { ## Returns data associated with the tree ## Note: the function checks for unique labels. It's currently unecessary ## but could be useful in the future if non-unique labels are allowed. type <- match.arg(type) label.type <- match.arg(label.type) ids <- nodeId(x, type) labs <- labels(x, type) ## replace any missing labels with node numbers labs[is.na(labs)] <- names(labs)[is.na(labs)] tdata <- x@data[match(ids, row.names(x@data)), , drop=FALSE] row.names(tdata) <- ids data.names <- labs[match(names(labs), rownames(tdata))] if (label.type == "row.names") { if (!any(duplicated(data.names)) && ## length(data.names) > 0 && !any(is.na(data.names)) ) { row.names(tdata) <- data.names } else { warning("Non-unique or missing labels found, ", "labels cannot be coerced to tdata row.names. ", "Use the label.type argument to include labels ", "as first column of data.") } } if (identical(label.type,"column")) { tdata <- data.frame(label=data.names, tdata) } ## remove empty columns (filled with NAs) if(!empty.columns) { emptyCol <- apply(tdata, 2, function(x) all(is.na(x))) tdata <- tdata[, !emptyCol, drop=FALSE] } tdata }) ##' @rdname tdata-methods ##' @aliases tdata<- ##' @export setGeneric("tdata<-", function(x, ..., value) { standardGeneric("tdata<-") }) ##' @name tdata<- ##' @rdname tdata-methods ##' @aliases tdata<-,phylo4d-method tdata<-,phylo4d,ANY-method setReplaceMethod("tdata", signature(x="phylo4d", value="ANY"), function(x, type = c("all", "tip", "internal"), merge.data = TRUE, clear.all = FALSE, ..., value) { type <- match.arg(type) ## format new data value <- formatData(x, value, type, keep.all=TRUE, ...) ## get old data to keep (if any) if (clear.all || type=="all") { keep <- NULL } else { if (type=="tip") { keep <- tdata(x, type="internal", empty.column=FALSE) keep <- formatData(x, keep, "internal", match.data=FALSE) } else if (type=="internal") { keep <- tdata(x, type="tip", empty.column=FALSE) keep <- formatData(x, keep, "tip", match.data=FALSE) } } ## create updated data updated.data <- switch(type, tip = .phylo4Data(x, tip.data=value, node.data=keep, merge.data=merge.data), internal = .phylo4Data(x, tip.data=keep, node.data=value, merge.data=merge.data), all = .phylo4Data(x, all.data=value, merge.data=merge.data)) ## try to arrange new columns after old columns kept <- names(updated.data) %in% names(keep) old.cols <- names(updated.data)[kept] new.cols <- names(updated.data)[!kept] x@data <- updated.data[c(old.cols, new.cols)] if(is.character(checkval <- checkPhylo4(x))) stop(checkval) return(x) }) ### Tip data wrappers ##' @rdname tdata-methods ##' @aliases tipData tipData-method ##' @export setGeneric("tipData", function(x, ...) { standardGeneric("tipData") }) ##' @name tipData ##' @rdname tdata-methods ##' @aliases tipData,phylo4d-method setMethod("tipData", signature(x="phylo4d"), function(x, ...) { tdata(x, type="tip", ...) }) ## tipData<- ##' @rdname tdata-methods ##' @aliases tipData<- ##' @export setGeneric("tipData<-", function(x, ..., value) { standardGeneric("tipData<-") }) ##' @name tipData<- ##' @rdname tdata-methods ##' @aliases tipData<-,phylo4d-method tipData<-,phylo4d,ANY-method setReplaceMethod("tipData", signature(x="phylo4d", value="ANY"), function(x, ..., value) { tdata(x, type="tip", ...) <- value if(is.character(checkval <- checkPhylo4(x))) stop(checkval) return(x) }) ### Node data wrappers ##' @rdname tdata-methods ##' @aliases nodeData nodeData-method ##' @export setGeneric("nodeData", function(x, ...) { standardGeneric("nodeData") }) ##' @name nodeData ##' @rdname tdata-methods ##' @aliases nodeData,phylo4d-method setMethod("nodeData", signature(x="phylo4d"), function(x, ...) { tdata(x, type="internal", ...) }) ## nodeData<- ##' @rdname tdata-methods ##' @aliases nodeData<- ##' @export setGeneric("nodeData<-", function(x, ..., value) { standardGeneric("nodeData<-") }) ##' @name nodeData<- ##' @rdname tdata-methods ##' @aliases nodeData<-,phylo4d-method nodeData<-,phylo4d,ANY-method setReplaceMethod("nodeData", signature(x="phylo4d", value="ANY"), function(x, ..., value) { tdata(x, type="internal", ...) <- value if(is.character(checkval <- checkPhylo4(x))) stop(checkval) return(x) }) phylobase/R/phylobase.options.R0000644000176200001440000000374614553646170016271 0ustar liggesusers##' Set or return options of phylobase ##' ##' Provides a mean to control the validity of \code{phylobase} ##' objects such as singletons, reticulated trees, polytomies, etc. ##' ##' The parameter values set via a call to this function will remain ##' in effect for the rest of the session, affecting the subsequent ##' behavior of phylobase. ##' ##' @param \dots a list may be given as the only argument, or any ##' number of arguments may be in the \code{name=value} form, or no ##' argument at all may be given. See the Value and Details sections ##' for explanation. ##' @return A list with the updated values of the parameters. If ##' arguments are provided, the returned list is invisible. ##' @author Francois Michonneau (adapted from the package \code{sm}) ##' @keywords phylobase validator ##' @examples ##' \dontrun{ ##' phylobase.options(poly="fail") ##' # subsequent trees with polytomies will fail the validity check ##' } ##' ##' @export phylobase.options <- function (...) { if (nargs() == 0) return(.phylobase.Options) current <- .phylobase.Options temp <- list(...) if (length(temp) == 1 && is.null(names(temp))) { arg <- temp[[1]] switch(mode(arg), list = temp <- arg, character = return(.phylobase.Options[arg]), stop("invalid argument: ", sQuote(arg))) } if (length(temp) == 0) return(current) n <- names(temp) if (is.null(n)) stop("options must be given by name") if (!all(names(temp) %in% names(current))) stop("Option name invalid: ", sQuote(names(temp))) changed <- current[n] current[n] <- temp current <- lapply(current, function(foo) { foo <- match.arg(foo, c("warn", "fail", "ok")) }) if (!identical(current$retic, "fail")) { stop("Currently reticulated trees are not handled by phylobase.") } ## options are always global env <- asNamespace("phylobase") assign(".phylobase.Options", current, envir = env) invisible(current) } phylobase/R/MRCA-methods.R0000644000176200001440000000433614553646170014770 0ustar liggesusers ##' Most Recent Common Ancestor (MRCA) of 2 or more nodes. ##' ##' Given some nodes (i.e., tips and/or internal), this function ##' returns the node corresponding to the most recent common ancestor. ##' ##' If \code{phy} is a \code{phylo4} or \code{phylo4d} object, the ##' nodes can contain both numeric or character values that will be ##' used by \code{getNode} to retrieve the correct node. However, if ##' \code{phy} is a \code{phylo} object, the nodes must be a numeric ##' vector. ##' ##' With \code{phylo4} and \code{phylo4d} objects, if a single node is ##' provided, it will be returned. ##' ##' @title MRCA ##' @param phy a phylogenetic tree in phylo4, phylo4d or phylo format. ##' @param ... a vector of nodes ##' @return the node corresponding to the most recent common ancestor ##' @export ##' @include phylo4d-methods.R getNode-methods.R ##' @include oldclasses-class.R ##' @rdname MRCA ##' @examples ##' data(geospiza) ##' MRCA(geospiza, 1, 5) ##' MRCA(geospiza, "fortis", 11) ##' MRCA(geospiza, 2, 4, "fusca", 3) ##' geo <- as(geospiza, "phylo") ##' MRCA(geo, c(1,5)) setGeneric("MRCA", function(phy, ...) { standardGeneric("MRCA") }) ##' @rdname MRCA ##' @aliases MRCA,phylo4-method setMethod("MRCA", signature(phy = "phylo4"), function(phy, ...) { nodes <- list(...) ## if length==1 and first element is a vector, ## use it as the list if (length(nodes)==1 && length(nodes[[1]])>1) { nodes <- as.list(nodes[[1]]) } lNodes <- sapply(nodes, function(nd) { getNode(x=phy, node=nd, missing="fail") }) ## Correct behavior when the root is part of the nodes uniqueNodes <- unique(lNodes) root <- nodeId(phy, "root") if(root %in% uniqueNodes) { res <- getNode(phy, root) return(res) } ## Correct behavior in case of MRCA of identical taxa if(length(uniqueNodes) == 1) { res <- uniqueNodes[[1]] return(res) } else { ancests <- lapply(nodes, ancestors, phy=phy, type="ALL") res <- getNode(phy, max(Reduce(intersect, ancests))) return(res) } }) ##' @rdname MRCA ##' @aliases MRCA,phylo-method setMethod("MRCA", signature(phy = "phylo"), function(phy, ...) { ape::getMRCA(phy, ...) }) phylobase/R/oldclasses-class.R0000644000176200001440000000036614553646170016043 0ustar liggesusers## This file contains the old class definitions needed ## better interoperation with other packages ## ape classes setOldClass("phylo") setOldClass("multiPhylo") ## setOldClass("multi.tree") ## obsolete ## ade4 classes setOldClass("phylog") phylobase/R/phylo4-class.R0000644000176200001440000000266714553646170015134 0ustar liggesusers##' The phylo4 class ##' ##' Classes for phylogenetic trees ##' ##' @name phylo4-class ##' @docType class ##' @section Objects from the Class: Phylogenetic tree objects can be created by ##' calls to the \code{\link{phylo4}} constructor function. Translation ##' functions from other phylogenetic packages are also available. See ##' \code{\link{coerce-methods}}. ##' @author Ben Bolker, Thibaut Jombart ##' @seealso The \code{\link{phylo4-methods}} constructor, the ##' \code{\link{checkPhylo4}} function to check the validity of ##' \code{phylo4} objects. See also the \code{\link{phylo4d-methods}} ##' constructor and the \linkS4class{phylo4d} class. ##' @keywords classes ##' @include RcppExports.R checkdata.R ##' @export setClass("phylo4", representation(edge = "matrix", edge.length = "numeric", label = "character", edge.label = "character", order = "character", annote = "list"), prototype = list( edge = matrix(nrow = 0, ncol = 2, dimnames = list(NULL, c("ancestor", "descendant"))), edge.length = numeric(0), label = character(0), edge.label = character(0), order = "unknown", annote = list() ), validity = checkPhylo4) phylobase/NEWS.md0000644000176200001440000002324014555671670013357 0ustar liggesusers## CHANGES IN phylobase VERSION 0.8.12 * CRAN maintenance release. ## CHANGES IN phylobase VERSION 0.8.10 * CRAN maintenance release in prepartion for R 4.0.0 with `stringsAsFactors=FALSE` as default. For backwards compatibility, `stringsAsFactors` is set to `TRUE` internally to mimic the previous default behavior. For the time being, conversion to non-factors data types will need to be handled manually. ## CHANGES in phylobase VERSION 0.8.8 * CRAN maintenance release. Updated documentation of the `ancestors()` function to remove unused `...`. ## CHANGES in phylobase VERSION 0.8.6 * CRAN maintenance release following updates to RNeXML. ## CHANGES in phylobase VERSION 0.8.4 * CRAN maintenance release ## CHANGES in phylobase VERSION 0.8.2 * Fix typo in examples of phylo4d methods. ## CHANGES IN phylobase VERSION 0.8.0 ### New features * Initial basic support for converting RNeXML objects in phylo4 and phylo4d format. * New methods: `internalEdges()`, `terminalEdges()` * `descendants()` has now a `"ALL"` argument to include self in results * New method: `nodeHeight()` provides a consistent and comprehensive way of calculating the distance between a node and either the root or the tips. (fix #3) * The replacement methods for `labels`, `tipLabels`, `nodeLabels`, `edgeLabels` now accept `NA` or `NULL` to remove labels (fix #2) ### Major changes * `readNexus` and `readNewick` now internally use the package `rncl` to parse files. They also use a different approach to reconstruct the edge matrix. These changes make file parsing faster. Objects created with this new approach may not exactly be identical to those created in previous versions as node numbering might differ, they should however be fully compatible with each others. * `readNexus` and `readNewick` can now parse tree files with trees containing a subset of the taxa listed in the TAXA Block. * Source code for the package is hosted on GitHub at https://github.com/fmichonneau/phylobase ### Minor changes * All tests done with testthat * `rootNode` returns the rootNode using the same format as `getNode()`. * All documentation is in Roxygen format * `hasPoly`, `hasRetic`, `hasSingle` are now methods instead of functions. ### Deprecated functions * `nodeDepth` and `depthTips` are now deprecated and are replaced by `nodeHeight` ### Bug fixes * Fix bug: `NA` in labels were considered duplicated by `checkPhylo4()`. * Fix bug #605 (R-forge) -- treePlot subsets numeric data for plotting. * Fix bug #4: `descendants()` behave like `ancestors()` when provided with a vector of nodes and is consistent across all arguments. ## CHANGES IN phylobase VERSION 0.6.8 * Not many user-visible changes, most are related to improving speeds during test of object validation (most tests done in C++) and to getNode that is used by many functions. * Changes to package structure to make it compatible with devtools (switching testing to testthat -- partial at this stage) and docs to roxygen format (partial at this stage). * Changes to package structure to comply with new Rcpp standards ## CHANGES IN phylobase VERSION 0.6.5 * Updates from cout/cerr to Rcpp::Rcout/Rcerr * Comments in Nexus tree strings are being removed before being processed by readNCL ## CHANGES IN phylobase VERSION 0.6.3 * Fixed bugs in getNode in cases where labels included regexpr metacharacters and when a tip was labelled 0 * New methods: depthTips, nodeDepth and isUltrametric ## CHANGES IN phylobase VERSION 0.6.2 * Improve handling of errors returned by NCL (NxsException) * Fix bug in case state labels are missing from the NEXUS file * Upgrade to NCL 2.1.14 ## CHANGES IN phylobase VERSION 0.6.1 * Fix bugs that prevented building on Windows 64-bit systems ## CHANGES IN phylobase VERSION 0.6 ### MAJOR CHANGES * Updated to the Nexus Class Library (NCL) 2.1.12. * Changed the way NCL is built during the installation process. * Complete rewrite of the function readNexus which brings many new functionalities. * Nodes labels do not have to be unique. ### NEW FEATURES * In readNexus, the option return.labels gives the state labels of the characters. * It is now possible to import several types of data blocks in a single NEXUS file with readNexus. * The function phylobase.options() provides global options to control the behavior of the phylo4/phylo4d validator. * The new method hasDuplicatedLabels() indicates whether any node labels are duplicated. * The new method nData() returns the number of datasets associated with a tree. * The column that contains the labels can now be specified by its name in the function formatData() ### MINOR CHANGES * The function getNode() has been modified to allow node matching in the case of non-unique labels. * Many new unit tests. ### BUG FIXES * Far too many to document. See the SVN log for details. ### KNOWN ISSUES * Unrooted trees are not supported by all functions, e.g. plot() and reorder(). * Factors are not supported by the default plotting method. ## CHANGES IN phylobase VERSION 0.5 ### MAJOR CHANGES * A var-cov matrix tree class, phylo4vcov, and methods for converting to and from other classes now exists. * Replaced separate the tip.label and node.label slots with a unified label slot in the phylo4 class definition. * Replaced separate the tip.data and node.data into a single data slot in the phylo4d class definition. * The phylo4 class grew a annotate slot. * The phylo4d class grew a metadata slot. * Added an order slot to the phylo4 class definition and updated as() methods to assign the proper order (if possible) when converting between ape and phylobase tree formats. * The Nnode slot was removed from the phylo4 class definition. * An explicit root edge has been added to the edge matrix with 0 as the ancestor and nTips(phy) + 1 as the rood node. * The edgeLabels() and edgeLength() accessors now return vectors with named elements in the same order as rows of the edge matrix, even when some/all values are missing. * The labels() accessor and nodeID() methods now always return labels in ascending order of node ID * Many function and argument names and defaults have been changed to make them more consistent most functions follow the getNode() pattern. * The plotting functions have been replaced (see below). * Now, data are matched against node numbers instead of node labels. * Tip and internal node labels have now internal names that are character strings of the node number they correspond to. Thus it is possible to store labels in any order and assignment of labels more robust. * We now use the RUnit package (not required for normal use) for adding unit tests. Adding unit tests to inst/unitTests/ is now preferred over the tests/ directory. * Numerous changes to pruning and tree subsetting code. It is considerably more robust and no longer relies on calls to APE. ### NEW FEATURES * Added a function nodeType() for identifying whether a node is root, tip or internal. * Changed nodeNumbers to nodeId() and extended it abilities. * Added method reorder() for converting edge matrices into preorder or postorder. * Added the edgeOrder accessor to get the order of a phylobase object. * Added a package help file accessible from ?phylobase. * Added labels()<- for assigning labels. * Added edgeLength()<- for assigning edgeLengths. * Added a phylo4() method for importing APE phylo objects. * Added a hasTipData() method. * Added a edgeId() method. * Created the addData() method for adding data to phylo4 objects. * Added tipData and nodeData getter/setter methods * If all node.labels are numerical values, they are automatically converted as data. Useful when importing consensus tree from MrBayes. * It is now possible to print tree objects in edge order using the edgeOrder argument in printphylo4(). * reorder(), descendants(), ancestors(), and portions of the plotting code have been recoded in C to improve performance. * Added a developer vignette to document and guide development of the phylobase package. * The previous plotting functions, based on base graphics, have been replaced with function based on the grid graphics device. * A S4 generic plot() function, calling treePlot() has been added it dispatches a plotting function based on object class and arguments. * Plots using grid based code can be inserted at the tree tips using the tip.plot.fun argument in plot() * The getNode() method has been enhanced to allow matching against specific node types, and if the requested node is missing, all nodes of specified type are returned. * Changed getEdge() to allow no node argument, which returns all edges appropriate for the given type. ### CHANGES * Node labels are, if not supplied, a vector of NA. * printphylo() is now deprecated, print() and summary() now alsow work on empty objects. * phylo4() is now and S4 generic with signature "matrix". * phylobase now uses a NAMESPACE file. * Legacy plotting code (0.4) can be found in the SVN repo tags directory. * The tdata default "type" argument changed to 'all'. * Row names now stored internally as numeric, not character. ### BUG FIXES * Far too many to document. See the SVN log for details. ### KNOWN ISSUES * Unrooted trees are not supported by all functions, e.g. plot() and reorder(). * Factors are not supported by the default plotting method. * The Nexus Class Library is build for the system default ARCH which may or may not be the architecture that R and the rest of the package is built with. If this occurs the package will fail to load. * Unique labels are required for internal nodes, this behavior will be changed in the future. phylobase/MD50000644000176200001440000002014114556040263012553 0ustar liggesusers9ef63cc7ce545f9a589c1cc6b921b7ee *DESCRIPTION 7a141473f1fa43e0d1dc5774666b230d *NAMESPACE 5dcab1d1f04e2aea551b8f185faf48a9 *NEWS.md 5d7d5aaeacdcbb2b7c94e2a7a12c8283 *R/MRCA-methods.R b5984a768d183ef335b1f77afbf494b6 *R/RcppExports.R 360d531ea9499bc48e3ba4ea344780b1 *R/addData-methods.R 7b22b93b9fec95625e3789b95e82a747 *R/ancestors.R 27d501dd383df3c91579dcc6028f0852 *R/checkdata.R cf200a46cf69d04f04f6b31c80c75bb1 *R/edgeLength-methods.R 9edcd964c68d44867b019abe4105f093 *R/extractTree.R b241527b6be331df65777ac493bf5d55 *R/formatData.R c91b1a7bbcea7047e0370985bbcf4d44 *R/getNode-methods.R f85e38d409d57420ac6e02b1f44c1dc9 *R/internal-constructors.R 7bd80915399baa2675528dfed8b193e1 *R/labels-methods.R cb2282bb40632e8f7039991482938d11 *R/multiphylo4-class.R 97bef8bb049e23553a30e9c00f07d6f5 *R/nodeId-methods.R c0e2782404632e4e3420ac9520a7eb67 *R/oldclasses-class.R 016336404f44444178d488798ae5607c *R/pdata.R 871f687a6a4c9e2b3ca3c7ce787dcc4a *R/phylo4-accessors.R 599019bec50bff5ab3e265d3d29ec5bc *R/phylo4-class.R be1814a94cc3b26b66451f236b67cedc *R/phylo4-methods.R 3a740fa03aa3940f253b321e006fa157 *R/phylo4d-accessors.R d28d5cb63f628bc8cf032d226857ceb1 *R/phylo4d-class.R 4ea51d252c0a8eb8ad410c05bc78d6f6 *R/phylo4d-methods.R 8362c5992f661922af98167c66bfa8ef *R/phylobase-package.R 6cfe1b8f4fa6b546480b9b0917e8884b *R/phylobase.options.R 0c1561e5ae25e50f5811a863450a878e *R/phylomats-class.R 97b55e8896ba2f87877ee9ee1a81a54a *R/print-methods.R 3c625fbec9acfd9826bf6a58c49f3da1 *R/readNCL.R 712c2b4cfcce97c593cdebd36a846c87 *R/reorder-methods.R af36b2ab79cdce9ab7f1c51b99a9120c *R/root-methods.R 119077bc7e59bcd2a801b3717ca61dcf *R/setAs-methods.R b12e60d130b8617e92ece7cd5e2faa08 *R/shortestPath-methods.R d566204cf9829a745739412ce5887963 *R/subset-methods.R ddb1f86ef610780a336bdf7473b1cb69 *R/summary-methods.R 957d6bb59eea50e691c3411bd7c8a455 *R/tbind.R 54333801e92f6320240187986cf19887 *R/tdata-methods.R 5e074eca6071257efba5767f6eae8467 *R/treePlot.R a3451a2d297b035ecf6561a4fdb3ae28 *R/treestruc.R 38747d50f18ac2b910afecf24ed1d92c *R/zzz.R 6b9bd9afb26af85c6e5b8e6cf2764ec0 *README.md 0c97be72bf87a4341209b491b8f9d94f *build/vignette.rds 7a03af7f836f7bff48f5b9dc83b28ca8 *data/geospiza.rda 8a843dd8cd966030b246f06adee0ac13 *data/geospiza_raw.rda 26e3cdf5f9480147fd9ef4a3f8b75c3b *data/owls4.rda 71e7c91801fcbc726214d7f7273e627b *inst/doc/phylobase.Rmd 1e052925ae2706f8e6f522eb8166d774 *inst/doc/phylobase.html 7cfba1e69724dd93fe4a07525e419ed4 *inst/nexmlfiles/comp_analysis.xml 1fff9fa62be103e818e88abf156ffacb *inst/nexusfiles/ExContData.Rdata c05860e96ba5feab12b1269f43a43f1b *inst/nexusfiles/MultiLineTrees.nex a9a55d0e542ea83751c134892a17440f *inst/nexusfiles/NastyLabels.nex 72b184a406aa23c2e1711df4f3fd0275 *inst/nexusfiles/NastyLabels2.nex f8225a526530eabfaa8ea117e2a82aae *inst/nexusfiles/co1.nex f0289cdad66a374a438f582e2ab76a29 *inst/nexusfiles/minNex.nex f77c8d44a525dbb3b06c335110ad3547 *inst/nexusfiles/minSeq.nex 4d5d4d71cf83b54eed9811470482e8d2 *inst/nexusfiles/newick.tre 51849f725c9b6097be5f2b6453c33844 *inst/nexusfiles/noStateLabels.nex 9fec41c9d01e57b43dc8e55f1547096b *inst/nexusfiles/shorebird_underscore.nex d7eeca6e30d22f9a431822452109e922 *inst/nexusfiles/testSubsetTaxa.nex ee3bac96ca12af01b3c7610df8339f34 *inst/nexusfiles/test_min.nex 8c16a312ee724e2a94aecd5b2c6df0ee *inst/nexusfiles/treeRoundingError.nex 99b2fe340a17a7e8cac9cfb9bdbafe70 *inst/nexusfiles/treeWithContinuousData.nex 9d27abaf6517ea4ca9881bd9f8c0032a *inst/nexusfiles/treeWithDiscAndContData.nex 963e6a5568b7fae9291232b8abfd496c *inst/nexusfiles/treeWithDiscreteData.nex 6deabaca8bbfe8c34e60d06349f31398 *inst/nexusfiles/treeWithPolyExcludedData.nex b6390d9653d37f920612cbe3a8d38fe5 *inst/nexusfiles/treeWithSpecialCharacters.nex 4961bb5af89e1cfd63944af5d8ee8408 *inst/nexusfiles/treeWithUnderscoreLabels.nex f60b817d2d2c29ca1baf3116036e5b0c *man/MRCA.Rd a1cab3a109e699ab90e4af7e940fe065 *man/addData-methods.Rd 1b6a647f124770e75c61be47537afd36 *man/ancestors.Rd b57155fe8d3a737483b36d8d94449890 *man/checkPhylo4.Rd 7c17808a7f0103ea984dd9c1140939a4 *man/edgeLength-methods.Rd 76750a52c8492b23eb5509f4f8fa729a *man/edges-accessors.Rd c5ff6259f85ca20555d80f07116c0e4e *man/extractTree.Rd ddae828de98e3fef5cbf12da7bad079f *man/formatData.Rd 37368a2111c74bbe32a0f7bbb9f65534 *man/geospiza.Rd 13206bcf24f9a5bd0fa48aee6a8a27e4 *man/getNode-methods.Rd 4bbe093b00fa3f31d09e1e0f9e0ca687 *man/labels-methods.Rd 6519db726c64b47e02cab2424c39a647 *man/multiPhylo-class.Rd b976ab5ef7d5d9d0a348ef16019820c3 *man/nTips-methods.Rd 5f5619026f03eb92dc7c5a76410ce13a *man/nodeId-methods.Rd 77587a114be0693a65f6f44c04080d2e *man/owls4.Rd d07a2bf017b1d937cdbec916190127b1 *man/pdata-class.Rd d88a1ee35365662fbeb5dbe4efe6bde3 *man/pdata.Rd 375b27916734c02363a64ee7c8dba307 *man/phylo4-class.Rd 346858324db6b6edb22d4ea5b5418c91 *man/phylo4-methods.Rd 27cc410eb347b2f7b56d4c144004a383 *man/phylo4d-accessors.Rd 73b3b7b79cd7bc62c7e9d60a49642256 *man/phylo4d-class.Rd 90521e06f2d8a2f3f5abbcb0f84f80e4 *man/phylo4d-methods.Rd ccb481d77f91417f5a2ff91a53a0670a *man/phyloXXYY.Rd b6cc1d701b92a9c71525e9ad1ddeef89 *man/phylobase-package.Rd 32b2159b920d7397b804da4944625b3c *man/phylobase.options.Rd 3e42e81472cd89d1c56ed6fe68471cbd *man/phylobubbles.Rd 7d5119552a6eb8f7531e246cfaa64535 *man/phylomat-class.Rd 1c25c187e1ff92e536e730a272ade04b *man/plotOneTree.Rd 8a9cdf0b346eb24ddb4499dcac81e103 *man/print-methods.Rd e74c8a894e975dc89eb75300777b45ac *man/readNexus.Rd b8bac1e95bc7e7ee47077875704aa7be *man/reorder-methods.Rd 63c94c453c9202600ddc58de6568d793 *man/root-methods.Rd 5f16f493fdcfb4f7c3d9228b91f2a368 *man/setAs-methods.Rd 366c27b381f7c07f2a1498f18fee04eb *man/shortestPath-methods.Rd 25107c4d398faef49d91082d20f1d917 *man/subset-methods.Rd d94fdf7044af2b4852dfd0dd84af84c0 *man/summary-methods.Rd 4279bd2a53391cf3f7fe95638b462859 *man/tdata-methods.Rd 2191b11c1d55bdef94f4890460dbecda *man/tip.data.plot.Rd 4db927dbac982617d9e5337744344249 *man/treePlot-methods.Rd dac696c0ed689e542e6de63cad132871 *man/treeStructure-methods.Rd ed0d19722e28a7d316256f2c247be33e *src/Makevars 1e0cc7f2ea27756865f63d6758ca90a8 *src/Makevars.win 551bf6ba0a370ead89d5a1d6766fd96f *src/RcppExports.cpp 2ba5b488a78a904712cdefc6f87307f9 *src/ancestors.c c78cc56ae6c035ed9a0a584424eac960 *src/checkPhylo4.cpp 4b08d7daaf385bd79465aa3e0785967e *src/descendants.c 1b1d0ecd28d6eb26a29fc576091cc5c3 *src/phyloXX.c 2f6412f3d74e84ac030d36b948e24f9e *src/phylobase_init.c dc5efccf4d370c4c7b0801bcbfd74a9b *src/reorderBinary.c 1944dc3ac77930043bb7ccb02f3718cd *src/reorderRobust.c cb2ef3c2e0613221c053e3236b36debd *tests/misctests.R 9f8cda1294f43f665a0a96aa7b7f7977 *tests/phylo4dtests.R fd985e3b18ff2d41e3c213f8b9418f27 *tests/phylosubtest.R db2a0aaf0280429619fb99b2855c835e *tests/phylotorture.R 647bb8fbf0e8266427210598fc3fd21a *tests/plottest.R c08c45b2d046fc6386a34c9fe78aea51 *tests/roundtrip.R ab01639d84fb8c735c4b80404a16e621 *tests/test-all.R 38c287fa7b4426eab00c31412ff770be *tests/testprune.R 8c24f793e3f704b87d3eb84e30dfac52 *tests/testthat/test.checkdata.R c668499d76ffe8fad700cb13aa59d362 *tests/testthat/test.class-phylo4.R b1297d002ae23743d2c84979ec4e4ef3 *tests/testthat/test.class-phylo4d.R 28cb571f46bd6bb0127e2123d919ca8c *tests/testthat/test.formatData.R 1275c5c4b612317ed4e6c9f1a7e8eb15 *tests/testthat/test.methods-oldclasses.R 8616708a4340f16b336f5ea57e25f7ed *tests/testthat/test.methods-phylo4.R 9dd09d9e64303c752ed57a7331543854 *tests/testthat/test.pdata.R e4d54b4db45a69a5e40811975cc44274 *tests/testthat/test.phylo4.R d38fa9feddccd722b1c56a4864dbfc9e *tests/testthat/test.phylobase.options.R e1d0fada9b7ed61564f9fb1570d02f4f *tests/testthat/test.prune.R 7a7050ade501c998d593f5be3be6d8ce *tests/testthat/test.readNCL.R e29d3170f506dc31551e611b5dc60600 *tests/testthat/test.setAs-Methods.R 37b1df7381866235003e027eff81e2c7 *tests/testthat/test.subset.R 7ce9e14f01d0b524e56ec238d90275e0 *tests/testthat/test.tbind.R 3286fe80846d087c46a36fcf380e42a7 *tests/testthat/test.treePlot.R 7020fbe04de6da74f575a83039235325 *tests/testthat/test.treestruc.R 521ece6dcb763bcbfd39c327fff884e2 *tests/testthat/test.treewalk.R 22de180f583552fec8c7efef221c1908 *vignettes/auto/developer.el 796900b65010439fefca7e437507e41f *vignettes/fig-vignettes-plotvcvphylo-1.png 71e7c91801fcbc726214d7f7273e627b *vignettes/phylobase.Rmd phylobase/inst/0000755000176200001440000000000014555747152013234 5ustar liggesusersphylobase/inst/nexusfiles/0000755000176200001440000000000014553646170015415 5ustar liggesusersphylobase/inst/nexusfiles/noStateLabels.nex0000644000176200001440000000065114553646170020673 0ustar liggesusers#NEXUS BEGIN TAXA; DIMENSIONS NTAX=4; TAXLABELS spA spB spC spD ; END; BEGIN TREES; TRANSLATE 1 spA, 2 spB, 3 spC, 4 spD; TREE testTree = (1,(2,(3,4))); END; BEGIN CHARACTERS; TITLE 'TestStd'; DIMENSIONS NCHAR=3; FORMAT DATATYPE = STANDARD MISSING = ? SYMBOLS = "0 1 2"; CHARSTATELABELS 1 char1, 2 char2, 3 char3; MATRIX spA 1 0 1 spB 2 1 0 spC 0 1 2 spD 1 2 0 ; END; phylobase/inst/nexusfiles/ExContData.Rdata0000644000176200001440000001076414553646170020374 0ustar liggesusersY 8T$J*)s2!:E7ݯT*E)T*5B.Kw3 oSy5ֻ}3,7X/$aI!QT#-ieBcl 242 e[#Pk ; f{ApdfwCCKBr# ̫ۨAgfjk9\:N~(^L.}H20XV IP›ql~+.zȩXtbg "(Pl|N`(x]P'dFlkfÝI(1p}X*i5*{bo/]Wa/lGIpoz=ZX<MןÙ Cx &[X__Gˊ7-B a645Lr :r' L,Xw&2JgB?4d)C'-Ueo5y)01wma3ˌ%,?߲.hm>=t 4fuv>_x˚q(nc0 0c#[oW5քo}y–%V_eq|q҂kTW7tC-Bxz&ɿ-lqZg@w?r?!NDOd4qAh7qT]hj^ghIVQD``B]>V&~e:W~Uv%}߈^hzdq.zq93Km7:订<3L͆n{@7x*BTMU|=V׀wQOq8R`auܜ۲Pk_ÔaSm7qHSAkR͙͚7djNx3Kr4hWk1~~]h 3MXz| t8.6r &R2Z~uF G CڗzgdHo[>`GLXWK_$tϲ6=*t ގi_$eGh^Z8+ߔFo4J-p9=܈Pw]_XB\.ʶQ=ńl_Mb1.xh.ݒcXh;: ~t9kOm~|kFu^?<7ɝ&GychdyQ 24D󓯏D^}/q;()1o$7r<{lz{m\gB?_;  ":%AkBߙ z4 QQ<L\΂'c[K?GxeFׇFL AF^ywjCndbI|9WWhCgN0}>?&7`TĠG 4+whc }x+Tr"`qt3fBtGZqqiz)(2\^"j/CIкĘ{eWl5>~y|V6_ vPxΐBnC7+_\+x3 }e8"jgʈ]dh-G8Ȃ\Qà P;?KD`8D lQD3_;N%N˲PLnz9?Įk]A] ?šPQb؈+sv}ђYu![uwB"!v1vVY:tw ON_unD]$= mqe$~A.AV҆Q߯/D_g.^Xˮ\ ]lsHTr΁J2g֨K| z BծUY;%)MĪ5Bg#B6 7Ok`P%=45 €($ _Mr|0z|dק;Ǘ N?AiksE" TF \3YB#Z 3B.GDëvdW:*6|m74^F-j>ewNC*l2dN2DyD:!/HI;ܜ^MM߸2WGev5&_HaR+A$#%0=oEdgӟk_2Ą|&yRmd`N-x=VRM{LQ0?MOr 5s)ĤOf`f9WWE];4Vr;Cђ~s_BǛc9)#ɩrꭟg?)F˓PNͻ1٩ CqLB$wtMO*U}2GyE mPw'N|g露2kd-N_O$A^!i*4*>V|7%CcT$vl4ەߪϙ-擡j׊_G}(3 .@%Q¥;(S\Q9$Tn /z7'C?TgQ_3\Ur5mVLur3Р~YW"_4-oCnH{fT(Oy{(٤:(.{fωfVo2˸)(?Hݥ] `{hQ T\ ,ԙs~Tι_%dU $ mG%e@g`4ju_aBbJS&;5|w6NqMG_.IOvPyzPpYKlAO.>"/'/%I>?N_ַT/hR,TՅ5Z ~}Yoiuibqjokk+ZP/+ YoءP{nYpΩ}_ zgjK?5$,њ*E ^gfPaCL߈Wci/jZտ{L$;tD) {P'UʋQbP Iii?ԽhjȈ9 4lkƌFivS |QTu]נ}G݉hI43 GqkL&33Ls$Dq 1xXwg+Jv$R$޸ك>. ndPS&m&4qV)wuJex($8xge~KRiTgt ^FmA?Ri3 <<'bgoo_Xo _Ri-+ʿ#`|\K]i|6o3Bvgx)tz]Dw83fOǹNTʄCdSa|P3΄>{+Jq0(B#cFv &1ǹ=/L'J) ebfid*Bsx0L\) 3$-d/ H ѓ2ឍƋ!Jt :Byphylobase/inst/nexusfiles/treeWithPolyExcludedData.nex0000644000176200001440000003226414553646170023047 0ustar liggesusers#NEXUS [written Wed Mar 10 11:51:23 EST 2010 by Mesquite version 2.72 (build 527) at francois-laptop/127.0.1.1] BEGIN TAXA; TITLE Taxa; DIMENSIONS NTAX=18; TAXLABELS Myrmecocystuscfnavajo Myrmecocystuscreightoni Myrmecocystusdepilis Myrmecocystuskathjuli Myrmecocystuskennedyi Myrmecocystusmendax Myrmecocystusmexicanus Myrmecocystusmimicus Myrmecocystusnavajo Myrmecocystusnequazcatl Myrmecocystusplacodops Myrmecocystusromainei Myrmecocystussemirufus Myrmecocystussnellingi Myrmecocystustenuinodis Myrmecocystustestaceus Myrmecocystuswheeleri Myrmecocystusyuma ; END; BEGIN CHARACTERS; TITLE testIncomplete; DIMENSIONS NCHAR=3; FORMAT DATATYPE = STANDARD GAP = - MISSING = ? SYMBOLS = "0 1 2"; CHARSTATELABELS 1 Test1 /test1A test1B, 2 Test2 /test2A test2B, 3 Test3 /test3A test3B test3C; MATRIX Myrmecocystuscfnavajo 1(0 1)(0 1 2) Myrmecocystuscreightoni ?(0 1)(0 1) Myrmecocystusdepilis 102 Myrmecocystuskathjuli 100 Myrmecocystuskennedyi 010 Myrmecocystusmendax 101 Myrmecocystusmexicanus 000 Myrmecocystusmimicus ??0 Myrmecocystusnavajo ?11 Myrmecocystusnequazcatl 100 Myrmecocystusplacodops 001 Myrmecocystusromainei 11(0 1 2) Myrmecocystussemirufus 001 Myrmecocystussnellingi 1?0 Myrmecocystustenuinodis 101 Myrmecocystustestaceus ??0 Myrmecocystuswheeleri 000 Myrmecocystusyuma 01? ; END; BEGIN TREES; Title 'Trees from "treepluscharV01.nex"'; LINK Taxa = Taxa; TRANSLATE 1 Myrmecocystuscfnavajo, 2 Myrmecocystuscreightoni, 3 Myrmecocystusdepilis, 4 Myrmecocystuskathjuli, 5 Myrmecocystuskennedyi, 6 Myrmecocystusmendax, 7 Myrmecocystusmexicanus, 8 Myrmecocystusmimicus, 9 Myrmecocystusnavajo, 10 Myrmecocystusnequazcatl, 11 Myrmecocystusplacodops, 12 Myrmecocystusromainei, 13 Myrmecocystussemirufus, 14 Myrmecocystussnellingi, 15 Myrmecocystustenuinodis, 16 Myrmecocystustestaceus, 17 Myrmecocystuswheeleri, 18 Myrmecocystusyuma; TREE bestML = (((((((((13:1.724765,11:1.724765):2.926053,6:4.650818):0.689044,(4:1.08387,17:1.08387):4.255993):0.198842,((8:2.708942,3:2.708942):2.027251,((12:2.193845,10:2.193845):2.257581,18:4.451425):0.284767):0.802512):0.506099,5:6.044804):4.524387,2:10.569191):0.836689,(14:2.770378,15:2.770378):8.635503):0.89482,16:12.300701):1.699299,(7:5.724923,(1:2.869547,9:2.869547):2.855375):8.275077); END; BEGIN ASSUMPTIONS; TYPESET * UNTITLED = unord: 1 - 3; EXSET * UNTITLED = 3; END; BEGIN MESQUITECHARMODELS; ProbModelSet * UNTITLED = 'Mk1 (est.)': 1 - 3; END; Begin MESQUITE; MESQUITESCRIPTVERSION 2; TITLE AUTO; tell ProjectCoordinator; timeSaved 1268239884091; getEmployee #mesquite.minimal.ManageTaxa.ManageTaxa; tell It; setID 0 9015005506118934442; endTell; getEmployee #mesquite.charMatrices.ManageCharacters.ManageCharacters; tell It; setID 0 2565950173085067248; checksumv 0 2 4144740407 null numChars 3 short true bits 7 states 7 sumSquaresStatesOnly 220.0 NumFiles 1 NumMatrices 1; endTell; getWindow; tell It; suppress; setResourcesState false false 155; setPopoutState 400; setExplanationSize 0; setAnnotationSize 0; setFontIncAnnot 0; setFontIncExp 0; setSize 1278 934; setLocation 1440 0; setFont SanSerif; setFontSize 10; getToolPalette; tell It; endTell; desuppress; endTell; getEmployee #mesquite.trees.BasicTreeWindowCoord.BasicTreeWindowCoord; tell It; makeTreeWindow #9015005506118934442 #mesquite.trees.BasicTreeWindowMaker.BasicTreeWindowMaker; tell It; suppressEPCResponse; setTreeSource #mesquite.trees.StoredTrees.StoredTrees; tell It; setTreeBlock 1; toggleUseWeights off; endTell; setAssignedID 630.1180487973731.4514395117633566598; getTreeWindow; tell It; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; setSize 1123 867; setLocation 1440 0; setFont SanSerif; setFontSize 10; getToolPalette; tell It; endTell; getTreeDrawCoordinator #mesquite.trees.BasicTreeDrawCoordinator.BasicTreeDrawCoordinator; tell It; suppress; setTreeDrawer #mesquite.trees.DiagonalDrawTree.DiagonalDrawTree; tell It; setNodeLocs #mesquite.trees.NodeLocsStandard.NodeLocsStandard; tell It; inhibitStretchToggle on; branchLengthsToggle off; toggleScale on; toggleBroadScale off; toggleCenter off; toggleEven off; endTell; setEdgeWidth 12; orientUp; endTell; setBackground White; setBranchColor Black; showNodeNumbers off; showBranchColors on; labelBranchLengths off; centerBrLenLabels on; showBrLensUnspecified on; showBrLenLabelsOnTerminals on; setBrLenLabelColor 0 0 255; setNumBrLenDecimals 6; desuppress; getEmployee #mesquite.trees.BasicDrawTaxonNames.BasicDrawTaxonNames; tell It; setColor Black; toggleColorPartition on; toggleShadePartition off; toggleShowFootnotes on; toggleNodeLabels on; toggleCenterNodeNames off; toggleShowNames on; namesAngle ?; endTell; endTell; setTreeNumber 1; setDrawingSizeMode 0; toggleLegendFloat on; scale 0; toggleTextOnTree off; showWindow; newAssistant #mesquite.ancstates.TraceCharacterHistory.TraceCharacterHistory; tell It; suspend ; setDisplayMode #mesquite.ancstates.ShadeStatesOnTree.ShadeStatesOnTree; tell It; toggleLabels off; toggleGray off; endTell; setHistorySource #mesquite.ancstates.RecAncestralStates.RecAncestralStates; tell It; getCharacterSource #mesquite.charMatrices.CharSrcCoordObed.CharSrcCoordObed; tell It; setCharacterSource #mesquite.charMatrices.StoredCharacters.StoredCharacters; tell It; setDataSet #2565950173085067248; endTell; endTell; setMethod #mesquite.parsimony.ParsAncestralStates.ParsAncestralStates; tell It; setModelSource #mesquite.parsimony.CurrentParsModels.CurrentParsModels; toggleMPRsMode off; endTell; endTell; setCharacter 1; setMapping 1; toggleShowLegend on; toggleGray off; toggleWeights on; setInitialOffsetX 4; setInitialOffsetY -191; setLegendWidth 142; setLegendHeight 191; resume ; endTell; endTell; desuppressEPCResponse; getEmployee #mesquite.trees.ColorBranches.ColorBranches; tell It; setColor Red; removeColor off; endTell; getEmployee #mesquite.ornamental.BranchNotes.BranchNotes; tell It; setAlwaysOn off; endTell; getEmployee #mesquite.ornamental.ColorTreeByPartition.ColorTreeByPartition; tell It; colorByPartition off; endTell; getEmployee #mesquite.ornamental.DrawTreeAssocDoubles.DrawTreeAssocDoubles; tell It; setOn on; setDigits 4; writeAsPercentage off; toggleCentred on; toggleHorizontal on; setFontSize 10; setOffset 0 0; endTell; getEmployee #mesquite.trees.TreeInfoValues.TreeInfoValues; tell It; panelOpen false; endTell; endTell; endTell; getEmployee #mesquite.charMatrices.BasicDataWindowCoord.BasicDataWindowCoord; tell It; showDataWindow #2565950173085067248 #mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindowMaker; tell It; getWindow; tell It; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; setSize 1123 867; setLocation 1440 0; setFont SanSerif; setFontSize 10; getToolPalette; tell It; endTell; setTool mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindow.arrow; colorCells #mesquite.charMatrices.NoColor.NoColor; colorRowNames #mesquite.charMatrices.TaxonGroupColor.TaxonGroupColor; colorColumnNames #mesquite.charMatrices.CharGroupColor.CharGroupColor; colorText #mesquite.charMatrices.NoColor.NoColor; setBackground White; toggleShowNames on; toggleShowTaxonNames on; toggleTight off; toggleThinRows off; toggleShowChanges on; toggleSeparateLines off; toggleShowStates on; toggleAutoWCharNames on; toggleAutoTaxonNames off; toggleShowDefaultCharNames off; toggleConstrainCW on; setColumnWidth 70; toggleBirdsEye off; toggleAllowAutosize on; toggleColorsPanel off; toggleDiagonal on; setDiagonalHeight 80; toggleLinkedScrolling on; toggleScrollLinkedTables off; endTell; hideWindow; getEmployee #mesquite.charMatrices.ColorCells.ColorCells; tell It; setColor Red; removeColor off; endTell; getEmployee #mesquite.categ.StateNamesStrip.StateNamesStrip; tell It; showStrip off; endTell; getEmployee #mesquite.charMatrices.AnnotPanel.AnnotPanel; tell It; togglePanel off; endTell; getEmployee #mesquite.charMatrices.CharReferenceStrip.CharReferenceStrip; tell It; showStrip off; endTell; getEmployee #mesquite.charMatrices.QuickKeySelector.QuickKeySelector; tell It; autotabOff; endTell; getEmployee #mesquite.categ.SmallStateNamesEditor.SmallStateNamesEditor; tell It; panelOpen true; endTell; endTell; showExtraDataWindow #2565950173085067248 #mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindowMaker; tell It; getWindow; tell It; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; setSize 1123 867; setLocation 1440 0; setFont SanSerif; setFontSize 10; getToolPalette; tell It; setTool mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindow.ibeam; endTell; setTool mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindow.ibeam; colorCells #mesquite.charMatrices.NoColor.NoColor; colorRowNames #mesquite.charMatrices.TaxonGroupColor.TaxonGroupColor; colorColumnNames #mesquite.charMatrices.CharGroupColor.CharGroupColor; colorText #mesquite.charMatrices.NoColor.NoColor; setBackground White; toggleShowNames on; toggleShowTaxonNames on; toggleTight off; toggleThinRows off; toggleShowChanges on; toggleSeparateLines off; toggleShowStates on; toggleAutoWCharNames on; toggleAutoTaxonNames off; toggleShowDefaultCharNames off; toggleConstrainCW on; toggleBirdsEye off; toggleAllowAutosize on; toggleColorsPanel off; toggleDiagonal on; setDiagonalHeight 80; toggleLinkedScrolling on; toggleScrollLinkedTables off; getInfoPanel; tell It; btspOpen true; apOpen true; fpOpen true; endTell; toggleInfoPanel off; endTell; showWindow; getWindow; tell It; forceAutosize; endTell; getEmployee #mesquite.charMatrices.ColorCells.ColorCells; tell It; setColor Red; removeColor off; endTell; getEmployee #mesquite.categ.StateNamesEditor.StateNamesEditor; tell It; makeWindow; tell It; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; setSize 1123 867; setLocation 1440 0; setFont SanSerif; setFontSize 10; getToolPalette; tell It; setTool mesquite.categ.StateNamesEditor.StateNamesWindow.ibeam; endTell; setActive; rowsAreCharacters on; toggleConstrainChar on; toggleConstrainCharNum 3; togglePanel off; toggleSummaryPanel off; endTell; showWindow; endTell; getEmployee #mesquite.categ.StateNamesStrip.StateNamesStrip; tell It; showStrip off; endTell; getEmployee #mesquite.charMatrices.AnnotPanel.AnnotPanel; tell It; togglePanel off; endTell; getEmployee #mesquite.charMatrices.CharReferenceStrip.CharReferenceStrip; tell It; showStrip off; endTell; getEmployee #mesquite.charMatrices.QuickKeySelector.QuickKeySelector; tell It; autotabOff; endTell; getEmployee #mesquite.categ.SmallStateNamesEditor.SmallStateNamesEditor; tell It; panelOpen true; endTell; endTell; endTell; getEmployee #mesquite.charMatrices.ManageCharacters.ManageCharacters; tell It; showCharacters #2565950173085067248 #mesquite.lists.CharacterList.CharacterList; tell It; setData 0; getWindow; tell It; newAssistant #mesquite.lists.DefaultCharOrder.DefaultCharOrder; newAssistant #mesquite.lists.CharListInclusion.CharListInclusion; newAssistant #mesquite.lists.CharListPartition.CharListPartition; newAssistant #mesquite.stochchar.CharListProbModels.CharListProbModels; getTable; tell It; columnWidth 1 101; endTell; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; setSize 1123 867; setLocation 1440 0; setFont SanSerif; setFontSize 10; getToolPalette; tell It; setTool mesquite.lists.CharacterList.CharacterListWindow.arrow; endTell; endTell; showWindow; getEmployee #mesquite.lists.CharListAnnotPanel.CharListAnnotPanel; tell It; togglePanel off; endTell; endTell; endTell; endTell; end; begin brownie; taxset all = 1 -18; END; phylobase/inst/nexusfiles/MultiLineTrees.nex0000644000176200001440000000505214553646170021040 0ustar liggesusers#NEXUS Begin trees; Translate 1 Acorus, 2 Protarum, 3 Biarum, 4 Helicodiceros, 5 Eminium, 6 Dracunculus, 7 Pinellia, 8 Peltandra, 9 Steudnera, 10 Remusatia, 11 Colocasia, 12 Arum, 13 Callopsis, 14 Spathicarpa, 15 Dieffenbachia, 16 Dracontium, 17 Anaphyllopsis, 18 Gonatopus, 19 Epipremnum, 20 Scindapsus, 21 Anadendrum, 22 Stenospermation, 23 Monstera, 24 Rhodospatha, 25 Holochlamys, 26 Heteropsis, 27 Amydrium, 28 Rhaphidophora, 29 Spathiphyllum, 30 Pothos, 31 Anthurium, 32 Cercestis, 33 Aglaonema1, 34 Montrichardia, 35 Philodendron, 36 Anubias, 37 Nephthytis, 38 Rhektophyllum, 39 Anchomanes, 40 Typhonodorum, 41 Typhonium, 42 Spirodela, 43 Landoltia, 44 Asterostigma, 45 Zantedeschia, 46 Calla, 47 Schismatoglottis, 48 Zamioculcas, 49 Culcasia, 50 Cyrtosperma, 51 Aglaonema, 52 Scaphispatha, 53 Chlorospatha, 54 Arophyton, 55 Jasarum, 56 Caladium, 57 Xanthosoma, 58 Hapaline, 59 Ambrosina, 60 Alocasia, 61 Pistia, 62 Homalomena, 63 Amorphophallus, 64 Alloschemone, 65 Arisaema, 66 Symplocarpus, 67 Orontium, 68 Lysichiton, 69 Gymnostachys ; tree PAUP_1 = [&U] (1:70,((((((((((((((((((((2:4,(((3:0,((4:1,12:0):0,(5:2,6:0):1):0):2,7:7):1, ((9:1,10:0):1,11:0):1):0):2,61:13):0,(60:3,65:4):1):1,41:3):5,59:20):1,8:4):0,40:8):4, ((((52:5,(53:2,54:6):6):2,58:7):1,((55:4,57:4):0,56:2):2):3,63:6):1):11,((32:2,37:1):3, (33:1,51:0):2):3):1,(35:0,62:2):9):1,34:9):3,(13:5,45:13):4):0,(36:5,(38:0,39:0):4):1):2, ((14:7,15:10):6,44:13):10):4,(46:17,47:6):3):3,(((16:1,17:1):0,50:1):13,(18:2,48:5):2):3):1,49:8):6, ((((19:4,20:1):1,(((21:4,(23:2,(25:5,29:3):3):0):1,28:2):0,27:2):0):1,(((22:3,64:11):0,26:3):1, 24:2):1):7,(30:6,31:31):4):11):11,(42:11,43:14):20):38,(69:17,((66:3,68:3):1,67:0):12):1):36); tree PAUP_2 = [&U] (1:70,((((((((((((((((((((2:4,(((3:0,((4:1,12:0):0,(5:2,6:0):1):0):2,7:7):1, ((9:1,10:0):1,11:0):1):0):2,61:13):0,(60:3,65:4):1):1,41:3):5,59:20):1,8:4):0,40:8):4, ((((52:5,(53:2,54:6):6):2,58:7):1,((55:4,57:4):0,56:2):2):3,63:6):1):11,((32:2,37:1):3, (33:1,51:0):2):3):1,(35:0,62:2):9):1,34:9):3,(13:5,45:13):4):0,(36:5,(38:0,39:0):4):1):2, ((14:7,15:10):6,44:13):10):4,(46:17,47:6):3):3,(((16:1,17:1):0,50:1):13,(18:2,48:5):2):3):1,49:8):6, ((((19:4,20:1):1,(((21:4,(23:2,(25:5,29:3):3):0):1,28:2):0,27:2):0):1,(((22:3,64:11):0,26:3):1, 24:2):1):7,(30:6,31:31):4):11):11,(42:11,43:14):20):38,(69:17,((66:3,68:3):1,67:0):12):1):36); End; phylobase/inst/nexusfiles/shorebird_underscore.nex0000644000176200001440000002642314553646170022352 0ustar liggesusers#NEXUS [Data from Gavin Thomas] BEGIN TAXA; DIMENSIONS NTAX = 71; TAXLABELS Catoptrophorus_semipalmatus Tringa_ochropus Tringa_stagnatilis Tringa_flavipes Tringa_nebularia Tringa_totanus Tringa_erythropus Tringa_melanoleuca Tringa_glareola Steganopus_tricolor Phalaropus_lobatus Phalaropus_fulicaria Micropalama_himantopus Eurynorhynchus_pygmeus Aphriza_virgata Calidris_canutus Calidris_tenuirostris Calidris_temminckii Calidris_maritima Calidris_ptilocnemis Calidris_mauri Calidris_alba Calidris_alpina Calidris_bairdii Calidris_minutilla Calidris_pusilla Calidris_minuta Calidris_ruficollis Calidris_subminuta Arenaria_interpres Arenaria_melanocephala Tringa_hypoleucos Tringa_macularia Limnodromus_griseus Gallinago_gallinago Coenocorypha_aucklandica Coenocorypha_pusilla Limosa_fedoa Limosa_haemastica Limosa_limosa Limosa_lapponica Bartramia_longicauda Numenius_tahitiensis Numenius_phaeopus Numenius_arquata Numenius_americanus Rostratula_benghalensis Jacana_spinosa Jacana_jacana Metopidius_indicus Actophilornis_africanus Pedionomus_torquatus Pluvialis_apricaria Pluvialis_dominica Eudromias_morinellus Charadrius_montanus Charadrius_vociferus Charadrius_wilsonia Charadrius_dubius Charadrius_hiaticula Charadrius_melodus Vanellus_vanellus Vanellus_lugubris Vanellus_armatus Recurvirostra_avosetta Haematopus_longirostris Haematopus_fuliginosus Haematopus_moquini Haematopus_ostralegus Haematopus_unicolor Haematopus_finschi ; END; BEGIN CHARACTERS; TITLE MassClutchSize; DIMENSIONS NCHAR=4; FORMAT DATATYPE = CONTINUOUS; CHARSTATELABELS 1 malemass, 2 femalemass, 3 eggmass, 4 clutchsize; MATRIX Actophilornis_africanus 143.2 260.7 8.6 4.00 Aphriza_virgata 186.3 216.3 22.4 4.00 Arenaria_interpres 108.0 113.0 17.9 3.50 Arenaria_melanocephala 113.6 124.2 17.3 4.00 Bartramia_longicauda 151.0 164.0 23.5 3.99 Calidris_alba 52.8 55.4 11.2 3.90 Calidris_alpina 41.0 45.1 10.7 3.90 Calidris_bairdii 39.3 39.7 9.6 4.00 Calidris_canutus 126.0 148.0 19.3 3.70 Calidris_maritima 67.6 76.3 13.3 3.90 Calidris_mauri 28.0 31.0 7.5 3.90 Calidris_minuta 24.0 27.1 6.3 3.80 Calidris_minutilla 20.3 22.2 6.4 3.90 Calidris_ptilocnemis 76.3 83.0 14.2 4.00 Calidris_pusilla 25.0 27.0 6.9 4.00 Calidris_ruficollis 25.7 26.6 8.3 4.00 Calidris_subminuta 29.0 32.0 7.5 4.00 Calidris_temminckii 24.3 27.8 5.8 4.00 Calidris_tenuirostris 156.0 174.0 22.0 4.00 Catoptrophorus_semipalmatus 273.0 301.4 39.5 4.00 Charadrius_dubius 38.3 39.2 7.7 3.90 Charadrius_hiaticula 63.5 64.7 10.9 3.80 Charadrius_melodus 54.9 55.6 9.4 3.30 Charadrius_montanus 102.0 114.0 16.5 3.00 Charadrius_vociferus 92.1 101.0 14.5 4.00 Charadrius_wilsonia 59.0 63.0 12.4 3.00 Coenocorypha_aucklandica 101.2 116.1 23.7 2.00 Coenocorypha_pusilla 75.9 85.4 16.1 2.10 Eudromias_morinellus 100.0 117.0 17.0 2.90 Eurynorhynchus_pygmeus 31.0 34.6 8.0 4.00 Gallinago_gallinago 111.0 128.0 16.5 3.90 Haematopus_finschi 517.0 554.0 44.2 2.33 Haematopus_fuliginosus 740.3 778.5 69.5 2.00 Haematopus_longirostris 602.3 626.3 49.0 2.50 Haematopus_moquini 668.0 730.0 55.8 1.70 Haematopus_ostralegus 500.0 536.0 46.7 2.80 Haematopus_unicolor 717.0 734.0 48.2 2.40 Jacana_jacana 108.3 142.8 9.7 3.50 Jacana_spinosa 86.9 145.4 8.3 4.00 Limnodromus_griseus 111.0 116.0 17.5 4.10 Limosa_fedoa 320.0 421.0 44.5 4.10 Limosa_haemastica 222.0 289.0 37.5 4.00 Limosa_lapponica 313.0 354.0 37.0 3.72 Limosa_limosa 264.0 315.0 39.0 3.90 Metopidius_indicus 176.2 282.4 11.9 4.00 Micropalama_himantopus 55.8 60.4 11.2 3.90 Numenius_americanus 640.1 758.6 73.0 4.00 Numenius_arquata 662.0 788.0 76.0 3.90 Numenius_phaeopus 368.0 398.0 50.0 3.90 Numenius_tahitiensis 378.0 489.0 54.8 4.00 Pedionomus_torquatus 54.0 72.4 10.0 3.60 Phalaropus_fulicaria 50.8 61.0 7.5 3.80 Phalaropus_lobatus 32.4 37.4 6.3 4.00 Pluvialis_apricaria 175.0 176.0 32.8 3.90 Pluvialis_dominica 145.0 146.0 26.0 4.00 Recurvirostra_avosetta 258.0 288.0 31.7 3.90 Rostratula_benghalensis 146.0 159.0 12.4 4.00 Steganopus_tricolor 50.2 68.1 9.4 4.00 Tringa_erythropus 142.0 161.0 24.5 4.00 Tringa_flavipes 80.0 83.7 17.4 4.00 Tringa_glareola 62.0 73.0 13.5 4.00 Tringa_hypoleucos 45.5 50.0 12.5 3.90 Tringa_macularia 36.9 48.0 9.0 4.00 Tringa_melanoleuca 164.0 176.0 27.9 3.70 Tringa_nebularia 172.0 175.0 30.5 3.90 Tringa_ochropus 75.0 85.0 15.5 3.90 Tringa_stagnatilis 67.1 76.0 14.0 4.00 Tringa_totanus 123.0 135.0 22.3 4.00 Vanellus_armatus 162.0 167.0 16.5 3.10 Vanellus_lugubris 109.5 113.0 13.7 3.00 Vanellus_vanellus 211.0 226.0 25.5 3.90 ; END; BEGIN CHARACTERS; TITLE MatingSystem; DIMENSIONS NCHAR=1; FORMAT DATATYPE = STANDARD SYMBOLS="0 1 2"; CHARSTATELABELS 1 matingSystem / Monogamous Polygynous Polyandrous; MATRIX Actophilornis_africanus 2 Aphriza_virgata 0 Arenaria_interpres 0 Arenaria_melanocephala 0 Bartramia_longicauda 0 Calidris_alba 2 Calidris_alpina 0 Calidris_bairdii 0 Calidris_canutus 0 Calidris_maritima 0 Calidris_mauri 0 Calidris_minuta 2 Calidris_minutilla 0 Calidris_ptilocnemis 0 Calidris_pusilla 0 Calidris_ruficollis 0 Calidris_subminuta 0 Calidris_temminckii 2 Calidris_tenuirostris 0 Catoptrophorus_semipalmatus 0 Charadrius_dubius 0 Charadrius_hiaticula 0 Charadrius_melodus 0 Charadrius_montanus 2 Charadrius_vociferus 0 Charadrius_wilsonia 0 Coenocorypha_aucklandica 1 Coenocorypha_pusilla 0 Eudromias_morinellus 2 Eurynorhynchus_pygmeus 0 Gallinago_gallinago 0 Haematopus_finschi 0 Haematopus_fuliginosus 0 Haematopus_longirostris 0 Haematopus_moquini 0 Haematopus_ostralegus 0 Haematopus_unicolor 0 Jacana_jacana 2 Jacana_spinosa 2 Limnodromus_griseus 0 Limosa_fedoa 0 Limosa_haemastica 0 Limosa_lapponica 0 Limosa_limosa 0 Metopidius_indicus 2 Micropalama_himantopus 0 Numenius_americanus 0 Numenius_arquata 0 Numenius_phaeopus 0 Numenius_tahitiensis 0 Pedionomus_torquatus 2 Phalaropus_fulicaria 2 Phalaropus_lobatus 2 Pluvialis_apricaria 0 Pluvialis_dominica 0 Recurvirostra_avosetta 0 Rostratula_benghalensis 2 Steganopus_tricolor 2 Tringa_erythropus 0 Tringa_flavipes 0 Tringa_glareola 0 Tringa_hypoleucos 0 Tringa_macularia 2 Tringa_melanoleuca 0 Tringa_nebularia 0 Tringa_ochropus 0 Tringa_stagnatilis 0 Tringa_totanus 0 Vanellus_armatus 0 Vanellus_lugubris 0 Vanellus_vanellus 1 ; END; BEGIN TREES; TRANSLATE 1 Catoptrophorus_semipalmatus, 2 Tringa_ochropus, 3 Tringa_stagnatilis, 4 Tringa_flavipes, 5 Tringa_nebularia, 6 Tringa_totanus, 7 Tringa_erythropus, 8 Tringa_melanoleuca, 9 Tringa_glareola, 10 Steganopus_tricolor, 11 Phalaropus_lobatus, 12 Phalaropus_fulicaria, 13 Micropalama_himantopus, 14 Eurynorhynchus_pygmeus, 15 Aphriza_virgata, 16 Calidris_canutus, 17 Calidris_tenuirostris, 18 Calidris_temminckii, 19 Calidris_maritima, 20 Calidris_ptilocnemis, 21 Calidris_mauri, 22 Calidris_alba, 23 Calidris_alpina, 24 Calidris_bairdii, 25 Calidris_minutilla, 26 Calidris_pusilla, 27 Calidris_minuta, 28 Calidris_ruficollis, 29 Calidris_subminuta, 30 Arenaria_interpres, 31 Arenaria_melanocephala, 32 Tringa_hypoleucos, 33 Tringa_macularia, 34 Limnodromus_griseus, 35 Gallinago_gallinago, 36 Coenocorypha_aucklandica, 37 Coenocorypha_pusilla, 38 Limosa_fedoa, 39 Limosa_haemastica, 40 Limosa_limosa, 41 Limosa_lapponica, 42 Bartramia_longicauda, 43 Numenius_tahitiensis, 44 Numenius_phaeopus, 45 Numenius_arquata, 46 Numenius_americanus, 47 Rostratula_benghalensis, 48 Jacana_spinosa, 49 Jacana_jacana, 50 Metopidius_indicus, 51 Actophilornis_africanus, 52 Pedionomus_torquatus, 53 Pluvialis_apricaria, 54 Pluvialis_dominica, 55 Eudromias_morinellus, 56 Charadrius_montanus, 57 Charadrius_vociferus, 58 Charadrius_wilsonia, 59 Charadrius_dubius, 60 Charadrius_hiaticula, 61 Charadrius_melodus, 62 Vanellus_vanellus, 63 Vanellus_lugubris, 64 Vanellus_armatus, 65 Recurvirostra_avosetta, 66 Haematopus_longirostris, 67 Haematopus_fuliginosus, 68 Haematopus_moquini, 69 Haematopus_ostralegus, 70 Haematopus_unicolor, 71 Haematopus_finschi ; TREE * UNTITLED = [&R] ((((((((1:19.701,(2:19.086,((3:13.762,4:13.762,5:13.762,6:13.762,(7:5.324,8:5.324):8.438):3.114,9:16.876):2.21):0.615):2.499,(10:3.42,(11:2.158,12:2.158):1.262):18.78):9.9,((13:17.413,14:17.413,(15:6.019,(16:3.798,17:3.798):2.221):11.394,(18:10.013,((19:2.588,20:2.588):6.989,(21:9.142,(22:8.707,((23:7.836,(24:7.4,(25:6.965,(26:3.483,27:3.483):3.482):0.435):0.436):0.435,(28:2.609,29:2.609):5.662):0.436):0.435):0.435):0.436):7.4):9.287,(30:5.68,31:5.68):21.02):5.4,(32:5.779,33:5.779):26.320999):2.3,(34:23.8,(35:22.8,(36:4.91,37:4.91):17.889999):1):10.6):2.6,(38:11.739,(39:9.303,(40:5.869,41:5.869):3.434):2.436):25.261):13.4,(42:20.299,(43:14.869,(44:10.15,(45:6.404,46:6.404):3.746):4.719):5.43):30.101):13.4,((47:43.3,((48:10.8,49:10.8):21.6,(50:19.845,51:19.845):12.555):10.9):8.8,52:52.099999):11.7):18.072,(((53:8.33,54:8.33):23.437001,((55:26.700001,(56:22.991999,((57:5.548,58:5.548):10.027,(59:12.882,(60:8.793,61:8.793):4.089):2.693):7.417):3.708):3,(62:22.961,63:22.960999,64:22.961):6.739):2.067):1.033,(65:19.1,(66:14.817,(67:12.849,(68:11.072,(69:4.283,70:4.283):6.789,71:11.072):1.777):1.968):4.283):13.7):49.071998); END; phylobase/inst/nexusfiles/minSeq.nex0000644000176200001440000000023514553646170017365 0ustar liggesusers#NEXUS begin data; dimensions ntax=3 nchar=4; format datatype=dna missing=?; matrix seq1 atcg seq2 tcga seq3 cgat ; end; phylobase/inst/nexusfiles/newick.tre0000644000176200001440000000002614553646170017407 0ustar liggesusers(a:1,(b:2,c:3)xx:4)yy;phylobase/inst/nexusfiles/NastyLabels2.nex0000644000176200001440000002100014553646170020425 0ustar liggesusers#NEXUS begin data; dimensions ntax=17 nchar=432; format datatype=dna missing=?; matrix 'h uman' ctgactcctgaggagaagtctgccgttactgccctgtggggcaaggtgaacgtggatgaagttggtggtgaggccctgggcaggctgctggtggtctacccttggacccagaggttctttgagtcctttggggatctgtccactcctgatgctgttatgggcaaccctaaggtgaaggctcatggcaagaaagtgctcggtgcctttagtgatggcctggctcacctggacaacctcaagggcacctttgccacactgagtgagctgcactgtgacaagctgcacgtggatcctgagaacttcaggctcctgggcaacgtgctggtctgtgtgctggcccatcactttggcaaagaattcaccccaccagtgcaggctgcctatcagaaagtggtggctggtgtggctaatgccctggcccacaagtatcac t_arsier ctgactgctgaagagaaggccgccgtcactgccctgtggggcaaggtagacgtggaagatgttggtggtgaggccctgggcaggctgctggtcgtctacccatggacccagaggttctttgactcctttggggacctgtccactcctgccgctgttatgagcaatgctaaggtcaaggcccatggcaaaaaggtgctgaacgcctttagtgacggcatggctcatctggacaacctcaagggcacctttgctaagctgagtgagctgcactgtgacaaattgcacgtggatcctgagaatttcaggctcttgggcaatgtgctggtgtgtgtgctggcccaccactttggcaaagaattcaccccgcaggttcaggctgcctatcagaaggtggtggctggtgtggctactgccttggctcacaagtaccac 'b_ushbaby' ctgactcctgatgagaagaatgccgtttgtgccctgtggggcaaggtgaatgtggaagaagttggtggtgaggccctgggcaggctgctggttgtctacccatggacccagaggttctttgactcctttggggacctgtcctctccttctgctgttatgggcaaccctaaagtgaaggcccacggcaagaaggtgctgagtgcctttagcgagggcctgaatcacctggacaacctcaagggcacctttgctaagctgagtgagctgcattgtgacaagctgcacgtggaccctgagaacttcaggctcctgggcaacgtgctggtggttgtcctggctcaccactttggcaaggatttcaccccacaggtgcaggctgcctatcagaaggtggtggctggtgtggctactgccctggctcacaaataccac 'ha re' ctgtccggtgaggagaagtctgcggtcactgccctgtggggcaaggtgaatgtggaagaagttggtggtgagaccctgggcaggctgctggttgtctacccatggacccagaggttcttcgagtcctttggggacctgtccactgcttctgctgttatgggcaaccctaaggtgaaggctcatggcaagaaggtgctggctgccttcagtgagggtctgagtcacctggacaacctcaaaggcaccttcgctaagctgagtgaactgcattgtgacaagctgcacgtggatcctgagaacttcaggctcctgggcaacgtgctggttattgtgctgtctcatcactttggcaaagaattcactcctcaggtgcaggctgcctatcagaaggtggtggctggtgtggccaatgccctggctcacaaataccac 'ra\bbit' ctgtccagtgaggagaagtctgcggtcactgccctgtggggcaaggtgaatgtggaagaagttggtggtgaggccctgggcaggctgctggttgtctacccatggacccagaggttcttcgagtcctttggggacctgtcctctgcaaatgctgttatgaacaatcctaaggtgaaggctcatggcaagaaggtgctggctgccttcagtgagggtctgagtcacctggacaacctcaaaggcacctttgctaagctgagtgaactgcactgtgacaagctgcacgtggatcctgagaacttcaggctcctgggcaacgtgctggttattgtgctgtctcatcattttggcaaagaattcactcctcaggtgcaggctgcctatcagaaggtggtggctggtgtggccaatgccctggctcacaaataccac 'co''w' ctgactgctgaggagaaggctgccgtcaccgccttttggggcaaggtgaaagtggatgaagttggtggtgaggccctgggcaggctgctggttgtctacccctggactcagaggttctttgagtcctttggggacttgtccactgctgatgctgttatgaacaaccctaaggtgaaggcccatggcaagaaggtgctagattcctttagtaatggcatgaagcatctcgatgacctcaagggcacctttgctgcgctgagtgagctgcactgtgataagctgcatgtggatcctgagaacttcaagctcctgggcaacgtgctagtggttgtgctggctcgcaattttggcaaggaattcaccccggtgctgcaggctgactttcagaaggtggtggctggtgtggccaatgccctggcccacagatatcat 'sh"eep' ctgactgctgaggagaaggctgccgtcaccggcttctggggcaaggtgaaagtggatgaagttggtgctgaggccctgggcaggctgctggttgtctacccctggactcagaggttctttgagcactttggggacttgtccaatgctgatgctgttatgaacaaccctaaggtgaaggcccatggcaagaaggtgctagactcctttagtaacggcatgaagcatctcgatgacctcaagggcacctttgctcagctgagtgagctgcactgtgataagctgcacgtggatcctgagaacttcaggctcctgggcaacgtgctggtggttgtgctggctcgccaccatggcaatgaattcaccccggtgctgcaggctgactttcagaaggtggtggctggtgttgccaatgccctggcccacaaatatcac pig ctgtctgctgaggagaaggaggccgtcctcggcctgtggggcaaagtgaatgtggacgaagttggtggtgaggccctgggcaggctgctggttgtctacccctggactcagaggttcttcgagtcctttggggacctgtccaatgccgatgccgtcatgggcaatcccaaggtgaaggcccacggcaagaaggtgctccagtccttcagtgacggcctgaaacatctcgacaacctcaagggcacctttgctaagctgagcgagctgcactgtgaccagctgcacgtggatcctgagaacttcaggctcctgggcaacgtgatagtggttgttctggctcgccgccttggccatgacttcaacccgaatgtgcaggctgcttttcagaaggtggtggctggtgttgctaatgccctggcccacaagtaccac elephseal ttgacggcggaggagaagtctgccgtcacctccctgtggggcaaagtgaaggtggatgaagttggtggtgaagccctgggcaggctgctggttgtctacccctggactcagaggttctttgactcctttggggacctgtcctctcctaatgctattatgagcaaccccaaggtcaaggcccatggcaagaaggtgctgaattcctttagtgatggcctgaagaatctggacaacctcaagggcacctttgctaagctcagtgagctgcactgtgaccagctgcatgtggatcccgagaacttcaagctcctgggcaatgtgctggtgtgtgtgctggcccgccactttggcaaggaattcaccccacagatgcagggtgcctttcagaaggtggtagctggtgtggccaatgccctcgcccacaaatatcac rat ctaactgatgctgagaaggctgctgttaatgccctgtggggaaaggtgaaccctgatgatgttggtggcgaggccctgggcaggctgctggttgtctacccttggacccagaggtactttgatagctttggggacctgtcctctgcctctgctatcatgggtaaccctaaggtgaaggcccatggcaagaaggtgataaacgccttcaatgatggcctgaaacacttggacaacctcaagggcacctttgctcatctgagtgaactccactgtgacaagctgcatgtggatcctgagaacttcaggctcctgggcaatatgattgtgattgtgttgggccaccacctgggcaaggaattcaccccctgtgcacaggctgccttccagaaggtggtggctggagtggccagtgccctggctcacaagtaccac mouse ctgactgatgctgagaagtctgctgtctcttgcctgtgggcaaaggtgaaccccgatgaagttggtggtgaggccctgggcaggctgctggttgtctacccttggacccagcggtactttgatagctttggagacctatcctctgcctctgctatcatgggtaatcccaaggtgaaggcccatggcaaaaaggtgataactgcctttaacgagggcctgaaaaacctggacaacctcaagggcacctttgccagcctcagtgagctccactgtgacaagctgcatgtggatcctgagaacttcaggctcctaggcaatgcgatcgtgattgtgctgggccaccacctgggcaaggatttcacccctgctgcacaggctgccttccagaaggtggtggctggagtggccactgccctggctcacaagtaccac hamster ctgactgatgctgagaaggcccttgtcactggcctgtggggaaaggtgaacgccgatgcagttggcgctgaggccctgggcaggttgctggttgtctacccttggacccagaggttctttgaacactttggagacctgtctctgccagttgctgtcatgaataacccccaggtgaaggcccatggcaagaaggtgatccactccttcgctgatggcctgaaacacctggacaacctgaagggcgccttttccagcctgagtgagctccactgtgacaagctgcacgtggatcctgagaacttcaagctcctgggcaatatgatcatcattgtgctgatccacgacctgggcaaggacttcactcccagtgcacagtctgcctttcataaggtggtggctggtgtggccaatgccctggctcacaagtaccac marsupial ttgacttctgaggagaagaactgcatcactaccatctggtctaaggtgcaggttgaccagactggtggtgaggcccttggcaggatgctcgttgtctacccctggaccaccaggttttttgggagctttggtgatctgtcctctcctggcgctgtcatgtcaaattctaaggttcaagcccatggtgctaaggtgttgacctccttcggtgaagcagtcaagcatttggacaacctgaagggtacttatgccaagttgagtgagctccactgtgacaagctgcatgtggaccctgagaacttcaagatgctggggaatatcattgtgatctgcctggctgagcactttggcaaggattttactcctgaatgtcaggttgcttggcagaagctcgtggctggagttgcccatgccctggcccacaagtaccac duck tggacagccgaggagaagcagctcatcaccggcctctggggcaaggtcaatgtggccgactgtggagctgaggccctggccaggctgctgatcgtctacccctggacccagaggttcttcgcctccttcgggaacctgtccagccccactgccatccttggcaaccccatggtccgtgcccatggcaagaaagtgctcacctccttcggagatgctgtgaagaacctggacaacatcaagaacaccttcgcccagctgtccgagctgcactgcgacaagctgcacgtggaccctgagaacttcaggctcctgggtgacatcctcatcatcgtcctggccgcccacttcaccaaggatttcactcctgactgccaggccgcctggcagaagctggtccgcgtggtggcccacgctctggcccgcaagtaccac chicken tggactgctgaggagaagcagctcatcaccggcctctggggcaaggtcaatgtggccgaatgtggggccgaagccctggccaggctgctgatcgtctacccctggacccagaggttctttgcgtcctttgggaacctctccagccccactgccatccttggcaaccccatggtccgcgcccacggcaagaaagtgctcacctcctttggggatgctgtgaagaacctggacaacatcaagaacaccttctcccaactgtccgaactgcattgtgacaagctgcatgtggaccccgagaacttcaggctcctgggtgacatcctcatcattgtcctggccgcccacttcagcaaggacttcactcctgaatgccaggctgcctggcagaagctggtccgcgtggtggcccatgccctggctcgcaagtaccac xenlaev tggacagctgaagagaaggccgccatcacttctgtatggcagaaggtcaatgtagaacatgatggccatgatgccctgggcaggctgctgattgtgtacccctggacccagagatacttcagtaactttggaaacctctccaattcagctgctgttgctggaaatgccaaggttcaagcccatggcaagaaggttctttcagctgttggcaatgccattagccatattgacagtgtgaagtcctctctccaacaactcagtaagatccatgccactgaactgtttgtggaccctgagaactttaagcgttttggtggagttctggtcattgtcttgggtgccaaactgggaactgccttcactcctaaagttcaggctgcttgggagaaattcattgcagttttggttgatggtcttagccagggctataac xentrop tggacagctgaagaaaaagcaaccattgcttctgtgtgggggaaagtcgacattgaacaggatggccatgatgcattatccaggctgctggttgtttatccctggactcagaggtacttcagcagttttggaaacctctccaatgtctccgctgtctctggaaatgtcaaggttaaagcccatggaaataaagtcctgtcagctgttggcagtgcaatccagcatctggatgatgtgaagagccaccttaaaggtcttagcaagagccatgctgaggatcttcatgtggatcccgaaaacttcaagcgccttgcggatgttctggtgatcgttctggctgccaaacttggatctgccttcactccccaagtccaagctgtctgggagaagctcaatgcaactctggtggctgctcttagccatggctacttc ; end; begin mrbayes; [The following block illustrates how to set up two data partitions and use different models for the different partitions.] charset non_coding = 1-90 358-432; charset coding = 91-357; partition region = 2:non_coding,coding; set partition = region; [The following lines set a codon model for the second data partition (coding) and allows the non_coding and coding partitions to have different overall rates.] lset applyto=(2) nucmodel=codon; prset ratepr=variable; [Codon models are computationally complex so the following lines set the parameters of the MCMC such that only 1 chain is run for 100 generations and results are printed to screen and to file every tenth generation. To start this chain, you need to type 'mcmc' after executing this block. You need to run the chain longer to get adequate convergence.] mcmcp ngen=100 nchains=1 printfreq=10 samplefreq=10; end; phylobase/inst/nexusfiles/treeWithDiscAndContData.nex0000644000176200001440000003766714553646170022613 0ustar liggesusers#NEXUS [written Tue May 29 18:24:39 PDT 2007 by Mesquite version 1.06 (build g97) at cnidaria-1347.ucdavis.edu/169.237.66.185] BEGIN TAXA; DIMENSIONS NTAX=18; TAXLABELS Myrmecocystuscfnavajo Myrmecocystuscreightoni Myrmecocystusdepilis Myrmecocystuskathjuli Myrmecocystuskennedyi Myrmecocystusmendax Myrmecocystusmexicanus Myrmecocystusmimicus Myrmecocystusnavajo Myrmecocystusnequazcatl Myrmecocystusplacodops Myrmecocystusromainei Myrmecocystussemirufus Myrmecocystussnellingi Myrmecocystustenuinodis Myrmecocystustestaceus Myrmecocystuswheeleri Myrmecocystusyuma ; END; BEGIN CHARACTERS; TITLE Morphology; DIMENSIONS NCHAR=32; FORMAT DATATYPE = CONTINUOUS; CHARSTATELABELS 1 eyewidth, 2 eyelength, 3 headlength, 4 headwidth, 5 mesosomaprofilehaircount, 6 FLfemurlength, 7 FLtibialength, 8 MLfemurlength, 9 MLtibialength, 10 HLfemurlength, 11 HLtibialength, 12 mesosomalength, 13 scapelength, 14 funiculuslength, 15 mesosomamaxwidth, 16 mesosomaminwidth, 17 lneyewidth, 18 lneyelength, 19 lnheadlength, 20 lnheadwidth, 21 lnmesosomaprofilehaircount, 22 lnFLfemurlength, 23 lnFLtibialength, 24 lnMLfemurlength, 25 lnMLtibialength, 26 lnHLfemurlength, 27 lnHLtibialength, 28 lnmesosomalength, 29 lnscapelength, 30 lnfuniculuslength, 31 lnmesosomamaxwidth, 32 lnmesosomaminwidth ; MATRIX Myrmecocystuscfnavajo 0.347 0.433 1.338 1.052 39.0 1.434 1.246 1.515 1.409 2.007 2.126 1.962 1.63 2.464 0.836 0.417 -1.058430499 -0.837017551 0.291175962 0.050693114 3.663561646 0.360467742 0.21993842 0.415415439 0.342880233 0.69664107 0.75424228 0.673964361 0.488580015 0.901786046 -0.179126666 -0.874669057 Myrmecocystuscreightoni 0.1622 0.20655 0.82985 0.71865 0.0 0.8226 0.68895 0.7854 0.7704 1.0457 1.05835 1.11875 0.89955 1.4073 0.4955 0.28995 -1.819995314 -1.577954034 -0.187439126 -0.332990376 1.098612289 -0.198226599 -0.374805986 -0.242539085 -0.261554411 0.041684897 0.053820826 0.109048315 -0.106449058 0.340231802 -0.70254289 -1.243482504 Myrmecocystusdepilis 0.2345 0.279 1.2125 1.0218 24.0 1.25183 1.0856245 1.31244 1.278025 1.70082 1.77591 1.774585 1.335 2.049 0.7741235 0.438396 -1.453769132 -1.2784033 0.185730051 0.015758636 3.163968392 0.217906079 0.073480925 0.262244849 0.23828925 0.523667061 0.565922636 0.566419189 0.284385731 0.712661014 -0.266387722 -0.827757638 Myrmecocystuskathjuli 0.206 0.247 1.1235 0.951 19.5 1.35352 1.101125 1.39927 1.29104 1.708335 1.794895 1.70561 1.379 2.04 0.7319725 0.4122135 -1.579985164 -1.398768684 0.115861323 -0.05067484 2.890371758 0.299777539 0.092762585 0.334283576 0.252849066 0.529578184 0.581198779 0.53251657 0.319877422 0.710946449 -0.315164554 -0.88802496 Myrmecocystuskennedyi 0.219 0.277 1.2115 1.075 27.5 1.405 1.176 1.4625 1.456 1.8545 1.9205 1.8345 1.4375 2.1 0.7655 0.455 -1.518693975 -1.283737773 0.191857133 0.072285615 3.314020688 0.339154824 0.16141842 0.379143386 0.373863136 0.615804395 0.650805137 0.606659596 0.362132481 0.741737305 -0.267251876 -0.788424862 Myrmecocystusmendax 0.2721 0.3336 1.558 1.4531 85.0 1.8742 1.6042 1.994 1.935 2.6013 2.6829 2.5963 1.9381 2.9722 1.0311 0.5232 -1.301585633 -1.097812608 0.443402947 0.373699205 4.442651256 0.628181902 0.47262519 0.690142672 0.660107326 0.95601132 0.986898299 0.954087355 0.661708112 1.089302419 0.030626194 -0.647791479 Myrmecocystusmexicanus 0.4335 0.5285 1.602 1.2705 26.5 2.242 1.8555 2.4795 2.2075 3.0705 3.089 2.597 2.211 3.239 0.916 0.394 -0.837335004 -0.642862653 0.466427394 0.227429133 3.275540168 0.796749683 0.612629812 0.902886082 0.785535617 1.116397202 1.124535193 0.952838633 0.792756695 1.172973609 -0.096394475 -0.93952217 Myrmecocystusmimicus 0.2197 0.2733 1.141 1.036 30.0 1.23793 1.027 1.26786 1.1749 1.56482 1.63226 1.67201 1.264 1.881 0.708 0.384 -1.5154923 -1.297185186 0.131905071 0.035367144 3.401197382 0.21344063 0.026641931 0.23733044 0.161183038 0.447770801 0.489965558 0.514026496 0.234281296 0.63180355 -0.345311185 -0.957112726 Myrmecocystusnavajo 0.2805 0.3755 1.0525 0.795 18.5 1.168535 1.0180075 1.16102 1.12958 1.634705 1.65155 1.546225 1.3485 1.954 0.6263965 0.314671 -1.272519447 -0.980051192 0.050015872 -0.230223916 2.90855558 0.153682711 0.016748671 0.148877742 0.121090106 0.491448376 0.501633856 0.434955774 0.298626416 0.669236464 -0.468766381 -1.171358882 Myrmecocystusnequazcatl 0.238 0.295 1.058 1.118 49.0 1.51118 1.1793 1.60672 1.41636 1.95228 1.96042 2.01975 1.477 2.228 0.84806 0.486044 -1.435484605 -1.220779923 0.056380333 0.111541375 3.891820298 0.412890803 0.164921042 0.474194834 0.3480902 0.66899792 0.673158736 0.702973741 0.390013004 0.801104322 -0.164803891 -0.721456124 Myrmecocystusplacodops 0.2805 0.347 1.5425 1.4355 39.5 1.6688 1.474045 1.838315 1.761365 2.349265 2.418685 2.28195 1.8045 2.7645 0.955494 0.484641 -1.271539142 -1.058496944 0.433360292 0.360682154 3.675579114 0.512103438 0.387068202 0.606349823 0.563245783 0.852964487 0.881290662 0.824898518 0.589936973 1.015395403 -0.047278511 -0.724537171 Myrmecocystusromainei 0.229 0.271 1.164 1.067 27.0 1.31488 1.06962 1.369 1.278 1.74 1.78517 1.72 1.346 2.081 0.797 0.421 -1.474033275 -1.305636458 0.151862349 0.064850972 3.295836866 0.273745407 0.067303445 0.314080546 0.245296356 0.553885113 0.579513649 0.542324291 0.297137231 0.732848547 -0.2269006 -0.865122445 Myrmecocystussemirufus 0.2393 0.295 1.3424 1.2826 69.0 1.548 1.3236 1.626 1.611 2.074 2.272 2.0392 1.572 2.3424 0.8935 0.4917 -1.430037284 -1.220779923 0.294459057 0.248889268 4.234106505 0.436963775 0.280355297 0.486123011 0.476855104 0.72947911 0.820660501 0.712557574 0.452348694 0.851176045 -0.112608944 -0.709886505 Myrmecocystussnellingi 0.1626 0.2052 0.786 0.69185 17.0 0.7471 0.5778 0.71195 0.68865 0.95225 0.93645 1.02635 0.83555 1.3684 0.47505 0.2805 -1.819869438 -1.586743338 -0.244666624 -0.374320538 2.83148024 -0.296208766 -0.554168612 -0.349125994 -0.38004857 -0.051854551 -0.071457181 0.020580617 -0.182376816 0.309479365 -0.750825896 -1.272022688 Myrmecocystustenuinodis 0.16695 0.2165 0.80965 0.69565 15.5 0.82035 0.79215 0.82915 0.7881 1.02385 1.0765 1.0843 0.89445 1.37155 0.5079 0.2895 -1.794140731 -1.531128383 -0.212724354 -0.364765146 2.714672815 -0.201043311 -0.233005565 -0.188002646 -0.240303423 0.023136261 0.071803358 0.077801384 -0.1121299 0.313462769 -0.679348936 -1.244818912 Myrmecocystustestaceus 0.271 0.3475 1.0435 0.8825 23.5 1.11074 0.981997 1.145875 1.10783 1.527625 1.55838 1.505275 1.329 2.018 0.6360145 0.288181 -1.305643267 -1.057223576 0.041499168 -0.125900131 3.14578457 0.102786566 -0.021927567 0.135585284 0.099368885 0.423310977 0.441300868 0.408161226 0.283878423 0.701812041 -0.453369253 -1.244254341 Myrmecocystuswheeleri 0.197 0.259 1.153 0.981 32.0 1.34961 1.11238 1.43273 1.26582 1.62673 1.75947 1.77914 1.427 2.058 0.732 0.394545 -1.62455155 -1.350927217 0.142367241 -0.019182819 3.465735903 0.299815662 0.106501864 0.359581715 0.235720134 0.486571865 0.565012627 0.576130101 0.355574338 0.721734637 -0.311974765 -0.930022077 Myrmecocystusyuma 0.189 0.237 0.864 0.809 10.0 0.867184 0.783 0.878905 0.757646 1.0528 1.15593 1.14947 0.932 1.437 0.549142 0.319 -1.666008264 -1.439695138 -0.14618251 -0.211956362 2.302585093 -0.142504099 -0.244622583 -0.129078464 -0.277539021 0.051453282 0.144905215 0.139300967 -0.070422464 0.362557607 -0.599398219 -1.142564176 ; END; BEGIN CHARACTERS; TITLE Foraging; DIMENSIONS NCHAR=2; FORMAT DATATYPE = STANDARD GAP = - MISSING = ? SYMBOLS = " 0 1 2"; CHARSTATELABELS 1 time / diurnal crepuscular nocturnal, 2 subgenus / Endiodioctes Eremnocystus Myrmecocystus ; MATRIX Myrmecocystuscfnavajo 22 Myrmecocystuscreightoni 11 Myrmecocystusdepilis 00 Myrmecocystuskathjuli 00 Myrmecocystuskennedyi 00 Myrmecocystusmendax 00 Myrmecocystusmexicanus 22 Myrmecocystusmimicus 00 Myrmecocystusnavajo 22 Myrmecocystusnequazcatl 00 Myrmecocystusplacodops 00 Myrmecocystusromainei 00 Myrmecocystussemirufus 00 Myrmecocystussnellingi 11 Myrmecocystustenuinodis 11 Myrmecocystustestaceus 12 Myrmecocystuswheeleri 00 Myrmecocystusyuma 11 ; END; BEGIN TREES; TRANSLATE 1 Myrmecocystuscfnavajo, 2 Myrmecocystuscreightoni, 3 Myrmecocystusdepilis, 4 Myrmecocystuskathjuli, 5 Myrmecocystuskennedyi, 6 Myrmecocystusmendax, 7 Myrmecocystusmexicanus, 8 Myrmecocystusmimicus, 9 Myrmecocystusnavajo, 10 Myrmecocystusnequazcatl, 11 Myrmecocystusplacodops, 12 Myrmecocystusromainei, 13 Myrmecocystussemirufus, 14 Myrmecocystussnellingi, 15 Myrmecocystustenuinodis, 16 Myrmecocystustestaceus, 17 Myrmecocystuswheeleri, 18 Myrmecocystusyuma; TREE bestML = (((((((((13:1.724765,11:1.724765):2.926053,6:4.650818):0.689044,(4:1.08387,17:1.08387):4.255993):0.198842,((8:2.708942,3:2.708942):2.027251,((12:2.193845,10:2.193845):2.257581,18:4.451425):0.284767):0.802512):0.506099,5:6.044804):4.524387,2:10.569191):0.836689,(14:2.770378,15:2.770378):8.635503):0.89482,16:12.300701):1.699299,(7:5.724923,(1:2.869547,9:2.869547):2.855375):8.275077); END; BEGIN ASSUMPTIONS; TYPESET * UNTITLED (CHARACTERS = 'Morphology') = Squared: 1 - 32; END; Begin MESQUITE; MESQUITESCRIPTVERSION 2; TITLE AUTO; tell ProjectCoordinator; getEmployee #mesquite.minimal.ManageTaxa.ManageTaxa; tell It; setID 0 9015005506118934442; endTell; getEmployee #mesquite.charMatrices.ManageCharacters.ManageCharacters; tell It; setID 0 2565950173085067248; checksum 0 389122022; setID 1 1161953040649633474; checksum 1 3582198254; endTell; getEmployee #mesquite.charMatrices.BasicDataWindowCoord.BasicDataWindowCoord; tell It; showDataWindow #2565950173085067248 #mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindowMaker; tell It; getWindow; tell It; setSize 420 280; setLocation 400 156; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; endTell; setTool mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindow.arrow; colorCells #mesquite.charMatrices.NoColor.NoColor; setBackground White; toggleShowNames on; toggleTight off; toggleShowChanges on; toggleSeparateLines off; toggleShowStates on; toggleAutoWithCharNames on; toggleShowDefaultCharNames off; toggleConstrainCW on; toggleBirdsEye off; toggleColorsPanel off; birdsEyeWidth 2; toggleLinkedScrolling on; toggleScrollLinkedTables off; endTell; showWindow; getWindow; tell It; forceAutosize; endTell; getEmployee #mesquite.charMatrices.AnnotPanel.AnnotPanel; tell It; togglePanel off; endTell; getEmployee #mesquite.charMatrices.ColorCells.ColorCells; tell It; setColor Red; removeColor off; endTell; endTell; showDataWindow #1161953040649633474 #mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindowMaker; tell It; getWindow; tell It; getTable; tell It; rowNamesWidth 232; endTell; setSize 798 748; setLocation 348 22; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; setTool mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindow.ibeam; endTell; setTool mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindow.ibeam; colorCells #mesquite.charMatrices.NoColor.NoColor; setBackground White; toggleShowNames on; toggleTight off; toggleShowChanges on; toggleSeparateLines off; toggleShowStates on; toggleAutoWithCharNames on; toggleShowDefaultCharNames off; toggleConstrainCW on; toggleBirdsEye off; toggleColorsPanel off; birdsEyeWidth 2; toggleLinkedScrolling on; toggleScrollLinkedTables off; endTell; showWindow; getWindow; tell It; forceAutosize; endTell; getEmployee #mesquite.categ.StateNamesEditor.StateNamesEditor; tell It; makeWindow; tell It; setSize 314 400; setLocation 60 10; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; setTool mesquite.categ.StateNamesEditor.StateNamesWindow.ibeam; endTell; rowsAreCharacters on; toggleConstrainChar on; toggleConstrainCharNum 3; togglePanel off; endTell; showWindow; endTell; getEmployee #mesquite.categ.StateNamesStrip.StateNamesStrip; tell It; showStrip off; endTell; getEmployee #mesquite.charMatrices.AnnotPanel.AnnotPanel; tell It; togglePanel off; endTell; getEmployee #mesquite.charMatrices.ColorCells.ColorCells; tell It; setColor Red; removeColor off; endTell; getEmployee #mesquite.charMatrices.QuickKeySelector.QuickKeySelector; tell It; autotabOff; endTell; endTell; endTell; getEmployee #mesquite.trees.BasicTreeWindowCoord.BasicTreeWindowCoord; tell It; makeTreeWindow #9015005506118934442 #mesquite.trees.BasicTreeWindowMaker.BasicTreeWindowMaker; tell It; setTreeSource #mesquite.trees.StoredTrees.StoredTrees; tell It; setTreeBlock 1; toggleUseWeights off; endTell; setAssignedID 630.1180487973731.4514395117633566598; getTreeWindow; tell It; setSize 520 400; setLocation 60 10; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; endTell; setActive; getTreeDrawCoordinator #mesquite.trees.BasicTreeDrawCoordinator.BasicTreeDrawCoordinator; tell It; suppress; setTreeDrawer #mesquite.trees.DiagonalDrawTree.DiagonalDrawTree; tell It; setEdgeWidth 12; orientUp; getEmployee #mesquite.trees.NodeLocsStandard.NodeLocsStandard; tell It; stretchToggle off; branchLengthsToggle off; toggleScale on; toggleCenter off; toggleEven off; namesAngle ?; endTell; endTell; setBackground White; setBranchColor Black; showNodeNumbers off; labelBranchLengths off; desuppress; getEmployee #mesquite.trees.BasicDrawTaxonNames.BasicDrawTaxonNames; tell It; setColor Black; toggleColorPartition on; toggleShadePartition off; toggleNodeLabels on; toggleShowNames on; endTell; endTell; setTreeNumber 1; useSuggestedSize on; toggleTextOnTree off; newAssistant #mesquite.ancstates.TraceCharacterHistory.TraceCharacterHistory; tell It; suspend ; setDisplayMode #mesquite.ancstates.ShadeStatesOnTree.ShadeStatesOnTree; tell It; toggleLabels off; endTell; setHistorySource #mesquite.ancstates.RecAncestralStates.RecAncestralStates; tell It; getCharacterSource #mesquite.charMatrices.CharSrcCoordObed.CharSrcCoordObed; tell It; setCharacterSource #mesquite.charMatrices.StoredCharacters.StoredCharacters; tell It; setDataSet #1161953040649633474; endTell; endTell; setMethod #mesquite.parsimony.ParsAncestralStates.ParsAncestralStates; tell It; setModelSource #mesquite.parsimony.CurrentParsModels.CurrentParsModels; endTell; endTell; setCharacter 1; toggleShowLegend on; toggleGray off; toggleWeights on; setInitialOffsetX -162; setInitialOffsetY -177; setLegendWidth 142; setLegendHeight 177; resume ; endTell; endTell; showWindow; getEmployee #mesquite.ornamental.BranchNotes.BranchNotes; tell It; setAlwaysOn off; endTell; getEmployee #mesquite.trees.ColorBranches.ColorBranches; tell It; setColor Red; removeColor off; endTell; endTell; endTell; endTell; end; begin brownie; taxset all=1-18; end; phylobase/inst/nexusfiles/minNex.nex0000644000176200001440000000150614553646170017371 0ustar liggesusers#NEXUS BEGIN TAXA; DIMENSIONS NTAX=4; TAXLABELS spA spB spC spD ; END; BEGIN TREES; TRANSLATE 1 spA, 2 spB, 3 spC, 4 spD; TREE testTree = (1,(2,(3,4))); END; BEGIN CHARACTERS; TITLE 'TestContinuous'; DIMENSIONS NCHAR=3; FORMAT DATATYPE = CONTINUOUS; CHARSTATELABELS 1 char1, 2 char2, 3 char3; MATRIX spB 0.21 0.22 0.23 spA 0.11 0.12 0.13 spD 0.41 0.42 0.43 spC 0.31 0.32 0.33 ; END; BEGIN CHARACTERS; TITLE 'TestStd'; DIMENSIONS NCHAR=3; FORMAT DATATYPE = STANDARD MISSING = ? SYMBOLS = "0 1 2"; CHARSTATELABELS 1 char1 / state11 state12 state13, 2 char2 / state21 state22 state23, 3 char3 / state31 state32 state33; MATRIX spA 1 (0 1) ? spB 2 (1 2) 0 spC 0 (0 1 2) 1 spD 1 2 0 ; END; [BEGIN ASSUMPTIONS; EXSET * UNTITLED = 3; END;] phylobase/inst/nexusfiles/NastyLabels.nex0000644000176200001440000000175014553646170020355 0ustar liggesusers#NEXUS [Data from Gavin Thomas] BEGIN TAXA; DIMENSIONS NTAX = 11; TAXLABELS subterraneus Mus_musculus H._sapiens 'H. sapiens #429' 'Fred''s new sp.' 'rusticus (1)' '"shoal bass"' AMNION _23 x21.02 myType ; end; BEGIN CHARACTERS; DIMENSIONS NCHAR=1; FORMAT DATATYPE = STANDARD SYMBOLS="0 1"; CHARSTATELABELS 1 aCharacter / on off; MATRIX subterraneus 0 Mus_musculus 1 H._sapiens 0 'H. sapiens #429' 1 'Fred''s new sp.' 0 'rusticus (1)' 1 '"shoal bass"' 0 AMNION 1 _23 0 x21.02 1 myType 0 ; END; BEGIN TREES; TRANSLATE 1 subterraneus, 2 Mus_musculus, 3 H._sapiens, 4 'H. sapiens #429', 5 'Fred''s new sp.', 6 'rusticus (1)', 7 '"shoal bass"', 8 AMNION, 9 _23, 10 x21.02, 11 myType ; TREE * COMB = (1,(2,(3,(4,(5,(6,(7,(8,(9,(10,11)))))))))); end; phylobase/inst/nexusfiles/co1.nex0000644000176200001440000000156014553646170016615 0ustar liggesusers#NEXUS [ID: 0916634271] begin trees; [Note: This tree contains information on the topology, branch lengths (if present), and the probability of the partition indicated by the branch.] tree con_50_majrule = (Cow:0.143336,Seal:0.225087,((((((Carp:0.171296,Loach:0.222039)1.00:0.194575,Frog:0.237101)0.76:0.073060,Chicken:0.546258)1.00:0.204809,Human:0.533183)0.99:0.124549,(Mouse:0.134574,Rat:0.113163)1.00:0.154442)0.88:0.055934,Whale:0.145592)0.93:0.047441); [Note: This tree contains information only on the topology and branch lengths (mean of the posterior probability density).] tree con_50_majrule = (Cow:0.143336,Seal:0.225087,((((((Carp:0.171296,Loach:0.222039):0.194575,Frog:0.237101):0.073060,Chicken:0.546258):0.204809,Human:0.533183):0.124549,(Mouse:0.134574,Rat:0.113163):0.154442):0.055934,Whale:0.145592):0.047441); end; phylobase/inst/nexusfiles/treeWithContinuousData.nex0000644000176200001440000003623014553646170022611 0ustar liggesusers#NEXUS [written Tue May 29 18:24:39 PDT 2007 by Mesquite version 1.06 (build g97) at cnidaria-1347.ucdavis.edu/169.237.66.185] BEGIN TAXA; DIMENSIONS NTAX=18; TAXLABELS Myrmecocystuscfnavajo Myrmecocystuscreightoni Myrmecocystusdepilis Myrmecocystuskathjuli Myrmecocystuskennedyi Myrmecocystusmendax Myrmecocystusmexicanus Myrmecocystusmimicus Myrmecocystusnavajo Myrmecocystusnequazcatl Myrmecocystusplacodops Myrmecocystusromainei Myrmecocystussemirufus Myrmecocystussnellingi Myrmecocystustenuinodis Myrmecocystustestaceus Myrmecocystuswheeleri Myrmecocystusyuma ; END; BEGIN CHARACTERS; TITLE 'Morphology'; DIMENSIONS NCHAR=32; FORMAT DATATYPE = CONTINUOUS; CHARSTATELABELS 1 eyewidth, 2 eyelength, 3 headlength, 4 headwidth, 5 mesosomaprofilehaircount, 6 FLfemurlength, 7 FLtibialength, 8 MLfemurlength, 9 MLtibialength, 10 HLfemurlength, 11 HLtibialength, 12 mesosomalength, 13 scapelength, 14 funiculuslength, 15 mesosomamaxwidth, 16 mesosomaminwidth, 17 lneyewidth, 18 lneyelength, 19 lnheadlength, 20 lnheadwidth, 21 lnmesosomaprofilehaircount, 22 lnFLfemurlength, 23 lnFLtibialength, 24 lnMLfemurlength, 25 lnMLtibialength, 26 lnHLfemurlength, 27 lnHLtibialength, 28 lnmesosomalength, 29 lnscapelength, 30 lnfuniculuslength, 31 lnmesosomamaxwidth, 32 lnmesosomaminwidth ; MATRIX Myrmecocystuscfnavajo 0.347 0.433 1.338 1.052 39.0 1.434 1.246 1.515 1.409 2.007 2.126 1.962 1.63 2.464 0.836 0.417 -1.058430499 -0.837017551 0.291175962 0.050693114 3.663561646 0.360467742 0.21993842 0.415415439 0.342880233 0.69664107 0.75424228 0.673964361 0.488580015 0.901786046 -0.179126666 -0.874669057 Myrmecocystuscreightoni 0.1622 0.20655 0.82985 0.71865 0.0 0.8226 0.68895 0.7854 0.7704 1.0457 1.05835 1.11875 0.89955 1.4073 0.4955 0.28995 -1.819995314 -1.577954034 -0.187439126 -0.332990376 1.098612289 -0.198226599 -0.374805986 -0.242539085 -0.261554411 0.041684897 0.053820826 0.109048315 -0.106449058 0.340231802 -0.70254289 -1.243482504 Myrmecocystusdepilis 0.2345 0.279 1.2125 1.0218 24.0 1.25183 1.0856245 1.31244 1.278025 1.70082 1.77591 1.774585 1.335 2.049 0.7741235 0.438396 -1.453769132 -1.2784033 0.185730051 0.015758636 3.163968392 0.217906079 0.073480925 0.262244849 0.23828925 0.523667061 0.565922636 0.566419189 0.284385731 0.712661014 -0.266387722 -0.827757638 Myrmecocystuskathjuli 0.206 0.247 1.1235 0.951 19.5 1.35352 1.101125 1.39927 1.29104 1.708335 1.794895 1.70561 1.379 2.04 0.7319725 0.4122135 -1.579985164 -1.398768684 0.115861323 -0.05067484 2.890371758 0.299777539 0.092762585 0.334283576 0.252849066 0.529578184 0.581198779 0.53251657 0.319877422 0.710946449 -0.315164554 -0.88802496 Myrmecocystuskennedyi 0.219 0.277 1.2115 1.075 27.5 1.405 1.176 1.4625 1.456 1.8545 1.9205 1.8345 1.4375 2.1 0.7655 0.455 -1.518693975 -1.283737773 0.191857133 0.072285615 3.314020688 0.339154824 0.16141842 0.379143386 0.373863136 0.615804395 0.650805137 0.606659596 0.362132481 0.741737305 -0.267251876 -0.788424862 Myrmecocystusmendax 0.2721 0.3336 1.558 1.4531 85.0 1.8742 1.6042 1.994 1.935 2.6013 2.6829 2.5963 1.9381 2.9722 1.0311 0.5232 -1.301585633 -1.097812608 0.443402947 0.373699205 4.442651256 0.628181902 0.47262519 0.690142672 0.660107326 0.95601132 0.986898299 0.954087355 0.661708112 1.089302419 0.030626194 -0.647791479 Myrmecocystusmexicanus 0.4335 0.5285 1.602 1.2705 26.5 2.242 1.8555 2.4795 2.2075 3.0705 3.089 2.597 2.211 3.239 0.916 0.394 -0.837335004 -0.642862653 0.466427394 0.227429133 3.275540168 0.796749683 0.612629812 0.902886082 0.785535617 1.116397202 1.124535193 0.952838633 0.792756695 1.172973609 -0.096394475 -0.93952217 Myrmecocystusmimicus 0.2197 0.2733 1.141 1.036 30.0 1.23793 1.027 1.26786 1.1749 1.56482 1.63226 1.67201 1.264 1.881 0.708 0.384 -1.5154923 -1.297185186 0.131905071 0.035367144 3.401197382 0.21344063 0.026641931 0.23733044 0.161183038 0.447770801 0.489965558 0.514026496 0.234281296 0.63180355 -0.345311185 -0.957112726 Myrmecocystusnavajo 0.2805 0.3755 1.0525 0.795 18.5 1.168535 1.0180075 1.16102 1.12958 1.634705 1.65155 1.546225 1.3485 1.954 0.6263965 0.314671 -1.272519447 -0.980051192 0.050015872 -0.230223916 2.90855558 0.153682711 0.016748671 0.148877742 0.121090106 0.491448376 0.501633856 0.434955774 0.298626416 0.669236464 -0.468766381 -1.171358882 Myrmecocystusnequazcatl 0.238 0.295 1.058 1.118 49.0 1.51118 1.1793 1.60672 1.41636 1.95228 1.96042 2.01975 1.477 2.228 0.84806 0.486044 -1.435484605 -1.220779923 0.056380333 0.111541375 3.891820298 0.412890803 0.164921042 0.474194834 0.3480902 0.66899792 0.673158736 0.702973741 0.390013004 0.801104322 -0.164803891 -0.721456124 Myrmecocystusplacodops 0.2805 0.347 1.5425 1.4355 39.5 1.6688 1.474045 1.838315 1.761365 2.349265 2.418685 2.28195 1.8045 2.7645 0.955494 0.484641 -1.271539142 -1.058496944 0.433360292 0.360682154 3.675579114 0.512103438 0.387068202 0.606349823 0.563245783 0.852964487 0.881290662 0.824898518 0.589936973 1.015395403 -0.047278511 -0.724537171 Myrmecocystusromainei 0.229 0.271 1.164 1.067 27.0 1.31488 1.06962 1.369 1.278 1.74 1.78517 1.72 1.346 2.081 0.797 0.421 -1.474033275 -1.305636458 0.151862349 0.064850972 3.295836866 0.273745407 0.067303445 0.314080546 0.245296356 0.553885113 0.579513649 0.542324291 0.297137231 0.732848547 -0.2269006 -0.865122445 Myrmecocystussemirufus 0.2393 0.295 1.3424 1.2826 69.0 1.548 1.3236 1.626 1.611 2.074 2.272 2.0392 1.572 2.3424 0.8935 0.4917 -1.430037284 -1.220779923 0.294459057 0.248889268 4.234106505 0.436963775 0.280355297 0.486123011 0.476855104 0.72947911 0.820660501 0.712557574 0.452348694 0.851176045 -0.112608944 -0.709886505 Myrmecocystussnellingi 0.1626 0.2052 0.786 0.69185 17.0 0.7471 0.5778 0.71195 0.68865 0.95225 0.93645 1.02635 0.83555 1.3684 0.47505 0.2805 -1.819869438 -1.586743338 -0.244666624 -0.374320538 2.83148024 -0.296208766 -0.554168612 -0.349125994 -0.38004857 -0.051854551 -0.071457181 0.020580617 -0.182376816 0.309479365 -0.750825896 -1.272022688 Myrmecocystustenuinodis 0.16695 0.2165 0.80965 0.69565 15.5 0.82035 0.79215 0.82915 0.7881 1.02385 1.0765 1.0843 0.89445 1.37155 0.5079 0.2895 -1.794140731 -1.531128383 -0.212724354 -0.364765146 2.714672815 -0.201043311 -0.233005565 -0.188002646 -0.240303423 0.023136261 0.071803358 0.077801384 -0.1121299 0.313462769 -0.679348936 -1.244818912 Myrmecocystustestaceus 0.271 0.3475 1.0435 0.8825 23.5 1.11074 0.981997 1.145875 1.10783 1.527625 1.55838 1.505275 1.329 2.018 0.6360145 0.288181 -1.305643267 -1.057223576 0.041499168 -0.125900131 3.14578457 0.102786566 -0.021927567 0.135585284 0.099368885 0.423310977 0.441300868 0.408161226 0.283878423 0.701812041 -0.453369253 -1.244254341 Myrmecocystuswheeleri 0.197 0.259 1.153 0.981 32.0 1.34961 1.11238 1.43273 1.26582 1.62673 1.75947 1.77914 1.427 2.058 0.732 0.394545 -1.62455155 -1.350927217 0.142367241 -0.019182819 3.465735903 0.299815662 0.106501864 0.359581715 0.235720134 0.486571865 0.565012627 0.576130101 0.355574338 0.721734637 -0.311974765 -0.930022077 Myrmecocystusyuma 0.189 0.237 0.864 0.809 10.0 0.867184 0.783 0.878905 0.757646 1.0528 1.15593 1.14947 0.932 1.437 0.549142 0.319 -1.666008264 -1.439695138 -0.14618251 -0.211956362 2.302585093 -0.142504099 -0.244622583 -0.129078464 -0.277539021 0.051453282 0.144905215 0.139300967 -0.070422464 0.362557607 -0.599398219 -1.142564176 ; END; BEGIN TREES; TRANSLATE 1 Myrmecocystuscfnavajo, 2 Myrmecocystuscreightoni, 3 Myrmecocystusdepilis, 4 Myrmecocystuskathjuli, 5 Myrmecocystuskennedyi, 6 Myrmecocystusmendax, 7 Myrmecocystusmexicanus, 8 Myrmecocystusmimicus, 9 Myrmecocystusnavajo, 10 Myrmecocystusnequazcatl, 11 Myrmecocystusplacodops, 12 Myrmecocystusromainei, 13 Myrmecocystussemirufus, 14 Myrmecocystussnellingi, 15 Myrmecocystustenuinodis, 16 Myrmecocystustestaceus, 17 Myrmecocystuswheeleri, 18 Myrmecocystusyuma; TREE bestML = (((((((((13:1.724765,11:1.724765):2.926053,6:4.650818):0.689044,(4:1.08387,17:1.08387):4.255993):0.198842,((8:2.708942,3:2.708942):2.027251,((12:2.193845,10:2.193845):2.257581,18:4.451425):0.284767):0.802512):0.506099,5:6.044804):4.524387,2:10.569191):0.836689,(14:2.770378,15:2.770378):8.635503):0.89482,16:12.300701):1.699299,(7:5.724923,(1:2.869547,9:2.869547):2.855375):8.275077); END; BEGIN ASSUMPTIONS; TYPESET * UNTITLED (CHARACTERS = 'Morphology') = Squared: 1 - 32; END; Begin MESQUITE; MESQUITESCRIPTVERSION 2; TITLE AUTO; tell ProjectCoordinator; getEmployee #mesquite.minimal.ManageTaxa.ManageTaxa; tell It; setID 0 9015005506118934442; endTell; getEmployee #mesquite.charMatrices.ManageCharacters.ManageCharacters; tell It; setID 0 2565950173085067248; checksum 0 389122022; setID 1 1161953040649633474; checksum 1 3582198254; endTell; getEmployee #mesquite.charMatrices.BasicDataWindowCoord.BasicDataWindowCoord; tell It; showDataWindow #2565950173085067248 #mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindowMaker; tell It; getWindow; tell It; setSize 420 280; setLocation 400 156; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; endTell; setTool mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindow.arrow; colorCells #mesquite.charMatrices.NoColor.NoColor; setBackground White; toggleShowNames on; toggleTight off; toggleShowChanges on; toggleSeparateLines off; toggleShowStates on; toggleAutoWithCharNames on; toggleShowDefaultCharNames off; toggleConstrainCW on; toggleBirdsEye off; toggleColorsPanel off; birdsEyeWidth 2; toggleLinkedScrolling on; toggleScrollLinkedTables off; endTell; showWindow; getWindow; tell It; forceAutosize; endTell; getEmployee #mesquite.charMatrices.AnnotPanel.AnnotPanel; tell It; togglePanel off; endTell; getEmployee #mesquite.charMatrices.ColorCells.ColorCells; tell It; setColor Red; removeColor off; endTell; endTell; showDataWindow #1161953040649633474 #mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindowMaker; tell It; getWindow; tell It; getTable; tell It; rowNamesWidth 232; endTell; setSize 798 748; setLocation 348 22; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; setTool mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindow.ibeam; endTell; setTool mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindow.ibeam; colorCells #mesquite.charMatrices.NoColor.NoColor; setBackground White; toggleShowNames on; toggleTight off; toggleShowChanges on; toggleSeparateLines off; toggleShowStates on; toggleAutoWithCharNames on; toggleShowDefaultCharNames off; toggleConstrainCW on; toggleBirdsEye off; toggleColorsPanel off; birdsEyeWidth 2; toggleLinkedScrolling on; toggleScrollLinkedTables off; endTell; showWindow; getWindow; tell It; forceAutosize; endTell; getEmployee #mesquite.categ.StateNamesEditor.StateNamesEditor; tell It; makeWindow; tell It; setSize 314 400; setLocation 60 10; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; setTool mesquite.categ.StateNamesEditor.StateNamesWindow.ibeam; endTell; rowsAreCharacters on; toggleConstrainChar on; toggleConstrainCharNum 3; togglePanel off; endTell; showWindow; endTell; getEmployee #mesquite.categ.StateNamesStrip.StateNamesStrip; tell It; showStrip off; endTell; getEmployee #mesquite.charMatrices.AnnotPanel.AnnotPanel; tell It; togglePanel off; endTell; getEmployee #mesquite.charMatrices.ColorCells.ColorCells; tell It; setColor Red; removeColor off; endTell; getEmployee #mesquite.charMatrices.QuickKeySelector.QuickKeySelector; tell It; autotabOff; endTell; endTell; endTell; getEmployee #mesquite.trees.BasicTreeWindowCoord.BasicTreeWindowCoord; tell It; makeTreeWindow #9015005506118934442 #mesquite.trees.BasicTreeWindowMaker.BasicTreeWindowMaker; tell It; setTreeSource #mesquite.trees.StoredTrees.StoredTrees; tell It; setTreeBlock 1; toggleUseWeights off; endTell; setAssignedID 630.1180487973731.4514395117633566598; getTreeWindow; tell It; setSize 520 400; setLocation 60 10; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; endTell; setActive; getTreeDrawCoordinator #mesquite.trees.BasicTreeDrawCoordinator.BasicTreeDrawCoordinator; tell It; suppress; setTreeDrawer #mesquite.trees.DiagonalDrawTree.DiagonalDrawTree; tell It; setEdgeWidth 12; orientUp; getEmployee #mesquite.trees.NodeLocsStandard.NodeLocsStandard; tell It; stretchToggle off; branchLengthsToggle off; toggleScale on; toggleCenter off; toggleEven off; namesAngle ?; endTell; endTell; setBackground White; setBranchColor Black; showNodeNumbers off; labelBranchLengths off; desuppress; getEmployee #mesquite.trees.BasicDrawTaxonNames.BasicDrawTaxonNames; tell It; setColor Black; toggleColorPartition on; toggleShadePartition off; toggleNodeLabels on; toggleShowNames on; endTell; endTell; setTreeNumber 1; useSuggestedSize on; toggleTextOnTree off; newAssistant #mesquite.ancstates.TraceCharacterHistory.TraceCharacterHistory; tell It; suspend ; setDisplayMode #mesquite.ancstates.ShadeStatesOnTree.ShadeStatesOnTree; tell It; toggleLabels off; endTell; setHistorySource #mesquite.ancstates.RecAncestralStates.RecAncestralStates; tell It; getCharacterSource #mesquite.charMatrices.CharSrcCoordObed.CharSrcCoordObed; tell It; setCharacterSource #mesquite.charMatrices.StoredCharacters.StoredCharacters; tell It; setDataSet #1161953040649633474; endTell; endTell; setMethod #mesquite.parsimony.ParsAncestralStates.ParsAncestralStates; tell It; setModelSource #mesquite.parsimony.CurrentParsModels.CurrentParsModels; endTell; endTell; setCharacter 1; toggleShowLegend on; toggleGray off; toggleWeights on; setInitialOffsetX -162; setInitialOffsetY -177; setLegendWidth 142; setLegendHeight 177; resume ; endTell; endTell; showWindow; getEmployee #mesquite.ornamental.BranchNotes.BranchNotes; tell It; setAlwaysOn off; endTell; getEmployee #mesquite.trees.ColorBranches.ColorBranches; tell It; setColor Red; removeColor off; endTell; endTell; endTell; endTell; end; begin brownie; taxset all=1-18; end; phylobase/inst/nexusfiles/treeWithUnderscoreLabels.nex0000644000176200001440000002275014553646170023107 0ustar liggesusers#NEXUS [written Tue May 29 18:24:39 PDT 2007 by Mesquite version 1.06 (build g97) at cnidaria-1347.ucdavis.edu/169.237.66.185] BEGIN TAXA; DIMENSIONS NTAX=18; TAXLABELS Myrmecocystuscfnavajo Myrmecocystus_creightoni Myrmecocystusdepilis Myrmecocystuskathjuli Myrmecocystuskennedyi Myrmecocystusmendax Myrmecocystusmexicanus Myrmecocystusmimicus Myrmecocystusnavajo Myrmecocystusnequazcatl Myrmecocystusplacodops Myrmecocystusromainei Myrmecocystussemirufus Myrmecocystussnellingi Myrmecocystustenuinodis Myrmecocystustestaceus Myrmecocystuswheeleri Myrmecocystusyuma ; END; BEGIN CHARACTERS; TITLE Foraging; DIMENSIONS NCHAR=2; FORMAT DATATYPE = STANDARD GAP = - MISSING = ? SYMBOLS = " 0 1 2"; CHARSTATELABELS 1 time_period / diurnal crepuscular nocturnal, 2 subgenus / Endiodioctes Eremnocystus Myrmecocystus ; MATRIX Myrmecocystuscfnavajo 22 Myrmecocystus_creightoni 11 Myrmecocystusdepilis 00 Myrmecocystuskathjuli 00 Myrmecocystuskennedyi 00 Myrmecocystusmendax 00 Myrmecocystusmexicanus 22 Myrmecocystusmimicus 00 Myrmecocystusnavajo 22 Myrmecocystusnequazcatl 00 Myrmecocystusplacodops 00 Myrmecocystusromainei 00 Myrmecocystussemirufus 00 Myrmecocystussnellingi 11 Myrmecocystustenuinodis 11 Myrmecocystustestaceus 12 Myrmecocystuswheeleri 00 Myrmecocystusyuma 11 ; END; BEGIN TREES; TRANSLATE 1 Myrmecocystuscfnavajo, 2 Myrmecocystus_creightoni, 3 Myrmecocystusdepilis, 4 Myrmecocystuskathjuli, 5 Myrmecocystuskennedyi, 6 Myrmecocystusmendax, 7 Myrmecocystusmexicanus, 8 Myrmecocystusmimicus, 9 Myrmecocystusnavajo, 10 Myrmecocystusnequazcatl, 11 Myrmecocystusplacodops, 12 Myrmecocystusromainei, 13 Myrmecocystussemirufus, 14 Myrmecocystussnellingi, 15 Myrmecocystustenuinodis, 16 Myrmecocystustestaceus, 17 Myrmecocystuswheeleri, 18 Myrmecocystusyuma; TREE bestML = (((((((((13:1.724765,11:1.724765):2.926053,6:4.650818):0.689044,(4:1.08387,17:1.08387):4.255993):0.198842,((8:2.708942,3:2.708942):2.027251,((12:2.193845,10:2.193845):2.257581,18:4.451425):0.284767):0.802512):0.506099,5:6.044804):4.524387,2:10.569191):0.836689,(14:2.770378,15:2.770378):8.635503):0.89482,16:12.300701):1.699299,(7:5.724923,(1:2.869547,9:2.869547):2.855375):8.275077); END; BEGIN ASSUMPTIONS; TYPESET * UNTITLED (CHARACTERS = Foraging) = unord: 1 - 2; END; BEGIN MESQUITECHARMODELS; ProbModelSet * UNTITLED (CHARACTERS = 'Matrix in file "treepluscharV01.nex"') = Browniandefault: 1 - 32; ProbModelSet * UNTITLED (CHARACTERS = Foraging) = 'Mk1 (est.)': 1 - 2; END; Begin MESQUITE; MESQUITESCRIPTVERSION 2; TITLE AUTO; tell ProjectCoordinator; getEmployee #mesquite.minimal.ManageTaxa.ManageTaxa; tell It; setID 0 9015005506118934442; endTell; getEmployee #mesquite.charMatrices.ManageCharacters.ManageCharacters; tell It; setID 0 2565950173085067248; checksum 0 389122022; setID 1 1161953040649633474; checksum 1 3582198254; endTell; getEmployee #mesquite.charMatrices.BasicDataWindowCoord.BasicDataWindowCoord; tell It; showDataWindow #2565950173085067248 #mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindowMaker; tell It; getWindow; tell It; setSize 420 280; setLocation 400 156; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; endTell; setTool mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindow.arrow; colorCells #mesquite.charMatrices.NoColor.NoColor; setBackground White; toggleShowNames on; toggleTight off; toggleShowChanges on; toggleSeparateLines off; toggleShowStates on; toggleAutoWithCharNames on; toggleShowDefaultCharNames off; toggleConstrainCW on; toggleBirdsEye off; toggleColorsPanel off; birdsEyeWidth 2; toggleLinkedScrolling on; toggleScrollLinkedTables off; endTell; showWindow; getWindow; tell It; forceAutosize; endTell; getEmployee #mesquite.charMatrices.AnnotPanel.AnnotPanel; tell It; togglePanel off; endTell; getEmployee #mesquite.charMatrices.ColorCells.ColorCells; tell It; setColor Red; removeColor off; endTell; endTell; showDataWindow #1161953040649633474 #mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindowMaker; tell It; getWindow; tell It; getTable; tell It; rowNamesWidth 232; endTell; setSize 798 748; setLocation 348 22; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; setTool mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindow.ibeam; endTell; setTool mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindow.ibeam; colorCells #mesquite.charMatrices.NoColor.NoColor; setBackground White; toggleShowNames on; toggleTight off; toggleShowChanges on; toggleSeparateLines off; toggleShowStates on; toggleAutoWithCharNames on; toggleShowDefaultCharNames off; toggleConstrainCW on; toggleBirdsEye off; toggleColorsPanel off; birdsEyeWidth 2; toggleLinkedScrolling on; toggleScrollLinkedTables off; endTell; showWindow; getWindow; tell It; forceAutosize; endTell; getEmployee #mesquite.categ.StateNamesEditor.StateNamesEditor; tell It; makeWindow; tell It; setSize 314 400; setLocation 60 10; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; setTool mesquite.categ.StateNamesEditor.StateNamesWindow.ibeam; endTell; rowsAreCharacters on; toggleConstrainChar on; toggleConstrainCharNum 3; togglePanel off; endTell; showWindow; endTell; getEmployee #mesquite.categ.StateNamesStrip.StateNamesStrip; tell It; showStrip off; endTell; getEmployee #mesquite.charMatrices.AnnotPanel.AnnotPanel; tell It; togglePanel off; endTell; getEmployee #mesquite.charMatrices.ColorCells.ColorCells; tell It; setColor Red; removeColor off; endTell; getEmployee #mesquite.charMatrices.QuickKeySelector.QuickKeySelector; tell It; autotabOff; endTell; endTell; endTell; getEmployee #mesquite.trees.BasicTreeWindowCoord.BasicTreeWindowCoord; tell It; makeTreeWindow #9015005506118934442 #mesquite.trees.BasicTreeWindowMaker.BasicTreeWindowMaker; tell It; setTreeSource #mesquite.trees.StoredTrees.StoredTrees; tell It; setTreeBlock 1; toggleUseWeights off; endTell; setAssignedID 630.1180487973731.4514395117633566598; getTreeWindow; tell It; setSize 520 400; setLocation 60 10; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; endTell; setActive; getTreeDrawCoordinator #mesquite.trees.BasicTreeDrawCoordinator.BasicTreeDrawCoordinator; tell It; suppress; setTreeDrawer #mesquite.trees.DiagonalDrawTree.DiagonalDrawTree; tell It; setEdgeWidth 12; orientUp; getEmployee #mesquite.trees.NodeLocsStandard.NodeLocsStandard; tell It; stretchToggle off; branchLengthsToggle off; toggleScale on; toggleCenter off; toggleEven off; namesAngle ?; endTell; endTell; setBackground White; setBranchColor Black; showNodeNumbers off; labelBranchLengths off; desuppress; getEmployee #mesquite.trees.BasicDrawTaxonNames.BasicDrawTaxonNames; tell It; setColor Black; toggleColorPartition on; toggleShadePartition off; toggleNodeLabels on; toggleShowNames on; endTell; endTell; setTreeNumber 1; useSuggestedSize on; toggleTextOnTree off; newAssistant #mesquite.ancstates.TraceCharacterHistory.TraceCharacterHistory; tell It; suspend ; setDisplayMode #mesquite.ancstates.ShadeStatesOnTree.ShadeStatesOnTree; tell It; toggleLabels off; endTell; setHistorySource #mesquite.ancstates.RecAncestralStates.RecAncestralStates; tell It; getCharacterSource #mesquite.charMatrices.CharSrcCoordObed.CharSrcCoordObed; tell It; setCharacterSource #mesquite.charMatrices.StoredCharacters.StoredCharacters; tell It; setDataSet #1161953040649633474; endTell; endTell; setMethod #mesquite.parsimony.ParsAncestralStates.ParsAncestralStates; tell It; setModelSource #mesquite.parsimony.CurrentParsModels.CurrentParsModels; endTell; endTell; setCharacter 1; toggleShowLegend on; toggleGray off; toggleWeights on; setInitialOffsetX -162; setInitialOffsetY -177; setLegendWidth 142; setLegendHeight 177; resume ; endTell; endTell; showWindow; getEmployee #mesquite.ornamental.BranchNotes.BranchNotes; tell It; setAlwaysOn off; endTell; getEmployee #mesquite.trees.ColorBranches.ColorBranches; tell It; setColor Red; removeColor off; endTell; endTell; endTell; endTell; end; begin brownie; taxset all=1-18; end; phylobase/inst/nexusfiles/treeWithSpecialCharacters.nex0000644000176200001440000000124714553646170023231 0ustar liggesusers#NEXUS BEGIN TAXA; DIMENSIONS NTAX=6; TAXLABELS Species_1 'Species 2' 'Species 3' 'Species/4' 'Species\5' 'Species"6' ; END; BEGIN CHARACTERS; TITLE TestCharacters; DIMENSIONS NCHAR=2; FORMAT DATATYPE = STANDARD GAP = - MISSING = ? SYMBOLS = " 0 1"; CHARSTATELABELS 1 character1 / state1.1 'state 1.2', 2 character2 / state2.1 'state 2 2'; MATRIX Species_1 01 'Species 2' 10 'Species 3' 11 'Species/4' 00 'Species\5' 01 'Species"6' ?1 ; END; BEGIN TREES; TRANSLATE 1 Species_1, 2 'Species 2', 3 'Species 3', 4 'Species/4', 5 'Species\5', 6 'Species"6'; TREE tree1 = ((((1,2),3),4),5); END; phylobase/inst/nexusfiles/testSubsetTaxa.nex0000644000176200001440000000066714553646170021125 0ustar liggesusers#NEXUS BEGIN TAXA; DIMENSIONS NTAX=6; TAXLABELS cnidaria porifera ctenophora protostomia deuterostomia xeno ; END; BEGIN TREES; TRANSLATE 1 deuterostomia, 2 protostomia, 3 porifera, 4 ctenophora, 5 cnidaria, 6 xeno; TREE hyp1 = (3,((4,5),(1,2))); TREE hyp2 = (3,(4,(6,(1,2)))); TREE hyp3 = (1,(2,(3,(4,(5,6))))); END; phylobase/inst/nexusfiles/test_min.nex0000644000176200001440000000045114553646170017753 0ustar liggesusers#NEXUS BEGIN TAXA; DIMENSIONS NTAX=4; TAXLABELS cnidaria porifera ctenophora protostomia ; END; BEGIN TREES; TRANSLATE 1 cnidaria, 2 protostomia, 3 porifera, 4 ctenophora; TREE hyp1 = ((1:5,2:5):3,(3:6,4:6):3); END; phylobase/inst/nexusfiles/treeWithDiscreteData.nex0000644000176200001440000002273614553646170022213 0ustar liggesusers#NEXUS [written Tue May 29 18:24:39 PDT 2007 by Mesquite version 1.06 (build g97) at cnidaria-1347.ucdavis.edu/169.237.66.185] BEGIN TAXA; DIMENSIONS NTAX=18; TAXLABELS Myrmecocystuscfnavajo Myrmecocystuscreightoni Myrmecocystusdepilis Myrmecocystuskathjuli Myrmecocystuskennedyi Myrmecocystusmendax Myrmecocystusmexicanus Myrmecocystusmimicus Myrmecocystusnavajo Myrmecocystusnequazcatl Myrmecocystusplacodops Myrmecocystusromainei Myrmecocystussemirufus Myrmecocystussnellingi Myrmecocystustenuinodis Myrmecocystustestaceus Myrmecocystuswheeleri Myrmecocystusyuma ; END; BEGIN CHARACTERS; TITLE Foraging; DIMENSIONS NCHAR=2; FORMAT DATATYPE = STANDARD GAP = - MISSING = ? SYMBOLS = " 0 1 2"; CHARSTATELABELS 1 time / diurnal crepuscular nocturnal, 2 subgenus / Endiodioctes Eremnocystus Myrmecocystus ; MATRIX Myrmecocystuscfnavajo 22 Myrmecocystuscreightoni 11 Myrmecocystusdepilis 00 Myrmecocystuskathjuli 00 Myrmecocystuskennedyi 00 Myrmecocystusmendax 00 Myrmecocystusmexicanus 22 Myrmecocystusmimicus 00 Myrmecocystusnavajo 22 Myrmecocystusnequazcatl 00 Myrmecocystusplacodops 00 Myrmecocystusromainei 00 Myrmecocystussemirufus 00 Myrmecocystussnellingi 11 Myrmecocystustenuinodis 11 Myrmecocystustestaceus 12 Myrmecocystuswheeleri 00 Myrmecocystusyuma 11 ; END; BEGIN TREES; TRANSLATE 1 Myrmecocystuscfnavajo, 2 Myrmecocystuscreightoni, 3 Myrmecocystusdepilis, 4 Myrmecocystuskathjuli, 5 Myrmecocystuskennedyi, 6 Myrmecocystusmendax, 7 Myrmecocystusmexicanus, 8 Myrmecocystusmimicus, 9 Myrmecocystusnavajo, 10 Myrmecocystusnequazcatl, 11 Myrmecocystusplacodops, 12 Myrmecocystusromainei, 13 Myrmecocystussemirufus, 14 Myrmecocystussnellingi, 15 Myrmecocystustenuinodis, 16 Myrmecocystustestaceus, 17 Myrmecocystuswheeleri, 18 Myrmecocystusyuma; TREE bestML = (((((((((13:1.724765,11:1.724765):2.926053,6:4.650818):0.689044,(4:1.08387,17:1.08387):4.255993):0.198842,((8:2.708942,3:2.708942):2.027251,((12:2.193845,10:2.193845):2.257581,18:4.451425):0.284767):0.802512):0.506099,5:6.044804):4.524387,2:10.569191):0.836689,(14:2.770378,15:2.770378):8.635503):0.89482,16:12.300701):1.699299,(7:5.724923,(1:2.869547,9:2.869547):2.855375):8.275077); END; BEGIN ASSUMPTIONS; TYPESET * UNTITLED (CHARACTERS = Foraging) = unord: 1 - 2; END; BEGIN MESQUITECHARMODELS; ProbModelSet * UNTITLED (CHARACTERS = 'Matrix in file "treepluscharV01.nex"') = Browniandefault: 1 - 32; ProbModelSet * UNTITLED (CHARACTERS = Foraging) = 'Mk1 (est.)': 1 - 2; END; Begin MESQUITE; MESQUITESCRIPTVERSION 2; TITLE AUTO; tell ProjectCoordinator; getEmployee #mesquite.minimal.ManageTaxa.ManageTaxa; tell It; setID 0 9015005506118934442; endTell; getEmployee #mesquite.charMatrices.ManageCharacters.ManageCharacters; tell It; setID 0 2565950173085067248; checksum 0 389122022; setID 1 1161953040649633474; checksum 1 3582198254; endTell; getEmployee #mesquite.charMatrices.BasicDataWindowCoord.BasicDataWindowCoord; tell It; showDataWindow #2565950173085067248 #mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindowMaker; tell It; getWindow; tell It; setSize 420 280; setLocation 400 156; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; endTell; setTool mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindow.arrow; colorCells #mesquite.charMatrices.NoColor.NoColor; setBackground White; toggleShowNames on; toggleTight off; toggleShowChanges on; toggleSeparateLines off; toggleShowStates on; toggleAutoWithCharNames on; toggleShowDefaultCharNames off; toggleConstrainCW on; toggleBirdsEye off; toggleColorsPanel off; birdsEyeWidth 2; toggleLinkedScrolling on; toggleScrollLinkedTables off; endTell; showWindow; getWindow; tell It; forceAutosize; endTell; getEmployee #mesquite.charMatrices.AnnotPanel.AnnotPanel; tell It; togglePanel off; endTell; getEmployee #mesquite.charMatrices.ColorCells.ColorCells; tell It; setColor Red; removeColor off; endTell; endTell; showDataWindow #1161953040649633474 #mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindowMaker; tell It; getWindow; tell It; getTable; tell It; rowNamesWidth 232; endTell; setSize 798 748; setLocation 348 22; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; setTool mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindow.ibeam; endTell; setTool mesquite.charMatrices.BasicDataWindowMaker.BasicDataWindow.ibeam; colorCells #mesquite.charMatrices.NoColor.NoColor; setBackground White; toggleShowNames on; toggleTight off; toggleShowChanges on; toggleSeparateLines off; toggleShowStates on; toggleAutoWithCharNames on; toggleShowDefaultCharNames off; toggleConstrainCW on; toggleBirdsEye off; toggleColorsPanel off; birdsEyeWidth 2; toggleLinkedScrolling on; toggleScrollLinkedTables off; endTell; showWindow; getWindow; tell It; forceAutosize; endTell; getEmployee #mesquite.categ.StateNamesEditor.StateNamesEditor; tell It; makeWindow; tell It; setSize 314 400; setLocation 60 10; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; setTool mesquite.categ.StateNamesEditor.StateNamesWindow.ibeam; endTell; rowsAreCharacters on; toggleConstrainChar on; toggleConstrainCharNum 3; togglePanel off; endTell; showWindow; endTell; getEmployee #mesquite.categ.StateNamesStrip.StateNamesStrip; tell It; showStrip off; endTell; getEmployee #mesquite.charMatrices.AnnotPanel.AnnotPanel; tell It; togglePanel off; endTell; getEmployee #mesquite.charMatrices.ColorCells.ColorCells; tell It; setColor Red; removeColor off; endTell; getEmployee #mesquite.charMatrices.QuickKeySelector.QuickKeySelector; tell It; autotabOff; endTell; endTell; endTell; getEmployee #mesquite.trees.BasicTreeWindowCoord.BasicTreeWindowCoord; tell It; makeTreeWindow #9015005506118934442 #mesquite.trees.BasicTreeWindowMaker.BasicTreeWindowMaker; tell It; setTreeSource #mesquite.trees.StoredTrees.StoredTrees; tell It; setTreeBlock 1; toggleUseWeights off; endTell; setAssignedID 630.1180487973731.4514395117633566598; getTreeWindow; tell It; setSize 520 400; setLocation 60 10; setFont SanSerif; setFontSize 10; onInfoBar; setExplanationSize 30; setAnnotationSize 20; setFontIncAnnot 0; setFontIncExp 0; getToolPalette; tell It; endTell; setActive; getTreeDrawCoordinator #mesquite.trees.BasicTreeDrawCoordinator.BasicTreeDrawCoordinator; tell It; suppress; setTreeDrawer #mesquite.trees.DiagonalDrawTree.DiagonalDrawTree; tell It; setEdgeWidth 12; orientUp; getEmployee #mesquite.trees.NodeLocsStandard.NodeLocsStandard; tell It; stretchToggle off; branchLengthsToggle off; toggleScale on; toggleCenter off; toggleEven off; namesAngle ?; endTell; endTell; setBackground White; setBranchColor Black; showNodeNumbers off; labelBranchLengths off; desuppress; getEmployee #mesquite.trees.BasicDrawTaxonNames.BasicDrawTaxonNames; tell It; setColor Black; toggleColorPartition on; toggleShadePartition off; toggleNodeLabels on; toggleShowNames on; endTell; endTell; setTreeNumber 1; useSuggestedSize on; toggleTextOnTree off; newAssistant #mesquite.ancstates.TraceCharacterHistory.TraceCharacterHistory; tell It; suspend ; setDisplayMode #mesquite.ancstates.ShadeStatesOnTree.ShadeStatesOnTree; tell It; toggleLabels off; endTell; setHistorySource #mesquite.ancstates.RecAncestralStates.RecAncestralStates; tell It; getCharacterSource #mesquite.charMatrices.CharSrcCoordObed.CharSrcCoordObed; tell It; setCharacterSource #mesquite.charMatrices.StoredCharacters.StoredCharacters; tell It; setDataSet #1161953040649633474; endTell; endTell; setMethod #mesquite.parsimony.ParsAncestralStates.ParsAncestralStates; tell It; setModelSource #mesquite.parsimony.CurrentParsModels.CurrentParsModels; endTell; endTell; setCharacter 1; toggleShowLegend on; toggleGray off; toggleWeights on; setInitialOffsetX -162; setInitialOffsetY -177; setLegendWidth 142; setLegendHeight 177; resume ; endTell; endTell; showWindow; getEmployee #mesquite.ornamental.BranchNotes.BranchNotes; tell It; setAlwaysOn off; endTell; getEmployee #mesquite.trees.ColorBranches.ColorBranches; tell It; setColor Red; removeColor off; endTell; endTell; endTell; endTell; end; begin brownie; taxset all=1-18; end; phylobase/inst/nexusfiles/treeRoundingError.nex0000644000176200001440000000056714553646170021620 0ustar liggesusers#NEXUS BEGIN TAXA; DIMENSIONS NTAX=4; TAXLABELS spA spB spC spD ; END; BEGIN CHARACTERS; TITLE 'Morphology'; DIMENSIONS NCHAR=1; FORMAT DATATYPE = CONTINUOUS; CHARSTATELABELS 1 testTest; MATRIX spA 0.6263965 spB 0.7741235 spC 1.0180075 spD 1.0856245 ; END; BEGIN TREES; TRANSLATE 1 spA, 2 spB, 3 spC, 4 spD; TREE testTree = (1,(2,(3,4))); END; phylobase/inst/doc/0000755000176200001440000000000014555747152014001 5ustar liggesusersphylobase/inst/doc/phylobase.Rmd0000644000176200001440000006360214555745776016454 0ustar liggesusers--- title: "The phylo4 classes and methods" author: ["Ben Bolker", "Peter Cowan", "François Michonneau"] output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{The phylo4 classes and methods} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```r library(phylobase) ``` ## Introduction This document describes the new 'phylo4' S4 classes and methods, which are intended to provide a unifying standard for the representation of phylogenetic trees and comparative data in R. The `phylobase` package was developed to help both end users and package developers by providing a common suite of tools likely to be shared by all packages designed for phylogenetic analysis, facilities for data and tree manipulation, and standardization of formats. This standardization will benefit *end-users* by making it easier to move data and compare analyses across packages, and to keep comparative data synchronized with phylogenetic trees. Users will also benefit from a repository of functions for tree manipulation, for example tools for including or excluding subtrees (and associated phenotypic data) or improved tree and data plotting facilities. `phylobase` will benefit *developers* by freeing them to put their programming effort into developing new methods rather than into re-coding base tools. We (the `phylobase` developers) hope `phylobase` will also facilitate code validation by providing a repository for benchmark tests, and more generally that it will help catalyze community development of comparative methods in R. A more abstract motivation for developing `phylobase` was to improve data checking and abstraction of the tree data formats. `phylobase` can check that data and trees are associated in the proper fashion, and protects users and developers from accidently reordering one, but not the other. It also seeks to abstract the data format so that commonly used information (for example, branch length information or the ancestor of a particular node) can be accessed without knowledge of the underlying data structure (i.e., whether the tree is stored as a matrix, or a list, or a parenthesis-based format). This is achieved through generic `phylobase` functions which which retrieve the relevant information from the data structures. The benefits of such abstraction are multiple: (1) *easier access to the relevant information* via a simple function call (this frees both users and developers from learning details of complex data structures), (2) *freedom to optimize data structures in the future without breaking code.* Having the generic functions in place to "translate" between the data structures and the rest of the program code allows program and data structure development to proceed somewhat independently. The alternative is code written for specific data structures, in which modifications to the data structure requires rewriting the entire package code (often exacting too high a price, which results in the persistence of less-optimal data structures). (3) *providing broader access to the range of tools in `phylobase`*. Developers of specific packages can use these new tools based on S4 objects without knowing the details of S4 programming. The base 'phylo4' class is modeled on the the `phylo` class in `ape`. and extend the 'phylo4' class to include data or multiple trees respectively. In addition to describing the classes and methods, this vignette gives examples of how they might be used. ## Package overview The phylobase package currently implements the following functions and data structures: - Data structures for storing a single tree and multiple trees: and ? - A data structure for storing a tree with associated tip and node data: - A data structure for storing multiple trees with one set of tip data: - Functions for reading nexus files into the above data structures - Functions for converting between the above data structures and objects as well as `phylog` objects (although the latter are now deprecated ...) - Functions for editing trees and data (i.e., subsetting and replacing) - Functions for plotting trees and trees with data ## Using the S4 help system The help system works similarly to the help system with some small differences relating to how methods are written. The function is a good example. When we type we are provided the help for the default plotting function which expects `x` and `y`. `R` also provides a way to smartly dispatch the right type of plotting function. In the case of an object (a class object) `R` evaluates the class of the object and finds the correct functions, so the following works correctly. ```r library(ape) set.seed(1) ## set random-number seed rand_tree <- rcoal(10) ## Make a random tree with 10 tips plot(rand_tree) ``` However, typing still takes us to the default `plot` help. We have to type to find what we are looking for. This is because generics are simply functions with a dot and the class name added. The generic system is too complicated to describe here, but doesn't include the same dot notation. As a result doesn't work, `R` still finds the right plotting function. ```r library(phylobase) # convert rand_tree to a phylo4 object rand_p4_tree <- as(rand_tree, "phylo4") plot(rand_p4_tree) ``` All fine and good, but how to we find out about all the great features of the `phylobase` plotting function? `R` has two nifty ways to find it, the first is to simply put a question mark in front of the whole call: ```r `?`(plot(rand_p4_tree)) ``` `R` looks at the class of the object and takes us to the correct help file (note: this only works with objects). The second ways is handy if you already know the class of your object, or want to compare to generics for different classes: ```r `?`(method, plot("phylo4")) ``` More information about how documentation works can be found in the methods package, by running the following command. ```r help('Documentation', package="methods") ``` ## Trees without data You can start with a tree --- an object of class `phylo` from the `ape` package (e.g., read in using the `read.tree()` or `read.nexus()` functions), and convert it to a `phylo4` object. For example, load the raw *Geospiza* data: ```r library(phylobase) data(geospiza_raw) # what does it contain? names(geospiza_raw) #> [1] "tree" "data" ``` Convert the `S3` tree to a `S4 phylo4` object using the `as()` function: ```r (g1 <- as(geospiza_raw$tree, "phylo4")) #> label node ancestor edge.length node.type #> 1 fuliginosa 1 24 0.05500 tip #> 2 fortis 2 24 0.05500 tip #> 3 magnirostris 3 23 0.11000 tip #> 4 conirostris 4 22 0.18333 tip #> 5 scandens 5 21 0.19250 tip #> 6 difficilis 6 20 0.22800 tip #> 7 pallida 7 25 0.08667 tip #> 8 parvulus 8 27 0.02000 tip #> 9 psittacula 9 27 0.02000 tip #> 10 pauper 10 26 0.03500 tip #> 11 Platyspiza 11 18 0.46550 tip #> 12 fusca 12 17 0.53409 tip #> 13 Pinaroloxias 13 16 0.58333 tip #> 14 olivacea 14 15 0.88077 tip #> 15 15 0 NA root #> 16 16 15 0.29744 internal #> 17 17 16 0.04924 internal #> 18 18 17 0.06859 internal #> 19 19 18 0.13404 internal #> 20 20 19 0.10346 internal #> [ reached 'max' / getOption("max.print") -- omitted 7 rows ] ``` The (internal) nodes appear with labels \verb++ because they are not defined: ```r nodeLabels(g1) #> 15 16 17 18 19 20 21 22 23 24 25 26 27 #> NA NA NA NA NA NA NA NA NA NA NA NA NA ``` You can also retrieve the node labels with \texttt{labels(g1,"internal")}. A simple way to assign the node numbers as labels (useful for various checks) is ```r nodeLabels(g1) <- paste("N", nodeId(g1, "internal"), sep="") head(g1, 5) #> label node ancestor edge.length node.type #> 1 fuliginosa 1 24 0.05500 tip #> 2 fortis 2 24 0.05500 tip #> 3 magnirostris 3 23 0.11000 tip #> 4 conirostris 4 22 0.18333 tip #> 5 scandens 5 21 0.19250 tip ``` The \texttt{summary} method gives a little extra information, including information on the distribution of branch lengths: ```r summary(g1) #> #> Phylogenetic tree : g1 #> #> Number of tips : 14 #> Number of nodes : 13 #> Branch lengths: #> mean : 0.1764008 #> variance : 0.04624379 #> distribution : #> Min. 1st Qu. Median Mean 3rd Qu. Max. #> 0.00917 0.04985 0.08000 0.17640 0.21912 0.88077 ``` Print tip labels: ```r tipLabels(g1) #> 1 2 3 4 5 6 #> "fuliginosa" "fortis" "magnirostris" "conirostris" "scandens" "difficilis" #> 7 8 9 10 11 12 #> "pallida" "parvulus" "psittacula" "pauper" "Platyspiza" "fusca" #> 13 14 #> "Pinaroloxias" "olivacea" ``` (`labels(g1,"tip")` would also work.) You can modify labels and other aspects of the tree --- for example, to convert all the labels to lower case: ```r tipLabels(g1) <- tolower(tipLabels(g1)) ``` You could also modify selected labels, e.g. to modify the labels in positions 11 and 13 (which happen to be the only labels with uppercase letters): ```r tipLabels(g1)[c(11, 13)] <- c("platyspiza", "pinaroloxias") ``` Note that for a given tree, `phylobase` always return the `tipLabels` in the same order. Print node numbers (in edge matrix order): ```r nodeId(g1, type='all') #> [1] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 ``` Does it have information on branch lengths? ```r hasEdgeLength(g1) #> [1] TRUE ``` It does! What do they look like? ```r edgeLength(g1) #> 15-16 16-17 17-18 18-19 19-20 20-21 21-22 22-23 23-24 24-1 24-2 #> 0.29744 0.04924 0.06859 0.13404 0.10346 0.03550 0.00917 0.07333 0.05500 0.05500 0.05500 #> 23-3 22-4 21-5 0-15 20-6 19-25 25-7 25-26 26-27 27-8 27-9 #> 0.11000 0.18333 0.19250 NA 0.22800 0.24479 0.08667 0.05167 0.01500 0.02000 0.02000 #> 26-10 18-11 17-12 16-13 15-14 #> 0.03500 0.46550 0.53409 0.58333 0.88077 ``` Note that the root has `` as its length. Print edge labels (also empty in this case --- therefore all `NA`): ```r edgeLabels(g1) #> 15-16 16-17 17-18 18-19 19-20 20-21 21-22 22-23 23-24 24-1 24-2 23-3 22-4 21-5 0-15 #> NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA #> 20-6 19-25 25-7 25-26 26-27 27-8 27-9 26-10 18-11 17-12 16-13 15-14 #> NA NA NA NA NA NA NA NA NA NA NA NA ``` You can also use this function to label specific edges: ```r edgeLabels(g1)["23-24"] <- "an edge" edgeLabels(g1) #> 15-16 16-17 17-18 18-19 19-20 20-21 21-22 22-23 23-24 #> NA NA NA NA NA NA NA NA "an edge" #> 24-1 24-2 23-3 22-4 21-5 0-15 20-6 19-25 25-7 #> NA NA NA NA NA NA NA NA NA #> 25-26 26-27 27-8 27-9 26-10 18-11 17-12 16-13 15-14 #> NA NA NA NA NA NA NA NA NA ``` The edge labels are named according to the nodes they connect (ancestor-descendant). You can get the edge(s) associated with a particular node: ```r getEdge(g1, 24) # default uses descendant node #> 24 #> "23-24" getEdge(g1, 24, type="ancestor") # edges using ancestor node #> 24 24 #> "24-1" "24-2" ``` These results can in turn be passed to the function \texttt{edgeLength} to retrieve the length of a given set of edges: ```r edgeLength(g1)[getEdge(g1, 24)] #> 23-24 #> 0.055 edgeLength(g1)[getEdge(g1, 24, "ancestor")] #> 24-1 24-2 #> 0.055 0.055 ``` Is it rooted? ```r isRooted(g1) #> [1] TRUE ``` Which node is the root? ```r rootNode(g1) #> N15 #> 15 ``` Does it contain any polytomies? ```r hasPoly(g1) #> [1] FALSE ``` Is the tree ultrametric? ```r isUltrametric(g1) #> [1] TRUE ``` You can also get the depth (distance from the root) of any given node or the tips: ```r nodeDepth(g1, 23) #> Warning: 'nodeDepth' is deprecated. #> Use 'nodeHeight' instead. #> See help("Deprecated") #> N23 #> 0.77077 depthTips(g1) #> Warning: 'depthTips' is deprecated. #> Use 'nodeHeight' instead. #> See help("Deprecated") #> Warning: 'nodeDepth' is deprecated. #> Use 'nodeHeight' instead. #> See help("Deprecated") #> fuliginosa fortis magnirostris conirostris scandens difficilis #> 0.88077 0.88077 0.88077 0.88077 0.88077 0.88077 #> pallida parvulus psittacula pauper platyspiza fusca #> 0.88077 0.88077 0.88077 0.88077 0.88077 0.88077 #> pinaroloxias olivacea #> 0.88077 0.88077 ``` ## Trees with data The `phylo4d` class matches trees with data, or combines them with a data frame to make a `phylo4d` (tree-with-data) object. Now we'll take the _Geospiza_ data from `geospiza_raw$data` and merge it with the tree. First, let's prepare the data: ```r g1 <- as(geospiza_raw$tree, "phylo4") geodata <- geospiza_raw$data ``` However, since *G. olivacea* is included in the tree but not in the data set, we will initially run into some trouble: ```r g2 <- phylo4d(g1, geodata) #> Error in formatData(phy = x, dt = tip.data, type = "tip", ...): The following nodes are not found in the dataset: olivacea ``` To deal with *G. olivacea* missing from the data, we have a few choices. The easiest is to use to allow to create the new object with a warning (you can also use to proceed without warnings): ```r g2 <- phylo4d(g1, geodata, missing.data="warn") #> Warning in formatData(phy = x, dt = tip.data, type = "tip", ...): The following nodes are #> not found in the dataset: olivacea ``` Another way to deal with this would be to use `prune()` to drop the offending tip from the tree first: ```r g1sub <- prune(g1, "olivacea") g1B <- phylo4d(g1sub, geodata) ``` The difference between the two objects is that the species *G. olivacea* is still present in the tree but has no data (i.e., `NA`) associated with it. In the other case, *G. olivacea* is not included in the tree anymore. The approach you choose depends on the goal of your analysis. You can summarize the new object with the function `summary`. It breaks down the statistics about the traits based on whether it is associated with the tips for the internal nodes: \<\\>= summary(g2) @ Or use `tdata()` to extract the data (i.e., `tdata(g2)`). By default, `tdata()` will retrieve tip data, but you can also get internal node data only () or --- if the tip and node data have the same format --- all the data combined (). If you want to plot the data (e.g. for checking the input), `plot(tdata(g2))` will create the default plot for the data --- in this case, since it is a data frame, this will be a `pairs` plot of the data. ## Subsetting The `subset` command offers a variety of ways of extracting portions of a `phylo4` or `phylo4d` tree, keeping any tip/node data consistent. tips.include : give a vector of tips (names or numbers) to retain tips.exclude : give a vector of tips (names or numbers) to drop mrca : give a vector of node or tip names or numbers; extract the clade containing these taxa node.subtree : give a node (name or number); extract the subtree starting from this node Different ways to extract the *fuliginosa*-*scandens* clade: ```r subset(g2, tips.include=c("fuliginosa", "fortis", "magnirostris", "conirostris", "scandens")) subset(g2, node.subtree=21) subset(g2, mrca=c("scandens", "fortis")) ``` One could drop the clade by doing ```r subset(g2, tips.exclude=c("fuliginosa", "fortis", "magnirostris", "conirostris", "scandens")) subset(g2, tips.exclude=names(descendants(g2, MRCA(g2, c("difficilis", "fortis"))))) ``` ## Tree-walking `phylobase` provides many functions that allows users to explore relationships between nodes on a tree (tree-walking and tree traversal). Most functions work by specifying the `phylo4` (or `phylo4d`) object as the first argument, the node numbers/labels as the second argument (followed by some additional arguments). `getNode` allows you to find a node based on its node number or its label. It returns a vector with node numbers as values and labels as names: ```r data(geospiza) getNode(geospiza, 10) #> pauper #> 10 getNode(geospiza, "pauper") #> pauper #> 10 ``` If no node is specified, they are all returned, and if a node can't be found it's returned as a `NA`. It is possible to control what happens when a node can't be found: ```r getNode(geospiza) #> fuliginosa fortis magnirostris conirostris scandens difficilis #> 1 2 3 4 5 6 #> pallida parvulus psittacula pauper Platyspiza fusca #> 7 8 9 10 11 12 #> Pinaroloxias olivacea N15 N16 N17 N18 #> 13 14 15 16 17 18 #> N19 N20 N21 N22 N23 N24 #> 19 20 21 22 23 24 #> N25 N26 N27 #> 25 26 27 getNode(geospiza, 10:14) #> pauper Platyspiza fusca Pinaroloxias olivacea #> 10 11 12 13 14 getNode(geospiza, "melanogaster", missing="OK") # no warning #> #> NA getNode(geospiza, "melanogaster", missing="warn") # warning! #> Warning in getNode(geospiza, "melanogaster", missing = "warn"): Some nodes not found #> among all nodes in tree: melanogaster #> #> NA ``` `children` and `ancestor` give the immediate neighboring nodes: ```r children(geospiza, 16) #> N17 Pinaroloxias #> 17 13 ancestor(geospiza, 16) #> N15 #> 15 ``` while `descendants` and `ancestors` can traverse the tree up to the tips or root respectively: ```r descendants(geospiza, 16) # by default returns only the tips #> Pinaroloxias fusca Platyspiza difficilis scandens conirostris #> 13 12 11 6 5 4 #> magnirostris fuliginosa fortis pallida pauper parvulus #> 3 1 2 7 10 8 #> psittacula #> 9 descendants(geospiza, "all") # also include the internal nodes #> Warning in getNode(phy, node, missing = "warn"): Some nodes not found among all nodes in #> tree: all #> named list() ancestors(geospiza, 20) #> N19 N18 N17 N16 N15 #> 19 18 17 16 15 ancestors(geospiza, 20, "ALL") # uppercase ALL includes self #> N20 N19 N18 N17 N16 N15 #> 20 19 18 17 16 15 ``` `siblings` returns the other node(s) associated with the same ancestor: ```r siblings(geospiza, 20) #> N25 #> 25 siblings(geospiza, 20, include.self=TRUE) #> N20 N25 #> 20 25 ``` `MRCA` returns the most common recent ancestor for a set of tips, and shortest path returns the nodes connecting 2 nodes: ```r MRCA(geospiza, 1:6) #> N20 #> 20 shortestPath(geospiza, 4, "pauper") #> N19 N20 N21 N22 N25 N26 #> 19 20 21 22 25 26 ``` ## multiPhylo4 classes `multiPhylo4` classes are not yet implemented but will be coming soon. ## Examples ### Constructing a Brownian motion trait simulator This section will describe a way of constructing a simulator that generates trait values for extant species (tips) given a tree with branch lengths, assuming a model of Brownian motion. We can use to coerce the tree into a variance-covariance matrix form, and then use `mvrnorm` from the `MASS` package to generate a set of multivariate normally distributed values for the tips. (A benefit of this approach is that we can very quickly generate a very large number of replicates.) This example illustrates a common feature of working with `phylobase` --- combining tools from several different packages to operate on phylogenetic trees with data. We start with a randomly generated tree using `rcoal()` from `ape` to generate the tree topology and branch lengths: ```r set.seed(1001) tree <- as(rcoal(12), "phylo4") ``` Next we generate the phylogenetic variance-covariance matrix (by coercing the tree to a `phylo4vcov` object) and pick a single set of normally distributed traits (using to pick a multivariate normal deviate with a variance-covariance matrix that matches the structure of the tree). ```r vmat <- as(tree, "phylo4vcov") vmat <- cov2cor(vmat) library(MASS) trvec <- mvrnorm(1, mu=rep(0, 12), Sigma=vmat) ``` The last step (easy) is to convert the `phylo4vcov` object back to a `phylo4d` object: ```r treed <- phylo4d(tree, tip.data=as.data.frame(trvec)) plot(treed) ``` ![plot of chunk plotvcvphylo](fig-vignettes-plotvcvphylo-1.png) ## Definitions/slots This section details the internal structure of the `phylo4`, `multiphylo4` (coming soon!), `phylo4d`, and `multiphylo4d` (coming soon!) classes. The basic building blocks of these classes are the `phylo4` object and a dataframe. The `phylo4` tree format is largely similar to the one used by `phylo` class in the package `ape`[^1]. We use "edge" for ancestor-descendant relationships in the phylogeny (sometimes called "branches") and "edge lengths" for their lengths ("branch lengths"). Most generally, "nodes" are all species in the tree; species with descendants are "internal nodes" (we often refer to these just as "nodes", meaning clear from context); "tips" are species with no descendants. The "root node" is the node with no ancestor (if one exists). ### phylo4 Like `phylo`, the main components of the `phylo4` class are: edge : a 2-column matrix of integers, with $N$ rows for a rooted tree or $N-1$ rows for an unrooted tree and column names `ancestor` and `descendant`. Each row contains information on one edge in the tree. See below for further constraints on the edge matrix. edge.length : numeric list of edge lengths (length $N$ (rooted) or $N-1$ (unrooted) or empty (length 0)) tip.label : character vector of tip labels (required), with length=# of tips. Tip labels need not be unique, but data-tree matching with non-unique labels will cause an error node.label : character vector of node labels, length=# of internal nodes or 0 (if empty). Node labels need not be unique, but data-tree matching with non-unique labels will cause an error order : character: "preorder", "postorder", or "unknown" (default), describing the order of rows in the edge matrix. , "pruningwise" and "cladewise" are accepted for compatibility with `ape` The edge matrix must not contain `NA`s, with the exception of the root node, which has an `NA` for `ancestor`. `phylobase` does not enforce an order on the rows of the edge matrix, but it stores information on the current ordering in the slot --- current allowable values are "unknown" (the default), "preorder" (equivalent to "cladewise" in `ape`) or "postorder" [^2]. The basic criteria for the edge matrix are similar to those of `ape`, as documented it's tree specification[^3]. This is a modified version of those rules, for a tree with $n$ tips and $m$ internal nodes: - Tips (no descendants) are coded $1,\ldots, n$, and internal nodes ($\ge 1$ descendant) are coded $n + 1, \ldots , n + m$ ($n + 1$ is the root). Both series are numbered with no gaps. - The first (ancestor) column has only values $> n$ (internal nodes): thus, values $\le n$ (tips) appear only in the second (descendant) column - all internal nodes (not including the root) must appear in the first (ancestor) column at least once [unlike `ape`, which nominally requires each internal node to have at least two descendants (although it doesn't absolutely prohibit them and has a function to get rid of them), `phylobase` does allow these "singleton nodes" and has a method `hasSingle` for detecting them]. Singleton nodes can be useful as a way of representing changes along a lineage; they are used this way in the `ouch` package. - the number of occurrences of a node in the first column is related to the nature of the node: once if it is a singleton, twice if it is dichotomous (i.e., of degree 3 [counting ancestor as well as descendants]), three times if it is trichotomous (degree 4), and so on. `phylobase` does not technically prohibit reticulations (nodes or tips that appear more than once in the descendant column), but they will probably break most of the methods. Disconnected trees, cycles, and other exotica are not tested for, but will certainly break the methods. We have defined basic methods for `phylo4`:`show`, `print`, and a variety of accessor functions (see help files). `summary` does not seem to be terribly useful in the context of a "raw" tree, because there is not much to compute. ### phylo4d The `phylo4d` class extends `phylo4` with data. Tip data, and (internal) node data are stored separately, but can be retrieved together or separately with `tdata(x,"tip")`, `tdata(x,"internal")` or `tdata(x,"all")`. There is no separate slot for edge data, but these can be stored as node data associated with the descendant node. [^1]: [^2]: see for more information on orderings. (`ape`'s "pruningwise" is "bottom-up" ordering). [^3]: phylobase/inst/doc/phylobase.html0000644000176200001440000027076614555747152016677 0ustar liggesusers The phylo4 classes and methods

The phylo4 classes and methods

Ben Bolker

Peter Cowan

François Michonneau

library(phylobase)

Introduction

This document describes the new ‘phylo4’ S4 classes and methods, which are intended to provide a unifying standard for the representation of phylogenetic trees and comparative data in R. The phylobase package was developed to help both end users and package developers by providing a common suite of tools likely to be shared by all packages designed for phylogenetic analysis, facilities for data and tree manipulation, and standardization of formats.

This standardization will benefit end-users by making it easier to move data and compare analyses across packages, and to keep comparative data synchronized with phylogenetic trees. Users will also benefit from a repository of functions for tree manipulation, for example tools for including or excluding subtrees (and associated phenotypic data) or improved tree and data plotting facilities. phylobase will benefit developers by freeing them to put their programming effort into developing new methods rather than into re-coding base tools. We (the phylobase developers) hope phylobase will also facilitate code validation by providing a repository for benchmark tests, and more generally that it will help catalyze community development of comparative methods in R.

A more abstract motivation for developing phylobase was to improve data checking and abstraction of the tree data formats. phylobase can check that data and trees are associated in the proper fashion, and protects users and developers from accidently reordering one, but not the other. It also seeks to abstract the data format so that commonly used information (for example, branch length information or the ancestor of a particular node) can be accessed without knowledge of the underlying data structure (i.e., whether the tree is stored as a matrix, or a list, or a parenthesis-based format). This is achieved through generic phylobase functions which which retrieve the relevant information from the data structures. The benefits of such abstraction are multiple: (1) easier access to the relevant information via a simple function call (this frees both users and developers from learning details of complex data structures), (2) freedom to optimize data structures in the future without breaking code. Having the generic functions in place to “translate” between the data structures and the rest of the program code allows program and data structure development to proceed somewhat independently. The alternative is code written for specific data structures, in which modifications to the data structure requires rewriting the entire package code (often exacting too high a price, which results in the persistence of less-optimal data structures). (3) providing broader access to the range of tools in phylobase. Developers of specific packages can use these new tools based on S4 objects without knowing the details of S4 programming.

The base ‘phylo4’ class is modeled on the the phylo class in ape. and extend the ‘phylo4’ class to include data or multiple trees respectively. In addition to describing the classes and methods, this vignette gives examples of how they might be used.

Package overview

The phylobase package currently implements the following functions and data structures:

  • Data structures for storing a single tree and multiple trees: and ?

  • A data structure for storing a tree with associated tip and node data:

  • A data structure for storing multiple trees with one set of tip data:

  • Functions for reading nexus files into the above data structures

  • Functions for converting between the above data structures and objects as well as phylog objects (although the latter are now deprecated …)

  • Functions for editing trees and data (i.e., subsetting and replacing)

  • Functions for plotting trees and trees with data

Using the S4 help system

The help system works similarly to the help system with some small differences relating to how methods are written. The function is a good example. When we type we are provided the help for the default plotting function which expects x and y. R also provides a way to smartly dispatch the right type of plotting function. In the case of an object (a class object) R evaluates the class of the object and finds the correct functions, so the following works correctly.

library(ape)
set.seed(1)  ## set random-number seed
rand_tree <- rcoal(10) ## Make a random tree with 10 tips
plot(rand_tree)

However, typing still takes us to the default plot help. We have to type to find what we are looking for. This is because generics are simply functions with a dot and the class name added.

The generic system is too complicated to describe here, but doesn’t include the same dot notation. As a result doesn’t work, R still finds the right plotting function.

library(phylobase)
# convert rand_tree to a phylo4 object
rand_p4_tree <- as(rand_tree, "phylo4")
plot(rand_p4_tree)

All fine and good, but how to we find out about all the great features of the phylobase plotting function? R has two nifty ways to find it, the first is to simply put a question mark in front of the whole call:

`?`(plot(rand_p4_tree))

R looks at the class of the object and takes us to the correct help file (note: this only works with objects). The second ways is handy if you already know the class of your object, or want to compare to generics for different classes:

`?`(method, plot("phylo4"))

More information about how documentation works can be found in the methods package, by running the following command.

help('Documentation', package="methods")

Trees without data

You can start with a tree — an object of class phylo from the ape package (e.g., read in using the read.tree() or read.nexus() functions), and convert it to a phylo4 object.

For example, load the raw Geospiza data:

library(phylobase)
data(geospiza_raw) # what does it contain?
names(geospiza_raw)
#> [1] "tree" "data"

Convert the S3 tree to a S4 phylo4 object using the as() function:

(g1 <- as(geospiza_raw$tree, "phylo4"))
#>           label node ancestor edge.length node.type
#> 1    fuliginosa    1       24     0.05500       tip
#> 2        fortis    2       24     0.05500       tip
#> 3  magnirostris    3       23     0.11000       tip
#> 4   conirostris    4       22     0.18333       tip
#> 5      scandens    5       21     0.19250       tip
#> 6    difficilis    6       20     0.22800       tip
#> 7       pallida    7       25     0.08667       tip
#> 8      parvulus    8       27     0.02000       tip
#> 9    psittacula    9       27     0.02000       tip
#> 10       pauper   10       26     0.03500       tip
#> 11   Platyspiza   11       18     0.46550       tip
#> 12        fusca   12       17     0.53409       tip
#> 13 Pinaroloxias   13       16     0.58333       tip
#> 14     olivacea   14       15     0.88077       tip
#> 15         <NA>   15        0          NA      root
#> 16         <NA>   16       15     0.29744  internal
#> 17         <NA>   17       16     0.04924  internal
#> 18         <NA>   18       17     0.06859  internal
#> 19         <NA>   19       18     0.13404  internal
#> 20         <NA>   20       19     0.10346  internal
#>  [ reached 'max' / getOption("max.print") -- omitted 7 rows ]

The (internal) nodes appear with labels because they are not defined:

nodeLabels(g1)
#> 15 16 17 18 19 20 21 22 23 24 25 26 27 
#> NA NA NA NA NA NA NA NA NA NA NA NA NA

You can also retrieve the node labels with .

A simple way to assign the node numbers as labels (useful for various checks) is

nodeLabels(g1) <- paste("N", nodeId(g1, "internal"), sep="")
head(g1, 5)
#>          label node ancestor edge.length node.type
#> 1   fuliginosa    1       24     0.05500       tip
#> 2       fortis    2       24     0.05500       tip
#> 3 magnirostris    3       23     0.11000       tip
#> 4  conirostris    4       22     0.18333       tip
#> 5     scandens    5       21     0.19250       tip

The method gives a little extra information, including information on the distribution of branch lengths:

summary(g1)
#> 
#>  Phylogenetic tree : g1 
#> 
#>  Number of tips    : 14 
#>  Number of nodes   : 13 
#>  Branch lengths:
#>         mean         : 0.1764008 
#>         variance     : 0.04624379 
#>         distribution :
#>    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
#> 0.00917 0.04985 0.08000 0.17640 0.21912 0.88077

Print tip labels:

tipLabels(g1)
#>              1              2              3              4              5              6 
#>   "fuliginosa"       "fortis" "magnirostris"  "conirostris"     "scandens"   "difficilis" 
#>              7              8              9             10             11             12 
#>      "pallida"     "parvulus"   "psittacula"       "pauper"   "Platyspiza"        "fusca" 
#>             13             14 
#> "Pinaroloxias"     "olivacea"

(labels(g1,"tip") would also work.)

You can modify labels and other aspects of the tree — for example, to convert all the labels to lower case:

tipLabels(g1) <- tolower(tipLabels(g1))

You could also modify selected labels, e.g. to modify the labels in positions 11 and 13 (which happen to be the only labels with uppercase letters):

tipLabels(g1)[c(11, 13)] <- c("platyspiza", "pinaroloxias")

Note that for a given tree, phylobase always return the tipLabels in the same order.

Print node numbers (in edge matrix order):

nodeId(g1, type='all')
#>  [1]  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27

Does it have information on branch lengths?

hasEdgeLength(g1)
#> [1] TRUE

It does! What do they look like?

edgeLength(g1)
#>   15-16   16-17   17-18   18-19   19-20   20-21   21-22   22-23   23-24    24-1    24-2 
#> 0.29744 0.04924 0.06859 0.13404 0.10346 0.03550 0.00917 0.07333 0.05500 0.05500 0.05500 
#>    23-3    22-4    21-5    0-15    20-6   19-25    25-7   25-26   26-27    27-8    27-9 
#> 0.11000 0.18333 0.19250      NA 0.22800 0.24479 0.08667 0.05167 0.01500 0.02000 0.02000 
#>   26-10   18-11   17-12   16-13   15-14 
#> 0.03500 0.46550 0.53409 0.58333 0.88077

Note that the root has <NA> as its length.

Print edge labels (also empty in this case — therefore all NA):

edgeLabels(g1)
#> 15-16 16-17 17-18 18-19 19-20 20-21 21-22 22-23 23-24  24-1  24-2  23-3  22-4  21-5  0-15 
#>    NA    NA    NA    NA    NA    NA    NA    NA    NA    NA    NA    NA    NA    NA    NA 
#>  20-6 19-25  25-7 25-26 26-27  27-8  27-9 26-10 18-11 17-12 16-13 15-14 
#>    NA    NA    NA    NA    NA    NA    NA    NA    NA    NA    NA    NA

You can also use this function to label specific edges:

edgeLabels(g1)["23-24"] <- "an edge"
edgeLabels(g1)
#>     15-16     16-17     17-18     18-19     19-20     20-21     21-22     22-23     23-24 
#>        NA        NA        NA        NA        NA        NA        NA        NA "an edge" 
#>      24-1      24-2      23-3      22-4      21-5      0-15      20-6     19-25      25-7 
#>        NA        NA        NA        NA        NA        NA        NA        NA        NA 
#>     25-26     26-27      27-8      27-9     26-10     18-11     17-12     16-13     15-14 
#>        NA        NA        NA        NA        NA        NA        NA        NA        NA

The edge labels are named according to the nodes they connect (ancestor-descendant). You can get the edge(s) associated with a particular node:

getEdge(g1, 24) # default uses descendant node
#>      24 
#> "23-24"
getEdge(g1, 24, type="ancestor") # edges using ancestor node
#>     24     24 
#> "24-1" "24-2"

These results can in turn be passed to the function to retrieve the length of a given set of edges:

edgeLength(g1)[getEdge(g1, 24)]
#> 23-24 
#> 0.055
edgeLength(g1)[getEdge(g1, 24, "ancestor")]
#>  24-1  24-2 
#> 0.055 0.055

Is it rooted?

isRooted(g1)
#> [1] TRUE

Which node is the root?

rootNode(g1)
#> N15 
#>  15

Does it contain any polytomies?

hasPoly(g1)
#> [1] FALSE

Is the tree ultrametric?

isUltrametric(g1)
#> [1] TRUE

You can also get the depth (distance from the root) of any given node or the tips:

nodeDepth(g1, 23)
#> Warning: 'nodeDepth' is deprecated.
#> Use 'nodeHeight' instead.
#> See help("Deprecated")
#>     N23 
#> 0.77077
depthTips(g1)
#> Warning: 'depthTips' is deprecated.
#> Use 'nodeHeight' instead.
#> See help("Deprecated")

#> Warning: 'nodeDepth' is deprecated.
#> Use 'nodeHeight' instead.
#> See help("Deprecated")
#>   fuliginosa       fortis magnirostris  conirostris     scandens   difficilis 
#>      0.88077      0.88077      0.88077      0.88077      0.88077      0.88077 
#>      pallida     parvulus   psittacula       pauper   platyspiza        fusca 
#>      0.88077      0.88077      0.88077      0.88077      0.88077      0.88077 
#> pinaroloxias     olivacea 
#>      0.88077      0.88077

Trees with data

The phylo4d class matches trees with data, or combines them with a data frame to make a phylo4d (tree-with-data) object.

Now we’ll take the Geospiza data from geospiza_raw$data and merge it with the tree. First, let’s prepare the data:

g1 <- as(geospiza_raw$tree, "phylo4")
geodata <- geospiza_raw$data

However, since G. olivacea is included in the tree but not in the data set, we will initially run into some trouble:

g2 <- phylo4d(g1, geodata)
#> Error in formatData(phy = x, dt = tip.data, type = "tip", ...): The following nodes are not found in the dataset:  olivacea

To deal with G. olivacea missing from the data, we have a few choices. The easiest is to use to allow to create the new object with a warning (you can also use to proceed without warnings):

g2 <- phylo4d(g1, geodata, missing.data="warn")
#> Warning in formatData(phy = x, dt = tip.data, type = "tip", ...): The following nodes are
#> not found in the dataset: olivacea

Another way to deal with this would be to use prune() to drop the offending tip from the tree first:

g1sub <- prune(g1, "olivacea")
g1B <- phylo4d(g1sub, geodata)

The difference between the two objects is that the species G. olivacea is still present in the tree but has no data (i.e., NA) associated with it. In the other case, G. olivacea is not included in the tree anymore. The approach you choose depends on the goal of your analysis.

You can summarize the new object with the function summary. It breaks down the statistics about the traits based on whether it is associated with the tips for the internal nodes: <<geomergesum>>= summary(g2) @

Or use tdata() to extract the data (i.e., tdata(g2)). By default, tdata() will retrieve tip data, but you can also get internal node data only () or — if the tip and node data have the same format — all the data combined ().

If you want to plot the data (e.g. for checking the input), plot(tdata(g2)) will create the default plot for the data — in this case, since it is a data frame, this will be a pairs plot of the data.

Subsetting

The subset command offers a variety of ways of extracting portions of a phylo4 or phylo4d tree, keeping any tip/node data consistent.

tips.include

give a vector of tips (names or numbers) to retain

tips.exclude

give a vector of tips (names or numbers) to drop

mrca

give a vector of node or tip names or numbers; extract the clade containing these taxa

node.subtree

give a node (name or number); extract the subtree starting from this node

Different ways to extract the fuliginosa-scandens clade:

subset(g2, tips.include=c("fuliginosa", "fortis", "magnirostris",
  "conirostris", "scandens"))
subset(g2, node.subtree=21)
subset(g2, mrca=c("scandens", "fortis"))

One could drop the clade by doing

subset(g2, tips.exclude=c("fuliginosa", "fortis", "magnirostris",
  "conirostris", "scandens"))
subset(g2, tips.exclude=names(descendants(g2, MRCA(g2, c("difficilis",
"fortis")))))

Tree-walking

phylobase provides many functions that allows users to explore relationships between nodes on a tree (tree-walking and tree traversal). Most functions work by specifying the phylo4 (or phylo4d) object as the first argument, the node numbers/labels as the second argument (followed by some additional arguments).

getNode allows you to find a node based on its node number or its label. It returns a vector with node numbers as values and labels as names:

data(geospiza)
getNode(geospiza, 10)
#> pauper 
#>     10
getNode(geospiza, "pauper")
#> pauper 
#>     10

If no node is specified, they are all returned, and if a node can’t be found it’s returned as a NA. It is possible to control what happens when a node can’t be found:

getNode(geospiza)
#>   fuliginosa       fortis magnirostris  conirostris     scandens   difficilis 
#>            1            2            3            4            5            6 
#>      pallida     parvulus   psittacula       pauper   Platyspiza        fusca 
#>            7            8            9           10           11           12 
#> Pinaroloxias     olivacea          N15          N16          N17          N18 
#>           13           14           15           16           17           18 
#>          N19          N20          N21          N22          N23          N24 
#>           19           20           21           22           23           24 
#>          N25          N26          N27 
#>           25           26           27
getNode(geospiza, 10:14)
#>       pauper   Platyspiza        fusca Pinaroloxias     olivacea 
#>           10           11           12           13           14
getNode(geospiza, "melanogaster", missing="OK") # no warning
#> <NA> 
#>   NA
getNode(geospiza, "melanogaster", missing="warn") # warning!
#> Warning in getNode(geospiza, "melanogaster", missing = "warn"): Some nodes not found
#> among all nodes in tree: melanogaster
#> <NA> 
#>   NA

children and ancestor give the immediate neighboring nodes:

children(geospiza, 16)
#>          N17 Pinaroloxias 
#>           17           13
ancestor(geospiza, 16)
#> N15 
#>  15

while descendants and ancestors can traverse the tree up to the tips or root respectively:

descendants(geospiza, 16) # by default returns only the tips
#> Pinaroloxias        fusca   Platyspiza   difficilis     scandens  conirostris 
#>           13           12           11            6            5            4 
#> magnirostris   fuliginosa       fortis      pallida       pauper     parvulus 
#>            3            1            2            7           10            8 
#>   psittacula 
#>            9
descendants(geospiza, "all") # also include the internal nodes
#> Warning in getNode(phy, node, missing = "warn"): Some nodes not found among all nodes in
#> tree: all
#> named list()
ancestors(geospiza, 20)
#> N19 N18 N17 N16 N15 
#>  19  18  17  16  15
ancestors(geospiza, 20, "ALL") # uppercase ALL includes self
#> N20 N19 N18 N17 N16 N15 
#>  20  19  18  17  16  15

siblings returns the other node(s) associated with the same ancestor:

siblings(geospiza, 20)
#> N25 
#>  25
siblings(geospiza, 20, include.self=TRUE)
#> N20 N25 
#>  20  25

MRCA returns the most common recent ancestor for a set of tips, and shortest path returns the nodes connecting 2 nodes:

MRCA(geospiza, 1:6)
#> N20 
#>  20
shortestPath(geospiza, 4, "pauper")
#> N19 N20 N21 N22 N25 N26 
#>  19  20  21  22  25  26

multiPhylo4 classes

multiPhylo4 classes are not yet implemented but will be coming soon.

Examples

Constructing a Brownian motion trait simulator

This section will describe a way of constructing a simulator that generates trait values for extant species (tips) given a tree with branch lengths, assuming a model of Brownian motion.

We can use to coerce the tree into a variance-covariance matrix form, and then use mvrnorm from the MASS package to generate a set of multivariate normally distributed values for the tips. (A benefit of this approach is that we can very quickly generate a very large number of replicates.) This example illustrates a common feature of working with phylobase — combining tools from several different packages to operate on phylogenetic trees with data.

We start with a randomly generated tree using rcoal() from ape to generate the tree topology and branch lengths:

set.seed(1001)
tree <- as(rcoal(12), "phylo4")

Next we generate the phylogenetic variance-covariance matrix (by coercing the tree to a phylo4vcov object) and pick a single set of normally distributed traits (using to pick a multivariate normal deviate with a variance-covariance matrix that matches the structure of the tree).

vmat <- as(tree, "phylo4vcov")
vmat <- cov2cor(vmat)
library(MASS)
trvec <- mvrnorm(1, mu=rep(0, 12), Sigma=vmat)

The last step (easy) is to convert the phylo4vcov object back to a phylo4d object:

treed <- phylo4d(tree, tip.data=as.data.frame(trvec))
plot(treed)

plot of chunk plotvcvphylo

Definitions/slots

This section details the internal structure of the phylo4, multiphylo4 (coming soon!), phylo4d, and multiphylo4d (coming soon!) classes. The basic building blocks of these classes are the phylo4 object and a dataframe. The phylo4 tree format is largely similar to the one used by phylo class in the package ape1.

We use “edge” for ancestor-descendant relationships in the phylogeny (sometimes called “branches”) and “edge lengths” for their lengths (“branch lengths”). Most generally, “nodes” are all species in the tree; species with descendants are “internal nodes” (we often refer to these just as “nodes”, meaning clear from context); “tips” are species with no descendants. The “root node” is the node with no ancestor (if one exists).

phylo4

Like phylo, the main components of the phylo4 class are:

edge

a 2-column matrix of integers, with \(N\) rows for a rooted tree or \(N-1\) rows for an unrooted tree and column names ancestor and descendant. Each row contains information on one edge in the tree. See below for further constraints on the edge matrix.

edge.length

numeric list of edge lengths (length \(N\) (rooted) or \(N-1\) (unrooted) or empty (length 0))

tip.label

character vector of tip labels (required), with length=# of tips. Tip labels need not be unique, but data-tree matching with non-unique labels will cause an error

node.label

character vector of node labels, length=# of internal nodes or 0 (if empty). Node labels need not be unique, but data-tree matching with non-unique labels will cause an error

order

character: “preorder”, “postorder”, or “unknown” (default), describing the order of rows in the edge matrix. , “pruningwise” and “cladewise” are accepted for compatibility with ape

The edge matrix must not contain NAs, with the exception of the root node, which has an NA for ancestor. phylobase does not enforce an order on the rows of the edge matrix, but it stores information on the current ordering in the slot — current allowable values are “unknown” (the default), “preorder” (equivalent to “cladewise” in ape) or “postorder” 2.

The basic criteria for the edge matrix are similar to those of ape, as documented it’s tree specification3. This is a modified version of those rules, for a tree with \(n\) tips and \(m\) internal nodes:

  • Tips (no descendants) are coded \(1,\ldots, n\), and internal nodes (\(\ge 1\) descendant) are coded \(n + 1, \ldots , n + m\) (\(n + 1\) is the root). Both series are numbered with no gaps.

  • The first (ancestor) column has only values \(> n\) (internal nodes): thus, values \(\le n\) (tips) appear only in the second (descendant) column

  • all internal nodes (not including the root) must appear in the first (ancestor) column at least once [unlike ape, which nominally requires each internal node to have at least two descendants (although it doesn’t absolutely prohibit them and has a function to get rid of them), phylobase does allow these “singleton nodes” and has a method hasSingle for detecting them]. Singleton nodes can be useful as a way of representing changes along a lineage; they are used this way in the ouch package.

  • the number of occurrences of a node in the first column is related to the nature of the node: once if it is a singleton, twice if it is dichotomous (i.e., of degree 3 [counting ancestor as well as descendants]), three times if it is trichotomous (degree 4), and so on.

phylobase does not technically prohibit reticulations (nodes or tips that appear more than once in the descendant column), but they will probably break most of the methods. Disconnected trees, cycles, and other exotica are not tested for, but will certainly break the methods.

We have defined basic methods for phylo4:show, print, and a variety of accessor functions (see help files). summary does not seem to be terribly useful in the context of a “raw” tree, because there is not much to compute.

phylo4d

The phylo4d class extends phylo4 with data. Tip data, and (internal) node data are stored separately, but can be retrieved together or separately with tdata(x,"tip"), tdata(x,"internal") or tdata(x,"all"). There is no separate slot for edge data, but these can be stored as node data associated with the descendant node.

phylobase/inst/nexmlfiles/0000755000176200001440000000000014553646170015376 5ustar liggesusersphylobase/inst/nexmlfiles/comp_analysis.xml0000644000176200001440000001371114553646170020764 0ustar liggesusers