Removed 'age', separated update and node matrix

NAMESPACE

@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+export(addNdmtrx)
 export(addTip)
 export(cTrees)
 export(calcDstBLD)
@@ -13,8 +14,10 @@ export(calcOvrlp)
 export(calcPhyDv)
 export(checkTreeMan)
 export(checkTreeMen)
-export(downdateTree)
 export(fastCheckTreeMan)
+export(getAge)
+export(getDcsd)
+export(getLvng)
 export(getNdAge)
 export(getNdKids)
 export(getNdLng)
@@ -39,11 +42,12 @@ export(getPrnt)
 export(getSpnAge)
 export(getSpnsAge)
 export(getSubtree)
-export(getTreeAge)
 export(getTxnyms)
 export(pinTips)
+export(pstMnp)
 export(randTree)
 export(readTree)
+export(rmNdmtrx)
 export(rmTips)
 export(searchTxnyms)
 export(setAge)
@@ -54,10 +58,9 @@ export(setNdsID)
 export(setNdsOther)
 export(setNdsSpn)
 export(setPD)
-export(setTol)
 export(setTxnyms)
 export(taxaResolve)
-export(updateTree)
+export(updateSlts)
 export(writeTree)
 exportClasses(Node)
 exportClasses(TreeMan)

R/check_methods.R

@@ -25,6 +25,7 @@ fastCheckTreeMan <- function(object) {
 #' @export
 checkTreeMan <- function(object) {
   # TODO: use prids as vector to test for circularity
+  # TODO: ensure spns are not negative
   .check <- function(nd) {
     test_id <- is.character(nd[['id']]) & 'id' %in% names(nd)  # must have id
     # must have either prid/ptid or both

R/gen-methods.R

@@ -5,15 +5,15 @@
 #' @details Equivalent to \code{ape}'s \code{rtree()} but returns a
 #' \code{TreeMan} tree. Tree is always rooted and bifurcating.
 #' @param n number of tips, integer, must be 3 or greater
-#' @param update T/F update tree slots after generation? Default TRUE.
+#' @param wndmtrx T/F add node matrix? Default TRUE.
 #' @param parallel T/F run in parallel? Default FALSE.
 #' @seealso
 #' \code{\link{TreeMan-class}}
 #' @export
 #' @examples
 #' library(treeman)
 #' tree <- randTree(5)
-randTree <- function(n, update=TRUE, parallel=FALSE) {
+randTree <- function(n, wndmtrx=TRUE, parallel=FALSE) {
   # Return a random tree based on a broken-stick model
   .add <- function(i) {
     nd <- vector("list", length=4)
@@ -51,18 +51,9 @@ randTree <- function(n, update=TRUE, parallel=FALSE) {
   # init new tree object
   tree <- new('TreeMan', ndlst=ndlst, root='n1', wtxnyms=FALSE,
               ndmtrx=NULL, prinds=prinds, tinds=tinds)
-  if(update) {
-    tree <- updateTree(tree)
-  } else {
-    # init basic slots
-    tree@updtd <- FALSE
-    tree@tips <- paste0('t', 1:n)
-    tree@ntips <- n
-    tree@nds <- paste0('n', 1:(n-1))
-    tree@nnds <- n - 1
-    tree@all <- names(tree@ndlst)
-    tree@nall <- nnds
-    tree@wspn <- TRUE
+  tree <- updateSlts(tree)
+  if(wndmtrx) {
+    tree <- addNdmtrx(tree)
   }
   tree
 }

R/get-nd-methods.R

@@ -29,12 +29,12 @@ getNdLng <- function(tree, id) {
 #' @details Returns a numeric.
 #' @param tree \code{TreeMan} object
 #' @param id node id
-#' @param tree_age numeric value of known age of tree, tree['age'] if tree is up-to-date
+#' @param tree_age numeric value of known age of tree
 #' @seealso
 #' \code{\link{getNdsAge}}, 
 #' \code{\link{getSpnAge}}, 
 #' \code{\link{getSpnsAge}}, 
-#' \code{\link{getPrnt}}, \code{\link{getTreeAge}}
+#' \code{\link{getPrnt}}, \code{\link{getAge}}
 #' \url{https://github.com/DomBennett/treeman/wiki/get-methods}
 #' @export
 #' @examples
@@ -43,7 +43,7 @@ getNdLng <- function(tree, id) {
 #' # when did apes emerge?
 #' # get parent id for all apes
 #' prnt_id <- getPrnt(mammals, ids=c('Homo_sapiens', 'Hylobates_concolor'))
-#' # mammal_age <- getTreeAge(mammals)  # ~166.2, needs to be performed when tree is not up-to-date
+#' # mammal_age <- getAge(mammals)  # ~166.2, needs to be performed when tree is not up-to-date
 #' getNdAge(mammals, id=prnt_id, tree_age=166.2)
 getNdAge <- function(tree, id, tree_age) {
   tree_age - .getNdPrdstsFrmLst(tree@ndlst, tree@prinds, id=id)
@@ -55,7 +55,7 @@ getNdAge <- function(tree, id, tree_age) {
 #' @details Returns a dataframe.
 #' @param tree \code{TreeMan} object
 #' @param id node id
-#' @param tree_age numeric value of known age of tree, tree['age'] if tree is updated
+#' @param tree_age numeric value of known age of tree
 #' @seealso
 #' \code{\link{getNdAge}}, 
 #' \code{\link{getNdsAge}}, 
@@ -65,7 +65,7 @@ getNdAge <- function(tree, id, tree_age) {
 #' @examples
 #' library(treeman)
 #' data(mammals)
-#' # mammal_age <- getTreeAge(mammals)  # ~166.2, needs to be performed when tree is not up-to-date
+#' # mammal_age <- getAge(mammals)  # ~166.2, needs to be performed when tree is not up-to-date
 #' getSpnAge(mammals, id='Homo_sapiens', tree_age=166.2)
 getSpnAge <- function(tree, id, tree_age) {
   end <- .getNdPrdstsFrmLst(tree@ndlst, tree@prinds, id=id)

R/get-nds-methods.R

@@ -65,7 +65,7 @@ getNdsSstr <- function(tree, ids, parallel=FALSE, progress="none") {
 #' tree <- randTree(10)
 #' getNdsPD(tree, ids=tree['all'])  # return PD of all ids
 getNdsPD <- function(tree, ids, parallel=FALSE, progress="none") {
-  if(tree@updtd & length(ids) > 1) {
+  if(!is.null(tree@ndmtrx) & length(ids) > 1) {
     all_ids <- tree@all
     spns <- .getSltSpns(tree@ndlst)
     res <- .getNdsPDFrmMtrx(tree@ndmtrx, all_ids, ids, spns,
@@ -94,7 +94,7 @@ getNdsPD <- function(tree, ids, parallel=FALSE, progress="none") {
 #' tree <- randTree(10)
 #' getNdsPrdst(tree, ids=tree['tips'])  # return prdsts for all tips
 getNdsPrdst <- function(tree, ids, parallel=FALSE, progress="none") {
-  if(tree@updtd & length(ids) > 1) {
+  if(!is.null(tree@ndmtrx) & length(ids) > 1) {
     all_ids <- tree@all
     spns <- .getSltSpns(tree@ndlst)
     res <- .getNdsPrdstsFrmMtrx(tree@ndmtrx, all_ids, ids, spns,
@@ -152,7 +152,7 @@ getNdsSlt <- function(tree, slt_nm, ids, parallel=FALSE, progress="none") {
 #' getNdsKids(tree, id=tree['nds'])
 getNdsKids <- function(tree, ids, parallel=FALSE,
                        progress="none") {
-  if(tree@updtd & length(ids) > 1) {
+  if(!is.null(tree@ndmtrx) & length(ids) > 1) {
     res <- .getNdsKidsFrmMtrx(tree@ndmtrx, tree@all,
                               ids, tree@tips, parallel, progress)
   } else {
@@ -169,7 +169,7 @@ getNdsKids <- function(tree, ids, parallel=FALSE,
 #' @details Returns a vector, parallelizable.
 #' @param tree \code{TreeMan} object
 #' @param ids vector of node ids
-#' @param tree_age numeric value of known age of tree, tree['age'] if tree is updated
+#' @param tree_age numeric value of known age of tree
 #' @param parallel logical, make parallel?
 #' @param progress name of the progress bar to use, see \code{\link{create_progress_bar}}
 #' @seealso
@@ -181,11 +181,11 @@ getNdsKids <- function(tree, ids, parallel=FALSE,
 #' @examples
 #' library(treeman)
 #' tree <- randTree(10)
-#' getNdsAge(tree, ids=tree['nds'], tree_age=tree['age'])
+#' getNdsAge(tree, ids=tree['nds'], tree_age=getAge(tree))
 getNdsAge <- function(tree, ids, tree_age,
                       parallel=FALSE,
                       progress="none") {
-  if(tree@updtd & length(ids) > 1) {
+  if(!is.null(tree@ndmtrx) & length(ids) > 1) {
     spns <- .getSltSpns(tree@ndlst)
     res <- .getNdsPrdstsFrmMtrx(tree@ndmtrx, tree@all,
                                ids, spns, parallel, progress)
@@ -207,7 +207,7 @@ getNdsAge <- function(tree, ids, tree_age,
 #' @details Returns a dataframe, parallelizable.
 #' @param tree \code{TreeMan} object
 #' @param ids vector of node ids
-#' @param tree_age numeric value of known age of tree, tree['age'] if tree is updated
+#' @param tree_age numeric value of known age of tree
 #' @param parallel logical, make parallel?
 #' @param progress name of the progress bar to use, see \code{\link{create_progress_bar}}
 #' @seealso
@@ -221,10 +221,10 @@ getNdsAge <- function(tree, ids, tree_age,
 #' tree <- randTree(10)
 #' # all nodes but root
 #' ids <- tree['nds'][tree['nds'] != tree['root']]
-#' getSpnsAge(tree, ids=ids, tree_age=tree['age'])
+#' getSpnsAge(tree, ids=ids, tree_age=getAge(tree))
 getSpnsAge <- function(tree, ids, tree_age,
                        parallel=FALSE, progress="none") {
-  if(tree@updtd & length(ids) > 1) {
+  if(!is.null(tree@ndmtrx) & length(ids) > 1) {
     spns <- .getSltSpns(tree@ndlst)
     end <- .getNdsPrdstsFrmMtrx(tree@ndmtrx, tree@all,
                                 ids, spns, parallel, progress)
@@ -264,7 +264,7 @@ getSpnsAge <- function(tree, ids, tree_age,
 #' getNdsPrids(tree, ids=tree['tips'])
 getNdsPrids <- function(tree, ids, ordrd=FALSE,
                         parallel=FALSE, progress="none") {
-  if(tree@updtd & length(ids) > 1 & !ordrd) {
+  if(!is.null(tree@ndmtrx) & length(ids) > 1 & !ordrd) {
     res <- .getNdsPridsFrmMtrx(tree@ndmtrx, tree@all,
                                ids, parallel, progress)
   } else {
@@ -295,7 +295,7 @@ getNdsPrids <- function(tree, ids, ordrd=FALSE,
 #' # get all nodes to tip for all nodes
 #' getNdsPtids(tree, ids=tree['nds'])
 getNdsPtids <- function(tree, ids, parallel=FALSE, progress="none") {
-  if(tree@updtd & length(ids) > 1) {
+  if(!is.null(tree@ndmtrx) & length(ids) > 1) {
     res <- .getNdsPtidsFrmMtrx(tree@ndmtrx, tree@all,
                                ids, parallel, progress)
   } else {

R/get-spcl-methods.R

@@ -1,3 +1,63 @@
+
+# EXTINCT/EXTANT
+.livingOrDesceased <- function(tree, tol=1e-8, bool) {
+  if(!is.null(tree@ndmtrx)) {
+    spns <- getNdsSlt(tree, 'spn', names(tree@ndlst))
+    tip_prdsts <- .getNdsPrdstsFrmMtrx(tree@ndmtrx, tree@all,
+                                       tree@tips, spns,
+                                       parallel=FALSE,
+                                       progress="none")
+  } else {
+    tip_prdsts <- .getNdsPrdstsFrmLst(tree@ndlst, tree@tips,
+                                      tree@prinds, parallel=FALSE,
+                                      progress='none')
+  }
+  age <- max(tip_prdsts)
+  extant_is <- (age - tip_prdsts) <= tol
+  living <- names(extant_is)[extant_is]
+  deceased <- tree@tips[!tree@tips %in% living]
+  if(bool) {
+    return(living)
+  }
+  deceased
+}
+
+#' @name getDcsd
+#' @title Get extinct tips from a tree
+#' @description Return all extinct tip \code{ID}s.
+#' @details Returns a vector.
+#' @param tree \code{TreeMan} object
+#' @param tol zero tolerance
+#' @seealso
+#' \code{\link{getLvng}}, 
+#' \url{https://github.com/DomBennett/treeman/wiki/get-methods}
+#' @export
+#' @examples
+#' library(treeman)
+#' tree <- randTree(10)
+#' (getDcsd(tree))
+getDcsd <- function(tree, tol=1e-8) {
+  .livingOrDesceased(tree=tree, tol=tol, bool=FALSE)
+}
+
+#' @name getLvng
+#' @title Get extant tips from a tree
+#' @description Return all extant tip \code{ID}s.
+#' @details Returns a vector.
+#' @param tree \code{TreeMan} object
+#' @param tol zero tolerance
+#' @seealso
+#' \code{\link{getDcsd}}, 
+#' \url{https://github.com/DomBennett/treeman/wiki/get-methods}
+#' @export
+#' @examples
+#' library(treeman)
+#' tree <- randTree(10)
+#' (getLvng(tree))
+getLvng <- function(tree, tol=1e-8) {
+  .livingOrDesceased(tree=tree, tol=tol, bool=TRUE)
+}
+
 # SINGLE ND
 # TODO: bring outgroup, parent and path into terminological line with getNd(s)
 
@@ -137,7 +197,7 @@ getTxnyms <- function(tree, txnyms) {
 #' # get tree of apes
 #' ape_id <- getPrnt(mammals, ids=c('Homo_sapiens', 'Hylobates_concolor'))
 #' apes <- getSubtree(mammals, id=ape_id)
-#' apes <- updateTree(apes)
+#' summary(apes)
 getSubtree <- function(tree, id) {
   if(!id %in% tree@nds) {
     stop('`id` is not an internal node')
@@ -148,32 +208,31 @@ getSubtree <- function(tree, id) {
   ndlst[[id]][['spn']] <- 0
   new_tree <- new('TreeMan', ndlst=ndlst, root=id,
                   ndmtrx=NULL)
+  new_tree <- pstMnp(new_tree)
+  new_tree <- updateSlts(new_tree)
   new_tree
 }
 
 # TREE FUNCTIONS
 
-#' @name getTreeAge
+#' @name getAge
 #' @title Get age of tree
 #' @description Returns age, numeric, of tree
-#' @details This can also be achieved with \code{tree['age']} but will
-#' only work if the the tree has been updated with \code{updateTree()}.
-#' For faster computation, especially within function that perform multiple
-#' tree manipulations where the whole tree doesn't need updating, use this function.
-#' Parallelizable.
+#' @details Calculates the age of a tree, determined as the maximum tip to root
+#' distance.
 #' @param tree \code{TreeMan} object
 #' @param parallel logical, make parallel?
 #' @seealso
-#' \code{\link{updateTree}}, 
+#' \code{\link{updateSlts}}, 
 #' \url{https://github.com/DomBennett/treeman/wiki/get-methods}
 #' @export
 #' @examples
 #' library(treeman)
 #' tree <- randTree(10)
-#' (getTreeAge(tree))
-getTreeAge <- function(tree, parallel=FALSE) {
+#' (getAge(tree))
+getAge <- function(tree, parallel=FALSE) {
   tids <- tree@tips
-  if(tree@updtd) {
+  if(!is.null(tree@ndmtrx)) {
     all_ids <- tree@all
     spns <- .getSltSpns(tree@ndlst)
     res <- .getTreeAgeFrmMtrx(tree@ndmtrx, all_ids, tids, spns, parallel)