[fix] performance improvement #27

DESCRIPTION

@@ -16,8 +16,10 @@ Authors@R: c(person("Andrie", "de Vries", role=c("aut", "cre"),
 License: GPL-2|GPL-3
 LazyLoad: true
 ByteCompile: true
-URL: https://github.com/andrie/ggdendro
+URL: https://andrie.github.io/ggdendro/
 BugReports: https://github.com/andrie/ggdendro/issues
+Depends:
+    R(>= 3.5)
 Imports:
     MASS,
     ggplot2(>= 0.9.2)

R/dendro_data.R

@@ -84,7 +84,6 @@ is.dendro <- function(x) {
 #'
 #' @export
 as.dendro <- function(segments, labels, leaf_labels = NULL, class) {
-  # stopifnot(inherits(x, list))
   if (missing(class)) stop("Missing class in as.dendro")
   x <- list(
     segments = segments,

R/dendrogram.R

@@ -155,8 +155,16 @@ dendrogram_data <- function(x, type = c("rectangle", "triangle"), ...) {
     type = type, center = center, leaflab = leaflab,
     dLeaf = dLeaf, nodePar = nodePar, edgePar = edgePar, horiz = FALSE
   )
-  names(ret$segments) <- c("x", "y", "xend", "yend")
-  names(ret$labels) <- c("x", "y", "label")
+  ret$segments <- as.data.frame(matrix(
+    ret$segments, ncol = 4, byrow = TRUE, 
+    dimnames = list(NULL, c("x", "y", "xend", "yend"))
+    ))
+
+  ret$labels <- cbind(
+    as.data.frame(matrix(ret$labels$xy, ncol = 2, byrow = TRUE, dimnames = list(NULL, c("x", "y")))),
+    data.frame(text = ret$labels$text)
+  )
+
   ret
 }
 

R/plotNode.R

@@ -2,10 +2,9 @@
 plotNode <-  function (x1, x2, subtree, type, center, leaflab, dLeaf, nodePar, 
             edgePar, horiz = FALSE) 
   {
-    ddsegments <- data.frame(NA_real_, NA_real_, NA_real_, NA_real_)
     ddsegments <- NULL
-    ddlabels <- data.frame(NA_real_, NA_real_, NA_character_)
-    ddlabels <- NULL
+    ddlabels <- list()
+
     wholetree <- subtree
     depth <- 0L
     llimit <- list()
@@ -73,7 +72,8 @@ plotNode <-  function (x1, x2, subtree, type, center, leaflab, dLeaf, nodePar,
           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)
-          ddlabels <- rbind(ddlabels, data.frame(x = X, y = 0, text = nodeText))
+          ddlabels$xy <- c(ddlabels$xy, X, 0)
+          ddlabels$text <- c(ddlabels$text, nodeText)
         }
       }
       else if (inner) {
@@ -102,14 +102,16 @@ plotNode <-  function (x1, x2, subtree, type, center, leaflab, dLeaf, nodePar,
           if (type == "triangle") {
             # segmentsHV(xTop, yTop, xBot, yBot)
             # segmentsHV(xTop, yTop, xBot, yBot)
-            ddsegments <- rbind(ddsegments, data.frame(x = xTop, y = yTop, xend = xBot, yend = yBot))
-            # ddsegments <- rbind(ddsegments, data.frame(xTop, yTop, xBot, yBot))
+            # ddsegments <- rbind(ddsegments, data.frame(x = xTop, y = yTop, xend = xBot, yend = yBot))
+            ddsegments <- c(ddsegments, xTop, yTop, xBot, yBot)
           }
           else {
             # segmentsHV(xTop, yTop, xBot, yTop)
             # segmentsHV(xBot, yTop, xBot, yBot)
-            ddsegments <- rbind(ddsegments, data.frame(x = xTop, y = yTop, xend = xBot, yend = yTop))
-            ddsegments <- rbind(ddsegments, data.frame(x = xBot, y = yTop, xend = xBot, yend = yBot))
+            # ddsegments <- rbind(ddsegments, data.frame(x = xTop, y = yTop, xend = xBot, yend = yTop))
+            # ddsegments <- rbind(ddsegments, data.frame(x = xBot, y = yTop, xend = xBot, yend = yBot))
+            ddsegments <- c(ddsegments, xTop, yTop, xBot, yTop)
+            ddsegments <- c(ddsegments, xBot, yTop, xBot, yBot)
           }
           vln <- NULL
           # if (is.leaf(child) && leaflab == "textlike") {

inst/WORDLIST

@@ -11,6 +11,7 @@ behaviour
 de
 dendro
 diana
+ggdendogram
 ggdendrogram
 ggplot
 hclust

tests/testthat/test-7-recursion.R

@@ -1,7 +1,28 @@
-test_that("multiplication works", {
+test_that("large dendogram completes in reasonable time", {
 
-  # node_overflow_data <- readr::read_csv("data/mydata.csv", col_types = paste0(rep("d", 27), collapse = ""))
-  node_overflow_data <- read_node_overflow_data()
+  skip_on_cran()
+
+  # find data file location
+  file_location <- c(
+    "tests/testthat/data/node_overflow_data.rds", "data/node_overflow_data.rds"
+  )
+  fl <- file_location[file.exists(file_location)]
+  node_overflow_data <- readRDS(fl)
+
+  # run hclust
   dhc <- hclust(dist(node_overflow_data), method = "average")
-  dendro_data(dhc, type = "rectangle")
+
+  # start ggdendro tests
+  elapsed_time <- system.time({
+    dhd <- dendro_data(dhc, type = "rectangle")
+  })[[3]]
+
+
+  # performance expectation: complete in less than 4 seconds
+  expect_lt(elapsed_time, 4)
+
+  expect_s3_class(dhd, "dendro")
+  p2 <- ggdendrogram(dhd, type = "rectangle")
+
+  expect_s3_class(p2, "ggplot")
 })