Created new _nds_ functions based around nd mat

NAMESPACE

@@ -73,7 +73,7 @@ importFrom(stats,runif)
 importFrom(utils,combn)
 importFrom(utils,write.table)
 useDynLib(treeman)
+useDynLib(treeman,cFindPrids)
 useDynLib(treeman,cGetNdPrids)
 useDynLib(treeman,cGetNdPtids)
 useDynLib(treeman,cGetNdsMat)
-useDynLib(treeman,findPrids)

R/calc-methods.R

@@ -156,13 +156,14 @@ calcOvrlp <- function(tree, ids_1, ids_2, nrmlsd=FALSE, ...) {
 #' tree_1 <- randTree(10)
 #' tree_2 <- randTree(10)
 #' calcDstBLD(tree_1, tree_2)
+
 calcDstBLD <- function(tree_1, tree_2, nrmlsd=FALSE, ...) {
   n1 <- tree_1@nds[!tree_1@nds == tree_1@root]
   n2 <- tree_2@nds[!tree_2@nds == tree_2@root]
-  c1 <- getNdsKids(tree_1, n1, ...)
-  c2 <- getNdsKids(tree_2, n2, ...)
-  s1 <- getNdsSlt(tree_1, slt_nm="spn", ids=n1, ...)
-  s2 <- getNdsSlt(tree_2, slt_nm="spn", ids=n2, ...)
+  c1 <- getNdsKids(tree_1, n1)
+  c2 <- getNdsKids(tree_2, n2)
+  s1 <- getNdsSlt(tree_1, slt_nm="spn", ids=n1)
+  s2 <- getNdsSlt(tree_2, slt_nm="spn", ids=n2)
   d1 <- s2[match(c1, c2)]
   d1[which(is.na(d1))] <- 0
   d1 <- s1 - d1
@@ -261,22 +262,22 @@ calcPhyDv <- function(tree, tids, ...) {
 #' library(treeman)
 #' tree <- randTree(10)
 #' calcFrPrp(tree, tree['tips'])
-calcFrPrp <- function(tree, tids, ...) {
+calcFrPrp <- function(tree, tids, parallel=FALSE) {
   .calc <- function(tid) {
     ids <- c(tid, prids[[tid]])
     sum(spns[ids]/ns[ids])
   }
   all <- names(tree@ndlst)
   tids <- sapply(tree@ndlst, function(x) length(x[['ptid']]) == 0)
-  tids <- all[tids]
   nds_mat <- getNdsMat(tree, all)
   prids <- apply(nds_mat, 2, function(x) all[x])
-  ns <- apply(nds_mat, 1, sum)
+  ns <- apply(nds_mat, 1, function(x) sum(tids & x))
   rm(nds_mat)
   ns[ns == 0] <- 1  # prevent division by 0
   spns <- sapply(tree@ndlst, function(x) x[['spn']])
+  tids <- all[tids]
   l_data <- data.frame(tid=tids, stringsAsFactors=FALSE)
-  plyr::mdply(.data=l_data, .fun=.calc, ...)[ ,2]
+  res_2 <- plyr::mdply(.data=l_data, .fun=.calc, .parallel=parallel)[ ,2]
 }
 
 #' @name calcDstMtrx

R/gen-methods.R

@@ -51,6 +51,16 @@ randTree <- function(n, update=TRUE, parallel=FALSE) {
   tree <- new('TreeMan', ndlst=ndlst, root='n1')
   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
 }

R/get-methods.R

@@ -36,7 +36,6 @@
 #' prids <- apply(res, 2, function(x) all[x])
 getNdsMat <- function(tree, qry_ids) {
   res <- .getNdsMat(tree@ndlst, qry_ids)
-  res <- res > 0
   rownames(res) <- names(tree@ndlst)
   colnames(res) <- qry_ids
   res
@@ -244,6 +243,7 @@ getNdsPrdst <- function(tree, ids) {
   res <- .getNdsMat(tree@ndlst, ids)
   all <- sapply(tree@ndlst, function(x) x[['spn']])
   res <- apply(res, 2, function(x) sum(all[x]))
+  res <- res + all[ids]
   names(res) <- ids
   res
 }
@@ -328,13 +328,18 @@ getNdKids <- function(tree, id) {
 #' library(treeman)
 #' tree <- randTree(10)
 #' getNdsKids(tree, id=tree['nds'])
-getNdsKids <- function(tree, ids, ...) {
+getNdsKids <- function(tree, ids) {
   # TODO: make parallel
-  tids <- sapply(tree@ndlst, function(x) length(x[['ptid']]) == 0)
-  tids <- names(tids)[tids]
-  res <- .getNdsMat(tree@ndlst, tids)
-  is <- match(ids, names(tree@ndlst))
-  res <- apply(res[is, ], 1, function(x) tids[x])
+  if(length(ids) <= 1) {
+    res <- getNdKids(tree, ids)
+    res <- list(res)
+  } else {
+    tids <- sapply(tree@ndlst, function(x) length(x[['ptid']]) == 0)
+    tids <- names(tids)[tids]
+    res <- .getNdsMat(tree@ndlst, tids)
+    is <- match(ids, names(tree@ndlst))
+    res <- apply(res[is, ], 1, function(x) tids[x])
+  }
   names(res) <- ids
   res
 }

R/manip-methods.R

@@ -22,7 +22,7 @@ rmTips <- function(tree, tid, drp_intrnl=TRUE) {
   # internal
   .rmTip <- function(tid) {
     # get sister IDs
-    sids <- .getSstr(ndlst, tid)
+    sids <- .getNdSstr(ndlst, tid)
     # get prid
     prid <- ndlst[[tid]][['prid']][[1]]
     # remove tid
@@ -54,6 +54,7 @@ rmTips <- function(tree, tid, drp_intrnl=TRUE) {
   sapply(tid, .rmTip)
   tree@ndlst <- ndlst
   tree@root <- rid
+  tree@updtd <- FALSE
   tree
 }
 

R/ndlst-methods.R

@@ -1,3 +1,18 @@
+# Attemp for making getNdsMat run in parallel
+# ... actually made it slower
+# ntids <- length(tids)
+# n <- foreach::getDoParWorkers()
+# nparts <- ntids %/% n
+# parts <- c(seq(1, ntids - 1, nparts), ntids + 1)
+# res <- foreach (i=2:length(parts), .combine="cbind") %dopar% {
+#   tids <- tids[parts[i-1]:(parts[i] - 1)]
+#   res <- .Call("cGetNdsMat", PACKAGE="treeman",
+#                as.integer(length(nids)),
+#                as.integer(tids),
+#                as.integer(prids))
+#   res
+# }
+
 # MULTIPLE NDS
 #' @useDynLib treeman cGetNdsMat
 .getNdsMat <- function(ndlst, qry_ids) {
@@ -11,6 +26,7 @@
                as.integer(tids),
                as.integer(prids))
   res <- res > 0
+  res
 }
 
 # SINGLE ND
@@ -35,7 +51,7 @@
 }
 
 .getNdPrdst <- function(ndlst, id) {
-  prids <- .getPrids(ndlst, id)
+  prids <- .getNdPrids(ndlst, id)
   sum(sapply(ndlst[prids], function(x) x[['spn']])) +
     ndlst[[id]][['spn']]
 }
@@ -53,13 +69,13 @@
 }
 
 .getNdKids <- function(ndlst, id) {
-  ptids <- .getPtids(ndlst, id)
+  ptids <- .getNdPtids(ndlst, id)
   kids <- sapply(ndlst[ptids], function(x) length(x[['ptid']]) == 0)
   ptids[as.logical(kids)]
 }
 
 .getNdPD <- function(ndlst, id) {
-  ptids <- .getPtids(ndlst, id)
+  ptids <- .getNdPtids(ndlst, id)
   if(length(ptids) > 0) {
     res <- sum(sapply(ndlst[ptids], function(x) x[['spn']]))
   } else {
@@ -73,6 +89,6 @@
 .getTreeAge <- function(ndlst) {
   tids <- sapply(ndlst, function(x) length(x[['ptid']]) == 0)
   tids <- as.integer(which(tids))
-  tip_prdsts <- sapply(tids, .getPrdst, ndlst=ndlst)
+  tip_prdsts <- sapply(tids, .getNdPrdst, ndlst=ndlst)
   max(tip_prdsts)
 }

R/node-declaration.R

@@ -4,8 +4,8 @@
     spn <- pd <- prdst <- numeric()
   } else {
     spn <- nd[['spn']]
-    pd <- .getPD(tree@ndlst, id)
-    prdst <- .getPrdst(tree@ndlst, id)
+    pd <- .getNdPD(tree@ndlst, id)
+    prdst <- .getNdPrdst(tree@ndlst, id)
   }
   if(length(tree@age) > 0) {
     age <- tree@age - prdst
@@ -17,7 +17,7 @@
   } else {
     txnym <- nd[['txnym']]
   }
-  kids <- names(tree@ndlst)[.getKids(tree@ndlst, id)]
+  kids <- names(tree@ndlst)[.getNdKids(tree@ndlst, id)]
   new('Node', id=nd[['id']], spn=spn, prid=as.character(nd[['prid']][1]),
      ptid=as.character(nd[['ptid']]), kids=as.character(kids),
      nkids=length(kids), pd=pd, txnym=txnym, prdst=prdst,

R/read-write-methods.R

@@ -82,8 +82,6 @@ writeTree <- function(tree, file, ndLabels=function(nd){
 #' @param ... \code{plyr} arguments
 #' @seealso
 #' \code{\link{writeTree}}, \code{\link{randTree}}, \url{https://en.wikipedia.org/wiki/Newick_format}
-#' @useDynLib treeman
-#' @useDynLib treeman findPrids
 #' @export
 #' @examples
 #' library(treeman)
@@ -104,6 +102,8 @@ readTree <- function(file=NULL, text=NULL, update=TRUE, ...) {
   tree
 }
 
+#' @useDynLib treeman
+#' @useDynLib treeman cFindPrids
 .readTree <- function(trstr, update) {
   # Internals
   .idspn <- function(i) {
@@ -151,7 +151,7 @@ readTree <- function(file=NULL, text=NULL, update=TRUE, ...) {
   # gen prids
   opns <- gregexpr("\\(", trstr)[[1]]
   clss <- gregexpr("\\)", trstr)[[1]]
-  prids <- .Call("findPrids", PACKAGE="treeman",
+  prids <- .Call("cFindPrids", PACKAGE="treeman",
                  as.integer(nds),
                  as.integer(clss),
                  as.integer(opns))
@@ -170,6 +170,16 @@ readTree <- function(file=NULL, text=NULL, update=TRUE, ...) {
   tree <- new('TreeMan', ndlst=ndlst, root=ids[root])
   if(update) {
     tree <- updateTree(tree)
+  } else {
+    # init basic slots
+    tree@updtd <- FALSE
+    tree@tips <- sort(ids[tids])
+    tree@ntips <- length(tids)
+    tree@nds <- sort(ids[ids != tree@tips])
+    tree@nnds <- length(tree@nds)
+    tree@all <- names(tree@ndlst)
+    tree@nall <- length(tree@all)
+    tree@wspn <- any(spns > 0)
   }
   tree
 }

R/set-methods.R

@@ -33,6 +33,7 @@ setPD <- function(tree, val) {
   spns <- getNdsSlt(tree, ids=tree@all, slt_nm="spn")
   spns <- spns/(tree@pd/val)
   tree <- setNdsSpn(tree, ids=tree@all, vals=spns)
+  tree@updtd <- FALSE
   tree
 }
 
@@ -58,6 +59,7 @@ setAge <- function(tree, val) {
   spns <- getNdsSlt(tree, ids=tree@all, slt_nm="spn")
   spns <- spns/(tree@age/val)
   tree <- setNdsSpn(tree, ids=tree@all, vals=spns)
+  tree@updtd <- FALSE
   tree
 }
 
@@ -83,6 +85,7 @@ setAge <- function(tree, val) {
 #' viz(tree)
 setNdSpn <- function(tree, id, val) {
   tree@ndlst[[id]][['spn']] <- val
+  tree@updtd <- FALSE
   tree
 }
 
@@ -119,6 +122,7 @@ setNdsSpn <- function(tree, ids, vals, ...) {
   ndlst <- plyr::mlply(l_data, .fun=.reset, ...)
   ndlst <- ndlst[1:length(ndlst)]
   tree@ndlst[ids] <- ndlst
+  tree@updtd <- FALSE
   tree
 }
 
@@ -142,6 +146,7 @@ setNdsSpn <- function(tree, ids, vals, ...) {
 #' summary(tree)
 setTol <- function(tree, tol) {
   tree@tol <- tol
+  tree@updtd <- FALSE
   tree
 }
 
@@ -221,6 +226,7 @@ setNdsID <- function(tree, ids, vals, ...) {
   tree@ext <- .rplcS4('ext')
   tree@exc <- .rplcS4('exc')
   tree@root <- .rplcS4('root')
+  tree@updtd <- FALSE
   tree
 }
 
@@ -246,6 +252,7 @@ setNdsID <- function(tree, ids, vals, ...) {
 #' (getNdSlt(tree, id='t1', slt_nm='binary_val'))
 setNdOther <- function(tree, id, val, slt_nm) {
   tree@ndlst[[id]][slt_nm] <- val
+  tree@updtd <- FALSE
   tree
 }
 
@@ -275,5 +282,6 @@ setNdsOther <- function(tree, ids, vals, slt_nm, ...) {
   l_data <- data.frame(id=ids, val=vals,
                        stringsAsFactors=FALSE)
   plyr::m_ply(.data=l_data, .fun=.set)
+  tree@updtd <- FALSE
   tree
 }

R/treeman-declaration.R

@@ -28,6 +28,7 @@
 #' @slot ply logical, is tree bifurcating
 #' @slot tol numeric of tolerance for determining extant
 #' @slot root character of node id of root, if no root then empty character
+#' @slot updtd logical, if tree slots have been updated since initiation or change
 #' @details
 #' A \code{TreeMan} object holds a list of nodes. The idea of the \code{TreeMan}
 #' class is to make adding and removing nodes as similar as possible to adding
@@ -89,6 +90,7 @@ setClass('TreeMan', representation=representation(
   ultr='logical',        # logical, do all tips end at 0
   ply='logical',         # logical, is tree bifurcating
   tol='numeric',         # numeric of tolerance for determining extant
+  updtd='logical',       # logical, if tree has been updated since a change
   root='character'),     # character of node id of root, if no root then empty character
   prototype=prototype(tol=1e-8), validity=fastCheckTreeMan)
 
@@ -169,8 +171,8 @@ setMethod('str', c('object'='TreeMan'),
 #' @exportMethod summary
 setMethod('summary', c('object'='TreeMan'),
           function(object){
-            if(length(object@ply) == 0) {
-              stop("Tree is not updated. Use `updateTree()`")
+            if(!object@updtd) {
+              stop("Tree is not updated since change or initiation. Use `updateTree()`")
             }
             msg <- 'Tree (TreeMan Object):\n'
             msg <- paste0(msg, '  + ', object@ntips, ' tips\n')

R/update-methods.R

@@ -27,7 +27,7 @@ updateTree <- function(tree) {
   tree@nnds <- length(tree@nds)
   tree@all <- names(tree@ndlst)
   tree@nall <- length(tree@all)
-  tree@wspn <- any(sapply(tree@ndlst, function(n) n[['spn']] != 0))
+  tree@wspn <- any(sapply(tree@ndlst, function(n) n[['spn']] > 0))
   if(tree@wspn) {
     if(length(tree@root) > 0) {
       tip_prdsts <- getNdsPrdst(tree, tree@tips)
@@ -48,5 +48,6 @@ updateTree <- function(tree) {
     tree@ultr <- logical()
   }
   tree@ply <- any(sapply(tree@ndlst, function(n) length(n[['ptid']]) > 2))
+  tree@updtd <- TRUE
   initialize(tree)
 }

src/read_tools.c

@@ -2,7 +2,7 @@
 #include <Rinternals.h>
 
 // Return vector of position of prid in Newick string
-SEXP findPrids(SEXP nds_, SEXP clss_, SEXP opns_)
+SEXP cFindPrids(SEXP nds_, SEXP clss_, SEXP opns_)
 {
   SEXP res;
   int n = length(nds_);