Merge pull request #65 from vsimko/master

refactoring and fixing issue #64

Author: vsimko

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: corrplot
 Type: Package
 Title: Visualization of a Correlation Matrix
-Version: 0.78
+Version: 0.79
 Author: Taiyun Wei, Viliam Simko
 Suggests:
     seriation,

R/colorlegend.R

@@ -10,7 +10,7 @@
 #' @param ratio.colbar The width ratio of colorbar to the total colorlegend
 #'   (including colorbar, segments and labels).
 #' @param lim.segment Vector (quantile) of length 2, the elements should be in
-#'   [-1,1], giving segments coordinates ranges.
+#'   [0,1], giving segments coordinates ranges.
 #' @param align Character, alignment type of labels, \code{"l"} means left,
 #'   \code{"c"} means center and \code{"r"} right.
 #' @param addlabels Logical, whether add text label or not.
@@ -20,24 +20,36 @@
 #' @keywords hplot
 #' @author Taiyun Wei
 #' @export
-colorlegend <- function(colbar, labels, at = NULL,
-    xlim = c(0, 1), ylim = c(0, 1), vertical = TRUE, ratio.colbar = 0.4,
-    lim.segment = NULL, align = c("c", "l", "r"), addlabels = TRUE,
-    ...) {
-
-  if (is.null(at) & addlabels) {
+colorlegend <- function(
+  colbar,
+  labels,
+  at = NULL,
+  xlim = c(0, 1),
+  ylim = c(0, 1),
+  vertical = TRUE,
+  ratio.colbar = 0.4,
+  lim.segment = NULL,
+  align = c("c", "l", "r"),
+  addlabels = TRUE,
+  ...)
+{
+  if (is.null(at) && addlabels) {
     at <- seq(0L, 1L, length = length(labels))
   }
 
   if (is.null(lim.segment)) {
-    lim.segment <- ratio.colbar + c(0, ratio.colbar / 5)
+    lim.segment <- ratio.colbar + c(0, ratio.colbar * .2)
   }
 
-  if (any(at < 0L) | any(at > 1L)) {
+  if (any(at < 0L) || any(at > 1L)) {
     stop("at should be between 0 and 1")
   }
 
-  if (any(lim.segment < 0L) | any(lim.segment > 1L)) {
+  if (length(lim.segment) != 2) {
+    stop("lim.segment should be a vector of length 2")
+  }
+
+  if (any(lim.segment < 0L) || any(lim.segment > 1L)) {
     stop("lim.segment should be between 0 and 1")
   }
 
@@ -57,30 +69,30 @@ colorlegend <- function(colbar, labels, at = NULL,
            rep(xlim[1] + xgap * rat1, len), yyy[-1],
            col = colbar, border = colbar)
       rect(xlim[1], ylim[1], xlim[1] + xgap * rat1, ylim[2], border = "black")
-
-      pos.xlabel <- rep(xlim[1] + xgap * max(rat2, rat1), length(at))
       segments(xlim[1] + xgap * rat2[1], at, xlim[1] + xgap * rat2[2], at)
 
       if (addlabels) {
+        pos.xlabel <- rep(xlim[1] + xgap * max(rat2, rat1), length(at))
         switch(align,
           l = text(pos.xlabel, y = at, labels = labels, pos = 4, ...),
           r = text(xlim[2],    y = at, labels = labels, pos = 2, ...),
           c = text((pos.xlabel + xlim[2]) / 2, y = at, labels = labels, ...),
           stop("programming error - should not have reached this line!")
         )
       }
-  }
+  } else {
 
-  if (!vertical) {
     at <- at * xgap + xlim[1]
     xxx <- seq(xlim[1], xlim[2], length = len + 1)
+
     rect(xxx[1:len], rep(ylim[2] - rat1 * ygap, len),
-         xxx[-1], rep(ylim[2], len), col = colbar, border = colbar)
+         xxx[-1], rep(ylim[2], len),
+         col = colbar, border = colbar)
     rect(xlim[1], ylim[2] - rat1 * ygap, xlim[2], ylim[2], border = "black")
-    pos.ylabel <- rep(ylim[2] - ygap * max(rat2, rat1), length(at))
     segments(at, ylim[2] - ygap * rat2[1], at, ylim[2] - ygap * rat2[2])
 
     if (addlabels) {
+      pos.ylabel <- rep(ylim[2] - ygap * max(rat2, rat1), length(at))
       switch(align,
        l = text(x = at, y = pos.ylabel, labels = labels, pos = 1, ...),
        r = text(x = at, y = ylim[1],    labels = labels, pos = 2, ...),

R/corrRect.hclust.R

@@ -22,7 +22,11 @@
 #' @keywords hplot
 #' @author Taiyun Wei
 #' @export
-corrRect.hclust <- function(corr, k = 2, col = "black", lwd = 2,
+corrRect.hclust <- function(
+  corr,
+  k = 2,
+  col = "black",
+  lwd = 2,
   method = c("complete", "ward", "ward.D", "ward.D2", "single", "average",
              "mcquitty", "median", "centroid") )
 {
@@ -32,7 +36,10 @@ corrRect.hclust <- function(corr, k = 2, col = "black", lwd = 2,
   hc <- cutree(tree, k = k)
   clustab <- table(hc)[unique(hc[tree$order])]
   cu <- c(0, cumsum(clustab))
-  mat <- cbind(cu[-(k + 1)] + 0.5, n - cu[-(k + 1)] + 0.5,
-               cu[-1] + 0.5, n - cu[-1] + 0.5)
-  rect(mat[,1], mat[,2], mat[,3], mat[,4], border = col, lwd = lwd)
+
+  rect(cu[-(k + 1)] + 0.5,
+       n - cu[-(k + 1)] + 0.5,
+       cu[-1] + 0.5,
+       n - cu[-1] + 0.5,
+       border = col, lwd = lwd)
 }

man/colorlegend.Rd

@@ -6,6 +6,7 @@ pdf(NULL)
 test_that("Basic usage of colorlegend", {
   plot(0, type = "n")
   expect_silent(colorlegend(rainbow(100), 0:9))
+  expect_silent(colorlegend(rainbow(100), 0:9, vertical = FALSE))
 })
 
 test_that("Calling colorlegend without first calling plot should fail", {
@@ -16,3 +17,35 @@ test_that("Calling colorlegend without first calling plot should fail", {
   expect_error(colorlegend(rainbow(100), 0:9),
                regexp = "plot.new has not been called yet")
 })
+
+test_that("Issue #64: lim.segment in function colorlegend()", {
+  plot(0, type = "n")
+
+  expect_error(colorlegend(rainbow(100), 0:9, lim.segment = 1),
+               regexp = "should be a vector of length 2")
+
+  expect_error(colorlegend(rainbow(100), 0:9, lim.segment = c(1,2,3)),
+               regexp = "should be a vector of length 2")
+
+  # lim.segment[1] >= 0
+  expect_error(colorlegend(rainbow(100), 0:9, lim.segment = c(-0.1, 0)),
+               regexp = "should be between 0 and 1")
+
+  # lim.segment[2] <= 1
+  expect_error(colorlegend(rainbow(100), 0:9, lim.segment = c(0, 1.1)),
+               regexp = "should be between 0 and 1")
+
+  # automatic lim.segment
+  expect_silent(colorlegend(rainbow(100), 0:9, lim.segment = NULL))
+
+  expect_silent(colorlegend(rainbow(100), 0:9, lim.segment = c(0,1)))
+})
+
+test_that("Parameter `at` should be between 0 and 1", {
+  plot(0, type = "n")
+
+  expect_error(colorlegend(rainbow(100), 0:2, at = c(-1,.5,.8)),
+               regexp = "should be between 0 and 1")
+
+  expect_silent(colorlegend(rainbow(100), 0:2, at = c(0,.5,.8)))
+})

tests/testthat/test-colorlegend.R

@@ -34,7 +34,7 @@ test_that("Issue #20: plotmath expressions in rownames / colnames", {
   corrplot(M)
 })
 
-test_that("Issues #21: plotCI=rect incompatible with some methods", {
+test_that("Issue #21: plotCI=rect incompatible with some methods", {
   M <- cor(mtcars)
   L <- M - 0.1
   U <- M + 0.1