[Phylobase-commits] r898 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Apr 1 04:05:14 CEST 2014
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
More information about the Phylobase-commits
mailing list