Added ultr to treeman

NAMESPACE

@@ -48,6 +48,7 @@ export(getSpnsAge)
 export(getSubtree)
 export(getTxnyms)
 export(getUnqNds)
+export(isUltrmtrc)
 export(loadTreeMan)
 export(pinTips)
 export(pstMnp)

R/get-spcl-methods.R

@@ -1,4 +1,27 @@
 
+# ULTRAMETRIC
+#' @name isUltrmtrc
+#' @title Is tree ultrametric?
+#' @description Return TRUE if all tips end at 0, else FALSE.
+#' @details Returns a boolean. This function works in the background
+#' for the \code{['ultr']} slot in a \code{TreeMan} object.
+#' @param tree \code{TreeMan} object
+#' @param tol zero tolerance
+#' @seealso
+#' \code{\link{getLvng}}, \code{\link{getDcsd}}
+#' @export
+#' @examples
+#' library(treeman)
+#' tree <- randTree(10)
+#' (isUltrmtrc(tree))
+isUltrmtrc <- function(tree, tol=1e-8) {
+  dead <- .livingOrDesceased(tree, tol=tol, bool=FALSE)
+  if(length(dead) > 0) {
+    return(FALSE)
+  }
+  TRUE
+}
+
 # EXTINCT/EXTANT
 .livingOrDesceased <- function(tree, tol=1e-8, bool) {
   if(!is.null(tree@ndmtrx)) {
@@ -29,7 +52,7 @@
 #' @param tree \code{TreeMan} object
 #' @param tol zero tolerance
 #' @seealso
-#' \code{\link{getLvng}}, 
+#' \code{\link{getLvng}}, \code{\link{isUltrmtrc}},
 #' \url{https://github.com/DomBennett/treeman/wiki/get-methods}
 #' @export
 #' @examples
@@ -47,7 +70,7 @@ getDcsd <- function(tree, tol=1e-8) {
 #' @param tree \code{TreeMan} object
 #' @param tol zero tolerance
 #' @seealso
-#' \code{\link{getDcsd}}, 
+#' \code{\link{getDcsd}}, \code{\link{isUltrmtrc}},
 #' \url{https://github.com/DomBennett/treeman/wiki/get-methods}
 #' @export
 #' @examples

R/treeman-declaration.R

@@ -130,9 +130,15 @@ setMethod('[', c('TreeMan', 'character'),
             slt_nms <- slt_nms[slt_nms != 'ndmtrx']
             slt_nms <- slt_nms[slt_nms != 'tinds']
             slt_nms <- slt_nms[slt_nms != 'prinds']
+            # ultr is special, shouldn't be updated when updateSlts()
+            # too slow to calculate. Instead only calc if called.
+            if(i == 'ultr') {
+              return(isUltrmtrc(tree))
+            }
             if(!i %in% slt_nms) {
-              slt_nms <- paste0(slt_nms, collapse=', ')
-              stop(paste0('`', i, '` not a tree slot. Available slots: ', slt_nms))
+              slt_nms <- paste0(c(slt_nms, 'ultr'), collapse=', ')
+              stop(paste0('`', i, '` not a tree slot. Available slots: ',
+                          slt_nms))
             }
             slot(x, i)
           })

tests/testthat/test-get-spcl-methods.R

@@ -4,6 +4,12 @@ library(testthat)
 
 # RUNNING
 context('Testing \'get-spcl-methods\'')
+test_that('isUltrmtrc() works',{
+  tree <- randTree(10, wndmtrx=sample(c(TRUE, FALSE), 1))
+  expect_false(isUltrmtrc(tree))
+  tree <- ultrTree(tree)
+  expect_true(isUltrmtrc(tree))
+})
 test_that('getDcsd() works', {
   tree <- randTree(10, wndmtrx=sample(c(TRUE, FALSE), 1))
   dead <- getDcsd(tree)