-## nodelabels.R (2007-03-05)
+## nodelabels.R (2010-07-17)
-## Labelling the Nodes and the Tips of a Tree
+## Labelling Trees
-## Copyright 2004-2007 Emmanuel Paradis, 2006 Ben Bolker, and 2006 Jim Lemon
+## Copyright 2004-2010 Emmanuel Paradis, 2006 Ben Bolker, and 2006 Jim Lemon
## This file is part of the R-package `ape'.
## See the file ../COPYING for licensing issues.
}
BOTHlabels <- function(text, sel, XX, YY, adj, frame, pch, thermo,
- pie, piecol, col, bg, ...)
+ pie, piecol, col, bg, horiz, width, height, ...)
{
if (missing(text)) text <- NULL
if (length(adj) == 1) adj <- c(adj, 0.5)
}
if (!is.null(thermo)) {
parusr <- par("usr")
- width <- CEX * (parusr[2] - parusr[1]) / 40
- height <- CEX * (parusr[4] - parusr[3]) / 15
+
+ if (is.null(width)) {
+ width <- CEX * (parusr[2] - parusr[1])
+ width <- if (horiz) width/15 else width/40
+ }
+
+ if (is.null(height)) {
+ height <- CEX * (parusr[4] - parusr[3])
+ height <- if (horiz) height/40 else height/15
+ }
+
if (is.vector(thermo)) thermo <- cbind(thermo, 1 - thermo)
- thermo <- height * thermo
- xl <- XX - width/2
- xr <- xl + width
- yb <- YY - height/2
+ thermo <- if (horiz) width * thermo else height * thermo
if (is.null(piecol)) piecol <- rainbow(ncol(thermo))
- ## draw the first rectangle:
- rect(xl, yb, xr, yb + thermo[, 1], border = NA, col = piecol[1])
- for (i in 2:ncol(thermo))
- rect(xl, yb + rowSums(thermo[, 1:(i - 1), drop = FALSE]),
- xr, yb + rowSums(thermo[, 1:i]),
- border = NA, col = piecol[i])
- rect(xl, yb, xr, yb + height, border = "black")
- segments(xl, YY, xl - width/5, YY)
- segments(xr, YY, xr + width/5, YY)
+
+ xl <- XX - width/2 + adj[1] - 0.5 # added 'adj' from Janet Young (2009-09-30)
+ xr <- xl + width
+ yb <- YY - height/2 + adj[2] - 0.5
+ yt <- yb + height
+
+ if (horiz) {
+ ## draw the first rectangle:
+ rect(xl, yb, xl + thermo[, 1], yt, border = NA, col = piecol[1])
+ for (i in 2:ncol(thermo))
+ rect(xl + rowSums(thermo[, 1:(i - 1), drop = FALSE]), yb,
+ xl + rowSums(thermo[, 1:i]), yt, border = NA, col = piecol[i])
+ } else {
+ ## draw the first rectangle:
+ rect(xl, yb, xr, yb + thermo[, 1], border = NA, col = piecol[1])
+ for (i in 2:ncol(thermo))
+ rect(xl, yb + rowSums(thermo[, 1:(i - 1), drop = FALSE]),
+ xr, yb + rowSums(thermo[, 1:i]),
+ border = NA, col = piecol[i])
+ }
+
+ ## check for NA's before drawing the borders
+ s <- apply(thermo, 1, function(xx) any(is.na(xx)))
+ xl[s] <- xr[s] <- NA
+ rect(xl, yb, xr, yt, border = "black")
+
+ if (!horiz) {
+ segments(xl, YY, xl - width/5, YY)
+ segments(xr, YY, xr + width/5, YY)
+ }
}
## from BB:
if (!is.null(pie)) {
if (is.vector(pie)) pie <- cbind(pie, 1 - pie)
xrad <- CEX * diff(par("usr")[1:2]) / 50
- for (i in 1:length(sel))
- floating.pie.asp(XX[i], YY[i], pie[i, ],
- radius = xrad, col = piecol)
+ xrad <- rep(xrad, length(sel))
+ XX <- XX + adj[1] - 0.5
+ YY <- YY + adj[2] - 0.5
+ for (i in 1:length(sel)) {
+ if (any(is.na(pie[i, ]))) next
+ floating.pie.asp(XX[i], YY[i], pie[i, ], radius = xrad[i], col = piecol)
+ }
}
if (!is.null(text)) text(XX, YY, text, adj = adj, col = col, ...)
if (!is.null(pch)) points(XX + adj[1] - 0.5, YY + adj[2] - 0.5,
pch = pch, col = col, bg = bg, ...)
}
-nodelabels <- function(text, node, adj = c(0.5, 0.5), frame = "rect",
- pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
- col = "black", bg = "lightblue", ...)
+nodelabels <-
+ function(text, node, adj = c(0.5, 0.5), frame = "rect",
+ pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
+ col = "black", bg = "lightblue", horiz = FALSE,
+ width = NULL, height = NULL, ...)
{
- if (missing(node))
- node <- (.last_plot.phylo$Ntip + 1):length(.last_plot.phylo$xx)
- XX <- .last_plot.phylo$xx[node]
- YY <- .last_plot.phylo$yy[node]
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ if (missing(node)) node <- (lastPP$Ntip + 1):length(lastPP$xx)
+ XX <- lastPP$xx[node]
+ YY <- lastPP$yy[node]
BOTHlabels(text, node, XX, YY, adj, frame, pch, thermo,
- pie, piecol, col, bg, ...)
+ pie, piecol, col, bg, horiz, width, height, ...)
}
-tiplabels <- function(text, tip, adj = c(0.5, 0.5), frame = "rect",
- pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
- col = "black", bg = "yellow", ...)
+tiplabels <-
+ function(text, tip, adj = c(0.5, 0.5), frame = "rect",
+ pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
+ col = "black", bg = "yellow", horiz = FALSE,
+ width = NULL, height = NULL, ...)
{
- if (missing(tip)) tip <- 1:.last_plot.phylo$Ntip
- XX <- .last_plot.phylo$xx[tip]
- YY <- .last_plot.phylo$yy[tip]
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ if (missing(tip)) tip <- 1:lastPP$Ntip
+ XX <- lastPP$xx[tip]
+ YY <- lastPP$yy[tip]
BOTHlabels(text, tip, XX, YY, adj, frame, pch, thermo,
- pie, piecol, col, bg, ...)
+ pie, piecol, col, bg, horiz, width, height, ...)
}
-edgelabels <- function(text, edge, adj = c(0.5, 0.5), frame = "rect",
- pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
- col = "black", bg = "lightgreen", ...)
+edgelabels <-
+ function(text, edge, adj = c(0.5, 0.5), frame = "rect",
+ pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
+ col = "black", bg = "lightgreen", horiz = FALSE,
+ width = NULL, height = NULL, ...)
{
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
if (missing(edge)) {
- sel <- 1:dim(.last_plot.phylo$edge)[1]
- subedge <- .last_plot.phylo$edge
+ sel <- 1:dim(lastPP$edge)[1]
+ subedge <- lastPP$edge
} else {
sel <- edge
- subedge <- .last_plot.phylo$edge[sel, , drop = FALSE]
+ subedge <- lastPP$edge[sel, , drop = FALSE]
}
- if (.last_plot.phylo$type == "phylogram") {
- if(.last_plot.phylo$direction %in% c("rightwards", "leftwards")) {
- XX <- (.last_plot.phylo$xx[subedge[, 1]] +
- .last_plot.phylo$xx[subedge[, 2]]) / 2
- YY <- .last_plot.phylo$yy[subedge[, 2]]
+ if (lastPP$type == "phylogram") {
+ if (lastPP$direction %in% c("rightwards", "leftwards")) {
+ XX <- (lastPP$xx[subedge[, 1]] + lastPP$xx[subedge[, 2]]) / 2
+ YY <- lastPP$yy[subedge[, 2]]
} else {
- XX <- .last_plot.phylo$xx[subedge[, 2]]
- YY <- (.last_plot.phylo$yy[subedge[, 1]] +
- .last_plot.phylo$yy[subedge[, 2]]) / 2
+ XX <- lastPP$xx[subedge[, 2]]
+ YY <- (lastPP$yy[subedge[, 1]] + lastPP$yy[subedge[, 2]]) / 2
}
} else {
- XX <- (.last_plot.phylo$xx[subedge[, 1]] +
- .last_plot.phylo$xx[subedge[, 2]]) / 2
- YY <- (.last_plot.phylo$yy[subedge[, 1]] +
- .last_plot.phylo$yy[subedge[, 2]]) / 2
+ XX <- (lastPP$xx[subedge[, 1]] + lastPP$xx[subedge[, 2]]) / 2
+ YY <- (lastPP$yy[subedge[, 1]] + lastPP$yy[subedge[, 2]]) / 2
}
BOTHlabels(text, sel, XX, YY, adj, frame, pch, thermo,
- pie, piecol, col, bg, ...)
+ pie, piecol, col, bg, horiz, width, height, ...)
+}
+
+edges <- function(nodes0, nodes1, arrows = 0, type = "classical", ...)
+{
+ type <- match.arg(type, c("classical", "triangle", "harpoon"))
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ ## we do the recycling if necessary:
+ if (length(nodes0) != length(nodes1)) {
+ tmp <- cbind(nodes0, nodes1)
+ nodes0 <- tmp[, 1]
+ nodes1 <- tmp[, 2]
+ }
+ x0 <- lastPP$xx[nodes0]
+ y0 <- lastPP$yy[nodes0]
+ x1 <- lastPP$xx[nodes1]
+ y1 <- lastPP$yy[nodes1]
+ if (arrows)
+ if (type == "classical")
+ graphics::arrows(x0, y0, x1, y1, code = arrows, ...)
+ else
+ fancyarrows(x0, y0, x1, y1, code = arrows, type = type, ...)
+ else
+ graphics::segments(x0, y0, x1, y1, ...)
+}
+
+fancyarrows <-
+ function(x0, y0, x1, y1, length = 0.25, angle = 30, code = 2,
+ col = par("fg"), lty = par("lty"), lwd = par("lwd"),
+ type = "triangle", ...)
+{
+ foo <- function(x0, y0, x1, y1) {
+ ## important to correct with these parameters cause
+ ## the coordinate system will likely not be Cartesian
+ pin <- par("pin")
+ usr <- par("usr")
+ A1 <- pin[1]/diff(usr[1:2])
+ A2 <- pin[2]/diff(usr[3:4])
+ x0 <- x0 * A1
+ y0 <- y0 * A2
+ x1 <- x1 * A1
+ y1 <- y1 * A2
+ atan2(y1 - y0, x1 - x0)
+ }
+ arrow.triangle <- function(x, y) {
+ beta <- alpha - angle/2
+ xa <- xinch(length * cos(beta)) + x
+ ya <- yinch(length * sin(beta)) + y
+ beta <- beta + angle
+ xb <- xinch(length * cos(beta)) + x
+ yb <- yinch(length * sin(beta)) + y
+ n <- length(x)
+ col <- rep(col, length.out = n)
+ for (i in 1:n)
+ polygon(c(x[i], xa[i], xb[i]), c(y[i], ya[i], yb[i]),
+ col = col[i], border = col[i])
+ list((xa + xb)/2, (ya + yb)/2)
+ }
+ arrow.harpoon <- function(x, y) {
+ beta <- alpha - angle/2
+ xa <- xinch(length * cos(beta)) + x
+ ya <- yinch(length * sin(beta)) + y
+ beta <- alpha + angle/2
+ xb <- xinch(length * cos(beta)) + x
+ yb <- yinch(length * sin(beta)) + y
+ xc <- x/2 + (xa + xb)/4
+ yc <- y/2 + (ya + yb)/4
+ n <- length(x)
+ col <- rep(col, length.out = n)
+ for (i in 1:n)
+ polygon(c(x[i], xa[i], xc[i], xb[i]),
+ c(y[i], ya[i], yc[i], yb[i]),
+ col = col[i], border = col[i])
+ list(xc, yc)
+ }
+
+ type <- match.arg(type, c("triangle", "harpoon"))
+ angle <- pi*angle/180 # degree -> radian
+ alpha <- foo(x0, y0, x1, y1) # angle of segment with x-axis
+ ## alpha is in [-pi, pi]
+
+ FUN <- if (type == "triangle") arrow.triangle else arrow.harpoon
+ XY0 <- if (code == 1 || code == 3) FUN(x0, y0) else list(x0, y0)
+ if (code >= 2) {
+ alpha <- (alpha + pi) %% (2 * pi)
+ XY1 <- FUN(x1, y1)
+ } else XY1 <- list(x1, y1)
+ segments(XY0[[1]], XY0[[2]], XY1[[1]], XY1[[2]], col = col, lty = lty, lwd = lwd, ...)
}
projects / ape.git / blobdiff