diff --git a/R/dendro_rpart.R b/R/dendro_rpart.R index 31fa29c..dc2ff0b 100644 --- a/R/dendro_rpart.R +++ b/R/dendro_rpart.R @@ -53,7 +53,7 @@ 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, @@ -61,14 +61,14 @@ dendro_data.rpart <- function(model, uniform = FALSE, branch = 1, compress = FAL 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 index 414150c..665d8f6 100644 --- 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 index 29bc431..d03013d 100644 --- 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)) @@ -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 == ""], 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 == ""], 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 diff --git a/inst/doc/ggdendro.html b/inst/doc/ggdendro.html index de94a3a..87e4bbd 100644 --- a/inst/doc/ggdendro.html +++ b/inst/doc/ggdendro.html @@ -242,7 +242,7 @@

Using the ggdendrogram() wrapper

ggdendrogram(hc, rotate = FALSE, size = 2) -

plot of chunk dendrogram

+

plot of chunk dendrogram

The next section shows how to take full control over the data extraction and subsequent plotting.

@@ -261,7 +261,7 @@

Extracting the dendrogram plot data using dendro_data()

p -

plot of chunk dendro1

+

plot of chunk dendro1

Of course, using ggplot2 to create the dendrogram means one has full control over the appearance of the plot. For example, here is the same data, but this time plotted horizontally with a clean background. In ggplot2 this means passing a number of options to theme. The ggdendro packages exports a function, theme_dendro() that wraps these options into a convenient function.

@@ -271,7 +271,7 @@

Extracting the dendrogram plot data using dendro_data()

theme_dendro() -

plot of chunk dendro-2

+

plot of chunk dendro-2

You can also draw dendrograms with triangular line segments (instead of rectangular segments). For example:

@@ -283,7 +283,7 @@

Extracting the dendrogram plot data using dendro_data()

theme_dendro() -

plot of chunk dendro-3

+

plot of chunk dendro-3

Regression tree diagrams

@@ -306,7 +306,7 @@

Regression tree diagrams

} -

plot of chunk tree

+

plot of chunk tree

Classification tree diagrams

@@ -327,7 +327,7 @@

Classification tree diagrams

} -

plot of chunk rpart

+

plot of chunk rpart

Twins diagrams: agnes and diana

@@ -344,7 +344,10 @@

Twins diagrams: agnes and diana

} -

plot of chunk twins

+
## Loading required package: cluster
+
+ +

plot of chunk twins

Conclusion

diff --git a/man/get_data_tree_leaf_labels.Rd b/man/get_data_tree_leaf_labels.Rd index cd5dfbe..aa90df1 100644 --- a/man/get_data_tree_leaf_labels.Rd +++ b/man/get_data_tree_leaf_labels.Rd @@ -4,7 +4,7 @@ \alias{get_data_tree_leaf_labels} \title{Extract labels data frame from tree object for plotting using ggplot.} \usage{ -get_data_tree_leaf_labels(model, ...) +get_data_tree_leaf_labels(model, uniform, ...) } \arguments{ \item{model}{object of class "tree", e.g. the output of tree()} diff --git a/man/tree_labels.Rd b/man/tree_labels.Rd index 2848429..c1562f5 100644 --- a/man/tree_labels.Rd +++ b/man/tree_labels.Rd @@ -4,7 +4,7 @@ \alias{tree_labels} \title{Extract labels data frame from tree object for plotting using ggplot.} \usage{ -tree_labels(model, ...) +tree_labels(model, uniform, ...) } \arguments{ \item{model}{object of class "tree", e.g. the output of tree()} diff --git a/man/tree_segments.Rd b/man/tree_segments.Rd index aac4506..0b27c68 100644 --- a/man/tree_segments.Rd +++ b/man/tree_segments.Rd @@ -4,7 +4,7 @@ \alias{tree_segments} \title{Extract data frame from tree object for plotting using ggplot.} \usage{ -tree_segments(model, ...) +tree_segments(model, uniform, ...) } \arguments{ \item{model}{object of class "tree", e.g. the output of tree()}