Strictly no special characters

letters, numbers and underscores only

R/check_methods.R

@@ -25,9 +25,19 @@ 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 id
+    test_id <- is.character(nd[['id']]) & 'id' %in% names(nd)
+    # id must contain no special characters
+    test_spcl_chrs <- test_id && !grepl('[^0-9a-zA-Z_]', nd[['id']])
+    # txnyms
+    test_txnym <- TRUE
+    if('txnym' %in% names(nd)) {
+      test_txnym <- is.character(nd[['txnym']])
+      for(txnym in nd[['txnym']]) {
+        test_txnym <- test_txnym && !grepl('[^0-9a-zA-Z_]', txnym)
+      }
+    }
     # must have either prid/ptid or both
     test_slts <- ('ptid' %in% names(nd) | 'prid' %in% names(nd))
     test_valid_nd <- nd[['id']] %in% nds  # nd id must be known
@@ -44,7 +54,8 @@ checkTreeMan <- function(object) {
     test_root <- rid != nd[['id']] |
       (rid == nd[['id']] & rid == nd[['prid']])
     bool <- test_id & test_valid_nd & test_prid &
-      test_ptid & test_sr & test_circ & test_slts
+      test_ptid & test_sr & test_circ & test_slts &
+      test_spcl_chrs & test_txnym
     if(length(bool) > 0 && bool) {
       return(TRUE)
     }

R/manip-methods.R

@@ -67,6 +67,7 @@ rmTips <- function(tree, tids, drp_intrnl=TRUE, progress="none") {
 #' @description Returns a tree with a new tip ID added
 #' @details User must provide new tip ID, the ID of the node
 #' which will become the new tip's sister, and new branch lengths.
+#' The tip ID must only contain letters numbers and underscores.
 #' Optionally, user can specify the IDs for the new parental interal nodes.
 #' Ensure that the \code{strt_age} is greater than the \code{end_age}, and that
 #' the \code{strt_age} falls within the age span of the sister ID. Otherwise, negative
@@ -106,6 +107,9 @@ addTip <- function(tree, tid, sid, strt_age=NULL,
   # tnd, tid -- new tip node and id
   # pnd, pid -- new parent node and id
   # gpnd, gpid -- grand parent (prid of old sister)
+  if(grepl('[^a-zA-Z_0-9]', tid)) {
+    stop(paste0('Unsuitable characters in tid [', tid, ']'))
+  }
   # init new nodes
   tnd <- list('id'=tid, 'prid'=pid, 'ptid'=character(), 'spn'=0)
   snd <- ndlst[[sid]]
@@ -210,6 +214,15 @@ pinTips <- function(tree, tids, lngs, end_ages, tree_age) {
       }
     }
   }
+  .testLngs <- function(lng) {
+    for(l in lng) {
+      if(grepl('[^a-zA-Z_0-9]', l)) {
+        stop(paste0('Unsuitable characters in [', l, ']'))
+      }
+    }
+    NULL
+  }
+  sapply(lngs, .testLngs)
   .getTxnyms <- function(txnym, ...) {
     txnym
   }

R/server-methods.R

@@ -5,9 +5,11 @@
 #' @details For each node, all the descendants are searched, the taxonomic lineages returned and
 #' then searched to find the lowest shared name.
 #' All the tip labels are searched against a specified taxonomic database through the GNR and NCBI.
+#' (So far only tested with NCBI database.)
 #' @param tree TreeMan object
 #' @param cache T/F, create a local cache of downloaded names?
 #' @param parent specify parent of all names to prevent false names
+#' @param clean T/F, ensure returned names contain no special characters?
 #' @seealso
 #' \code{\link{taxaResolve}}, \code{\link{setTxnyms}}, \code{\link{getTxnyms}}
 #' @export
@@ -20,7 +22,7 @@
 #' print(nd_labels)
 # TODO: add compatibility with other GNR datasources
 # TODO: catalogue of life, unlike NCBI, does not keep lineages and rank lengths constant between names
-searchTxnyms <- function (tree, cache=FALSE, parent=NULL) {
+searchTxnyms <- function (tree, cache=FALSE, parent=NULL, clean=TRUE) {
   # Use GNR to label all nodes in a phylogeny
   # first replace all _ with spaces
   tip_labels <- gsub ('_', ' ', tree@tips)
@@ -45,6 +47,10 @@ searchTxnyms <- function (tree, cache=FALSE, parent=NULL) {
       }
     }
   }
+  if(clean) {
+    nd_labels <- gsub('\\s', '_', nd_labels)
+    nd_labels <- gsub('[^a-zA-Z_0-9]', '', nd_labels)
+  }
   nd_labels
 }
 

R/set-methods.R

@@ -3,6 +3,8 @@
 #' @description Return a tree with txnyms added to specified nodes
 #' @details Returns a tree. Specify the taxonomic groups for nodes in a tree
 #' by providing a vector or list named by node IDs. Takes output from \code{searchTxnyms}.
+#' Only letters, numbers and underscores allowed. To remove special characters use regular
+#' expressions, e.g. \code{gsub(['a-zA-Z0-9_'], '', txnym)}
 #' @param tree \code{TreeMan} object
 #' @param txnyms named vector or list
 #' @seealso
@@ -14,11 +16,20 @@
 #' library(treeman)
 #' data(mammals)
 #' # let's change the txnym for humans
+#' # what's its summary before we change anything?
+#' summary(mammals[['Homo_sapiens']])
+#' # now let's add Hominini
 #' new_txnym <- list('Homo_sapiens'=c('Hominini', 'Homo'))
 #' mammals <- setTxnyms(mammals, new_txnym)
 #' summary(mammals[['Homo_sapiens']])
 setTxnyms <- function(tree, txnyms) {
   .add <- function(nid) {
+    for(txnym in txnyms[[nid]]) {
+      if(grepl('[^a-zA-Z_0-9]', txnym)) {
+        stop(paste0('Unsuitable characters in [',
+                    txnym, ']'))
+      }
+    }
     tree@ndlst[[nid]][['txnym']] <<- txnyms[[nid]]
   }
   pull <- names(txnyms) %in% names(tree@ndlst)
@@ -143,8 +154,9 @@ setNdsSpn <- function(tree, ids, vals, parallel=FALSE, progress="none") {
 #' @title Set the ID of a node
 #' @description Return a tree with the ID of a node altered.
 #' @details IDs cannot be changed directly for the \code{TreeMan} class. To change an
-#' ID use this function. Warning: all IDs must be unique, avoid spaces in IDs.
-#' Use \link{\code{updateSlts}} after running.
+#' ID use this function. Warning: all IDs must be unique, avoid spaces in IDs and only
+#' use letters, numbers and underscores.
+#' Use \code{\link{updateSlts}} after running.
 #' @param tree \code{TreeMan} object
 #' @param id id to be changed
 #' @param val new id
@@ -166,7 +178,7 @@ setNdID <- function(tree, id, val) {
 #' @title Set the IDs of multiple nodes
 #' @description Return a tree with the IDs of nodes altered.
 #' @details Runs \code{setNdID()} over multiple nodes. Warning: all IDs must be unique,
-#' avoid spaces in IDs. Parellizable.
+#' avoid spaces in IDs, only use numbers, letters and underscores. Parellizable.
 #' @param tree \code{TreeMan} object
 #' @param ids ids to be changed
 #' @param vals new ids
@@ -184,6 +196,12 @@ setNdID <- function(tree, id, val) {
 #' summary(tree)
 setNdsID <- function(tree, ids, vals, parallel=FALSE, progress="none") {
   # internals
+  .testSpcls <- function(id) {
+    if(grepl('[^a-zA-Z_0-9]', id)) {
+      stop(paste0('Unsuitable characters in [', id, ']'))
+    }
+    NULL
+  }
   .rplcS4 <- function(slt) {
     if(any(slot(tree, slt) %in% ids)) {
       mtchs <- match(slot(tree, slt), ids)
@@ -206,6 +224,7 @@ setNdsID <- function(tree, ids, vals, parallel=FALSE, progress="none") {
     nd[['prid']] <- .rplc("prid")
     nd
   }
+  sapply(vals, .testSpcls)
   l_data <- data.frame(i=1:length(tree@ndlst), stringsAsFactors=FALSE)
   ndlst <- plyr::mlply(l_data, .fun=.reset, .parallel=parallel, .progress=progress)
   ndlst <- ndlst[1:length(ndlst)]

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

@@ -91,8 +91,8 @@ test_that("getNdLng() works", {
   tree <- getTestTree(n)
   txnyms <- paste0('txnymns_', 1:tree['nall'])
   names(txnyms) <- tree['all']
-  txnyms[tree['root']] <- 'this is the root'
+  txnyms[tree['root']] <- 'this_is_the_root'
   tree <- setTxnyms(tree, txnyms)
   lng <- getNdLng(tree, sample(tree['tips'], 1))
-  expect_true(lng[[1]] == 'this is the root')
+  expect_true(lng[[1]] == 'this_is_the_root')
 })

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

@@ -88,9 +88,9 @@ test_that("getNdsLng() works", {
   tree <- getTestTree(n)
   txnyms <- paste0('txnymns_', 1:tree['nall'])
   names(txnyms) <- tree['all']
-  txnyms[tree['root']] <- 'this is the root'
+  txnyms[tree['root']] <- 'this_is_the_root'
   tree <- setTxnyms(tree, txnyms)
   lngs <- getNdsLng(tree, tree['tips'])
-  test <- all(sapply(lngs, function(x) x[[1]] == 'this is the root'))
+  test <- all(sapply(lngs, function(x) x[[1]] == 'this_is_the_root'))
   expect_true(test)
 })