Do not open any plot devices during calculation of dendro_data #25

R/dendro_rpart.R

@@ -53,22 +53,22 @@ dendro_data.rpart <- function(model, uniform = FALSE, branch = 1, compress = FAL
 
   if (compress & missing(nspace)) nspace <- branch
   if (!compress) nspace <- -1L     # means no compression
-  if(!interactive()) if (dev.cur() == 1L) dev.new() # not needed in R
+  # if(!interactive()) if (dev.cur() == 1L) dev.new() # not needed in R
 
   parms <- list(uniform = uniform, 
                 branch = branch, 
                 nspace = nspace,
                 minbranch = minbranch)
 
   ## define the plot region
-  temp <- rpartco(x, parms)
+  temp <- rpartco(x, parms = parms)
   xx <- temp$x
   yy <- temp$y
   # temp1 <- range(xx) + diff(range(xx)) * c(-margin, margin)
   # temp2 <- range(yy) + diff(range(yy)) * c(-margin, margin)
 #   plot(temp1, temp2, type = "n", axes = FALSE, xlab = "", ylab = "", ...)
   ## Save information per device, once a new device is opened.
-   assign(paste0("device", dev.cur()), parms, envir = rpart_ggdendro_env)
+   # assign(paste0("device", dev.cur()), parms, envir = rpart_ggdendro_env)
 
   # Draw a series of horseshoes or V's, left son, up, down to right son
   #   NA's in the vector cause lines() to "lift the pen"

R/dendro_tree.R

@@ -18,7 +18,7 @@
 #
 
 
-tree_ggdendro_env <- new.env()
+# tree_ggdendro_env <- new.env()
 
 #' Extract data from regression tree object for plotting using ggplot.
 #' 
@@ -43,14 +43,14 @@ dendro_data.tree <- function(model, type = c("proportional", "uniform"), ...){
   type <- match.arg(type)
   uniform <- type == "uniform"
 
-  dev <- dev.cur()
-  if (dev == 1L) dev <- 2L # as device will be opened.
+  # dev <- dev.cur()
+  # if (dev == 1L) dev <- 2L # as device will be opened.
 
-  assign(paste0("device", dev), uniform, envir = tree_ggdendro_env)
+  # assign(paste0("device", dev), uniform, envir = tree_ggdendro_env)
 
-	labels <- tree_labels(model, ...)
+	labels <- tree_labels(model, uniform = uniform, ...)
 	as.dendro(
-    segments = tree_segments(model, ...),
+    segments = tree_segments(model, uniform, ...),
 		labels = labels$labels,
 		leaf_labels = labels$leaf_labels,
     class="tree"
@@ -66,9 +66,10 @@ dendro_data.tree <- function(model, type = c("proportional", "uniform"), ...){
 #' @seealso \code{\link{ggdendrogram}}
 #' @family tree functions
 #' @author Code modified from original by Brian Ripley
-tree_segments <- function(model, ...){
+tree_segments <- function(model, uniform, ...){
+  if(missing(uniform)) stop("specify the uniform argument")
 	# Uses tree:::treeco to extract data frame of plot locations
-	xy <- treeco(model)
+	xy <- treeco(model, uniform = uniform)
 	n <- model$frame$n
 
 	# Lines copied from tree:::treepl
@@ -92,9 +93,9 @@ tree_segments <- function(model, ...){
 #' @seealso \code{\link{ggdendrogram}}
 #' @family tree functions
 #' @author Code modified from original by Brian Ripley
-tree_labels <- function(model, ...){
+tree_labels <- function(model, uniform, ...){
   # Uses tree:::treeco to extract data frame of plot locations
-  xy <- treeco(model)
+  xy <- treeco(model, uniform = uniform)
   label <- model$frame$var
 	yval  <- model$frame$yval
 	sleft  <- model$frame$splits.cutleft
@@ -138,9 +139,9 @@ tree_labels <- function(model, ...){
 #' @seealso \code{\link{ggdendrogram}}
 #' @family tree functions
 #' @author Code modified from original by Brian Ripley
-get_data_tree_leaf_labels <- function(model, ...){
+get_data_tree_leaf_labels <- function(model, uniform, ...){
   # Uses tree:::treeco to extract data frame of plot locations
-  xy <- treeco(model)
+  xy <- treeco(model, uniform = uniform)
   label <- model$frame$var
   yval  <- model$frame$yval
   sleft  <- model$frame$splits.cutleft
@@ -167,14 +168,15 @@ get_data_tree_leaf_labels <- function(model, ...){
 #' @param tree tree object
 #' @param uniform ???
 #' @keywords internal
-treeco <- function (tree, uniform) 
-{
-  if (missing(uniform)) {
-    pn <- paste0("device", dev.cur())
-    uniform <- if (exists(pn, envir = tree_ggdendro_env, inherits = FALSE)) 
-      get(pn, envir = tree_ggdendro_env, inherits = FALSE)
-    else FALSE
-  }
+treeco <- function (tree, uniform) {
+  # if (missing(uniform)) {
+  #   pn <- paste0("device", dev.cur())
+  #   uniform <- if (exists(pn, envir = tree_ggdendro_env, inherits = FALSE)) 
+  #     get(pn, envir = tree_ggdendro_env, inherits = FALSE)
+  #   else FALSE
+  # }
+  if(missing(uniform)) stop("specify uniform argument")
+
   frame <- tree$frame
   node <- as.integer(row.names(frame))
   depth <- tree.depth(node)

R/rpart.R

@@ -126,7 +126,7 @@ labels.rpart <- function(object, digits = 4, minlength = 1L, pretty,
 
 # rpart_ggdendro_env -------------------------------------------------------------------
 
-rpart_ggdendro_env <- new.env()
+# rpart_ggdendro_env <- new.env()
 
 
 # rpart.branch ------------------------------------------------------------
@@ -139,13 +139,14 @@ rpart_ggdendro_env <- new.env()
 ## most likely this could simply default to branch = 1
 rpart.branch <- function(x, y, node, branch)
 {
-  if (missing(branch)) {
-    pn <- paste0("device", dev.cur())
-    if (!exists(pn, envir = rpart_ggdendro_env, inherits = FALSE))
-      stop("no information available on parameters from previous call to plot()")
-    parms <- get(pn, envir = rpart_ggdendro_env, inherits = FALSE)
-    branch <- parms$branch
-  }
+  # if (missing(branch)) {
+  #   pn <- paste0("device", dev.cur())
+  #   if (!exists(pn, envir = rpart_ggdendro_env, inherits = FALSE))
+  #     stop("no information available on parameters from previous call to plot()")
+  #   parms <- get(pn, envir = rpart_ggdendro_env, inherits = FALSE)
+  #   branch <- parms$branch
+  # }
+  if(missing(branch)) branch <- 1
 
   ## Draw a series of horseshoes, left son, up, over, down to right son
   ##   NA's in the vector cause lines() to "lift the pen"
@@ -179,12 +180,12 @@ tree.depth <- function (nodes)
 #' @keywords internal
 rpartco <- function(tree, parms)
 {
-  if (missing(parms)) {
-    pn <- paste0("device", dev.cur())
-    if (!exists(pn, envir = rpart_ggdendro_env, inherits = FALSE))
-      stop("no information available on parameters from previous call to plot()")
-    parms <- get(pn, envir = rpart_ggdendro_env, inherits = FALSE)
-  }
+  # if (missing(parms)) {
+  #   pn <- paste0("device", dev.cur())
+  #   if (!exists(pn, envir = rpart_ggdendro_env, inherits = FALSE))
+  #     stop("no information available on parameters from previous call to plot()")
+  #   parms <- get(pn, envir = rpart_ggdendro_env, inherits = FALSE)
+  # }
 
   frame <- tree$frame
   node <- as.numeric(row.names(frame))
@@ -386,41 +387,41 @@ text.rpart <- function(x, splits = TRUE, label, FUN = text, all = FALSE,
                        ylevel = ylevels, digits = digits,
                        n = frame$n[leaves], use.n = use.n)
 
-    if (fancy) {
-      if (col2rgb(bg, alpha = TRUE)[4L, 1L] < 255) bg <- "white"
-      oval <- function(middlex, middley, a, b)
-      {
-        theta <- seq(0, 2 * pi, pi/30)
-        newx <- middlex + a * cos(theta)
-        newy <- middley + b * sin(theta)
-        polygon(newx, newy, border = TRUE, col = bg)
-      }
-
-      ## FIXME: use rect()
-      rectangle <- function(middlex, middley, a, b)
-      {
-        newx <- middlex + c(a, a, -a, -a)
-        newy <- middley + c(b, -b, -b, b)
-        polygon(newx, newy, border = TRUE, col = bg)
-      }
-
-      ## find maximum length of stat
-      maxlen <- max(string.bounding.box(stat)$columns) + 1L
-      maxht <- max(string.bounding.box(stat)$rows) + 1L
-
-      a.length <- if (fwidth < 1)  fwidth * cxy[1L] * maxlen else fwidth * cxy[1L]
-
-      b.length <- if (fheight < 1) fheight * cxy[2L] * maxht else fheight * cxy[2L]
-
-      ## create ovals and rectangles here
-      ## sqrt(2) creates the smallest oval that fits around the
-      ## best fitting rectangle
-      for (i in parent)
-        oval(xy$x[i], xy$y[i], sqrt(2) * a.length/2, sqrt(2) * b.length/2)
-      child <- match(node[frame$var == "<leaf>"], node)
-      for (i in child)
-        rectangle(xy$x[i], xy$y[i], a.length/2, b.length/2)
-    }
+    # if (fancy) {
+    #   if (col2rgb(bg, alpha = TRUE)[4L, 1L] < 255) bg <- "white"
+    #   oval <- function(middlex, middley, a, b)
+    #   {
+    #     theta <- seq(0, 2 * pi, pi/30)
+    #     newx <- middlex + a * cos(theta)
+    #     newy <- middley + b * sin(theta)
+    #     polygon(newx, newy, border = TRUE, col = bg)
+    #   }
+    #   
+    #   ## FIXME: use rect()
+    #   rectangle <- function(middlex, middley, a, b)
+    #   {
+    #     newx <- middlex + c(a, a, -a, -a)
+    #     newy <- middley + c(b, -b, -b, b)
+    #     polygon(newx, newy, border = TRUE, col = bg)
+    #   }
+    #   
+    #   ## find maximum length of stat
+    #   maxlen <- max(string.bounding.box(stat)$columns) + 1L
+    #   maxht <- max(string.bounding.box(stat)$rows) + 1L
+    #   
+    #   a.length <- if (fwidth < 1)  fwidth * cxy[1L] * maxlen else fwidth * cxy[1L]
+    #   
+    #   b.length <- if (fheight < 1) fheight * cxy[2L] * maxht else fheight * cxy[2L]
+    #   
+    #   ## create ovals and rectangles here
+    #   ## sqrt(2) creates the smallest oval that fits around the
+    #   ## best fitting rectangle
+    #   for (i in parent)
+    #     oval(xy$x[i], xy$y[i], sqrt(2) * a.length/2, sqrt(2) * b.length/2)
+    #   child <- match(node[frame$var == "<leaf>"], node)
+    #   for (i in child)
+    #     rectangle(xy$x[i], xy$y[i], a.length/2, b.length/2)
+    # }
 
     ##if FUN=text then adj=1 puts the split label to the left of the
     ##    split rather than centered