Merge branch 'dev'

andrie · Apr 27, 2016 · f4d6eae · f4d6eae
2 parents 295bd4b + 2c42986
commit f4d6eae
Show file tree

Hide file tree

Showing 9 changed files with 125 additions and 99 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -16,19 +16,19 @@ Description: This is a set of tools for dendrograms and
     functions that extract the dendrogram plot data. The package
     provides implementations for tree, rpart, as well as diana and agnes
     cluster diagrams.
-Version: 0.1-19
+Version: 0.1-20
 URL: https://github.com/andrie/ggdendro
 BugReports: https://github.com/andrie/ggdendro/issues
-Date: 2016-04-14
+Date: 2016-04-27
 Imports:
     MASS,
-    ggplot2(>= 0.9.2),
-    scales
+    ggplot2(>= 0.9.2)
 Suggests:
     rpart(>= 4.0-0),
     tree,
     testthat,
     knitr,
-    cluster
+    cluster,
+    scales
 VignetteBuilder: knitr
 RoxygenNote: 5.0.1
diff --git a/NEWS b/NEWS
@@ -1,12 +1,30 @@
-ggdendro 0.1-19 (Release date:)
+ggdendro 0.1-20 (Release date: 2016-04-27)
+==============
+
+Functional changes:
+
+- None
+
+Enhancements:
+
+- Don't open plot device during calculation of segment data #25
+
+
+ggdendro 0.1-19 (Release date: 2016-04-14)
 ==============
 
 Functional changes:
 
 - Removed margin argument from dendro_data.rpart, since this had no effect on plot.
 
+Bug fixes:
+
+- Fixed issue 20: Plot data is dependent on device, causing errors and spurious new devices
+- Fixed issue 24: Labels don't print in `ggdendrogram()` with package `scales_0.4`
+- Fixed issue 22: Margin not working for `dendro_data.rpart`
+
 
-ggdendro 0.1-18 (Release date: 25/2/2016)
+ggdendro 0.1-18 (Release date: 2016-02-25)
 ==============
 
 Functional changes:
@@ -17,8 +35,12 @@ Other changes:
 
 - Minor change in documentation to comply with latest ggplot2 release
 
+Fixes:
+
+- Fixed issue 13 by adding `geom_blank()`
+
 
-ggdendro 0.1-17 (Release date: 6/9/2015)
+ggdendro 0.1-17 (Release date: 2015-09-06)
 ==============
 
 Fixes:
@@ -27,7 +49,7 @@ Fixes:
 - Update NAMESPACE to import functions from base R (required by R-devel)
 
 
-ggdendro 0.1-16 (Release date: 5/9/2015)
+ggdendro 0.1-16 (Release date: 2015-09-05)
 ==============
 
 New functionality:
@@ -49,7 +71,7 @@ Changes:
 - Modified vignette to use knitr instead of SWeave
 
 
-ggdendro 0.1-14 (Release date: 03/09/2013)
+ggdendro 0.1-14 (Release date: 2013-09-03)
 ==============
 
 New functionality
@@ -62,7 +84,7 @@ Changes:
 
 
 
-ggdendro 0.1-12 (Release date: 27/01/2013)
+ggdendro 0.1-12 (Release date: 2013-01-27)
 ==============
 
 New functionality
@@ -72,7 +94,7 @@ Changes:
 * ggdendro now imports MASS, tree and ggplot2 (rather than suggests)
 * Added Brian D. Ripley as author (original author of package tree)
 
-ggdendro 0.1-09 (Release date: 25/12/2012)
+ggdendro 0.1-09 (Release date: 2012-12-25)
 ==============
 
 New functionality
@@ -82,7 +104,7 @@ Changes:
 * Removed support for rpart
 * Changed Licence from GPL (>=2) to GPL-2|GPL-3 to conform with rtree license conditions
 
-ggdendro 0.1-07 (Release date: 30/08/2012)
+ggdendro 0.1-07 (Release date: 2012-08-30)
 ==============
 
 New functionality
@@ -92,7 +114,7 @@ Changes:
 * Modified code to conform to `ggplot2` v0.9.2
 
 
-ggdendro 0.1-04 (Release date: 02/02/2012)
+ggdendro 0.1-04 (Release date: 2012-02-02)
 ==============
 
 New functionality
@@ -113,7 +135,7 @@ Changes in API
 * Fixed inconsistencies in the names of the `data.frame` segments.  The names are now always `x`, `y`, `xend` and `yend`
 
 
-ggdendro 0.0-7 (Release date: 12/8/2011)
+ggdendro 0.0-7 (Release date: 2011-08-12)
 ==============
 
 New functionality

diff --git a/R/dendro_rpart.R b/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"

diff --git a/R/dendro_tree.R b/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)

diff --git a/R/rpart.R b/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))
@@ -204,7 +205,7 @@ rpartco <- function(tree, parms)
     y <- (1 + max(depth) - depth) / max(depth, 4L)
   else {                    # make y- (parent y) = change in deviance
     y <- dev <- frame$dev
-    temp <- split(seq(node), depth)     #d epth 0 nodes, then 1, then ...
+    temp <- split(seq(node), depth)     #depth 0 nodes, then 1, then ...
     parent <- match(node %/% 2L, node)
     sibling <- match(ifelse(node %% 2L, node - 1L, node + 1L), node)
 
@@ -337,7 +338,8 @@ text.rpart <- function(x, splits = TRUE, label, FUN = text, all = FALSE,
     col <- names(frame)
     ylevels <- attr(x, "ylevels")
     if (!is.null(ylevels <- attr(x, "ylevels"))) col <- c(col, ylevels)
-    cxy <- par("cxy")                   # character width and height
+    # cxy <- par("cxy")                   # character width and height
+    cxy <- c(0.1, 0.1)
     if (!is.null(srt <- list(...)$srt) && srt == 90) cxy <- rev(cxy)
     xy <- rpartco(x, parms = parms)
 
@@ -386,41 +388,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