Updated other slots and TM [] plus other minors

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: treeman
 Type: Package
 Title: Phylogenetic Tree Manipulation Class and Methods
-Version: 1.1
+Version: 1.11
 Date: 2016-04-16
 Author: D.J. Bennett
 Maintainer: D.J. Bennett <dominic.john.bennett@gmail.com>

NAMESPACE

@@ -32,6 +32,7 @@ export(getNdPtids)
 export(getNdSlt)
 export(getNdSstr)
 export(getNdsAge)
+export(getNdsFrmTxnyms)
 export(getNdsKids)
 export(getNdsLng)
 export(getNdsPD)
@@ -46,7 +47,6 @@ export(getPrnt)
 export(getSpnAge)
 export(getSpnsAge)
 export(getSubtree)
-export(getTxnyms)
 export(getUnqNds)
 export(isUltrmtrc)
 export(loadTreeMan)
@@ -58,6 +58,7 @@ export(readTrmn)
 export(rmClade)
 export(rmNdmtrx)
 export(rmNodes)
+export(rmOtherSlt)
 export(rmTips)
 export(saveTreeMan)
 export(searchTxnyms)

R/check_methods.R

@@ -75,13 +75,28 @@ checkNdlst <- function(ndlst, root) {
     FALSE
   }
   nds <- names(ndlst)
+  if(any(duplicated(nds))) {
+    dups <- nds[duplicated(nds)]
+    dups <- unique(dups)
+    msg <- 'These node IDs are duplicated:\n'
+    if(length(dups) > 1) {
+      for(i in 1:length(dups) - 1) {
+        msg <- paste0(msg, dups[i], ', ')
+      }
+    }
+    msg <- paste0(msg, dups[length(dups)], '\n')
+    cat(msg)
+    return(FALSE)
+  }
   rid <- root
   nd_checks <- sapply(ndlst, .check)
   if(!all(nd_checks)) {
     msg <- 'These nodes are invalid:\n'
     bad <- which(!nd_checks)
-    for(i in bad[-length(bad)]) {
-      msg <- paste0(msg, nds[i], ', ')
+    if(length(bad) > 1) {
+      for(i in bad[-length(bad)]) {
+        msg <- paste0(msg, nds[i], ', ')
+      }
     }
     msg <- paste0(msg, nds[bad[length(bad)]], '\n')
     cat(msg, '\n')

R/get-nd-methods.R

@@ -5,7 +5,7 @@
 #' @param tree \code{TreeMan} object
 #' @param id node id
 #' @seealso
-#' \code{\link{getNdsLng}}, \code{\link{getTxnyms}},
+#' \code{\link{getNdsLng}}, \code{\link{getNdsFrmTxnyms}},
 #' \url{https://github.com/DomBennett/treeman/wiki/get-methods}
 #' @export
 #' @examples
@@ -160,7 +160,7 @@ getNdPrdst <- function(tree, id) {
 #' @title Get a node slot
 #' @description Returns the value of named slot.
 #' @details Returned object depends on name, either character, vector or numeric.
-#' Default node slots are: id, spn, prid, ptid and txnym.
+#' Default node slots are: id, spn, prid, ptid and txnym. If slot is empty, returns NA.
 #' @param tree \code{TreeMan} object
 #' @param slt_nm slot name
 #' @param id node id
@@ -173,7 +173,11 @@ getNdPrdst <- function(tree, id) {
 #' tree <- randTree(10)
 #' getNdSlt(tree, slt_nm='spn', id='t1')  # return span of t1
 getNdSlt <- function(tree, slt_nm, id) {
-  tree@ndlst[[id]][[slt_nm]]
+  res <- tree@ndlst[[id]][[slt_nm]]
+  if(is.null(res)) {
+    res <- NA
+  }
+  res
 }
 
 #' @name getNdPD

R/get-nds-methods.R

@@ -7,7 +7,7 @@
 #' @param parallel logical, make parallel?
 #' @param progress name of the progress bar to use, see \code{\link{create_progress_bar}}
 #' @seealso
-#' \code{\link{getNdLng}}, \code{\link{getTxnyms}},
+#' \code{\link{getNdLng}}, \code{\link{getNdsFrmTxnyms}},
 #' \url{https://github.com/DomBennett/treeman/wiki/get-methods}
 #' @export
 #' @examples
@@ -108,7 +108,7 @@ getNdsPrdst <- function(tree, ids, parallel=FALSE, progress="none") {
 
 #' @name getNdsSlt
 #' @title Get a node slot for multiple nodes
-#' @description Returns the value of named slot.
+#' @description Returns the values of named slot as a vector for atomic values, else list.
 #' @details Returned object depends on name, either character, vector or numeric. Parallelizable.
 #' Default node slots are: id, spn, prid, ptid and txnym.
 #' @param tree \code{TreeMan} object
@@ -129,9 +129,14 @@ getNdsSlt <- function(tree, slt_nm, ids, parallel=FALSE, progress="none") {
     getNdSlt(tree, slt_nm, ids[i])
   }
   l_data <- data.frame(i=1:length(ids), stringsAsFactors=FALSE)
-  res <- plyr::mdply(.data=l_data, .fun=.get, .parallel=parallel,
+  res <- plyr::mlply(.data=l_data, .fun=.get, .parallel=parallel,
                      .progress=progress)
-  res[ ,2]
+  res <- res[1:length(res)]
+  if(all(sapply(res, length) == 1)) {
+    res <- unlist(res, recursive=FALSE)
+  }
+  names(res) <- ids
+  res
 }
 
 #' @name getNdsKids

R/get-spcl-methods.R

@@ -218,7 +218,7 @@ getCnnctdNds <- function(tree, tids) {
   names(counts)[counts < length(tids)]
 }
 
-#' @name getTxnyms
+#' @name getNdsFrmTxnyms
 #' @title Get IDs for nodes represented txnyms
 #' @description Return a list of IDs for any node that contains the given txnyms.
 #' @details Returns a list. Txnyms must be spelt correctly.
@@ -232,8 +232,8 @@ getCnnctdNds <- function(tree, tids) {
 #' library(treeman)
 #' data(mammals)
 #' # what ID represents the apes?
-#' getTxnyms(mammals, 'Hominoidea')
-getTxnyms <- function(tree, txnyms) {
+#' getNdsFrmTxnyms(mammals, 'Hominoidea')
+getNdsFrmTxnyms <- function(tree, txnyms) {
   # get nd id(s) for taxonyms
   .get <- function(id, txnym, ...) {
     for(t in txnyms) {

R/read-write-methods.R

@@ -97,8 +97,13 @@ writeTree <- function(tree, file, append=FALSE, ndLabels=function(nd){
 #' @description Return a \code{TreeMan} or \code{TreeMen} object from a Newick treefile
 #' @details Read a single or multiple trees from a file, or a text string. Parallelizable
 #' when reading multiple trees.
+#' The function will add any internal node labels in the Newick tree as a user-defined data slots.
+#' The name of this slot is defined with the \code{spcl_slt_nm}.
+#' These data can be accessed/manipulated with the \code{`getNdsSlt()`} function.
+#' Trees are always read as rooted. (Unrooted trees have polytomous root nodes.)
 #' @param file file path
 #' @param text Newick character string
+#' @param spcl_slt_nm name of special slot for internal node labels, default 'Unknown'.
 #' @param wndmtrx T/F add node matrix? Default FALSE.
 #' @param parallel logical, make parallel?
 #' @param progress name of the progress bar to use, see \code{\link{create_progress_bar}}
@@ -110,36 +115,41 @@ writeTree <- function(tree, file, append=FALSE, ndLabels=function(nd){
 #' @export
 #' @examples
 #' library(treeman)
-#' tree <- readTree(text="((A:1.0,B:1.0):1.0,(C:1.0,D:1.0):1.0);")
-readTree <- function(file=NULL, text=NULL, wndmtrx=FALSE, parallel=FALSE,
-                     progress='none') {
+#' # tree string with internal node labels as bootstrap results
+#' tree <- readTree(text="((A:1.0,B:1.0)0.9:1.0,(C:1.0,D:1.0)0.8:1.0)0.7:1.0;",
+#' spcl_slt_nm='bootstrap')
+#' # retrieve bootstrap values by node
+#' tree['bootstrap']
+readTree <- function(file=NULL, text=NULL, spcl_slt_nm='Unknown', wndmtrx=FALSE,
+                     parallel=FALSE, progress='none') {
   if(!is.null(file)) {
     trstr <- scan(file, what="raw", quiet=TRUE)
   } else {
     trstr <- text
   }
   if(length(trstr) > 1) {
     trstr <- as.list(trstr)
-    trees <- plyr::mlply(trstr, .fun=.readTree, wndmtrx=wndmtrx,
-                         .progress=progress, .parallel=parallel)
+    trees <- plyr::mlply(trstr, .fun=.readTree, spcl_slt_nm=spcl_slt_nm,
+                         wndmtrx=wndmtrx, .progress=progress, .parallel=parallel)
     names(trees) <- NULL
+    trees <- trees[1:length(trees)]
     tree <- as(trees, 'TreeMen')
   } else {
-    tree <- .readTree(trstr, wndmtrx)
+    tree <- .readTree(trstr, spcl_slt_nm, wndmtrx)
   }
   tree
 }
 
 #' @useDynLib treeman
 #' @useDynLib treeman cFindPrids
-.readTree <- function(trstr, wndmtrx) {
+.readTree <- function(trstr, spcl_slt_nm, wndmtrx) {
   # Internals
   .idspn <- function(i) {
     mtdt <- substr(trstr, start=nds[i-1] + 1, stop=nds[i])
     mtdt <- gsub("(\\(|\\)|,|;)", "", mtdt)
     mtdt <- strsplit(mtdt, ":")[[1]]
+    id <- NA
     if(length(mtdt) == 0) {
-      id <- paste0('n', i)
       spn <- NA
     } else if(length(mtdt) == 1) {
       id <- mtdt
@@ -148,7 +158,6 @@ readTree <- function(file=NULL, text=NULL, wndmtrx=FALSE, parallel=FALSE,
       id <- mtdt[1]
       spn <- as.numeric(mtdt[2])
     } else {
-      id <- paste0('n', i)
       spn <- as.numeric(mtdt[2])
     }
     c(id, spn)
@@ -186,13 +195,36 @@ readTree <- function(file=NULL, text=NULL, wndmtrx=FALSE, parallel=FALSE,
   tinds <- which(!1:length(ids) %in% prinds)
   prinds[is.na(prinds)] <- root
   spns[is.na(spns)] <- 0
+  # move internal node labels to other
+  other <- rep(NA, length(ids))
+  intnds <- 1:length(ids) %in% prinds
+  other[intnds] <- ids[intnds]
+  ids[intnds] <- paste0('n', which(intnds))
+  # rm NAs from IDs
+  pull <- is.na(ids)
+  ids[pull] <- paste0('n', which(pull))
+  # ensure no dups in ids
+  dups <- duplicated(ids)
+  if(any(dups)) {
+    dups <- unique(ids[dups])
+    for(dup in dups) {
+      pull <- ids == dup
+      other[pull] <- ids[pull]
+      ids[pull] <- paste0('n', which(pull))
+    }
+  }
   ptids <- ids[-root]
   ptnds_pool <- prinds[-root]
   ndlst <- lapply(1:length(ids), .add)
   names(ndlst) <- ids
   tree <- new('TreeMan', ndlst=ndlst, root=ids[root],
               ndmtrx=NULL, wtxnyms=FALSE,
               prinds=prinds, tinds=tinds)
+  pull <- !is.na(other)
+  if(any(pull)) {
+    tree <- setNdsOther(tree, ids=ids[pull], vals=other[pull],
+                        slt_nm=spcl_slt_nm)
+  }
   tree <- updateSlts(tree)
   if(wndmtrx) {
     tree <- addNdmtrx(tree)

R/server-methods.R

@@ -14,7 +14,7 @@
 #' @param clean T/F, ensure returned names contain no special characters?
 #' @param infer T/F, infer taxonyms for unfound nodes?
 #' @seealso
-#' \code{\link{taxaResolve}}, \code{\link{setTxnyms}}, \code{\link{getTxnyms}}
+#' \code{\link{taxaResolve}}, \code{\link{setTxnyms}}, \code{\link{getNdsFrmTxnyms}}
 #' @export
 #' @examples
 #' tree <- randTree(8)
@@ -88,7 +88,7 @@ searchTxnyms <- function (tree, cache=FALSE, parent=NULL, clean=TRUE,
 #' @param cache T/F, create a local cache of downloaded names?
 #' @param parent specify parent of all names to prevent false names
 #' @seealso
-#' \code{\link{searchTxnyms}}, \code{\link{setTxnyms}}, \code{\link{getTxnyms}}
+#' \code{\link{searchTxnyms}}, \code{\link{setTxnyms}}, \code{\link{getNdsFrmTxnyms}}
 #' @export
 #' @examples
 #' my_lovely_names <- c ('Gallus gallus', 'Pongo pingu', 'Homo sapiens',

R/set-methods.R

@@ -304,3 +304,36 @@ setNdsOther <- function(tree, ids, vals, slt_nm, parallel=FALSE, progress="none"
   }
   tree
 }
+
+#' @name rmOtherSlt
+#' @title Remove a user-defined slot
+#' @description Returns a tree with a user-defined tree slot removed.
+#' @details A user can specify a new slot using the \code{setNdSlt()} function
+#' or upon reading a tree. This can be removed using this function by specifying
+#' the name of the slot to be removed.
+#' @param tree \code{TreeMan} object
+#' @param slt_nm name of slot to be removed
+#' @seealso
+#' \code{\link{setNdOther}}, \code{\link{setNdsOther}},
+#' \url{https://github.com/DomBennett/treeman/wiki/set-methods}
+#' @export
+#' @examples
+#' library(treeman)
+#' tree <- randTree(10)
+#' vals <- runif(min=0, max=1, n=tree['nall'])
+#' tree <- setNdsOther(tree, tree['all'], vals, 'confidence')
+#' tree <- updateSlts(tree)
+#' summary(tree)
+#' tree <- rmOtherSlt(tree, 'confidence')
+#' tree <- updateSlts(tree)
+#' summary(tree)
+rmOtherSlt <- function(tree, slt_nm) {
+  .set <- function(id) {
+    tree@ndlst[[id]][[slt_nm]] <<- NULL
+  }
+  l_data <- data.frame(id=tree@all, stringsAsFactors=FALSE)
+  plyr::m_ply(.data=l_data, .fun=.set)
+  tree@updtd <- FALSE
+  tree@othr_slt_nms <- tree@othr_slt_nms[tree@othr_slt_nms != slt_nm]
+  tree
+}

R/treeman-declaration.R

@@ -67,9 +67,14 @@
 #' tree[['t1']]   # return t1 node object
 #' tree['pd']     # return phylogenetic diversity
 #' tree['ply']    # is polytomous?
-#' # Additional special slots
+#' # Additional special slots (calculated upon call)
 #' tree['age']   # get tree's age
 #' tree['ultr']  # determine if tree is ultrametric
+#' tree['spns']  # get all the spans of the tree IDs
+#' tree['prids'] # get all the IDs of preceding nodes
+#' tree['ptids'] # get all the IDs of following nodes
+#' tree['txnyms'] # get all the taxonyms of all nodes
+#' # In addition [] can be used for any user-defined slot
 #' # Because all nodes are lists with metadata we can readily
 #' #  get specific information on nodes of interest
 #' nd <- tree[['n2']]
@@ -141,8 +146,22 @@ setMethod('[', c('TreeMan', 'character', 'missing', 'missing'),
             if(i == 'age') {
               return(getAge(x))
             }
+            # getNdsSlt extractor
+            xtr_slts <- c('spns', 'prids', 'ptids', 'txnyms')
+            if(i %in% xtr_slts) {
+              slt_nm <- sub('s$', '', i)  # rm s at end
+              res <- getNdsSlt(x, slt_nm, x@all)
+              names(res) <- x@all
+              return(res)
+            }
+            if(i %in% x@othr_slt_nms) {
+              res <- getNdsSlt(x, i, x@all)
+              names(res) <- x@all
+              return(res)
+            }
             if(!i %in% slt_nms) {
-              slt_nms <- paste0(c(slt_nms, 'ultr', 'age'), collapse=', ')
+              slt_nms <- paste0(c(slt_nms, 'ultr', 'age', xtr_slts,
+                                  x@othr_slt_nms), collapse=', ')
               stop(paste0('`', i, '` not a tree slot. Available slots: ',
                           slt_nms))
             }