[Phylobase-commits] r852 - in pkg: R src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Feb 13 17:19:32 CET 2014
Author: francois
Date: 2014-02-13 17:19:32 +0100 (Thu, 13 Feb 2014)
New Revision: 852
Modified:
pkg/R/RcppExports.R
pkg/R/checkdata.R
pkg/R/methods-phylo4.R
pkg/src/RcppExports.cpp
pkg/src/checkPhylo4.cpp
Log:
updates to checkPhylo4Cpp (removed unncessary functions), fixed case of non-rooted tree for node generation, fixed test for NA edge lengths, fixed edge length must be a named vector (even if empty), fixed omission of test on valid ordering.
Modified: pkg/R/RcppExports.R
===================================================================
--- pkg/R/RcppExports.R 2014-02-13 16:14:54 UTC (rev 851)
+++ pkg/R/RcppExports.R 2014-02-13 16:19:32 UTC (rev 852)
@@ -41,22 +41,14 @@
.Call('phylobase_getAllNodesSafe', PACKAGE = 'phylobase', edge)
}
-getAllNodesFast <- function(edge) {
- .Call('phylobase_getAllNodesFast', PACKAGE = 'phylobase', edge)
+getAllNodesFast <- function(edge, rooted) {
+ .Call('phylobase_getAllNodesFast', PACKAGE = 'phylobase', edge, rooted)
}
-testNodes <- function(edge) {
- .Call('phylobase_testNodes', PACKAGE = 'phylobase', edge)
-}
-
testEqInt <- function(x, y) {
.Call('phylobase_testEqInt', PACKAGE = 'phylobase', x, y)
}
-getInternalNodes <- function(edge) {
- .Call('phylobase_getInternalNodes', PACKAGE = 'phylobase', edge)
-}
-
all_naC <- function(x) {
.Call('phylobase_all_naC', PACKAGE = 'phylobase', x)
}
Modified: pkg/R/checkdata.R
===================================================================
--- pkg/R/checkdata.R 2014-02-13 16:14:54 UTC (rev 851)
+++ pkg/R/checkdata.R 2014-02-13 16:19:32 UTC (rev 852)
@@ -51,9 +51,20 @@
err <- c(err, "The edge.label slot needs to be a named vector.")
attributes(object at edge.label) <- list(names=character(0))
}
-
+
res <- checkTreeCpp(object, opts=opt)
+ if (hasEdgeLength(object) && any(is.na(edgeLength(object)))) {
+ naElen <- names(which(is.na(object at edge.length)))
+ if (! identical(naElen, edgeId(object, "root")))
+ err <- c(err, "Only the root can have NA as edge length. ")
+ }
+
+ if (!object at order %in% phylo4_orderings) {
+ err <- c(err, paste("unknown order: allowed values are",
+ paste(phylo4_orderings,collapse=",")))
+ }
+
err <- ifelse(nzchar(res[[1]]), c(err, res[[1]]), err)
wrn <- ifelse(nzchar(res[[2]]), c(wrn, res[[2]]), wrn)
Modified: pkg/R/methods-phylo4.R
===================================================================
--- pkg/R/methods-phylo4.R 2014-02-13 16:14:54 UTC (rev 851)
+++ pkg/R/methods-phylo4.R 2014-02-13 16:19:32 UTC (rev 852)
@@ -226,7 +226,9 @@
len <- .createEdge(value, x at edge, type="lengths", use.names)
## return empty vector if all values are NA
if (all(is.na(len))) {
- x at edge.length <- numeric()
+ emptyVec <- numeric()
+ attributes(emptyVec) <- list(names=character(0))
+ x at edge.length <- emptyVec
} else {
x at edge.length <- len
}
Modified: pkg/src/RcppExports.cpp
===================================================================
--- pkg/src/RcppExports.cpp 2014-02-13 16:14:54 UTC (rev 851)
+++ pkg/src/RcppExports.cpp 2014-02-13 16:19:32 UTC (rev 852)
@@ -158,35 +158,21 @@
END_RCPP
}
// getAllNodesFast
-Rcpp::IntegerVector getAllNodesFast(Rcpp::IntegerMatrix edge);
-RcppExport SEXP phylobase_getAllNodesFast(SEXP edgeSEXP) {
+Rcpp::IntegerVector getAllNodesFast(Rcpp::IntegerMatrix edge, bool rooted);
+RcppExport SEXP phylobase_getAllNodesFast(SEXP edgeSEXP, SEXP rootedSEXP) {
BEGIN_RCPP
SEXP __sexp_result;
{
Rcpp::RNGScope __rngScope;
Rcpp::traits::input_parameter< Rcpp::IntegerMatrix >::type edge(edgeSEXP );
- Rcpp::IntegerVector __result = getAllNodesFast(edge);
+ Rcpp::traits::input_parameter< bool >::type rooted(rootedSEXP );
+ Rcpp::IntegerVector __result = getAllNodesFast(edge, rooted);
PROTECT(__sexp_result = Rcpp::wrap(__result));
}
UNPROTECT(1);
return __sexp_result;
END_RCPP
}
-// testNodes
-Rcpp::List testNodes(Rcpp::IntegerMatrix edge);
-RcppExport SEXP phylobase_testNodes(SEXP edgeSEXP) {
-BEGIN_RCPP
- SEXP __sexp_result;
- {
- Rcpp::RNGScope __rngScope;
- Rcpp::traits::input_parameter< Rcpp::IntegerMatrix >::type edge(edgeSEXP );
- Rcpp::List __result = testNodes(edge);
- PROTECT(__sexp_result = Rcpp::wrap(__result));
- }
- UNPROTECT(1);
- return __sexp_result;
-END_RCPP
-}
// testEqInt
Rcpp::List testEqInt(Rcpp::IntegerVector x, Rcpp::IntegerVector y);
RcppExport SEXP phylobase_testEqInt(SEXP xSEXP, SEXP ySEXP) {
@@ -203,21 +189,6 @@
return __sexp_result;
END_RCPP
}
-// getInternalNodes
-Rcpp::IntegerVector getInternalNodes(Rcpp::IntegerMatrix edge);
-RcppExport SEXP phylobase_getInternalNodes(SEXP edgeSEXP) {
-BEGIN_RCPP
- SEXP __sexp_result;
- {
- Rcpp::RNGScope __rngScope;
- Rcpp::traits::input_parameter< Rcpp::IntegerMatrix >::type edge(edgeSEXP );
- Rcpp::IntegerVector __result = getInternalNodes(edge);
- PROTECT(__sexp_result = Rcpp::wrap(__result));
- }
- UNPROTECT(1);
- return __sexp_result;
-END_RCPP
-}
// all_naC
bool all_naC(Rcpp::NumericVector x);
RcppExport SEXP phylobase_all_naC(SEXP xSEXP) {
Modified: pkg/src/checkPhylo4.cpp
===================================================================
--- pkg/src/checkPhylo4.cpp 2014-02-13 16:14:54 UTC (rev 851)
+++ pkg/src/checkPhylo4.cpp 2014-02-13 16:19:32 UTC (rev 852)
@@ -128,24 +128,30 @@
}
//[[Rcpp::export]]
-Rcpp::IntegerVector getAllNodesFast (Rcpp::IntegerMatrix edge) {
+Rcpp::IntegerVector getAllNodesFast (Rcpp::IntegerMatrix edge, bool rooted) {
Rcpp::IntegerVector tmp = Rcpp::as_vector(edge);
Rcpp::IntegerVector maxN = Rcpp::range(tmp);
Rcpp::IntegerVector ans = Rcpp::seq_len(maxN[1] + 1);
- return ans - 1;
+ if (rooted) {
+ return ans - 1;
+ }
+ else {
+ ans.erase(0);
+ return ans - 1;
+ }
}
-//[[Rcpp::export]]
-Rcpp::List testNodes (Rcpp::IntegerMatrix edge) {
- Rcpp::IntegerVector allNodes = Rcpp::as_vector(edge);
- allNodes = Rcpp::unique(allNodes);
- std::sort (allNodes.begin(), allNodes.end());
- Rcpp::IntegerVector supposedNodes = getAllNodesFast(edge);
- Rcpp::IntegerVector test = Rcpp::setdiff(supposedNodes, allNodes);
- Rcpp::LogicalVector res = supposedNodes == allNodes;
- return Rcpp::List::create(supposedNodes, allNodes, test, res);
-}
+// Rcpp::List testNodes (Rcpp::IntegerMatrix edge, bool rooted) {
+// Rcpp::IntegerVector allNodes = Rcpp::as_vector(edge);
+// allNodes = Rcpp::unique(allNodes);
+// std::sort (allNodes.begin(), allNodes.end());
+// Rcpp::IntegerVector supposedNodes = getAllNodesFast(edge, rooted);
+// Rcpp::IntegerVector test = Rcpp::setdiff(supposedNodes, allNodes);
+// Rcpp::LogicalVector res = supposedNodes == allNodes;
+// return Rcpp::List::create(supposedNodes, allNodes, test, res);
+// }
+
//[[Rcpp::export]]
Rcpp::List testEqInt (Rcpp::IntegerVector x, Rcpp::IntegerVector y) {
Rcpp::LogicalVector xy = x == y;
@@ -153,18 +159,16 @@
return Rcpp::List::create(xy, yx);
}
+// Rcpp::IntegerVector getInternalNodes (Rcpp::IntegerMatrix edge, bool rooted) {
+// Rcpp::IntegerVector ances = getAnces(edge);
+// Rcpp::IntegerVector allNodes = getAllNodesFast(edge, rooted);
+// Rcpp::IntegerVector tips = tipsFast(ances);
+// Rcpp::IntegerVector intNodes = Rcpp::setdiff(allNodes, tips);
+// intNodes.erase(intNodes.begin());
+// return intNodes;
+// }
//[[Rcpp::export]]
-Rcpp::IntegerVector getInternalNodes (Rcpp::IntegerMatrix edge) {
- Rcpp::IntegerVector ances = getAnces(edge);
- Rcpp::IntegerVector allNodes = getAllNodesFast(edge);
- Rcpp::IntegerVector tips = tipsFast(ances);
- Rcpp::IntegerVector intNodes = Rcpp::setdiff(allNodes, tips);
- intNodes.erase(intNodes.begin());
- return intNodes;
-}
-
-//[[Rcpp::export]]
bool all_naC (Rcpp::NumericVector x) {
return is_true(all(is_na(x)));
}
@@ -266,6 +270,8 @@
int nrow = ed.nrow();
Rcpp::IntegerVector ances = getAnces(ed);
//Rcpp::IntegerVector desc = getDesc(ed);
+ int nroots = nRoots(ances);
+ bool rooted = nroots > 0;
Rcpp::NumericVector edLength = obj.slot("edge.length");
Rcpp::CharacterVector edLengthNm = edLength.names();
Rcpp::CharacterVector label = obj.slot("label");
@@ -273,13 +279,12 @@
Rcpp::CharacterVector edLabel = obj.slot("edge.label");
Rcpp::CharacterVector edLabelNm = edLabel.names();
Rcpp::IntegerVector allnodesSafe = getAllNodesSafe(ed);
- Rcpp::IntegerVector allnodesFast = getAllNodesFast(ed);
+ Rcpp::IntegerVector allnodesFast = getAllNodesFast(ed, rooted);
int nEdLength = edLength.size();
int nLabel = label.size();
int nEdLabel = edLabel.size();
int nEdges = nrow;
bool hasEdgeLength = !all_naC(edLength);
- int nroots = nRoots(ances);
// check tips
int ntipsSafe = nTipsSafe(ances);
@@ -297,13 +302,13 @@
}
// check edge lengths
- if (hasEdgeLength) {
+ if (hasEdgeLength) {
if (nEdLength != nEdges) {
err.append("Number of edge lengths do not match number of edges. ");
}
- if (nb_naC(edLength) > (nroots + 1)) {
- err.append("Only the root should have NA as an edge length. ");
- }
+ // if (nb_naC(edLength) > nroots) { // not enough! -- best done in R
+ // err.append("Only the root should have NA as an edge length. ");
+ // }
if (getRange(edLength, TRUE)[0] < 0) {
err.append("Edge lengths must be non-negative. ");
}
More information about the Phylobase-commits
mailing list