[Phylobase-commits] r452 - in branches/fm-branch: . R data man tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Aug 13 16:48:13 CEST 2009
Author: francois
Date: 2009-08-13 16:48:13 +0200 (Thu, 13 Aug 2009)
New Revision: 452
Modified:
branches/fm-branch/DESCRIPTION
branches/fm-branch/R/checkData-deprecated.R
branches/fm-branch/R/checkdata.R
branches/fm-branch/R/class-phylo4.R
branches/fm-branch/R/class-phylo4d.R
branches/fm-branch/R/methods-phylo4.R
branches/fm-branch/R/methods-phylo4d.R
branches/fm-branch/R/phylo4.R
branches/fm-branch/R/prune.R
branches/fm-branch/R/setAs-Methods.R
branches/fm-branch/R/treewalk.R
branches/fm-branch/data/geospiza.rda
branches/fm-branch/man/as-methods.Rd
branches/fm-branch/man/check.phylo4.Rd
branches/fm-branch/man/check.phylo4d.Rd
branches/fm-branch/man/phylo4d-class.Rd
branches/fm-branch/man/phylo4d.Rd
branches/fm-branch/man/prune-methods.Rd
branches/fm-branch/man/subset-methods.Rd
branches/fm-branch/tests/misctests.R
branches/fm-branch/tests/testprune.R
Log:
o created replace method for edgeLength
o updated hasEdgeLength test
o fixed bugs in replace methods for labels
o updated hasNodeLabels test
o added test on validity of phylo4(d) object in edgeLabels replace method
o updated coerce method from phylo4 to phylo (need more work)
o fixed small bugs in .createLabels
o created new function .createEdge
o updated phylo4 constructor to use .createEdge
o updated prune method for phylo4d objects
o phylo4 validator checks for correct formatting of edge lenghts
o updated getNode to reflect new structure of labels
o rewrote getEdge and adding more arguments
o updated example in man pages so my branch checks only with warnings
o updated geospiza data (added internal labels)
o updated tests
Modified: branches/fm-branch/DESCRIPTION
===================================================================
--- branches/fm-branch/DESCRIPTION 2009-08-01 00:02:21 UTC (rev 451)
+++ branches/fm-branch/DESCRIPTION 2009-08-13 14:48:13 UTC (rev 452)
@@ -1,7 +1,7 @@
Package: phylobase
Type: Package
Title: Base package for phylogenetic structures and comparative data
-Version: 0.4
+Version: 0.4.1
Date: 2009-04-21
Depends: methods, grid, ape(>= 2.1)
Suggests: ade4, MASS, gridBase
@@ -9,6 +9,6 @@
Maintainer: Ben Bolker <bolker at ufl.edu>
Description: Provides a base S4 class for comparative methods, incorporating one or more trees and trait data
License: GPL
-Collate: phylo4.R checkdata.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 pdata.R subset.R prune.R treePlot.R identify.R treestruc.R treewalk.R readNexus.R tbind.R zzz.R printphylo-deprecated.R updatePhylo4.R checkData.R
+Collate: phylo4.R checkData-deprecated.R checkdata.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 pdata.R subset.R prune.R treePlot.R identify.R treestruc.R treewalk.R readNexus.R tbind.R zzz.R printphylo-deprecated.R updatePhylo4.R
Encoding: UTF-8
URL: http://phylobase.R-forge.R-project.org
Modified: branches/fm-branch/R/checkData-deprecated.R
===================================================================
--- branches/fm-branch/R/checkData-deprecated.R 2009-08-01 00:02:21 UTC (rev 451)
+++ branches/fm-branch/R/checkData-deprecated.R 2009-08-13 14:48:13 UTC (rev 452)
@@ -273,3 +273,48 @@
}
}
}
+
+
+attachData <- function(object,
+ label.type=c("row.names","column"),
+ label.column=1,
+ use.tip.names=TRUE,
+ use.node.names=FALSE,
+ ...)
+{
+
+ ## assumes data have already been checked by checkData!
+ ## name matching default: use row.names of data frame
+ label.type = match.arg(label.type)
+ if (identical(label.type, "row.names")) {
+ tip.names <- row.names(object at tip.data)
+ node.names <- row.names(object at node.data)
+ }
+ else {
+ tip.names <- object at tip.data[,label.column]
+ node.names <- object at node.data[,label.column]
+ }
+
+
+ ## for each set of data, take appropriate actions
+
+ ## tip data operations:
+ ## if tip.data exist
+ if (!all(dim(object at tip.data)==0)) {
+ ## if we want to use tip.names
+ if (use.tip.names) {
+ object at tip.data <- object at tip.data[match(object at tip.label,tip.names),,drop=FALSE]
+ }
+ }
+
+ ## node data operations
+ if (!all(dim(object at node.data)==0)) {
+ ## if we want to use tip.names
+ if (use.node.names) {
+ object at node.data <- object at node.data[match(object at node.label,node.names),,drop=FALSE]
+ }
+ }
+
+ return(object)
+
+}
Modified: branches/fm-branch/R/checkdata.R
===================================================================
--- branches/fm-branch/R/checkdata.R 2009-08-01 00:02:21 UTC (rev 451)
+++ branches/fm-branch/R/checkdata.R 2009-08-13 14:48:13 UTC (rev 452)
@@ -113,6 +113,13 @@
}
}
+ ## make sure that edgeLength has correct length and is numerical
+ if(hasEdgeLength(object)) {
+ if(length(object at edge.length) != nedges)
+ stop("The number of edge lengths is different from the number of edges.")
+ if(!is.numeric(object at edge.length)) stop("Edge lengths are not numeric.")
+ }
+
## make sure that tip and node labels are unique
lb <- labels(object, "allnode")
lb <- lb[nchar(lb) > 0]
@@ -172,7 +179,7 @@
else getNode(phy, nd, missing="OK")
})
ndDt <- unlist(ndDt)
-
+
## Make sure that data are matched to appropriate nodes
if(which != "all") {
switch(which,
@@ -217,6 +224,9 @@
tmpDt[match(rownames(dt), rownames(tmpDt)), ] <- dt
}
else {
+ ## Remove rownames in data provided
+ rownames(dt) <- NULL
+
## Check differences between dataset and tree
diffNr <- nrow(dt) - nr
if(diffNr > 0 && extra.data != "OK") {
@@ -236,50 +246,3 @@
tmpDt
}
-
-
-attachData <- function(object,
- label.type=c("row.names","column"),
- label.column=1,
- use.tip.names=TRUE,
- use.node.names=FALSE,
- ...)
-{
-
- ## assumes data have already been checked by checkData!
- ## name matching default: use row.names of data frame
- label.type = match.arg(label.type)
- if (identical(label.type, "row.names")) {
- tip.names <- row.names(object at tip.data)
- node.names <- row.names(object at node.data)
- }
- else {
- tip.names <- object at tip.data[,label.column]
- node.names <- object at node.data[,label.column]
- }
-
-
- ## for each set of data, take appropriate actions
-
- ## tip data operations:
- ## if tip.data exist
- if (!all(dim(object at tip.data)==0)) {
- ## if we want to use tip.names
- if (use.tip.names) {
- object at tip.data <- object at tip.data[match(object at tip.label,tip.names),,drop=FALSE]
- }
- #tip.names <- object at tip.label
- }
-
- ## node data operations
- if (!all(dim(object at node.data)==0)) {
- ## if we want to use tip.names
- if (use.node.names) {
- object at node.data <- object at node.data[match(object at node.label,node.names),,drop=FALSE]
- }
- #node.names <- object at node.label
- }
-
- return(object)
-
-}
Modified: branches/fm-branch/R/class-phylo4.R
===================================================================
--- branches/fm-branch/R/class-phylo4.R 2009-08-01 00:02:21 UTC (rev 451)
+++ branches/fm-branch/R/class-phylo4.R 2009-08-13 14:48:13 UTC (rev 452)
@@ -23,7 +23,7 @@
#####################
.createLabels <- function(value, ntips, nnodes, use.names = TRUE,
- which = c("tip", "internal")) {
+ which = c("tip", "internal", "allnode")) {
which <- match.arg(which)
@@ -33,27 +33,25 @@
## create NA character vector of node labels
res <- character(lgthRes)
is.na(res) <- TRUE
+
+ ## create internal names
names(res) <- switch(which,
tip = 1:ntips,
internal = seq(from=ntips+1, length=lgthRes),
allnode = 1:(ntips+nnodes))
- ## if value is NULL
- if(is.null(value) || all(is.na(value))) {
+ ## if no values are provided
+ if(missing(value) || is.null(value) || all(is.na(value))) {
## tip labels can't be NULL
if(!identical(which, "internal")) {
tipLbl <- .genlab("T", ntips)
res[1:ntips] <- tipLbl
}
}
+
## if labels are provided
else {
- ## check that not only numbers
- ##if(length(grep("[a-zA-Z]", value)) == 0)
- ## stop("Labels need to contain characters. ",
- ## "They can't just be numerical values")
-
## check that lengths match
if(length(value) != lgthRes)
stop("Number of labels does not match number of nodes.")
@@ -71,6 +69,28 @@
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
#####################
@@ -96,37 +116,23 @@
edge <- as.matrix(edge[, 1:2])
colnames(edge) <- c("ancestor", "descendant")
- ## edge.length
- if(!is.null(edge.length)) {
- if(!is.numeric(edge.length)) stop("edge.length is not numeric")
- edge.length <- edge.length
- } else {
- edge.length <- numeric(0)
- }
-
- if(length(edge.length) > 0) {
- if(length(edge.length) != nrow(edge))
- stop("The number of edge lengths is different from the number of edges.")
- ## FM - 2009-04-19
- ## edge.length is named according to the nodes the edge links together
- ## (ancestor-descendant). This should allow more robust edge/edge.length
- ## association and limit the problems associated with reordering trees.
- names(edge.length) <- paste(edge[,1], edge[,2], sep="-")
- }
-
## number of tips and number of nodes
ntips <- sum(tabulate(na.omit(edge[, 1])) == 0)
nnodes <- length(unique(na.omit(c(edge)))) - ntips
+ ## edge.length
+ edge.length <- .createEdge(value=edge.length, edgeMat=edge, type="lengths", use.names=FALSE)
+
+ ## edge.label
+ edge.label <- .createEdge(value=edge.label, edgeMat=edge, type="labels", use.names=FALSE)
+
## tip.label
tip.label <- .createLabels(value=tip.label, ntips=ntips, nnodes=nnodes,
which="tip")
- ## edge.label
- if(is.null(edge.label)) {
- edge.label <- character(0)
- } else if (length(edge.label)>0 && length(edge.label) != nrow(edge))
- stop("number of edge labels is not consistent with the number of edges")
+ ## node.label
+ node.label <- .createLabels(node.label, ntips=ntips, nnodes=nnodes,
+ which="internal")
## fill in the result
res <- new("phylo4")
@@ -134,8 +140,7 @@
res at edge.length <- edge.length
res at Nnode <- nnodes
res at tip.label <- tip.label
- res at node.label <- .createLabels(node.label, ntips=ntips, nnodes=nnodes,
- which="internal")
+ res at node.label <- node.label
res at edge.label <- edge.label
res at order <- order
Modified: branches/fm-branch/R/class-phylo4d.R
===================================================================
--- branches/fm-branch/R/class-phylo4d.R 2009-08-01 00:02:21 UTC (rev 451)
+++ branches/fm-branch/R/class-phylo4d.R 2009-08-13 14:48:13 UTC (rev 452)
@@ -27,8 +27,8 @@
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,
- match.data=TRUE, merge.data=TRUE, ...) {
+.phylo4Data <- function(x, tip.data=NULL, node.data=NULL, all.data=NULL,
+ match.data=TRUE, merge.data=TRUE, ...) {
## Make sure that data provided are a data frame
classData <- function(someData) {
@@ -36,7 +36,7 @@
if(is.vector(someData))
someData <- as.data.frame(someData)
if(!is.data.frame(someData)) {
- nmSomedata <- deparseSubstitute(someData)
+ nmSomeData <- substitute(someData)
stop(paste(nmSomeData, "must be a vector or a data frame"))
}
someData
@@ -51,18 +51,17 @@
tip.data <- classData(tip.data)
node.data <- classData(node.data)
-
## Replacing node labels by node numbers and formatting the data to make sure
## they have the correct dimensions
- if(!is.null(all.data))
+ if(!is.null(all.data) && all(dim(all.data) > 0))
all.data <- formatData(x, all.data, which="all",
match.data=match.data, ...)
- if(!is.null(tip.data))
+ if(!is.null(tip.data) && all(dim(tip.data) > 0))
tip.data <- formatData(x, tip.data, which="tip",
match.data=match.data, ...)
- if(!is.null(node.data))
+ if(!is.null(node.data) && all(dim(node.data) > 0))
node.data <- formatData(x, node.data, which="internal",
match.data=match.data, ...)
Modified: branches/fm-branch/R/methods-phylo4.R
===================================================================
--- branches/fm-branch/R/methods-phylo4.R 2009-08-01 00:02:21 UTC (rev 451)
+++ branches/fm-branch/R/methods-phylo4.R 2009-08-13 14:48:13 UTC (rev 452)
@@ -15,7 +15,8 @@
### 3.3. edgeOrder()
### 3.4. hasEdgeLength()
### 3.5. edgeLength()
-### 3.6. sumEdgeLength()
+### 3.6. edgeLength() <-
+### 3.7. sumEdgeLength()
### 4. Root accessors
### 4.1. isRooted()
@@ -141,7 +142,7 @@
})
setMethod("hasEdgeLength","phylo4", function(x) {
- length(x at edge.length)>0
+ !all(is.na(x at edge.length))
})
setMethod("edgeLength", "phylo4", function(x, which) {
@@ -157,18 +158,15 @@
}
})
-setReplaceMethod("edgeLength", "phylo4", function(x, which, ..., value) {
- ## TODO: check lengths of x and which, and that value is numerical (do this in
- ## checkTree)
- if(!hasEdgeLength(x))
- ## FIXME: allow user to create edge length this way
- stop("No edges on this tree.")
- else {
- n <- getNode(x, which)
- nmEdge <- sapply(names(x at edge.length), function(foo)
- unlist(strsplit(foo, "-"))[2])
- x at edge.length[match(n, nmEdge)] <- value
+setReplaceMethod("edgeLength", "phylo4", function(x, use.names=TRUE, ..., value) {
+ if(use.names && !is.null(names(value))) {
+ if(!all(names(value) %in% names(x at edge.length)))
+ stop("Names provided don't match internal edge labels")
+ x at edge.length[match(names(value), names(x at edge.length))] <- value
}
+ else
+ x at edge.length[1:nEdges(x)] <- value
+ if(is.character(checkval <- checkPhylo4(x))) stop(checkval)
x
})
@@ -230,7 +228,8 @@
setReplaceMethod("labels",
signature(object="phylo4", value="character"),
- function(object, which = c("tip", "internal", "allnode"), ..., value) {
+ function(object, which = c("tip", "internal", "allnode"),
+ use.names=FALSE, ..., value) {
which <- match.arg(which)
@@ -238,25 +237,40 @@
## If 'tip'
tip = {
object at tip.label <- .createLabels(value, nTips(object),
- nNodes(object),
+ nNodes(object), use.names,
which="tip")
object
},
## If 'internal'
internal = {
object at node.label <- .createLabels(value, nTips(object),
- nNodes(object),
+ nNodes(object), use.names,
which="internal")
object
},
## If 'allnode'
allnode = {
- object at tip.label <- .createLabels(value, nTips(object),
- nNodes(object),
- which="tip")
- object at node.label <- .createLabels(value, nTips(object),
- nNodes(object),
- which="internal")
+ if(use.names) {
+ tipVal <- value[names(value) %in% nodeId(object, "tip")]
+ nodVal <- value[names(value) %in% nodeId(object, "internal")]
+ object at tip.label <- .createLabels(tipVal, nTips(object),
+ nNodes(object), use.names,
+ which="tip")
+ object at node.label <- .createLabels(nodVal, nTips(object),
+ nNodes(object), use.names,
+ which="internal")
+ }
+ else {
+ ntips <- nTips(object)
+ nedges <- nTips(object) + nNodes(object)
+ object at tip.label <- .createLabels(value[1:ntips], nTips(object),
+ nNodes(object), use.names,
+ which="tip")
+ object at node.label <- .createLabels(value[(ntips+1):nedges],
+ nTips(object),
+ nNodes(object), use.names,
+ which="internal")
+ }
object
})
@@ -269,13 +283,7 @@
### Node Labels
setMethod("hasNodeLabels", "phylo4", function(x) {
- if(length(x at node.label) == 0) {
- warning("You are using an old version of a phylo4 object.")
- FALSE
- }
- else {
- !all(is.na(x at node.label))
- }
+ !all(is.na(x at node.label))
})
setMethod("nodeLabels", "phylo4", function(object) {
@@ -312,6 +320,7 @@
setReplaceMethod("edgeLabels", signature(object="phylo4", value="character"),
function(object, ..., value) {
object at edge.label <- value
+ if(is.character(checkval <- checkPhylo4(object))) stop(checkval)
object
})
Modified: branches/fm-branch/R/methods-phylo4d.R
===================================================================
--- branches/fm-branch/R/methods-phylo4d.R 2009-08-01 00:02:21 UTC (rev 451)
+++ branches/fm-branch/R/methods-phylo4d.R 2009-08-13 14:48:13 UTC (rev 452)
@@ -122,22 +122,17 @@
function(object, which = c("tip", "internal", "allnode"), ...,
value) {
which <- match.arg(which)
- if (which == "allnode") {
- namesmatch <- all(colnames(object at tip.data) == colnames(object at node.data))
- classmatch <- all(sapply(object at tip.data, class) == sapply(object at node.data,
- class))
- if (!(classmatch && namesmatch))
- stop("Node and tip columns do not match;",
- "you should access tip and node data separately")
- }
- if(is.matrix(value)) value <- as.data.frame(value)
- if(!is.data.frame(value))
- stop("For now, only data.frame or matrix can be provided")
- switch(which,
- tip = object at tip.data <- value,
- internal = object at node.data <- value,
- allnode = stop("for now, must set tip and node data separately"))
- if(checkData(object, ...)) object <- attachData(object, ...)
+
+ tmpData <- switch(which,
+ tip = .phylo4Data(object, tip.data=value, ...),
+ internal = .phylo4Data(object, node.data=value, ...),
+ allnode = .phylo4Data(object, all.data=value, ...))
+
+ if(all(dim(tmpData$tip.data)))
+ object at tip.data <- tmpData$tip.data
+ if(all(dim(tmpData$node.data)))
+ object at node.data <- tmpData$node.data
+
object
})
@@ -147,21 +142,38 @@
...) {
pos <- match.arg(pos)
+ tmpData <- .phylo4Data(x=x, tip.data=tip.data, node.data=node.data,
+ all.data=all.data, merge.data=merge.data,
+ match.data=match.data, ...)
- tmpData <- .phylo4Data(x, tip.data, node.data, all.data, merge.data,
- match.data=TRUE, ...)
-
if(identical(pos, "before")) {
- if(!all(dim(tmpData$tip.data) == 0))
- x at tip.data <- cbind(tmpData$tip.data, x at tip.data)
- if(!all(dim(tmpData$node.data) == 0))
- x at node.data <- cbind(tmpData$node.data, x at node.data)
+ if(!all(dim(tmpData$tip.data) == 0)) {
+ if(all(dim(x at tip.data) > 0))
+ x at tip.data <- cbind(tmpData$tip.data, x at tip.data)
+ else
+ x at tip.data <- tmpData$tip.data
+ }
+ if(!all(dim(tmpData$node.data) == 0)) {
+ if(all(dim(x at tip.data) > 0))
+ x at node.data <- cbind(tmpData$node.data, x at node.data)
+ else
+ x at node.data <- tmpData$node.data
+ }
}
else {
- if(!all(dim(tmpData$tip.data) == 0))
- x at tip.data <- cbind(x at tip.data, tmpData$tip.data)
- if(!all(dim(tmpData$node.data) == 0))
- x at node.data <- cbind(x at node.data, tmpData$node.data)
+ if(!all(dim(tmpData$tip.data) == 0)) {
+ if(all(dim(x at tip.data) > 0))
+ x at tip.data <- cbind(x at tip.data, tmpData$tip.data)
+ else
+ x at tip.data <- tmpData$tip.data
+ }
+
+ if(!all(dim(tmpData$node.data) == 0)) {
+ if(all(dim(x at node.data) > 0))
+ x at node.data <- cbind(x at node.data, tmpData$node.data)
+ else
+ x at node.data <- tmpData$node.data
+ }
}
x
Modified: branches/fm-branch/R/phylo4.R
===================================================================
--- branches/fm-branch/R/phylo4.R 2009-08-01 00:02:21 UTC (rev 451)
+++ branches/fm-branch/R/phylo4.R 2009-08-13 14:48:13 UTC (rev 452)
@@ -38,6 +38,10 @@
standardGeneric("edgeLength")
})
+setGeneric("edgeLength<-", function(x, ..., value) {
+ standardGeneric("edgeLength<-")
+})
+
setGeneric("sumEdgeLength", function(phy, node) {
standardGeneric("sumEdgeLength")
})
Modified: branches/fm-branch/R/prune.R
===================================================================
--- branches/fm-branch/R/prune.R 2009-08-01 00:02:21 UTC (rev 451)
+++ branches/fm-branch/R/prune.R 2009-08-13 14:48:13 UTC (rev 452)
@@ -12,8 +12,8 @@
})
## setGeneric("drop.tip") ## if ape has already been loaded
-
+
DropTip <- function(phy,tip,...) {
if (length(tip)==0) {
phy
@@ -32,29 +32,49 @@
## trace("prune", browser, signature = "phylo4d")
## untrace("prune", signature = "phylo4d")
-setMethod("prune","phylo4d",
- function(phy, tip, trim.internal = TRUE, subtree = FALSE,
- ...) {
- ## need unique labels to match data correctly
- oldnodelabels <- phy at node.label
- nodetags <- .genlab("N",nNodes(phy))
- phy at node.label <- nodetags
- oldtiplabels <- phy at tip.label
- phytr <- DropTip(phy,tip,trim.internal, subtree)
- ## this DROPS data
- ntr = match(phytr at node.label,nodetags)
- ttr = match(phytr at tip.label,oldtiplabels)
- phytr at node.label <- oldnodelabels[ntr]
- phytr at tip.label <- oldtiplabels[ttr]
- phytr at node.data <- phy at node.data[ntr,,drop=FALSE]
- phytr at tip.data <- phy at tip.data[ttr,,drop=FALSE]
- phytr
- })
+setMethod("prune", "phylo4d", function(phy, tip, trim.internal=TRUE,
+ subtree=FALSE, ...) {
+ tree <- extractTree(phy)
+ phytr <- DropTip(tree, tip, trim.internal, subtree)
-setMethod("prune","phylo",
+ ## create temporary phylo4 object with unique labels
+ tmpLbl <- .genlab("n", nTips(phy)+nNodes(phy))
+ tmpPhy <- tree
+ labels(tmpPhy, "all") <- tmpLbl
+ tmpPhytr <- DropTip(tmpPhy, getNode(phy, tip), trim.internal, subtree)
+
+ ## get node numbers to keep
+ oldLbl <- labels(tmpPhy, "all")
+ newLbl <- labels(tmpPhytr, "all")
+ toKeep <- as.numeric(names(oldLbl[oldLbl %in% newLbl]))
+ tipToKeep <- toKeep[toKeep %in% nodeId(phy, "tip")]
+ nodToKeep <- toKeep[toKeep %in% nodeId(phy, "internal")]
+
+ if(!all(dim(phy at tip.data) == 0)) {
+ tipDt <- phy at tip.data[match(tipToKeep, rownames(phy at tip.data)) ,, drop=FALSE]
+ tipDt <- tipDt[sort(rownames(tipDt)) ,, drop=FALSE]
+ rownames(tipDt) <- 1:nTips(phytr)
+ }
+ else
+ tipDt <- data.frame(NULL)
+
+ if(!all(dim(phy at node.data) == 0)) {
+ nodDt <- phy at node.data[match(nodToKeep, rownames(phy at node.data)) ,, drop=FALSE]
+ nodDt <- nodDt[sort(rownames(nodDt)) ,, drop=FALSE]
+ rownames(nodDt) <- 1:nNodes(phytr)
+ }
+ else
+ nodDt <- data.frame(NULL)
+
+ phytr <- phylo4d(phytr, tip.data=tipDt, node.data=nodDt, match.data=FALSE)
+
+ phytr
+})
+
+setMethod("prune", "phylo",
function(phy, tip, trim.internal = TRUE, subtree = FALSE,
...) {
- DropTip(phy,tip,trim.internal, subtree)
+ DropTip(phy, tip, trim.internal, subtree)
})
## setMethod("prune","ANY",
Modified: branches/fm-branch/R/setAs-Methods.R
===================================================================
--- branches/fm-branch/R/setAs-Methods.R 2009-08-01 00:02:21 UTC (rev 451)
+++ branches/fm-branch/R/setAs-Methods.R 2009-08-13 14:48:13 UTC (rev 452)
@@ -71,16 +71,20 @@
setAs("phylo4", "phylo", function(from, to) {
if (inherits(from, "phylo4d"))
warning("losing data while coercing phylo4d to phylo")
- brlen <- from at edge.length
+ brlen <- unname(from at edge.length)
## rootnode is only node with no ancestor
rootpos <- which(is.na(from at edge[, 1]))
if (isRooted(from)) brlen <- brlen[-rootpos]
+ if(hasNodeLabels(from))
+ nodLbl <- unname(from at node.label)
+ else
+ nodLbl <- character(0)
edgemat <- unname(from at edge[-rootpos, ])
y <- list(edge = edgemat,
Nnode = from at Nnode,
- tip.label = from at tip.label,
+ tip.label = unname(from at tip.label),
edge.length = brlen,
- node.label = from at node.label)
+ node.label = nodLbl)
class(y) <- "phylo"
if (from at order != 'unknown') {
## TODO postorder != pruningwise -- though quite similar
@@ -143,7 +147,6 @@
## The order of 'node' defines the order of all other elements
node <- nodeId(x, "all")
- #node <- sort(node)
ancestr <- ancestor(x, node)
ndType <- nodeType(x)
intNode <- names(ndType[ndType == "internal"])
@@ -152,8 +155,6 @@
E <- data.frame(node, ancestr)
if (hasEdgeLength(x)) {
- ## !! in phylobase, the order is node-ancestors whereas in ape it's
- ## ancestor-node
nmE <- paste(E[,2], E[,1], sep="-")
edge.length <- edgeLength(x)[match(nmE, names(x at edge.length))]
}
Modified: branches/fm-branch/R/treewalk.R
===================================================================
--- branches/fm-branch/R/treewalk.R 2009-08-01 00:02:21 UTC (rev 451)
+++ branches/fm-branch/R/treewalk.R 2009-08-13 14:48:13 UTC (rev 452)
@@ -7,29 +7,45 @@
## x = n-nTips(phy)
## so: n = x+nTips(phy)
-getNode <- function(phy,node,missing=c("warn","OK","fail")) {
- missing <- match.arg(missing)
- if (is.numeric(node) && all(floor(node)==node,na.rm=TRUE)) {
+getNode <- function(phy, node, missing=c("warn","OK","fail")) {
+ missing <- match.arg(missing)
+
+ if (is.numeric(node) && all(floor(node) == node, na.rm=TRUE)) {
node <- as.integer(node)
}
+
if (is.character(node)) {
- rval <- match(node, labels(phy, "allnode"))
- # return NA for any NA_character_ inputs
- rval[is.na(node)] <- NA
- names(rval) <- node
- } else if (is.integer(node)) {
- rval <- match(node, seq_len(nTips(phy) + nNodes(phy)))
- names(rval) <- labels(phy,"allnode")[rval]
- } else stop("node must be integer or character")
- if (any(is.na(rval))) {
- missnodes <- node[is.na(rval)]
- msg <- paste("some nodes missing from tree: ",paste(missnodes,collapse=","))
- switch(missing,
- fail=stop(msg),
- warn=warning(msg),
- OK={})
- }
- return(rval)
+ irval <- match(node, labels(phy, "allnode"))
+
+ }
+ else {
+ if (is.integer(node)) {
+ irval <- match(as.character(node), names(labels(phy, "allnode")))
+ }
+ else stop("Node must be a vector of class \'integer\' or \'character\'.")
+ }
+
+ ## node numbers
+ rval <- names(labels(phy, "allnode"))[irval]
+ rval <- as.integer(rval)
+ rval[is.na(node)] <- NA # return NA for any NA_character_ inputs
+
+ ## node labels
+ nmNd <- labels(phy, "allnode")[irval]
+ names(rval) <- nmNd
+ ## if node doesn't exist put node called as its name
+ names(rval)[is.na(nmNd)] <- node[is.na(nmNd)]
+
+ ## deal with nodes that don't match
+ if (any(is.na(rval))) {
+ missnodes <- node[is.na(rval)]
+ msg <- paste("Some nodes are missing from tree: ", paste(missnodes,collapse=", "))
+ switch(missing,
+ fail=stop(msg),
+ warn=warning(msg),
+ OK={})
+ }
+ return(rval)
}
@@ -132,9 +148,6 @@
} # end MRCA
-
-
-
###############
# shortestPath
###############
@@ -174,27 +187,53 @@
-
-
###########
# getEdge
###########
-getEdge <- function(phy, node){
+getEdge <- function(phy, node, type=c("node", "ancestor", "all"),
+ output=c("otherEnd", "allEdge"),
+ missing=c("warn", "OK", "fail")) {
- ## conversion from phylo, phylo4 and phylo4d
- x <- as(phy, "phylo4")
+ type <- match.arg(type)
+ missing <- match.arg(missing)
+ output <- match.arg(output)
+ res <- character(0)
- ## come checks
- if (is.character(checkval <- checkPhylo4(x))) stop(checkval)
- node <- getNode(x, node)
- if(any(is.na(node))) stop("wrong node specified")
- root <- getNode(x, nTips(x)+1)
- node[node==root] <- NA
+ if(!identical(class(phy), "phylo4")) phy <- as(phy, "phylo4")
- ## main computations
- E <- x at edge
- res <- match(node, E[,2])
- names(res) <- names(node)
+ if(identical(type, "all")) {
+ if(!missing(node))
+ warning("Argument \'node\' is ignored if type=\"all\".")
+ if(!missing(output))
+ warning("Argument \'output\' is ignored if type=\"all\".")
+ res <- names(phy at edge.length)
+ }
+ else {
+ node <- getNode(phy, node, missing)
- return(res)
-} # end getEdge
+ nd <- lapply(node, function(x) {
+ if(is.na(x))
+ res <- NA
+ else {
+ ndTmp <- switch(type,
+ node = paste("-", x, sep=""),
+ ancestor = paste(x, "-", sep=""))
+ res <- grep(ndTmp, names(phy at edge.length), value=TRUE)
+ }
+ })
+ nd <- unlist(nd)
+ if(identical(output, "allEdge"))
+ res <- nd
+ else {
+ nd <- strsplit(nd, "-")
+ res <- switch(type,
+ node = sapply(nd, function(x) x[2]),
+ ancestor = sapply(nd, function(x) x[1]))
+ res <- as.integer(res)
+ }
+ }
+ ## if we return names, then it gets confusing if it's not unique
+ ## for instance for edge 17 in geospiza, the names would be:
+ ## 171 172 173
+ unname(res)
+}
Modified: branches/fm-branch/data/geospiza.rda
===================================================================
(Binary files differ)
Modified: branches/fm-branch/man/as-methods.Rd
===================================================================
--- branches/fm-branch/man/as-methods.Rd 2009-08-01 00:02:21 UTC (rev 451)
+++ branches/fm-branch/man/as-methods.Rd 2009-08-13 14:48:13 UTC (rev 452)
@@ -45,13 +45,8 @@
(\code{phylo}, \code{multiPhylo}) \code{ade4} objects (\code{phylog}), and to \code{data.frame} respresentation.
}
\section{Methods}{
-<<<<<<< .mine
\describe{
- \item{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{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:}
->>>>>>> .r437
\describe{
\item{\code{phylobase} to \code{phylobase} formats:}{
Modified: branches/fm-branch/man/check.phylo4.Rd
===================================================================
--- branches/fm-branch/man/check.phylo4.Rd 2009-08-01 00:02:21 UTC (rev 451)
+++ branches/fm-branch/man/check.phylo4.Rd 2009-08-13 14:48:13 UTC (rev 452)
@@ -24,7 +24,7 @@
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_4Dec2006.pdf}.
+ http://ape.mpl.ird.fr/misc/FormatTreeR_4Dec2006.pdf.
These are essentially that:
\itemize{
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/phylobase -r 452
More information about the Phylobase-commits
mailing list