R/paint.R

In ouch: Ornstein-Uhlenbeck Models for Phylogenetic Comparative Hypotheses

##' Painting regimes on a phylogenetic tree
##'
##' Function to paint selective regimes on a phylogenetic tree.
##'
##' The names of `subtree` and `branch` must be the names of nodes of `tree`.
##' The painting proceeds in a particular order:
##' one can overpaint a branch.
##' The subtrees indicated by the elements of `subtree` are painted first, in order.
##' Then the branches indicated by `branch` are painted.
##' If `tree` is of class [`hansentree`][hansen], then `paint` begins with the regimes specified in the `regimes` slot of `tree`.
##' Otherwise, `paint` begins with a blank canvas,
##' i.e., a tree painted with the single regime "nonspec".
##' Note that, if `tree` is a multivariate `hansentree`, then there are multiple regime specifications contained in `tree`.
##' In this case, the argument `which` lets you pick which one you wish to begin with;
##' by default, the first is used.
##'
##' @keywords models
##' @family methods for ouch trees
##' @family phylogenetic comparative models
##' @include ouchtree.R
##'
##' @param tree An object of class [`ouchtree`].
##' @param subtree An optional named vector specifying the root nodes of subtrees.
##' Each branch that descends from this node will be painted with the specified regime.
##' @param branch An optional named vector specifying the end nodes of branches.
##' The unique branch that terminates at the named node will be painted with the specified regime.
##' @param which integer;
##' if `tree` is a [`hansentree`][hansen], start not with a blank canvas but with the regime specifications `tree` contains for the character indicated by `which`.
##' @return A vector of class 'factor' with names corresponding to the nodes in `tree`, specifying selective regimes.
##' @author Aaron A. King
##' @example examples/paint.R
##' @importFrom utils head tail
##' @export
paint <- function (tree, subtree, branch, which = 1) {
  if (!is(tree,'ouchtree'))
    pStop("paint",sQuote("tree")," must be of class ",sQuote("ouchtree"),".")
  if (is(tree,'hansentree')) {
    regimes <- try(tree@regimes[[which]],silent=FALSE)
    if (inherits(regimes,'try-error'))
      pStop("paint",sQuote("paint")," error: invalid ",sQuote("which"),".")
  } else {
    regimes <- rep('unspec',length(tree@nodes))
    names(regimes) <- tree@nodes
  }
  if (!missing(subtree)) {
    st.nm <- names(subtree)
    if (is.null(st.nm))
      pStop("paint",sQuote("subtree")," must be a named vector.")
    if (!all(st.nm%in%tree@nodes))
      pStop("paint","all names of ",sQuote("subtree")," must be names of nodes of ",sQuote("tree"),".")
    subtree <- as.character(subtree)
  } else {
    subtree <- character(0)
    st.nm <- character(0)
  }
  if (!missing(branch)) {
    br.nm <- names(branch)
    if(is.null(br.nm))
      pStop("paint",sQuote("branch")," must be a named vector.")
    if (!all(br.nm%in%tree@nodes))
      pStop("paint","all names of ",sQuote("branch")," must be names of nodes of ",sQuote("tree"),".")
    branch <- as.character(branch)
  } else {
    branch <- character(0)
    br.nm <- character(0)
  }
  tog <- as.factor(c(as.character(subtree),as.character(branch)))
  subtree <- head(tog,length(subtree))
  branch <- tail(tog,length(branch))
  names(subtree) <- st.nm
  names(branch) <- br.nm
  for (k in seq(along=subtree)) {
    st <- sapply(tree@lineages,function(x,y)y%in%x[-1],y=st.nm[k])
    regimes[st] <- as.character(subtree[k])
  }
  for (k in seq(along=branch)) {
    br <- tree@nodes%in%br.nm[k]
    regimes[br] <- as.character(branch[k])
  }
  as.factor(regimes)
}