[Phylobase-commits] r660 - in branches/slot-mods: R data inst/unitTests man tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Sep 23 06:59:03 CEST 2009
Author: regetz
Date: 2009-09-23 06:59:02 +0200 (Wed, 23 Sep 2009)
New Revision: 660
Modified:
branches/slot-mods/R/checkdata.R
branches/slot-mods/R/class-phylo4.R
branches/slot-mods/R/formatData.R
branches/slot-mods/R/methods-phylo4.R
branches/slot-mods/R/prune.R
branches/slot-mods/R/setAs-Methods.R
branches/slot-mods/R/subset.R
branches/slot-mods/data/geospiza.rda
branches/slot-mods/inst/unitTests/runit.class-phylo4d.R
branches/slot-mods/inst/unitTests/runit.labelsReplaceMethod.R
branches/slot-mods/inst/unitTests/runit.methods-phylo4.R
branches/slot-mods/inst/unitTests/runit.methods-phylo4d.R
branches/slot-mods/inst/unitTests/runit.setAs-Methods.R
branches/slot-mods/inst/unitTests/runit.subset.R
branches/slot-mods/man/phylo4-class.Rd
branches/slot-mods/man/phylo4d-class.Rd
branches/slot-mods/tests/phylotorture.R
branches/slot-mods/tests/phylotorture.Rout.save
branches/slot-mods/tests/testprune.Rout.save
Log:
Replaced separate tip.label and node.label slots with a unified label
slot in the phylo4 class definition. Updated label and label<- methods,
and fixed other methods, functions, and tests that specifically depended
on the old slot configuration.
Modified: branches/slot-mods/R/checkdata.R
===================================================================
--- branches/slot-mods/R/checkdata.R 2009-09-23 00:33:01 UTC (rev 659)
+++ branches/slot-mods/R/checkdata.R 2009-09-23 04:59:02 UTC (rev 660)
@@ -16,8 +16,7 @@
## case of empty phylo4 object
if(nrow(object at edge) == 0 && length(object at edge.length) == 0 &&
- length(object at node.label) == 0 &&
- length(object at tip.label) == 0 && length(object at edge.label) == 0)
+ length(object at label) == 0 && length(object at edge.label) == 0)
return(TRUE)
## FIXME: check for cyclicity?
@@ -27,7 +26,7 @@
if (length(object at edge.length) != nedges)
return("edge lengths do not match number of edges")
if(!is.numeric(object at edge.length))
- stop("Edge lengths are not numeric.")
+ return("edge lengths are not numeric")
## presumably we shouldn't allow NAs mixed
## with numeric branch lengths except at the root
if (sum(is.na(object at edge.length)) > 1)
@@ -41,8 +40,6 @@
## return("number of tip labels not consistent with number of edges and nodes")
## check: tip numbers = (m+1):(m+n)
ntips <- nTips(object)
- if(length(object at tip.label) != ntips)
- return("number of tip labels not consistent with number of tips")
E <- edges(object)
tips <- unique(sort(E[,2][!E[,2] %in% E[,1]]))
nodes <- unique(sort(c(E)))
@@ -81,49 +78,33 @@
paste(phylo4_orderings,collapse=","))
}
- ## make sure that nodes and edges have internal names
- ## and that they match the nodes
- if (is.null(names(object at tip.label))) {
- if(length(object at tip.label) == nTips(object)) {
- stop("There is no internal name associated with your tips. Use the ",
- "function tipLabels <- to change your tip labels.")
+ ## make sure tip/node labels have internal names that match node IDs
+ lab.msg <- "Use tipLabels<- (and nodeLabels<- if needed) to update them."
+ if (is.null(names(object at label))) {
+ return(c("Tip and node labels must have names matching node IDs. ",
+ lab.msg))
+
+ } else {
+ if (!all(tips %in% names(na.omit(object at label)))) {
+ return(c("All tips must have associated tip labels. ",
+ lab.msg))
}
- else
- stop("Your object doesn't have internal node names and the number of ",
- "tip labels doesn't match the number tips.")
- }
- else {
- if(!all(names(object at tip.label) %in% nodeId(object, "tip")))
- stop("Internal names for tips don't match tip ID numbers")
- }
-
- if (is.null(names(object at node.label))) {
- if(length(object at node.label) == nNodes(object)) {
- stop("There is no internal names associated with internal ",
- "nodes. Use the function nodeLabels <- to create or ",
- "change your internal node labels.")
+ if (!all(names(object at label) %in% nodeId(object, "all"))) {
+ return(c("One or more tip/node label has an unmatched ID name ",
+ lab.msg))
}
- else
- stop("Your object doesn't have internal node names and the number of ",
- "node labels doesn't match the number nodes.")
}
- else {
- if(!all(names(object at node.label) %in% nodeId(object, "internal")))
- stop("Internal names for tips don't match tip ID numbers")
- }
+ ## make sure edge lengths have internal names that match the edges
+ elen.msg <- "Use edgeLength<- to update them."
if(hasEdgeLength(object)) {
- if(is.null(names(object at edge.length))) {
- warning("Your edges don't have internal names. Use the function ",
- "edgeLength <- to update the the branch lengths of your ",
- "tree.")
+ if (is.null(names(object at edge.length))) {
+ return(c("Edge lengths must have names matching edge IDs. ",
+ elen.msg))
}
- else {
- tEdgLbl <- paste(object at edge[,1], object at edge[,2], sep="-")
- if(!all(names(object at edge.length) %in% tEdgLbl))
- stop("There is something wrong with your internal edge length ",
- "labels. Use the function edgeLength <- to update the the ",
- "branch lengths of your tree.")
+ if (!all(names(object at edge.length) %in% edgeId(object, "all"))) {
+ return(c("One or more edge lengths has an unmatched ID name. ",
+ elen.msg))
}
}
Modified: branches/slot-mods/R/class-phylo4.R
===================================================================
--- branches/slot-mods/R/class-phylo4.R 2009-09-23 00:33:01 UTC (rev 659)
+++ branches/slot-mods/R/class-phylo4.R 2009-09-23 04:59:02 UTC (rev 660)
@@ -1,8 +1,7 @@
setClass("phylo4",
representation(edge = "matrix",
edge.length = "numeric",
- node.label = "character",
- tip.label = "character",
+ label = "character",
edge.label = "character",
order = "character",
annote = "list"),
@@ -10,8 +9,7 @@
edge = matrix(nrow = 0, ncol = 2,
dimname = list(NULL, c("ancestor", "descendant"))),
edge.length = numeric(0),
- tip.label = character(0),
- node.label = character(0),
+ label = character(0),
edge.label = character(0),
order = "unknown",
annote = list()
@@ -138,8 +136,7 @@
res <- new("phylo4")
res at edge <- edge
res at edge.length <- edge.length
- res at tip.label <- tip.label
- res at node.label <- node.label
+ res at label <- c(tip.label, node.label)
res at edge.label <- edge.label
res at order <- order
res at annote <- annote
Modified: branches/slot-mods/R/formatData.R
===================================================================
--- branches/slot-mods/R/formatData.R 2009-09-23 00:33:01 UTC (rev 659)
+++ branches/slot-mods/R/formatData.R 2009-09-23 04:59:02 UTC (rev 660)
@@ -31,7 +31,9 @@
else getNode(phy, nd, missing="OK")
})
ndDt <- unlist(ndDt)
-
+# ndDt <- ifelse(nchar(gsub("[0-9]", "", ndNames))==0,
+# getNode(phy, as.integer(ndNames), missing="OK"),
+# getNode(phy, ndNames, missing="OK"))
## Make sure that data are matched to appropriate nodes
if(type != "all") {
switch(type,
Modified: branches/slot-mods/R/methods-phylo4.R
===================================================================
--- branches/slot-mods/R/methods-phylo4.R 2009-09-23 00:33:01 UTC (rev 659)
+++ branches/slot-mods/R/methods-phylo4.R 2009-09-23 04:59:02 UTC (rev 660)
@@ -198,7 +198,7 @@
setReplaceMethod("edgeLength", signature(x="phylo4"),
function(x, use.names=TRUE, ..., value) {
if(use.names && !is.null(names(value))) {
- if(!all(names(value) %in% names(edgeLength(x))))
+ if(!all(names(value) %in% edgeId(x, "all")))
stop("Names provided don't match internal edge labels")
x at edge.length[match(names(value), names(x at edge.length))] <- value
}
@@ -253,19 +253,12 @@
type <- match.arg(type)
## [JR: below, using match for ordering rather than direct character
## indexing b/c the latter is slow for vectors of a certain size]
- lbl <- switch(type,
- all={
- all <- c(object at tip.label, object at node.label)
- all[match(nodeId(object, "all"), names(all))]
- },
- tip={
- tip <- object at tip.label
- tip[match(nodeId(object, "tip"), names(tip))]
- },
- internal={
- int <- object at node.label
- int[match(nodeId(object, "internal"), names(int))]
- })
+ label <- object at label
+ id <- nodeId(object, type)
+ lbl <- label[match(id, names(label))]
+ # reassign names b/c any unmatched will be NA (could instead assign
+ # names only to the unmatched ones, but this seems simpler)
+ names(lbl) <- id
return(lbl)
})
@@ -277,65 +270,37 @@
## Default options
if(missing(type))
- type <- "tip"
+ type <- "all"
if (missing(use.names))
use.names <- FALSE
type <- match.arg(type)
+ ## generate new labels of the desired type
+ new.label <- .createLabels(value, nTips(x), nNodes(x), use.names,
+ type=type)
- ob <- switch(type,
- ## If 'tip'
- tip = {
- x at tip.label <- .createLabels(value, nTips(x),
- nNodes(x), use.names,
- type="tip")
- x
- },
- ## If 'internal'
- internal = {
- x at node.label <- .createLabels(value, nTips(x),
- nNodes(x), use.names,
- type="internal")
- x
- },
- ## If 'allnode'
- allnode = {
- if(use.names) {
- tipVal <- value[names(value) %in% nodeId(x, "tip")]
- nodVal <- value[names(value) %in% nodeId(x, "internal")]
- x at tip.label <- .createLabels(tipVal, nTips(x),
- nNodes(x), use.names,
- type="tip")
- x at node.label <- .createLabels(nodVal, nTips(x),
- nNodes(x), use.names,
- type="internal")
- }
- else {
- ntips <- nTips(x)
- nedges <- nTips(x) + nNodes(x)
- x at tip.label <- .createLabels(value[1:ntips], nTips(x),
- nNodes(x), use.names,
- type="tip")
- x at node.label <- .createLabels(value[(ntips+1):nedges],
- nTips(x),
- nNodes(x), use.names,
- type="internal")
- }
- x
- })
+ ## replace existing labels and add new ones as needed
+ old.label <- x at label
+ old.index <- match(names(new.label), names(old.label))
+ isNew <- is.na(old.index)
+ old.label[old.index[!isNew]] <- new.label[!isNew]
+ updated.label <- c(old.label, new.label[isNew])
- if(is.character(checkval <- checkPhylo4(ob)))
+ ## for efficiency, drop any NA labels
+ x at label <- updated.label[!is.na(updated.label)]
+
+ if(is.character(checkval <- checkPhylo4(x)))
stop(checkval)
else
- return(ob)
+ return(x)
})
### Node Labels
setMethod("hasNodeLabels", signature(x="phylo4"),
function(x) {
- !all(is.na(x at node.label))
+ !all(is.na(nodeLabels(x)))
})
setMethod("nodeLabels", signature(x="phylo4"),
Modified: branches/slot-mods/R/prune.R
===================================================================
--- branches/slot-mods/R/prune.R 2009-09-23 00:33:01 UTC (rev 659)
+++ branches/slot-mods/R/prune.R 2009-09-23 04:59:02 UTC (rev 660)
@@ -65,9 +65,8 @@
singletons <- which(tabulate(na.omit(edge.new[,1]))==1)
}
- ## remove dropped elements from tip.label and node.label
- tip.label.new <- tipLabels(x)[names(tipLabels(x)) %in% edge.new]
- node.label.new <- nodeLabels(x)[names(nodeLabels(x)) %in% edge.new]
+ ## 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)
@@ -79,16 +78,14 @@
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(node.label.new))
+ 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(node.label.new)[ind] <- newid
+ names(label.new)[ind] <- newid
edge.new[match(tip.add, edge.new)] <- newid
tip.now[match(tip.add, tip.now)] <- newid
- tip.label.new <- c(tip.label.new, node.label.new[ind])
- node.label.new <- node.label.new[-ind]
isTip <- edge.new %in% tip.now
edge.new[isTip] <- match(edge.new[isTip],
sort(unique.default(edge.new[isTip])))
@@ -102,16 +99,21 @@
edge.names <- makeEdgeNames(edge.new)
names(edge.length.new) <- edge.names
names(edge.label.new) <- edge.names
- tip.label.new <- tip.label.new[order(as.numeric(names(tip.label.new)))]
- names(tip.label.new) <- seq_along(tip.label.new)
- names(node.label.new) <- seq_along(node.label.new) + length(tip.label.new)
+ label.new <- label.new[order(as.numeric(names(label.new)))]
+ names(label.new) <- seq_along(label.new)
- ## create and return new phylo4 object
- ## NOTE: a faster but looser approach would be to replace the slots
- ## of x with their new values and return x
- phylo4(x=edge.new, edge.length = edge.length.new, tip.label =
- tip.label.new, node.label = node.label.new, edge.label =
- edge.label.new, annote=x at annote)
+ ## 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")
Modified: branches/slot-mods/R/setAs-Methods.R
===================================================================
--- branches/slot-mods/R/setAs-Methods.R 2009-09-23 00:33:01 UTC (rev 659)
+++ branches/slot-mods/R/setAs-Methods.R 2009-09-23 04:59:02 UTC (rev 660)
@@ -144,14 +144,16 @@
## 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 = from at edge, edge.length = from at edge.length,
-## Nnode = nNodes(from), tip.label = from at tip.label)
+## y <- list(edge = edges(from, drop.root=TRUE),
+## Nnode = nNodes(from), tip.label = tipLabels(from))
## class(y) <- "phylo"
-## if (length(y$edge.length) == 0)
-## y$edge.length <- NULL
-## if (length(y$node.label) == 0)
-## y$node.label <- NULL
+## 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")
Modified: branches/slot-mods/R/subset.R
===================================================================
--- branches/slot-mods/R/subset.R 2009-09-23 00:33:01 UTC (rev 659)
+++ branches/slot-mods/R/subset.R 2009-09-23 04:59:02 UTC (rev 660)
@@ -49,7 +49,7 @@
dropped <- setdiff(all.tips, kept)
unknown <- numeric(0)
} else {
- kept <- x at tip.label
+ kept <- getNode(x, nodeId(x, "tip"))
dropped <- numeric(0)
unknown <- numeric(0)
}
Modified: branches/slot-mods/data/geospiza.rda
===================================================================
(Binary files differ)
Modified: branches/slot-mods/inst/unitTests/runit.class-phylo4d.R
===================================================================
--- branches/slot-mods/inst/unitTests/runit.class-phylo4d.R 2009-09-23 00:33:01 UTC (rev 659)
+++ branches/slot-mods/inst/unitTests/runit.class-phylo4d.R 2009-09-23 04:59:02 UTC (rev 660)
@@ -24,8 +24,7 @@
# create altered version such that each slot is out of order with
# respect to all others; methods should be able to handle this
phy.alt <- phy
-phy.alt at tip.label <- rev(phy at tip.label)
-phy.alt at node.label <- rev(phy at node.label)
+phy.alt at label <- rev(phy at label)
phy.alt at edge <- phy at edge[c(6:9, 1:5), ]
phy.alt at edge.length <- phy at edge.length[c(7:9, 1:6)]
phy.alt at edge.label <- phy at edge.label[c(8:9, 1:7)]
Modified: branches/slot-mods/inst/unitTests/runit.labelsReplaceMethod.R
===================================================================
--- branches/slot-mods/inst/unitTests/runit.labelsReplaceMethod.R 2009-09-23 00:33:01 UTC (rev 659)
+++ branches/slot-mods/inst/unitTests/runit.labelsReplaceMethod.R 2009-09-23 04:59:02 UTC (rev 660)
@@ -12,53 +12,53 @@
## case all options by default and unnamed vector
p4c <- p4
- labels(p4c) <- tLbl
+ tipLabels(p4c) <- tLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4c at tip.label) %in% nodeId(p4c, "tip")))
+ checkTrue(all(names(tipLabels(p4c)) %in% nodeId(p4c, "tip")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(unname(p4c at tip.label), tLbl)
+ checkEquals(unname(tipLabels(p4c)), tLbl)
## case all options by default and named vector
p4c <- p4
- labels(p4c) <- nmTLbl
+ tipLabels(p4c) <- nmTLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4c at tip.label) %in% nodeId(p4c, "tip")))
+ checkTrue(all(names(tipLabels(p4c)) %in% nodeId(p4c, "tip")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(unname(p4c at tip.label), unname(nmTLbl))
+ checkEquals(unname(tipLabels(p4c)), unname(nmTLbl))
## case type defined
p4c <- p4
- labels(p4c, "tip") <- tLbl
+ tipLabels(p4c) <- tLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4c at tip.label) %in% nodeId(p4c, "tip")))
+ checkTrue(all(names(tipLabels(p4c)) %in% nodeId(p4c, "tip")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(unname(p4c at tip.label), tLbl)
+ checkEquals(unname(tipLabels(p4c)), tLbl)
## case type defined and use.names=TRUE but no names
p4c <- p4
- labels(p4c, "tip", use.names=TRUE) <- tLbl
+ tipLabels(p4c, use.names=TRUE) <- tLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4c at tip.label) %in% nodeId(p4c, "tip")))
+ checkTrue(all(names(tipLabels(p4c)) %in% nodeId(p4c, "tip")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(unname(p4c at tip.label), tLbl)
+ checkEquals(unname(tipLabels(p4c)), tLbl)
## case type defined and use.names=TRUE with names
p4c <- p4
- labels(p4c, "tip", use.names=TRUE) <- nmTLbl
+ tipLabels(p4c, use.names=TRUE) <- nmTLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4c at tip.label) %in% nodeId(p4c, "tip")))
+ checkTrue(all(names(tipLabels(p4c)) %in% nodeId(p4c, "tip")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(p4c at tip.label, nmTLbl[order(as.numeric(names(nmTLbl)))])
+ checkEquals(tipLabels(p4c), nmTLbl[order(as.numeric(names(nmTLbl)))])
}
test.labelsNodePhylo4 <- function() {
@@ -72,33 +72,33 @@
## case type defined
p4c <- p4
- labels(p4c, "internal") <- ndLbl
+ nodeLabels(p4c) <- ndLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4c at node.label) %in% nodeId(p4c, "internal")))
+ checkTrue(all(names(nodeLabels(p4c)) %in% nodeId(p4c, "all")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(unname(p4c at node.label), ndLbl)
+ checkEquals(unname(nodeLabels(p4c)), ndLbl)
## case type defined and use.names=TRUE but no names
p4c <- p4
- labels(p4c, "internal", use.names=TRUE) <- ndLbl
+ nodeLabels(p4c, use.names=TRUE) <- ndLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4c at node.label) %in% nodeId(p4c, "internal")))
+ checkTrue(all(names(nodeLabels(p4c)) %in% nodeId(p4c, "all")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(unname(p4c at node.label), ndLbl)
+ checkEquals(unname(nodeLabels(p4c)), ndLbl)
## case type defined and use.names=TRUE with names
p4c <- p4
- labels(p4c, "internal", use.names=TRUE) <- nmNdLbl
+ nodeLabels(p4c, use.names=TRUE) <- nmNdLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4c at node.label) %in% nodeId(p4c, "internal")))
+ checkTrue(all(names(nodeLabels(p4c)) %in% nodeId(p4c, "all")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(p4c at node.label, nmNdLbl[order(as.numeric(names(nmNdLbl)))])
+ checkEquals(nodeLabels(p4c), nmNdLbl[order(as.numeric(names(nmNdLbl)))])
}
@@ -111,53 +111,53 @@
## case all options by default and unnamed vector
p4dc <- p4d
- labels(p4dc) <- tLbl
+ tipLabels(p4dc) <- tLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4dc at tip.label) %in% nodeId(p4dc, "tip")))
+ checkTrue(all(names(tipLabels(p4dc)) %in% nodeId(p4dc, "tip")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(unname(p4dc at tip.label), tLbl)
+ checkEquals(unname(tipLabels(p4dc)), tLbl)
## case all options by default and named vector
p4dc <- p4d
- labels(p4dc) <- nmTLbl
+ tipLabels(p4dc) <- nmTLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4dc at tip.label) %in% nodeId(p4dc, "tip")))
+ checkTrue(all(names(tipLabels(p4dc)) %in% nodeId(p4dc, "tip")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(unname(p4dc at tip.label), unname(nmTLbl))
+ checkEquals(unname(tipLabels(p4dc)), unname(nmTLbl))
## case type defined
p4dc <- p4d
- labels(p4dc, "tip") <- tLbl
+ tipLabels(p4dc) <- tLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4dc at tip.label) %in% nodeId(p4dc, "tip")))
+ checkTrue(all(names(tipLabels(p4dc)) %in% nodeId(p4dc, "tip")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(unname(p4dc at tip.label), tLbl)
+ checkEquals(unname(tipLabels(p4dc)), tLbl)
## case type defined and use.names=TRUE but no names
p4dc <- p4d
- labels(p4dc, "tip", use.names=TRUE) <- tLbl
+ tipLabels(p4dc, use.names=TRUE) <- tLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4dc at tip.label) %in% nodeId(p4dc, "tip")))
+ checkTrue(all(names(tipLabels(p4dc)) %in% nodeId(p4dc, "tip")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(unname(p4dc at tip.label), tLbl)
+ checkEquals(unname(tipLabels(p4dc)), tLbl)
## case type defined and use.names=TRUE with names
p4dc <- p4d
- labels(p4dc, "tip", use.names=TRUE) <- nmTLbl
+ tipLabels(p4dc, use.names=TRUE) <- nmTLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4dc at tip.label) %in% nodeId(p4dc, "tip")))
+ checkTrue(all(names(tipLabels(p4dc)) %in% nodeId(p4dc, "tip")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(p4dc at tip.label, nmTLbl[order(as.numeric(names(nmTLbl)))])
+ checkEquals(tipLabels(p4dc), nmTLbl[order(as.numeric(names(nmTLbl)))])
}
test.labelsNodePhylo4d <- function() {
@@ -171,33 +171,33 @@
## case type defined
p4dc <- p4d
- labels(p4dc, "internal") <- ndLbl
+ nodeLabels(p4dc) <- ndLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4dc at node.label) %in% nodeId(p4dc, "internal")))
+ checkTrue(all(names(nodeLabels(p4dc)) %in% nodeId(p4dc, "internal")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(unname(p4dc at node.label), ndLbl)
+ checkEquals(unname(nodeLabels(p4dc)), ndLbl)
## case type defined and use.names=TRUE but no names
p4dc <- p4d
- labels(p4dc, "internal", use.names=TRUE) <- ndLbl
+ nodeLabels(p4dc, use.names=TRUE) <- ndLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4dc at node.label) %in% nodeId(p4dc, "internal")))
+ checkTrue(all(names(nodeLabels(p4dc)) %in% nodeId(p4dc, "internal")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(unname(p4dc at node.label), ndLbl)
+ checkEquals(unname(nodeLabels(p4dc)), ndLbl)
## case type defined and use.names=TRUE with names
p4dc <- p4d
- labels(p4dc, "internal", use.names=TRUE) <- nmNdLbl
+ nodeLabels(p4dc, use.names=TRUE) <- nmNdLbl
## check the internal names are there and match tips
- checkTrue(all(names(p4dc at node.label) %in% nodeId(p4dc, "internal")))
+ checkTrue(all(names(nodeLabels(p4dc)) %in% nodeId(p4dc, "internal")))
## check that the labels are correct: here use.names=FALSE
## so the order should be the same as in the shuffled vector
## of name labels
- checkEquals(p4dc at node.label, nmNdLbl[order(as.numeric(names(nmNdLbl)))])
+ checkEquals(nodeLabels(p4dc), nmNdLbl[order(as.numeric(names(nmNdLbl)))])
}
@@ -212,28 +212,19 @@
p4c <- p4
labels(p4c, "all") <- allLbl
- checkTrue(all(names(p4c at tip.label) %in% nodeId(p4c, "tip")))
- checkTrue(all(names(p4c at node.label) %in% nodeId(p4c, "internal")))
- checkEquals(unname(p4c at tip.label), allLbl[1:nTips(p4)])
- checkEquals(unname(p4c at node.label),
- allLbl[(nTips(p4)+1):(nTips(p4)+nNodes(p4))])
+ checkTrue(all(names(labels(p4c)) %in% nodeId(p4c, "all")))
+ checkEquals(unname(labels(p4c)), allLbl)
p4c <- p4
labels(p4c, "all") <- nmAllLbl
- checkTrue(all(names(p4c at tip.label) %in% nodeId(p4c, "tip")))
- checkTrue(all(names(p4c at node.label) %in% nodeId(p4c, "internal")))
- checkEquals(unname(p4c at tip.label), unname(nmAllLbl[1:nTips(p4)]))
- checkEquals(unname(p4c at node.label),
- unname(nmAllLbl[(nTips(p4)+1):(nTips(p4)+nNodes(p4))]))
+ checkTrue(all(names(labels(p4c)) %in% nodeId(p4c, "all")))
+ checkEquals(unname(labels(p4c)), unname(nmAllLbl))
-
p4c <- p4
tmpNm <- nmAllLbl[order(as.numeric(names(nmAllLbl)))]
labels(p4c, "all", use.names=TRUE) <- nmAllLbl
- checkTrue(all(names(p4c at tip.label) %in% nodeId(p4c, "tip")))
- checkTrue(all(names(p4c at node.label) %in% nodeId(p4c, "internal")))
- checkEquals(p4c at tip.label, tmpNm[names(tmpNm) %in% nodeId(p4c, "tip")])
- checkEquals(p4c at node.label, tmpNm[names(tmpNm) %in% nodeId(p4c, "internal")])
+ checkTrue(all(names(labels(p4c)) %in% nodeId(p4c, "all")))
+ checkEquals(labels(p4c), tmpNm[names(tmpNm) %in% nodeId(p4c, "all")])
}
test.labelsAllPhylo4d <- function() {
@@ -247,26 +238,18 @@
p4dc <- p4d
labels(p4dc, "all") <- allLbl
- checkTrue(all(names(p4dc at tip.label) %in% nodeId(p4dc, "tip")))
- checkTrue(all(names(p4dc at node.label) %in% nodeId(p4dc, "internal")))
- checkEquals(unname(p4dc at tip.label), allLbl[1:nTips(p4d)])
- checkEquals(unname(p4dc at node.label),
- allLbl[(nTips(p4d)+1):(nTips(p4d)+nNodes(p4d))])
+ checkTrue(all(names(labels(p4dc)) %in% nodeId(p4dc, "all")))
+ checkEquals(unname(labels(p4dc)), allLbl)
p4dc <- p4d
labels(p4dc, "all") <- nmAllLbl
- checkTrue(all(names(p4dc at tip.label) %in% nodeId(p4dc, "tip")))
- checkTrue(all(names(p4dc at node.label) %in% nodeId(p4dc, "internal")))
- checkEquals(unname(p4dc at tip.label), unname(nmAllLbl[1:nTips(p4d)]))
- checkEquals(unname(p4dc at node.label),
- unname(nmAllLbl[(nTips(p4d)+1):(nTips(p4d)+nNodes(p4d))]))
+ checkTrue(all(names(labels(p4dc)) %in% nodeId(p4dc, "all")))
+ checkEquals(unname(labels(p4dc)), unname(nmAllLbl))
p4dc <- p4d
tmpNm <- nmAllLbl[order(as.numeric(names(nmAllLbl)))]
labels(p4dc, "all", use.names=TRUE) <- nmAllLbl
- checkTrue(all(names(p4dc at tip.label) %in% nodeId(p4dc, "tip")))
- checkTrue(all(names(p4dc at node.label) %in% nodeId(p4dc, "internal")))
- checkEquals(p4dc at tip.label, tmpNm[names(tmpNm) %in% nodeId(p4dc, "tip")])
- checkEquals(p4dc at node.label, tmpNm[names(tmpNm) %in% nodeId(p4dc, "internal")])
+ checkTrue(all(names(labels(p4dc)) %in% nodeId(p4dc, "all")))
+ checkEquals(labels(p4dc), tmpNm[names(tmpNm) %in% nodeId(p4dc, "all")])
}
Modified: branches/slot-mods/inst/unitTests/runit.methods-phylo4.R
===================================================================
--- branches/slot-mods/inst/unitTests/runit.methods-phylo4.R 2009-09-23 00:33:01 UTC (rev 659)
+++ branches/slot-mods/inst/unitTests/runit.methods-phylo4.R 2009-09-23 04:59:02 UTC (rev 660)
@@ -22,8 +22,7 @@
# create altered version such that each slot is out of order with
# respect to all others; methods should be able to handle this
phy.alt <- phy
-phy.alt at tip.label <- rev(phy at tip.label)
-phy.alt at node.label <- rev(phy at node.label)
+phy.alt at label <- rev(phy at label)
phy.alt at edge <- phy at edge[c(6:9, 1:5), ]
phy.alt at edge.length <- phy at edge.length[c(7:9, 1:6)]
phy.alt at edge.label <- phy at edge.label[c(8:9, 1:7)]
@@ -142,16 +141,16 @@
#TODO function(object, type = c("tip", "internal", "allnode"), use.names, ..., value)
}
+test.nodeLabels.phylo4 <- function() {
+ checkIdentical(nodeLabels(phy.alt), setNames(lab.int, nid.int))
+}
+
test.hasNodeLabels.phylo4 <- function() {
checkTrue(hasNodeLabels(phy.alt))
- phy.alt at node.label <- NA_character_
+ nodeLabels(phy.alt) <- NA_character_
checkTrue(!hasNodeLabels(phy.alt))
}
-test.nodeLabels.phylo4 <- function() {
- checkIdentical(nodeLabels(phy.alt), setNames(lab.int, nid.int))
-}
-
test.Replace.nodeLabels.phylo4 <- function() {
#TODO function(object, ..., value) {
}
Modified: branches/slot-mods/inst/unitTests/runit.methods-phylo4d.R
===================================================================
--- branches/slot-mods/inst/unitTests/runit.methods-phylo4d.R 2009-09-23 00:33:01 UTC (rev 659)
+++ branches/slot-mods/inst/unitTests/runit.methods-phylo4d.R 2009-09-23 04:59:02 UTC (rev 660)
@@ -30,8 +30,7 @@
# create altered version such that each slot is out of order with
# respect to all others; methods should be able to handle this
phyd.alt <- phyd
-phyd.alt at tip.label <- rev(phyd at tip.label)
-phyd.alt at node.label <- rev(phyd at node.label)
+phyd.alt at label <- rev(phyd at label)
phyd.alt at edge <- phyd at edge[c(6:9, 1:5), ]
phyd.alt at edge.length <- phyd at edge.length[c(7:9, 1:6)]
phyd.alt at edge.label <- phyd at edge.label[c(8:9, 1:7)]
Modified: branches/slot-mods/inst/unitTests/runit.setAs-Methods.R
===================================================================
--- branches/slot-mods/inst/unitTests/runit.setAs-Methods.R 2009-09-23 00:33:01 UTC (rev 659)
+++ branches/slot-mods/inst/unitTests/runit.setAs-Methods.R 2009-09-23 04:59:02 UTC (rev 660)
@@ -22,8 +22,7 @@
# create altered version such that each slot is out of order with
# respect to all others; methods should be able to handle this
phy.alt <- phy
-phy.alt at tip.label <- rev(phy at tip.label)
-phy.alt at node.label <- rev(phy at node.label)
+phy.alt at label <- rev(phy at label)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/phylobase -r 660
More information about the Phylobase-commits
mailing list