From noreply at r-forge.r-project.org Tue Apr 1 03:11:54 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 1 Apr 2014 03:11:54 +0200 (CEST) Subject: [Phylobase-commits] r897 - pkg/R Message-ID: <20140401011154.DD50F1851EE@r-forge.r-project.org> Author: francois Date: 2014-04-01 03:11:51 +0200 (Tue, 01 Apr 2014) New Revision: 897 Removed: pkg/R/methods-oldclasses.R Log: not needed the same is done automatically by ape Deleted: pkg/R/methods-oldclasses.R =================================================================== --- pkg/R/methods-oldclasses.R 2014-03-31 16:24:15 UTC (rev 896) +++ pkg/R/methods-oldclasses.R 2014-04-01 01:11:51 UTC (rev 897) @@ -1,4 +0,0 @@ -setMethod("reorder", signature(x = "phylo"), function(x, order = 'cladewise') { - x <- ape::reorder.phylo(x, order) - x -}) From noreply at r-forge.r-project.org Tue Apr 1 04:05:14 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 1 Apr 2014 04:05:14 +0200 (CEST) Subject: [Phylobase-commits] r898 - pkg/R Message-ID: <20140401020514.F1FCC18708E@r-forge.r-project.org> Author: francois Date: 2014-04-01 04:05:08 +0200 (Tue, 01 Apr 2014) New Revision: 898 Added: pkg/R/MRCA-methods.R pkg/R/addData-methods.R pkg/R/ancestors.R pkg/R/descendants.R pkg/R/edgeLength-methods.R pkg/R/getNode-methods.R pkg/R/internal-constructors.R pkg/R/labels-methods.R pkg/R/nData-methods.R pkg/R/nodeId-methods.R pkg/R/phylo4-accessors.R pkg/R/phylo4-class.R pkg/R/phylo4-methods.R pkg/R/phylo4d-accessors.R pkg/R/phylo4d-class.R pkg/R/phylo4d-methods.R pkg/R/print-methods.R pkg/R/reorder-methods.R pkg/R/root-methods.R pkg/R/shortestPath-methods.R pkg/R/summary-methods.R pkg/R/tdata-methods.R Removed: pkg/R/class-phylo4.R pkg/R/class-phylo4d.R pkg/R/methods-multiphylo4.R pkg/R/methods-phylo4.R pkg/R/methods-phylo4d.R pkg/R/treewalk.R Modified: pkg/R/checkdata.R pkg/R/class-multiphylo4.R pkg/R/phylo4.R pkg/R/phylobase-package.R pkg/R/setAs-Methods.R pkg/R/tbind.R Log: major restructuring of functions to allow easier documentation with roxygen Copied: pkg/R/MRCA-methods.R (from rev 889, pkg/R/treewalk.R) =================================================================== --- pkg/R/MRCA-methods.R (rev 0) +++ pkg/R/MRCA-methods.R 2014-04-01 02:05:08 UTC (rev 898) @@ -0,0 +1,72 @@ + +##' 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 +##' @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, ...) +}) Added: pkg/R/addData-methods.R =================================================================== --- pkg/R/addData-methods.R (rev 0) +++ pkg/R/addData-methods.R 2014-04-01 02:05:08 UTC (rev 898) @@ -0,0 +1,94 @@ + +##' 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}} 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 be passed to \link{formatData} +##' @return \code{addData} returns a \code{phylo4d} object. +##' @author Francois Michonneau +##' @seealso \code{\link{tdata}} for extracting or updating data and +##' \code{\link{phylo4d}} constructor. +##' @keywords 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 at data) == 0)) { + x at data <- new.data + return(x) + } + + if (identical(pos, "after")) { + new.data <- merge(x at data, new.data, by=0, all=TRUE, + sort=FALSE, suffixes=c(".old", ".new")) + } else { + new.data <- merge(new.data, x at data, by=0, all=TRUE, + sort=FALSE, suffixes=c(".new", ".old")) + } + row.names(new.data) <- new.data[["Row.names"]] + x at data <- subset(new.data, select=-Row.names) + + 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, ...) +}) Copied: pkg/R/ancestors.R (from rev 889, pkg/R/treewalk.R) =================================================================== --- pkg/R/ancestors.R (rev 0) +++ pkg/R/ancestors.R 2014-04-01 02:05:08 UTC (rev 898) @@ -0,0 +1,227 @@ + +#' 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. +#' +#' \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 x 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") +#' @param include.self whether to include self in list of siblings +#' @param \dots a list of node numbers or names, or a vector of node numbers or +#' names +#' @return \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 +#' @include getNode-methods.R +#' @include phylo4-accessors.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 +children <- function(phy,node) { + node2 <- getNode(phy,node) + r <- which(edges(phy)[,1]==node2) + getNode(phy,edges(phy)[r,2]) +} + +##' @rdname ancestors +##' @aliases descendants +descendants <- function (phy, node, type=c("tips","children","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)) + ## if just a single node, return as a single vector + if (length(res)==1) res <- res[[1]] + } else { + ## edge matrix must be in preorder for the C function! + if (phy at order=="preorder") { + edge <- phy at 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", node, ancestor, descendant) + storage.mode(isDes) <- "logical" + + ## for internal nodes only, drop self (not sure why this rule?) + int.node <- intersect(node, nodeId(phy, "internal")) + isDes[cbind(match(int.node, descendant), + match(int.node, 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]])) + res <- getNode(phy, descendant[isDes[, seq_along(node)]]) + } + ## names(res) <- as.character(oNode[isValid]) + + 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 +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 +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 at order=="postorder") { + edge <- phy at 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", node, ancestor, descendant) + 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 + ##} +} Modified: pkg/R/checkdata.R =================================================================== --- pkg/R/checkdata.R 2014-04-01 01:11:51 UTC (rev 897) +++ pkg/R/checkdata.R 2014-04-01 02:05:08 UTC (rev 898) @@ -42,8 +42,7 @@ #' 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.R +#' @include RcppExports.R phylo4-accessors.R #' @keywords misc checkPhylo4 <- function(object) { ct <- checkTree(object) Modified: pkg/R/class-multiphylo4.R =================================================================== --- pkg/R/class-multiphylo4.R 2014-04-01 01:11:51 UTC (rev 897) +++ pkg/R/class-multiphylo4.R 2014-04-01 02:05:08 UTC (rev 898) @@ -1,5 +1,17 @@ ## 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 +#' @include class-multiphylo4.R setClass("multiPhylo4", representation(phylolist = "list", tree.names = "character"), prototype = list(phylolist = list(), tree.names = character(0))) @@ -8,6 +20,6 @@ contains = "multiPhylo4") setMethod("initialize", "multiPhylo4", function(.Object, ...) { - stop('multiPhylo and multiphylo4d not yet implemented. - Try using a list of phylo4(d) objects and lapply()') + stop("multiPhylo and multiphylo4d not yet implemented", + "Try using a list of phylo4(d) objects and lapply().") }) Deleted: pkg/R/class-phylo4.R =================================================================== --- pkg/R/class-phylo4.R 2014-04-01 01:11:51 UTC (rev 897) +++ pkg/R/class-phylo4.R 2014-04-01 02:05:08 UTC (rev 898) @@ -1,268 +0,0 @@ -#' The phylo4 class -#' -#' Classes for phylogenetic trees -#' -#' -#' @name phylo4-class -#' @aliases phylo4_orderings phylo-class 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}} constructor, the \code{\link{checkPhylo4}} -#' function to check the validity of \code{phylo4} objects. See also the -#' \code{\link{phylo4d}} constructor and the \linkS4class{phylo4d} class. -#' @keywords classes -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, - dimname = list(NULL, c("ancestor", "descendant"))), - edge.length = numeric(0), - label = character(0), - edge.label = character(0), - order = "unknown", - annote = list() - ), - validity = checkPhylo4) - -##################### -## Labels constructor -##################### - -.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=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 -} - -##################### -## phylo4 constructor -##################### - - -#' 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. -#' -#' @name phylo4-methods -#' @aliases phylo4 phylo4-methods phylo4,matrix-method phylo4,phylo-method -#' @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 -#' @note Translation functions are available from many valid tree formats. See -#' \link{coerce-methods}. -#' @section Methods: \describe{ \item{x = "matrix"}{creates a phylobase tree -#' from a matrix of edges} -#' -#' \item{x = "phylo"}{creates a phylobase tree from an object of class -#' \code{phylo}} } -#' @author phylobase team -#' @seealso \code{\link{coerce-methods}} for translation functions. The -#' \linkS4class{phylo4} class, the \code{\link{formatData}} function to check -#' the validity of \code{phylo4} objects. See also the \code{\link{phylo4d}} -#' constructor, and \linkS4class{phylo4d} class. -#' @keywords classes -#' @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) -#' -## generic -setGeneric("phylo4", function(x, ...) { standardGeneric("phylo4")} ) - -# ape orderings should be allowed for so we can import trees from ape e.g. during subsetting -phylo4_orderings <- c("unknown", "preorder", "postorder", "pruningwise", "cladewise") - -## first arg is a matrix -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(any(is.na(edge))) stop("NA are not allowed in edge matrix") ## taken care by checkTree - 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 at 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 at edge.length <- edge.length - res at label <- c(tip.label, node.label) - res at edge.label <- edge.label - res at order <- order - res at annote <- annote - - ## checkPhylo4 will return a character string if object is - ## bad, otherwise TRUE - if (is.character(checkval <- checkPhylo4(res))) stop(checkval) - return(res) -}) - -## first arg is a phylo -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 at annote <- annote - - return(res) -}) Deleted: pkg/R/class-phylo4d.R =================================================================== --- pkg/R/class-phylo4d.R 2014-04-01 01:11:51 UTC (rev 897) +++ pkg/R/class-phylo4d.R 2014-04-01 02:05:08 UTC (rev 898) @@ -1,192 +0,0 @@ -################################### -## phylo4d class -## extend: phylo with data -#' phylo4d class -setClass("phylo4d", - representation(data="data.frame", - metadata = "list"), - - prototype = list( - data = data.frame(NULL), - metadata = list()), - - validity = checkPhylo4, - contains="phylo4") - -###################### -## phylo4d constructor -###################### - -#' 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}} constructor and the \code{\link{formatData}} function -#' to check the validity of trees and data. See also the \code{\link{phylo4}} -#' constructor, the \linkS4class{phylo4} class, and the -#' \code{\link{checkPhylo4}} function to check the validity of \code{phylo4} -#' trees. -#' @keywords classes -#' @include formatData.R -#' @examples -#' example(read.tree, "ape") -#' obj <- phylo4d(as(tree.owls.bis,"phylo4"), data.frame(wing=1:3)) -#' obj -#' names(obj) -#' summary(obj) - -## TEST ME -## '...' recognized args for data are tipdata and nodedata. -## other recognized options are those known by the phylo4 constructor -## - -## generic -setGeneric("phylo4d", function(x, ...) { standardGeneric("phylo4d")} ) - -## Core part 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) - } 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) - - ## 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]) - } - -} - - -## first arg is a phylo4 -### phylo4d class rewrite -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 at data <- .phylo4Data(x=x, tip.data=tip.data, node.data=node.data, - all.data=all.data, merge.data=merge.data) - ## add any metadata - res at metadata <- metadata - return(res) -}) - - -## first arg is a matrix of edges -setMethod("phylo4d", c("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) -}) - -## first arg is a phylo -setMethod("phylo4d", "phylo", - function(x, tip.data=NULL, - node.data=NULL, all.data=NULL, [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/phylobase -r 898 From noreply at r-forge.r-project.org Tue Apr 8 17:06:22 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 17:06:22 +0200 (CEST) Subject: [Phylobase-commits] r899 - pkg/R Message-ID: <20140408150623.14B5118702E@r-forge.r-project.org> Author: francois Date: 2014-04-08 17:06:21 +0200 (Tue, 08 Apr 2014) New Revision: 899 Modified: pkg/R/nodeId-methods.R Log: added/formated documentation for nodeId and edgeId Modified: pkg/R/nodeId-methods.R =================================================================== --- pkg/R/nodeId-methods.R 2014-04-01 02:05:08 UTC (rev 898) +++ pkg/R/nodeId-methods.R 2014-04-08 15:06:21 UTC (rev 899) @@ -1,6 +1,37 @@ +##' 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(geopsiza, "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") +}) -# return node IDs (or a subset thereof) in ascending order +##' @rdname nodeId-methods +##' @aliases nodeId,phylo4-method setMethod("nodeId", signature(x="phylo4"), function(x, type=c("all", "tip","internal","root")) { @@ -28,7 +59,17 @@ }) -# return edge IDs (or a subset thereof) in edge matrix order +#### ----- edgeId + +##' @rdname nodeId-methods +##' @aliases edgeId +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")) { From noreply at r-forge.r-project.org Tue Apr 8 17:07:30 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 17:07:30 +0200 (CEST) Subject: [Phylobase-commits] r900 - pkg/R Message-ID: <20140408150730.AA9FE18703B@r-forge.r-project.org> Author: francois Date: 2014-04-08 17:07:30 +0200 (Tue, 08 Apr 2014) New Revision: 900 Modified: pkg/R/edgeLength-methods.R Log: updated/added documentation for edgeLength methods Modified: pkg/R/edgeLength-methods.R =================================================================== --- pkg/R/edgeLength-methods.R 2014-04-08 15:06:21 UTC (rev 899) +++ pkg/R/edgeLength-methods.R 2014-04-08 15:07:30 UTC (rev 900) @@ -1,37 +1,96 @@ +## 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.name 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}. +##' @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{nodeDepth}{a named vector indicating the \dQuote{depth} (the +##' distance between the root and the tip) of each tip.} +##' +##' \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})} +##' } +##' @seealso \code{ancestors}, \code{descendants}, \code{.Machine} for +##' more information about tolerance. +##' @export +##' @docType methods +##' @rdname edgeLength-methods +##' @include phylo4-class.R phylo4-methods.R phylo4-accessors.R 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 +setGeneric("hasEdgeLength", function(x) { + standardGeneric("hasEdgeLength") +}) -setMethod("depthTips", signature(x="phylo4"), function(x) { - nodeDepth(x, 1:nTips(x)) +##' @rdname edgeLength-methods +##' @aliases hasEdgeLength,phylo4-method +setMethod("hasEdgeLength", signature(x="phylo4"), + function(x) { + !all(is.na(x at edge.length)) }) +#### ----- edgeLength - -setMethod("nodeDepth", signature(x="phylo4"), - function(x, node) { - 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 - } +##' @rdname edgeLength-methods +##' @aliases edgeLength +setGeneric("edgeLength", function(x, ...) { + standardGeneric("edgeLength") }) - -setMethod("hasEdgeLength", signature(x="phylo4"), - function(x) { - !all(is.na(x at edge.length)) +##' @rdname edgeLength-methods +##' @aliases edgeLength<- +setGeneric("edgeLength<-", function(x, ..., value) { + standardGeneric("edgeLength<-") }) -# return edge lengths in order by edgeIds (same order as edge matrix) +##' @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 @@ -46,6 +105,8 @@ return(elen) }) +##' @rdname edgeLength-methods +##' @aliases edgeLength<-,phylo4-method setReplaceMethod("edgeLength", signature(x="phylo4"), function(x, use.names=TRUE, ..., value) { len <- .createEdge(value, x at edge, type="lengths", use.names) @@ -61,6 +122,57 @@ x }) +##### ------ depthTips + +##' @rdname edgeLength-methods +##' @aliases depthTips +setGeneric("depthTips", function(x) { + standardGeneric("depthTips") +}) + +##' @rdname edgeLength-methods +##' @aliases depthTips,phylo4-methods +setMethod("depthTips", signature(x="phylo4"), function(x) { + nodeDepth(x, 1:nTips(x)) +}) + +##### ----- nodeDepth + +##' @rdname edgeLength-methods +##' @aliases nodeDepth +setGeneric("nodeDepth", function(x, node) { + standardGeneric("nodeDepth") +}) + +##' @rdname edgeLength-methods +##' @aliases nodeDepth,phylo4-method +setMethod("nodeDepth", signature(x="phylo4"), + function(x, node) { + 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 + } +}) + +###### ----- sumEdgeLength + +##' @rdname edgeLength-methods +##' @aliases sumEdgeLength +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)) @@ -68,11 +180,21 @@ else { nd <- getNode(x, node) iEdges <- which(x at edge[,2] %in% nd) - sumEdges <- sum(x at edge.length[iEdges],na.rm=TRUE) + sumEdges <- sum(x at edge.length[iEdges], na.rm=TRUE) sumEdges } }) +###### ----- isUltrametric + +##' @rdname edgeLength-methods +##' @aliases isUltrametric +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)) { From noreply at r-forge.r-project.org Tue Apr 8 17:18:06 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 17:18:06 +0200 (CEST) Subject: [Phylobase-commits] r901 - pkg/R Message-ID: <20140408151806.D27091868B5@r-forge.r-project.org> Author: francois Date: 2014-04-08 17:18:06 +0200 (Tue, 08 Apr 2014) New Revision: 901 Modified: pkg/R/formatData.R Log: updated roxygen formatting Modified: pkg/R/formatData.R =================================================================== --- pkg/R/formatData.R 2014-04-08 15:07:30 UTC (rev 900) +++ pkg/R/formatData.R 2014-04-08 15:18:06 UTC (rev 901) @@ -1,58 +1,65 @@ -#' 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}} constructor, the \linkS4class{phylo4d} -#' class. See also the \code{\link{checkPhylo4}}, the \code{\link{phylo4}} -#' constructor and the \linkS4class{phylo4} class. See -#' \code{\link{coerce-methods}} for translation functions. -#' @keywords misc +##' 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}} constructor, the +##' \linkS4class{phylo4d} class. See \code{\link{coerce-methods}} for +##' translation functions. +##' @keywords misc +##' @include formatData <- function(phy, dt, type=c("tip", "internal", "all"), match.data=TRUE, rownamesAsLabels=FALSE, label.type=c("rownames", "column"), From noreply at r-forge.r-project.org Tue Apr 8 17:20:42 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 17:20:42 +0200 (CEST) Subject: [Phylobase-commits] r902 - pkg/R Message-ID: <20140408152042.CDE01186E01@r-forge.r-project.org> Author: francois Date: 2014-04-08 17:20:40 +0200 (Tue, 08 Apr 2014) New Revision: 902 Modified: pkg/R/phylobase.options.R Log: updated roxygen formatting for phylobase.options Modified: pkg/R/phylobase.options.R =================================================================== --- pkg/R/phylobase.options.R 2014-04-08 15:18:06 UTC (rev 901) +++ pkg/R/phylobase.options.R 2014-04-08 15:20:40 UTC (rev 902) @@ -1,29 +1,27 @@ -### Modified code from package sm - - -#' 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 +##' 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 phylobase.options <- function (...) { if (nargs() == 0) return(.phylobase.Options) current <- .phylobase.Options From noreply at r-forge.r-project.org Tue Apr 8 17:43:01 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 17:43:01 +0200 (CEST) Subject: [Phylobase-commits] r903 - pkg/R Message-ID: <20140408154302.056C218491C@r-forge.r-project.org> Author: francois Date: 2014-04-08 17:43:01 +0200 (Tue, 08 Apr 2014) New Revision: 903 Added: pkg/R/extractTree.R Removed: pkg/R/prune.R Modified: pkg/R/subset.R Log: cleaned up added doc for prune/subset/extractTree, extractTree in its own file, prune incorporated with subset Added: pkg/R/extractTree.R =================================================================== --- pkg/R/extractTree.R (rev 0) +++ pkg/R/extractTree.R 2014-04-08 15:43:01 UTC (rev 903) @@ -0,0 +1,35 @@ +## 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}}, \code{\link{phylo4d}}, +##' \code{\link{coerce-methods}} for translation functions. +##' @keywords methods +##' @export +##' @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") +} Deleted: pkg/R/prune.R =================================================================== --- pkg/R/prune.R 2014-04-08 15:20:40 UTC (rev 902) +++ pkg/R/prune.R 2014-04-08 15:43:01 UTC (rev 903) @@ -1,157 +0,0 @@ - -setGeneric("prune", function(x, ...) { - standardGeneric("prune") -}) - - -## return characters, sorted in NUMERIC order -.chnumsort <- function(x) { - as.character(sort(as.numeric(x))) -} - -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 at edge <- edge.new - ##TODO would prefer to leave out NA from edge.length slot, but can't - x at edge.length <- edge.length.new - x at edge.label <- edge.label.new[!is.na(edge.label.new)] - x at label <- label.new[!is.na(label.new)] - if(is.character(checkval <- checkPhylo4(x))) { - stop(checkval) - } else { - return(x) - } - -}) - -## trace("prune", browser, signature = "phylo4d") -## untrace("prune", signature = "phylo4d") -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 at data[match(nodesToKeep, rownames(x at 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),")") -## }) - Modified: pkg/R/subset.R =================================================================== --- pkg/R/subset.R 2014-04-08 15:20:40 UTC (rev 902) +++ pkg/R/subset.R 2014-04-08 15:43:01 UTC (rev 903) @@ -2,122 +2,128 @@ ## 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 -#' @aliases subset-methods subset,phylo4-method subset,phylo4d-method prune -#' prune-methods prune,phylo4-method prune,phylo4d-method [-methods -#' [,phylo4-method [,phylo4,character,missing,missing-method -#' [,phylo4,numeric,missing,missing-method -#' [,phylo4,logical,missing,missing-method -#' [,phylo4,missing,missing,missing-method [,phylo4d-method -#' [,phylo4d,ANY,character,missing-method [,phylo4d,ANY,numeric,missing-method -#' [,phylo4d,ANY,logical,missing-method [,phylo4d,ANY,missing,missing-method -#' [,phylo4,ANY,ANY,ANY-method na.omit,phylo4d-method -#' @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 \dots additional arguments to be passed to other methods -#' @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 manip methods -#' @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))) +##' 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 \dots additional arguments to be passed to other methods +##' @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 +##' @export +##' @rdname subset-methods +##' @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))) 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 @@ -127,11 +133,6 @@ node.subtree), is.null))>1) { stop("must specify at most one criterion for subsetting") } - #arglist <- list(...) - #if (length(arglist)>0) { - # warning("unused arguments: ", - # paste(names(arglist),collapse=",")) - #} all.tips <- nodeId(x, "tip") if (!is.null(tips.include)) { nodes <- getNode(x, tips.include, missing="OK") @@ -191,79 +192,231 @@ ## * in "[" methods for both phylo4 and phylo4d: ## if (!missing(...)) stop("unused argument(s)") -## phylo4 '[' methods +##### -------- 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) { x }) -## phylo4d '[' methods + +##### -------- 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 -## extract the phylo4 part of phylo4d; relies on implicit coerce method +##' @rdname subset-methods +##' @aliases prune +setGeneric("prune", function(x, ...) { + standardGeneric("prune") +}) +## return characters, sorted in NUMERIC order +.chnumsort <- function(x) { + as.character(sort(as.numeric(x))) +} -#' 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}}, \code{\link{phylo4d}}, -#' \code{\link{coerce-methods}} for translation functions. -#' @keywords methods -#' @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") -} +##' @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 at edge <- edge.new + ##TODO would prefer to leave out NA from edge.length slot, but can't + x at edge.length <- edge.length.new + x at edge.label <- edge.label.new[!is.na(edge.label.new)] + x at 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 at data[match(nodesToKeep, rownames(x at 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),")") +## }) + From noreply at r-forge.r-project.org Tue Apr 8 17:43:43 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 17:43:43 +0200 (CEST) Subject: [Phylobase-commits] r904 - pkg/R Message-ID: <20140408154343.45CCE184BE5@r-forge.r-project.org> Author: francois Date: 2014-04-08 17:43:42 +0200 (Tue, 08 Apr 2014) New Revision: 904 Added: pkg/R/subset-methods.R Log: renaming subset subset-methods Copied: pkg/R/subset-methods.R (from rev 903, pkg/R/subset.R) =================================================================== --- pkg/R/subset-methods.R (rev 0) +++ pkg/R/subset-methods.R 2014-04-08 15:43:42 UTC (rev 904) @@ -0,0 +1,422 @@ +################ +## 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 \dots additional arguments to be passed to other methods +##' @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 +##' @export +##' @rdname subset-methods +##' @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))) +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)") + +##### -------- 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) { + 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 +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 at edge <- edge.new + ##TODO would prefer to leave out NA from edge.length slot, but can't + x at edge.length <- edge.length.new + x at edge.label <- edge.label.new[!is.na(edge.label.new)] + x at 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 at data[match(nodesToKeep, rownames(x at 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),")") +## }) + From noreply at r-forge.r-project.org Tue Apr 8 18:18:17 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 18:18:17 +0200 (CEST) Subject: [Phylobase-commits] r905 - pkg/R Message-ID: <20140408161817.524E0186E77@r-forge.r-project.org> Author: francois Date: 2014-04-08 18:18:16 +0200 (Tue, 08 Apr 2014) New Revision: 905 Modified: pkg/R/treestruc.R Log: cleaning up doc, making hasSingle hasPoly and hasRetic methods Modified: pkg/R/treestruc.R =================================================================== --- pkg/R/treestruc.R 2014-04-08 15:43:42 UTC (rev 904) +++ pkg/R/treestruc.R 2014-04-08 16:18:16 UTC (rev 905) @@ -1,57 +1,89 @@ -## not bothering to check for zero branch lengths: -## consensus is that this isn't very important, -## and that it's simple enough to do -## any(edgeLength(x)==0) if necessary -hasPoly <- function(object) { - if(!checkPhylo4(object)) stop("to be used with a phylo4 object") - if (nEdges(object)==0) return(FALSE) - degree <- tabulate(edges(object, drop.root=TRUE)[, 1]) - any(degree > 2) -} +##' 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 +##' @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 at edge[, 1]) + any(degree == 1) +}) -#' Test trees for polytomies, inline nodes, or reticulation -#' -#' checks to see whether trees have (structural) polytomies, inline nodes -#' (i.e., nodes with a single descendant), or reticulation (i.e., nodes with -#' more than one ancestor) -#' -#' -#' @aliases hasSingle hasPoly hasRetic -#' @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 -#' @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) -#' -hasSingle <- function(object) { - if(!checkPhylo4(object)) stop("to be used with a phylo4 object") - if (nEdges(object)==0) return(FALSE) - degree <- tabulate(edges(object, drop.root=TRUE)[, 1]) - any(degree == 1) -} +##' @rdname treeStructure-methods +##' @aliases hasRetic +setGeneric("hasRetic", function(object) { + standardGeneric("hasRetic") +}) -hasRetic <- function(object) { - if(!checkPhylo4(object)) stop("to be used with a phylo4 object") - if (nEdges(object)==0) return(FALSE) - ancest <- tabulate(edges(object)[, 2]) - any(ancest > 1) -} +##' @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 +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 at edge[, 1]) + any(degree > 2) +}) + + ### TO BE FINISHED - Thibaut # Returns a vector of logical From noreply at r-forge.r-project.org Tue Apr 8 18:52:35 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 18:52:35 +0200 (CEST) Subject: [Phylobase-commits] r906 - pkg/R Message-ID: <20140408165235.DB73C187008@r-forge.r-project.org> Author: francois Date: 2014-04-08 18:52:35 +0200 (Tue, 08 Apr 2014) New Revision: 906 Removed: pkg/R/subset.R Log: deleting old subset.R Deleted: pkg/R/subset.R =================================================================== --- pkg/R/subset.R 2014-04-08 16:18:16 UTC (rev 905) +++ pkg/R/subset.R 2014-04-08 16:52:35 UTC (rev 906) @@ -1,422 +0,0 @@ -################ -## 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 \dots additional arguments to be passed to other methods -##' @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 -##' @export -##' @rdname subset-methods -##' @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))) -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)") - -##### -------- 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) { - 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 -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 at edge <- edge.new - ##TODO would prefer to leave out NA from edge.length slot, but can't - x at edge.length <- edge.length.new - x at edge.label <- edge.label.new[!is.na(edge.label.new)] - x at 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 at data[match(nodesToKeep, rownames(x at 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),")") -## }) - From noreply at r-forge.r-project.org Tue Apr 8 18:53:46 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 18:53:46 +0200 (CEST) Subject: [Phylobase-commits] r907 - pkg/R Message-ID: <20140408165346.559B8186F66@r-forge.r-project.org> Author: francois Date: 2014-04-08 18:53:45 +0200 (Tue, 08 Apr 2014) New Revision: 907 Modified: pkg/R/phylo4-accessors.R pkg/R/treestruc.R Log: finished commented code in treestruc and moved it to phylo4-accessor, new methods: terminalEdges and internalEdges, updated doc to reflect these changes. Modified: pkg/R/phylo4-accessors.R =================================================================== --- pkg/R/phylo4-accessors.R 2014-04-08 16:52:35 UTC (rev 906) +++ pkg/R/phylo4-accessors.R 2014-04-08 16:53:45 UTC (rev 907) @@ -74,12 +74,32 @@ ##' ##' @param x A \code{phylo4} or \code{phylo4d} object. ##' -##' @return \code{edges} returns the edge matrix that represent the -##' ancestor-descendant relationships among the nodes of the tree. +##' @return \describe{ +##' +##' \item{\code{edges}}{returns the edge matrix that represent the +##' ancestor-descendant relationships among the nodes of the tree.} ##' -##' \code{edgeOrder} returns the order in which the edge matrix is in. +##' \item{\code{edgeOrder}}{returns the order in which the edge matrix +##' is in.} ##' -##' @seealso reorder +##' \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(geosp?za) +##' 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 @@ -97,10 +117,51 @@ e }) +##### -------- edgeOrder + ##' @rdname edges-accessors +##' @aliases edgeOrder +setGeneric("edgeOrder", function(x, ...) { + standardGeneric("edgeOrder") +}) + +##' @rdname edges-accessors ##' @aliases edgeOrder,phylo4-method setMethod("edgeOrder", signature(x="phylo4"), function(x, ...) { x at order }) +##### -------- internalEdges + +##' @rdname edges-accessors +##' @aliases internalEdges +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 +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 +}) Modified: pkg/R/treestruc.R =================================================================== --- pkg/R/treestruc.R 2014-04-08 16:52:35 UTC (rev 906) +++ pkg/R/treestruc.R 2014-04-08 16:53:45 UTC (rev 907) @@ -82,40 +82,3 @@ degree <- tabulateTips(object at edge[, 1]) any(degree > 2) }) - - -### TO BE FINISHED - Thibaut - -# Returns a vector of logical -# TRUE = this edge goes from an internal node to another -#internEdges <- function(object){ -# if(!checkPhylo4(object)) stop("to be used with a phylo4 object") -# x <- object -# isTips <- (tabulate(x at edge[,1]) == 0) -# tips <- x at edge[isTips, 1] -# inter <- is.na(match(x at edge[,2],tips)) -# return(inter) -#} - -# Returns a vector of logical -# TRUE = this edge goes from an internal node to a tip -#terminEdges <- function(object){ -# return(!internEdges(object)) -#} - -#isPoly <- function(object, position=c("all", "terminal", "internal")){ -# if(!checkPhylo4(object)) stop("to be used with a phylo4 object") -# x <- object -# pos <- match.arg(position) -# res <- (tabulate(x at edge[,1]) > 2) - - # all polytomies -# if(pos=="all") return(res) - - # find which edge ends at a tip - - - - # external polytomies - -#} From noreply at r-forge.r-project.org Tue Apr 8 18:57:26 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 18:57:26 +0200 (CEST) Subject: [Phylobase-commits] r908 - pkg/R Message-ID: <20140408165727.1A91A187044@r-forge.r-project.org> Author: francois Date: 2014-04-08 18:57:26 +0200 (Tue, 08 Apr 2014) New Revision: 908 Modified: pkg/R/treePlot.R Log: updated/formatted docs for treePlot functions. Modified: pkg/R/treePlot.R =================================================================== --- pkg/R/treePlot.R 2014-04-08 16:53:45 UTC (rev 907) +++ pkg/R/treePlot.R 2014-04-08 16:57:26 UTC (rev 908) @@ -1,57 +1,58 @@ -#' 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 -#' @param phy A \code{phylo4} or \code{phylo4d} object -#' @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 \dots Currently unused, parameters to be passed on to \code{gpar} -#' @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} -#' @seealso \code{\link{phylobubbles}} -#' @keywords methods -#' @examples -#' -#' -#' ## example of plotting two grid plots on the same page -#' 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) +##' 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 +##' @param phy A \code{phylo4} or \code{phylo4d} object +##' @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 \dots Currently unused, parameters to be passed on to \code{gpar} +##' @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} +##' @seealso \code{\link{phylobubbles}} +##' @keywords methods +##' @export +##' @examples +##' +##' +##' ## example of plotting two grid plots on the same page +##' 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, @@ -161,50 +162,51 @@ -#' 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}} -#' @keywords methods -#' @examples -#' -#' -#' 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() -#' -#' +##' 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 +##' +##' +##' 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) { @@ -313,38 +315,39 @@ -#' 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}} -#' @keywords methods -#' @examples -#' -#' -#' data(geospiza) -#' coor <- phyloXXYY(geospiza) -#' plot(coor$xx, coor$yy, pch = 20) -#' -#' +##' 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 @@ -469,39 +472,40 @@ -#' 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} -#' @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. -#' +##' 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, @@ -669,29 +673,30 @@ -#' 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 -#' @keywords methods +##' 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'), From noreply at r-forge.r-project.org Tue Apr 8 19:39:20 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 19:39:20 +0200 (CEST) Subject: [Phylobase-commits] r909 - pkg/R Message-ID: <20140408173920.BDA321813E1@r-forge.r-project.org> Author: francois Date: 2014-04-08 19:39:20 +0200 (Tue, 08 Apr 2014) New Revision: 909 Modified: pkg/R/root-methods.R Log: updated doc for root methods Modified: pkg/R/root-methods.R =================================================================== --- pkg/R/root-methods.R 2014-04-08 16:57:26 UTC (rev 908) +++ pkg/R/root-methods.R 2014-04-08 17:39:20 UTC (rev 909) @@ -1,5 +1,28 @@ +##' 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 @@ -7,13 +30,30 @@ any(edges(x)[, 1] == 0) }) +##' @rdname root-methods +##' @aliases rootNode +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) - unname(edges(x)[which(edges(x)[, 1] == 0), 2]) + rootnd <- unname(edges(x)[which(edges(x)[, 1] == 0), 2]) + getNode(x, rootnd) }) +##' @rdname root-methods +##' @aliases rootNode<- +setGeneric("rootNode<-", function(x, value) { + standardGeneric("rootNode<-") +}) + +##' @rdname root-methods +##' @aliases rootNode<-,phylo4-method setReplaceMethod("rootNode", signature(x="phylo4"), function(x, value) { stop("Root node replacement not implemented yet") From noreply at r-forge.r-project.org Tue Apr 8 19:39:52 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 19:39:52 +0200 (CEST) Subject: [Phylobase-commits] r910 - pkg/R Message-ID: <20140408173952.24BC8183FAD@r-forge.r-project.org> Author: francois Date: 2014-04-08 19:39:51 +0200 (Tue, 08 Apr 2014) New Revision: 910 Modified: pkg/R/labels-methods.R Log: updated doc for labels methods Modified: pkg/R/labels-methods.R =================================================================== --- pkg/R/labels-methods.R 2014-04-08 17:39:20 UTC (rev 909) +++ pkg/R/labels-methods.R 2014-04-08 17:39:51 UTC (rev 910) @@ -3,93 +3,103 @@ ### 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<- labels,phylo4-method -#' labels<-,phylo4,ANY,ANY,character-method -#' labels<-,phylo4d,ANY,ANY,character-method hasDuplicatedLabels -#' hasDuplicatedLabels-methods hasDuplicatedLabels,phylo4-method hasNodeLabels -#' hasNodeLabels-methods hasNodeLabels,phylo4-method nodeLabels -#' nodeLabels-methods nodeLabels,phylo4-method nodeLabels<- -#' nodeLabels<-,phylo4,character-method nodeLabels<-,phylo4d,ANY-method -#' tipLabels tipLabels-methods tipLabels,phylo4-method tipLabels<- -#' tipLabels<-,phylo4,character-method tipLabels<-,phylo4d,character-method -#' hasEdgeLabels hasEdgeLabels-methods hasEdgeLabels,phylo4-method edgeLabels -#' edgeLabels<- edgeLabels-methods edgeLabels,phylo4-method -#' edgeLabels<-,phylo4,character-method -#' @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 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} } -#' @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) -#' -## return labels in increasing node order +# @aliases labels<- labels,phylo4-method +# labels<-,phylo4,ANY,ANY,character-method +# labels<-,phylo4d,ANY,ANY,character-method hasDuplicatedLabels +# hasDuplicatedLabels-methods hasDuplicatedLabels,phylo4-method hasNodeLabels +# hasNodeLabels-methods hasNodeLabels,phylo4-method nodeLabels +# nodeLabels-methods nodeLabels,phylo4-method nodeLabels<- +# nodeLabels<-,phylo4,character-method nodeLabels<-,phylo4d,ANY-method +# tipLabels tipLabels-methods tipLabels,phylo4-method tipLabels<- +# tipLabels<-,phylo4,character-method tipLabels<-,phylo4d,character-method +# hasEdgeLabels hasEdgeLabels-methods hasEdgeLabels,phylo4-method edgeLabels +# edgeLabels<- edgeLabels-methods edgeLabels,phylo4-method +# edgeLabels<-,phylo4,character-method + +##' 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 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} } +##' @export +##' @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) @@ -104,6 +114,15 @@ return(lbl) }) +##' @rdname labels-methods +##' @aliases labels<- +setGeneric("labels<-", + function(x, type, use.names, ..., value) { + standardGeneric("labels<-") + }) + +##' @rdname labels-methods +##' @aliases labels<-,phylo4,ANY,ANY,character-method setReplaceMethod("labels", signature(x="phylo4", type="ANY", use.names="ANY", value="character"), @@ -138,7 +157,17 @@ return(x) }) -### Duplicated Labels +##### -------- hasDuplicatedLabels + +##' @rdname labels-methods +##' @aliases hasDuplicatedLabels +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 @@ -149,18 +178,45 @@ any(duplicated(na.omit(labels(x, type)))) }) +##### --------- hasNodeLabels -### Node Labels +##' @rdname labels-methods +##' @aliases hasNodeLabels +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 +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 +##' @aliases nodeLabels<- +setGeneric("nodeLabels<-", + function(x, ..., value) { + standardGeneric("nodeLabels<-") + }) + +##' @rdname labels-methods +##' @aliases nodeLabels<-,phylo4,character-method setReplaceMethod("nodeLabels", signature(x="phylo4", value="character"), function(x, ..., value) { labels(x, type="internal", ...) <- value @@ -168,27 +224,63 @@ x }) -### Tip labels +##### ---------- tipLabels + +##' @rdname labels-methods +##' @aliases tipLabels +setGeneric("tipLabels", function(x) { + standardGeneric("tipLabels") +}) + +##' @rdname labels-methods +##' @aliases tipLabels,phylo4-method setMethod("tipLabels", signature(x="phylo4"), function(x) { labels(x, type="tip") }) +##' @rdname labels-methods +##' @aliases tipLabels<- +setGeneric("tipLabels<-", + function(x, ..., value) { + standardGeneric("tipLabels<-") +}) + +##' @rdname labels-methods +##' @aliases tipLabels<-,phylo4,character-method setReplaceMethod("tipLabels", signature(x="phylo4", value="character"), function(x, ..., value) { labels(x, type="tip", ...) <- value if(is.character(checkval <- checkPhylo4(x))) stop(checkval) - return(x) + return(x) }) -### Edge labels +##### ---------- hasEdgeLabels + +##' @rdname labels-methods +##' @aliases hasEdgeLabels +setGeneric("hasEdgeLabels", function(x) { + standardGeneric("hasEdgeLabels") +}) + +##' @rdname labels-methods +##' @aliases hasEdgeLabels,phylo4-method setMethod("hasEdgeLabels", signature(x="phylo4"), function(x) { !all(is.na(x at edge.label)) }) -# return edge labels in order by edgeIds (same order as edge matrix) +##### ---------- edgeLabels + +##' @rdname labels-methods +##' @aliases edgeLabels +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 @@ -199,6 +291,15 @@ return(lbl) }) +##' @rdname labels-methods +##' @aliases edgeLabels<- +setGeneric("edgeLabels<-", + function(x, ..., value) { + standardGeneric("edgeLabels<-") + }) + +##' @rdname labels-methods +##' @aliases edgeLabels<-,phylo4,character-method setReplaceMethod("edgeLabels", signature(x="phylo4", value="character"), function(x, ..., value) { lbl <- .createEdge(value, x at edge, type="labels") From noreply at r-forge.r-project.org Tue Apr 8 19:40:45 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 19:40:45 +0200 (CEST) Subject: [Phylobase-commits] r911 - pkg/R Message-ID: <20140408174045.2B6B1184F9B@r-forge.r-project.org> Author: francois Date: 2014-04-08 19:40:44 +0200 (Tue, 08 Apr 2014) New Revision: 911 Modified: pkg/R/class-multiphylo4.R Log: cosmetic change to roxygen doc. Modified: pkg/R/class-multiphylo4.R =================================================================== --- pkg/R/class-multiphylo4.R 2014-04-08 17:39:51 UTC (rev 910) +++ pkg/R/class-multiphylo4.R 2014-04-08 17:40:44 UTC (rev 911) @@ -1,17 +1,16 @@ ## 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 -#' @include class-multiphylo4.R +##' 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))) From noreply at r-forge.r-project.org Tue Apr 8 19:55:07 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 19:55:07 +0200 (CEST) Subject: [Phylobase-commits] r912 - pkg/R Message-ID: <20140408175507.946CF187025@r-forge.r-project.org> Author: francois Date: 2014-04-08 19:55:07 +0200 (Tue, 08 Apr 2014) New Revision: 912 Modified: pkg/R/print-methods.R Log: add roxygen doc for print methods. Modified: pkg/R/print-methods.R =================================================================== --- pkg/R/print-methods.R 2014-04-08 17:40:44 UTC (rev 911) +++ pkg/R/print-methods.R 2014-04-08 17:55:07 UTC (rev 912) @@ -1,88 +1,113 @@ -#' 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 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 -#' @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 -#' @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) -#' -#' -#' @export printphylo4 -printphylo4 <- 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)) - } - } -} +##' 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 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 +##' @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 +##' @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) +##' +##' +##' @export +##' @aliases print +##' @rdname print-methods +setGeneric("print") -### Hack for print/show -### from http://tolstoy.newcastle.edu.au/R/e2/devel/06/12/1363.html -setMethod("print", "phylo4", printphylo4) +##' @rdname print-methods +##' @aliases print,phylo4-method +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 +setGeneric("show") + +##' @rdname print-methods +##' @aliases show,phylo4-method setMethod("show", signature(object="phylo4"), - function(object) printphylo4(object)) + function(object) print(object)) -### names +##' @rdname print-methods +##' @aliases names +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)) }) -### Head and Tail +##' @rdname print-methods +##' @aliases 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,phylo4-method +setGeneric("tail") setMethod("tail", signature(x="phylo4"), function(x, n=20) { tail(as(x, "data.frame"), n=n) From noreply at r-forge.r-project.org Tue Apr 8 19:55:55 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 19:55:55 +0200 (CEST) Subject: [Phylobase-commits] r913 - pkg/R Message-ID: <20140408175555.D9336187035@r-forge.r-project.org> Author: francois Date: 2014-04-08 19:55:55 +0200 (Tue, 08 Apr 2014) New Revision: 913 Removed: pkg/R/phylo4.R Log: phylo4.R not needed anymore, all generic defined with their methods. Deleted: pkg/R/phylo4.R =================================================================== --- pkg/R/phylo4.R 2014-04-08 17:55:07 UTC (rev 912) +++ pkg/R/phylo4.R 2014-04-08 17:55:55 UTC (rev 913) @@ -1,186 +0,0 @@ -## Same order as in methods-phylo4.R - -## nTips - - -## depthTips -setGeneric("depthTips", function(x) { - standardGeneric("depthTips") -}) - -## nNodes -setGeneric("nNodes", function(x) { - standardGeneric("nNodes") -}) - -## nodeType -setGeneric("nodeType", function(x) { - standardGeneric("nodeType") -}) - -## nodeId -setGeneric("nodeId", function(x, type=c("all", "tip", "internal", - "root")) { - standardGeneric("nodeId") -}) - -## nodeDepth -setGeneric("nodeDepth", function(x, node) { - standardGeneric("nodeDepth") -}) - -## nEdges -setGeneric("nEdges", function(x) { - standardGeneric("nEdges") -}) - -## edges -setGeneric("edges", function(x, ...) { - standardGeneric("edges") -}) - -## edgeOrder -setGeneric("edgeOrder", function(x, ...) { - standardGeneric("edgeOrder") -}) - -## edgeId -setGeneric("edgeId", function(x, type=c("all", "tip", "internal", - "root")) { - standardGeneric("edgeId") -}) - -## hasEdgeLength -setGeneric("hasEdgeLength", function(x) { - standardGeneric("hasEdgeLength") -}) - -## edgeLength -setGeneric("edgeLength", function(x, ...) { - standardGeneric("edgeLength") -}) - -## edgeLength<- -setGeneric("edgeLength<-", function(x, ..., value) { - standardGeneric("edgeLength<-") -}) - -## sumEdgeLength -setGeneric("sumEdgeLength", function(x, node) { - standardGeneric("sumEdgeLength") -}) - -## isRooted -setGeneric("isRooted", function(x) { - standardGeneric("isRooted") -}) - -## rootNode -setGeneric("rootNode", function(x) { - standardGeneric("rootNode") -}) - -## rootNode<- -setGeneric("rootNode<-", function(x, value) { - standardGeneric("rootNode<-") -}) - -## labels -setGeneric("labels") - -## labels<- -setGeneric("labels<-", - function(x, type, use.names, ..., value) { - standardGeneric("labels<-") - }) - -## hasDuplicatedLabels -setGeneric("hasDuplicatedLabels", - function(x, type) { - standardGeneric("hasDuplicatedLabels") - }) - -## hasNodeLabels -setGeneric("hasNodeLabels", function(x) { - standardGeneric("hasNodeLabels") -}) - -## nodeLabels -setGeneric("nodeLabels", function(x) { - standardGeneric("nodeLabels") -}) - -## nodeLabels<- -setGeneric("nodeLabels<-", - function(x, ..., value) { - standardGeneric("nodeLabels<-") - }) - -## tipLabels -setGeneric("tipLabels", function(x) { - standardGeneric("tipLabels") -}) - -## tipLabels<- -setGeneric("tipLabels<-", - function(x, ..., value) { - standardGeneric("tipLabels<-") - }) - -## hasEdgeLabels -setGeneric("hasEdgeLabels", function(x) { - standardGeneric("hasEdgeLabels") -}) - -## edgeLabels -setGeneric("edgeLabels", function(x) { - standardGeneric("edgeLabels") -}) - -## edgeLabels<- -setGeneric("edgeLabels<-", - function(x, ..., value) { - standardGeneric("edgeLabels<-") - }) - -## print -setGeneric("print") - - -## head -setGeneric("head") - -## tail -setGeneric("tail") - -## isUltrametric -setGeneric("isUltrametric", function(x, tol=.Machine$double.eps^.5) { - standardGeneric("isUltrametric") -}) - - -### ----------- phylo4d methods ----------- - -##setGeneric("na.omit") - - - -##setGeneric("rootEdge", function(x, order, ...) { -## standardGeneric("rootEdge") -##}) - -################### -## Function .genlab -################### -## (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="") -} - - From noreply at r-forge.r-project.org Tue Apr 8 20:06:21 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 20:06:21 +0200 (CEST) Subject: [Phylobase-commits] r914 - pkg/R Message-ID: <20140408180621.7F752187178@r-forge.r-project.org> Author: francois Date: 2014-04-08 20:06:20 +0200 (Tue, 08 Apr 2014) New Revision: 914 Modified: pkg/R/edgeLength-methods.R pkg/R/formatData.R pkg/R/labels-methods.R pkg/R/phylo4-accessors.R pkg/R/root-methods.R Log: fixed a few things to make dev_tools::document() work Modified: pkg/R/edgeLength-methods.R =================================================================== --- pkg/R/edgeLength-methods.R 2014-04-08 17:55:55 UTC (rev 913) +++ pkg/R/edgeLength-methods.R 2014-04-08 18:06:20 UTC (rev 914) @@ -47,6 +47,7 @@ ##' more information about tolerance. ##' @export ##' @docType methods +##' @aliases hasEdgeLength ##' @rdname edgeLength-methods ##' @include phylo4-class.R phylo4-methods.R phylo4-accessors.R nodeId-methods.R ##' @examples @@ -105,6 +106,7 @@ return(elen) }) +##' @name edgeLength<- ##' @rdname edgeLength-methods ##' @aliases edgeLength<-,phylo4-method setReplaceMethod("edgeLength", signature(x="phylo4"), Modified: pkg/R/formatData.R =================================================================== --- pkg/R/formatData.R 2014-04-08 17:55:55 UTC (rev 913) +++ pkg/R/formatData.R 2014-04-08 18:06:20 UTC (rev 914) @@ -59,7 +59,6 @@ ##' \linkS4class{phylo4d} class. See \code{\link{coerce-methods}} for ##' translation functions. ##' @keywords misc -##' @include formatData <- function(phy, dt, type=c("tip", "internal", "all"), match.data=TRUE, rownamesAsLabels=FALSE, label.type=c("rownames", "column"), Modified: pkg/R/labels-methods.R =================================================================== --- pkg/R/labels-methods.R 2014-04-08 17:55:55 UTC (rev 913) +++ pkg/R/labels-methods.R 2014-04-08 18:06:20 UTC (rev 914) @@ -121,6 +121,7 @@ standardGeneric("labels<-") }) +##' @name labels<- ##' @rdname labels-methods ##' @aliases labels<-,phylo4,ANY,ANY,character-method setReplaceMethod("labels", @@ -215,6 +216,7 @@ standardGeneric("nodeLabels<-") }) +##' @name nodeLabels<- ##' @rdname labels-methods ##' @aliases nodeLabels<-,phylo4,character-method setReplaceMethod("nodeLabels", signature(x="phylo4", value="character"), @@ -246,6 +248,7 @@ standardGeneric("tipLabels<-") }) +##' @name tipLabels<- ##' @rdname labels-methods ##' @aliases tipLabels<-,phylo4,character-method setReplaceMethod("tipLabels", signature(x="phylo4", value="character"), @@ -298,6 +301,7 @@ standardGeneric("edgeLabels<-") }) +##' @name edgeLabels<- ##' @rdname labels-methods ##' @aliases edgeLabels<-,phylo4,character-method setReplaceMethod("edgeLabels", signature(x="phylo4", value="character"), Modified: pkg/R/phylo4-accessors.R =================================================================== --- pkg/R/phylo4-accessors.R 2014-04-08 17:55:55 UTC (rev 913) +++ pkg/R/phylo4-accessors.R 2014-04-08 18:06:20 UTC (rev 914) @@ -4,6 +4,7 @@ ##' 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. Modified: pkg/R/root-methods.R =================================================================== --- pkg/R/root-methods.R 2014-04-08 17:55:55 UTC (rev 913) +++ pkg/R/root-methods.R 2014-04-08 18:06:20 UTC (rev 914) @@ -52,6 +52,7 @@ standardGeneric("rootNode<-") }) +##' @name rootNode<- ##' @rdname root-methods ##' @aliases rootNode<-,phylo4-method setReplaceMethod("rootNode", signature(x="phylo4"), From noreply at r-forge.r-project.org Tue Apr 8 23:10:44 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 23:10:44 +0200 (CEST) Subject: [Phylobase-commits] r915 - pkg/R Message-ID: <20140408211044.B318F184F9B@r-forge.r-project.org> Author: francois Date: 2014-04-08 23:10:44 +0200 (Tue, 08 Apr 2014) New Revision: 915 Added: pkg/R/setAs-methods.R Log: cosmetic changes to code, cleaned/added roxygen documentation Copied: pkg/R/setAs-methods.R (from rev 898, pkg/R/setAs-Methods.R) =================================================================== --- pkg/R/setAs-methods.R (rev 0) +++ pkg/R/setAs-methods.R 2014-04-08 21:10:44 UTC (rev 915) @@ -0,0 +1,307 @@ + +##' 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{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 +##' @seealso generic \code{\link[methods]{as}}, \code{\link{phylo4}}, +##' \code{\link{phylo4d}}, \code{\link{extractTree}}, the original +##' \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 +##' @export +##' @include phylo4-methods.R +##' @include phylo4d-methods.R +##' @include oldclasses-class.R +##' @examples +##' +##' tree.owls <- ape::read.tree(text="(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);") +##' ## 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 at 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()) +}) + + +####################################################### +## 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 at edge, from at edge.length, from at tip.label, +## from at node.label,from at edge.label,from at 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 at root.edge)) +## # y$root.edge <- from at 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) + tDf$label <- as.character(tDf$label) + + if (class(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 +}) From noreply at r-forge.r-project.org Tue Apr 8 23:11:38 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 23:11:38 +0200 (CEST) Subject: [Phylobase-commits] r916 - pkg/R Message-ID: <20140408211138.ED375184FA3@r-forge.r-project.org> Author: francois Date: 2014-04-08 23:11:38 +0200 (Tue, 08 Apr 2014) New Revision: 916 Added: pkg/R/multiphylo4-class.R Removed: pkg/R/class-multiphylo4.R Log: renaming class-multiphylo4 to multiphylo4-class, moving setAs code for this class here Deleted: pkg/R/class-multiphylo4.R =================================================================== --- pkg/R/class-multiphylo4.R 2014-04-08 21:10:44 UTC (rev 915) +++ pkg/R/class-multiphylo4.R 2014-04-08 21:11:38 UTC (rev 916) @@ -1,24 +0,0 @@ -## 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, ...) { - stop("multiPhylo and multiphylo4d not yet implemented", - "Try using a list of phylo4(d) objects and lapply().") -}) Copied: pkg/R/multiphylo4-class.R (from rev 911, pkg/R/class-multiphylo4.R) =================================================================== --- pkg/R/multiphylo4-class.R (rev 0) +++ pkg/R/multiphylo4-class.R 2014-04-08 21:11:38 UTC (rev 916) @@ -0,0 +1,53 @@ +## 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 at phylolist, function(x) as(x, "phylo")) + names(y) <- from at tree.names + if (hasTipData(from)) + warning("discarded tip data") + class(y) <- "multiPhylo" + y +}) From noreply at r-forge.r-project.org Tue Apr 8 23:12:54 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 23:12:54 +0200 (CEST) Subject: [Phylobase-commits] r917 - pkg/R Message-ID: <20140408211254.68CC4185F02@r-forge.r-project.org> Author: francois Date: 2014-04-08 23:12:54 +0200 (Tue, 08 Apr 2014) New Revision: 917 Added: pkg/R/oldclasses-class.R pkg/R/phylomats-class.R Removed: pkg/R/class-oldclasses.R pkg/R/class-phylomats.R Log: file renaming from class-*.R to *-class.R Deleted: pkg/R/class-oldclasses.R =================================================================== --- pkg/R/class-oldclasses.R 2014-04-08 21:11:38 UTC (rev 916) +++ pkg/R/class-oldclasses.R 2014-04-08 21:12:54 UTC (rev 917) @@ -1,13 +0,0 @@ -## 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") Deleted: pkg/R/class-phylomats.R =================================================================== --- pkg/R/class-phylomats.R 2014-04-08 21:11:38 UTC (rev 916) +++ pkg/R/class-phylomats.R 2014-04-08 21:12:54 UTC (rev 917) @@ -1,131 +0,0 @@ - -#' 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 -#' @keywords classes -#' @examples -#' -#' tree.owls <- ape::read.tree(text="(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);") -#' 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 at edge.label, - order=from at order) -} -setAs("phylo4","phylo4vcov", - function(from,to) { - as_phylo4vcov(from)}) - -## var-cov to phylo4 -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 at edge.label,order="unknown"), - "preorder") - }) - - Copied: pkg/R/oldclasses-class.R (from rev 880, pkg/R/class-oldclasses.R) =================================================================== --- pkg/R/oldclasses-class.R (rev 0) +++ pkg/R/oldclasses-class.R 2014-04-08 21:12:54 UTC (rev 917) @@ -0,0 +1,13 @@ +## 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") Copied: pkg/R/phylomats-class.R (from rev 890, pkg/R/class-phylomats.R) =================================================================== --- pkg/R/phylomats-class.R (rev 0) +++ pkg/R/phylomats-class.R 2014-04-08 21:12:54 UTC (rev 917) @@ -0,0 +1,131 @@ + +#' 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 +#' @keywords classes +#' @examples +#' +#' tree.owls <- ape::read.tree(text="(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);") +#' 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 at edge.label, + order=from at order) +} +setAs("phylo4","phylo4vcov", + function(from,to) { + as_phylo4vcov(from)}) + +## var-cov to phylo4 +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 at edge.label,order="unknown"), + "preorder") + }) + + From noreply at r-forge.r-project.org Tue Apr 8 23:13:38 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 23:13:38 +0200 (CEST) Subject: [Phylobase-commits] r918 - pkg/R Message-ID: <20140408211338.B98691861BD@r-forge.r-project.org> Author: francois Date: 2014-04-08 23:13:38 +0200 (Tue, 08 Apr 2014) New Revision: 918 Removed: pkg/R/descendants.R Log: descendants.R not needed anymore, content moved to ancestors.R and getNode-methods.R Deleted: pkg/R/descendants.R =================================================================== --- pkg/R/descendants.R 2014-04-08 21:12:54 UTC (rev 917) +++ pkg/R/descendants.R 2014-04-08 21:13:38 UTC (rev 918) @@ -1,496 +0,0 @@ -## 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. -#' -#' @aliases getNode getEdge nodeId nodeId,phylo4-method edgeId -#' edgeId,phylo4-method -#' @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 -#' @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") -#' -getNode <- 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) -} - - -#' 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. Invalid nodes are automatically omitted by -#' \code{ancestors} and \code{descendants}, with a warning. \code{ancestor} -#' will return \code{NA} for any invalid nodes, with a warning. Both -#' \code{children} and \code{siblings} will return an empty vector, again with -#' a warning. In contrast, \code{MRCA} and \code{shortestPath} will throw an -#' immediate error if any input nodes are invalid. -#' -#' @aliases children descendants ancestor ancestors siblings MRCA shortestPath -#' sumEdgeLength sumEdgeLength,phylo4-method -#' @param phy a \linkS4class{phylo4} object (or one inheriting from -#' \linkS4class{phylo4}, e.g. a \linkS4class{phylo4d} object) -#' @param x 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") -#' @param include.self whether to include self in list of siblings -#' @param \dots a list of node numbers or names, or a vector of node numbers or -#' names -#' @param node1 a node number (or name) -#' @param node2 a node number (or name) -#' @return \item{list("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{ and }{ 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{list("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{list("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; \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{ and }{ \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; \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{list("children")}{ \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; -#' \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{list("siblings")}{ returns sibling nodes -#' (children of the same parent)} \item{list("MRCA")}{ returns the most recent -#' common ancestor of two or more nodes} \item{list("shortestPath")}{ returns -#' the nodes of the shortest path from one node to another (excluding -#' \code{node1} and \code{node2})} \item{list("sumEdgeLength")}{ returns the -#' sum of branch length for branches starting at nodes provided} -#' @note \code{MRCA} is uppercase to avoid conflict with \code{mrca} in ape -#' @seealso \code{\link[ape]{mrca}}, in the ape package, gives a list of all -#' subtrees -#' @keywords misc -#' @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")) -} - - -children <- function(phy,node) { - node2 <- getNode(phy,node) - r <- which(edges(phy)[,1]==node2) - getNode(phy,edges(phy)[r,2]) -} - -## get descendants [recursively] -descendants <- function (phy, node, type=c("tips","children","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)) - ## if just a single node, return as a single vector - if (length(res)==1) res <- res[[1]] - } else { - ## edge matrix must be in preorder for the C function! - if (phy at order=="preorder") { - edge <- phy at 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", node, ancestor, descendant) - storage.mode(isDes) <- "logical" - - ## for internal nodes only, drop self (not sure why this rule?) - int.node <- intersect(node, nodeId(phy, "internal")) - isDes[cbind(match(int.node, descendant), - match(int.node, 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]])) - res <- getNode(phy, descendant[isDes[, seq_along(node)]]) - } - ## names(res) <- as.character(oNode[isValid]) - - 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)) - ##} -} - -siblings <- function(phy, node, include.self=FALSE) { - v <- children(phy,ancestor(phy,node)) - if (!include.self) v <- v[v!=getNode(phy,node)] - v -} - -## get ancestors (all nodes) -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 at order=="postorder") { - edge <- phy at 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", node, ancestor, descendant) - 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 - ##} -} - -MRCA <- 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]]) - } - - ## Correct behavior when the root is part of the nodes - testNodes <- lapply(nodes, getNode, x=phy) - ## BMB: why lapply, not sapply? - lNodes <- unlist(testNodes) - if (any(is.na(lNodes))) - stop("nodes not found in tree: ",paste(names(lNodes)[is.na(lNodes)], - collapse=", ")) - uniqueNodes <- unique(testNodes) - root <- nTips(phy)+1 - 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) - } -} # end MRCA - - -############### -# shortestPath -############### -shortestPath <- function(phy, node1, node2){ - - ## conversion from phylo, phylo4 and phylo4d - if (class(phy) == "phylo4d") { - x <- extractTree(phy) - } - else if (class(phy) != "phylo4"){ - x <- as(phy, "phylo4") - } - - ## some checks - ## if (is.character(checkval <- checkPhylo4(x))) stop(checkval) # no need - t1 <- getNode(x, node1) - t2 <- getNode(x, node2) - if(any(is.na(c(t1,t2)))) stop("wrong node specified") - if(t1==t2) return(NULL) - - ## main computations - comAnc <- MRCA(x, t1, t2) # common ancestor - desComAnc <- descendants(x, comAnc, type="all") - ancT1 <- ancestors(x, t1, type="all") - path1 <- intersect(desComAnc, ancT1) # path: common anc -> t1 - - ancT2 <- ancestors(x, 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(x, res) - - return(res) -} # end shortestPath - - - -########### -# getEdge -########### -getEdge <- function(x, node, type=c("descendant", "ancestor"), - missing=c("warn", "OK", "fail")) { - - if(!identical(class(x), "phylo4")) x <- as(x, "phylo4") - - 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))) - -} From noreply at r-forge.r-project.org Tue Apr 8 23:14:16 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 23:14:16 +0200 (CEST) Subject: [Phylobase-commits] r919 - pkg/R Message-ID: <20140408211416.D57CD18651B@r-forge.r-project.org> Author: francois Date: 2014-04-08 23:14:16 +0200 (Tue, 08 Apr 2014) New Revision: 919 Removed: pkg/R/setAs-Methods.R Log: deleting file, now called setAs-methods.R Deleted: pkg/R/setAs-Methods.R =================================================================== --- pkg/R/setAs-Methods.R 2014-04-08 21:13:38 UTC (rev 918) +++ pkg/R/setAs-Methods.R 2014-04-08 21:14:16 UTC (rev 919) @@ -1,332 +0,0 @@ -####################################################### -## Importing from ape -#' 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{ade4} objects -#' (\code{phylog}, \emph{now deprecated}), and to \code{data.frame} -#' representation. -#' -#' -#' @name as -#' @aliases as as-method as,phylo,phylo4-method as,phylo,phylo4d-method -#' as,multiPhylo4,multiPhylo-method as,multiPhylo,multiPhylo4-method -#' as,multiPhylo4d,multiPhylo-method as,phylo4,phylo-method -#' as,phylo4d,phylo-method as,phylo4,data.frame-method -#' as,phylo4d,data.frame-method as,phylo4vcov,phylo4-method -#' as,phylo4,phylo4vcov-method coerce-methods coerce,phylo,phylo4-method -#' coerce,phylo,phylo4d-method coerce,multiPhylo4,multiPhylo-method -#' coerce,multiPhylo,multiPhylo4-method coerce,multiPhylo4d,multiPhylo-method -#' coerce,phylo4,phylo-method coerce,phylo4d,phylo-method -#' coerce,phylo4,data.frame-method coerce,phylo4d,data.frame-method -#' coerce,phylo4vcov,phylo4-method coerce,phylo4,phylo4vcov-method -#' @docType methods -#' @section Usage: \code{as(object, class)} -#' @author Ben Bolker, Thibaut Jombart, Marguerite Butler, Steve Kembel -#' @seealso generic \code{\link[methods]{as}}, \code{\link{phylo4}}, -#' \code{\link{phylo4d}}, \code{\link{extractTree}}, the original -#' \code{\link[ade4]{phylog}} from the \code{ade4} package and -#' \code{\link[ape]{as.phylo}} from the \code{ape} package. -#' @keywords methods -#' @export -#' @include phylo4-methods.R -#' @include phylo4d-methods.R -#' @examples -#' -#' tree.owls <- ape::read.tree(text="(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);") -#' ## 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 at 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 -}) - -setAs("phylo", "phylo4d", function(from, to) { - phylo4d(as(from, "phylo4"), tip.data = data.frame()) -}) - -#' 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 -}) - -####################################################### -## 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 at edge, from at edge.length, from at tip.label, -## from at node.label,from at edge.label,from at order) -## }) - -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 at root.edge)) -## # y$root.edge <- from at root.edge -## warning("losing data while coercing phylo4d to phylo") -## y -##}) -#' Class "phylog" -#' -#' S4 version of the class \code{phylog} from the \code{ade4} package. -#' -#' -#' @name phylog-class -#' @aliases phylog-class coerce,phylo4,phylog-method -#' @docType class -#' @section Objects from the Class: A virtual Class: No objects may be created -#' from it. -#' @author Thibaut Jombart \email{jombart@@biomserv.univ-lyon1.fr} -#' @seealso The original \code{\link[ade4]{phylog}} from the \code{ade4} -#' package. -#' @keywords classes -NULL -setAs("multiPhylo4", "multiPhylo", function(from, to) { - y <- lapply(from at phylolist, function(x) as(x, "phylo")) - names(y) <- from at tree.names - if (hasTipData(from)) - warning("discarded tip data") - class(y) <- "multiPhylo" - y -}) - -####################################################### -## Exporting to ade4 -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) - tDf$label <- as.character(tDf$label) - - if (class(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 -} - -setAs(from = "phylo4", to = "data.frame", def=function(from) { - d <- .phylo4ToDataFrame(from, edgeOrder="pretty") - d -}) From noreply at r-forge.r-project.org Tue Apr 8 23:15:27 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 23:15:27 +0200 (CEST) Subject: [Phylobase-commits] r920 - pkg/R Message-ID: <20140408211527.2EB73186880@r-forge.r-project.org> Author: francois Date: 2014-04-08 23:15:26 +0200 (Tue, 08 Apr 2014) New Revision: 920 Modified: pkg/R/ancestors.R pkg/R/checkdata.R pkg/R/edgeLength-methods.R pkg/R/extractTree.R pkg/R/phylo4-accessors.R pkg/R/phylobase-package.R pkg/R/print-methods.R pkg/R/reorder-methods.R Log: fixed @include for correct order in NAMESPACE collate, and cosmetic changes to roxygen doc Modified: pkg/R/ancestors.R =================================================================== --- pkg/R/ancestors.R 2014-04-08 21:14:16 UTC (rev 919) +++ pkg/R/ancestors.R 2014-04-08 21:15:26 UTC (rev 920) @@ -1,85 +1,86 @@ -#' 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. -#' -#' \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 x 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") -#' @param include.self whether to include self in list of siblings -#' @param \dots a list of node numbers or names, or a vector of node numbers or -#' names -#' @return \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 -#' @include getNode-methods.R -#' @include phylo4-accessors.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")) +##' 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. +##' +##' \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 x 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") +##' @param include.self whether to include self in list of siblings +##' @param \dots a list of node numbers or names, or a vector of node numbers or +##' names +##' @return \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 +##' @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) Modified: pkg/R/checkdata.R =================================================================== --- pkg/R/checkdata.R 2014-04-08 21:14:16 UTC (rev 919) +++ pkg/R/checkdata.R 2014-04-08 21:15:26 UTC (rev 920) @@ -1,49 +1,51 @@ ## 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{http://ape.mpl.ird.fr/misc/FormatTreeR_28July2008.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; \code{\link{formatData}}, the \code{\link{phylo4d}} 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 phylo4-accessors.R -#' @keywords misc +##' 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{http://ape.mpl.ird.fr/misc/FormatTreeR_28July2008.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; \code{\link{formatData}}, the \code{\link{phylo4d}} 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 +##' @keywords misc checkPhylo4 <- function(object) { ct <- checkTree(object) Modified: pkg/R/edgeLength-methods.R =================================================================== --- pkg/R/edgeLength-methods.R 2014-04-08 21:14:16 UTC (rev 919) +++ pkg/R/edgeLength-methods.R 2014-04-08 21:15:26 UTC (rev 920) @@ -49,7 +49,9 @@ ##' @docType methods ##' @aliases hasEdgeLength ##' @rdname edgeLength-methods -##' @include phylo4-class.R phylo4-methods.R phylo4-accessors.R nodeId-methods.R +##' @include phylo4-class.R +##' @include phylo4-methods.R +##' @include nodeId-methods.R ##' @examples ##' data(geospiza) ##' hasEdgeLength(geospiza) # TRUE Modified: pkg/R/extractTree.R =================================================================== --- pkg/R/extractTree.R 2014-04-08 21:14:16 UTC (rev 919) +++ pkg/R/extractTree.R 2014-04-08 21:15:26 UTC (rev 920) @@ -20,6 +20,7 @@ ##' \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") Modified: pkg/R/phylo4-accessors.R =================================================================== --- pkg/R/phylo4-accessors.R 2014-04-08 21:14:16 UTC (rev 919) +++ pkg/R/phylo4-accessors.R 2014-04-08 21:15:26 UTC (rev 920) @@ -10,7 +10,7 @@ ##' edge respectively. ##' @docType methods ##' @export -##' @include phylo4-methods.R +##' @include phylo4-class.R phylo4-methods.R ##' @rdname nTips-methods setGeneric("nTips", function(x) { standardGeneric("nTips") Modified: pkg/R/phylobase-package.R =================================================================== --- pkg/R/phylobase-package.R 2014-04-08 21:14:16 UTC (rev 919) +++ pkg/R/phylobase-package.R 2014-04-08 21:15:26 UTC (rev 920) @@ -71,6 +71,7 @@ #' @importFrom stats reorder #' @importFrom utils head tail #' @importFrom ade4 newick2phylog +#' #' #' @exportMethod print head tail reorder plot summary #' @exportMethod phylo4 phylo4d @@ -82,7 +83,6 @@ #' @exportMethod [<- [[ [[<- #' @exportMethod labels labels<- nodeLabels nodeLabels<- tipLabels tipLabels<- edgeLabels edgeLabels<- #' @exportMethod hasNodeLabels hasEdgeLabels hasDuplicatedLabels -#' NULL Modified: pkg/R/print-methods.R =================================================================== --- pkg/R/print-methods.R 2014-04-08 21:14:16 UTC (rev 919) +++ pkg/R/print-methods.R 2014-04-08 21:15:26 UTC (rev 920) @@ -32,8 +32,8 @@ ##' @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 +##' @author Marguerite Butler, Thibaut Jombart \email{jombart@@biomserv.univ-lyon1.fr}, Steve Kembel +##' @include setAs-methods.R ##' @keywords methods ##' @examples ##' @@ -72,7 +72,6 @@ } }) - ##' @rdname print-methods ##' @aliases show setGeneric("show") Modified: pkg/R/reorder-methods.R =================================================================== --- pkg/R/reorder-methods.R 2014-04-08 21:14:16 UTC (rev 919) +++ pkg/R/reorder-methods.R 2014-04-08 21:15:26 UTC (rev 920) @@ -37,7 +37,7 @@ ##' \code{\link{children}} \code{\link{descendants}} ##' @keywords methods ##' @include phylo4-class.R -##' @include phylo4-accessors.R +##' @include phylo4-methods.R ##' @export ##' @examples ##' phy <- phylo4(ape::rtree(5)) From noreply at r-forge.r-project.org Tue Apr 8 23:23:25 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Apr 2014 23:23:25 +0200 (CEST) Subject: [Phylobase-commits] r921 - pkg/R Message-ID: <20140408212325.C79EF187446@r-forge.r-project.org> Author: francois Date: 2014-04-08 23:23:25 +0200 (Tue, 08 Apr 2014) New Revision: 921 Modified: pkg/R/pdata.R pkg/R/phylo4d-class.R pkg/R/phylobase-package.R pkg/R/phylomats-class.R pkg/R/readNCL.R pkg/R/summary-methods.R Log: more cosmetic changes to roxygen doc Modified: pkg/R/pdata.R =================================================================== --- pkg/R/pdata.R 2014-04-08 21:15:26 UTC (rev 920) +++ pkg/R/pdata.R 2014-04-08 21:23:25 UTC (rev 921) @@ -2,20 +2,20 @@ 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 +##' 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 setClass("pdata", representation(data="data.frame", type="factor", comment="character", @@ -26,23 +26,23 @@ ## 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 +##' 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)) { Modified: pkg/R/phylo4d-class.R =================================================================== --- pkg/R/phylo4d-class.R 2014-04-08 21:15:26 UTC (rev 920) +++ pkg/R/phylo4d-class.R 2014-04-08 21:23:25 UTC (rev 921) @@ -1,32 +1,32 @@ ################################### ## 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}} constructor and the \code{\link{formatData}} function -#' to check the validity of trees and data. See also the \code{\link{phylo4}} -#' 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) +##' 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}} constructor and the \code{\link{formatData}} function +##' to check the validity of trees and data. See also the \code{\link{phylo4}} +##' 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"), Modified: pkg/R/phylobase-package.R =================================================================== --- pkg/R/phylobase-package.R 2014-04-08 21:15:26 UTC (rev 920) +++ pkg/R/phylobase-package.R 2014-04-08 21:23:25 UTC (rev 921) @@ -1,132 +1,132 @@ -#' 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{http://ncl.sourceforge.net/?}) -#' } -#' -#' @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 -#' @docType 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}. -#' @keywords package -#' -#' @useDynLib phylobase -#' @import methods -#' @import ape -#' @importFrom Rcpp evalCpp -#' @importFrom graphics plot -#' @importFrom stats reorder -#' @importFrom utils head tail -#' @importFrom ade4 newick2phylog -#' -#' -#' @exportMethod print head tail reorder plot summary -#' @exportMethod phylo4 phylo4d -#' @exportMethod edges edgeId hasEdgeLength edgeLength edgeLength<- sumEdgeLength edgeOrder -#' @exportMethod isRooted rootNode rootNode<- -#' @exportMethod nodeId nodeType nodeDepth -#' @exportMethod isUltrametric -#' @exportMethod subset prune [ -#' @exportMethod [<- [[ [[<- -#' @exportMethod labels labels<- nodeLabels nodeLabels<- tipLabels tipLabels<- edgeLabels edgeLabels<- -#' @exportMethod hasNodeLabels hasEdgeLabels hasDuplicatedLabels +##' 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{http://ncl.sourceforge.net/?}) +##' } +##' +##' @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 +##' @docType 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}. +##' @keywords package +##' +##' @useDynLib phylobase +##' @import methods +##' @import ape +##' @importFrom Rcpp evalCpp +##' @importFrom graphics plot +##' @importFrom stats reorder +##' @importFrom utils head tail +##' @importFrom ade4 newick2phylog +##' +##' +##' @exportMethod print head tail reorder plot summary +##' @exportMethod phylo4 phylo4d +##' @exportMethod edges edgeId hasEdgeLength edgeLength edgeLength<- sumEdgeLength edgeOrder +##' @exportMethod isRooted rootNode rootNode<- +##' @exportMethod nodeId nodeType nodeDepth +##' @exportMethod isUltrametric +##' @exportMethod subset prune [ +##' @exportMethod [<- [[ [[<- +##' @exportMethod labels labels<- nodeLabels nodeLabels<- tipLabels tipLabels<- edgeLabels edgeLabels<- +##' @exportMethod hasNodeLabels hasEdgeLabels hasDuplicatedLabels NULL -#' 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) -#' +##' 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) -#' +##' '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 Modified: pkg/R/phylomats-class.R =================================================================== --- pkg/R/phylomats-class.R 2014-04-08 21:15:26 UTC (rev 920) +++ pkg/R/phylomats-class.R 2014-04-08 21:23:25 UTC (rev 921) @@ -1,47 +1,48 @@ -#' 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 -#' @keywords classes -#' @examples -#' -#' tree.owls <- ape::read.tree(text="(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);") -#' 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. -#' -#' +##' 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 +##' @examples +##' +##' tree.owls <- ape::read.tree(text="(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);") +##' 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", @@ -57,11 +58,14 @@ edge.label=from at edge.label, order=from at order) } +##' @rdname phylomat-class +##' @aliases setAs,phylo,phylo4vcov-method setAs("phylo4","phylo4vcov", function(from,to) { as_phylo4vcov(from)}) -## var-cov to phylo4 +##' @rdname phylomat-class +##' @aliases setAs,phylo4vcov,phylo4-method setAs("phylo4vcov","phylo4", function(from,to) { matrix2tree <- function(v,reorder=TRUE) { Modified: pkg/R/readNCL.R =================================================================== --- pkg/R/readNCL.R 2014-04-08 21:15:26 UTC (rev 920) +++ pkg/R/readNCL.R 2014-04-08 21:23:25 UTC (rev 921) @@ -3,97 +3,97 @@ ### - readNexus (wrapper for readNCL importing Nexus files) ### - readNewick (wrapper for readNCL importing Newick files) -#' Create a phylo4, phylo4d or data.frame object from a Nexus or a Newick file -#' -#' \code{readNexus} reads a Nexus file and outputs a \code{phylo4} or -#' \code{phylo4d} or \code{data.frame} object. -#' -#' \code{readNewick} reads a Newick file and outputs a \code{phylo4} or -#' \code{phylo4d} object. -#' -#' -#' \code{readNexus} extracts data held in a Nexus file, specifically from DATA, -#' CHARACTER or TREES blocks present in the file. 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. In addition with \code{type="all"}, the -#' \code{phylo4d} constructor will be used if -#' \code{check.node.labels="asdata"}. -#' -#' \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 thus \code{check.node.labels} takes 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 documentation of \link{phylo4-methods}, -#' \link{phylo4d} and \link{formatData} for the complete list of options. -#' -#' @name Import Nexus and Newick files -#' @aliases readNexus readNCL readNewick -#' @docType methods -#' @param file a Nexus file for \code{readNexus} or a file that contains Newick -#' formatted trees for \code{readNewick} -#' @param simplify If there are multiple trees in the file, only the first one -#' is returned if TRUE and a list of phylo4/phylo4d 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 char.all If TRUE, returns all characters, even those excluded in the -#' NEXUS file -#' @param polymorphic.convert If TRUE, converts polymorphic characters to -#' missing data -#' @param levels.uniform If TRUE, uses the same levels for all characters -#' @param quiet If 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 TRUE) or state codes -#' should be returned. -#' @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 (by \sQuote{make.names}) so that they are. -#' @param convert.edge.length logical. If \sQuote{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 still use trees with -#' negative branch lengths are an artifact of the method used to build the -#' tree. -#' @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 when read by NCL. 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 -#' @keywords misc +##' Create a phylo4, phylo4d or data.frame object from a Nexus or a Newick file +##' +##' \code{readNexus} reads a Nexus file and outputs a \code{phylo4} or +##' \code{phylo4d} or \code{data.frame} object. +##' +##' \code{readNewick} reads a Newick file and outputs a \code{phylo4} or +##' \code{phylo4d} object. +##' +##' \code{readNexus} extracts data held in a Nexus file, specifically from DATA, +##' CHARACTER or TREES blocks present in the file. 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. In addition with \code{type="all"}, the +##' \code{phylo4d} constructor will be used if +##' \code{check.node.labels="asdata"}. +##' +##' \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 thus \code{check.node.labels} takes 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 documentation of \link{phylo4-methods}, +##' \link{phylo4d} and \link{formatData} 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 there are multiple trees in the file, only the first one +##' is returned if TRUE and a list of phylo4/phylo4d 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 char.all If TRUE, returns all characters, even those excluded in the +##' NEXUS file +##' @param polymorphic.convert If TRUE, converts polymorphic characters to +##' missing data +##' @param levels.uniform If TRUE, uses the same levels for all characters +##' @param quiet If 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 TRUE) or state codes +##' should be returned. +##' @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 (by \sQuote{make.names}) so that they are. +##' @param convert.edge.length logical. If \sQuote{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 still use trees with +##' negative branch lengths are an artifact of the method used to build the +##' tree. +##' @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 when read by NCL. 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 +##' @keywords misc readNCL <- function(file, simplify=FALSE, type=c("all", "tree", "data"), char.all=FALSE, polymorphic.convert=TRUE, levels.uniform=FALSE, quiet=TRUE, @@ -318,6 +318,8 @@ toRet } +##' @rdname readNexus +##' @aliases readNexus readNexus <- function (file, simplify=FALSE, type=c("all", "tree", "data"), char.all=FALSE, polymorphic.convert=TRUE, levels.uniform=FALSE, quiet=TRUE, @@ -332,6 +334,8 @@ check.names=check.names, convert.edge.length=convert.edge.length, ...)) } +##' @rdname readNexus +##' @aliases readNewick readNewick <- function(file, simplify=FALSE, quiet=TRUE, check.node.labels=c("keep", "drop", "asdata"), convert.edge.length=FALSE, ...) { Modified: pkg/R/summary-methods.R =================================================================== --- pkg/R/summary-methods.R 2014-04-08 21:15:26 UTC (rev 920) +++ pkg/R/summary-methods.R 2014-04-08 21:23:25 UTC (rev 921) @@ -1,78 +1,78 @@ -#' 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? -#' -#' @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}} constructor and -#' \code{\linkS4class{phylo4d}} class. -#' @keywords methods -#' @include phylo4-methods.R -#' @include phylo4d-methods.R -#' @export -#' @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 -#' +##' 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? +##' +##' @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} +##' [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/phylobase -r 921 From noreply at r-forge.r-project.org Wed Apr 9 20:30:29 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 9 Apr 2014 20:30:29 +0200 (CEST) Subject: [Phylobase-commits] r922 - pkg/src Message-ID: <20140409183029.8233C187557@r-forge.r-project.org> Author: francois Date: 2014-04-09 20:30:28 +0200 (Wed, 09 Apr 2014) New Revision: 922 Modified: pkg/src/checkPhylo4.cpp Log: fixed bug in getAllNodesFast (result shouldn't depend on whether the tree is rooted, just on presence of 0 in edge matrix), commented variables not used anymore. Modified: pkg/src/checkPhylo4.cpp =================================================================== --- pkg/src/checkPhylo4.cpp 2014-04-08 21:23:25 UTC (rev 921) +++ pkg/src/checkPhylo4.cpp 2014-04-09 18:30:28 UTC (rev 922) @@ -130,17 +130,18 @@ } //[[Rcpp::export]] -Rcpp::IntegerVector getAllNodesFast (Rcpp::IntegerMatrix edge, bool rooted) { +Rcpp::IntegerVector getAllNodesFast (Rcpp::IntegerMatrix edge) { Rcpp::IntegerVector tmp = Rcpp::as_vector(edge); Rcpp::IntegerVector maxN = Rcpp::range(tmp); - Rcpp::IntegerVector ans = Rcpp::seq_len(maxN[1] + 1); - if (rooted) { - return ans - 1; + Rcpp::IntegerVector ans; + if (maxN[0] == 0) { + ans = Rcpp::seq_len(maxN[1] + 1); + ans = ans - 1; } else { - ans.erase(0); - return ans - 1; + ans = Rcpp::seq_len(maxN[1]); } + return ans; } @@ -287,7 +288,7 @@ Rcpp::IntegerVector ances = getAnces(ed); //Rcpp::IntegerVector desc = getDesc(ed); int nroots = nRoots(ances); - bool rooted = nroots > 0; + //bool rooted = nroots > 0; Rcpp::NumericVector edLength = obj.slot("edge.length"); Rcpp::CharacterVector edLengthNm = edLength.names(); Rcpp::CharacterVector label = obj.slot("label"); @@ -295,10 +296,10 @@ Rcpp::CharacterVector edLabel = obj.slot("edge.label"); Rcpp::CharacterVector edLabelNm = edLabel.names(); Rcpp::IntegerVector allnodesSafe = getAllNodesSafe(ed); - Rcpp::IntegerVector allnodesFast = getAllNodesFast(ed, rooted); + Rcpp::IntegerVector allnodesFast = getAllNodesFast(ed); int nEdLength = edLength.size(); - int nLabel = label.size(); - int nEdLabel = edLabel.size(); + //int nLabel = label.size(); + //int nEdLabel = edLabel.size(); int nEdges = nrow; bool hasEdgeLength = !all_naC(edLength); From noreply at r-forge.r-project.org Wed Apr 9 21:54:17 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 9 Apr 2014 21:54:17 +0200 (CEST) Subject: [Phylobase-commits] r923 - pkg/R Message-ID: <20140409195417.7D79E187038@r-forge.r-project.org> Author: francois Date: 2014-04-09 21:54:17 +0200 (Wed, 09 Apr 2014) New Revision: 923 Modified: pkg/R/MRCA-methods.R pkg/R/RcppExports.R pkg/R/addData-methods.R pkg/R/ancestors.R pkg/R/checkdata.R pkg/R/edgeLength-methods.R pkg/R/getNode-methods.R pkg/R/internal-constructors.R pkg/R/labels-methods.R pkg/R/multiphylo4-class.R pkg/R/nodeId-methods.R pkg/R/pdata.R pkg/R/phylo4-accessors.R pkg/R/phylo4-class.R pkg/R/phylo4-methods.R pkg/R/phylo4d-accessors.R pkg/R/phylo4d-methods.R pkg/R/phylobase-package.R pkg/R/phylobase.options.R pkg/R/phylomats-class.R pkg/R/print-methods.R pkg/R/readNCL.R pkg/R/reorder-methods.R pkg/R/root-methods.R pkg/R/setAs-methods.R pkg/R/shortestPath-methods.R pkg/R/subset-methods.R pkg/R/summary-methods.R pkg/R/tdata-methods.R pkg/R/treePlot.R pkg/R/treestruc.R Log: clean up and add @export and @exportMethod where appropriate Modified: pkg/R/MRCA-methods.R =================================================================== --- pkg/R/MRCA-methods.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/MRCA-methods.R 2014-04-09 19:54:17 UTC (rev 923) @@ -19,6 +19,7 @@ ##' @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) Modified: pkg/R/RcppExports.R =================================================================== --- pkg/R/RcppExports.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/RcppExports.R 2014-04-09 19:54:17 UTC (rev 923) @@ -41,8 +41,8 @@ .Call('phylobase_getAllNodesSafe', PACKAGE = 'phylobase', edge) } -getAllNodesFast <- function(edge, rooted) { - .Call('phylobase_getAllNodesFast', PACKAGE = 'phylobase', edge, rooted) +getAllNodesFast <- function(edge) { + .Call('phylobase_getAllNodesFast', PACKAGE = 'phylobase', edge) } testEqInt <- function(x, y) { Modified: pkg/R/addData-methods.R =================================================================== --- pkg/R/addData-methods.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/addData-methods.R 2014-04-09 19:54:17 UTC (rev 923) @@ -35,6 +35,7 @@ ##' @seealso \code{\link{tdata}} for extracting or updating data and ##' \code{\link{phylo4d}} constructor. ##' @keywords methods +##' @rdname addData-methods ##' @include phylo4d-class.R ##' @export ##' @examples Modified: pkg/R/ancestors.R =================================================================== --- pkg/R/ancestors.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/ancestors.R 2014-04-09 19:54:17 UTC (rev 923) @@ -11,7 +11,7 @@ ##' ##' 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. ##' @@ -20,11 +20,9 @@ ##' ##' \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 x 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 @@ -36,7 +34,8 @@ ##' @param include.self whether to include self in list of siblings ##' @param \dots a list of node numbers or names, or a vector of node numbers or ##' names -##' @return \item{\code{ancestors}}{ return a named vector (or a list +##' @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} ##' @@ -55,10 +54,11 @@ ##' ##' \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 @@ -91,6 +91,7 @@ ##' @rdname ancestors ##' @aliases children +##' @export children <- function(phy,node) { node2 <- getNode(phy,node) r <- which(edges(phy)[,1]==node2) @@ -99,6 +100,7 @@ ##' @rdname ancestors ##' @aliases descendants +##' @export descendants <- function (phy, node, type=c("tips","children","all")) { type <- match.arg(type) @@ -162,6 +164,7 @@ ##' @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)] @@ -170,6 +173,7 @@ ##' @rdname ancestors ##' @aliases siblings +##' @export ancestors <- function (phy, node, type=c("all","parent","ALL")) { type <- match.arg(type) Modified: pkg/R/checkdata.R =================================================================== --- pkg/R/checkdata.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/checkdata.R 2014-04-09 19:54:17 UTC (rev 923) @@ -45,6 +45,7 @@ ##' @include RcppExports.R ##' @include phylo4-class.R ##' @include phylo4-methods.R +##' @export ##' @keywords misc checkPhylo4 <- function(object) { ct <- checkTree(object) Modified: pkg/R/edgeLength-methods.R =================================================================== --- pkg/R/edgeLength-methods.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/edgeLength-methods.R 2014-04-09 19:54:17 UTC (rev 923) @@ -21,11 +21,12 @@ ##' @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.name should the the name attributes of \code{value} be +##' @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 @@ -82,17 +83,12 @@ ##' @rdname edgeLength-methods ##' @aliases edgeLength +##' @export setGeneric("edgeLength", function(x, ...) { standardGeneric("edgeLength") }) ##' @rdname edgeLength-methods -##' @aliases edgeLength<- -setGeneric("edgeLength<-", function(x, ..., value) { - standardGeneric("edgeLength<-") -}) - -##' @rdname edgeLength-methods ##' @aliases edgeLength,phylo4-method setMethod("edgeLength", signature(x="phylo4"), function(x, node) { @@ -108,10 +104,17 @@ 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 -setReplaceMethod("edgeLength", signature(x="phylo4"), +##' @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 at edge, type="lengths", use.names) ## return empty vector if all values are NA @@ -130,6 +133,7 @@ ##' @rdname edgeLength-methods ##' @aliases depthTips +##' @export setGeneric("depthTips", function(x) { standardGeneric("depthTips") }) @@ -144,6 +148,7 @@ ##' @rdname edgeLength-methods ##' @aliases nodeDepth +##' @export setGeneric("nodeDepth", function(x, node) { standardGeneric("nodeDepth") }) @@ -171,6 +176,7 @@ ##' @rdname edgeLength-methods ##' @aliases sumEdgeLength +##' @export setGeneric("sumEdgeLength", function(x, node) { standardGeneric("sumEdgeLength") }) @@ -193,6 +199,7 @@ ##' @rdname edgeLength-methods ##' @aliases isUltrametric +##' @export setGeneric("isUltrametric", function(x, tol=.Machine$double.eps^.5) { standardGeneric("isUltrametric") }) Modified: pkg/R/getNode-methods.R =================================================================== --- pkg/R/getNode-methods.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/getNode-methods.R 2014-04-09 19:54:17 UTC (rev 923) @@ -31,8 +31,6 @@ ##' \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. ##' -##' @aliases getNode getEdge nodeId nodeId,phylo4-method edgeId -##' edgeId,phylo4-method ##' @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 @@ -57,6 +55,7 @@ ##' of edge IDs, in edge matrix order} ##' @keywords misc ##' @export +##' @rdname getNode-methods ##' @include phylo4-class.R ##' @examples ##' @@ -150,6 +149,7 @@ ##' @rdname getNode-methods ##' @aliases getEdge-methods +##' @export setGeneric("getEdge", function(x, node, type=c("descendant", "ancestor"), missing=c("warn", "OK", "fail")) { standardGeneric("getEdge") Modified: pkg/R/internal-constructors.R =================================================================== --- pkg/R/internal-constructors.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/internal-constructors.R 2014-04-09 19:54:17 UTC (rev 923) @@ -3,6 +3,17 @@ ## 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")) { @@ -53,7 +64,8 @@ } -.createEdge <- function(value, edgeMat, type=c("lengths", "labels"), use.names=TRUE) { +.createEdge <- function(value, edgeMat, type=c("lengths", "labels"), + use.names=TRUE) { type <- match.arg(type) lgthRes <- nrow(edgeMat) Modified: pkg/R/labels-methods.R =================================================================== --- pkg/R/labels-methods.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/labels-methods.R 2014-04-09 19:54:17 UTC (rev 923) @@ -62,7 +62,7 @@ ##' \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} } -##' @export +##' @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 @@ -116,6 +116,7 @@ ##' @rdname labels-methods ##' @aliases labels<- +##' @export setGeneric("labels<-", function(x, type, use.names, ..., value) { standardGeneric("labels<-") @@ -162,6 +163,7 @@ ##' @rdname labels-methods ##' @aliases hasDuplicatedLabels +##' @export setGeneric("hasDuplicatedLabels", function(x, type) { standardGeneric("hasDuplicatedLabels") @@ -183,6 +185,7 @@ ##' @rdname labels-methods ##' @aliases hasNodeLabels +##' @export setGeneric("hasNodeLabels", function(x) { standardGeneric("hasNodeLabels") }) @@ -198,6 +201,7 @@ ##' @rdname labels-methods ##' @aliases nodeLabels +##' @export setGeneric("nodeLabels", function(x) { standardGeneric("nodeLabels") }) @@ -211,6 +215,7 @@ ##' @rdname labels-methods ##' @aliases nodeLabels<- +##' @export setGeneric("nodeLabels<-", function(x, ..., value) { standardGeneric("nodeLabels<-") @@ -230,6 +235,7 @@ ##' @rdname labels-methods ##' @aliases tipLabels +##' @export setGeneric("tipLabels", function(x) { standardGeneric("tipLabels") }) @@ -243,6 +249,7 @@ ##' @rdname labels-methods ##' @aliases tipLabels<- +##' @export setGeneric("tipLabels<-", function(x, ..., value) { standardGeneric("tipLabels<-") @@ -263,6 +270,7 @@ ##' @rdname labels-methods ##' @aliases hasEdgeLabels +##' @export setGeneric("hasEdgeLabels", function(x) { standardGeneric("hasEdgeLabels") }) @@ -278,6 +286,7 @@ ##' @rdname labels-methods ##' @aliases edgeLabels +##' @export setGeneric("edgeLabels", function(x) { standardGeneric("edgeLabels") }) @@ -296,6 +305,7 @@ ##' @rdname labels-methods ##' @aliases edgeLabels<- +##' @export setGeneric("edgeLabels<-", function(x, ..., value) { standardGeneric("edgeLabels<-") Modified: pkg/R/multiphylo4-class.R =================================================================== --- pkg/R/multiphylo4-class.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/multiphylo4-class.R 2014-04-09 19:54:17 UTC (rev 923) @@ -10,7 +10,7 @@ ##' @aliases multiPhylo-class multiPhylo4-class multiPhylo4d-class tbind ##' @docType class ##' @keywords classes -##' @export +## @export setClass("multiPhylo4", representation(phylolist = "list", tree.names = "character"), prototype = list(phylolist = list(), tree.names = character(0))) Modified: pkg/R/nodeId-methods.R =================================================================== --- pkg/R/nodeId-methods.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/nodeId-methods.R 2014-04-09 19:54:17 UTC (rev 923) @@ -21,7 +21,7 @@ ##' @include phylo4-class.R phylo4-methods.R phylo4-accessors.R root-methods.R ##' @examples ##' data(geospiza) -##' identical(nodeId(geopsiza, "tip"), 1:nTips(geospiza)) +##' identical(nodeId(geospiza, "tip"), 1:nTips(geospiza)) ##' nodeId(geospiza, "internal") ##' edgeId(geospiza, "internal") ##' nodeId(geospiza, "root") @@ -45,7 +45,15 @@ ## 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 = getAllNodesFast(x at edge, isRooted(x)), + all = { + if (isRooted(x)) { + res <- getAllNodesFast(x at edge)[-1] + } + else { + res <- getAllNodesFast(x at edge) + } + res + }, ## tips are nodes that do not appear in the ancestor column ## three times slower: setdiff(E[, 2], E[, 1]), tip = tipsFast(x at edge[,1]), @@ -53,7 +61,7 @@ ## about 0.5 faster than: setdiff(getAllNodesFast(x at edge, isRooted(x)), tipsFast(x at edge[,1])), internal = unique(E[E[, 1] != 0, 1]), ## roots are nodes that have NA as ancestor - root = if (!isRooted(x)) NA else unname(E[E[, 1] == 0, 2])) + root = if (!isRooted(x)) return(NA) else unname(E[E[, 1] == 0, 2])) return(sort(nid)) @@ -63,6 +71,7 @@ ##' @rdname nodeId-methods ##' @aliases edgeId +##' @export setGeneric("edgeId", function(x, type=c("all", "tip", "internal", "root")) { standardGeneric("edgeId") Modified: pkg/R/pdata.R =================================================================== --- pkg/R/pdata.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/pdata.R 2014-04-09 19:54:17 UTC (rev 923) @@ -16,6 +16,7 @@ ##' \code{new("pdata", ...)}. ##' @author Ben Bolker ##' @keywords classes +#### @export setClass("pdata", representation(data="data.frame", type="factor", comment="character", @@ -38,7 +39,7 @@ ##' 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} +## @param object an object of class \code{pdata} ##' @return An object of class \code{pdata} ##' @author Ben Bolker ##' @seealso \linkS4class{pdata} @@ -56,6 +57,7 @@ obj } + check_pdata <- function(object) { nvar <- ncol(object at data) badlevels <- levels(object at type)[!levels(object at type) %in% ptypes] @@ -75,16 +77,21 @@ xd2 }) +#### @exportMethod [<- +setGeneric("[<-") + setMethod("[<-","pdata",function(x,i, j,...,drop=FALSE,value) { "[<-"(x at data,i,j,...,drop=drop,value) }) +### @exportMethod [[ setGeneric("[[") setMethod("[[","pdata", function(x,i,j,...,exact=NA) { x at data[[i,j,...,exact=exact]] }) +#### @exportMethod [[<- setGeneric("[[<-") setMethod("[[<-","pdata", function(x,i,j,...,exact=NA,value) { Modified: pkg/R/phylo4-accessors.R =================================================================== --- pkg/R/phylo4-accessors.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/phylo4-accessors.R 2014-04-09 19:54:17 UTC (rev 923) @@ -11,6 +11,7 @@ ##' @docType methods ##' @export ##' @include phylo4-class.R phylo4-methods.R +##' @include oldclasses-class.R ##' @rdname nTips-methods setGeneric("nTips", function(x) { standardGeneric("nTips") @@ -38,6 +39,7 @@ ##' @rdname nTips-methods ##' @aliases nNodes +##' @export setGeneric("nNodes", function(x) { standardGeneric("nNodes") }) @@ -55,6 +57,7 @@ ##' @rdname nTips-methods ##' @aliases nEdges +##' @export setGeneric("nEdges", function(x) { standardGeneric("nEdges") }) @@ -71,12 +74,16 @@ ### Edge accessors ######################################################### -##' edges accessors +##' Edges accessors ##' -##' @param x A \code{phylo4} or \code{phylo4d} object. +##' 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.} ##' @@ -87,16 +94,15 @@ ##' 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 +##' \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. +##' 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(geosp?za) +##' edgeOrder(geospiza) ##' geoPost <- reorder(geospiza, "postorder") ##' edgeOrder(geoPost) ##' ## with a binary tree this should always be true @@ -112,7 +118,7 @@ ##' @rdname edges-accessors ##' @aliases edges,phylo4-method setMethod("edges", signature(x="phylo4"), - function(x, drop.root=FALSE, ...) { + function(x, drop.root=FALSE) { e <- x at edge if (drop.root) e <- e[e[, 1] != 0, ] e @@ -122,6 +128,7 @@ ##' @rdname edges-accessors ##' @aliases edgeOrder +##' @export setGeneric("edgeOrder", function(x, ...) { standardGeneric("edgeOrder") }) @@ -129,7 +136,7 @@ ##' @rdname edges-accessors ##' @aliases edgeOrder,phylo4-method setMethod("edgeOrder", signature(x="phylo4"), - function(x, ...) { + function(x) { x at order }) @@ -137,6 +144,7 @@ ##' @rdname edges-accessors ##' @aliases internalEdges +##' @export setGeneric("internalEdges", function(x) { standardGeneric("internalEdges") }) @@ -154,6 +162,7 @@ ##' @rdname edges-accessors ##' @aliases terminalEdges +##' @export setGeneric("terminalEdges", function(x) { standardGeneric("terminalEdges") }) Modified: pkg/R/phylo4-class.R =================================================================== --- pkg/R/phylo4-class.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/phylo4-class.R 2014-04-09 19:54:17 UTC (rev 923) @@ -2,9 +2,7 @@ ##' ##' Classes for phylogenetic trees ##' -##' ##' @name phylo4-class -##' @aliases phylo4_orderings phylo-class 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 Modified: pkg/R/phylo4-methods.R =================================================================== --- pkg/R/phylo4-methods.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/phylo4-methods.R 2014-04-09 19:54:17 UTC (rev 923) @@ -40,6 +40,7 @@ ##' (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 @@ -48,7 +49,9 @@ ##' the validity of \code{phylo4} objects. See also the \code{\link{phylo4d}} ##' constructor, and \linkS4class{phylo4d} class. ##' @export -##' @include internal-constructors.R phylo4-class.R +##' @aliases phylo4 +##' @rdname phylo4-methods +##' @include internal-constructors.R phylo4-class.R oldclasses-class.R ##' @examples ##' ##' # a three species tree: @@ -73,8 +76,12 @@ ##' setGeneric("phylo4", function(x, ...) { standardGeneric("phylo4")} ) -# ape orderings should be allowed for so we can import trees from ape e.g. during subsetting -phylo4_orderings <- c("unknown", "preorder", "postorder", "pruningwise", "cladewise") +## 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 @@ -85,7 +92,7 @@ ## edge edge <- x mode(edge) <- "integer" - #if(any(is.na(edge))) stop("NA are not allowed in edge matrix") ## taken care by checkTree + if(ncol(edge) > 2) warning("The edge matrix has more than two columns, ", "only the first two columns are considered.") @@ -102,14 +109,16 @@ 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) + 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 <- .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) Modified: pkg/R/phylo4d-accessors.R =================================================================== --- pkg/R/phylo4d-accessors.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/phylo4d-accessors.R 2014-04-09 19:54:17 UTC (rev 923) @@ -2,20 +2,28 @@ ##' 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 -##' phylo4d objects. +##' \code{phylo4d} objects. ##' -##' The outcome of the test is based on row names of the data frame stored in -##' \code{data}. If there are no rows having row names from the set -##' \code{nodeId(x, "tip")}, then \code{hasTipData} returns FALSE. Likewise, if -##' there are no rows having row names from the set \code{nodeId(x, -##' "internal")}, then \code{hasNodeData} returns FALSE. +##' \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. ##' -##' @aliases hasNodeData hasNodeData-methods hasNodeData,phylo4d-method -##' hasTipData hasTipData-methods hasTipData,phylo4d-method -##' @param x a phylo4d object -##' @return \item{list("logical")}{return \code{TRUE} or \code{FALSE} depending -##' whether data are associated with the tree (i.e., the slots \code{tip.data} -##' or \code{node.data} are not empty)} +##' @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 @@ -23,13 +31,15 @@ ##' @author Ben Bolker, Thibault Jombart, Francois Michonneau ##' @seealso \code{\link{phylo4d}} constructor and \code{\linkS4class{phylo4d}} ##' class. -##' @name hasTipData +##' @rdname phylo4d-accessors +##' @aliases hasTipData ##' @keywords methods ##' @docType methods -##' @include phylo4d-class.R +##' @include phylo4d-class.R phylo4d-methods.R ##' @export ##' @examples ##' data(geospiza) +##' nData(geospiza) ## 5 ##' hasTipData(geospiza) ## TRUE ##' hasNodeData(geospiza) ## FALSE ##' @@ -37,24 +47,36 @@ standardGeneric("hasTipData") }) -##' @name hasTipData-methods -##' @rdname 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 hasTipData +##' @rdname phylo4d-accessors ##' @aliases hasNodeData-methods +##' @export setGeneric("hasNodeData", function(x) { standardGeneric("hasNodeData") }) -##' @name hasNodeData-methods -##' @rdname hasTipData +##' @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 at data) +}) Modified: pkg/R/phylo4d-methods.R =================================================================== --- pkg/R/phylo4d-methods.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/phylo4d-methods.R 2014-04-09 19:54:17 UTC (rev 923) @@ -95,6 +95,7 @@ ##' @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);" Modified: pkg/R/phylobase-package.R =================================================================== --- pkg/R/phylobase-package.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/phylobase-package.R 2014-04-09 19:54:17 UTC (rev 923) @@ -26,7 +26,7 @@ ##' between two nodes in your tree ##' ##' \item robust functions to import data from NEXUS and Newick files -##' using the NEXUS Class Library (\url{http://ncl.sourceforge.net/?}) +##' using the NEXUS Class Library (\url{http://ncl.sourceforge.net/}) ##' } ##' ##' @section History: @@ -72,17 +72,17 @@ ##' @importFrom utils head tail ##' @importFrom ade4 newick2phylog ##' -##' -##' @exportMethod print head tail reorder plot summary -##' @exportMethod phylo4 phylo4d -##' @exportMethod edges edgeId hasEdgeLength edgeLength edgeLength<- sumEdgeLength edgeOrder -##' @exportMethod isRooted rootNode rootNode<- -##' @exportMethod nodeId nodeType nodeDepth -##' @exportMethod isUltrametric -##' @exportMethod subset prune [ -##' @exportMethod [<- [[ [[<- -##' @exportMethod labels labels<- nodeLabels nodeLabels<- tipLabels tipLabels<- edgeLabels edgeLabels<- -##' @exportMethod hasNodeLabels hasEdgeLabels hasDuplicatedLabels +##' +## exportMethod should only be used for generics defined outside the package! +## @exportMethod print head tail reorder plot summary +## @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 NULL Modified: pkg/R/phylobase.options.R =================================================================== --- pkg/R/phylobase.options.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/phylobase.options.R 2014-04-09 19:54:17 UTC (rev 923) @@ -21,7 +21,7 @@ ##' # subsequent trees with polytomies will fail the validity check ##' } ##' -##' @export phylobase.options +##' @export phylobase.options <- function (...) { if (nargs() == 0) return(.phylobase.Options) current <- .phylobase.Options Modified: pkg/R/phylomats-class.R =================================================================== --- pkg/R/phylomats-class.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/phylomats-class.R 2014-04-09 19:54:17 UTC (rev 923) @@ -19,6 +19,7 @@ ##' @author Ben Bolker ##' @rdname phylomat-class ##' @keywords classes +##' @export ##' @examples ##' ##' tree.owls <- ape::read.tree(text="(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);") @@ -58,12 +59,14 @@ edge.label=from at edge.label, order=from at 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", Modified: pkg/R/print-methods.R =================================================================== --- pkg/R/print-methods.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/print-methods.R 2014-04-09 19:54:17 UTC (rev 923) @@ -47,13 +47,13 @@ ##' print(treedata) ##' ##' -##' @export ##' @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) { @@ -74,6 +74,7 @@ ##' @rdname print-methods ##' @aliases show +##' @exportMethod show setGeneric("show") ##' @rdname print-methods @@ -83,6 +84,7 @@ ##' @rdname print-methods ##' @aliases names +##' @exportMethod names setGeneric("names") ##' @rdname print-methods @@ -95,6 +97,7 @@ ##' @rdname print-methods ##' @aliases head +##' @exportMethod head setGeneric("head") ##' @rdname print-methods @@ -105,8 +108,12 @@ }) ##' @rdname print-methods +##' @aliases tail +##' @exportMethod tail +setGeneric("tail") + +##' @rdname print-methods ##' @aliases tail,phylo4-method -setGeneric("tail") setMethod("tail", signature(x="phylo4"), function(x, n=20) { tail(as(x, "data.frame"), n=n) Modified: pkg/R/readNCL.R =================================================================== --- pkg/R/readNCL.R 2014-04-09 18:30:28 UTC (rev 922) +++ pkg/R/readNCL.R 2014-04-09 19:54:17 UTC (rev 923) @@ -3,96 +3,111 @@ ### - readNexus (wrapper for readNCL importing Nexus files) ### - readNewick (wrapper for readNCL importing Newick files) -##' Create a phylo4, phylo4d or data.frame object from a Nexus or a Newick file +##' Create a phylo4, phylo4d or data.frame object from a Nexus or a +##' Newick file ##' ##' \code{readNexus} reads a Nexus file and outputs a \code{phylo4} or ##' \code{phylo4d} or \code{data.frame} object. ##' -##' \code{readNewick} reads a Newick file and outputs a \code{phylo4} or -##' \code{phylo4d} object. +##' \code{readNewick} reads a Newick file and outputs a \code{phylo4} +##' or \code{phylo4d} object. ##' -##' \code{readNexus} extracts data held in a Nexus file, specifically from DATA, -##' CHARACTER or TREES blocks present in the file. 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. +##' \code{readNexus} extracts data held in a Nexus file, specifically +##' from DATA, CHARACTER or TREES blocks present in the file. 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 [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/phylobase -r 923 From noreply at r-forge.r-project.org Wed Apr 9 21:57:41 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 9 Apr 2014 21:57:41 +0200 (CEST) Subject: [Phylobase-commits] r924 - pkg/man Message-ID: <20140409195741.9ADD1187063@r-forge.r-project.org> Author: francois Date: 2014-04-09 21:57:40 +0200 (Wed, 09 Apr 2014) New Revision: 924 Added: pkg/man/MRCA.Rd pkg/man/addData-methods.Rd pkg/man/ancestors.Rd pkg/man/checkPhylo4.Rd pkg/man/edgeLength-methods.Rd pkg/man/edges-accessors.Rd pkg/man/extractTree.Rd pkg/man/getNode-methods.Rd pkg/man/labels-methods.Rd pkg/man/nTips-methods.Rd pkg/man/nodeId-methods.Rd pkg/man/phylo4-methods.Rd pkg/man/phylo4d-accessors.Rd pkg/man/phylo4d-methods.Rd pkg/man/print-methods.Rd pkg/man/readNexus.Rd pkg/man/root-methods.Rd pkg/man/setAs-methods.Rd pkg/man/shortestPath-methods.Rd pkg/man/summary-methods.Rd pkg/man/tdata-methods.Rd pkg/man/treeStructure-methods.Rd Removed: pkg/man/addData.Rd pkg/man/as-methods.Rd pkg/man/check.phylo4.Rd pkg/man/extract.tree.Rd pkg/man/getNode.Rd pkg/man/hasSingles.Rd pkg/man/phylo4-accessors.Rd pkg/man/phylo4-display.Rd pkg/man/phylo4-labels.Rd pkg/man/phylo4.Rd pkg/man/phylo4d-display.Rd pkg/man/phylo4d-hasData.Rd pkg/man/phylo4d-nData.Rd pkg/man/phylo4d.Rd pkg/man/phylog.Rd pkg/man/printphylo4.Rd pkg/man/readNCL.Rd pkg/man/tdata.Rd pkg/man/treewalk.Rd Modified: pkg/man/formatData.Rd pkg/man/geospiza.Rd pkg/man/multiPhylo-class.Rd pkg/man/owls4.Rd pkg/man/pdata-class.Rd pkg/man/pdata.Rd pkg/man/phylo4-class.Rd pkg/man/phylo4d-class.Rd pkg/man/phyloXXYY.Rd pkg/man/phylobase-package.Rd pkg/man/phylobase.options.Rd pkg/man/phylobubbles.Rd pkg/man/phylomat-class.Rd pkg/man/plotOneTree.Rd pkg/man/reorder-methods.Rd pkg/man/subset-methods.Rd pkg/man/tip.data.plot.Rd pkg/man/treePlot-methods.Rd Log: major re-organization of the docs with transition to roxygen Added: pkg/man/MRCA.Rd =================================================================== --- pkg/man/MRCA.Rd (rev 0) +++ pkg/man/MRCA.Rd 2014-04-09 19:57:40 UTC (rev 924) @@ -0,0 +1,48 @@ +\docType{methods} +\name{MRCA} +\alias{MRCA} +\alias{MRCA,phylo-method} +\alias{MRCA,phylo4-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)) +} + Added: pkg/man/addData-methods.Rd =================================================================== --- pkg/man/addData-methods.Rd (rev 0) +++ pkg/man/addData-methods.Rd 2014-04-09 19:57:40 UTC (rev 924) @@ -0,0 +1,78 @@ +\docType{methods} +\name{addData} +\alias{addData} +\alias{addData,phylo4-method} +\alias{addData,phylo4d-method} +\alias{addData-methods} +\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{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?} + + \item{\dots}{additional arguments to be passed to + \link{formatData}} +} +\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}} 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) +} +\author{ +Francois Michonneau +} +\seealso{ +\code{\link{tdata}} for extracting or updating data and +\code{\link{phylo4d}} constructor. +} +\keyword{methods} + Deleted: pkg/man/addData.Rd =================================================================== --- pkg/man/addData.Rd 2014-04-09 19:54:17 UTC (rev 923) +++ pkg/man/addData.Rd 2014-04-09 19:57:40 UTC (rev 924) @@ -1,61 +0,0 @@ -\name{addData} -\alias{addData} -\alias{addData-methods} -\alias{addData,phylo4-method} -\alias{addData,phylo4d-method} - -\title{Adding data to a phylo4 or a phylo4d object} -\description{ - \code{addData} adds data to a \code{phylo4} (converting it in a - \code{phylo4d} object) or to a \code{phylo4d} object -} -\usage{ -\S4method{addData}{phylo4}(x, tip.data, node.data, all.data, - merge.data=TRUE, pos=c("after", "before"), \dots) -\S4method{addData}{phylo4d}(x, tip.data, node.data, all.data, - merge.data=TRUE, pos=c("after", "before"), \dots) -} -\arguments{ - \item{x}{a phylo4 or a phylo4d object} - \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?} - \item{\dots}{additional arguments to be passed to \link{formatData}} -} -\value{ - \code{addData} returns a \code{phylo4d} object. -} -\details{ - Rules for matching data to tree nodes are identical to those used by - the \code{\link{phylo4d}} 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. -} -\seealso{ - \code{\link{tdata}} for extracting or updating data and - \code{\link{phylo4d}} constructor. -} -\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) -} -\author{Francois Michonneau} -\keyword{methods} Added: pkg/man/ancestors.Rd =================================================================== --- pkg/man/ancestors.Rd (rev 0) +++ pkg/man/ancestors.Rd 2014-04-09 19:57:40 UTC (rev 924) @@ -0,0 +1,109 @@ +\name{ancestor} +\alias{ancestor} +\alias{ancestors} +\alias{children} +\alias{descendants} +\alias{siblings} +\title{Tree traversal and utility functions} +\usage{ +ancestor(phy, node) + +children(phy, node) + +descendants(phy, node, type = c("tips", "children", "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")} + + \item{include.self}{whether to include self in list of + siblings} + + \item{\dots}{a list of node numbers or names, or a vector + of node numbers or names} +} +\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 +} + Deleted: pkg/man/as-methods.Rd =================================================================== --- pkg/man/as-methods.Rd 2014-04-09 19:54:17 UTC (rev 923) +++ pkg/man/as-methods.Rd 2014-04-09 19:57:40 UTC (rev 924) @@ -1,138 +0,0 @@ -\name{as} -\docType{methods} -\alias{as} -\alias{as-method} -\alias{as,phylo,phylo4-method} -\alias{as,phylo,phylo4d-method} -\alias{as,multiPhylo4,multiPhylo-method} -\alias{as,multiPhylo,multiPhylo4-method} -\alias{as,multiPhylo4d,multiPhylo-method} -\alias{as,phylo4,phylo-method} -\alias{as,phylo4d,phylo-method} -\alias{as,phylo4,data.frame-method} -\alias{as,phylo4d,data.frame-method} -\alias{as,phylo4vcov,phylo4-method} -\alias{as,phylo4,phylo4vcov-method} -\alias{coerce-methods} -\alias{coerce,phylo,phylo4-method} -\alias{coerce,phylo,phylo4d-method} -\alias{coerce,multiPhylo4,multiPhylo-method} -\alias{coerce,multiPhylo,multiPhylo4-method} -\alias{coerce,multiPhylo4d,multiPhylo-method} -\alias{coerce,phylo4,phylo-method} -\alias{coerce,phylo4d,phylo-method} -\alias{coerce,phylo4,data.frame-method} -\alias{coerce,phylo4d,data.frame-method} -\alias{coerce,phylo4vcov,phylo4-method} -\alias{coerce,phylo4,phylo4vcov-method} - -\title{Converting between phylo4/phylo4d and other phylogenetic tree formats} - -\section{Usage}{ -\code{as(object, class)} -} - -\section{Arguments}{ -\describe{ - \item{\code{object}}{a tree of class \code{phylo4}, \code{phylo} or - \code{phylog}, or tree and data object of class \code{phylo4d}.} - \item{\code{class}}{the name of the class to which \code{tree} should - be coerced (e.g., \code{"phylo4"} or \code{"data.frame"}).} -} -} -\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{ade4} objects (\code{phylog}, \emph{now deprecated}), and to - \code{data.frame} representation. -} - -\section{Methods}{ - - Coerce from one object class to another using - \code{as(object, "class")}, where the \code{object} is of the old class - and the returned object is of the new class \code{"class"}. The - \code{as} function examines the class of \code{object} and the new - \code{"class"} specified to choose the proper conversion without - additional information from the user. Conversions exist for - combinations: - - \describe{ - \item{}{\code{phylobase} to \code{phylobase} formats: - \describe{ - - \item{\code{as(object, "phylo4d")}}{where object is of class \linkS4class{phylo4} and returns an object of class \linkS4class{phylo4d}, with empty data.} - - \item{\code{as(object, "phylo4")}}{where object is of class \linkS4class{phylo4d} and returns an object of class \linkS4class{phylo4}. If data are dropped during the conversion, a warning message is produced. A similar conversion can be done by using the function \code{extractTree}, but in this case, no error message is produced.} - }} %end phylobase to phylobase - - \item{}{\code{phylobase} to \code{ape} formats: - \describe{ - - \item{\code{as(object, "phylo")}}{where object is of class \linkS4class{phylo4} or \linkS4class{phylo4d} and returns an object of class \code{phylo}. If data are dropped during the conversion from a \code{phylo4d} object, a warning message is produced.} - - \item{\code{as(object, "multiPhylo")}}{~~Not implemented yet. where object is of class \linkS4class{multiPhylo4} and returns an object of class \code{multiPhylo}.} - }} % end phylobase to ape - - \item{}{\code{ape} to \code{phylobase} formats: - \describe{ - - \item{\code{as(object, "phylo4")}}{where object is of class \code{phylo} and returns an object of class \code{phylo4}.} - - \item{\code{as(object, "phylo4d")}}{where object is of class \code{phylo} and returns an object of class \code{phylo4d}, with empty data.} - - \item{\code{as(object, "multiPhylo4")}}{~~Not implemented yet. where object is of class \code{multiPhylo} and returns an object of class \code{multiPhylo4}. } - }} % end ape to phylobase - - \item{}{\code{phylobase} to \code{ade4} formats: - \describe{ - - \item{\code{as(object, "phylog")}}{where object is of class \code{phylo4} and returns an object of class \linkS4class{phylog}.} - } - Note that this format is now deprecated; the \code{ade4} developers recommend that you use \code{adephylo} instead, - which uses \code{phylo} and \code{phylo4} formats natively. -} % end phylobase to ade4 - - \item{}{\code{phylobase} format to \code{data.frame}: - \describe{ - - \item{\code{as(object, "data.frame")}}{where object is of class \code{phylo4} or \code{phylo4d} and returns an object of class \code{data.frame}, with data included in the case of \code{phylo4d}.} - }} % end phylobase to dataframe - } % end main description -} % end methods - -\author{Ben Bolker, Thibaut Jombart, Marguerite Butler, Steve Kembel} -\seealso{ generic \code{\link[methods]{as}}, \code{\link{phylo4}}, - \code{\link{phylo4d}}, \code{\link{extractTree}}, the original - \code{\link[ade4]{phylog}} from the \code{ade4} package and - \code{\link[ape]{as.phylo}} from the \code{ape} package. -} - - -\examples{ -trString <- "(((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=trString) -## 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") -} -\keyword{methods} -\concept{phylo4 tree formats} -\concept{convert tree formats} -\concept{conversion between tree formats} Deleted: pkg/man/check.phylo4.Rd =================================================================== --- pkg/man/check.phylo4.Rd 2014-04-09 19:54:17 UTC (rev 923) +++ pkg/man/check.phylo4.Rd 2014-04-09 19:57:40 UTC (rev 924) @@ -1,67 +0,0 @@ -\name{checkPhylo4} -\alias{checkPhylo4} -\alias{checkTree} -\alias{checkPhylo4Data} -\title{Validity checking for phylo4 objects} -\description{ - Basic checks on the validity of S4 phylogenetic objects -} -\usage{ -checkPhylo4(object) -checkTree(object) -checkPhylo4Data(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. -} -\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{http://ape.mpl.ird.fr/misc/FormatTreeR_28July2008.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; - \code{\link{formatData}}, the \code{\link{phylo4d}} 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} Added: pkg/man/checkPhylo4.Rd =================================================================== --- pkg/man/checkPhylo4.Rd (rev 0) +++ pkg/man/checkPhylo4.Rd 2014-04-09 19:57:40 UTC (rev 924) @@ -0,0 +1,65 @@ +\name{checkPhylo4} +\alias{checkPhylo4} +\alias{checkPhylo4Data} +\alias{checkTree} +\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{http://ape.mpl.ird.fr/misc/FormatTreeR_28July2008.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; \code{\link{formatData}}, the +\code{\link{phylo4d}} 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.} +} +\keyword{misc} + Added: pkg/man/edgeLength-methods.Rd =================================================================== --- pkg/man/edgeLength-methods.Rd (rev 0) +++ pkg/man/edgeLength-methods.Rd 2014-04-09 19:57:40 UTC (rev 924) @@ -0,0 +1,115 @@ +\docType{methods} +\name{hasEdgeLength} +\alias{depthTips} +\alias{depthTips,phylo4-method} +\alias{depthTips,phylo4-methods} +\alias{edgeLength} +\alias{edgeLength,phylo4-method} +\alias{edgeLength<-} +\alias{edgeLength<-,phylo4,ANY-method} +\alias{edgeLength<-,phylo4-method} +\alias{hasEdgeLength} +\alias{hasEdgeLength,phylo4-method} +\alias{isUltrametric} +\alias{isUltrametric,phylo4-method} +\alias{nodeDepth} +\alias{nodeDepth,phylo4-method} +\alias{sumEdgeLength} +\alias{sumEdgeLength,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 + +depthTips(x) + +\S4method{depthTips}{phylo4}(x) + +nodeDepth(x, node) + +\S4method{nodeDepth}{phylo4}(x, node) + +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{value}{a numeric vector indicating the new values + for the edge lengths} + + \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{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}.} + + \item{\dots}{optional arguments (none used at present).} +} +\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{nodeDepth}{a named vector indicating the +\dQuote{depth} (the distance between the root and the tip) +of each tip.} + +\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})} } +} +\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 +} +\seealso{ +\code{ancestors}, \code{descendants}, \code{.Machine} for +more information about tolerance. +} + Added: pkg/man/edges-accessors.Rd =================================================================== --- pkg/man/edges-accessors.Rd (rev 0) +++ pkg/man/edges-accessors.Rd 2014-04-09 19:57:40 UTC (rev 924) @@ -0,0 +1,74 @@ +\docType{methods} +\name{edges} +\alias{edgeOrder} +\alias{edgeOrder,phylo4-method} +\alias{edges} +\alias{edges,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{drop.root}{logical (default FALSE), should the edge + connecting the root be included in the edge matrix?} + + \item{\dots}{Optional arguments used by specific methods. + (None used at present).} +} +\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)) +} +\author{ +Ben Bolker, Francois Michonneau, Thibaut Jombart +} +\seealso{ +reorder, edgeId +} + Deleted: pkg/man/extract.tree.Rd =================================================================== --- pkg/man/extract.tree.Rd 2014-04-09 19:54:17 UTC (rev 923) +++ pkg/man/extract.tree.Rd 2014-04-09 19:57:40 UTC (rev 924) @@ -1,28 +0,0 @@ -\name{extractTree} -\alias{extractTree} -\title{Get tree from tree+data object} -\description{ - Extracts a \code{phylo4} tree object from a \code{phylo4d} 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. } -} -\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. -} -\author{ Ben Bolker } -\seealso{\code{\link{phylo4}}, \code{\link{phylo4d}}, \code{\link{coerce-methods}} for translation functions. } -\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) -} -\keyword{methods} Added: pkg/man/extractTree.Rd =================================================================== --- pkg/man/extractTree.Rd (rev 0) +++ pkg/man/extractTree.Rd 2014-04-09 19:57:40 UTC (rev 924) @@ -0,0 +1,43 @@ +\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) +} +\author{ +Ben Bolker +} +\seealso{ +\code{\link{phylo4}}, \code{\link{phylo4d}}, +\code{\link{coerce-methods}} for translation functions. +} +\keyword{methods} + Modified: pkg/man/formatData.Rd =================================================================== --- pkg/man/formatData.Rd 2014-04-09 19:54:17 UTC (rev 923) +++ pkg/man/formatData.Rd 2014-04-09 19:57:40 UTC (rev 924) @@ -1,84 +1,92 @@ \name{formatData} \alias{formatData} - \title{Format data for use in phylo4d objects} - -\description{ - Associates data with tree nodes and applies consistent formatting - rules. -} - \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) +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} + + \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{ [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/phylobase -r 924 From noreply at r-forge.r-project.org Wed Apr 9 21:59:12 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 9 Apr 2014 21:59:12 +0200 (CEST) Subject: [Phylobase-commits] r925 - in pkg: inst/unitTests tests/testthat Message-ID: <20140409195912.5FBD818707F@r-forge.r-project.org> Author: francois Date: 2014-04-09 21:59:11 +0200 (Wed, 09 Apr 2014) New Revision: 925 Added: pkg/tests/testthat/test.readNCL.R Removed: pkg/inst/unitTests/runit.readNCL.R Log: converted readNCL unit tests to testthat Deleted: pkg/inst/unitTests/runit.readNCL.R =================================================================== --- pkg/inst/unitTests/runit.readNCL.R 2014-04-09 19:57:40 UTC (rev 924) +++ pkg/inst/unitTests/runit.readNCL.R 2014-04-09 19:59:11 UTC (rev 925) @@ -1,466 +0,0 @@ -# -# --- Test readNCL.R --- -# - -### Get all the test files -if (Sys.getenv("RCMDCHECK") == FALSE) { - 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") - -## Contains correct (as of 2010-03-08) phylo4 representation of one of the tree -## stored in the nexus file -mlFile <- file.path(pth, "multiLines.Rdata") - -## 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(mlFile)) -stopifnot(file.exists(treePolyDt)) -stopifnot(file.exists(treeContDt)) -stopifnot(file.exists(treeDiscCont)) -stopifnot(file.exists(ExContDataFile)) -stopifnot(file.exists(noStateLabels)) - -op <- phylobase.options() - -test.readNCL <- function() { - ## 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) - ## Read trees - co1 <- readNCL(file=co1File, check.node.labels="asdata") - ## Tree 1 - co1Tree1 <- co1[[1]] - checkIdentical(labels(co1Tree1), labCo1) # check labels - checkIdentical(edgeLength(co1Tree1), eLco1) # check edge lengths - checkIdentical(nodeType(co1Tree1), nTco1) # check node types - checkIdentical(as(co1Tree1, "data.frame")$labelValues, lVco1) # check label values - ## Tree 2 - co1Tree2 <- co1[[2]] - checkIdentical(labels(co1Tree2), labCo1) # check labels - checkIdentical(edgeLength(co1Tree2), eLco1) # check edge lengths - checkIdentical(nodeType(co1Tree2), nTco1) # check node types - - ## Check option simplify - co1 <- readNCL(file=co1File, check.node.labels="asdata", simplify=TRUE) - checkIdentical(length(co1), as.integer(1)) # make sure there is only one tree - checkIdentical(labels(co1), labCo1) # check labels - checkIdentical(edgeLength(co1), eLco1) # check edge lengths - checkIdentical(nodeType(co1), nTco1) # check node type - checkIdentical(as(co1, "data.frame")$labelValues, lVco1) # check label values - - ## Check option check.node.labels - phylobase.options(allow.duplicated.labels="fail") - checkException(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) - checkIdentical(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) - checkIdentical(labels(co1), labCo1) # check labels - checkIdentical(edgeLength(co1), eLco1) # check edge lengths - checkIdentical(nodeType(co1), nTco1) # check node type - checkIdentical(as(co1, "data.frame")$labelValues, NULL) # check label values don't exist - - ## ########### Mutli Lines -- tree only - multiLines <- readNCL(file=multiLinesFile) - ## load correct representation and make sure that the trees read - ## match it - load(mlFile) - checkIdentical(multiLines[[1]], ml1) - checkIdentical(multiLines[[2]], ml2) - rm(ml1, ml2) - - ## ########### Tree + data -- file from Mesquite - ## 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") - ## Tree only - tr <- readNCL(file=treeDiscDt, type="tree") - checkIdentical(labels(tr), labTr) # check labels - checkIdentical(edgeLength(tr), eTr) # check edge lengths - checkIdentical(nodeType(tr), nTtr) # check node types - checkIdentical(class(tr), p4) # check class - ## Data only - dt1 <- readNCL(file=treeDiscDt, type="data", return.labels=FALSE, - levels.uniform=FALSE) - checkIdentical(dt1, dtTest1) - dt2 <- readNCL(file=treeDiscDt, type="data", return.labels=TRUE, - levels.uniform=FALSE) - checkIdentical(dt2, dtTest2) - ## Tree + Data - trDt1 <- readNCL(file=treeDiscDt, type="all", return.labels=FALSE, - levels.uniform=FALSE) - checkIdentical(labels(trDt1), labTr) # check labels - checkIdentical(edgeLength(trDt1), eTr) # check edge lengths - checkIdentical(nodeType(trDt1), nTtr) # check node types - checkIdentical(class(trDt1), p4d) # check class - checkIdentical(tdata(trDt1, type="tip")[rownames(dtTest1), ], dtTest1) - trDt2 <- readNCL(file=treeDiscDt, type="all", return.labels=TRUE, - levels.uniform=FALSE) - checkIdentical(labels(trDt2), labTr) # check labels - checkIdentical(edgeLength(trDt2), eTr) # check edge lengths - checkIdentical(nodeType(trDt2), nTtr) # check node types - checkIdentical(class(trDt2), p4d) # check class - checkIdentical(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)) - - ## 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) - checkIdentical(labels(trChr1), labTr) # check labels - checkIdentical(edgeLength(trChr1), eTr) # check edge lengths - checkIdentical(nodeType(trChr1), nTtr) # check node types - checkIdentical(class(trChr1), p4d) # check class - checkIdentical(tdata(trChr1, "tip"), dtPoly1) - ## 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) - checkIdentical(labels(trChr2), labTr) # check labels - checkIdentical(edgeLength(trChr2), eTr) # check edge lengths - checkIdentical(nodeType(trChr2), nTtr) # check node types - checkIdentical(class(trChr2), p4d) # check class - checkIdentical(tdata(trChr2, "tip"), dtPoly2) - ## 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) - checkIdentical(labels(trChr3), labTr) # check labels - checkIdentical(edgeLength(trChr3), eTr) # check edge lengths - checkIdentical(nodeType(trChr3), nTtr) # check node types - checkIdentical(class(trChr3), p4d) # check class - checkIdentical(tdata(trChr3, "tip"), dtPoly3) - ## char.all=TRUE, levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=FALSE - ## not yet implemented - ## trChr4 <- - checkException(readNCL(file=treePolyDt, type="all", - levels.uniform=FALSE, - return.labels=TRUE, - polymorphic.convert=FALSE)) - ## 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) - checkIdentical(labels(trChr5), labTr) # check labels - checkIdentical(edgeLength(trChr5), eTr) # check edge lengths - checkIdentical(nodeType(trChr5), nTtr) # check node types - checkIdentical(class(trChr5), p4d) # check class - checkIdentical(tdata(trChr5, "tip"), dtPoly5) - ## 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) - checkIdentical(labels(trChr6), labTr) # check labels - checkIdentical(edgeLength(trChr6), eTr) # check edge lengths - checkIdentical(nodeType(trChr6), nTtr) # check node types - checkIdentical(class(trChr6), p4d) # check class - checkIdentical(tdata(trChr6, "tip"), dtPoly6) - ## char.all=TRUE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=FALSE - ## not yet implemented - ## trChr7 <- - checkException(readNCL(file=treePolyDt, type="all", char.all=TRUE, - levels.uniform=TRUE, - return.labels=TRUE, - polymorphic.convert=FALSE)) - ## 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) - checkIdentical(labels(trChr8), labTr) # check labels - checkIdentical(edgeLength(trChr8), eTr) # check edge lengths - checkIdentical(nodeType(trChr8), nTtr) # check node types - checkIdentical(class(trChr8), p4d) # check class - checkIdentical(tdata(trChr8, "tip"), dtPoly8) - - ## -- with char.all=FALSE - ## 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) - checkIdentical(labels(trChr1F), labTr) # check labels - checkIdentical(edgeLength(trChr1F), eTr) # check edge lengths - checkIdentical(nodeType(trChr1F), nTtr) # check node types - checkIdentical(class(trChr1F), p4d) # check class - checkIdentical(tdata(trChr1F, "tip"), dtPoly1[, 1:2]) - ## 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) - checkIdentical(labels(trChr2F), labTr) # check labels - checkIdentical(edgeLength(trChr2F), eTr) # check edge lengths - checkIdentical(nodeType(trChr2F), nTtr) # check node types - checkIdentical(class(trChr2F), p4d) # check class - checkIdentical(tdata(trChr2F, "tip"), dtPoly2[, 1:2]) - ## 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) - checkIdentical(labels(trChr3F), labTr) # check labels - checkIdentical(edgeLength(trChr3F), eTr) # check edge lengths - checkIdentical(nodeType(trChr3F), nTtr) # check node types - checkIdentical(class(trChr3F), p4d) # check class - checkIdentical(tdata(trChr3F, "tip"), dtPoly3[, 1:2]) - ## char.all=FALSE, levels.uniform=FALSE, return.labels=TRUE, polymorphic.convert=FALSE - ## not yet implemented - ## trChr4F <- - checkException(readNCL(file=treePolyDt, type="all", - levels.uniform=FALSE, - return.labels=TRUE, - polymorphic.convert=FALSE)) - ## 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) - checkIdentical(labels(trChr5F), labTr) # check labels - checkIdentical(edgeLength(trChr5F), eTr) # check edge lengths - checkIdentical(nodeType(trChr5F), nTtr) # check node types - checkIdentical(class(trChr5F), p4d) # check class - checkIdentical(tdata(trChr5F, "tip"), dtPoly5F) - ## 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) - checkIdentical(labels(trChr6F), labTr) # check labels - checkIdentical(edgeLength(trChr6F), eTr) # check edge lengths - checkIdentical(nodeType(trChr6F), nTtr) # check node types - checkIdentical(class(trChr6F), p4d) # check class - checkIdentical(tdata(trChr6F, "tip"), dtPoly6F) - ## char.all=FALSE, levels.uniform=TRUE, return.labels=TRUE, polymorphic.convert=FALSE - ## not yet implemented - ## trChr7F <- - checkException(readNCL(file=treePolyDt, type="all", char.all=FALSE, - levels.uniform=TRUE, - return.labels=TRUE, - polymorphic.convert=FALSE)) - ## 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) - checkIdentical(labels(trChr8F), labTr) # check labels - checkIdentical(edgeLength(trChr8F), eTr) # check edge lengths - checkIdentical(nodeType(trChr8F), nTtr) # check node types - checkIdentical(class(trChr8F), p4d) # check class - checkIdentical(tdata(trChr8F, "tip"), dtPoly8F) - - ## ########## Tree + Data -- test with continuous Characters - DtCont <- readNCL(file=treeContDt, type="data") - trDtCont <- readNCL(file=treeContDt, type="all") - load(ExContDataFile) - checkIdentical(DtCont, ExContData[rownames(DtCont), ]) - checkIdentical(tdata(trDtCont, "tip"), ExContData) - rm(ExContData) - checkIdentical(labels(trDtCont), labTr) # check labels - checkIdentical(edgeLength(trDtCont), eTr) # check edge lengths - checkIdentical(nodeType(trDtCont), nTtr) # check node types - checkIdentical(class(trDtCont), p4d) # check class - - ## ########## Tree + Data -- 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), ]) - rm(ExContDataFile) - checkIdentical(dtDiscCont, dtDiscContTest[rownames(dtDiscCont), ]) - checkIdentical(tdata(trDtDiscCont, "tip"), dtDiscContTest) - checkIdentical(labels(trDtDiscCont), labTr) # check labels - checkIdentical(edgeLength(trDtDiscCont), eTr) # check edge lengths - checkIdentical(nodeType(trDtDiscCont), nTtr) # check node types - checkIdentical(class(trDtDiscCont), p4d) # check class - - ## ########### Check for proper handling of missing files - checkException(readNCL(file="foo.bar")) - - ## ########### Check behavior in case of missing state labels - ow <- options("warn") - options(warn=2) - checkException(readNCL(file=noStateLabels, return.labels=TRUE)) - options(ow) - dtNoSt <- readNCL(file=noStateLabels, type="data", return.labels=TRUE) - checkIdentical(dtNoSt$char1, factor(c(1,2,0,1))) - - ## ########### 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 - ## check.node.labels="drop" with readNCL - newTr <- readNCL(file=newick, file.format="newick", check.node.labels="drop") - checkIdentical(labels(newTr), labNew) - checkIdentical(edgeLength(newTr), eLnew) - checkIdentical(nodeType(newTr), nTnew) - ## check.node.labels="drop" with readNewick - newTr <- readNewick(file=newick, check.node.labels="drop") - checkIdentical(labels(newTr), labNew) - checkIdentical(edgeLength(newTr), eLnew) - checkIdentical(nodeType(newTr), nTnew) - ## check.node.labels="asdata" with readNCL - newTr <- readNCL(file=newick, file.format="newick", check.node.labels="asdata") - checkIdentical(labels(newTr), labNew) - checkIdentical(tdata(newTr)$labelValues, factor(c(NA, NA, NA, "yy", "xx"))) - ## check.node.labels="asdata" with readNewick - newTr <- readNewick(file=newick, check.node.labels="asdata") - checkIdentical(labels(newTr), labNew) - checkIdentical(tdata(newTr)$labelValues, factor(c(NA, NA, NA, "yy", "xx"))) - ## check.node.labels="keep" with readNCL - labNew[4:5] <- c("yy", "xx") - newTr <- readNCL(file=newick, file.format="newick", check.node.labels="keep") - checkIdentical(labels(newTr), labNew) - ## check.node.labels="keep" with readNewick - newTr <- readNewick(file=newick, check.node.labels="keep") - checkIdentical(labels(newTr), labNew) -} Copied: pkg/tests/testthat/test.readNCL.R (from rev 880, pkg/inst/unitTests/runit.readNCL.R) =================================================================== --- pkg/tests/testthat/test.readNCL.R (rev 0) +++ pkg/tests/testthat/test.readNCL.R 2014-04-09 19:59:11 UTC (rev 925) @@ -0,0 +1,537 @@ +# +# --- Test readNCL.R --- +# + +### Get all the test files +if (Sys.getenv("RCMDCHECK") == FALSE) { + 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") + +## Contains correct (as of 2010-03-08) phylo4 representation of one of the tree +## stored in the nexus file +mlFile <- file.path(pth, "multiLines.Rdata") + +## 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(mlFile)) +stopifnot(file.exists(treePolyDt)) +stopifnot(file.exists(treeContDt)) +stopifnot(file.exists(treeDiscCont)) +stopifnot(file.exists(ExContDataFile)) +stopifnot(file.exists(noStateLabels)) + +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]] + expect_equal(labels(co1Tree1), labCo1) # check labels + expect_equal(edgeLength(co1Tree1), eLco1) # 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) # 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) + 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) # 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) + expect_equal(labels(co1), labCo1) # check labels + expect_equal(edgeLength(co1), eLco1) # 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("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 + load(mlFile) + expect_equal(multiLines[[1]], ml1) + expect_equal(multiLines[[2]], ml2) + rm(ml1, 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, [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/phylobase -r 925 From noreply at r-forge.r-project.org Wed Apr 9 22:00:10 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 9 Apr 2014 22:00:10 +0200 (CEST) Subject: [Phylobase-commits] r926 - pkg/R Message-ID: <20140409200010.93E7418708D@r-forge.r-project.org> Author: francois Date: 2014-04-09 22:00:09 +0200 (Wed, 09 Apr 2014) New Revision: 926 Removed: pkg/R/nData-methods.R Log: removing nData-methods, content transferred to phylo4d-accessors.R Deleted: pkg/R/nData-methods.R =================================================================== --- pkg/R/nData-methods.R 2014-04-09 19:59:11 UTC (rev 925) +++ pkg/R/nData-methods.R 2014-04-09 20:00:09 UTC (rev 926) @@ -1,30 +0,0 @@ - -##' Retrieves the number of datasets in phylo4d objects -##' -##' Method to retrieve the number of datasets associated with a phylogenetic -##' tree stored as a phylo4d object -##' -##' \code{nData} returns the number of datasets (i.e., columns) that are -##' associated with a \code{phylo4d} object. -##' -##' @param x A \code{phylo4d} object -##' @return \code{nData} returns a vector. -##' @author Francois Michonnea -##' @seealso \code{\link{tdata}}, \code{\link{phylo4d}} -##' @keywords methods -##' @export -##' @rdname nData-methods -##' @docType methods -##' @examples -##' -##' data(geospiza) -##' nData(geospiza) -setGeneric("nData", function(x, ...) { - standardGeneric("nData") -}) - -##' @rdname nData-methods -##' @aliases nData,phylo4d-method -setMethod("nData", signature(x="phylo4d"), function(x) { - ncol(x at data) -}) From noreply at r-forge.r-project.org Wed Apr 9 22:01:09 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 9 Apr 2014 22:01:09 +0200 (CEST) Subject: [Phylobase-commits] r927 - pkg/inst/unitTests Message-ID: <20140409200109.9F79F1874AC@r-forge.r-project.org> Author: francois Date: 2014-04-09 22:01:09 +0200 (Wed, 09 Apr 2014) New Revision: 927 Modified: pkg/inst/unitTests/runit.formatData.R Log: dealing with formatData not being exported Modified: pkg/inst/unitTests/runit.formatData.R =================================================================== --- pkg/inst/unitTests/runit.formatData.R 2014-04-09 20:00:09 UTC (rev 926) +++ pkg/inst/unitTests/runit.formatData.R 2014-04-09 20:01:09 UTC (rev 927) @@ -49,32 +49,32 @@ # extra.data=c("warn", "OK", "fail"), keep.all=TRUE ## vector data coerced to data.frame (colname dt) - checkIdentical(formatData(phy.alt, 1:5), - formatData(phy.alt, data.frame(dt=1:5))) + checkIdentical(phylobase:::formatData(phy.alt, 1:5), + phylobase:::formatData(phy.alt, data.frame(dt=1:5))) ## list of vector data coerced to data.frame (colnames as given) - checkIdentical(formatData(phy.alt, list(a=1:5, b=6:10)), - formatData(phy.alt, data.frame(a=1:5, b=6:10))) + checkIdentical(phylobase:::formatData(phy.alt, list(a=1:5, b=6:10)), + phylobase:::formatData(phy.alt, data.frame(a=1:5, b=6:10))) ## factor data coerced to data.frame (colname dt) - checkIdentical(formatData(phy.alt, factor(letters[1:5])), - formatData(phy.alt, data.frame(dt=letters[1:5]))) + checkIdentical(phylobase:::formatData(phy.alt, factor(letters[1:5])), + phylobase:::formatData(phy.alt, data.frame(dt=letters[1:5]))) ## matrix data coerced to data.frame (colnames V1, V2) - checkIdentical(formatData(phy.alt, matrix(1:10, ncol=2)), - formatData(phy.alt, data.frame(V1=1:5, V2=6:10))) + checkIdentical(phylobase:::formatData(phy.alt, matrix(1:10, ncol=2)), + phylobase:::formatData(phy.alt, data.frame(V1=1:5, V2=6:10))) ## matrix data coerced to data.frame (colname as given) - checkIdentical(formatData(phy.alt, matrix(1:10, ncol=2, + checkIdentical(phylobase:::formatData(phy.alt, matrix(1:10, ncol=2, dimnames=list(NULL, c("a", "b")))), - formatData(phy.alt, data.frame(a=1:5, b=6:10))) + phylobase:::formatData(phy.alt, data.frame(a=1:5, b=6:10))) ## error if dt is, say, a phylo4 object - checkException(formatData(phy.alt, phy.alt)) + checkException(phylobase:::formatData(phy.alt, phy.alt)) ## error if column number is out of range - checkException(formatData(phy.alt, data.frame(a=1:5, + checkException(phylobase:::formatData(phy.alt, data.frame(a=1:5, lab=rev(nid.tip)), type="tip", match.data=FALSE, label.type="column", label.column=3), data.frame(a=c(1:5, rep(NA, 4)), lab=c(rev(nid.tip), rep(NA, 4)), row.names=nid.all)) ## error if column name is wrong - checkException(formatData(phy.alt, data.frame(a=1:5, + checkException(phylobase:::formatData(phy.alt, data.frame(a=1:5, lab=rev(nid.tip)), type="tip", match.data=FALSE, label.type="column", label.column="foo"), data.frame(a=c(1:5, rep(NA, 4)), lab=c(rev(nid.tip), rep(NA, @@ -86,27 +86,27 @@ # ## don't match (purely positional) - checkIdentical(formatData(phy.alt, data.frame(a=1:5, + checkIdentical(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) - checkIdentical(formatData(phy.alt, data.frame(a=1:5, + checkIdentical(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)) - checkIdentical(formatData(phy.alt, data.frame(a=1:5, + checkIdentical(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) - checkIdentical(formatData(phy.alt, data.frame(a=1:5, + checkIdentical(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) - checkIdentical(formatData(phy.alt, data.frame(a=1:5, + checkIdentical(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 - checkException(formatData(phy.alt, data.frame(a=1:5, + checkException(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)) @@ -115,45 +115,45 @@ # ## should ignore label (purely positional) and retain a label col - checkIdentical(formatData(phy.alt, data.frame(a=1:5, + checkIdentical(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) - checkIdentical(formatData(phy.alt, data.frame(a=1:5, + checkIdentical(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)) - checkIdentical(formatData(phy.alt, data.frame(a=1:5, + checkIdentical(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) - checkIdentical(formatData(phy.alt, data.frame(a=1:5, + checkIdentical(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)) - checkIdentical(formatData(phy.alt, data.frame(a=1:5, + checkIdentical(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) - checkIdentical(formatData(phy.alt, data.frame(a=1:5, + checkIdentical(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 - checkException(formatData(phy.alt, data.frame(a=1:5, + checkException(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' - checkException(formatData(phy.alt, data.frame(a=1:5, row.names=4:8), + checkException(phylobase:::formatData(phy.alt, data.frame(a=1:5, row.names=4:8), type="tip")) ## and vice versa - checkException(formatData(phy.alt, data.frame(a=6:9, row.names=1:4), + checkException(phylobase:::formatData(phy.alt, data.frame(a=6:9, row.names=1:4), type="internal")) # @@ -161,31 +161,31 @@ # ## force error conditions - checkException(formatData(phy.alt, data.frame(a=1:3), type="tip")) - checkException(formatData(phy.alt, data.frame(a=1:3), type="tip", + checkException(phylobase:::formatData(phy.alt, data.frame(a=1:3), type="tip")) + checkException(phylobase:::formatData(phy.alt, data.frame(a=1:3), type="tip", missing.data="fail")) options(warn=3) - checkException(formatData(phy.alt, data.frame(a=1:3), type="tip", + checkException(phylobase:::formatData(phy.alt, data.frame(a=1:3), type="tip", missing.data="warn")) options(warn=0) ## missing data with matching - checkIdentical(formatData(phy.alt, data.frame(a=rev(nid.tip)[-1], + checkIdentical(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)))) - checkIdentical(formatData(phy.alt, data.frame(a=rev(nid.int)[-1], + checkIdentical(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))) - checkIdentical(formatData(phy.alt, data.frame(a=rev(nid.all)[-1], + checkIdentical(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 - checkIdentical(formatData(phy.alt, data.frame(a=rev(nid.tip)[-1]), + checkIdentical(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)))) - checkIdentical(formatData(phy.alt, data.frame(a=rev(nid.int)[-1]), + checkIdentical(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))) - checkIdentical(formatData(phy.alt, data.frame(a=rev(nid.all)[-1]), + checkIdentical(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))) @@ -194,37 +194,37 @@ # ## force error conditions - checkException(formatData(phy.alt, data.frame(a=1:3), type="tip", + checkException(phylobase:::formatData(phy.alt, data.frame(a=1:3), type="tip", missing.data="fail")) options(warn=3) - checkException(formatData(phy.alt, data.frame(a=0:5, row.names=0:5), + checkException(phylobase:::formatData(phy.alt, data.frame(a=0:5, row.names=0:5), type="tip", missing="warn")) - checkException(formatData(phy.alt, data.frame(a=0:5, row.names=0:5), + checkException(phylobase:::formatData(phy.alt, data.frame(a=0:5, row.names=0:5), type="tip")) options(warn=0) ## extra data with matching - checkIdentical(formatData(phy.alt, data.frame(a=c(0L, rev(nid.tip)), + checkIdentical(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)))) - checkIdentical(formatData(phy.alt, data.frame(a=c(0L, rev(nid.int)), + checkIdentical(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))) - checkIdentical(formatData(phy.alt, data.frame(a=c(0L, rev(nid.all)), + checkIdentical(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 - checkIdentical(formatData(phy.alt, data.frame(a=1:15), + checkIdentical(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)))) - checkIdentical(formatData(phy.alt, data.frame(a=1:15), + checkIdentical(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))) - checkIdentical(formatData(phy.alt, data.frame(a=1:15), + checkIdentical(phylobase:::formatData(phy.alt, 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 - checkIdentical(formatData(phy.alt, data.frame(a=0:3, row.names=0:3), + checkIdentical(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)))) @@ -233,23 +233,23 @@ # ## keep all rows - checkIdentical(formatData(phy.alt, data.frame(a=1:5, + checkIdentical(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)) - checkIdentical(formatData(phy.alt, data.frame(a=1:5, + checkIdentical(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)) - checkIdentical(formatData(phy.alt, data.frame(a=6:9, + checkIdentical(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)) - checkIdentical(formatData(phy.alt, data.frame(a=6:9, + checkIdentical(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 - checkIdentical(formatData(phy.alt, data.frame(a=1:5, + checkIdentical(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)) - checkIdentical(formatData(phy.alt, data.frame(a=6:9, + checkIdentical(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)) @@ -268,50 +268,50 @@ tipLabels(phy.dup)[2] <- tipLabels(phy.dup)[1] ## vector data coerced to data.frame (colname dt) - checkIdentical(formatData(phy.dup, 1:5), - formatData(phy.dup, data.frame(dt=1:5))) + checkIdentical(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) - checkIdentical(formatData(phy.dup, list(a=1:5, b=6:10)), - formatData(phy.dup, data.frame(a=1:5, b=6:10))) + checkIdentical(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) - checkIdentical(formatData(phy.dup, factor(letters[1:5])), - formatData(phy.dup, data.frame(dt=letters[1:5]))) + checkIdentical(phylobase:::formatData(phy.dup, factor(letters[1:5])), + phylobase:::formatData(phy.dup, data.frame(dt=letters[1:5]))) ## matrix data coerced to data.frame (colnames V1, V2) - checkIdentical(formatData(phy.dup, matrix(1:10, ncol=2)), - formatData(phy.dup, data.frame(V1=1:5, V2=6:10))) + checkIdentical(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) - checkIdentical(formatData(phy.dup, matrix(1:10, ncol=2, + checkIdentical(phylobase:::formatData(phy.dup, matrix(1:10, ncol=2, dimnames=list(NULL, c("a", "b")))), - formatData(phy.dup, data.frame(a=1:5, b=6:10))) + phylobase:::formatData(phy.dup, data.frame(a=1:5, b=6:10))) ## error if dt is, say, a phylo4 object - checkException(formatData(phy.dup, phy.dup)) + checkException(phylobase:::formatData(phy.dup, phy.dup)) # # matching options # ## don't match (purely positional) - checkIdentical(formatData(phy.dup, data.frame(a=1:5, + checkIdentical(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) - checkIdentical(formatData(phy.dup, data.frame(a=1:5, + checkIdentical(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)) - checkIdentical(formatData(phy.dup, data.frame(a=1:5, + checkIdentical(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) - checkIdentical(formatData(phy.dup, data.frame(a=c(1,3,4,5), + checkIdentical(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) - checkIdentical(formatData(phy.dup, data.frame(a=c(1,2,3,4,5), + checkIdentical(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 - checkException(formatData(phy.dup, data.frame(a=1:5, + checkException(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)) @@ -320,41 +320,41 @@ # ## should ignore label (purely positional) and retain a label col - checkIdentical(formatData(phy.dup, data.frame(a=1:5, + checkIdentical(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) - checkIdentical(formatData(phy.dup, data.frame(a=1:5, + checkIdentical(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)) - checkIdentical(formatData(phy.dup, data.frame(a=1:5, + checkIdentical(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) - checkIdentical(formatData(phy.dup, data.frame(a=1:4, + checkIdentical(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) - checkIdentical(formatData(phy.dup, data.frame(a=1:5, + checkIdentical(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 - checkException(formatData(phy.dup, data.frame(a=1:5, + checkException(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' - checkException(formatData(phy.dup, data.frame(a=1:5, row.names=4:8), + checkException(phylobase:::formatData(phy.dup, data.frame(a=1:5, row.names=4:8), type="tip")) ## and vice versa - checkException(formatData(phy.dup, data.frame(a=6:9, row.names=1:4), + checkException(phylobase:::formatData(phy.dup, data.frame(a=6:9, row.names=1:4), type="internal")) # @@ -362,31 +362,31 @@ # ## force error conditions - checkException(formatData(phy.dup, data.frame(a=1:3), type="tip")) - checkException(formatData(phy.dup, data.frame(a=1:3), type="tip", + checkException(phylobase:::formatData(phy.dup, data.frame(a=1:3), type="tip")) + checkException(phylobase:::formatData(phy.dup, data.frame(a=1:3), type="tip", missing.data="fail")) options(warn=3) - checkException(formatData(phy.dup, data.frame(a=1:3), type="tip", + checkException(phylobase:::formatData(phy.dup, data.frame(a=1:3), type="tip", missing.data="warn")) options(warn=0) ## missing data with matching - checkIdentical(formatData(phy.dup, data.frame(a=rev(nid.tip)[-1], + checkIdentical(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)))) - checkIdentical(formatData(phy.dup, data.frame(a=rev(nid.int)[-1], + checkIdentical(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))) - checkIdentical(formatData(phy.dup, data.frame(a=rev(nid.all)[-1], + checkIdentical(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 - checkIdentical(formatData(phy.dup, data.frame(a=rev(nid.tip)[-1]), + checkIdentical(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)))) - checkIdentical(formatData(phy.dup, data.frame(a=rev(nid.int)[-1]), + checkIdentical(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))) - checkIdentical(formatData(phy.dup, data.frame(a=rev(nid.all)[-1]), + checkIdentical(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))) @@ -394,38 +394,38 @@ # extra.data # - ## force error conditions - checkException(formatData(phy.dup, data.frame(a=1:3), type="tip", + ## force error conditions + checkException(phylobase:::formatData(phy.dup, data.frame(a=1:3), type="tip", missing.data="fail")) options(warn=3) - checkException(formatData(phy.dup, data.frame(a=0:5, row.names=0:5), + checkException(phylobase:::formatData(phy.dup, data.frame(a=0:5, row.names=0:5), type="tip", missing="warn")) - checkException(formatData(phy.dup, data.frame(a=0:5, row.names=0:5), + checkException(phylobase:::formatData(phy.dup, data.frame(a=0:5, row.names=0:5), type="tip")) options(warn=0) ## extra data with matching - checkIdentical(formatData(phy.dup, data.frame(a=c(0L, rev(nid.tip)), + checkIdentical(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)))) - checkIdentical(formatData(phy.dup, data.frame(a=c(0L, rev(nid.int)), + checkIdentical(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))) - checkIdentical(formatData(phy.dup, data.frame(a=c(0L, rev(nid.all)), + checkIdentical(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 - checkIdentical(formatData(phy.dup, data.frame(a=1:15), + checkIdentical(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)))) - checkIdentical(formatData(phy.dup, data.frame(a=1:15), + checkIdentical(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))) - checkIdentical(formatData(phy.dup, data.frame(a=1:15), + checkIdentical(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 - checkIdentical(formatData(phy.dup, data.frame(a=0:3, row.names=0:3), + checkIdentical(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)))) @@ -434,23 +434,23 @@ # ## keep all rows - checkIdentical(formatData(phy.dup, data.frame(a=1:5, + checkIdentical(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)) - checkIdentical(formatData(phy.dup, data.frame(a=1:5, + checkIdentical(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)) - checkIdentical(formatData(phy.dup, data.frame(a=6:9, + checkIdentical(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)) - checkIdentical(formatData(phy.dup, data.frame(a=6:9, + checkIdentical(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 - checkIdentical(formatData(phy.dup, data.frame(a=1:5, + checkIdentical(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)) - checkIdentical(formatData(phy.dup, data.frame(a=6:9, + checkIdentical(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)) From noreply at r-forge.r-project.org Wed Apr 9 22:01:52 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 9 Apr 2014 22:01:52 +0200 (CEST) Subject: [Phylobase-commits] r928 - in pkg: . src tests/testthat Message-ID: <20140409200152.9C0CB1874BA@r-forge.r-project.org> Author: francois Date: 2014-04-09 22:01:51 +0200 (Wed, 09 Apr 2014) New Revision: 928 Modified: pkg/DESCRIPTION pkg/NAMESPACE pkg/NEWS pkg/src/RcppExports.cpp pkg/tests/testthat/test.methods-phylo4.R Log: dealing with modified output of rootNode Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2014-04-09 20:01:09 UTC (rev 927) +++ pkg/DESCRIPTION 2014-04-09 20:01:51 UTC (rev 928) @@ -1,15 +1,15 @@ Package: phylobase Type: Package Title: Base package for phylogenetic structures and comparative data -Version: 0.6.8 -Date: 2014-03-20 -Imports: +Version: 0.6.9-1 +Date: 2014-04-08 +Imports: ade4, ape (>= 3.0), - Rcpp (>= 0.11.0), + Rcpp (>= 0.11.0) +Depends: + grid, methods -Depends: - grid LinkingTo: Rcpp Suggests: MASS, @@ -23,30 +23,42 @@ Description: Provides a base S4 class for comparative methods, incorporating one or more trees and trait data License: GPL (>= 2) +URL: http://phylobase.R-forge.R-project.org Collate: 'RcppExports.R' - 'phylo4.R' 'checkdata.R' + 'phylo4-class.R' + 'oldclasses-class.R' + 'internal-constructors.R' + 'phylo4-methods.R' 'formatData.R' - 'class-multiphylo4.R' - 'class-oldclasses.R' - 'class-phylo4.R' - 'class-phylo4d.R' - 'class-phylomats.R' - 'methods-multiphylo4.R' - 'methods-oldclasses.R' - 'methods-phylo4.R' - 'methods-phylo4d.R' - 'setAs-Methods.R' + 'phylo4d-class.R' + 'phylo4d-methods.R' + 'getNode-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' - 'subset.R' + 'phylo4d-accessors.R' 'phylobase-package.R' 'phylobase.options.R' - 'prune.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' - 'treewalk.R' - 'readNCL.R' - 'tbind.R' 'zzz.R' -URL: http://phylobase.R-forge.R-project.org Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2014-04-09 20:01:09 UTC (rev 927) +++ pkg/NAMESPACE 2014-04-09 20:01:51 UTC (rev 928) @@ -1,119 +1,87 @@ -# ---------------------------------------------------------------------- - -useDynLib(phylobase) - -#---------------------------------------------------------------------- - -import(methods) -import(ape) - -importFrom(Rcpp, evalCpp) -importFrom(graphics, plot) -importFrom(stats, reorder) -importFrom(utils, head, tail) -importFrom(ade4, newick2phylog) - -#---------------------------------------------------------------------- - -exportClasses(phylo4, phylo4d, multiPhylo4, multiPhylo4d) - -#---------------------------------------------------------------------- - -# utility methods -exportMethods(print, head, tail, reorder, plot, summary) - -# tree constructor methods -exportMethods(phylo4, phylo4d) - -# counting methods -exportMethods(nTips, nNodes, nEdges, depthTips) - -# edge methods -exportMethods(edges, edgeId, hasEdgeLength, edgeLength, "edgeLength<-", - sumEdgeLength, edgeOrder) - -# root methods -exportMethods(isRooted, rootNode, "rootNode<-") -#export(rootEdge) # no methods defined yet? - -# node methods -exportMethods(nodeId, nodeType, nodeDepth) - -# tree properties methods -exportMethods(isUltrametric) - -# tree data methods -exportMethods(tdata, "tdata<-", tipData, "tipData<-", nodeData, - "nodeData<-", hasTipData, hasNodeData, addData, nData) - -# subset methods -exportMethods(subset, prune, "[") - -# pdata methods -exportMethods("[<-", "[[", "[[<-") - -# label methods -exportMethods(labels, "labels<-", nodeLabels, "nodeLabels<-", - tipLabels, "tipLabels<-", edgeLabels, "edgeLabels<-", - hasNodeLabels, hasEdgeLabels, hasDuplicatedLabels) - -#---------------------------------------------------------------------- - -# tree structure functions -export(hasPoly, hasSingle, hasRetic) - -# treewalk functions -export(getNode, ancestor, children, descendants, siblings, ancestors, - MRCA, shortestPath, getEdge) - -# Import functions -export(readNexus) -export(readNewick) -export(readNCL) - -# pdata functions -export(pdata, check_pdata) - -# plotting functions -export(treePlot, plotOneTree, tip.data.plot) -export(phyloXXYY, phylobubbles) - -# misc functions -export(extractTree, tbind) -export(checkPhylo4, checkTree, checkPhylo4Data, formatData) -export(as_phylo4vcov) -export(printphylo4) - -#---------------------------------------------------------------------- - -# misc objects -export(phylo4_orderings) - -## options +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(nodeData) +export(nodeDepth) +export(nodeId) +export(nodeLabels) +export(nodeType) +export(phylo4) +export(phylo4d) +export(phyloXXYY) export(phylobase.options) - - - -## commented out in source code, probably should be omitted here -#export(phyloStripchart) -#export(internEdges, terminEdges, isPoly) - -## presumably these should remain hidden -##export(.createLabels, .createEdge, .phylo4Data, orderIndex, .genlab, -## .chnumsort, .phylo4ToDataFrame, .bubLegendGrob) -## hidden: drawDetails.bubLegend) - -## recently removed: -## tree.plot -## segs -## checkData -## attachData -## orderIndex - -#---------------------------------------------------------------------- -## For reference, quick & dirty UNIX-y commandline statements to pull -## out methods and functions from package code; use in pkg/R/ dir: -# grep "^ *setMethod" *.R | sed 's/setMethod(//' | sed 's/.*:["]\([^,]*\)["].*/\1/' | sort | uniq -# grep "^ *setReplaceMethod" *.R | sed 's/setReplaceMethod(//' | sed 's/.*:["]\([^,]*\)["].*/\1/' | sort | uniq -# grep "^[^ ].*<- *function *(" *.R | sed 's/.*R://' - +export(phylobubbles) +export(plotOneTree) +export(prune) +export(readNCL) +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(ape) +import(methods) +importFrom(Rcpp,evalCpp) +importFrom(ade4,newick2phylog) +importFrom(graphics,plot) +importFrom(stats,reorder) +importFrom(utils,head) +importFrom(utils,tail) +useDynLib(phylobase) Modified: pkg/NEWS =================================================================== --- pkg/NEWS 2014-04-09 20:01:09 UTC (rev 927) +++ pkg/NEWS 2014-04-09 20:01:51 UTC (rev 928) @@ -7,6 +7,14 @@ * * ************************************************* + CHANGES IN phylobase VERSION 0.6.10 + + * All documentation is now in Roxygen format + + * New methods: internalEdges(), terminalEdges() + + * hasPoly, hasRetic, hasSingle are now methods instead of functions. + CHANGES IN phylobase VERSION 0.6.8 * Not many user-visible changes, most are related to improving speeds Modified: pkg/src/RcppExports.cpp =================================================================== --- pkg/src/RcppExports.cpp 2014-04-09 20:01:09 UTC (rev 927) +++ pkg/src/RcppExports.cpp 2014-04-09 20:01:51 UTC (rev 928) @@ -158,15 +158,14 @@ END_RCPP } // getAllNodesFast -Rcpp::IntegerVector getAllNodesFast(Rcpp::IntegerMatrix edge, bool rooted); -RcppExport SEXP phylobase_getAllNodesFast(SEXP edgeSEXP, SEXP rootedSEXP) { +Rcpp::IntegerVector getAllNodesFast(Rcpp::IntegerMatrix edge); +RcppExport SEXP phylobase_getAllNodesFast(SEXP edgeSEXP) { BEGIN_RCPP SEXP __sexp_result; { Rcpp::RNGScope __rngScope; Rcpp::traits::input_parameter< Rcpp::IntegerMatrix >::type edge(edgeSEXP ); - Rcpp::traits::input_parameter< bool >::type rooted(rootedSEXP ); - Rcpp::IntegerVector __result = getAllNodesFast(edge, rooted); + Rcpp::IntegerVector __result = getAllNodesFast(edge); PROTECT(__sexp_result = Rcpp::wrap(__result)); } UNPROTECT(1); Modified: pkg/tests/testthat/test.methods-phylo4.R =================================================================== --- pkg/tests/testthat/test.methods-phylo4.R 2014-04-09 20:01:09 UTC (rev 927) +++ pkg/tests/testthat/test.methods-phylo4.R 2014-04-09 20:01:51 UTC (rev 928) @@ -244,7 +244,7 @@ context("rootNode") test_that("rootNode works as expected", - expect_identical(rootNode(phy.alt), nid.int[1])) + expect_identical(rootNode(phy.alt), getNode(phy, nid.int[1]))) context("rootNode <-") test_that("rootNode <- is not yet implemented", From noreply at r-forge.r-project.org Wed Apr 9 22:05:14 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 9 Apr 2014 22:05:14 +0200 (CEST) Subject: [Phylobase-commits] r929 - pkg Message-ID: <20140409200514.DD1311874EA@r-forge.r-project.org> Author: francois Date: 2014-04-09 22:05:13 +0200 (Wed, 09 Apr 2014) New Revision: 929 Modified: pkg/NEWS Log: adding change to rootNode to NEWS Modified: pkg/NEWS =================================================================== --- pkg/NEWS 2014-04-09 20:01:51 UTC (rev 928) +++ pkg/NEWS 2014-04-09 20:05:13 UTC (rev 929) @@ -15,6 +15,8 @@ * hasPoly, hasRetic, hasSingle are now methods instead of functions. + * rootNode returns the rootNode using the same format as getNode(). + CHANGES IN phylobase VERSION 0.6.8 * Not many user-visible changes, most are related to improving speeds