[R-gregmisc-users] SF.net SVN: r-gregmisc:[1892] trunk/gplots/R
Brought to you by:
warnes
Menu
▾
▴
[R-gregmisc-users] SF.net SVN: r-gregmisc:[1892] trunk/gplots/R
|
From: <wa...@us...> - 2014-09-17 22:03:17
|
Revision: 1892
http://sourceforge.net/p/r-gregmisc/code/1892
Author: warnes
Date: 2014-09-17 22:03:10 +0000 (Wed, 17 Sep 2014)
Log Message:
-----------
To work around recursion limit issues triggered by deeply nested
dendrograms, (1) create a local *intepreted* copy of
stats:::plotNode(), (2) detect recursion limit error message within
heatmap.2() and generate a more user-friendly message.
Modified Paths:
--------------
trunk/gplots/R/heatmap.2.R
trunk/gplots/R/plotNode.R
Modified: trunk/gplots/R/heatmap.2.R
===================================================================
--- trunk/gplots/R/heatmap.2.R 2014-09-17 21:59:01 UTC (rev 1891)
+++ trunk/gplots/R/heatmap.2.R 2014-09-17 22:03:10 UTC (rev 1892)
@@ -560,7 +560,15 @@
par(mar = c(margins[1], 0, 0, 0))
if( dendrogram %in% c("both","row") )
{
- plot(ddr, horiz = TRUE, axes = FALSE, yaxs = "i", leaflab = "none")
+ flag <- try(
+ plot.dendrogram(ddr, horiz = TRUE, axes = FALSE, yaxs = "i", leaflab = "none")
+ )
+ if("try-error" %in% class(flag))
+ {
+ cond <- attr(flag, "condition")
+ if(!is.null(cond) && conditionMessage(cond)=="evaluation nested too deeply: infinite recursion / options(expressions=)?")
+ stop('Row dendrogram too deeply nested, recursion limit exceeded. Try increasing option("expressions"=...).')
+ }
}
else
plot.new()
@@ -569,7 +577,15 @@
if( dendrogram %in% c("both","column") )
{
- plot.dendrogram(ddc, axes = FALSE, xaxs = "i", leaflab = "none")
+ flag <- try(
+ plot.dendrogram(ddc, axes = FALSE, xaxs = "i", leaflab = "none")
+ )
+ if("try-error" %in% class(flag))
+ {
+ cond <- attr(flag, "condition")
+ if(!is.null(cond) && conditionMessage(cond)=="evaluation nested too deeply: infinite recursion / options(expressions=)?")
+ stop('Column dendrogram too deeply nested, recursion limit exceeded. Try increasing option("expressions"=...).')
+ }
}
else
plot.new()
Modified: trunk/gplots/R/plotNode.R
===================================================================
--- trunk/gplots/R/plotNode.R 2014-09-17 21:59:01 UTC (rev 1891)
+++ trunk/gplots/R/plotNode.R 2014-09-17 22:03:10 UTC (rev 1892)
@@ -10,178 +10,12 @@
.midDend <- stats:::.midDend
environment(.midDend) <- .GlobalEnv
-plotNode <-
- function (x1, x2, subtree, type, center, leaflab, dLeaf, nodePar,
- edgePar, horiz = FALSE)
-{
- inner <- !is.leaf(subtree) && x1 != x2
- yTop <- attr(subtree, "height")
- bx <- plotNodeLimit(x1, x2, subtree, center)
- xTop <- bx$x
- hasP <- !is.null(nPar <- attr(subtree, "nodePar"))
- if (!hasP)
- nPar <- nodePar
- if (getOption("verbose")) {
- cat(if (inner)
- "inner node"
- else "leaf", ":")
- if (!is.null(nPar)) {
- cat(" with node pars\n")
- str(nPar)
- }
- cat(if (inner)
- paste(" height", formatC(yTop), "; "), "(x1,x2)= (",
- formatC(x1, width = 4), ",", formatC(x2, width = 4),
- ")", "--> xTop=", formatC(xTop, width = 8), "\n",
- sep = "")
+unByteCode <- function(fun)
+ {
+ FUN <- eval(parse(text=deparse(fun)))
+ environment(FUN) <- environment(fun)
+ FUN
}
- Xtract <- function(nam, L, default, indx) rep(if (nam %in%
- names(L)) L[[nam]] else default, length.out = indx)[indx]
- asTxt <- function(x) if (is.character(x) || is.expression(
- is.null(x))
- x
- else as.character(x)
- i <- if (inner || hasP)
- 1
- else 2
- if (!is.null(nPar)) {
- pch <- Xtract("pch", nPar, default = 1L:2, i)
- cex <- Xtract("cex", nPar, default = c(1, 1), i)
- col <- Xtract("col", nPar, default = par("col"), i)
- bg <- Xtract("bg", nPar, default = par("bg"), i)
- points(if (horiz)
- cbind(yTop, xTop)
- else cbind(xTop, yTop), pch = pch, bg = bg, col = col,
- cex = cex)
- }
- if (leaflab == "textlike")
- p.col <- Xtract("p.col", nPar, default = "white", i)
- lab.col <- Xtract("lab.col", nPar, default = par("col"),
- i)
- lab.cex <- Xtract("lab.cex", nPar, default = c(1, 1), i)
- lab.font <- Xtract("lab.font", nPar, default = par("font"),
- i)
- lab.xpd <- Xtract("xpd", nPar, default = c(TRUE, TRUE), i)
- if (is.leaf(subtree)) {
- if (leaflab == "perpendicular") {
- if (horiz) {
- X <- yTop + dLeaf * lab.cex
- Y <- xTop
- srt <- 0
- adj <- c(0, 0.5)
- }
- else {
- Y <- yTop - dLeaf * lab.cex
- X <- xTop
- srt <- 90
- adj <- 1
- }
- nodeText <- asTxt(attr(subtree, "label"))
- text(X, Y, nodeText, xpd = lab.xpd, srt = srt, adj = adj,
- cex = lab.cex, col = lab.col, font = lab.font)
- }
- }
- else if (inner) {
- segmentsHV <- function(x0, y0, x1, y1) {
- if (horiz)
- segments(y0, x0, y1, x1, col = col, lty = lty,
- lwd = lwd)
- else segments(x0, y0, x1, y1, col = col, lty = lty,
- lwd = lwd)
- }
- for (k in seq_along(subtree)) {
- child <- subtree[[k]]
- yBot <- attr(child, "height")
- if (getOption("verbose"))
- cat("ch.", k, "@ h=", yBot, "; ")
- if (is.null(yBot))
- yBot <- 0
- xBot <- if (center)
- mean(bx$limit[k:(k + 1)])
- else bx$limit[k] + .midDend(child)
- hasE <- !is.null(ePar <- attr(child, "edgePar"))
- if (!hasE)
- ePar <- edgePar
- i <- if (!is.leaf(child) || hasE)
- 1
- else 2
- col <- Xtract("col", ePar, default = par("col"),
- i)
- lty <- Xtract("lty", ePar, default = par("lty"),
- i)
- lwd <- Xtract("lwd", ePar, default = par("lwd"),
- i)
- if (type == "triangle") {
- segmentsHV(xTop, yTop, xBot, yBot)
- }
- else {
- segmentsHV(xTop, yTop, xBot, yTop)
- segmentsHV(xBot, yTop, xBot, yBot)
- }
- vln <- NULL
- if (is.leaf(child) && leaflab == "textlike") {
- nodeText <- asTxt(attr(child, "label"))
- if (getOption("verbose"))
- cat("-- with \"label\"", format(nodeText))
- hln <- 0.6 * strwidth(nodeText, cex = lab.cex)/2
- vln <- 1.5 * strheight(nodeText, cex = lab.cex)/2
- rect(xBot - hln, yBot, xBot + hln, yBot + 2 *
- vln, col = p.col)
- text(xBot, yBot + vln, nodeText, xpd = lab.xpd,
- cex = lab.cex, col = lab.col, font = lab.font)
- }
- if (!is.null(attr(child, "edgetext"))) {
- edgeText <- asTxt(attr(child, "edgetext"))
- if (getOption("verbose"))
- cat("-- with \"edgetext\"", format(edgeText))
- if (!is.null(vln)) {
- mx <- if (type == "triangle")
- (xTop + xBot + ((xTop - xBot)/(yTop - yBot)) *
- vln)/2
- else xBot
- my <- (yTop + yBot + 2 * vln)/2
- }
- else {
- mx <- if (type == "triangle")
- (xTop + xBot)/2
- else xBot
- my <- (yTop + yBot)/2
- }
- p.col <- Xtract("p.col", ePar, default = "white",
- i)
- p.border <- Xtract("p.border", ePar, default = par("fg"),
- i)
- p.lwd <- Xtract("p.lwd", ePar, default = lwd,
- i)
- p.lty <- Xtract("p.lty", ePar, default = lty,
- i)
- t.col <- Xtract("t.col", ePar, default = col,
- i)
- t.cex <- Xtract("t.cex", ePar, default = 1, i)
- t.font <- Xtract("t.font", ePar, default = par("font"),
- i)
- vlm <- strheight(c(edgeText, "h"), cex = t.cex)/2
- hlm <- strwidth(c(edgeText, "m"), cex = t.cex)/2
- hl3 <- c(hlm[1L], hlm[1L] + hlm[2L], hlm[1L])
- if (horiz) {
- polygon(my + c(-hl3, hl3), mx + sum(vlm) *
- c(-1L:1L, 1L:-1L), col = p.col, border = p.border,
- lty = p.lty, lwd = p.lwd)
- text(my, mx, edgeText, cex = t.cex, col = t.col,
- font = t.font)
- }
- else {
- polygon(mx + c(-hl3, hl3), my + sum(vlm) *
- c(-1L:1L, 1L:-1L), col = p.col, border = p.border,
- lty = p.lty, lwd = p.lwd)
- text(mx, my, edgeText, cex = t.cex, col = t.col,
- font = t.font)
- }
- }
- plotNode(bx$limit[k], bx$limit[k + 1], subtree = child,
- type, center, leaflab, dLeaf, nodePar, edgePar,
- horiz)
- }
- }
- invisible()
-}
+
+plotNode <- unByteCode(stats:::plotNode)
+environment(plotNode) <- .GlobalEnv
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
