some big fixes for ape 2.7-1

[ape.git] / R / nodelabels.R

diff --git a/R/nodelabels.R b/R/nodelabels.R
index 5526b017b54733e48c14e44c099d3f8715d4aecb..40bfab1f899a671d3cca1119e79b202add38afe0 100644 (file)
--- a/R/nodelabels.R
+++ b/R/nodelabels.R
@@ -1,4 +1,4 @@
-## nodelabels.R (2010-01-30)
+## nodelabels.R (2010-07-17)
 
 ##   Labelling Trees
 
@@ -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,7 +201,7 @@ 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", ...)