[Phylobase-commits] r723 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Jan 26 16:54:30 CET 2010
Author: francois
Date: 2010-01-26 16:54:29 +0100 (Tue, 26 Jan 2010)
New Revision: 723
Modified:
pkg/R/checkdata.R
pkg/R/formatData.R
pkg/R/methods-phylo4.R
pkg/R/prune.R
pkg/R/treewalk.R
Log:
reverting working copies of files committed inadvertently
Modified: pkg/R/checkdata.R
===================================================================
--- pkg/R/checkdata.R 2010-01-26 15:28:06 UTC (rev 722)
+++ pkg/R/checkdata.R 2010-01-26 15:54:29 UTC (rev 723)
@@ -84,7 +84,7 @@
if (is.null(names(object at label))) {
stop(c("Tip and node labels must have names matching node IDs. ",
lab.msg))
-
+
} else {
if (!all(tips %in% names(na.omit(object at label)))) {
stop(c("All tips must have associated tip labels. ",
@@ -123,11 +123,11 @@
}
## make sure that tip and node labels are unique
- #lb <- labels(object, "all")
- #lb <- lb[nchar(lb) > 0]
- #lb <- na.omit(lb)
- #if(any(table(lb) > 1))
- # stop("All labels must be unique")
+ lb <- labels(object, "all")
+ lb <- lb[nchar(lb) > 0]
+ lb <- na.omit(lb)
+ if(any(table(lb) > 1))
+ stop("All labels must be unique")
## all done with fatal errors. Now construct a list
## of warnings and paste them together
Modified: pkg/R/formatData.R
===================================================================
--- pkg/R/formatData.R 2010-01-26 15:28:06 UTC (rev 722)
+++ pkg/R/formatData.R 2010-01-26 15:54:29 UTC (rev 723)
@@ -31,72 +31,30 @@
if (any(dim(dt)==0)) {
return(data.frame(row.names=ids.out))
}
-
+
label.type <- match.arg(label.type)
- ## TODO -- needs testing
- if (label.type == "column") {
- if (is.numeric(label.column))
- stopifnot(label.column %in% 1:ncol(dt))
- else
- stopifnot(label.column %in% names(dt))
- }
-
+ stopifnot(label.column %in% 1:ncol(dt))
missing.data <- match.arg(missing.data)
extra.data <- match.arg(extra.data)
if(match.data) {
-
-
## extract values to be matched to nodes
ndNames <- switch(label.type,
rownames = rownames(dt),
column = dt[,label.column])
- ## Deal with duplicated labels
- if (any(duplicated(labels(phy, type)))) {
- tmpDt <- getNode(phy, ndNames)
-
- }
-
- ## check whether labels are unique
- ##if (any(duplicated(labels(phy, type)))) {
- ## if (allowDuplicateLabels) {
- ## lb <- as(phy, "data.frame")[nodeId(phy, type), 1:2]
- ## if (label.type == "rownames") {
- ## dt <- data.frame(lbl=rownames(dt), dt)
- ## label.column <- 1 # just to be safe
- ## label.type <- "column"
- ## }
- ## dt <- merge(x=lb, y=dt, by.x=1, by.y=label.column)
- ## dt <- dt[,-1]
- ## ndNames <- dt$node
- ## }
- ## else stop("All labels must be unique")
- ##}
## either force matching on labels, or match on node
## numbers for any number-like elements and labels otherwise
if (rownamesAsLabels) {
ids.in <- getNode(phy, as.character(ndNames), missing="OK")
+ } else {
+ ids.in <- as.numeric(rep(NA, length(ndNames)))
+ treatAsNumber <- nchar(gsub("[0-9]", "", ndNames))==0
+ ids.in[treatAsNumber] <- getNode(phy,
+ as.integer(ndNames[treatAsNumber]), missing="OK")
+ ids.in[!treatAsNumber] <- getNode(phy,
+ as.character(ndNames[!treatAsNumber]), missing="OK")
}
- else {
- ids.in <- lapply(ndNames, function(ndnm) {
- if (nchar(gsub("[0-9]", "", ndnm)) == 0) {
- getNode(phy, as.integer(ndnm), missing="OK")
- }
- else {
- getNode(phy, as.character(ndnm), missing="OK")
- }
- })
- ids.in <- unlist(ids.in)
- #ids.in <- as.numeric(rep(NA, length(ndNames)))
- #treatAsNumber <- nchar(gsub("[0-9]", "", ndNames))==0
- #ids.in[treatAsNumber] <- getNode(phy,
- # as.integer(ndNames[treatAsNumber]), missing="OK")
- #ids.in[!treatAsNumber] <- getNode(phy,
- # as.character(ndNames[!treatAsNumber]), missing="OK")
- browser()
- }
-
## Make sure that data are matched to appropriate nodes
if (type=="tip" && any(na.omit(ids.in) %in% nodeId(phy,
"internal"))) {
@@ -132,9 +90,6 @@
fail = stop(msg))
}
## Format data to have correct dimensions
- ## TODO -- here build empty dataframe to match in case
- ## of duplicates.
- browser()
dt <- dt[!is.na(ids.in), , drop=FALSE]
rownames(dt) <- ids.in[!is.na(ids.in)]
dt.out <- dt[match(ids.out, rownames(dt)), , drop=FALSE]
@@ -142,6 +97,7 @@
if(label.type == "column") dt.out <- dt.out[, -label.column, drop=FALSE]
} else {
+
## Check if too many or not enough rows in input data
expected.nrow <- length(nodeId(phy, type))
diffNr <- nrow(dt) - expected.nrow
Modified: pkg/R/methods-phylo4.R
===================================================================
--- pkg/R/methods-phylo4.R 2010-01-26 15:28:06 UTC (rev 722)
+++ pkg/R/methods-phylo4.R 2010-01-26 15:54:29 UTC (rev 723)
@@ -507,7 +507,6 @@
orderIndex <- function(x, order=c("preorder", "postorder")) {
- browser()
order <- match.arg(order)
if(!isRooted(x)){
stop("Tree must be rooted to reorder")
@@ -597,7 +596,7 @@
order <- match.arg(order)
index <- orderIndex(x, order)
x at order <- order
- x at edge <- edges(x)[index, ]
+ x at edge <- x at edge[index, ]
if(hasEdgeLabels(x)) {
x at edge.label <- x at edge.label[index]
}
Modified: pkg/R/prune.R
===================================================================
--- pkg/R/prune.R 2010-01-26 15:28:06 UTC (rev 722)
+++ pkg/R/prune.R 2010-01-26 15:54:29 UTC (rev 723)
@@ -26,7 +26,6 @@
if (edgeOrder(x) == "postorder") {
edge.post <- edges(x)
} else {
- browser()
edge.post <- edges(reorder(x, "postorder"))
}
for (i in seq_along(edge.post[,2])) {
@@ -60,7 +59,6 @@
edge.length.new <- edge.length.new[-match(edge.names.drop,
names(edge.length.new))]
edge.label.new[edge.name.new] <- NA
- browser()
edge.label.new <- edge.label.new[-match(edge.names.drop,
names(edge.label.new))]
Modified: pkg/R/treewalk.R
===================================================================
--- pkg/R/treewalk.R 2010-01-26 15:28:06 UTC (rev 722)
+++ pkg/R/treewalk.R 2010-01-26 15:54:29 UTC (rev 723)
@@ -20,10 +20,7 @@
## match node to tree
if (is.character(node)) {
- ndTmp <- paste("^", node, "$", sep="")
- irval <- lapply(ndTmp, function(ND) grep(ND, labels(x, type)))
- irval <- unlist(irval)
- ##irval <- match(node, labels(x, type))
+ irval <- match(node, labels(x, type))
} else if (is.numeric(node) && all(floor(node) == node, na.rm=TRUE)) {
irval <- match(as.character(node), names(labels(x, type)))
} else {
@@ -296,7 +293,7 @@
## hack to return NA for tip nodes when type='ancestor'
if(length(res)==0) res <- NA
names(res) <- rep(nid, length(res))
- }
+ }
names(res) <- rep(nid, length(res))
res
})
More information about the Phylobase-commits
mailing list