[Phylobase-commits] r760 - in pkg: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Mar 23 01:06:33 CET 2010
Author: francois
Date: 2010-03-23 01:06:32 +0100 (Tue, 23 Mar 2010)
New Revision: 760
Added:
pkg/R/phylobase.options.R
pkg/man/phylobase.options.Rd
Modified:
pkg/DESCRIPTION
pkg/NAMESPACE
pkg/R/checkdata.R
pkg/R/methods-phylo4.R
pkg/R/zzz.R
pkg/man/check.phylo4.Rd
pkg/man/phylo4-labels.Rd
Log:
created phylobase.options function to return and alter default options of the validator, created hasDuplicatedLabels method, updated validator to take advantage of phylobase.options()
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2010-03-15 22:31:42 UTC (rev 759)
+++ pkg/DESCRIPTION 2010-03-23 00:06:32 UTC (rev 760)
@@ -9,5 +9,5 @@
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 (>= 2)
-Collate: phylo4.R checkdata.R formatData.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 treestruc.R treewalk.R readNexus.R tbind.R zzz.R
+Collate: phylo4.R checkdata.R formatData.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 phylobase.options.R prune.R treePlot.R treestruc.R treewalk.R readNexus.R tbind.R zzz.R
URL: http://phylobase.R-forge.R-project.org
Modified: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE 2010-03-15 22:31:42 UTC (rev 759)
+++ pkg/NAMESPACE 2010-03-23 00:06:32 UTC (rev 760)
@@ -80,6 +80,9 @@
# misc objects
export(phylo4_orderings)
+## options
+export(phylobase.options)
+
## commented out in source code, probably should be omitted here
#export(phyloStripchart)
#export(internEdges, terminEdges, isPoly)
Modified: pkg/R/checkdata.R
===================================================================
--- pkg/R/checkdata.R 2010-03-15 22:31:42 UTC (rev 759)
+++ pkg/R/checkdata.R 2010-03-23 00:06:32 UTC (rev 760)
@@ -1,4 +1,3 @@
-
## REQUIRED for all trees
checkPhylo4 <- function(object) {
ct <- checkTree(object)
@@ -10,15 +9,16 @@
return(ct)
}
-checkTree <- function(object,
- warn=c("retic","singleton","multiroot"),
- err=NULL) {
+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()
+
## FIXME: check for cyclicity?
nedges <- nrow(object at edge)
@@ -35,10 +35,7 @@
if (any(object at edge.length[!is.na(object at edge.length)] < 0))
return("edge lengths must be non-negative")
}
- ##TODO fix this up somehow, or remove? (Nnode slot no longer exists)
- ## if (length(object at tip.label)+object at Nnode-1 != N) # does not work with multifurcations
- ## return("number of tip labels not consistent with number of edges and nodes")
- ## check: tip numbers = (m+1):(m+n)
+
ntips <- nTips(object)
E <- edges(object)
tips <- unique(sort(E[,2][!E[,2] %in% E[,1]]))
@@ -46,7 +43,6 @@
intnodes <- nodes[!nodes %in% tips]
roots <- E[which(is.na(E[,1])),2]
nRoots <- length(roots)
-
if (!(all(tips==1:ntips) && all(nodes=(ntips+1):(ntips+length(intnodes)))))
return("tips and nodes incorrectly numbered")
@@ -67,7 +63,9 @@
return("root node must be first row of edge matrix")
}
- ##
+ if (!all(nDesc[(nTips+1):(nTips+nNodes(object))]>0))
+ return("nodes (nTips+1) to (nTips+nNodes) must all be internal nodes")
+
## how do we identify loops???
## EXPERIMENTAL: could be time-consuming for large trees?
if (FALSE) {
@@ -84,7 +82,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. ",
@@ -122,56 +120,55 @@
}
}
- ## 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")
-
## all done with fatal errors. Now construct a list
## of warnings and paste them together
msg <- character(0)
- ##fixme following check fails for unrooted trees
- ##if (!all(nDesc[(nTips+1):(nTips+nNodes(object))]>0))
- ## return("nodes (nTips+1) to (nTips+nNodes) must all be internal nodes")
+ ## make sure that tip and node labels are unique
+ if (hasDuplicatedLabels(object)) {
+ currmsg <- "Labels are not unique"
+ if (opt$allow.duplicated.labels == "fail")
+ return(currmsg)
+ if (opt$allow.duplicated.labels == "warn")
+ msg <- c(msg, currmsg)
+ }
+
if (any(nDesc>2)) {
currmsg <- "tree includes polytomies"
- if ("poly" %in% err)
- return(currmsg)
- if ("poly" %in% warn)
- msg <- c(msg,currmsg)
+ if (opt$poly == "fail")
+ return(currmsg)
+ if (opt$poly == "warn")
+ msg <- c(msg, currmsg)
}
if (nRoots>1) {
currmsg <- "tree has more than one root"
- if ("multiroot" %in% err)
- return(currmsg)
- if ("multiroot" %in% warn)
- msg <- c(msg,currmsg)
- }
+ if (opt$multiroot == "fail")
+ return(currmsg)
+ if (opt$multiroot == "warn")
+ msg <- c(msg,currmsg)
+ }
if (any(nDesc==1)) {
currmsg <- "tree contains singleton nodes"
- if ("singleton" %in% err)
+ if (opt$singleton == "fail")
return(currmsg)
- if ("singleton" %in% warn)
- msg <- c(msg,currmsg)
- }
+ if (opt$singleton == "warn")
+ msg <- c(msg, currmsg)
+ }
if (any(nAncest>1)) {
currmsg <- paste("tree is reticulated [most functions in phylobase haven't",
"been tested with reticulated trees]")
- if ("retic" %in% err)
- return(currmsg)
- if ("retic" %in% warn)
- msg <- c(msg,currmsg)
+ if (opt$retic == "fail")
+ return(currmsg)
+ if (opt$retic == "warn")
+ msg <- c(msg, currmsg)
}
if (length(msg)>0) {
- msg <- paste(msg,collapse=", ")
+ msg <- paste(msg, collapse=", ")
warning(msg)
}
return(TRUE)
- }
+}
checkPhylo4Data <- function(object) {
Modified: pkg/R/methods-phylo4.R
===================================================================
--- pkg/R/methods-phylo4.R 2010-03-15 22:31:42 UTC (rev 759)
+++ pkg/R/methods-phylo4.R 2010-03-23 00:06:32 UTC (rev 760)
@@ -95,7 +95,7 @@
## strip out the root ancestor
nodesVect <- as.vector(edges(x))
nodesVect <- nodesVect[nodesVect != 0]
- ## get a sorted list of the unique nodes
+ ## get a sorted list of the unique nodes
listNodes <- sort(unique(nodesVect))
t <- rep("internal", length(listNodes)) # FM: internal is default (I think it's safer)
names(t) <- listNodes
@@ -302,7 +302,18 @@
return(x)
})
+### Duplicated Labels
+setMethod("hasDuplicatedLabels", signature(x="phylo4", type="ANY"),
+ function(x, type=c("all", "tip", "internal")) {
+ ## Default options
+ if (missing(type)) {
+ type <- "all"
+ }
+ type <- match.arg(type)
+ any(duplicated(labels(x, type)))
+})
+
### Node Labels
setMethod("hasNodeLabels", signature(x="phylo4"),
function(x) {
@@ -596,7 +607,7 @@
order <- match.arg(order)
index <- orderIndex(x, order)
x at order <- order
- x at edge <- x at edge[index, ]
+ x at edge <- edges(x)[index, ]
if(hasEdgeLabels(x)) {
x at edge.label <- x at edge.label[index]
}
Added: pkg/R/phylobase.options.R
===================================================================
--- pkg/R/phylobase.options.R (rev 0)
+++ pkg/R/phylobase.options.R 2010-03-23 00:06:32 UTC (rev 760)
@@ -0,0 +1,23 @@
+phylobase.options <- function (...) {
+ ## code from package sm
+ if (nargs() == 0) return(.phylobase.Options)
+ current <- .phylobase.Options
+ if (is.character(...))
+ temp <- eval(parse(text = paste(c("list(", ..., ")"))))
+ else temp <- list(...)
+ if (length(temp) == 1 && is.null(names(temp))) {
+ arg <- temp[[1]]
+ switch(mode(arg),
+ list = temp <- arg,
+ character = return(.phylobase.Options[arg]),
+ stop("invalid argument: ", sQuote(arg)))
+ }
+ if (length(temp) == 0) return(current)
+ n <- names(temp)
+ if (is.null(n)) stop("options must be given by name")
+ changed <- current[n]
+ current[n] <- temp
+ if (sys.parent() == 0) env <- asNamespace("phylobase") else env <- parent.frame()
+ assign(".phylobase.Options", current, envir = env)
+ invisible(current)
+}
Modified: pkg/R/zzz.R
===================================================================
--- pkg/R/zzz.R 2010-03-15 22:31:42 UTC (rev 759)
+++ pkg/R/zzz.R 2010-03-23 00:06:32 UTC (rev 760)
@@ -4,8 +4,23 @@
# library.dynam("phylobase", pkg, lib )
#}
+".phylobase.Options" <-
+ list(retic = "warn",
+ singleton = "warn",
+ multiroot = "warn",
+ poly = "warn",
+ allow.duplicated.labels = "fail")
+
# use this with a namespace
.onLoad <- function(lib, pkg) {
require(ape)
require(methods)
}
+
+.onAttach <- function(library, pkg)
+{
+ ## we can't do this in .onLoad
+ unlockBinding(".phylobase.Options", asNamespace("phylobase"))
+}
+
+
Modified: pkg/man/check.phylo4.Rd
===================================================================
--- pkg/man/check.phylo4.Rd 2010-03-15 22:31:42 UTC (rev 759)
+++ pkg/man/check.phylo4.Rd 2010-03-23 00:06:32 UTC (rev 760)
@@ -8,9 +8,7 @@
}
\usage{
checkPhylo4(object)
-checkTree(object,
- warn=c("retic","singleton","multiroot"),
- err=NULL)
+checkTree(object)
checkPhylo4Data(object)
}
\arguments{
@@ -34,11 +32,11 @@
functions.
\code{checkPhylo4} is an (inflexible) wrapper for
- \code{checkTree}, which uses the default settings.
+ \code{checkTree}.
The rules for \code{phylo4} objects essentially follow
those for \code{phylo} objects from the \code{ape} package,
which are in turn defined in
- http://ape.mpl.ird.fr/misc/FormatTreeR_4Dec2006.pdf.
+ \url{http://ape.mpl.ird.fr/misc/FormatTreeR_28July2008.pdf}.
These are essentially that:
\itemize{
\item if the tree has edge lengths defined, the number of edge
@@ -55,6 +53,9 @@
\item tip and node labels must be unique
}
+ You can alter some of the default options by using the function
+ \code{phylobase.options}.
+
For \code{phylo4d} objects, \code{checkTree} also calls
\code{checkPhylo4Data} to check the validity of the data associated
with the tree. It ensures that (1) the data associated with the tree
Modified: pkg/man/phylo4-labels.Rd
===================================================================
--- pkg/man/phylo4-labels.Rd 2010-03-15 22:31:42 UTC (rev 759)
+++ pkg/man/phylo4-labels.Rd 2010-03-23 00:06:32 UTC (rev 760)
@@ -39,6 +39,8 @@
\S4method{labels}{phylo4,ANY,ANY,character}(x, type=c("all", "tip",
"internal"), use.names=FALSE) <- value
+\S4method{hasDuplicatedLabels}{phylo4}(x, type=c("all", "tip", "internal"))
+
\S4method{tipLabels}{phylo4}(x)
\S4method{tipLabels}{phylo4,character}(x) <- value
@@ -86,6 +88,9 @@
\item{labels}{\code{signature(object = "phylo4")}: tip and/or
internal node labels, ordered by node ID}
+ \item{hasDuplicatedLabels}{\code{signature(object = "phylo4")}: are
+ any labels duplicated?}
+
\item{tipLabels}{\code{signature(object = "phylo4")}: tip labels,
ordered by node ID}
Added: pkg/man/phylobase.options.Rd
===================================================================
--- pkg/man/phylobase.options.Rd (rev 0)
+++ pkg/man/phylobase.options.Rd 2010-03-23 00:06:32 UTC (rev 760)
@@ -0,0 +1,63 @@
+\name{phylobase.options}
+\alias{phylobase.options}
+\title{Set or return options of phylobase}
+\description{
+ Provides a mean to control the validity of \code{phylobase} objects
+ such as singletons, reticulated trees, polytomies, etc.
+}
+\usage{
+phylobase.options()
+}
+\arguments{
+ \item{\dots}{a list may be given as the only argument, or any number
+ of arguments may be in the \code{name=value} form, or no argument at
+ all may be given. See the Value and Details sections for
+ explanation.}
+ Arguments which are set by a function call will remain in effect until
+ the end of the current session, unless overwritten by a
+ subsequent call. In addition, they can be added as optional
+ parameters of calls to specific functions of \code{phylobase}; in
+ this case, their effect is limited to that function call. See the
+ documentation of specific functions for the list of options which are
+ recognised by that function.
+ \itemize{
+ \item{retic}{\dQuote{warn}, \dQuote{fail} or \dQuote{OK}. Are
+ reticulated trees allowed? \dQuote{warn} returns a warning
+ (default) and \dQuote{fail} returns an error message}
+
+ \item{singleton}{\dQuote{warn}, \dQuote{fail} or \dQuote{OK}. Are
+ singleton nodes allowed? \dQuote{warn} returns a warning
+ (default) and \dQuote{fail} returns an error message}
+
+ \item{multiroot}{\dQuote{warn}, \dQuote{fail} or \dQuote{OK}. Are
+ multiple roots allowed? \dQuote{warn} returns a warning
+ (default) and \dQuote{fail} returns an error message}
+
+ \item{poly}{\dQuote{warn}, \dQuote{fail} or \dQuote{OK}. Are
+ polytomies allowed? \dQuote{warn} returns a warning
+ (default) and \dQuote{fail} returns an error message}
+
+ \item{allow.duplicated.labels}{\dQuote{warn}, \dQuote{fail} or
+ \dQuote{OK}. Are duplicated labels allowed? \dQuote{warn} returns
+ a warning and \dQuote{fail} (default) returns an error message}
+ }
+}
+\value{
+ A list with the updated values of the parameters. If arguments are
+ provided, the returned list is invisible.
+}
+\details{
+ The parameter values set via a call to this function will remain in
+ effect for the rest of the session, affecting the subsequent behavior
+ of phylobase.
+}
+
+\examples{
+\dontrun{
+phylobase.options(poly="fail")
+# subsequent trees with polytomies will fail the validity check
+}
+}
+\author{Francois Michonneau (adapted from the package \code{sm})}
+\keyword{phylobase}
+\keyword{validator}
\ No newline at end of file
More information about the Phylobase-commits
mailing list