[Phylobase-commits] r848 - in pkg: . R src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Feb 12 20:40:48 CET 2014
Author: francois
Date: 2014-02-12 20:40:48 +0100 (Wed, 12 Feb 2014)
New Revision: 848
Added:
pkg/R/RcppExports.R
pkg/src/RcppExports.cpp
pkg/src/checkPhylo4.cpp
pkg/src/symbols.rds
Modified:
pkg/DESCRIPTION
pkg/R/checkdata.R
pkg/R/class-phylo4.R
pkg/R/methods-phylo4.R
Log:
convert checkdata to C++ to make it faster.
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2014-02-12 19:38:27 UTC (rev 847)
+++ pkg/DESCRIPTION 2014-02-12 19:40:48 UTC (rev 848)
@@ -1,13 +1,13 @@
Package: phylobase
Type: Package
Title: Base package for phylogenetic structures and comparative data
-Version: 0.6.5.2
-Date: 2013-04-29
+Version: 0.6.6
+Date: 2014-02-11
Depends:
methods,
grid,
ape(>= 2.1),
- Rcpp (>= 0.10.0)
+ Rcpp (>= 0.11.0)
Imports: ade4
LinkingTo: Rcpp
Suggests:
@@ -22,6 +22,7 @@
one or more trees and trait data
License: GPL (>= 2)
Collate:
+ 'RcppExports.R'
'phylo4.R'
'checkdata.R'
'formatData.R'
Added: pkg/R/RcppExports.R
===================================================================
--- pkg/R/RcppExports.R (rev 0)
+++ pkg/R/RcppExports.R 2014-02-12 19:40:48 UTC (rev 848)
@@ -0,0 +1,87 @@
+# This file was generated by Rcpp::compileAttributes
+# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
+
+isLabelName <- function(lblToCheck, lbl) {
+ .Call('phylobase_isLabelName', PACKAGE = 'phylobase', lblToCheck, lbl)
+}
+
+nRoots <- function(ances) {
+ .Call('phylobase_nRoots', PACKAGE = 'phylobase', ances)
+}
+
+tabulateTips <- function(ances) {
+ .Call('phylobase_tabulateTips', PACKAGE = 'phylobase', ances)
+}
+
+nTipsSafe <- function(ances) {
+ .Call('phylobase_nTipsSafe', PACKAGE = 'phylobase', ances)
+}
+
+nTipsFastCpp <- function(ances) {
+ .Call('phylobase_nTipsFastCpp', PACKAGE = 'phylobase', ances)
+}
+
+hasSingleton <- function(ances) {
+ .Call('phylobase_hasSingleton', PACKAGE = 'phylobase', ances)
+}
+
+hasPolytomy <- function(ances) {
+ .Call('phylobase_hasPolytomy', PACKAGE = 'phylobase', ances)
+}
+
+tipsSafe <- function(ances, desc) {
+ .Call('phylobase_tipsSafe', PACKAGE = 'phylobase', ances, desc)
+}
+
+tipsFast <- function(ances) {
+ .Call('phylobase_tipsFast', PACKAGE = 'phylobase', ances)
+}
+
+getAllNodesSafe <- function(edge) {
+ .Call('phylobase_getAllNodesSafe', PACKAGE = 'phylobase', edge)
+}
+
+getAllNodesFast <- function(edge) {
+ .Call('phylobase_getAllNodesFast', PACKAGE = 'phylobase', edge)
+}
+
+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)
+}
+
+any_naC <- function(x) {
+ .Call('phylobase_any_naC', PACKAGE = 'phylobase', x)
+}
+
+nb_naC <- function(x) {
+ .Call('phylobase_nb_naC', PACKAGE = 'phylobase', x)
+}
+
+getRange <- function(x, na_rm) {
+ .Call('phylobase_getRange', PACKAGE = 'phylobase', x, na_rm)
+}
+
+hasDuplicatedLabelsCpp <- function(label) {
+ .Call('phylobase_hasDuplicatedLabelsCpp', PACKAGE = 'phylobase', label)
+}
+
+edgeIdCpp <- function(edge, type) {
+ .Call('phylobase_edgeIdCpp', PACKAGE = 'phylobase', edge, type)
+}
+
+checkTreeCpp <- function(obj, opts) {
+ .Call('phylobase_checkTreeCpp', PACKAGE = 'phylobase', obj, opts)
+}
+
Modified: pkg/R/checkdata.R
===================================================================
--- pkg/R/checkdata.R 2014-02-12 19:38:27 UTC (rev 847)
+++ pkg/R/checkdata.R 2014-02-12 19:40:48 UTC (rev 848)
@@ -10,7 +10,69 @@
}
checkTree <- function(object) {
+
+ ## case of empty phylo4 object
+ if(nrow(object at edge) == 0 && length(object at edge.length) == 0 &&
+ length(object at label) == 0 && length(object at edge.label) == 0)
+ return(TRUE)
+ ## get options
+ opt <- phylobase.options()
+
+ ## Storage of error/warning messages
+ err <- wrn <- character(0)
+
+ ## Matrix is integer
+ if (!is.integer(object at edge)) {
+ err <- c(err, "Edge matrix needs to be integer.")
+ }
+
+ ## Matrix doesn't have NAs
+ if (any(is.na(object at edge))) {
+ err <- c(err, "Edge matrix cannot have NAs at this time.",
+ "This could only happen if singletons were allowed",
+ "but this is not supported by phylobase yet.")
+ }
+
+ ## Having non-integer or NAs cause cryptic messages, so stop here
+ ## if it's the case
+ if (length(err)) return(err)
+
+ ## Named slots
+ if (is.null(attributes(object at label)$names)) {
+ err <- c(err, "The label slot needs to be a named vector.")
+ attributes(object at label) <- list(names=character(0))
+ }
+ if (is.null(attributes(object at edge.length)$names)) {
+ err <- c(err, "The edge.length slot needs to be a named vector.")
+ attributes(object at edge.length) <- list(names=character(0))
+ }
+ if (is.null(attributes(object at edge.label)$names)) {
+ 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)
+
+ err <- ifelse(nzchar(res[[1]]), c(err, res[[1]]), err)
+ wrn <- ifelse(nzchar(res[[2]]), c(wrn, res[[2]]), wrn)
+
+ if (!is.na(wrn)) {
+ wrn <- paste(wrn, collapse=", ")
+ warning(wrn)
+ }
+ if (!is.na(err)) {
+ err <- paste(err, collapse=", ")
+ return(err) #failures are returned as text
+ }
+ else {
+ return(TRUE)
+ }
+
+}
+
+checkTreeOld <- function(object) {
+
## case of empty phylo4 object
if(nrow(object at edge) == 0 && length(object at edge.length) == 0 &&
length(object at label) == 0 && length(object at edge.label) == 0)
@@ -29,18 +91,17 @@
tips <- unique(sort(E[,2][!E[,2] %in% E[,1]]))
nodes <- unique(sort(c(E)))
intnodes <- nodes[!nodes %in% tips]
- roots <- E[which(is.na(E[,1])),2]
- nRoots <- length(roots)
+ nRoots <- length(which(E[,1] == 0))
## Check edge lengths
if (hasEdgeLength(object)) {
if (length(object at edge.length) != nedges)
err <- c(err, "edge lengths do not match number of edges")
- if(!is.numeric(object at edge.length))
- err <- c(err, "edge lengths are not numeric")
+ ##if(!is.numeric(object at edge.length)) # not needed
+ ## err <- c(err, "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)
+ if (sum(is.na(object at edge.length)) > (nRoots + 1))
err <- c(err, "NAs in edge lengths")
## Strip root edge branch length (if set to NA)
if (any(object at edge.length[!is.na(object at edge.length)] < 0))
Modified: pkg/R/class-phylo4.R
===================================================================
--- pkg/R/class-phylo4.R 2014-02-12 19:38:27 UTC (rev 847)
+++ pkg/R/class-phylo4.R 2014-02-12 19:40:48 UTC (rev 848)
@@ -109,7 +109,7 @@
## edge
edge <- x
mode(edge) <- "integer"
- #if(any(is.na(edge))) stop("NA are not allowed in edge matrix")
+ #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.")
@@ -125,9 +125,12 @@
ntips <- nTips(res)
nnodes <- nNodes(res)
- ## edge.length (drop elements if all are NA)
+ ## 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()
+ 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)
Modified: pkg/R/methods-phylo4.R
===================================================================
--- pkg/R/methods-phylo4.R 2014-02-12 19:38:27 UTC (rev 847)
+++ pkg/R/methods-phylo4.R 2014-02-12 19:40:48 UTC (rev 848)
@@ -63,13 +63,10 @@
if(nrow(E) == 0)
return(0)
else {
- ## doesn't handle reticulated networks
- ## res <- sum(!E[, 2] %in% E[, 1])
- res <- sum(tabulate(na.omit(E[,1])) == 0) ## twice as fast as ...
- ## change suggested by Aaron Mackey, handles reticulated networks better
- ## res <- sum(!(unique(E[,2]) %in% E[,1]))
- return(res)
- }
+ ## at this time NAs are not allowed in edge matrix
+ ## sum(tabulate(E[, 1]) == 0)
+ nTipsFastCpp(E[, 1])
+ }
})
## hack to ensure ape compatibility
@@ -388,7 +385,7 @@
setReplaceMethod("edgeLabels", signature(x="phylo4", value="character"),
function(x, ..., value) {
- lbl <- .createEdge(value, x at edge, type="labels")
+ lbl <- .createEdge(value, x at edge, type="labels")
x at edge.label <- lbl[!is.na(lbl)]
if(is.character(checkval <- checkPhylo4(x))) stop(checkval)
x
Added: pkg/src/RcppExports.cpp
===================================================================
--- pkg/src/RcppExports.cpp (rev 0)
+++ pkg/src/RcppExports.cpp 2014-02-12 19:40:48 UTC (rev 848)
@@ -0,0 +1,328 @@
+// This file was generated by Rcpp::compileAttributes
+// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
+
+#include <Rcpp.h>
+
+using namespace Rcpp;
+
+// isLabelName
+bool isLabelName(Rcpp::CharacterVector lblToCheck, Rcpp::CharacterVector lbl);
+RcppExport SEXP phylobase_isLabelName(SEXP lblToCheckSEXP, SEXP lblSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::CharacterVector >::type lblToCheck(lblToCheckSEXP );
+ Rcpp::traits::input_parameter< Rcpp::CharacterVector >::type lbl(lblSEXP );
+ bool __result = isLabelName(lblToCheck, lbl);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// nRoots
+int nRoots(Rcpp::IntegerVector ances);
+RcppExport SEXP phylobase_nRoots(SEXP ancesSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP );
+ int __result = nRoots(ances);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// tabulateTips
+std::vector<int> tabulateTips(Rcpp::IntegerVector ances);
+RcppExport SEXP phylobase_tabulateTips(SEXP ancesSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP );
+ std::vector<int> __result = tabulateTips(ances);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// nTipsSafe
+int nTipsSafe(Rcpp::IntegerVector ances);
+RcppExport SEXP phylobase_nTipsSafe(SEXP ancesSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP );
+ int __result = nTipsSafe(ances);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// nTipsFastCpp
+int nTipsFastCpp(Rcpp::IntegerVector ances);
+RcppExport SEXP phylobase_nTipsFastCpp(SEXP ancesSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP );
+ int __result = nTipsFastCpp(ances);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// hasSingleton
+bool hasSingleton(Rcpp::IntegerVector ances);
+RcppExport SEXP phylobase_hasSingleton(SEXP ancesSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP );
+ bool __result = hasSingleton(ances);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// hasPolytomy
+bool hasPolytomy(Rcpp::IntegerVector ances);
+RcppExport SEXP phylobase_hasPolytomy(SEXP ancesSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP );
+ bool __result = hasPolytomy(ances);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// tipsSafe
+Rcpp::IntegerVector tipsSafe(Rcpp::IntegerVector ances, Rcpp::IntegerVector desc);
+RcppExport SEXP phylobase_tipsSafe(SEXP ancesSEXP, SEXP descSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP );
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type desc(descSEXP );
+ Rcpp::IntegerVector __result = tipsSafe(ances, desc);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// tipsFast
+Rcpp::IntegerVector tipsFast(Rcpp::IntegerVector ances);
+RcppExport SEXP phylobase_tipsFast(SEXP ancesSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type ances(ancesSEXP );
+ Rcpp::IntegerVector __result = tipsFast(ances);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// getAllNodesSafe
+Rcpp::IntegerVector getAllNodesSafe(Rcpp::IntegerMatrix edge);
+RcppExport SEXP phylobase_getAllNodesSafe(SEXP edgeSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::IntegerMatrix >::type edge(edgeSEXP );
+ Rcpp::IntegerVector __result = getAllNodesSafe(edge);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// getAllNodesFast
+Rcpp::IntegerVector getAllNodesFast(Rcpp::IntegerMatrix edge);
+RcppExport SEXP phylobase_getAllNodesFast(SEXP edgeSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::IntegerMatrix >::type edge(edgeSEXP );
+ Rcpp::IntegerVector __result = getAllNodesFast(edge);
+ 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) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type x(xSEXP );
+ Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type y(ySEXP );
+ Rcpp::List __result = testEqInt(x, y);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ 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) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::NumericVector >::type x(xSEXP );
+ bool __result = all_naC(x);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// any_naC
+bool any_naC(Rcpp::NumericVector x);
+RcppExport SEXP phylobase_any_naC(SEXP xSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::NumericVector >::type x(xSEXP );
+ bool __result = any_naC(x);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// nb_naC
+int nb_naC(Rcpp::NumericVector x);
+RcppExport SEXP phylobase_nb_naC(SEXP xSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::NumericVector >::type x(xSEXP );
+ int __result = nb_naC(x);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// getRange
+Rcpp::NumericVector getRange(Rcpp::NumericVector x, const bool na_rm);
+RcppExport SEXP phylobase_getRange(SEXP xSEXP, SEXP na_rmSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::NumericVector >::type x(xSEXP );
+ Rcpp::traits::input_parameter< const bool >::type na_rm(na_rmSEXP );
+ Rcpp::NumericVector __result = getRange(x, na_rm);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// hasDuplicatedLabelsCpp
+bool hasDuplicatedLabelsCpp(Rcpp::CharacterVector label);
+RcppExport SEXP phylobase_hasDuplicatedLabelsCpp(SEXP labelSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::CharacterVector >::type label(labelSEXP );
+ bool __result = hasDuplicatedLabelsCpp(label);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// edgeIdCpp
+Rcpp::CharacterVector edgeIdCpp(Rcpp::IntegerMatrix edge, std::string type);
+RcppExport SEXP phylobase_edgeIdCpp(SEXP edgeSEXP, SEXP typeSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::IntegerMatrix >::type edge(edgeSEXP );
+ Rcpp::traits::input_parameter< std::string >::type type(typeSEXP );
+ Rcpp::CharacterVector __result = edgeIdCpp(edge, type);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
+// checkTreeCpp
+Rcpp::List checkTreeCpp(Rcpp::S4 obj, Rcpp::List opts);
+RcppExport SEXP phylobase_checkTreeCpp(SEXP objSEXP, SEXP optsSEXP) {
+BEGIN_RCPP
+ SEXP __sexp_result;
+ {
+ Rcpp::RNGScope __rngScope;
+ Rcpp::traits::input_parameter< Rcpp::S4 >::type obj(objSEXP );
+ Rcpp::traits::input_parameter< Rcpp::List >::type opts(optsSEXP );
+ Rcpp::List __result = checkTreeCpp(obj, opts);
+ PROTECT(__sexp_result = Rcpp::wrap(__result));
+ }
+ UNPROTECT(1);
+ return __sexp_result;
+END_RCPP
+}
Added: pkg/src/checkPhylo4.cpp
===================================================================
--- pkg/src/checkPhylo4.cpp (rev 0)
+++ pkg/src/checkPhylo4.cpp 2014-02-12 19:40:48 UTC (rev 848)
@@ -0,0 +1,393 @@
+
+#include <Rcpp.h>
+#include <iostream> // std::cout
+#include <algorithm> // std::count_if
+#include <vector> // std::vector
+#include <string> //
+#include <sstream>
+
+template <typename T>
+std::string NumberToString ( T Number ) {
+ std::ostringstream ss;
+ ss << Number;
+ return ss.str();
+}
+
+bool isZero(int i) { return (i == 0); }
+bool isOne(int i) { return ( i == 1); }
+bool isSupTwo(int i) { return (i > 2); }
+bool isEqual(int i, int j) { return (i == j); }
+
+Rcpp::IntegerVector getAnces(Rcpp::IntegerMatrix obj) {
+// returns the first column (ancestors) of the edge matrix
+ Rcpp::IntegerMatrix::Column out = obj( Rcpp::_ , 0);
+ return out;
+}
+
+Rcpp::IntegerVector getDesc(Rcpp::IntegerMatrix obj) {
+// returns the second column (descendants) of the edge matrix
+ Rcpp::IntegerMatrix::Column out = obj( Rcpp::_ , 1);
+ return out;
+}
+
+//[[Rcpp::export]]
+bool isLabelName(Rcpp::CharacterVector lblToCheck,
+ Rcpp::CharacterVector lbl ) {
+
+ Rcpp::CharacterVector noLbl = Rcpp::setdiff(lblToCheck, lbl);
+ return noLbl.size() == 0;
+}
+
+//[[Rcpp::export]]
+int nRoots (Rcpp::IntegerVector ances) {
+ int ans = std::count (ances.begin(), ances.end(), 0);
+ return ans;
+}
+
+//[[Rcpp::export]]
+std::vector<int> tabulateTips (Rcpp::IntegerVector ances) {
+// tabulates ancestor nodes that are not the root.
+ int n = ances.size();
+ std::vector<int> ans(n);
+ for (Rcpp::IntegerVector::iterator it = ances.begin(); it != ances.end(); ++it) {
+ if (*it > 0) ans[*it - 1]++;
+ }
+ return ans;
+}
+
+//[[Rcpp::export]]
+int nTipsSafe (Rcpp::IntegerVector ances) {
+// count how many zeros are in the tabulated vector of ancestors
+// this gives the number of tips
+ std::vector<int> tabTips = tabulateTips(ances);
+ int j = count_if (tabTips.begin(), tabTips.end(), isZero);
+ return j;
+}
+
+//[[Rcpp::export]]
+int nTipsFastCpp (Rcpp::IntegerVector ances) {
+// if nodes are correctly numbered min(ances) - 1 = nb of tips
+// (after removing the root, which is equal to 0).
+ int nroots = nRoots(ances);
+ if (nroots > 0) {
+ int whichRoot = Rcpp::which_min(ances);
+ ances.erase(whichRoot);
+ }
+ int tmp = Rcpp::min(ances);
+ return tmp - 1;
+}
+
+//[[Rcpp::export]]
+bool hasSingleton (Rcpp::IntegerVector ances) {
+ std::vector<int> tabTips = tabulateTips(ances);
+ int j = count_if (tabTips.begin(), tabTips.end(), isOne);
+ return j > 0;
+}
+
+//[[Rcpp::export]]
+bool hasPolytomy (Rcpp::IntegerVector ances) {
+ std::vector<int> tabTips = tabulateTips(ances);
+ int j = count_if (tabTips.begin(), tabTips.end(), isSupTwo);
+ return j > 0;
+}
+
+
+//[[Rcpp::export]]
+Rcpp::IntegerVector tipsSafe (Rcpp::IntegerVector ances, Rcpp::IntegerVector desc) {
+ Rcpp::IntegerVector res = Rcpp::match(desc, ances);
+ Rcpp::LogicalVector istip = Rcpp::is_na(res);
+ int nedge = ances.size();
+ std::vector<int> y(nedge);
+ int j = 0;
+ for(int i = 0; i < nedge; i++) {
+ if (istip[i]) {
+ y[j] = desc[i];
+ j++;
+ }
+ }
+ Rcpp::IntegerVector ans(j);
+ std::copy (y.begin(), y.begin()+j, ans.begin());
+ std::sort (ans.begin(), ans.end());
+ return ans;
+}
+
+//[[Rcpp::export]]
+Rcpp::IntegerVector tipsFast (Rcpp::IntegerVector ances) {
+ int ntips = nTipsFastCpp(ances);
+ Rcpp::IntegerVector ans = Rcpp::seq_len(ntips);
+ return ans;
+}
+
+
+//[[Rcpp::export]]
+Rcpp::IntegerVector getAllNodesSafe (Rcpp::IntegerMatrix edge) {
+ Rcpp::IntegerVector ans = Rcpp::as_vector(edge);
+ Rcpp::IntegerVector tmp = Rcpp::unique(ans);
+ std::sort(tmp.begin(), tmp.end());
+ return tmp;
+}
+
+//[[Rcpp::export]]
+Rcpp::IntegerVector getAllNodesFast (Rcpp::IntegerMatrix edge) {
+ 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;
+}
+
+//[[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::export]]
+Rcpp::List testEqInt (Rcpp::IntegerVector x, Rcpp::IntegerVector y) {
+ Rcpp::LogicalVector xy = x == y;
+ Rcpp::LogicalVector yx = y == x;
+ return Rcpp::List::create(xy, yx);
+}
+
+
+//[[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)));
+}
+
+//[[Rcpp::export]]
+bool any_naC (Rcpp::NumericVector x) {
+ return is_true(any(is_na(x)));
+}
+
+//[[Rcpp::export]]
+int nb_naC (Rcpp::NumericVector x) {
+ return sum(is_na(x));
+}
+
+
+//[[Rcpp::export]]
+Rcpp::NumericVector getRange(Rcpp::NumericVector x, const bool na_rm) {
+ Rcpp::NumericVector out(2);
+ out[0] = R_PosInf;
+ out[1] = R_NegInf;
+
+ int n = x.length();
+ for(int i = 0; i < n; ++i) {
+ if (!na_rm && R_IsNA(x[i])) {
+ out[0] = NA_REAL;
+ out[1] = NA_REAL;
+ return(out);
+ }
+
+ if (x[i] < out[0]) out[0] = x[i];
+ if (x[i] > out[1]) out[1] = x[i];
+ }
+
+ return(out);
+}
+
+//[[Rcpp::export]]
+bool hasDuplicatedLabelsCpp (Rcpp::CharacterVector label) {
+ return is_true(any(Rcpp::duplicated(label)));
+}
+
+std::string edgeIdCppInternal (int tmp1, int tmp2) {
+ std::string tmp1S = static_cast<std::ostringstream*>( &(std::ostringstream() << tmp1) )->str();
+ std::string tmp2S = static_cast<std::ostringstream*>( &(std::ostringstream() << tmp2) )->str();
+ tmp1S.append("-");
+ tmp1S.append(tmp2S);
+ return tmp1S;
+}
+
+//[[Rcpp::export]]
+Rcpp::CharacterVector edgeIdCpp (Rcpp::IntegerMatrix edge, std::string type) {
+ Rcpp::IntegerVector ances = getAnces(edge);
+ Rcpp::IntegerVector desc = getDesc(edge);
+
+ if (type == "tip" || type == "internal") {
+ Rcpp::IntegerVector tips = tipsFast(ances);
+ int ntips = tips.size();
+ Rcpp::IntegerVector ans = match(tips, desc);
+ if (type == "tip") {
+ Rcpp::CharacterVector c1(ntips);
+ for (int j = 0; j < ntips; j++) {
+ int tmp1 = ances[ans[j]-1];
+ int tmp2 = desc[ans[j]-1];
+ c1[j] = edgeIdCppInternal(tmp1, tmp2);
+ }
+ return c1;
+ }
+ else if (type == "internal") {
+ int nedge = ances.size();
+ Rcpp::IntegerVector idEdge = Rcpp::seq_len(nedge);
+ Rcpp::IntegerVector intnd = Rcpp::setdiff(idEdge, ans);
+ int nnd = intnd.size();
+ Rcpp::CharacterVector c1(nnd);
+ for (int j = 0; j < nnd; j++) {
+ int tmp1 = ances[intnd[j]-1];
+ int tmp2 = desc[intnd[j]-1];
+ c1[j] = edgeIdCppInternal(tmp1, tmp2);
+ }
+ return c1;
+ }
+ }
+ else {
+ int nedge = ances.size();
+ Rcpp::CharacterVector c1(nedge);
+ for (int j = 0; j < nedge; j++) {
+ int tmp1 = ances[j];
+ int tmp2 = desc[j];
+ c1[j] = edgeIdCppInternal(tmp1, tmp2);
+ }
+ return c1;
+ }
+}
+
+//[[Rcpp::export]]
+Rcpp::List checkTreeCpp(Rcpp::S4 obj, Rcpp::List opts) {
+
+ std::string err, wrn;
+ Rcpp::IntegerMatrix ed = obj.slot("edge");
+ int nrow = ed.nrow();
+ Rcpp::IntegerVector ances = getAnces(ed);
+ //Rcpp::IntegerVector desc = getDesc(ed);
+ Rcpp::NumericVector edLength = obj.slot("edge.length");
+ Rcpp::CharacterVector edLengthNm = edLength.names();
+ Rcpp::CharacterVector label = obj.slot("label");
+ Rcpp::CharacterVector labelNm = label.names();
+ Rcpp::CharacterVector edLabel = obj.slot("edge.label");
+ Rcpp::CharacterVector edLabelNm = edLabel.names();
+ Rcpp::IntegerVector allnodesSafe = getAllNodesSafe(ed);
+ Rcpp::IntegerVector allnodesFast = getAllNodesFast(ed);
+ 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);
+ int ntipsFast = nTipsFastCpp(ances);
+ bool testnTips = ntipsFast == ntipsSafe;
+ if (! testnTips) {
+ err.append("Tips incorrectly labeled. ");
+ }
+
+ //check internal nodes
+ bool testNodes = Rcpp::all(allnodesSafe == allnodesFast).is_true() && // is both ways comparison needed?
+ Rcpp::all(allnodesFast == allnodesSafe).is_true();
+ if (! testNodes) {
+ err.append("Nodes incorrectly labeled. ");
+ }
+
+ // check edge lengths
+ 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 (getRange(edLength, TRUE)[0] < 0) {
+ err.append("Edge lengths must be non-negative. ");
+ }
+ Rcpp::CharacterVector edgeLblSupp = edgeIdCpp(ed, "all");
+ Rcpp::CharacterVector edgeLblDiff = Rcpp::setdiff(edLengthNm, edgeLblSupp);
+ if ( edgeLblDiff.size() != 0 ) {
+ err.append("Edge lengths incorrectly labeled. ");
+ }
+ }
+
+ // check label names
+ Rcpp::CharacterVector chrLabelNm = Rcpp::as<Rcpp::CharacterVector>(allnodesFast);
+ int j = 0;
+ while (j < nroots) { //remove root(s)
+ chrLabelNm.erase(0);
+ j++;
+ }
+ bool testLabelNm = isLabelName(labelNm, chrLabelNm);
+ if (!testLabelNm) {
+ err.append("Tip and node labels must be a named vector, the names must match the node IDs. ");
+ err.append("Use tipLabels<- and/or nodeLabels<- to update them. ");
+ }
+
+ // check that tips have labels
+ Rcpp::CharacterVector tiplabel(ntipsFast);
+ std::copy (label.begin(), label.begin()+ntipsFast, tiplabel.begin());
+ bool emptyTipLabel = is_true(any(Rcpp::is_na(tiplabel)));
+ if ( emptyTipLabel ) {
+ err.append("All tips must have a label.");
+ }
+
+ // check edgeLabels
+ Rcpp::CharacterVector chrEdgeLblNm = edgeIdCpp(ed, "all");
+ bool testEdgeLblNm = isLabelName(edLabelNm, chrEdgeLblNm);
+ if (!testEdgeLblNm) {
+ err.append("Edge labels are not labelled correctly. Use the function edgeLabels<- to update them. ");
+ }
+
+ // make sure that tips and node labels are unique
+ if (hasDuplicatedLabelsCpp(label)) {
+ std::string labOpt = opts["allow.duplicated.labels"];
+ if (labOpt == "fail") {
+ err.append("Labels are not unique. ");
+ }
+ if (labOpt == "warn") {
+ wrn.append("Labels are not unique. ");
+ }
+ }
+
+ // check for polytomies
+ if (hasPolytomy(ances)) {
+ std::string msgPoly = "Tree includes polytomies. ";
+ std::string polyOpt = opts["poly"];
+ if (polyOpt == "fail") {
+ err.append(msgPoly);
+ }
+ if (polyOpt == "warn") {
+ wrn.append(msgPoly);
+ }
+ }
+
+ // check number of roots
+ if (nroots > 1) {
+ std::string msgRoot = "Tree has more than one root. ";
+ std::string rootOpt = opts["multiroot"];
+ if (rootOpt == "fail") {
+ err.append(msgRoot);
+ }
+ if (rootOpt == "warn") {
+ wrn.append(msgRoot);
+ }
+ }
+
+ // check for singletons
+ if (hasSingleton(ances)) {
+ std::string msgSing = "Tree contains singleton nodes. ";
+ std::string singOpt = opts["singleton"];
+ if (singOpt == "fail") {
+ err.append(msgSing);
+ }
+ if (singOpt == "warn") {
+ wrn.append(msgSing);
+ }
+ }
+
+ return Rcpp::List::create(err, wrn);
+}
Added: pkg/src/symbols.rds
===================================================================
(Binary files differ)
Property changes on: pkg/src/symbols.rds
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
More information about the Phylobase-commits
mailing list