Created RW functions for .trmn

NAMESPACE

@@ -48,6 +48,7 @@ export(pinTips)
 export(pstMnp)
 export(randTree)
 export(readTree)
+export(readTrmn)
 export(rmNdmtrx)
 export(rmTips)
 export(searchTxnyms)
@@ -64,6 +65,7 @@ export(taxaResolve)
 export(unblncdTree)
 export(updateSlts)
 export(writeTree)
+export(writeTrmn)
 exportClasses(Node)
 exportClasses(TreeMan)
 exportClasses(TreeMen)

R/read-write-methods.R

@@ -196,5 +196,100 @@ readTree <- function(file=NULL, text=NULL, wndmtrx=TRUE, parallel=FALSE,
   tree
 }
 
+#' @name writeTrmn
+#' @title Write a .trmn tree
+#' @description Write to disk a \code{TreeMan} object using the .trmn treefile
+#' @details Write a single tree to file using the .trmn format.
+#' It is faster to read and write tree files using treeman with the .trmn file format.
+#' In addition it is possible to encode more information than possible with the
+#' Newick, e.g. taxonomic information can be recorded as well.
+#' @param tree TreeMan object
+#' @param file file path
+#' @seealso
+#' \code{\link{readTrmn}},
+#' \code{\link{readTree}},\code{\link{writeTree}},
+#' \code{\link{randTree}},
+#' @export
+#' @examples
+#' library(treeman)
+#' tree <- randTree(10)
+#' writeTrmn(tree, file='test.trmn')
+#' tree <- readTrmn('test.trmn')
+#' file.remove('test.trmn')
+writeTrmn <- function(tree, file) {
+  res <- data.frame(prind=tree@prinds)
+  res[['id']] <- names(tree@ndlst)
+  if(tree@wspn) {
+    res[['spn']] <- sapply(tree@ndlst, function(x) x[['spn']])
+  }
+  if(tree@wtxnyms) {
+    res[['txnym']] <- sapply(tree@ndlst,
+                             function(x) paste0(x[['txnym']], collapse='|'))
+  }
+  write.csv(res, file=file, quote=FALSE, row.names=FALSE)
+}
 
-# TODO: develop .trmn file format
+#' @name readTrmn
+#' @title Read a .trmn tree
+#' @description Return a \code{TreeMan} object from a .trmn treefile
+#' @details Read a single tree from a file using the .trmn format.
+#' It is faster to read and write tree files using treeman with the .trmn file format.
+#' In addition it is possible to encode more information than possible with the
+#' Newick, e.g. taxonomic information can be recorded as well.
+#' @param file file path
+#' @param wndmtrx T/F add node matrix? Default TRUE.
+#' @seealso
+#' \code{\link{writeTrmn}},
+#' \code{\link{readTree}},\code{\link{writeTree}},
+#' \code{\link{randTree}},
+#' @export
+#' @examples
+#' library(treeman)
+#' tree <- randTree(10)
+#' writeTrmn(tree, file='test.trmn')
+#' tree <- readTrmn('test.trmn')
+#' file.remove('test.trmn')
+readTrmn <- function(file, wndmtrx=TRUE) {
+  .add <- function(i) {
+    nd <- vector("list", length=4)
+    names(nd) <- c('id', 'ptid', 'prid', 'spn')
+    nd[['id']] <- ids[i]
+    nd[['spn']] <- spns[i]
+    nd[['prid']] <- ids[prinds[i]]
+    nd[['ptid']] <- ptids[ptnds_pool == i]
+    nd
+  }
+  inpt <- read.csv(file, stringsAsFactors=FALSE)
+  prinds <- inpt[['prind']]
+  # all internal nodes should occur more than once (twice for bifurcating trees)
+  prind_test <- sum(prinds == 1:length(prinds)) == 1
+  prind_test <- all(table(prinds) > 1) & prind_test
+  if(!prind_test) {
+    stop('Tree is corrupted, check node structure is hierarchical.')
+  }
+  ids <- inpt[['id']]
+  if('spn' %in% names(inpt)) {
+    spns <- inpt[['spn']]
+  } else {
+    spns <- rep(0 , length(ids))
+  }
+  tinds <- which(!1:length(ids) %in% prinds)
+  root <- which(1:length(prinds) == prinds)
+  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)
+  tree <- updateSlts(tree)
+  if('txnym' %in% names(inpt)) {
+    txnyms <- strsplit(inpt[['txnym']], '\\|')
+    names(txnyms) <- ids
+    tree <- setTxnyms(tree, txnyms)
+  }
+  if(wndmtrx) {
+    tree <- addNdmtrx(tree)
+  }
+  tree
+}

tests/testthat/test-rw-methods.R

@@ -28,6 +28,37 @@ test_that('writeTree() works', {
   t2_age <- getAge(t2)
   expect_that(t1_age, equals(t2_age))
 })
+test_that('writeTrmn() works', {
+  t1 <- randTree(100)
+  writeTrmn(t1, 'test.trmn')
+  t2 <- readTrmn('test.trmn')
+  expect_that(t1['ntips'], equals(t2['ntips']))
+  expect_that(t1['nnds'], equals(t2['nnds']))
+  expect_that(t1['pd'], equals(t2['pd']))
+  t1_age <- getAge(t1)
+  t2_age <- getAge(t2)
+  expect_that(t1_age, equals(t2_age))
+  # test example with taxonomy
+  data(mammals)
+  ape_id <- getPrnt(mammals, ids=c('Homo_sapiens', 'Hylobates_concolor'))
+  tree <- getSubtree(mammals, id=ape_id)
+  writeTrmn(tree, file='test.trmn')
+  tree <- readTrmn('test.trmn')
+  expect_true(tree@wtxnyms)
+})
+test_that('readTrmn() works', {
+  tree <- randTree(10)
+  writeTrmn(tree, 'test.trmn')
+  t1 <- readTrmn('test.trmn')
+  tree@wspn <- FALSE
+  writeTrmn(tree, 'test.trmn')
+  t2 <- readTrmn('test.trmn')
+  expect_true(t1@wspn)
+  expect_true(!t2@wspn)
+})
 if(file.exists('test.tre')) {
   file.remove('test.tre')
+}
+if(file.exists('test.trmn')) {
+  file.remove('test.trmn')
 }