X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=R%2Fplot.phylo.R;h=4c23c6f0032361e6c3b6181941cbfd4c83ad3f24;hb=2014b83971be4b9cd1644d6127837df798e9335c;hp=7798d286d0c5b395efefdc554979226d21d416f6;hpb=bd53d983d5daf867bc50b00ace48d017506599ef;p=ape.git diff --git a/R/plot.phylo.R b/R/plot.phylo.R index 7798d28..4c23c6f 100644 --- a/R/plot.phylo.R +++ b/R/plot.phylo.R @@ -1,24 +1,25 @@ -## plot.phylo.R (2009-10-27) +## plot.phylo.R (2012-10-20) ## Plot Phylogenies -## Copyright 2002-2009 Emmanuel Paradis +## Copyright 2002-2012 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. -plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, - node.pos = NULL, show.tip.label = TRUE, - show.node.label = FALSE, edge.color = "black", - edge.width = 1, edge.lty = 1, font = 3, cex = par("cex"), - adj = NULL, srt = 0, no.margin = FALSE, - root.edge = FALSE, label.offset = 0, underscore = FALSE, - x.lim = NULL, y.lim = NULL, direction = "rightwards", - lab4ut = "horizontal", tip.color = "black", ...) +plot.phylo <- + function(x, type = "phylogram", use.edge.length = TRUE, + node.pos = NULL, show.tip.label = TRUE, + show.node.label = FALSE, edge.color = "black", + edge.width = 1, edge.lty = 1, font = 3, cex = par("cex"), + adj = NULL, srt = 0, no.margin = FALSE, root.edge = FALSE, + label.offset = 0, underscore = FALSE, x.lim = NULL, + y.lim = NULL, direction = "rightwards", lab4ut = "horizontal", + tip.color = "black", plot = TRUE, rotate.tree = 0, ...) { Ntip <- length(x$tip.label) - if (Ntip == 1) { - warning("found only one tip in the tree") + if (Ntip < 2) { + warning("found less than 2 tips in the tree") return(NULL) } if (any(tabulate(x$edge[, 1]) == 1)) @@ -62,12 +63,12 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, phyloORclado <- type %in% c("phylogram", "cladogram") horizontal <- direction %in% c("rightwards", "leftwards") + xe <- x$edge # to save if (phyloORclado) { ## we first compute the y-coordinates of the tips. 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): @@ -95,17 +96,7 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, } ## '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 @@ -130,7 +121,9 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, } else { xx <- .nodeDepthEdgelength(Ntip, Nnode, z$edge, Nedge, z$edge.length) } - } else switch(type, "fan" = { + } else { + rotate.tree <- 2 * pi * rotate.tree/360 + switch(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 @@ -146,14 +139,15 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, r <- .nodeDepth(Ntip, Nnode, z$edge, Nedge) r <- 1/r } + theta <- theta + rotate.tree xx <- r*cos(theta) yy <- r*sin(theta) }, "unrooted" = { nb.sp <- .nodeDepth(Ntip, Nnode, z$edge, Nedge) XY <- if (use.edge.length) - unrooted.xy(Ntip, Nnode, z$edge, z$edge.length, nb.sp) + unrooted.xy(Ntip, Nnode, z$edge, z$edge.length, nb.sp, rotate.tree) else - unrooted.xy(Ntip, Nnode, z$edge, rep(1, Nedge), nb.sp) + unrooted.xy(Ntip, Nnode, z$edge, rep(1, Nedge), nb.sp, rotate.tree) ## rescale so that we have only positive values xx <- XY$M[, 1] - min(XY$M[, 1]) yy <- XY$M[, 2] - min(XY$M[, 2]) @@ -165,9 +159,9 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, ## angle (1st compute the angles for the tips): yy <- c((1:Ntip)*2*pi/Ntip, rep(0, Nnode)) Y <- .nodeHeight(Ntip, Nnode, z$edge, Nedge, yy) - xx <- X * cos(Y) - yy <- X * sin(Y) - }) + xx <- X * cos(Y + rotate.tree) + yy <- X * sin(Y + rotate.tree) + })} if (phyloORclado) { if (!horizontal) { tmp <- yy @@ -198,8 +192,6 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, 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) } else switch(type, "fan" = { if (show.tip.label) { @@ -227,6 +219,8 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, if (show.tip.label) -1 - max(nchar(x$tip.label) * 0.03 * cex) else -1 } + ## mirror the xx: + if (phyloORclado && direction == "leftwards") xx <- x.lim[2] - xx if (is.null(y.lim)) { if (phyloORclado) { if (horizontal) y.lim <- c(1, Ntip) else { @@ -245,7 +239,6 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, 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 } } else switch(type, "fan" = { if (show.tip.label) { @@ -267,16 +260,20 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, y.lim <- c(0, y.lim) if (phyloORclado && horizontal) y.lim[1] <- 1 if (type %in% c("fan", "unrooted") && show.tip.label) - y.lim[1] <- -max(nchar(x$tip.label) * 0.018 * max(yy) * cex) + y.lim[1] <- -max(nchar(x$tip.label) * 0.018 * max(yy) * cex) if (type == "radial") - y.lim[1] <- if (show.tip.label) -1 - max(nchar(x$tip.label) * 0.018 * max(yy) * cex) else -1 + y.lim[1] <- if (show.tip.label) -1 - max(nchar(x$tip.label) * 0.018 * max(yy) * cex) else -1 } + ## mirror the yy: + if (phyloORclado && direction == "downwards") yy <- max(yy) - yy if (phyloORclado && root.edge) { if (direction == "leftwards") x.lim[2] <- x.lim[2] + x$root.edge if (direction == "downwards") y.lim[2] <- y.lim[2] + x$root.edge } - asp <- if (type %in% c("fan", "radial")) 1 else NA # fix by Klaus Schliep (2008-03-28) + asp <- if (type %in% c("fan", "radial", "unrooted")) 1 else NA # fixes by Klaus Schliep (2008-03-28 and 2010-08-12) plot(0, type = "n", xlim = x.lim, ylim = y.lim, ann = FALSE, axes = FALSE, asp = asp, ...) + +if (plot) { if (is.null(adj)) adj <- if (phyloORclado && direction == "leftwards") 1 else 0 if (phyloORclado && show.tip.label) { @@ -287,7 +284,7 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, } if (direction == "leftwards") { lox <- -label.offset - MAXSTRING * 1.05 * (1 - adj) - #xx <- xx + MAXSTRING + ##xx <- xx + MAXSTRING } if (!horizontal) { psr <- par("usr") @@ -332,6 +329,7 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, "upwards" = segments(xx[ROOT], 0, xx[ROOT], x$root.edge), "downwards" = segments(xx[ROOT], yy[ROOT], xx[ROOT], yy[ROOT] + x$root.edge)) if (show.tip.label) { + if (is.expression(x$tip.label)) underscore <- TRUE if (!underscore) x$tip.label <- gsub("_", " ", x$tip.label) if (phyloORclado) @@ -349,43 +347,59 @@ plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, y.adj[sel] <- strheight(x$tip.label)[sel] / 2 sel <- XY$axe < -pi / 4 & XY$axe > -0.75 * pi y.adj[sel] <- -strheight(x$tip.label)[sel] * 0.75 - text(xx[1:Ntip] + x.adj*cex, yy[1:Ntip] + y.adj*cex, + text(xx[1:Ntip] + x.adj * cex, yy[1:Ntip] + y.adj * cex, x$tip.label, adj = c(adj, 0), font = font, srt = srt, cex = cex, col = tip.color) } else { # if lab4ut == "axial" - adj <- as.numeric(abs(XY$axe) > pi/2) - srt <- 180*XY$axe/pi - srt[as.logical(adj)] <- srt[as.logical(adj)] - 180 + adj <- abs(XY$axe) > pi/2 + srt <- 180 * XY$axe / pi + srt[adj] <- srt[adj] - 180 + adj <- as.numeric(adj) + xx.tips <- xx[1:Ntip] + yy.tips <- yy[1:Ntip] + if (label.offset) { + xx.tips <- xx.tips + label.offset * cos(XY$axe) + yy.tips <- yy.tips + label.offset * sin(XY$axe) + } ## `srt' takes only a single value, so can't vectorize this: + ## (and need to 'elongate' these vectors:) + font <- rep(font, length.out = Ntip) + tip.color <- rep(tip.color, length.out = Ntip) + cex <- rep(cex, length.out = Ntip) 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]) + text(xx.tips[i], yy.tips[i], cex = cex[i], + x$tip.label[i], adj = adj[i], font = font[i], + srt = srt[i], col = tip.color[i]) } } if (type %in% c("fan", "radial")) { - xx.scaled <- xx[1:Ntip] - if (type == "fan") { # no need if type == "radial" - maxx <- max(abs(xx.scaled)) - if (maxx > 1) xx.scaled <- xx.scaled/maxx + xx.tips <- xx[1:Ntip] + yy.tips <- yy[1:Ntip] + ## using atan2 considerably facilitates things compared to acos... + angle <- atan2(yy.tips, xx.tips) # in radians + if (label.offset) { + xx.tips <- xx.tips + label.offset * cos(angle) + yy.tips <- yy.tips + label.offset * sin(angle) } - angle <- acos(xx.scaled)*180/pi - s1 <- angle > 90 & yy[1:Ntip] > 0 - s2 <- angle < 90 & yy[1:Ntip] < 0 - s3 <- angle > 90 & yy[1:Ntip] < 0 - angle[s1] <- angle[s1] + 180 - angle[s2] <- -angle[s2] - angle[s3] <- 180 - angle[s3] - adj <- numeric(Ntip) - adj[xx[1:Ntip] < 0] <- 1 + s <- xx.tips < 0 + angle <- angle * 180/pi # switch to degrees + angle[s] <- angle[s] + 180 + adj <- as.numeric(s) ## `srt' takes only a single value, so can't vectorize this: + ## (and need to 'elongate' these vectors:) + font <- rep(font, length.out = Ntip) + tip.color <- rep(tip.color, length.out = Ntip) + cex <- rep(cex, length.out = Ntip) 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]) + text(xx.tips[i], yy.tips[i], x$tip.label[i], font = font[i], + cex = cex[i], srt = angle[i], adj = adj[i], + col = tip.color[i]) } } if (show.node.label) - text(xx[ROOT:length(xx)] + label.offset, yy[ROOT:length(yy)], - x$node.label, adj = adj, font = font, srt = srt, cex = cex) + text(xx[ROOT:length(xx)] + label.offset, yy[ROOT:length(yy)], + x$node.label, adj = adj, font = font, srt = srt, cex = cex) +} L <- list(type = type, use.edge.length = use.edge.length, node.pos = node.pos, show.tip.label = show.tip.label, show.node.label = show.node.label, font = font, @@ -393,7 +407,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 = x$edge, xx = xx, yy = yy)), + assign("last_plot.phylo", c(L, list(edge = xe, xx = xx, yy = yy)), envir = .PlotPhyloEnv) invisible(L) } @@ -407,7 +421,7 @@ phylogram.plot <- function(edge, Ntip, Nnode, xx, yy, horizontal, yy <- xx xx <- tmp } - ## un trait vertical à chaque noeud... + ## un trait vertical a chaque noeud... x0v <- xx[nodes] y0v <- y1v <- numeric(Nnode) ## store the index of each node in the 1st column of edge: @@ -438,7 +452,7 @@ phylogram.plot <- function(edge, Ntip, Nnode, xx, yy, horizontal, 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) + DF <- data.frame(edge.color, edge.width, edge.lty, stringsAsFactors = FALSE) color.v <- rep("black", Nnode) width.v <- rep(1, Nnode) lty.v <- rep(1, Nnode) @@ -537,7 +551,7 @@ circular.plot <- function(edge, Ntip, Nnode, xx, yy, theta, } } -unrooted.xy <- function(Ntip, Nnode, edge, edge.length, nb.sp) +unrooted.xy <- function(Ntip, Nnode, edge, edge.length, nb.sp, rotate.tree) { foo <- function(node, ANGLE, AXIS) { ind <- which(edge[, 1] == node) @@ -552,7 +566,7 @@ unrooted.xy <- function(Ntip, Nnode, edge, edge.length, nb.sp) yy[sons[i]] <<- h*sin(beta) + yy[node] } for (i in sons) - if (i > Ntip) foo(i, angle[i], axis[i]) + if (i > Ntip) foo(i, angle[i], axis[i]) } Nedge <- dim(edge)[1] yy <- xx <- numeric(Ntip + Nnode) @@ -560,7 +574,7 @@ unrooted.xy <- function(Ntip, Nnode, edge, edge.length, nb.sp) ## `axis': the axis of each branch axis <- angle <- numeric(Ntip + Nnode) ## start with the root... - foo(Ntip + 1L, 2*pi, 0) + foo(Ntip + 1L, 2*pi, 0 + rotate.tree) M <- cbind(xx, yy) axe <- axis[1:Ntip] # the axis of the terminal branches (for export) @@ -581,6 +595,57 @@ node.depth <- function(phy) as.integer(N), double(n + m), DUP = FALSE, PACKAGE = "ape")[[6]] } +node.depth.edgelength <- function(phy) +{ + n <- length(phy$tip.label) + m <- phy$Nnode + N <- dim(phy$edge)[1] + phy <- reorder(phy, order = "pruningwise") + .C("node_depth_edgelength", as.integer(n), as.integer(n), + as.integer(phy$edge[, 1]), as.integer(phy$edge[, 2]), + as.integer(N), as.double(phy$edge.length), double(n + m), + DUP = FALSE, PACKAGE = "ape")[[7]] +} + +node.height <- function(phy) +{ + n <- length(phy$tip.label) + m <- phy$Nnode + N <- dim(phy$edge)[1] + phy <- reorder(phy, order = "pruningwise") + + e1 <- phy$edge[, 1] + e2 <- phy$edge[, 2] + + yy <- numeric(n + m) + TIPS <- e2[e2 <= n] + yy[TIPS] <- 1:n + + .C("node_height", as.integer(n), as.integer(m), + as.integer(e1), as.integer(e2), as.integer(N), + as.double(yy), DUP = FALSE, PACKAGE = "ape")[[6]] +} + +node.height.clado <- function(phy) +{ + n <- length(phy$tip.label) + m <- phy$Nnode + N <- dim(phy$edge)[1] + phy <- reorder(phy, order = "pruningwise") + + e1 <- phy$edge[, 1] + e2 <- phy$edge[, 2] + + yy <- numeric(n + m) + TIPS <- e2[e2 <= n] + yy[TIPS] <- 1:n + + .C("node_height_clado", as.integer(n), as.integer(m), + as.integer(e1), as.integer(e2), as.integer(N), + double(n + m), as.double(yy), DUP = FALSE, + PACKAGE = "ape")[[7]] +} + plot.multiPhylo <- function(x, layout = 1, ...) { if (layout > 1) @@ -592,3 +657,78 @@ plot.multiPhylo <- function(x, layout = 1, ...) } for (i in 1:length(x)) plot(x[[i]], ...) } + +trex <- function(phy, title = TRUE, subbg = "lightyellow3", + return.tree = FALSE, ...) +{ + lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) + devmain <- dev.cur() # where the main tree is plotted + + restore <- function() { + dev.set(devmain) + assign("last_plot.phylo", lastPP, envir = .PlotPhyloEnv) + } + + on.exit(restore()) + NEW <- TRUE + cat("Click close to a node. Right-click to exit.\n") + repeat { + x <- identify.phylo(phy, quiet = TRUE) + if (is.null(x)) return(invisible(NULL)) else { + x <- x$nodes + if (is.null(x)) cat("Try again!\n") else { + if (NEW) { + dev.new() + par(bg = subbg) + devsub <- dev.cur() + NEW <- FALSE + } else dev.set(devsub) + + tr <- extract.clade(phy, x) + plot(tr, ...) + if (is.character(title)) title(title) + else if (title) { + tl <- + if (is.null(phy$node.label)) + paste("From node #", x, sep = "") + else paste("From", phy$node.label[x - Ntip(phy)]) + title(tl) + } + if (return.tree) return(tr) + restore() + } + } + } +} + +kronoviz <- function(x, layout = length(x), horiz = TRUE, ...) +{ + par(mar = rep(0.5, 4), oma = rep(2, 4)) + rts <- sapply(x, function(x) branching.times(x)[1]) + maxrts <- max(rts) + lim <- cbind(rts - maxrts, rts) + Ntree <- length(x) + Ntips <- sapply(x, Ntip) + if (horiz) { + nrow <- layout + w <- 1 + h <- Ntips + } else { + nrow <- 1 + w <- Ntips + h <- 1 + } + layout(matrix(1:layout, nrow), widths = w, heights = h) + if (layout > Ntree && !par("ask")) { + par(ask = TRUE) + on.exit(par(ask = FALSE)) + } + if (horiz) { + for (i in 1:Ntree) + plot(x[[i]], x.lim = lim[i, ], ...) + } else { + for (i in 1:Ntree) + plot(x[[i]], y.lim = lim[i, ], direction = "u", ...) + } + axisPhylo(if (horiz) 1 else 4) # better if the deepest tree is last ;) +}