Merge pull request #167 from taiyun/col_interval

adjust assign-color algorithm

R/corrplot.R

@@ -27,9 +27,19 @@
 #'   otherwise a new plot is created.
 #'
 #' @param col Vector, the color of glyphs. It is distributed uniformly in
-#'   \code{cl.lim}. If NULL, \code{col} will be
+#'   \code{cl.lim} interval. If NULL, \code{col} will be
 #'   \code{colorRampPalette(col2)(200)}, see example about col2.
 #'
+#' @param cl.lim The limits \code{(x1, x2)} interval for assigning color by
+#'   \code{col}. If \code{NULL},
+#'   \code{cl.lim} will be \code{c(-1, 1)} when \code{is.corr} is  \code{TRUE}, .
+#'   \code{cl.lim} will be \code{c(min(corr), max(corr))} when \code{is.corr}
+#'   is \code{FALSE}
+#'
+#'   NOTICE: if you set \code{cl.lim} when \code{is.corr TRUE}, the assigning color
+#'   method is still distributed uniformly in [-1, 1], it only affect the display
+#'   on colorlegend.
+#'
 #'
 #' @param bg The background color.
 #'
@@ -107,8 +117,6 @@
 #'   \code{"full"}), \code{"b"} (default if \code{type=="lower"}) or \code{"n"},
 #'   \code{"n"} means don't draw colorlabel.
 #'
-#' @param cl.lim The  limits \code{(x1, x2)}  in the colorlabel.
-#'
 #' @param cl.length Integer, the number of number-text in colorlabel, passed to
 #'   \code{\link{colorlegend}}. If \code{NULL}, \code{cl.length} is
 #'   \code{length(col) + 1} when \code{length(col) <=20}; \code{cl.length} is 11
@@ -241,7 +249,7 @@
 corrplot <- function(corr,
   method = c("circle", "square", "ellipse", "number", "shade", "color", "pie"),
   type = c("full", "lower", "upper"), add = FALSE,
-  col = NULL, bg = "white", title = "", is.corr = TRUE,
+  col = NULL, cl.lim = NULL, bg = "white", title = "", is.corr = TRUE,
   diag = TRUE, outline = FALSE, mar = c(0, 0, 0, 0),
   addgrid.col = NULL, addCoef.col = NULL, addCoefasPercent = FALSE,
 
@@ -253,9 +261,8 @@ corrplot <- function(corr,
   tl.pos = NULL, tl.cex = 1,
   tl.col = "red", tl.offset = 0.4, tl.srt = 90,
 
-  cl.pos = NULL, cl.lim = NULL,
-  cl.length = NULL, cl.cex = 0.8, cl.ratio = 0.15,
-  cl.align.text = "c", cl.offset = 0.5,
+  cl.pos = NULL, cl.length = NULL, cl.cex = 0.8,
+  cl.ratio = 0.15, cl.align.text = "c", cl.offset = 0.5,
 
   number.cex = 1, number.font = 2, number.digits = NULL,
 
@@ -282,6 +289,8 @@ corrplot <- function(corr,
   insig <- match.arg(insig)
   plotCI <- match.arg(plotCI)
 
+
+
   # rescale symbols within the corrplot based on win.asp parameter
   if (win.asp != 1 && !(method %in% c("circle", "square"))) {
     stop("Parameter 'win.asp' is supported only for circle and square methods.")
@@ -304,25 +313,45 @@ corrplot <- function(corr,
     stop("color limits should cover matrix")
   }
 
+
   if (is.null(cl.lim)) {
     if (is.corr) {
       # if the matrix is expected to be a correlation matrix
       # it MUST be within the interval [-1,1]
-      cl.lim <- c(-1,1)
+      cl.lim <- c(-1, 1)
     } else {
       # Issue #91
       # if not a correlation matrix and the diagonal is hidden,
       # we need to compute limits from all cells except the diagonal
-      corr_tmp <- corr
-      diag(corr_tmp) <- ifelse(
-        rep(diag, length(diag(corr_tmp))),
-        diag(corr_tmp),
-        NA
-      )
-      cl.lim <- c(min(corr_tmp, na.rm = TRUE), max(corr_tmp, na.rm = TRUE))
+
+      if(!diag) {
+        diag(corr) = NA
+      }
+
+      cl.lim <- c(min(corr, na.rm = TRUE), max(corr, na.rm = TRUE))
+    }
+  }
+
+  # if the mat have both negative and positive values, it is a SpecialCorr
+  SpecialCorr = 0
+
+  if(is.corr) {
+    # check the interval if expecting a correlation matrix
+    # otherwise, the values can be any number
+    if (min(corr, na.rm = TRUE) < -1 - .Machine$double.eps ^ .75 ||
+        max(corr, na.rm = TRUE) >  1 + .Machine$double.eps ^ .75 ) {
+      stop("The matrix is not in [-1, 1]!")
+    }
+
+
+    SpecialCorr = 1
+
+    if(cl.lim[1] < -1 | cl.lim[2] > 1) {
+      stop('cl.lim should be within the interval [-1,1]')
     }
   }
 
+
   intercept <- 0
   zoom <- 1
 
@@ -331,46 +360,41 @@ corrplot <- function(corr,
     c_max <- max(corr, na.rm = TRUE)
     c_min <- min(corr, na.rm = TRUE)
 
-    # The following if-elseif-else code should exhaustively cover all 9
-    # combinations of c_min and c_max variables. Each variable can be either
-    # zero (0), positive (+) or negative (-).
-
-    # c_min c_max
-
-    # 00
-    # -0
-    # +0
-    # --
-    # 0-
-    if (c_max <= 0) {
-      intercept <- -cl.lim[2]
-      zoom <- 1 / (diff(cl.lim))
+    if(diff(cl.lim)/(c_max - c_min)> 2) {
+      warning("cl.lim interval too wide, please set a suitable value")
     }
 
-    # ++
-    # +-
-    # 0+
-    else if (c_min >= 0) {
-      intercept <- -cl.lim[1]
+    # all negative or positive, trans to [0, 1]
+    if (c_max <= 0 | c_min>=0) {
+      intercept <- -c_min
       zoom <- 1 / (diff(cl.lim))
+
+
+      if(cl.lim[1] * cl.lim[2] < 0) {
+        warning("cl.lim interval not suitable to the matrix")
+      }
+
     }
 
-    # -+
+
+    # mixed negative and positive, remain its sign, e.g. [-0.8, 1] or [-1, 0.7]
     else {
 
       # expression from the original code as a sanity check
       stopifnot(c_max * c_min < 0)
-
-      # newly derived expression which covers the single remainig case
+      # newly derived expression which covers the single remaining case
       stopifnot(c_min < 0 && c_max > 0)
 
+
+
       intercept <- 0
       zoom <- 1 / max(abs(cl.lim))
+      SpecialCorr <- 1
     }
 
-    # now, the zoom might still be Inf when cl.lim were both zero
+    # now, the zoom might still be Inf when c_max and c_min were both zero
     if (zoom == Inf) {
-      stopifnot(cl.lim[1] == 0 && cl.lim[2] == 0) # check the assumption
+      stopifnot(c_max == 0 && c_min == 0) # check the assumption
       zoom <- 0
     }
 
@@ -380,14 +404,7 @@ corrplot <- function(corr,
   cl.lim2 <- (intercept + cl.lim) * zoom
   int <- intercept * zoom
 
-  if (is.corr) {
-    # check the interval if expecting a correlation matrix
-    # otherwise, the values can be any number
-    if (min(corr, na.rm = TRUE) < -1 - .Machine$double.eps ^ .75 ||
-      max(corr, na.rm = TRUE) >  1 + .Machine$double.eps ^ .75 ) {
-      stop("The matrix is not in [-1, 1]!")
-    }
-  }
+
 
   if (is.null(col)) {
     col <- colorRampPalette(c("#67001F", "#B2182B", "#D6604D", "#F4A582",
@@ -494,8 +511,14 @@ corrplot <- function(corr,
 
 
   ## assign colors
-  assign.color <- function(dat = DAT, color = col) {
-    newcorr <- (dat + 1) / 2
+  assign.color <- function(dat = DAT, color = col, isSpecialCorr = SpecialCorr) {
+
+    if(isSpecialCorr) {
+      newcorr <- (dat + 1) / 2
+    } else {
+      newcorr <- dat
+    }
+
     newcorr[newcorr <= 0]  <- 0
     newcorr[newcorr >= 1]  <- 1 - 1e-16
     color[floor(newcorr * length(color)) + 1] # new color returned
@@ -889,6 +912,8 @@ corrplot <- function(corr,
   ### color legend
   if (cl.pos != "n") {
     colRange <- assign.color(dat = cl.lim2)
+
+
     ind1 <- which(col == colRange[1])
     ind2 <- which(col == colRange[2])
     colbar <- col[ind1:ind2]

tests/testthat/test-corrplot.R

@@ -67,11 +67,7 @@ test_that("Issue #7: Enable to plot a matrix with NA", {
   expect_equal(corrplot(M), M)
 })
 
-test_that("Issue #70: Enable to plot a matrix with NA when 'is.corr = FALSE'", {
-  M <- matrix(0, ncol = 5, nrow = 5)
-  M[1,1] <- NA
-  expect_true(is.matrix(corrplot(M, is.corr = FALSE)))
-})
+
 
 test_that("Issue #20: plotmath expressions in rownames / colnames", {
   M <- cor(mtcars)[1:5,1:5]