X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=R%2Fnodelabels.R;h=40bfab1f899a671d3cca1119e79b202add38afe0;hb=f91082164111e17be175283d9fe8335e89424d42;hp=019563dbdcaa492e2397e2c1777a3beec97633c3;hpb=b9f8872e29c6dbda44f60f67b9797dd90a119de6;p=ape.git

diff --git a/R/nodelabels.R b/R/nodelabels.R
index 019563d..40bfab1 100644
--- a/R/nodelabels.R
+++ b/R/nodelabels.R
@@ -1,8 +1,8 @@
-## nodelabels.R (2009-09-30)
+## nodelabels.R (2010-07-17)
 
 ##   Labelling Trees
 
-## Copyright 2004-2009 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.
@@ -46,7 +46,7 @@ floating.pie.asp <- function(xpos, ypos, x, edges = 200, radius = 1,
 }
 
 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)
@@ -84,23 +84,50 @@ BOTHlabels <- function(text, sel, XX, YY, adj, frame, pch, thermo,
     }
     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
+        thermo <- if (horiz) width * thermo else height * thermo
+        if (is.null(piecol)) piecol <- rainbow(ncol(thermo))
+
         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
-        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)
+        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)) {
@@ -109,41 +136,49 @@ BOTHlabels <- function(text, sel, XX, YY, adj, frame, pch, thermo,
         xrad <- rep(xrad, length(sel))
         XX <- XX + adj[1] - 0.5
         YY <- YY + adj[2] - 0.5
-        for (i in 1:length(sel))
+        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, ...)
 {
     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, ...)
 {
     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)) {
@@ -166,5 +201,92 @@ edgelabels <- function(text, edge, adj = c(0.5, 0.5), frame = "rect",
         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, ...)
 }