fixing issue #10

R/read.net.R

@@ -109,55 +109,55 @@ read.tree2 <- function(file = "", text = NULL, tree.names = NULL, skip = 0,
 {
   if (!is.null(text)) {
     if (!is.character(text))
-      stop("argument `text' must be of mode character")
+      stop("argument 'text' must be of mode character")
     tree <- text
   } else {
     tree <- scan(file = file, what = "", sep = "\n", quiet = TRUE,
                  skip = skip, comment.char = comment.char, ...)
   }
-
+  
   ## Suggestion from Eric Durand and Nicolas Bortolussi (added 2005-08-17):
   if (identical(tree, character(0))) {
     warning("empty character string.")
     return(NULL)
   }
-
-  tree <- gsub("[ \t]", "", tree)
-  tree <- gsub("''", "", tree)
-
-  single_quotes <- function(x, start = 1L) {
-    z <- unlist(gregexpr("'", x))
-    if (length(z) %% 2)
-      stop("wrong number of single quotes around labels")
+  
+  ## make a single string
+  if (length(tree) > 1) tree <- paste(tree, collapse = "")
+  
+  single_quotes <- function(x, z) {
+    x <- charToRaw(x)
+    z <- which(x == as.raw(39))
+    if (length(z) %% 2) stop("wrong number of single quotes around labels")
     l <- length(z) / 2
-    tmp <- strsplit(x, "'")[[1]]
-    ind_orig <- 2L * (1L:l)
-    tmp_label <- paste0("@_", start:(start + l - 1), "_@")
-    orig_label <- tmp[ind_orig]  #paste0("'", tmp[ind_orig], "'")
-    names(orig_label) <- tmp_label
-    for (i in 1:l) tmp[2 * i] <- tmp_label[i]
-    tmp <- paste0(tmp, collapse = "")
-    list(tmp, orig_label)
+    opening <- z[c(TRUE, FALSE)]
+    closing <- z[c(FALSE, TRUE)]
+    from <- c(1, closing + 1L)
+    to <- c(opening - 1L, length(x))
+    i <- mapply(":", from = from, to = to, SIMPLIFY = FALSE, USE.NAMES = FALSE)
+    keep <- lapply(i, function(i) x[i])
+    tmp_label <- paste0("IMPROBABLEPREFIX", 1:l, "IMPROBABLESUFFIX")
+    tmpLabsRaw <- lapply(tmp_label, charToRaw)
+    n <- 2 * l + 1L
+    res <- vector("list", n)
+    res[seq(1, n, 2)] <- keep
+    res[seq(2, n - 1, 2)] <- tmpLabsRaw
+    tree <<- rawToChar(unlist(res))
+    i <- mapply(":", from = opening, to = closing, SIMPLIFY = FALSE, USE.NAMES = FALSE)
+    orig_label <- lapply(i, function(i) x[i])
+    sapply(orig_label, rawToChar)
   }
-
-  ## replace labels with single quotes
-  z <- grepl("'", tree)
-  if (any(z)) {
-    Ntree <- length(tree)
-    tmp_label <- vector("list", Ntree)
-    for (i in 1:Ntree) {
-      if (z[i]) {
-        TMP <- single_quotes(tree[i])
-        tree[i] <- TMP[[1]]
-        tmp_label[[i]] <- TMP[[2]]
-      }
-    }
-  }
-
+
+  ## replace labels with single quotes (if needed)
+  SINGLE.QUOTES.FOUND <- grepl("'", tree)
+  if (SINGLE.QUOTES.FOUND) tmp_label <- single_quotes(tree)
+
   y <- unlist(gregexpr(";", tree))
-
-  ### replace comments may handle them different later on
-
+  if (all(y == -1))  {
+    warning("no semicolon(s) [end(s) of tree] found")
+    return(NULL)
+  }
+
   ## if one tree per line much faster
   if (identical(y, nchar(tree))) { # check if always one tree per line
     Ntree <- length(y)
@@ -166,9 +166,6 @@ read.tree2 <- function(file = "", text = NULL, tree.names = NULL, skip = 0,
       STRING[i] <- gsub("\\[[^]]*\\]", "", tree[i]) # delete comments (fix 2015-01-12)
     }
   } else {
-    ## tree <- paste0(tree)
-    ## tree <- unlist(strsplit(tree, ";"))
-    ## tree <- paste0(tree, ";")
     tree <- unlist(strsplit(tree, NULL))
     y <- which(tree == ";")
     Ntree <- length(y)
@@ -181,22 +178,22 @@ read.tree2 <- function(file = "", text = NULL, tree.names = NULL, skip = 0,
       STRING[i] <- gsub("\\[[^]]*\\]", "", tmp) # delete comments (fix 2015-01-12)
     }
   }
-
+  
   ## remove possible leading and trailing underscores
-  STRING <- gsub("^_+", "", STRING)
-  STRING <- gsub("_+$", "", STRING)
-
+  STRING <- gsub("^_+|_+$", "", STRING)
+  STRING <- gsub("[ \t]", "", STRING) # spaces and TABs within quoted labels are not deleted
+  
   getTreeName <- function(x) {
     res <- rep("", length(x))
     i <- regexpr("\\(", x)
     s <- i > 1
     if (any(s)) res[s] <- substr(x[s], 1, i[s] - 1)
     res
   }
-
+  
   tmpnames <- getTreeName(STRING)
   if (is.null(tree.names) && any(nzchar(tmpnames))) tree.names <- tmpnames
-
+  
   colon <- grep(":", STRING)
   if (!length(colon)) {
     stop("we need a network with branch lengths")
@@ -210,46 +207,43 @@ read.tree2 <- function(file = "", text = NULL, tree.names = NULL, skip = 0,
     # nocolon <- (1:Ntree)[!1:Ntree %in% colon]
     # obj[nocolon] <- lapply(STRING[nocolon], clado.build)
   }
-
-  for (i in 1:Ntree) {
-    if (z[i]) {
-      tmp_lab <- tmp_label[[i]]
-      tip.label <- obj[[i]]$tip.label
-      node.label <- obj[[i]]$node.label
-      ind <- match(tip.label, names(tmp_lab))
-      ind2 <- which(!is.na(ind))
-      if (length(ind2)) {
-        tip.label[ind2] <- tmp_lab[ind[ind2]]
-        tmp_lab <- tmp_lab[-ind[ind2]]
-      }
-
-      ind <- match(node.label, names(tmp_lab))
-      ind2 <- which(!is.na(ind))
-      if (length(ind2)) {
-        node.label[ind2] <- tmp_lab[ind[ind2]]
-        tmp_lab <- tmp_lab[-ind[ind2]]
+
+  if (SINGLE.QUOTES.FOUND) {
+    FOO <- function(x) {
+      i <- gsub("^IMPROBABLEPREFIX|IMPROBABLESUFFIX$", "", x)
+      tmp_label[as.integer(i)]
+    }
+    for (i in 1:Ntree) {
+      lab <- obj[[i]]$tip.label
+      k <- grep("IMPROBABLEPREFIX", lab)
+      if (length(k)) {
+        lab[k] <- FOO(lab[k])
+        obj[[i]]$tip.label <- lab
       }
-      if (length(tmp_lab)) {
-        for (j in 1:length(tmp_lab)) {
-          node.label <- gsub(names(tmp_lab)[j], tmp_lab[j], node.label)
-          tip.label <- gsub(names(tmp_lab)[j], tmp_lab[j], tip.label)
-        }
+      lab <- obj[[i]]$node.label
+      k <- grep("IMPROBABLEPREFIX", lab)
+      if (length(k)) {
+        lab[k] <- FOO(lab[k])
+        obj[[i]]$node.label <- lab
       }
-      obj[[i]]$tip.label <- tip.label
-      obj[[i]]$node.label <- node.label
     }
   }
   if (Ntree == 1 && !keep.multi) obj <- obj[[1]] else {
     if (!is.null(tree.names)) names(obj) <- tree.names
     class(obj) <- "multiPhylo"
   }
-  obj
+  return(obj)
 }
 
 
 as.evonet.phylo2 <- function(x, ...)
 {
+
+
   pos <- grep("#", x$tip.label)
+  if(length(pos)==0 ){ ##if we didn't find any '#' then it is a tree and return as is
+    return(x)
+  }
   ind <- match(pos, x$edge[, 2])
   reticulation <- x$edge[ind, , drop = FALSE]
   inheritance<-x$prob[ind]
@@ -294,6 +288,11 @@ as.evonet.phylo2 <- function(x, ...)
 read.net <- function(file = "", text = NULL, comment.char = "", ...)
 {
   x <- read.tree2(file = file, text = text, comment.char = comment.char, ...)
-  as.evonet.phylo2(x)
+  as.evonet.phylo2(x[[1]])
+  if("multiPhylo" %in% class(x)){
+    lapply(x,as.evonet.phylo2)
+  }else{
+    as.evonet.phylo2(x)
+  }
 }