Updates for documentation

R/ndlst-methods.R

@@ -160,7 +160,7 @@
 # SPECIAL
 
 #' @useDynLib treeman cGetNdmtrx
-.getNdmtrxFrmLst <- function(ndlst) {
+.getNdmtrxFrmLst <- function(ndlst, shared=FALSE, ...) {
   # return matrix of 01s for ids that descend from 
   message('Note, trees with `ndmtrx` cannot be saved and loaded using `save()` or `savehistory()`.',
           ' Loading from these files may cause unusual behaviour.')
@@ -173,7 +173,7 @@
                as.integer(length(nids)),
                as.integer(qry_ids),
                as.integer(prids))
-  res <- bigmemory::as.big.matrix(res, shared=FALSE)
+  res <- bigmemory::as.big.matrix(res, shared=shared, ...)
   res
 }
 # Attemp for making getNdsMat run in parallel

R/node-declaration.R

@@ -68,14 +68,14 @@ setMethod ('as.character', c('x'='Node'),
 #' @exportMethod show
 setMethod ('show', 'Node',
            function(object){
-             cat(as.character(object))
+             cat(summary(object))
            })
 #' @rdname Node-class
 #' @aliases Node-method
 #' @exportMethod print
 setMethod ('print', 'Node',
            function(x){
-             print(as.character(x))
+             print(summary(x))
            })
 #' @rdname Node-class
 #' @aliases Node-method

R/update-methods.R

@@ -59,23 +59,26 @@ updateSlts <- function(tree) {
 #' large amounts of memory and has no impact on adding or removing tips.
 #' Note, trees with the node matrix can not be written to disk using the
 #' 'serialization format' i.e. with \code{save} or \code{saveRDS}.
+#' The matrix is generated with bigmemory's `as.big.matrix()`.
 #' @param tree \code{TreeMan} object
+#' @param shared T/F, should the bigmatrix be shared? See bigmemory documentation.
 #' @seealso
-#' \code{\link{updateSlts}}, \code{\link{rmNdmtrx}}
+#' \code{\link{updateSlts}}, \code{\link{rmNdmtrx}},
+#' \link{https://cran.r-project.org/web/packages/bigmemory/index.html}
 #' @export
 #' @examples
 #' # library(treeman)
 #' tree <- randTree(10, wndmtrx=FALSE)
 #' summary(tree)
 #' tree <- addNdmtrx(tree)
 #' summary(tree)
-addNdmtrx <- function(tree) {
+addNdmtrx <- function(tree, shared=FALSE, ...) {
   if(!checkTreeMan(tree)) {
     stop('Invalid tree')
   }
   if(is.null(tree@ndmtrx)) {
     # generate ndmtrx
-    tree@ndmtrx <- .getNdmtrxFrmLst(tree@ndlst)
+    tree@ndmtrx <- .getNdmtrxFrmLst(tree@ndlst, shared=shared, ...)
   }
   tree
 }

other/1_pinning.R

@@ -5,33 +5,44 @@ library(treeman)
 
 # DATA
 data(mammals)  # example mammal tree is 'taxonomically informed', all nodes have taxonyms
-# rslvd names (i.e. with lineages) not in mammals tree generated with MoreTreeTools::taxaResolve
-# load pre-generated dataset from github
+# rslvd names (i.e. with lineages) not in mammals tree generated with taxaResolve()
+# load pre-generated dataset from github, requires internet
 load(url("https://github.com/DomBennett/treeman/raw/master/other/1_pinning.RData"))
 
 # PARAMETERS
-n <- 100  # number of missing mammal species to pin
+n <- 1000  # number of missing mammal species to pin
 
-# PIN
+# CLEAN DATA
 rnds <- sample(1:nrow(rslvd_mammals), n)
 rslvd_mammals <- rslvd_mammals[rnds, ]
-lngs <- plyr::mlply(rslvd_mammals, function(lineage, ...) strsplit(lineage, '\\|')[[1]])
-tids <- gsub("\\s+", "_", rslvd_mammals$search_name)  # always replace spaces with _
+lngs <- lapply(rslvd_mammals$lineage, function(lineage, ...) strsplit(lineage, '\\|')[[1]])
+# remove everything before mammalia
+pull <- sapply(lngs, function(lineage) any(grepl('mammalia', lineage, ignore.case=TRUE)))
+lngs <- lngs[pull]
+lngs <- lapply(lngs, function(lineage) {
+  lineage[-1*(1:(which(grepl('mammalia', lineage, ignore.case=TRUE)) - 1))]
+  })
+# always replace spaces with _
+lngs <- lapply(lngs, function(x) gsub("\\s+", "_", x))
+tids <- gsub("\\s+", "_", rslvd_mammals$search_name)
+tids <- tids[pull]
+cat('[', sum(pull)*100/n, '%] random names are pinnable\n', sep='')
+
+# PIN
 ends <- rep(0, length(tids))  # all tips end in the present
-pinned_tree <- pinTips(tree=mammals, lngs=lngs, tids=tids, end_ages=ends, tree_age=166.2)
-pinned_tree <- updateTree(pinned_tree)
+tree_age <- getAge(mammals)
+pinned_tree <- pinTips(tree=mammals, lngs=lngs, tids=tids,
+                       end_ages=ends, tree_age=tree_age)
+pinned_tree <- updateSlts(pinned_tree)
 p_added <- sum(tids %in% pinned_tree['tips'])*100/n
 cat('[', p_added, '%] of n pinned to mammals\n', sep='')
 
-# VIZ
-library(MoreTreeTools)  # for conversion to phylo
-# taxonyms function not working
+# VIZ (using ape)
 txnym <- function(n) {
   # return taxonyms for node labels, combining any multiple entries with _
   paste0(n[['txnym']], collapse='_')
 }
 writeTree(pinned_tree, file='temp.tre', ndLabels = txnym)
-writeTree(pinned_tree, file='temp.tre')
 tree_phylo <- ape::read.tree('temp.tre')
 plot(tree_phylo, show.tip.label=FALSE, edge.width=0.5, type='fan', no.margin=FALSE,
      edge.color='lightsteelblue3')

other/ndmtrx_speed.R

@@ -0,0 +1,19 @@
+# MEASURE RUN DIFFERENCES BETWEEN WNDMTRX=T/F
+data(mammals)
+summary(mammals)
+m1 <- mammals
+m2 <- addNdmtrx(mammals)
+timings <- data.frame(ndlst=rep(NA, 5),
+                      ndmtrx=rep(NA, 5))
+rownames(timings) <- c('prids', 'ptids', 'prdsts',
+                       'ages', 'frprp')
+tree <- m1
+for(i in 1:2) {
+  timings['prids', i] <- system.time(prids <- getNdsPrids(tree, tree['all']))[[1]]
+  timings['ptids', i] <- system.time(ptids <- getNdsPtids(tree, tree['all']))[[1]]
+  timings['prdsts', i] <- system.time(prdsts <- getNdsPrdst(tree, tree['all']))[[1]]
+  timings['ages', i] <- system.time(ages <- getNdsAge(tree, tree['all'], getAge(tree)))[[1]]
+  timings['frprp', i] <- system.time(frprps <- calcFrPrp(tree, tree['tips']))[[1]]
+  tree <- m2
+}
+mean(timings[['ndlst']]/timings[['ndmtrx']]) # ndmtrx is 2-3 times faster