Temporarily fixed function newick2phylog from package ade4

newick2phylog_DZ

newick2phylog_DZ <- function (x.tre, add.tools = TRUE, call = match.call()) 
{
  complete <- function(x.tre) {
    if (length(x.tre) > 1) {
      w <- ""
      for (i in 1:length(x.tre)) w <- paste(w, x.tre[i], 
                                            sep = "")
      x.tre <- w
    }
    ndroite <- nchar(gsub("[^)]", "", x.tre))
    ngauche <- nchar(gsub("[^(]", "", x.tre))
    if (ndroite != ngauche) 
      stop(paste(ngauche, "( versus", ndroite, ")"))
    if (regexpr(";", x.tre) == -1) 
      stop("';' not found")
    i <- 0
    kint <- 0
    kext <- 0
    arret <- FALSE
    if (regexpr("\\[", x.tre) != -1) {
      x.tre <- gsub("\\[[^\\[]*\\]", "", x.tre)
    }
    x.tre <- gsub(" ", "", x.tre)
    while (!arret) {
      i <- i + 1
      if (substr(x.tre, i, i) == ";") 
        arret <- TRUE
      if (substr(x.tre, i, i + 1) == "(,") {
        kext <- kext + 1
        add <- paste("Ext", kext, sep = "")
        x.tre <- paste(substring(x.tre, 1, i), add, 
                       substring(x.tre, i + 1), sep = "")
        i <- i + 1
      }
      else if (substr(x.tre, i, i + 1) == ",,") {
        kext <- kext + 1
        add <- paste("Ext", kext, sep = "")
        x.tre <- paste(substring(x.tre, 1, i), add, 
                       substring(x.tre, i + 1), sep = "")
        i <- i + 1
      }
      else if (substr(x.tre, i, i + 1) == ",)") {
        kext <- kext + 1
        add <- paste("Ext", kext, sep = "")
        x.tre <- paste(substring(x.tre, 1, i), add, 
                       substring(x.tre, i + 1), sep = "")
        i <- i + 1
      }
      else if (substr(x.tre, i, i + 1) == "(:") {
        kext <- kext + 1
        add <- paste("Ext", kext, sep = "")
        x.tre <- paste(substring(x.tre, 1, i), add, 
                       substring(x.tre, i + 1), sep = "")
        i <- i + 1
      }
      else if (substr(x.tre, i, i + 1) == ",:") {
        kext <- kext + 1
        add <- paste("Ext", kext, sep = "")
        x.tre <- paste(substring(x.tre, 1, i), add, 
                       substring(x.tre, i + 1), sep = "")
        i <- i + 1
      }
      else if (substr(x.tre, i, i + 1) == "),") {
        kint <- kint + 1
        add <- paste("I", kint, sep = "")
        x.tre <- paste(substring(x.tre, 1, i), add, 
                       substring(x.tre, i + 1), sep = "")
        i <- i + 1
      }
      else if (substr(x.tre, i, i + 1) == "))") {
        kint <- kint + 1
        add <- paste("I", kint, sep = "")
        x.tre <- paste(substring(x.tre, 1, i), add, 
                       substring(x.tre, i + 1), sep = "")
        i <- i + 1
      }
      else if (substr(x.tre, i, i + 1) == "):") {
        kint <- kint + 1
        add <- paste("I", kint, sep = "")
        x.tre <- paste(substring(x.tre, 1, i), add, 
                       substring(x.tre, i + 1), sep = "")
        i <- i + 1
      }
      else if (substr(x.tre, i, i + 1) == ");") {
        add <- "Root"
        x.tre <- paste(substring(x.tre, 1, i), add, 
                       substring(x.tre, i + 1), sep = "")
        i <- i + 1
      }
    }
    lab.points <- strsplit(x.tre, "[(),;]")[[1]]
    lab.points <- lab.points[lab.points != ""]
    no.long <- (regexpr(":", lab.points) == -1)
    if (all(no.long)) {
      lab.points <- paste(lab.points, ":", c(rep("1", 
                                                 length(no.long) - 1), "0.0"), sep = "")
    }
    else if (no.long[length(no.long)]) {
      lab.points[length(lab.points)] <- paste(lab.points[length(lab.points)], 
                                              ":0.0", sep = "")
    }
    else if (any(no.long)) {
      print(x.tre)
      stop("Non convenient data leaves or nodes with and without length")
    }
    w <- strsplit(x.tre, "[(),;]")[[1]]
    w <- w[w != ""]
    leurre <- make.names(w, unique = TRUE)
    leurre <- gsub("[.]", "_", leurre)
    for (i in 1:length(w)) {
      old <- paste(w[i])
      x.tre <- sub(old, leurre[i], x.tre, fixed = TRUE)
    }
    w <- strsplit(lab.points, ":")
    label <- function(x) {
      lab <- x[1]
      lab <- gsub("[.]", "_", lab)
      return(lab)
    }
    longueur <- function(x) {
      long <- x[2]
      return(long)
    }
    labels <- unlist(lapply(w, label))
    longueurs <- unlist(lapply(w, longueur))
    labels <- make.names(labels, TRUE)
    labels <- gsub("[.]", "_", labels)
    w <- labels
    for (i in 1:length(w)) {
      new <- w[i]
      x.tre <- sub(leurre[i], new, x.tre)
    }
    cat <- rep("", length(w))
    for (i in 1:length(w)) {
      new <- w[i]
      if (regexpr(paste("\\)", new, sep = ""), x.tre) != 
          -1) 
        cat[i] <- "int"
      else if (regexpr(paste(",", new, sep = ""), x.tre) != 
               -1) 
        cat[i] <- "ext"
      else if (regexpr(paste("\\(", new, sep = ""), x.tre) != 
               -1) 
        cat[i] <- "ext"
      else cat[i] <- "unknown"
    }
    return(list(tre = x.tre, noms = labels, poi = as.numeric(longueurs), 
                cat = cat))
  }
  res <- complete(x.tre)
  poi <- res$poi
  nam <- res$noms
  names(poi) <- nam
  cat <- res$cat
  res <- list(tre = res$tre)
  res$leaves <- poi[cat == "ext"]
  names(res$leaves) <- nam[cat == "ext"]
  res$nodes <- poi[cat == "int"]
  names(res$nodes) <- nam[cat == "int"]
  listclass <- list()
  dnext <- c(names(res$leaves), names(res$nodes))
  listpath <- as.list(dnext)
  names(listpath) <- dnext
  x.tre <- res$tre
  while (regexpr("[(]", x.tre) != -1) {
    a <- regexpr("\\([^\\(\\)]*\\)", x.tre)
    n1 <- a[1] + 1
    n2 <- n1 - 3 + attr(a, "match.length")
    chasans <- substring(x.tre, n1, n2)
    chaavec <- paste("\\(", chasans, "\\)", sep = "")
    nam <- unlist(strsplit(chasans, ","))
    w1 <- strsplit(x.tre, chaavec, perl = TRUE)[[1]][2]  # reg expr could be longer than 256 bites
    parent <- unlist(strsplit(w1, "[,\\);]"))[1]
    listclass[[parent]] <- nam
    x.tre <- gsub(chaavec, "", x.tre, perl = TRUE)  # reg expr could be longer than 256 bites
    w2 <- which(unlist(lapply(listpath, function(x) any(x[1] == 
                                                          nam))))
    for (i in w2) {
      listpath[[i]] <- c(parent, listpath[[i]])
    }
  }
  res$parts <- listclass
  res$paths <- listpath
  dnext <- c(res$leaves, res$nodes)
  names(dnext) <- c(names(res$leaves), names(res$nodes))
  res$droot <- unlist(lapply(res$paths, function(x) sum(dnext[x])))
  res$call <- call
  class(res) <- "phylog"
  if (!add.tools) 
    return(res)
  return(ade4:::newick2phylog.addtools(res))
}