From 42bf3d36a0a2a5edd0071739ad346ae9009abffa Mon Sep 17 00:00:00 2001 From: paradis Date: Thu, 24 Sep 2009 15:54:12 +0000 Subject: [PATCH] finally the new plot.phylo... git-svn-id: https://svn.mpl.ird.fr/ape/dev/ape@92 6e262413-ae40-0410-9e79-b911bd7a66b7 --- ChangeLog | 23 ++- DESCRIPTION | 2 +- R/plot.phylo.R | 450 +++++++++++++++++++++++++++++---------------- man/CADM.global.Rd | 1 + man/dist.gene.Rd | 2 +- man/read.nexus.Rd | 2 +- man/yule.time.Rd | 2 +- man/zoom.Rd | 6 +- 8 files changed, 317 insertions(+), 171 deletions(-) diff --git a/ChangeLog b/ChangeLog index 1375195..5c63f09 100644 --- a/ChangeLog +++ b/ChangeLog @@ -9,22 +9,33 @@ NEW FEATURES BUG FIXES - o seg.sites() did not handle ambiguous nucleotides correctly: they are - now ignored. + o seg.sites() did not handle ambiguous nucleotides correctly: they + are now ignored. + o plot(phy, root.edge = TRUE) failed if there was no $root.edge in + the tree: the argument is now ignored. -DEPRECATED & DEFUNCT - o The functions heterozygosity, nuc.div, theta.h, theta.k and - theta.s have been moved from ape to pegas. +OTHER CHANGES + o Trying to plot a tree with a single tip now returns NULL with a + warning (it returned an error previously). -OTHER CHANGES + o The way lines representing nodes are coloured in phylograms has + been modified (as well as their widths and types) following some + users' request; this is only for dichotomous nodes. o Deprecated functions are now listed in a help page: see help("ape-defunct"), with the quotes! +DEPRECATED & DEFUNCT + + o The functions heterozygosity, nuc.div, theta.h, theta.k and + theta.s have been moved from ape to pegas. + + + CHANGES IN APE VERSION 2.3-3 diff --git a/DESCRIPTION b/DESCRIPTION index 0a4038b..4c52a30 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: ape Version: 2.4 -Date: 2009-09-18 +Date: 2009-09-23 Title: Analyses of Phylogenetics and Evolution Author: Emmanuel Paradis, Ben Bolker, Julien Claude, Hoa Sien Cuong, Richard Desper, Benoit Durand, Julien Dutheil, Olivier Gascuel, Gangolf Jobb, Christoph Heibl, Daniel Lawson, Vincent Lefort, Pierre Legendre, Jim Lemon, Yvonnick Noel, Johan Nylander, Rainer Opgen-Rhein, Korbinian Strimmer, Damien de Vienne Maintainer: Emmanuel Paradis diff --git a/R/plot.phylo.R b/R/plot.phylo.R index fe45432..4ee98b6 100644 --- a/R/plot.phylo.R +++ b/R/plot.phylo.R @@ -1,4 +1,4 @@ -## plot.phylo.R (2009-03-27) +## plot.phylo.R (2009-09-23) ## Plot Phylogenies @@ -17,10 +17,33 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, lab4ut = "horizontal", tip.color = "black", ...) { Ntip <- length(x$tip.label) - if (Ntip == 1) stop("found only one tip in the tree!") - Nedge <- dim(x$edge)[1] + if (Ntip == 1) { + warning("found only one tip in the tree") + return(NULL) + } if (any(tabulate(x$edge[, 1]) == 1)) - stop("there are single (non-splitting) nodes in your tree; you may need to use collapse.singles().") + stop("there are single (non-splitting) nodes in your tree; you may need to use collapse.singles()") + + .nodeHeight <- function(Ntip, Nnode, edge, Nedge, yy) + .C("node_height", as.integer(Ntip), as.integer(Nnode), + as.integer(edge[, 1]), as.integer(edge[, 2]), + as.integer(Nedge), as.double(yy), + DUP = FALSE, PACKAGE = "ape")[[6]] + + .nodeDepth <- function(Ntip, Nnode, edge, Nedge) + .C("node_depth", as.integer(Ntip), as.integer(Nnode), + as.integer(edge[, 1]), as.integer(edge[, 2]), + as.integer(Nedge), double(Ntip + Nnode), + DUP = FALSE, PACKAGE = "ape")[[6]] + + .nodeDepthEdgelength <- function(Ntip, Nnode, edge, Nedge, edge.length) + .C("node_depth_edgelength", as.integer(Ntip), + as.integer(Nnode), as.integer(edge[, 1]), + as.integer(edge[, 2]), as.integer(Nedge), + as.double(edge.length), double(Ntip + Nnode), + DUP = FALSE, PACKAGE = "ape")[[7]] + + Nedge <- dim(x$edge)[1] Nnode <- x$Nnode ROOT <- Ntip + 1 type <- match.arg(type, c("phylogram", "cladogram", "fan", @@ -28,90 +51,100 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, direction <- match.arg(direction, c("rightwards", "leftwards", "upwards", "downwards")) if (is.null(x$edge.length)) use.edge.length <- FALSE - if (type == "unrooted" || !use.edge.length) root.edge <- FALSE + + ## the order of the last two conditions is important: + if (type %in% c("unrooted", "radial") || !use.edge.length || + is.null(x$root.edge) || !x$root.edge) root.edge <- FALSE + if (type == "fan" && root.edge) { + warning("drawing root edge with type = 'fan' is not yet supported") + root.edge <- FALSE + } + phyloORclado <- type %in% c("phylogram", "cladogram") horizontal <- direction %in% c("rightwards", "leftwards") if (phyloORclado) { ## we first compute the y-coordinates of the tips. - ## Fix from Klaus Schliep (2007-06-16): - if (!is.null(attr(x, "order"))) - if (attr(x, "order") == "pruningwise") - x <- reorder(x) - ## End of fix + phyOrder <- attr(x, "order") + ## make sure the tree is in cladewise order: + if (is.null(phyOrder) || phyOrder != "cladewise") { + xe <- x$edge + x <- reorder(x) # fix from Klaus Schliep (2007-06-16) + if (!identical(x$edge, xe)) { + ## modified from Li-San Wang's fix (2007-01-23): + ereorder <- match(x$edge[, 2], xe[, 2]) + if (length(edge.color) > 1) { + edge.color <- rep(edge.color, length.out = Nedge) + edge.color <- edge.color[ereorder] + } + if (length(edge.width) > 1) { + edge.width <- rep(edge.width, length.out = Nedge) + edge.width <- edge.width[ereorder] + } + if (length(edge.lty) > 1) { + edge.lty <- rep(edge.lty, length.out = Nedge) + edge.lty <- edge.lty[ereorder] + } + } + } +### By contrats to ape (< 2.4), the arguments edge.color, etc., are +### not elongated before being passed to segments(), except if needed +### to be reordered yy <- numeric(Ntip + Nnode) TIPS <- x$edge[x$edge[, 2] <= Ntip, 2] yy[TIPS] <- 1:Ntip } - edge.color <- rep(edge.color, length.out = Nedge) - edge.width <- rep(edge.width, length.out = Nedge) - edge.lty <- rep(edge.lty, length.out = Nedge) - ## fix from Li-San Wang (2007-01-23): - xe <- x$edge - x <- reorder(x, order = "pruningwise") - ereorder <- match(x$edge[, 2], xe[, 2]) - edge.color <- edge.color[ereorder] - edge.width <- edge.width[ereorder] - ## End of fix + ## 'z' is the tree in pruningwise order used in calls to .C + z <- reorder(x, order = "pruningwise") +### edge.color <- rep(edge.color, length.out = Nedge) +### edge.width <- rep(edge.width, length.out = Nedge) +### edge.lty <- rep(edge.lty, length.out = Nedge) +### ## fix from Li-San Wang (2007-01-23): +### xe <- x$edge +### x <- reorder(x, order = "pruningwise") +### ereorder <- match(x$edge[, 2], xe[, 2]) +### edge.color <- edge.color[ereorder] +### edge.width <- edge.width[ereorder] +### edge.lty <- edge.lty[ereorder] +### ## end of fix if (phyloORclado) { if (is.null(node.pos)) { node.pos <- 1 if (type == "cladogram" && !use.edge.length) node.pos <- 2 } if (node.pos == 1) - yy <- .C("node_height", as.integer(Ntip), as.integer(Nnode), - as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), - as.integer(Nedge), as.double(yy), - DUP = FALSE, PACKAGE = "ape")[[6]] + yy <- .nodeHeight(Ntip, Nnode, z$edge, Nedge, yy) else { ## node_height_clado requires the number of descendants ## for each node, so we compute `xx' at the same time ans <- .C("node_height_clado", as.integer(Ntip), - as.integer(Nnode), as.integer(x$edge[, 1]), - as.integer(x$edge[, 2]), as.integer(Nedge), + as.integer(Nnode), as.integer(z$edge[, 1]), + as.integer(z$edge[, 2]), as.integer(Nedge), double(Ntip + Nnode), as.double(yy), DUP = FALSE, PACKAGE = "ape") xx <- ans[[6]] - 1 yy <- ans[[7]] } if (!use.edge.length) { - if(node.pos != 2) - xx <- .C("node_depth", as.integer(Ntip), as.integer(Nnode), - as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), - as.integer(Nedge), double(Ntip + Nnode), - DUP = FALSE, PACKAGE = "ape")[[6]] - 1 + if (node.pos != 2) xx <- .nodeDepth(Ntip, Nnode, z$edge, Nedge) - 1 xx <- max(xx) - xx } else { - xx <- .C("node_depth_edgelength", as.integer(Ntip), - as.integer(Nnode), as.integer(x$edge[, 1]), - as.integer(x$edge[, 2]), as.integer(Nedge), - as.double(x$edge.length), double(Ntip + Nnode), - DUP = FALSE, PACKAGE = "ape")[[7]] + xx <- .nodeDepthEdgelength(Ntip, Nnode, z$edge, Nedge, z$edge.length) } } if (type == "fan") { ## if the tips are not in the same order in tip.label ## and in edge[, 2], we must reorder the angles: we ## use `xx' to store temporarily the angles - TIPS <- xe[which(xe[, 2] <= Ntip), 2] + TIPS <- x$edge[which(x$edge[, 2] <= Ntip), 2] xx <- seq(0, 2*pi*(1 - 1/Ntip), 2*pi/Ntip) theta <- double(Ntip) theta[TIPS] <- xx theta <- c(theta, numeric(Nnode)) - theta <- .C("node_height", as.integer(Ntip), as.integer(Nnode), - as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), - as.integer(Nedge), theta, DUP = FALSE, - PACKAGE = "ape")[[6]] + theta <- .nodeHeight(Ntip, Nnode, z$edge, Nedge, theta) if (use.edge.length) { - r <- .C("node_depth_edgelength", as.integer(Ntip), - as.integer(Nnode), as.integer(x$edge[, 1]), - as.integer(x$edge[, 2]), as.integer(Nedge), - as.double(x$edge.length), double(Ntip + Nnode), - DUP = FALSE, PACKAGE = "ape")[[7]] + r <- .nodeDepthEdgelength(Ntip, Nnode, z$edge, Nedge, z$edge.length) } else { - r <- .C("node_depth", as.integer(Ntip), as.integer(Nnode), - as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), - as.integer(Nedge), double(Ntip + Nnode), - DUP = FALSE, PACKAGE = "ape")[[6]] + r <- .nodeDepth(Ntip, Nnode, z$edge, Nedge) r <- 1/r } xx <- r*cos(theta) @@ -119,61 +152,58 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, } if (type == "unrooted") { + nb.sp <- .nodeDepth(Ntip, Nnode, z$edge, Nedge) XY <- if (use.edge.length) - unrooted.xy(Ntip, Nnode, x$edge, x$edge.length) + unrooted.xy(Ntip, Nnode, z$edge, z$edge.length, nb.sp) else - unrooted.xy(Ntip, Nnode, x$edge, rep(1, Nedge)) + unrooted.xy(Ntip, Nnode, z$edge, rep(1, Nedge), nb.sp) ## rescale so that we have only positive values xx <- XY$M[, 1] - min(XY$M[, 1]) yy <- XY$M[, 2] - min(XY$M[, 2]) } if (type == "radial") { - X <- .C("node_depth", as.integer(Ntip), as.integer(Nnode), - as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), - as.integer(Nedge), double(Ntip + Nnode), - DUP = FALSE, PACKAGE = "ape")[[6]] + X <- .nodeDepth(Ntip, Nnode, z$edge, Nedge) X[X == 1] <- 0 ## radius: X <- 1 - X/Ntip ## angle (1st compute the angles for the tips): yy <- c((1:Ntip)*2*pi/Ntip, rep(0, Nnode)) - Y <- .C("node_height", as.integer(Ntip), as.integer(Nnode), - as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), - as.integer(Nedge), as.double(yy), - DUP = FALSE, PACKAGE = "ape")[[6]] + Y <- .nodeHeight(Ntip, Nnode, z$edge, Nedge, yy) xx <- X * cos(Y) yy <- X * sin(Y) } - if (phyloORclado && direction != "rightwards") { - if (direction == "leftwards") { - xx <- -xx - xx <- xx - min(xx) - } + if (phyloORclado) { if (!horizontal) { tmp <- yy yy <- xx xx <- tmp - min(tmp) + 1 - if (direction == "downwards") { - yy <- -yy - yy <- yy - min(yy) - } } - } - if (phyloORclado && root.edge) { - if (direction == "rightwards") xx <- xx + x$root.edge - if (direction == "upwards") yy <- yy + x$root.edge + if (root.edge) { + if (direction == "rightwards") xx <- xx + x$root.edge + if (direction == "upwards") yy <- yy + x$root.edge + } } if (no.margin) par(mai = rep(0, 4)) if (is.null(x.lim)) { if (phyloORclado) { if (horizontal) { x.lim <- c(0, NA) - tmp <- - if (show.tip.label) nchar(x$tip.label) * 0.018 * max(xx) * cex - else 0 - x.lim[2] <- - if (direction == "leftwards") max(xx[ROOT] + tmp) - else max(xx[1:Ntip] + tmp) + pin1 <- par("pin")[1] # width of the device in inches + strWi <- strwidth(x$tip.label, "inches") # id. for the tip labels + ## 1.04 comes from that we are using a regular axis system + ## with 4% on both sides of the range of x: + xx.tips <- xx[1:Ntip] * 1.04 + ## 'alp' is the conversion coefficient from + ## user coordinates to inches: + alp <- try(uniroot(function(a) max(a*xx.tips + strWi) - pin1, + c(0, 1e6))$root, silent = TRUE) + ## if the above fails, give 1/3 of the device for the tip labels: + if (is.character(alp)) tmp <- max(xx.tips)*1.5 else { + tmp <- if (show.tip.label) max(xx.tips + strWi/alp) else max(xx.tips) + } + x.lim[2] <- tmp + if (direction == "leftwards") xx <- x.lim[2] - xx #max(xx[ROOT] + tmp) +# else max(xx[1:Ntip] + tmp) } else x.lim <- c(1, Ntip) } if (type == "fan") { @@ -208,12 +238,21 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, if (phyloORclado) { if (horizontal) y.lim <- c(1, Ntip) else { y.lim <- c(0, NA) - tmp <- - if (show.tip.label) nchar(x$tip.label) * 0.018 * max(yy) * cex - else 0 - y.lim[2] <- - if (direction == "downwards") max(yy[ROOT] + tmp) - else max(yy[1:Ntip] + tmp) + pin2 <- par("pin")[2] # height of the device in inches + strWi <- strwidth(x$tip.label, "inches") + ## 1.04 comes from that we are using a regular axis system + ## with 4% on both sides of the range of x: + yy.tips <- yy[1:Ntip] * 1.04 + ## 'alp' is the conversion coefficient from + ## user coordinates to inches: + alp <- try(uniroot(function(a) max(a*yy.tips + strWi) - pin2, + c(0, 1e6))$root, silent = TRUE) + ## if the above fails, give 1/3 of the device for the tip labels: + if (is.character(alp)) tmp <- max(yy.tips)*1.5 else { + tmp <- if (show.tip.label) max(yy.tips + strWi/alp) else max(yy.tips) + } + y.lim[2] <- tmp + if (direction == "downwards") yy <- y.lim[2] - yy } } if (type == "fan") { @@ -248,30 +287,28 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, } ## fix by Klaus Schliep (2008-03-28): asp <- if (type %in% c("fan", "radial")) 1 else NA - plot(0, type = "n", xlim = x.lim, ylim = y.lim, xlab = "", - ylab = "", xaxt = "n", yaxt = "n", bty = "n", asp = asp, ...) + plot(0, type = "n", xlim = x.lim, ylim = y.lim, ann = FALSE, axes = FALSE, asp = asp, ...) if (is.null(adj)) - adj <- if (phyloORclado && direction == "leftwards") 1 else 0 - if (phyloORclado) { + adj <- if (phyloORclado && direction == "leftwards") 1 else 0 + if (phyloORclado && show.tip.label) { MAXSTRING <- max(strwidth(x$tip.label, cex = cex)) + loy <- 0 if (direction == "rightwards") { lox <- label.offset + MAXSTRING * 1.05 * adj - loy <- 0 } if (direction == "leftwards") { lox <- -label.offset - MAXSTRING * 1.05 * (1 - adj) - loy <- 0 - xx <- xx + MAXSTRING + #xx <- xx + MAXSTRING } if (!horizontal) { psr <- par("usr") - MAXSTRING <- MAXSTRING * 1.09 * (psr[4] - psr[3]) / (psr[2] - psr[1]) + MAXSTRING <- MAXSTRING * 1.09 * (psr[4] - psr[3])/(psr[2] - psr[1]) loy <- label.offset + MAXSTRING * 1.05 * adj lox <- 0 srt <- 90 + srt if (direction == "downwards") { loy <- -loy - yy <- yy + MAXSTRING + ##yy <- yy + MAXSTRING srt <- 180 + srt } } @@ -280,10 +317,23 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, phylogram.plot(x$edge, Ntip, Nnode, xx, yy, horizontal, edge.color, edge.width, edge.lty) } else { - if (type == "fan") - circular.plot(x$edge, Ntip, Nnode, xx, yy, theta, - r, edge.color, edge.width, edge.lty) - else + if (type == "fan") { + ereorder <- match(z$edge[, 2], x$edge[, 2]) + if (length(edge.color) > 1) { + edge.color <- rep(edge.color, length.out = Nedge) + edge.color <- edge.color[ereorder] + } + if (length(edge.width) > 1) { + edge.width <- rep(edge.width, length.out = Nedge) + edge.width <- edge.width[ereorder] + } + if (length(edge.lty) > 1) { + edge.lty <- rep(edge.lty, length.out = Nedge) + edge.lty <- edge.lty[ereorder] + } + circular.plot(z$edge, Ntip, Nnode, xx, yy, theta, + r, edge.color, edge.width, edge.lty) + } else cladogram.plot(x$edge, xx, yy, edge.color, edge.width, edge.lty) } if (root.edge) @@ -294,10 +344,11 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, "downwards" = segments(xx[ROOT], yy[ROOT], xx[ROOT], yy[ROOT] + x$root.edge)) if (show.tip.label) { if (!underscore) x$tip.label <- gsub("_", " ", x$tip.label) - if (phyloORclado) { + + if (phyloORclado) text(xx[1:Ntip] + lox, yy[1:Ntip] + loy, x$tip.label, adj = adj, font = font, srt = srt, cex = cex, col = tip.color) - } + if (type == "unrooted") { if (lab4ut == "horizontal") { y.adj <- x.adj <- numeric(Ntip) @@ -316,12 +367,7 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, adj <- as.numeric(abs(XY$axe) > pi/2) srt <- 180*XY$axe/pi srt[as.logical(adj)] <- srt[as.logical(adj)] - 180 - ## temporary check of the values of `srt': - ## set to 0 if "-0.000001 < srt < 0" - sel <- srt > -1e-6 & srt < 0 - if (any(sel)) srt[sel] <- 0 - ## - ## `srt' takes only a single value, so we cannot vectorize this: + ## `srt' takes only a single value, so can't vectorize this: for (i in 1:Ntip) text(xx[i], yy[i], cex = cex, x$tip.label[i], adj = adj[i], font = font, srt = srt[i], col = tip.color[i]) @@ -342,7 +388,7 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, angle[s3] <- 180 - angle[s3] adj <- numeric(Ntip) adj[xx[1:Ntip] < 0] <- 1 - ## `srt' takes only a single value, so we cannot vectorize this: + ## `srt' takes only a single value, so can't vectorize this: for (i in 1:Ntip) text(xx[i], yy[i], x$tip.label[i], font = font, cex = cex, srt = angle[i], adj = adj[i], col = tip.color[i]) @@ -358,7 +404,7 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, label.offset = label.offset, x.lim = x.lim, y.lim = y.lim, direction = direction, tip.color = tip.color, Ntip = Ntip, Nnode = Nnode) - assign("last_plot.phylo", c(L, list(edge = xe, xx = xx, yy = yy)), + assign("last_plot.phylo", c(L, list(edge = x$edge, xx = xx, yy = yy)), envir = .PlotPhyloEnv) invisible(L) } @@ -375,87 +421,181 @@ phylogram.plot <- function(edge, Ntip, Nnode, xx, yy, horizontal, ## un trait vertical à chaque noeud... x0v <- xx[nodes] y0v <- y1v <- numeric(Nnode) + ## store the index of each node in the 1st column of edge: + NodeInEdge1 <- vector("list", Nnode) for (i in nodes) { - j <- edge[which(edge[, 1] == i), 2] - y0v[i - Ntip] <- min(yy[j]) - y1v[i - Ntip] <- max(yy[j]) + ii <- i - Ntip + j <- NodeInEdge1[[ii]] <- which(edge[, 1] == i) + tmp <- range(yy[edge[j, 2]]) + y0v[ii] <- tmp[1] + y1v[ii] <- tmp[2] } ## ... et un trait horizontal partant de chaque tip et chaque noeud ## vers la racine - sq <- if (Nnode == 1) 1:Ntip else c(1:Ntip, nodes[-1]) - y0h <- yy[sq] - x1h <- xx[sq] - ## match() is very useful here becoz each element in edge[, 2] is - ## unique (not sure this is so useful in edge[, 1]; needs to be checked) - ## `pos' gives for each element in `sq' its index in edge[, 2] - pos <- match(sq, edge[, 2]) - x0h <- xx[edge[pos, 1]] +### sq <- c(1:Ntip, nodes[-1]) +### y0h <- yy[sq] +### x1h <- xx[sq] +### ## match() is very useful here becoz each element in edge[, 2] is +### ## unique (not sure this is so useful in edge[, 1]; needs to be checked) +### ## `pos' gives for each element in `sq' its index in edge[, 2] +### pos <- match(sq, edge[, 2]) +### x0h <- xx[edge[pos, 1]] + x0h <- xx[edge[, 1]] + x1h <- xx[edge[, 2]] + y0h <- yy[edge[, 2]] +### donc plus besoin de 'pos' ni 'sq' - ## function dispatching the features to the vertical edges - foo <- function(edge.feat, default) { - e <- unique(edge.feat) - if (length(e) == 1) return(rep(e, Nnode)) else { - feat.v <- rep(default, Nnode) - for (i in 1:Nnode) { - br <- which(edge[, 1] == i + Ntip) - x <- unique(edge.feat[br]) - if (length(x) == 1) feat.v[i] <- x + nc <- length(edge.color) + nw <- length(edge.width) + nl <- length(edge.lty) + + if (nc + nw + nl == 3) { + color.v <- edge.color + width.v <- edge.width + lty.v <- edge.lty + } else { + Nedge <- dim(edge)[1] + edge.color <- rep(edge.color, length.out = Nedge) + edge.width <- rep(edge.width, length.out = Nedge) + edge.lty <- rep(edge.lty, length.out = Nedge) + DF <- data.frame(edge.color, edge.width, edge.lty) + color.v <- rep("black", Nnode) + width.v <- rep(1, Nnode) + lty.v <- rep(1, Nnode) + for (i in 1:Nnode) { + br <- NodeInEdge1[[i]] + if (length(br) > 2) { + x <- unique(DF[br, 1]) + if (length(x) == 1) color.v[i] <- x + x <- unique(DF[br, 2]) + if (length(x) == 1) width.v[i] <- x + x <- unique(DF[br, 3]) + if (length(x) == 1) lty.v[i] <- x + } else { + A <- br[1] + B <- br[2] + if (any(DF[A, ] != DF[B, ])) { + color.v[i] <- edge.color[B] + width.v[i] <- edge.width[B] + lty.v[i] <- edge.lty[B] + ## add a new line: + y0v <- c(y0v, y0v[i]) + y1v <- c(y1v, yy[i + Ntip]) + x0v <- c(x0v, x0v[i]) + color.v <- c(color.v, edge.color[A]) + width.v <- c(width.v, edge.width[A]) + lty.v <- c(lty.v, edge.lty[A]) + ## shorten the line: + y0v[i] <- yy[i + Ntip] + } else { + color.v[i] <- edge.color[A] + width.v[i] <- edge.width[A] + lty.v[i] <- edge.lty[A] + } } } - feat.v } - color.v <- foo(edge.color, "black") - width.v <- foo(edge.width, 1) - lty.v <- foo(edge.lty, 1) - ## we need to reorder: - edge.width <- edge.width[pos] - edge.color <- edge.color[pos] - edge.lty <- edge.lty[pos] +### ## function dispatching the features to the vertical edges +### foo <- function(edge.feat, default) { +### e <- unique(edge.feat) +### if (length(e) == 1) return(rep(e, Nnode)) +### else { +### feat.v <- rep(default, Nnode) +### for (i in 1:Nnode) { +### br <- NodeInEdge1[[i]] +### if (length(br) > 2) { +### x <- unique(edge.feat[br]) +### if (length(x) == 1) feat.v[i] <- x +### } else { +### if (edge.feat[br[1]] == edge.feat[br[2]]) +### feat.v[i] <- edge.feat[br[1]] +### else { +### feat.v[i] <- edge.feat[br[2]] +### ## add a new line: +### y0v <<- c(y0v, y0v[i]) +### y1v <<- c(y1v, yy[i + Ntip]) +### x0v <<- c(x0v, x0v[i]) +### feat.v <- c(feat.v, edge.feat[br[1]]) +### ## shorten the line: +### y0v[i] <<- yy[i + Ntip] +### } +### } +### } +### } +### feat.v +### } +### color.v <- foo(edge.color, "black") +### width.v <- foo(edge.width, 1) +### lty.v <- foo(edge.lty, 1) + +### ## we need to reorder: +### edge.width <- edge.width[pos] +### edge.color <- edge.color[pos] +### edge.lty <- edge.lty[pos] + if (horizontal) { - segments(x0v, y0v, x0v, y1v, col = color.v, lwd = width.v, lty = lty.v) # draws vertical lines segments(x0h, y0h, x1h, y0h, col = edge.color, lwd = edge.width, lty = edge.lty) # draws horizontal lines + segments(x0v, y0v, x0v, y1v, col = color.v, lwd = width.v, lty = lty.v) # draws vertical lines } else { - segments(y0v, x0v, y1v, x0v, col = color.v, lwd = width.v, lty = lty.v) # draws horizontal lines segments(y0h, x0h, y0h, x1h, col = edge.color, lwd = edge.width, lty = edge.lty) # draws vertical lines + segments(y0v, x0v, y1v, x0v, col = color.v, lwd = width.v, lty = lty.v) # draws horizontal lines } } cladogram.plot <- function(edge, xx, yy, edge.color, edge.width, edge.lty) - segments(xx[edge[, 1]], yy[edge[, 1]], xx[edge[, 2]], yy[edge[, 2]], - col = edge.color, lwd = edge.width, lty = edge.lty) + segments(xx[edge[, 1]], yy[edge[, 1]], xx[edge[, 2]], yy[edge[, 2]], + col = edge.color, lwd = edge.width, lty = edge.lty) circular.plot <- function(edge, Ntip, Nnode, xx, yy, theta, r, edge.color, edge.width, edge.lty) +### 'edge' must be in pruningwise order { r0 <- r[edge[, 1]] r1 <- r[edge[, 2]] theta0 <- theta[edge[, 2]] + costheta0 <- cos(theta0) + sintheta0 <- sin(theta0) - x0 <- r0*cos(theta0) - y0 <- r0*sin(theta0) - x1 <- r1*cos(theta0) - y1 <- r1*sin(theta0) + x0 <- r0 * costheta0 + y0 <- r0 * sintheta0 + x1 <- r1 * costheta0 + y1 <- r1 * sintheta0 segments(x0, y0, x1, y1, col = edge.color, lwd = edge.width, lty = edge.lty) tmp <- which(diff(edge[, 1]) != 0) start <- c(1, tmp + 1) - end <- c(tmp, dim(edge)[1]) + Nedge <- dim(edge)[1] + end <- c(tmp, Nedge) + + ## function dispatching the features to the arcs + foo <- function(edge.feat, default) { + if (length(edge.feat) == 1) return(rep(edge.feat, Nnode)) + else { + edge.feat <- rep(edge.feat, length.out = Nedge) + feat.arc <- rep(default, Nnode) + for (k in 1:Nnode) { + tmp <- edge.feat[start[k]] + if (tmp == edge.feat[end[k]]) feat.arc[k] <- tmp + } + } + feat.arc + } + co <- foo(edge.color, "black") + lw <- foo(edge.width, 1) + ly <- foo(edge.lty, 1) for (k in 1:Nnode) { i <- start[k] j <- end[k] X <- rep(r[edge[i, 1]], 100) Y <- seq(theta[edge[i, 2]], theta[edge[j, 2]], length.out = 100) - co <- if (edge.color[i] == edge.color[j]) edge.color[i] else "black" - lw <- if (edge.width[i] == edge.width[j]) edge.width[i] else 1 - ly <- if (edge.lty[i] == edge.lty[j]) edge.lty[i] else 1 - lines(X*cos(Y), X*sin(Y), col = co, lwd = lw, lty = ly) + lines(X*cos(Y), X*sin(Y), col = co[k], lwd = lw[k], lty = ly[k]) } } -unrooted.xy <- function(Ntip, Nnode, edge, edge.length) +unrooted.xy <- function(Ntip, Nnode, edge, edge.length, nb.sp) { foo <- function(node, ANGLE, AXIS) { ind <- which(edge[, 1] == node) @@ -472,19 +612,13 @@ unrooted.xy <- function(Ntip, Nnode, edge, edge.length) for (i in sons) if (i > Ntip) foo(i, angle[i], axis[i]) } - root <- Ntip + 1 Nedge <- dim(edge)[1] yy <- xx <- numeric(Ntip + Nnode) - nb.sp <- .C("node_depth", as.integer(Ntip), as.integer(Nnode), - as.integer(edge[, 1]), as.integer(edge[, 2]), - as.integer(Nedge), double(Ntip + Nnode), - DUP = FALSE, PACKAGE = "ape")[[6]] ## `angle': the angle allocated to each node wrt their nb of tips ## `axis': the axis of each branch axis <- angle <- numeric(Ntip + Nnode) ## start with the root... - ## xx[root] <- yy[root] <- 0 # already set! - foo(root, 2*pi, 0) + foo(Ntip + 1L, 2*pi, 0) M <- cbind(xx, yy) axe <- axis[1:Ntip] # the axis of the terminal branches (for export) @@ -514,5 +648,5 @@ plot.multiPhylo <- function(x, layout = 1, ...) par(ask = TRUE) on.exit(par(ask = FALSE)) } - for (i in 1:length(x)) plot(x[[i]], ...) + for (i in x) plot(i, ...) } diff --git a/man/CADM.global.Rd b/man/CADM.global.Rd index ee153ac..b6ebddc 100644 --- a/man/CADM.global.Rd +++ b/man/CADM.global.Rd @@ -1,4 +1,5 @@ \name{CADM.global} +\alias{CADM} \alias{CADM.global} \alias{CADM.post} \title{ Congruence among distance matrices } diff --git a/man/dist.gene.Rd b/man/dist.gene.Rd index 45ac67a..bf9cc3b 100644 --- a/man/dist.gene.Rd +++ b/man/dist.gene.Rd @@ -40,7 +40,7 @@ dist.gene(x, method = "pairwise", pairwise.deletion = FALSE, Missing data (\code{NA}) are coded and treated in R's usual way. } \value{ - an object of class \link[stats]{"dist"}. If \code{variance = TRUE} an + an object of class \code{dist}. If \code{variance = TRUE} an attribute called \code{"variance"} is given to the returned object. } \author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}} diff --git a/man/read.nexus.Rd b/man/read.nexus.Rd index d12f4d2..43a0e34 100644 --- a/man/read.nexus.Rd +++ b/man/read.nexus.Rd @@ -19,7 +19,7 @@ read.nexus(file, tree.names = NULL) The present implementation tries to follow as much as possible the NEXUS standard. Only the block ``TREES'' is read; the other data can be read with other functions (e.g., \code{\link{read.dna}}, - \code{\link[base]{read.table}}, ...). A trace of the original data is + \code{\link[utils]{read.table}}, ...). A trace of the original data is kept with the attribute \code{"origin"} (see below). `read.nexus' tries to represent correctly trees with a badly diff --git a/man/yule.time.Rd b/man/yule.time.Rd index a6574b0..4bbe952 100644 --- a/man/yule.time.Rd +++ b/man/yule.time.Rd @@ -38,7 +38,7 @@ yule.time(phy, birth, BIRTH = NULL, root.time = 0, opti = "nlm", start = 0.01) It is recommended to use \code{BIRTH} if possible, and required if speciation probability is constant on some time interval. If this primitive cannot be provided, a numerical integration is done with - \code{\link[base]{integrate}}. + \code{\link[stats]{integrate}}. The standard-errors of the parameters are computed with the Hessian of the log-likelihood function. diff --git a/man/zoom.Rd b/man/zoom.Rd index bd8734e..53d80b6 100644 --- a/man/zoom.Rd +++ b/man/zoom.Rd @@ -34,14 +34,14 @@ zoom(phy, focus, subtree = FALSE, col = rainbow, ...) If the argument `col' is a vector of colours, as many colours as the number of subtrees must be given. The alternative is to give a function that will create colours or grey levels from the number of - subtrees: see \code{\link[graphics]{rainbow}} for some possibilities + subtrees: see \code{\link[grDevices]{rainbow}} for some possibilities with colours. } \author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}} \seealso{ \code{\link{plot.phylo}}, \code{\link{drop.tip}}, - \code{\link[graphics]{layout}}, \code{\link[graphics]{rainbow}}, - \code{\link[graphics]{grey}} + \code{\link[graphics]{layout}}, \code{\link[grDevices]{rainbow}}, + \code{\link[grDevices]{grey}} } \examples{ \dontrun{ -- 2.39.2