R/corrplot.R
In MortenKrebs/diagtraject: Mining of Diagnosis Trajectories
Defines functions
draw_grid
draw_method_color
draw_method_square
corrplot
Documented in
corrplot
#' Modification of \code{corrplot::corrplot} by \code{https://github.com/taiyun}, that enable square size to repressent p-values.
#'
#' A graphical display of a correlation matrix, confidence interval. The details
#' are paid great attention to. It can also visualize a general matrix by
#' setting \code{is.corr = FALSE}.
#'
#' @param corr The correlation matrix to visualize, must be square if
#' \code{order} is not \code{"original"}. For general matrix, please using
#' \code{is.corr = FALSE} to convert.
#'
#' @param method Character, the visualization method of correlation matrix to be
#' used. Currently, it supports seven methods, named \code{"circle"}
#' (default), \code{"square"}, \code{"ellipse"}, \code{"number"},
#' \code{"pie"}, \code{"shade"} and \code{"color"}. See examples for details.
#'
#' The areas of circles or squares show the absolute value of corresponding
#' correlation coefficients. Method \code{"pie"} and \code{"shade"} came from
#' Michael Friendly's job (with some adjustment about the shade added on), and
#' \code{"ellipse"} came from D.J. Murdoch and E.D. Chow's job, see in section
#' References.
#'
#' @param type Character, \code{"full"} (default), \code{"upper"} or
#' \code{"lower"}, display full matrix, lower triangular or upper triangular
#' matrix.
#'
#' @param add Logical, if \code{TRUE}, the graph is added to an existing plot,
#' 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{colorRampPalette(col2)(200)}, see example about col2.
#'
#' @param full_col Logical, whether to use the entire color spectrum
#' defined in \code{col} for visualization.
#'
#' @param bg The background color.
#'
#' @param title Character, title of the graph.
#'
#' @param is.corr Logical, whether the input matrix is a correlation matrix or
#' not. We can visualize the non-correlation matrix by setting
#' \code{is.corr = FALSE}.
#'
#' @param diag Logical, whether display the correlation coefficients on the
#' principal diagonal.
#'
#' @param outline Logical or character, whether plot outline of circles, square
#' and ellipse, or the color of these glyphs. For pie, this represents the
#' color of the circle outlining the pie. If \code{outline} is \code{TRUE},
#' the default value is \code{"black"}.
#'
#' @param mar See \code{\link{par}}.
#'
#' @param addgrid.col The color of the grid. If \code{NA}, don't add grid. If
#' \code{NULL} the default value is chosen. The default value depends on
#' \code{method}, if \code{method} is \code{color} or \code{shade}, the color
#' of the grid is \code{NA}, that is, not draw grid; otherwise \code{"grey"}.
#'
#' @param addCoef.col Color of coefficients added on the graph. If \code{NULL}
#' (default), add no coefficients.
#'
#' @param addCoefasPercent Logic, whether translate coefficients into percentage
#' style for spacesaving.
#'
#' @param order Character, the ordering method of the correlation matrix.
#' \itemize{
#' \item{\code{"original"} for original order (default).}
#' \item{\code{"AOE"} for the angular order of the eigenvectors.}
#' \item{\code{"FPC"} for the first principal component order.}
#' \item{\code{"hclust"} for the hierarchical clustering order.}
#' \item{\code{"alphabet"} for alphabetical order.}
#' }
#'
#' See function \code{\link{corrMatOrder}} for details.
#'
#' @param hclust.method Character, the agglomeration method to be used when
#' \code{order} is \code{\link{hclust}}. This should be one of \code{"ward"},
#' \code{"ward.D"}, \code{"ward.D2"}, \code{"single"}, \code{"complete"},
#' \code{"average"}, \code{"mcquitty"}, \code{"median"} or \code{"centroid"}.
#'
#' @param addrect Integer, the number of rectangles draws on the graph according
#' to the hierarchical cluster, only valid when \code{order} is \code{hclust}.
#' If \code{NULL} (default), then add no rectangles.
#'
#' @param rect.col Color for rectangle border(s), only valid when \code{addrect}
#' is equal or greater than 1.
#'
#' @param rect.lwd Numeric, line width for borders for rectangle border(s), only
#' valid when \code{addrect} is equal or greater than 1.
#'
#' @param tl.pos Character or logical, position of text labels. If character, it
#' must be one of \code{"lt"}, \code{"ld"}, \code{"td"}, \code{"d"} or
#' \code{"n"}. \code{"lt"}(default if \code{type=="full"}) means left and top,
#' \code{"ld"}(default if \code{type=="lower"}) means left and diagonal,
#' \code{"td"}(default if \code{type=="upper"}) means top and diagonal(near),
#' \code{"d"} means diagonal, \code{"n"} means don't add textlabel.
#'
#' @param tl.cex Numeric, for the size of text label (variable names).
#'
#' @param tl.col The color of text label.
#'
#' @param tl.offset Numeric, for text label, see \code{\link{text}}.
#'
#' @param tl.srt Numeric, for text label string rotation in degrees, see
#' \code{\link{text}}.
#'
#' @param cl.pos Character or logical, position of color labels; If character,
#' it must be one of \code{"r"} (default if \code{type=="upper"} or
#' \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
#' when \code{length(col) > 20}
#'
#' @param cl.cex Numeric, cex of number-label in colorlabel, passed to
#' \code{\link{colorlegend}}.
#'
#' @param cl.ratio Numeric, to justify the width of colorlabel, 0.1~0.2 is
#' suggested.
#'
#' @param cl.align.text Character, \code{"l"}, \code{"c"} (default) or
#' \code{"r"}, for number-label in colorlabel, \code{"l"} means left,
#' \code{"c"} means center, and \code{"r"} means right.
#'
#' @param cl.offset Numeric, for number-label in colorlabel, see
#' \code{\link{text}}.
#'
#' @param ssl.pos Character or logical, position of square size legend; If character,
#' it must be one of \code{"r"} or \code{"b"}. Default \code{"n"}
#' means don't draw square size legend.
#'
#' @param ssl.lev Integer indicating number of levels in draw square size legend. Default \code{6}
#' levels.
#'
#' @param number.cex The \code{cex} parameter to send to the call to \code{text}
#' when writing the correlation coefficients into the plot.
#'
#' @param number.font the \code{font} parameter to send to the call to
#' \code{text} when writing the correlation coefficients into the plot.
#'
#' @param number.digits indicating the number of decimal digits to be
#' added into the plot. Non-negative integer or NULL, default NULL.
#'
#' @param addshade Character for shade style, \code{"negative"},
#' \code{"positive"} or \code{"all"}, only valid when \code{method} is
#' \code{"shade"}. If \code{"all"}, all correlation coefficients' glyph will
#' be shaded; if \code{"positive"}, only the positive will be shaded; if
#' \code{"negative"}, only the negative will be shaded. Note: the angle of
#' shade line is different, 45 degrees for positive and 135 degrees for
#' negative.
#'
#' @param shade.lwd Numeric, the line width of shade.
#'
#' @param shade.col The color of shade line.
#'
#' @param p.mat Matrix of p-value, if \code{NULL}, arguments \code{sig.level},
#' \code{insig}, \code{pch}, \code{pch.col}, \code{pch.cex} is invalid.
#'
#' @param sig.level Significant level, if the p-value in \code{p-mat} is bigger
#' than \code{sig.level}, then the corresponding correlation coefficient is
#' regarded as insignificant. If \code{insig} is \code{"label_sig"}, this may
#' be an increasing vector of significance levels, in which case \code{pch}
#' will be used once for the highest p-value interval and multiple times
#' (e.g. "*", "**", "***") for each lower p-value interval.
#'
#' @param insig Character, specialized insignificant correlation coefficients,
#' \code{"pch"} (default), \code{"p-value"}, \code{"blank"}, \code{"n"}, or
#' \code{"label_sig"}. If \code{"blank"}, wipe away the corresponding glyphs;
#' if \code{"p-value"}, add p-values the corresponding glyphs;
#' if \code{"pch"}, add characters (see \code{pch} for details) on
#' corresponding glyphs; if \code{"n"}, don't take any measures; if
#' \code{"label_sig"}, mark significant correlations with pch
#' (see \code{sig.level}).
#'
#' @param pch Add character on the glyphs of insignificant correlation
#' coefficients(only valid when \code{insig} is \code{"pch"}). See
#' \code{\link{par}}.
#'
#' @param pch.col The color of pch (only valid when \code{insig} is
#' \code{"pch"}).
#'
#' @param pch.cex The cex of pch (only valid when \code{insig} is \code{"pch"}).
#'
#' @param plotCI Character, method of ploting confidence interval. If
#' \code{"n"}, don't plot confidence interval. If "rect", plot rectangles
#' whose upper side means upper bound and lower side means lower bound,
#' respectively, and meanwhile correlation coefficients are also added on the
#' rectangles. If "circle", first plot a circle with the bigger absolute
#' bound, and then plot the smaller. Warning: if the two bounds are the same
#' sign, the smaller circle will be wiped away, thus forming a ring. Method
#' "square" is similar to "circle".
#'
#' @param lowCI.mat Matrix of the lower bound of confidence interval.
#'
#' @param uppCI.mat Matrix of the upper bound of confidence interval.
#'
#' @param na.label Label to be used for rendering \code{NA} cells. Default is
#' \code{"?"}. If "square", then the cell is rendered as a square with the
#' \code{na.label.col} color.
#'
#' @param na.label.col Color used for rendering \code{NA} cells. Default is
#' \code{"black"}.
#'
#' @param win.asp Aspect ration for the whole plot. Value other than 1 is
#' currently compatible only with methods "circle" and "square".
#'
#' @param \dots Additional arguments passing to function \code{text} for drawing
#' text label.
#'
#' @return (Invisibly) returns a reordered correlation matrix.
#'
#' @details \code{corrplot} function offers flexible ways to visualize
#' correlation matrix, lower and upper bound of confidence interval matrix.
#'
#' @references
#' Michael Friendly (2002).
#' \emph{Corrgrams: Exploratory displays for correlation matrices}.
#' The American Statistician, 56, 316--324.
#'
#' D.J. Murdoch, E.D. Chow (1996).
#' \emph{A graphical display of large correlation matrices}.
#' The American Statistician, 50, 178--180.
#'
#' @author Taiyun Wei (weitaiyun@@gmail.com)
#' @author Viliam Simko (viliam.simko@@gmail.com)
#' @author Michael Levy (michael.levy@@healthcatalyst.com)
#'
#' @note \code{Cairo} and \code{cairoDevice} packages is strongly recommended to
#' produce high-quality PNG, JPEG, TIFF bitmap files, especially for that
#' \code{method} \code{circle}, \code{ellipse}.
#'
#' @note Row- and column names of the input matrix are used as labels rendered
#' in the corrplot. Plothmath expressions will be used if the name is prefixed
#' by one of the following characters: \code{:}, \code{=} or \code{$}.
#' For example \code{":alpha + beta"}.
#'
#' @seealso Function \code{plotcorr} in the \code{ellipse} package and
#' \code{corrgram} in the \code{corrgram} package have some similarities.
#'
#' Package \code{seriation} offered more methods to reorder matrices, such as
#' ARSA, BBURCG, BBWRCG, MDS, TSP, Chen and so forth.
#'
#'
#' @import graphics grDevices stats
#' @export
#'
#'@examples
#'install.packages("corrplot")
#'library(corrplot)
#'devtools::install_github("MortenKrebs/diagtraject")
#'
#'mat <- matrix(rnorm(100),10,10)
#
#'rownames(mat) <- letters[1:10]
#'colnames(mat) <- letters[11:20]
#'
#'col <- colorRampPalette(c("#67001F", "#B2182B", "#FFFFFF", "#2166AC", "#053061")[5:1])(20)
#'
#'pm <- matrix(runif(100),10,10)
#'pm[pm<1e-6] <- 1e-6
#'
#'corrplot(mat, is.corr=FALSE, p.mat=pm,
#' method="p.square", insig="pch", col=col,
#' sig.level=0.05/56, pch="*", pch.cex=1, mar= c(4,4,4,0),
#' cl.ratio=0.25, cl.align.text="l", cl.lim=c(-5,5),
#' tl.col="black", bg="#fffffc",ssl.pos = "r",ssl.lev=6,full_col=F,cl.pos = "r")
#'text(9.5,9,labels = "log(HR)")
#'mtext("Second Diagnosis",side=3,line=1)
#'mtext("First Diagnosis",side=2,line=1)
#'
corrplot <- function(corr,
method = c("circle", "square", "ellipse", "number", "shade", "color", "pie","p.square"),
type = c("full", "lower", "upper"), add = FALSE,
col = NULL, full_col = TRUE, bg = "white", title = "", is.corr = TRUE,
diag = TRUE, outline = FALSE, mar = c(0, 0, 0, 0),
addgrid.col = NULL, addCoef.col = NULL, addCoefasPercent = FALSE,
order = c("original", "AOE", "FPC", "hclust", "alphabet"),
hclust.method = c("complete", "ward", "ward.D", "ward.D2", "single",
"average", "mcquitty", "median", "centroid"),
addrect = NULL, rect.col = "black", rect.lwd = 2,
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,
number.cex = 1, number.font = 2, number.digits = NULL,
addshade = c("negative", "positive", "all"),
shade.lwd = 1, shade.col = "white",
p.mat = NULL, sig.level = 0.05, p.min=NULL,
insig = c("pch", "p-value", "blank", "n", "label_sig"),
pch = 4, pch.col = "black", pch.cex = 3,
ssl.pos = "n", ssl.lev = 6,
plotCI = c("n", "square", "circle", "rect"),
lowCI.mat = NULL, uppCI.mat = NULL,
na.label = "?", na.label.col = "black",
win.asp = 1,
...)
{
# checking multi-option input parameters
method <- match.arg(method)
type <- match.arg(type)
order <- match.arg(order)
hclust.method <- match.arg(hclust.method)
addshade <- match.arg(addshade)
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.")
}
asp_rescale_factor <- min(1, win.asp) / max(1, win.asp)
stopifnot(asp_rescale_factor >= 0 && asp_rescale_factor <= 1)
if (!is.matrix(corr) && !is.data.frame(corr)) {
stop("Need a matrix or data frame!")
}
# select grid color automatically if not specified
if (is.null(addgrid.col)) {
addgrid.col <- switch(method, color = NA, shade = NA, "grey")
}
if (any(corr < cl.lim[1]) || any(corr > cl.lim[2])) {
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)
} 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))
}
}
intercept <- 0
zoom <- 1
if (!is.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))
}
# ++
# +-
# 0+
else if (c_min >= 0) {
intercept <- -cl.lim[1]
zoom <- 1 / (diff(cl.lim))
}
# -+
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
stopifnot(c_min < 0 && c_max > 0)
intercept <- 0
zoom <- 1 / max(abs(cl.lim))
}
# now, the zoom might still be Inf when cl.lim were both zero
if (zoom == Inf) {
stopifnot(cl.lim[1] == 0 && cl.lim[2] == 0) # check the assumption
zoom <- 0
}
corr <- (intercept + corr) * zoom
}
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",
"#FDDBC7", "#FFFFFF", "#D1E5F0", "#92C5DE",
"#4393C3", "#2166AC", "#053061"))(200)
}
n <- nrow(corr)
m <- ncol(corr)
min.nm <- min(n,m)
ord <- seq_len(min.nm)
if (order != "original") {
ord <- corrMatOrder(corr, order = order, hclust.method = hclust.method)
corr <- corr[ord, ord]
}
## set up variable names
if (is.null(rownames(corr))) {
rownames(corr) <- seq_len(n)
}
if (is.null(colnames(corr))) {
colnames(corr) <- seq_len(m)
}
# assigns Inf to cells in the matrix depending on the type paramter
apply_mat_filter <- function(mat) {
x <- matrix(1:n * m, nrow = n, ncol = m)
switch(type,
upper = mat[row(x) > col(x)] <- Inf,
lower = mat[row(x) < col(x)] <- Inf
)
if (!diag) {
diag(mat) <- Inf
}
return(mat)
}
# retrieves coordinates of cells to be rendered
getPos.Dat <- function(mat) {
tmp <- apply_mat_filter(mat)
Dat <- tmp[is.finite(tmp)]
ind <- which(is.finite(tmp), arr.ind = TRUE)
Pos <- ind
Pos[,1] <- ind[,2]
Pos[,2] <- -ind[,1] + 1 + n
return(list(Pos, Dat))
}
# retrieves coordinates of NA cells
# we use this for rending NA cells differently
getPos.NAs <- function(mat) {
tmp <- apply_mat_filter(mat)
ind <- which(is.na(tmp), arr.ind = TRUE)
Pos <- ind
Pos[,1] <- ind[,2]
Pos[,2] <- -ind[,1] + 1 + n
return(Pos)
}
Pos <- getPos.Dat(corr)[[1]]
# decide whether NA labels are going to be rendered or whether we ignore them
if (any(is.na(corr)) && is.character(na.label)) {
PosNA <- getPos.NAs(corr)
} else {
# explicitly set to NULL to indicate that NA labels are not going to be
# rendered
PosNA <- NULL
}
AllCoords <- rbind(Pos, PosNA)
# rows
n2 <- max(AllCoords[,2])
n1 <- min(AllCoords[,2])
nn <- n2 - n1
# columns
m2 <- max(AllCoords[,1])
m1 <- min(AllCoords[,1])
# Issue #19: legend color bar width 0 when using just one column matrix
# also discussed here: http://stackoverflow.com/questions/34638555/
mm <- max(1, m2 - m1)
# Issue #20: support plotmath expressions in rownames and colnames
expand_expression <- function(s) {
ifelse(grepl("^[:=$]", s), parse(text = substring(s, 2)), s)
}
newrownames <- sapply(
rownames(corr)[(n + 1 - n2):(n + 1 - n1)], expand_expression)
newcolnames <- sapply(
colnames(corr)[m1:m2], expand_expression)
DAT <- getPos.Dat(corr)[[2]]
len.DAT <- length(DAT)
rm(expand_expression) # making sure the function is only used here
# scale data to range [lower, upper]
# if the dataspan is invalid we use the coller in the middle of the interval
scale_to_range <- function(data, lower = 1, upper) {
dataspan <- max(data) - min(data)
if (dataspan == 0)
rep((upper - lower) / 2, length(data)) # middle color
else
(upper - lower) * (data - min(data)) / dataspan + lower # full range
}
## assign colors
assign.color <- function(dat = DAT, color = col) {
if (full_col) {
# Rescale data before computing color to ensure that all colors are used.
newcorr <- scale_to_range(data = dat, lower = 1, upper = length(color))
color[floor(newcorr)]
} else {
newcorr <- (dat + 1) / 2
newcorr[newcorr <= 0] <- 0
newcorr[newcorr >= 1] <- 1 - 1e-16
color[floor(newcorr * length(color)) + 1] # new color returned
}
}
col.fill <- assign.color()
isFALSE <- function(x) identical(x, FALSE)
isTRUE <- function(x) identical(x, TRUE)
if (isFALSE(tl.pos)) {
tl.pos <- "n"
}
if (is.null(tl.pos) || isTRUE(tl.pos)) {
tl.pos <- switch(type, full = "lt", lower = "ld", upper = "td")
}
if (isFALSE(cl.pos)) {
cl.pos <- "n"
}
if (is.null(cl.pos) || isTRUE(cl.pos)) {
cl.pos <- switch(type, full = "r", lower = "b", upper = "r")
}
if (isFALSE(outline)) {
col.border <- col.fill
} else if (isTRUE(outline)) {
col.border <- "black"
} else if (is.character(outline)) {
col.border <- outline
} else {
stop("Unsupported value type for parameter outline")
}
# restore this parameter when exiting the corrplot function in any way
oldpar <- par(mar = mar, bg = par()$bg)
on.exit(par(oldpar), add = TRUE)
## calculate label-text width approximately
if (!add) {
plot.new()
# Issue #10: code from Sebastien Rochette (github user @statnmap)
xlabwidth <- max(strwidth(newrownames, cex = tl.cex))
ylabwidth <- max(strwidth(newcolnames, cex = tl.cex))
laboffset <- strwidth("W", cex = tl.cex) * tl.offset
# Issue #10
for (i in 1:50) {
xlim <- c(
m1 - 0.5 - laboffset -
xlabwidth * (grepl("l", tl.pos) | grepl("d", tl.pos)),
m2 + 0.5 + mm * cl.ratio * (cl.pos == "r") +
xlabwidth * abs(cos(tl.srt * pi / 180)) * grepl("d", tl.pos)
) #+ c(-0.35, 0.15)
ylim <- c(
n1 - 0.5 - nn * cl.ratio * (cl.pos == "b") - laboffset,
n2 + 0.5 + laboffset +
ylabwidth * abs(sin(tl.srt * pi / 180)) * grepl("t", tl.pos)
) +
#c(-0.15, 0) +
c(0, -1) * (type == "upper" && tl.pos != "n") # nasty hack
# note: the nasty hack above is related to multiple issues
# (e.g. #96, #94, #102)
plot.window(xlim, ylim, asp = 1, xaxs = "i", yaxs = "i")
x.tmp <- max(strwidth(newrownames, cex = tl.cex))
y.tmp <- max(strwidth(newcolnames, cex = tl.cex))
laboffset.tmp <- strwidth("W", cex = tl.cex) * tl.offset
if (max(x.tmp - xlabwidth,
y.tmp - ylabwidth,
laboffset.tmp - laboffset) < 1e-03) {
break
}
xlabwidth <- x.tmp
ylabwidth <- y.tmp
laboffset <- laboffset.tmp
if (i == 50) {
warning(c("Not been able to calculate text margin, ",
"please try again with a clean new empty window using ",
"{plot.new(); dev.off()} or reduce tl.cex"))
}
}
if (.Platform$OS.type == "windows") {
grDevices::windows.options(width = 7,
height = 7 * diff(ylim) / diff(xlim))
}
xlim <- xlim + diff(xlim) * 0.01 * c(-1, 1)
ylim <- ylim + diff(ylim) * 0.01 * c(-1, 1)
plot.window(xlim = xlim , ylim = ylim,
asp = win.asp, xlab = "", ylab = "", xaxs = "i", yaxs = "i")
}
## for: add = TRUE
laboffset <- strwidth("W", cex = tl.cex) * tl.offset
## background for the cells
symbols(Pos, add = TRUE, inches = FALSE,
rectangles = matrix(1, len.DAT, 2), bg = bg, fg = bg)
## circle
if (method == "circle" && plotCI == "n") {
symbols(Pos, add = TRUE, inches = FALSE,
circles = asp_rescale_factor * 0.9 * abs(DAT) ^ 0.5 / 2,
fg = col.border, bg = col.fill)
}
## ellipse
if (method == "ellipse" && plotCI == "n") {
ell.dat <- function(rho, length = 99) {
k <- seq(0, 2 * pi, length = length)
x <- cos(k + acos(rho) / 2) / 2
y <- cos(k - acos(rho) / 2) / 2
cbind(rbind(x,y), c(NA, NA))
}
ELL.dat <- lapply(DAT, ell.dat)
ELL.dat2 <- 0.85 * matrix(unlist(ELL.dat), ncol = 2, byrow = TRUE)
ELL.dat2 <- ELL.dat2 + Pos[rep(1:length(DAT),each = 100),]
polygon(ELL.dat2, border = col.border, col = col.fill)
}
## number
if (is.null(number.digits)) {
# TODO: this expression might be confusing
number.digits <- switch(addCoefasPercent + 1, 2, 0)
}
stopifnot(number.digits %% 1 == 0) # is whole number
stopifnot(number.digits >= 0) # is non-negative number
if (method == "number" && plotCI == "n") {
x <- (DAT - int) * ifelse(addCoefasPercent, 100, 1) / zoom
text(Pos[,1], Pos[,2], font = number.font, col = col.fill,
labels = format(round(x, number.digits), nsmall = number.digits),
cex = number.cex)
}
# Issue #55: Support for multiple characters when rendering NAs
NA_LABEL_MAX_CHARS <- 2
# renders NA cells
if (is.matrix(PosNA) && nrow(PosNA) > 0) {
stopifnot(is.matrix(PosNA)) # sanity check
if (na.label == "square") {
symbols(PosNA, add = TRUE, inches = FALSE,
squares = rep(1, nrow(PosNA)),
bg = na.label.col, fg = na.label.col)
} else if (nchar(na.label) %in% 1:NA_LABEL_MAX_CHARS) {
symbols(PosNA, add = TRUE, inches = FALSE,
squares = rep(1, nrow(PosNA)), fg = bg, bg = bg)
text(PosNA[,1], PosNA[,2], font = number.font,
col = na.label.col,
labels = na.label, cex = number.cex, ...)
} else {
stop(paste("Maximum number of characters for NA label is:",
NA_LABEL_MAX_CHARS))
}
}
## pie
if (method == "pie" && plotCI == "n") {
# Issue #18: Corrplot background circle
symbols(Pos, add = TRUE, inches = FALSE,
circles = rep(0.5, len.DAT) * 0.85, fg = col.border)
pie.dat <- function(theta, length = 100) {
k <- seq(pi / 2, pi / 2 - theta, length = 0.5 * length * abs(theta) / pi)
x <- c(0, cos(k) / 2, 0)
y <- c(0, sin(k) / 2, 0)
cbind(rbind(x,y), c(NA, NA)) # pie.dat returned
}
PIE.dat <- lapply(DAT * 2 * pi, pie.dat)
len.pie <- unlist(lapply(PIE.dat, length)) / 2
PIE.dat2 <- 0.85 * matrix(unlist(PIE.dat), ncol = 2, byrow = TRUE)
PIE.dat2 <- PIE.dat2 + Pos[rep(1:length(DAT), len.pie),]
polygon(PIE.dat2, border = "black", col = col.fill)
}
## shade
if (method == "shade" && plotCI == "n") {
symbols(Pos, add = TRUE, inches = FALSE, squares = rep(1, len.DAT),
bg = col.fill, fg = addgrid.col)
shade.dat <- function(w) {
x <- w[1]
y <- w[2]
rho <- w[3]
x1 <- x - 0.5
x2 <- x + 0.5
y1 <- y - 0.5
y2 <- y + 0.5
dat <- NA
if ((addshade == "positive" || addshade == "all") && rho > 0) {
dat <- cbind(c(x1, x1, x), c(y, y1, y1),
c(x, x2, x2), c(y2, y2 ,y))
}
if ((addshade == "negative" || addshade == "all") && rho < 0) {
dat <- cbind(c(x1, x1, x), c(y, y2, y2),
c(x, x2, x2), c(y1, y1 ,y))
}
return(t(dat))
}
pos_corr <- rbind(cbind(Pos, DAT))
pos_corr2 <- split(pos_corr, 1:nrow(pos_corr))
SHADE.dat <- matrix(na.omit(unlist(lapply(pos_corr2, shade.dat))),
byrow = TRUE, ncol = 4)
segments(SHADE.dat[,1], SHADE.dat[,2], SHADE.dat[,3],
SHADE.dat[,4], col = shade.col, lwd = shade.lwd)
}
## square
if (method == "p.square" && plotCI == "n") {
if(!is.null(p.min)) p.mat[p.mat<p.min]<-p.min
p.mat_log <- -log10(p.mat)/max(-log10(p.mat))
draw_method_square(Pos, getPos.Dat(p.mat_log)[[2]], asp_rescale_factor, col.border, col.fill)
}
if (method == "square" && plotCI == "n") {
draw_method_square(Pos, getPos.Dat(p.mat)[[2]], asp_rescale_factor, col.border, col.fill)
}
## color
if (method == "color" && plotCI == "n") {
draw_method_color(Pos, col.border, col.fill)
}
## add grid
draw_grid(AllCoords, addgrid.col)
if (plotCI != "n") {
if (is.null(lowCI.mat) || is.null(uppCI.mat)) {
stop("Need lowCI.mat and uppCI.mat!")
}
if (order != "original") {
lowCI.mat <- lowCI.mat[ord, ord]
uppCI.mat <- uppCI.mat[ord, ord]
}
pos.lowNew <- getPos.Dat(lowCI.mat)[[1]]
lowNew <- getPos.Dat(lowCI.mat)[[2]]
pos.uppNew <- getPos.Dat(uppCI.mat)[[1]]
uppNew <- getPos.Dat(uppCI.mat)[[2]]
if (!method %in% c("circle", "square")) {
stop("Method shoud be circle or square if drawing confidence intervals.")
}
k1 <- (abs(uppNew) > abs(lowNew))
bigabs <- uppNew
bigabs[which(!k1)] <- lowNew[!k1]
smallabs <- lowNew
smallabs[which(!k1)] <- uppNew[!k1]
sig <- sign(uppNew * lowNew)
color_bigabs <- col[ceiling((bigabs + 1) * length(col) / 2)]
color_smallabs <- col[ceiling((smallabs + 1) * length(col) / 2)]
if (plotCI == "circle") {
symbols(pos.uppNew[,1], pos.uppNew[,2],
add = TRUE, inches = FALSE,
circles = 0.95 * abs(bigabs) ^ 0.5 / 2,
bg = ifelse(sig > 0, col.fill, color_bigabs),
fg = ifelse(sig > 0, col.fill, color_bigabs)
)
symbols(pos.lowNew[,1], pos.lowNew[,2],
add = TRUE, inches = FALSE,
circles = 0.95 * abs(smallabs) ^ 0.5 / 2,
bg = ifelse(sig > 0, bg, color_smallabs),
fg = ifelse(sig > 0, col.fill, color_smallabs))
}
if (plotCI == "square") {
symbols(pos.uppNew[,1], pos.uppNew[,2],
add = TRUE, inches = FALSE,
squares = abs(bigabs) ^ 0.5,
bg = ifelse(sig > 0, col.fill, color_bigabs),
fg = ifelse(sig > 0, col.fill, color_bigabs))
symbols(pos.lowNew[,1], pos.lowNew[,2],
add = TRUE, inches = FALSE,
squares = abs(smallabs) ^ 0.5,
bg = ifelse(sig > 0, bg, color_smallabs),
fg = ifelse(sig > 0, col.fill, color_smallabs))
}
if (plotCI == "rect") {
rect.width <- 0.25
rect(pos.uppNew[,1] - rect.width, pos.uppNew[,2] + smallabs / 2,
pos.uppNew[,1] + rect.width, pos.uppNew[,2] + bigabs / 2,
col = col.fill, border = col.fill)
segments(pos.lowNew[,1] - rect.width, pos.lowNew[,2] + DAT / 2,
pos.lowNew[,1] + rect.width, pos.lowNew[,2] + DAT / 2,
col = "black", lwd = 1)
segments(pos.uppNew[,1] - rect.width, pos.uppNew[,2] + uppNew / 2,
pos.uppNew[,1] + rect.width, pos.uppNew[,2] + uppNew / 2,
col = "black", lwd = 1)
segments(pos.lowNew[,1] - rect.width, pos.lowNew[,2] + lowNew / 2,
pos.lowNew[,1] + rect.width, pos.lowNew[,2] + lowNew / 2,
col = "black", lwd = 1)
segments(pos.lowNew[,1] - 0.5,pos.lowNew[,2],
pos.lowNew[,1] + 0.5, pos.lowNew[,2], col = "grey70", lty = 3)
}
}
if (!is.null(p.mat) && insig != "n") {
if (order != "original") {
p.mat <- p.mat[ord, ord]
}
pos.pNew <- getPos.Dat(p.mat)[[1]]
pNew <- getPos.Dat(p.mat)[[2]]
if (insig == "label_sig") {
# Unless another character is specified, mark sig with *
if (!is.character(pch))
pch <- "*"
place_points <- function(sig.locs, point) {
text(pos.pNew[,1][sig.locs], pos.pNew[,2][sig.locs],
labels = point, col = pch.col, cex = pch.cex, lwd = 2)
}
if (length(sig.level) == 1) {
place_points(sig.locs = which(pNew < sig.level), point = pch)
} else {
l <- length(sig.level)
for (i in seq_along(sig.level)) {
iter <- l + 1 - i
pchTmp <- paste(rep(pch, i), collapse = "")
if (i == length(sig.level)) {
locs <- which(pNew < sig.level[iter])
if (length(locs)) {
place_points(sig.locs = locs, point = pchTmp)
}
} else {
locs <- which(pNew < sig.level[iter] & pNew > sig.level[iter - 1])
if (length(locs)) {
place_points(sig.locs = locs, point = pchTmp)
}
}
}
}
} else {
ind.p <- which(pNew < sig.level)
p_inSig <- length(ind.p) > 0
if (insig == "pch" && p_inSig) {
points(pos.pNew[,1][ind.p], pos.pNew[,2][ind.p],
pch = pch, col = pch.col, cex = pch.cex, lwd = 2)
}
if (insig == "p-value" && p_inSig) {
text(pos.pNew[,1][ind.p], pos.pNew[,2][ind.p],
round(pNew[ind.p],2), col = pch.col)
}
if (insig == "blank" && p_inSig) {
symbols(pos.pNew[,1][ind.p], pos.pNew[,2][ind.p], inches = FALSE,
squares = rep(1, length(pos.pNew[,1][ind.p])),
fg = addgrid.col, bg = bg, add = TRUE)
}
}
}
### 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]
if (is.null(cl.length)) {
cl.length <- ifelse(length(colbar) > 20, 11, length(colbar) + 1)
}
labels <- round(seq(cl.lim[1], cl.lim[2], length = cl.length), 2)
labels[1] <- paste0("< ",labels[1])
labels[length(labels)] <- paste0(">",labels[length(labels)])
if (cl.pos == "r") {
vertical <- TRUE
xlim <- c(m2 + 0.5 + mm * 0.02, m2 + 0.5 + mm * cl.ratio)
ylim <- c(n1 - 0.5, n2 + 0.5)
}
if (cl.pos == "b") {
vertical <- FALSE
xlim <- c(m1 - 0.5, m2 + 0.5)
ylim <- c(n1 - 0.5 - nn * cl.ratio, n1 - 0.5 - nn * 0.02)
}
colorlegend(colbar = colbar, labels = labels,
offset = cl.offset, ratio.colbar = 0.3, cex = cl.cex,
xlim = xlim, ylim = ylim, vertical = vertical,
align = cl.align.text)
}
### square size legend
if (ssl.pos != "n") {
colRange <- assign.color(dat = cl.lim2)
ind1 <- which(col == colRange[1])
ind2 <- which(col == colRange[2])
colbar <- col[ind1:ind2]
if (is.null(cl.length)) {
cl.length <- ifelse(length(colbar) > 20, 11, length(colbar) + 1)
}
leg.p <- 10^-round(seq(1,max(-log10(p.mat)),length.out = ssl.lev))
leg.mat <-getPos.Dat(matrix(leg.p,length(leg.p),1))
leg.mat[[1]][,1] <-ncol(p.mat)+3
leg.mat[[1]][,2] <- 3:(2+length(leg.p))
symbols(leg.mat[[1]], add = TRUE, inches = FALSE,
squares = (-log10(leg.mat[[2]])/max(-log10(p.mat)) )^ 0.5,
bg = col[15], fg = "white")
leg.sig <-rep("",length(leg.p))
leg.sig[leg.p< sig.level] <- "*"
text(leg.mat[[1]],label =leg.sig)
leg.mat[[1]][,1] <-ncol(p.mat)+5
if(!is.null(p.min)) leg.mat[[2]][length(leg.mat[[2]])] <- paste0("<",leg.mat[[2]][length(leg.mat[[2]])])
leg.mat[[2]][ssl.lev] <- paste0("<",leg.mat[[2]][ssl.lev])
text(leg.mat[[1]],labels = leg.mat[[2]])
text(ncol(p.mat)+4,3+length(leg.p),labels = "p-value")
}
## add variable names and title
if (tl.pos != "n") {
pos.xlabel <- cbind(m1:m2, n2 + 0.5 + laboffset)
pos.ylabel <- cbind(m1 - 0.5, n2:n1)
if (tl.pos == "td") {
if (type != "upper") {
stop("type should be \"upper\" if tl.pos is \"dt\".")
}
pos.ylabel <- cbind(m1:(m1 + nn) - 0.5, n2:n1)
}
if (tl.pos == "ld") {
if (type != "lower") {
stop("type should be \"lower\" if tl.pos is \"ld\".")
}
pos.xlabel <- cbind(m1:m2, n2:(n2 - mm) + 0.5 + laboffset)
}
if (tl.pos == "d") {
pos.ylabel <- cbind(m1:(m1 + nn) - 0.5, n2:n1)
pos.ylabel <- pos.ylabel[1:min(n, m),]
symbols(pos.ylabel[,1] + 0.5, pos.ylabel[,2], add = TRUE,
bg = bg, fg = addgrid.col,
inches = FALSE, squares = rep(1, length(pos.ylabel[,1])))
text(pos.ylabel[,1] + 0.5, pos.ylabel[,2], newcolnames[1:min(n, m)],
col = tl.col, cex = tl.cex, ...)
} else {
text(pos.xlabel[,1], pos.xlabel[,2], newcolnames, srt = tl.srt,
adj = ifelse(tl.srt == 0, c(0.5,0), c(0,0)),
col = tl.col, cex = tl.cex, offset = tl.offset, ...)
text(pos.ylabel[,1], pos.ylabel[,2], newrownames,
col = tl.col, cex = tl.cex, pos = 2, offset = tl.offset, ...)
}
}
title(title, ...)
## add numbers
if (!is.null(addCoef.col) && method != "number") {
text(Pos[,1], Pos[,2], col = addCoef.col,
labels = round((DAT - int) * ifelse(addCoefasPercent, 100, 1) / zoom,
number.digits),
cex = number.cex, font = number.font)
}
## add grid, in case of the grid is ate when "diag=FALSE"
if (type == "full" && plotCI == "n" && !is.null(addgrid.col)) {
rect(m1 - 0.5, n1 - 0.5, m2 + 0.5, n2 + 0.5, border = addgrid.col)
}
## draws rectangles, call function corrRect.hclust
if (!is.null(addrect) && order == "hclust" && type == "full") {
corrRect.hclust(corr, k = addrect, method = hclust.method,
col = rect.col, lwd = rect.lwd)
}
invisible(corr) # reordered correlation matrix
}
#' @note pure function
#' @noRd
draw_method_square <- function(coords, values, asp_rescale_factor, fg, bg) {
symbols(coords, add = TRUE, inches = FALSE,
squares = asp_rescale_factor * abs(values) ^ 0.5,
bg = bg, fg = fg)
}
#' @note pure function
#' @noRd
draw_method_color <- function(coords, fg, bg) {
symbols(coords, squares = rep(1, nrow(coords)), fg = fg, bg = bg,
add = TRUE, inches = FALSE)
}
#' @note pure function
#' @noRd
draw_grid <- function(coords, fg) {
symbols(coords, add = TRUE, inches = FALSE, fg = fg, bg = NA,
rectangles = matrix(1, nrow = nrow(coords), ncol = 2))
}
MortenKrebs/diagtraject documentation built on March 6, 2021, 10:54 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions draw_grid draw_method_color draw_method_square corrplot
Documented in corrplot
#' Modification of \code{corrplot::corrplot} by \code{https://github.com/taiyun}, that enable square size to repressent p-values.
#'
#' A graphical display of a correlation matrix, confidence interval. The details
#' are paid great attention to. It can also visualize a general matrix by
#' setting \code{is.corr = FALSE}.
#'
#' @param corr The correlation matrix to visualize, must be square if
#' \code{order} is not \code{"original"}. For general matrix, please using
#' \code{is.corr = FALSE} to convert.
#'
#' @param method Character, the visualization method of correlation matrix to be
#' used. Currently, it supports seven methods, named \code{"circle"}
#' (default), \code{"square"}, \code{"ellipse"}, \code{"number"},
#' \code{"pie"}, \code{"shade"} and \code{"color"}. See examples for details.
#'
#' The areas of circles or squares show the absolute value of corresponding
#' correlation coefficients. Method \code{"pie"} and \code{"shade"} came from
#' Michael Friendly's job (with some adjustment about the shade added on), and
#' \code{"ellipse"} came from D.J. Murdoch and E.D. Chow's job, see in section
#' References.
#'
#' @param type Character, \code{"full"} (default), \code{"upper"} or
#' \code{"lower"}, display full matrix, lower triangular or upper triangular
#' matrix.
#'
#' @param add Logical, if \code{TRUE}, the graph is added to an existing plot,
#' 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{colorRampPalette(col2)(200)}, see example about col2.
#'
#' @param full_col Logical, whether to use the entire color spectrum
#' defined in \code{col} for visualization.
#'
#' @param bg The background color.
#'
#' @param title Character, title of the graph.
#'
#' @param is.corr Logical, whether the input matrix is a correlation matrix or
#' not. We can visualize the non-correlation matrix by setting
#' \code{is.corr = FALSE}.
#'
#' @param diag Logical, whether display the correlation coefficients on the
#' principal diagonal.
#'
#' @param outline Logical or character, whether plot outline of circles, square
#' and ellipse, or the color of these glyphs. For pie, this represents the
#' color of the circle outlining the pie. If \code{outline} is \code{TRUE},
#' the default value is \code{"black"}.
#'
#' @param mar See \code{\link{par}}.
#'
#' @param addgrid.col The color of the grid. If \code{NA}, don't add grid. If
#' \code{NULL} the default value is chosen. The default value depends on
#' \code{method}, if \code{method} is \code{color} or \code{shade}, the color
#' of the grid is \code{NA}, that is, not draw grid; otherwise \code{"grey"}.
#'
#' @param addCoef.col Color of coefficients added on the graph. If \code{NULL}
#' (default), add no coefficients.
#'
#' @param addCoefasPercent Logic, whether translate coefficients into percentage
#' style for spacesaving.
#'
#' @param order Character, the ordering method of the correlation matrix.
#' \itemize{
#' \item{\code{"original"} for original order (default).}
#' \item{\code{"AOE"} for the angular order of the eigenvectors.}
#' \item{\code{"FPC"} for the first principal component order.}
#' \item{\code{"hclust"} for the hierarchical clustering order.}
#' \item{\code{"alphabet"} for alphabetical order.}
#' }
#'
#' See function \code{\link{corrMatOrder}} for details.
#'
#' @param hclust.method Character, the agglomeration method to be used when
#' \code{order} is \code{\link{hclust}}. This should be one of \code{"ward"},
#' \code{"ward.D"}, \code{"ward.D2"}, \code{"single"}, \code{"complete"},
#' \code{"average"}, \code{"mcquitty"}, \code{"median"} or \code{"centroid"}.
#'
#' @param addrect Integer, the number of rectangles draws on the graph according
#' to the hierarchical cluster, only valid when \code{order} is \code{hclust}.
#' If \code{NULL} (default), then add no rectangles.
#'
#' @param rect.col Color for rectangle border(s), only valid when \code{addrect}
#' is equal or greater than 1.
#'
#' @param rect.lwd Numeric, line width for borders for rectangle border(s), only
#' valid when \code{addrect} is equal or greater than 1.
#'
#' @param tl.pos Character or logical, position of text labels. If character, it
#' must be one of \code{"lt"}, \code{"ld"}, \code{"td"}, \code{"d"} or
#' \code{"n"}. \code{"lt"}(default if \code{type=="full"}) means left and top,
#' \code{"ld"}(default if \code{type=="lower"}) means left and diagonal,
#' \code{"td"}(default if \code{type=="upper"}) means top and diagonal(near),
#' \code{"d"} means diagonal, \code{"n"} means don't add textlabel.
#'
#' @param tl.cex Numeric, for the size of text label (variable names).
#'
#' @param tl.col The color of text label.
#'
#' @param tl.offset Numeric, for text label, see \code{\link{text}}.
#'
#' @param tl.srt Numeric, for text label string rotation in degrees, see
#' \code{\link{text}}.
#'
#' @param cl.pos Character or logical, position of color labels; If character,
#' it must be one of \code{"r"} (default if \code{type=="upper"} or
#' \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
#' when \code{length(col) > 20}
#'
#' @param cl.cex Numeric, cex of number-label in colorlabel, passed to
#' \code{\link{colorlegend}}.
#'
#' @param cl.ratio Numeric, to justify the width of colorlabel, 0.1~0.2 is
#' suggested.
#'
#' @param cl.align.text Character, \code{"l"}, \code{"c"} (default) or
#' \code{"r"}, for number-label in colorlabel, \code{"l"} means left,
#' \code{"c"} means center, and \code{"r"} means right.
#'
#' @param cl.offset Numeric, for number-label in colorlabel, see
#' \code{\link{text}}.
#'
#' @param ssl.pos Character or logical, position of square size legend; If character,
#' it must be one of \code{"r"} or \code{"b"}. Default \code{"n"}
#' means don't draw square size legend.
#'
#' @param ssl.lev Integer indicating number of levels in draw square size legend. Default \code{6}
#' levels.
#'
#' @param number.cex The \code{cex} parameter to send to the call to \code{text}
#' when writing the correlation coefficients into the plot.
#'
#' @param number.font the \code{font} parameter to send to the call to
#' \code{text} when writing the correlation coefficients into the plot.
#'
#' @param number.digits indicating the number of decimal digits to be
#' added into the plot. Non-negative integer or NULL, default NULL.
#'
#' @param addshade Character for shade style, \code{"negative"},
#' \code{"positive"} or \code{"all"}, only valid when \code{method} is
#' \code{"shade"}. If \code{"all"}, all correlation coefficients' glyph will
#' be shaded; if \code{"positive"}, only the positive will be shaded; if
#' \code{"negative"}, only the negative will be shaded. Note: the angle of
#' shade line is different, 45 degrees for positive and 135 degrees for
#' negative.
#'
#' @param shade.lwd Numeric, the line width of shade.
#'
#' @param shade.col The color of shade line.
#'
#' @param p.mat Matrix of p-value, if \code{NULL}, arguments \code{sig.level},
#' \code{insig}, \code{pch}, \code{pch.col}, \code{pch.cex} is invalid.
#'
#' @param sig.level Significant level, if the p-value in \code{p-mat} is bigger
#' than \code{sig.level}, then the corresponding correlation coefficient is
#' regarded as insignificant. If \code{insig} is \code{"label_sig"}, this may
#' be an increasing vector of significance levels, in which case \code{pch}
#' will be used once for the highest p-value interval and multiple times
#' (e.g. "*", "**", "***") for each lower p-value interval.
#'
#' @param insig Character, specialized insignificant correlation coefficients,
#' \code{"pch"} (default), \code{"p-value"}, \code{"blank"}, \code{"n"}, or
#' \code{"label_sig"}. If \code{"blank"}, wipe away the corresponding glyphs;
#' if \code{"p-value"}, add p-values the corresponding glyphs;
#' if \code{"pch"}, add characters (see \code{pch} for details) on
#' corresponding glyphs; if \code{"n"}, don't take any measures; if
#' \code{"label_sig"}, mark significant correlations with pch
#' (see \code{sig.level}).
#'
#' @param pch Add character on the glyphs of insignificant correlation
#' coefficients(only valid when \code{insig} is \code{"pch"}). See
#' \code{\link{par}}.
#'
#' @param pch.col The color of pch (only valid when \code{insig} is
#' \code{"pch"}).
#'
#' @param pch.cex The cex of pch (only valid when \code{insig} is \code{"pch"}).
#'
#' @param plotCI Character, method of ploting confidence interval. If
#' \code{"n"}, don't plot confidence interval. If "rect", plot rectangles
#' whose upper side means upper bound and lower side means lower bound,
#' respectively, and meanwhile correlation coefficients are also added on the
#' rectangles. If "circle", first plot a circle with the bigger absolute
#' bound, and then plot the smaller. Warning: if the two bounds are the same
#' sign, the smaller circle will be wiped away, thus forming a ring. Method
#' "square" is similar to "circle".
#'
#' @param lowCI.mat Matrix of the lower bound of confidence interval.
#'
#' @param uppCI.mat Matrix of the upper bound of confidence interval.
#'
#' @param na.label Label to be used for rendering \code{NA} cells. Default is
#' \code{"?"}. If "square", then the cell is rendered as a square with the
#' \code{na.label.col} color.
#'
#' @param na.label.col Color used for rendering \code{NA} cells. Default is
#' \code{"black"}.
#'
#' @param win.asp Aspect ration for the whole plot. Value other than 1 is
#' currently compatible only with methods "circle" and "square".
#'
#' @param \dots Additional arguments passing to function \code{text} for drawing
#' text label.
#'
#' @return (Invisibly) returns a reordered correlation matrix.
#'
#' @details \code{corrplot} function offers flexible ways to visualize
#' correlation matrix, lower and upper bound of confidence interval matrix.
#'
#' @references
#' Michael Friendly (2002).
#' \emph{Corrgrams: Exploratory displays for correlation matrices}.
#' The American Statistician, 56, 316--324.
#'
#' D.J. Murdoch, E.D. Chow (1996).
#' \emph{A graphical display of large correlation matrices}.
#' The American Statistician, 50, 178--180.
#'
#' @author Taiyun Wei (weitaiyun@@gmail.com)
#' @author Viliam Simko (viliam.simko@@gmail.com)
#' @author Michael Levy (michael.levy@@healthcatalyst.com)
#'
#' @note \code{Cairo} and \code{cairoDevice} packages is strongly recommended to
#' produce high-quality PNG, JPEG, TIFF bitmap files, especially for that
#' \code{method} \code{circle}, \code{ellipse}.
#'
#' @note Row- and column names of the input matrix are used as labels rendered
#' in the corrplot. Plothmath expressions will be used if the name is prefixed
#' by one of the following characters: \code{:}, \code{=} or \code{$}.
#' For example \code{":alpha + beta"}.
#'
#' @seealso Function \code{plotcorr} in the \code{ellipse} package and
#' \code{corrgram} in the \code{corrgram} package have some similarities.
#'
#' Package \code{seriation} offered more methods to reorder matrices, such as
#' ARSA, BBURCG, BBWRCG, MDS, TSP, Chen and so forth.
#'
#'
#' @import graphics grDevices stats
#' @export
#'
#'@examples
#'install.packages("corrplot")
#'library(corrplot)
#'devtools::install_github("MortenKrebs/diagtraject")
#'
#'mat <- matrix(rnorm(100),10,10)
#
#'rownames(mat) <- letters[1:10]
#'colnames(mat) <- letters[11:20]
#'
#'col <- colorRampPalette(c("#67001F", "#B2182B", "#FFFFFF", "#2166AC", "#053061")[5:1])(20)
#'
#'pm <- matrix(runif(100),10,10)
#'pm[pm<1e-6] <- 1e-6
#'
#'corrplot(mat, is.corr=FALSE, p.mat=pm,
#' method="p.square", insig="pch", col=col,
#' sig.level=0.05/56, pch="*", pch.cex=1, mar= c(4,4,4,0),
#' cl.ratio=0.25, cl.align.text="l", cl.lim=c(-5,5),
#' tl.col="black", bg="#fffffc",ssl.pos = "r",ssl.lev=6,full_col=F,cl.pos = "r")
#'text(9.5,9,labels = "log(HR)")
#'mtext("Second Diagnosis",side=3,line=1)
#'mtext("First Diagnosis",side=2,line=1)
#'
corrplot <- function(corr,
method = c("circle", "square", "ellipse", "number", "shade", "color", "pie","p.square"),
type = c("full", "lower", "upper"), add = FALSE,
col = NULL, full_col = TRUE, bg = "white", title = "", is.corr = TRUE,
diag = TRUE, outline = FALSE, mar = c(0, 0, 0, 0),
addgrid.col = NULL, addCoef.col = NULL, addCoefasPercent = FALSE,
order = c("original", "AOE", "FPC", "hclust", "alphabet"),
hclust.method = c("complete", "ward", "ward.D", "ward.D2", "single",
"average", "mcquitty", "median", "centroid"),
addrect = NULL, rect.col = "black", rect.lwd = 2,
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,
number.cex = 1, number.font = 2, number.digits = NULL,
addshade = c("negative", "positive", "all"),
shade.lwd = 1, shade.col = "white",
p.mat = NULL, sig.level = 0.05, p.min=NULL,
insig = c("pch", "p-value", "blank", "n", "label_sig"),
pch = 4, pch.col = "black", pch.cex = 3,
ssl.pos = "n", ssl.lev = 6,
plotCI = c("n", "square", "circle", "rect"),
lowCI.mat = NULL, uppCI.mat = NULL,
na.label = "?", na.label.col = "black",
win.asp = 1,
...)
{
# checking multi-option input parameters
method <- match.arg(method)
type <- match.arg(type)
order <- match.arg(order)
hclust.method <- match.arg(hclust.method)
addshade <- match.arg(addshade)
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.")
}
asp_rescale_factor <- min(1, win.asp) / max(1, win.asp)
stopifnot(asp_rescale_factor >= 0 && asp_rescale_factor <= 1)
if (!is.matrix(corr) && !is.data.frame(corr)) {
stop("Need a matrix or data frame!")
}
# select grid color automatically if not specified
if (is.null(addgrid.col)) {
addgrid.col <- switch(method, color = NA, shade = NA, "grey")
}
if (any(corr < cl.lim[1]) || any(corr > cl.lim[2])) {
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)
} 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))
}
}
intercept <- 0
zoom <- 1
if (!is.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))
}
# ++
# +-
# 0+
else if (c_min >= 0) {
intercept <- -cl.lim[1]
zoom <- 1 / (diff(cl.lim))
}
# -+
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
stopifnot(c_min < 0 && c_max > 0)
intercept <- 0
zoom <- 1 / max(abs(cl.lim))
}
# now, the zoom might still be Inf when cl.lim were both zero
if (zoom == Inf) {
stopifnot(cl.lim[1] == 0 && cl.lim[2] == 0) # check the assumption
zoom <- 0
}
corr <- (intercept + corr) * zoom
}
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",
"#FDDBC7", "#FFFFFF", "#D1E5F0", "#92C5DE",
"#4393C3", "#2166AC", "#053061"))(200)
}
n <- nrow(corr)
m <- ncol(corr)
min.nm <- min(n,m)
ord <- seq_len(min.nm)
if (order != "original") {
ord <- corrMatOrder(corr, order = order, hclust.method = hclust.method)
corr <- corr[ord, ord]
}
## set up variable names
if (is.null(rownames(corr))) {
rownames(corr) <- seq_len(n)
}
if (is.null(colnames(corr))) {
colnames(corr) <- seq_len(m)
}
# assigns Inf to cells in the matrix depending on the type paramter
apply_mat_filter <- function(mat) {
x <- matrix(1:n * m, nrow = n, ncol = m)
switch(type,
upper = mat[row(x) > col(x)] <- Inf,
lower = mat[row(x) < col(x)] <- Inf
)
if (!diag) {
diag(mat) <- Inf
}
return(mat)
}
# retrieves coordinates of cells to be rendered
getPos.Dat <- function(mat) {
tmp <- apply_mat_filter(mat)
Dat <- tmp[is.finite(tmp)]
ind <- which(is.finite(tmp), arr.ind = TRUE)
Pos <- ind
Pos[,1] <- ind[,2]
Pos[,2] <- -ind[,1] + 1 + n
return(list(Pos, Dat))
}
# retrieves coordinates of NA cells
# we use this for rending NA cells differently
getPos.NAs <- function(mat) {
tmp <- apply_mat_filter(mat)
ind <- which(is.na(tmp), arr.ind = TRUE)
Pos <- ind
Pos[,1] <- ind[,2]
Pos[,2] <- -ind[,1] + 1 + n
return(Pos)
}
Pos <- getPos.Dat(corr)[[1]]
# decide whether NA labels are going to be rendered or whether we ignore them
if (any(is.na(corr)) && is.character(na.label)) {
PosNA <- getPos.NAs(corr)
} else {
# explicitly set to NULL to indicate that NA labels are not going to be
# rendered
PosNA <- NULL
}
AllCoords <- rbind(Pos, PosNA)
# rows
n2 <- max(AllCoords[,2])
n1 <- min(AllCoords[,2])
nn <- n2 - n1
# columns
m2 <- max(AllCoords[,1])
m1 <- min(AllCoords[,1])
# Issue #19: legend color bar width 0 when using just one column matrix
# also discussed here: http://stackoverflow.com/questions/34638555/
mm <- max(1, m2 - m1)
# Issue #20: support plotmath expressions in rownames and colnames
expand_expression <- function(s) {
ifelse(grepl("^[:=$]", s), parse(text = substring(s, 2)), s)
}
newrownames <- sapply(
rownames(corr)[(n + 1 - n2):(n + 1 - n1)], expand_expression)
newcolnames <- sapply(
colnames(corr)[m1:m2], expand_expression)
DAT <- getPos.Dat(corr)[[2]]
len.DAT <- length(DAT)
rm(expand_expression) # making sure the function is only used here
# scale data to range [lower, upper]
# if the dataspan is invalid we use the coller in the middle of the interval
scale_to_range <- function(data, lower = 1, upper) {
dataspan <- max(data) - min(data)
if (dataspan == 0)
rep((upper - lower) / 2, length(data)) # middle color
else
(upper - lower) * (data - min(data)) / dataspan + lower # full range
}
## assign colors
assign.color <- function(dat = DAT, color = col) {
if (full_col) {
# Rescale data before computing color to ensure that all colors are used.
newcorr <- scale_to_range(data = dat, lower = 1, upper = length(color))
color[floor(newcorr)]
} else {
newcorr <- (dat + 1) / 2
newcorr[newcorr <= 0] <- 0
newcorr[newcorr >= 1] <- 1 - 1e-16
color[floor(newcorr * length(color)) + 1] # new color returned
}
}
col.fill <- assign.color()
isFALSE <- function(x) identical(x, FALSE)
isTRUE <- function(x) identical(x, TRUE)
if (isFALSE(tl.pos)) {
tl.pos <- "n"
}
if (is.null(tl.pos) || isTRUE(tl.pos)) {
tl.pos <- switch(type, full = "lt", lower = "ld", upper = "td")
}
if (isFALSE(cl.pos)) {
cl.pos <- "n"
}
if (is.null(cl.pos) || isTRUE(cl.pos)) {
cl.pos <- switch(type, full = "r", lower = "b", upper = "r")
}
if (isFALSE(outline)) {
col.border <- col.fill
} else if (isTRUE(outline)) {
col.border <- "black"
} else if (is.character(outline)) {
col.border <- outline
} else {
stop("Unsupported value type for parameter outline")
}
# restore this parameter when exiting the corrplot function in any way
oldpar <- par(mar = mar, bg = par()$bg)
on.exit(par(oldpar), add = TRUE)
## calculate label-text width approximately
if (!add) {
plot.new()
# Issue #10: code from Sebastien Rochette (github user @statnmap)
xlabwidth <- max(strwidth(newrownames, cex = tl.cex))
ylabwidth <- max(strwidth(newcolnames, cex = tl.cex))
laboffset <- strwidth("W", cex = tl.cex) * tl.offset
# Issue #10
for (i in 1:50) {
xlim <- c(
m1 - 0.5 - laboffset -
xlabwidth * (grepl("l", tl.pos) | grepl("d", tl.pos)),
m2 + 0.5 + mm * cl.ratio * (cl.pos == "r") +
xlabwidth * abs(cos(tl.srt * pi / 180)) * grepl("d", tl.pos)
) #+ c(-0.35, 0.15)
ylim <- c(
n1 - 0.5 - nn * cl.ratio * (cl.pos == "b") - laboffset,
n2 + 0.5 + laboffset +
ylabwidth * abs(sin(tl.srt * pi / 180)) * grepl("t", tl.pos)
) +
#c(-0.15, 0) +
c(0, -1) * (type == "upper" && tl.pos != "n") # nasty hack
# note: the nasty hack above is related to multiple issues
# (e.g. #96, #94, #102)
plot.window(xlim, ylim, asp = 1, xaxs = "i", yaxs = "i")
x.tmp <- max(strwidth(newrownames, cex = tl.cex))
y.tmp <- max(strwidth(newcolnames, cex = tl.cex))
laboffset.tmp <- strwidth("W", cex = tl.cex) * tl.offset
if (max(x.tmp - xlabwidth,
y.tmp - ylabwidth,
laboffset.tmp - laboffset) < 1e-03) {
break
}
xlabwidth <- x.tmp
ylabwidth <- y.tmp
laboffset <- laboffset.tmp
if (i == 50) {
warning(c("Not been able to calculate text margin, ",
"please try again with a clean new empty window using ",
"{plot.new(); dev.off()} or reduce tl.cex"))
}
}
if (.Platform$OS.type == "windows") {
grDevices::windows.options(width = 7,
height = 7 * diff(ylim) / diff(xlim))
}
xlim <- xlim + diff(xlim) * 0.01 * c(-1, 1)
ylim <- ylim + diff(ylim) * 0.01 * c(-1, 1)
plot.window(xlim = xlim , ylim = ylim,
asp = win.asp, xlab = "", ylab = "", xaxs = "i", yaxs = "i")
}
## for: add = TRUE
laboffset <- strwidth("W", cex = tl.cex) * tl.offset
## background for the cells
symbols(Pos, add = TRUE, inches = FALSE,
rectangles = matrix(1, len.DAT, 2), bg = bg, fg = bg)
## circle
if (method == "circle" && plotCI == "n") {
symbols(Pos, add = TRUE, inches = FALSE,
circles = asp_rescale_factor * 0.9 * abs(DAT) ^ 0.5 / 2,
fg = col.border, bg = col.fill)
}
## ellipse
if (method == "ellipse" && plotCI == "n") {
ell.dat <- function(rho, length = 99) {
k <- seq(0, 2 * pi, length = length)
x <- cos(k + acos(rho) / 2) / 2
y <- cos(k - acos(rho) / 2) / 2
cbind(rbind(x,y), c(NA, NA))
}
ELL.dat <- lapply(DAT, ell.dat)
ELL.dat2 <- 0.85 * matrix(unlist(ELL.dat), ncol = 2, byrow = TRUE)
ELL.dat2 <- ELL.dat2 + Pos[rep(1:length(DAT),each = 100),]
polygon(ELL.dat2, border = col.border, col = col.fill)
}
## number
if (is.null(number.digits)) {
# TODO: this expression might be confusing
number.digits <- switch(addCoefasPercent + 1, 2, 0)
}
stopifnot(number.digits %% 1 == 0) # is whole number
stopifnot(number.digits >= 0) # is non-negative number
if (method == "number" && plotCI == "n") {
x <- (DAT - int) * ifelse(addCoefasPercent, 100, 1) / zoom
text(Pos[,1], Pos[,2], font = number.font, col = col.fill,
labels = format(round(x, number.digits), nsmall = number.digits),
cex = number.cex)
}
# Issue #55: Support for multiple characters when rendering NAs
NA_LABEL_MAX_CHARS <- 2
# renders NA cells
if (is.matrix(PosNA) && nrow(PosNA) > 0) {
stopifnot(is.matrix(PosNA)) # sanity check
if (na.label == "square") {
symbols(PosNA, add = TRUE, inches = FALSE,
squares = rep(1, nrow(PosNA)),
bg = na.label.col, fg = na.label.col)
} else if (nchar(na.label) %in% 1:NA_LABEL_MAX_CHARS) {
symbols(PosNA, add = TRUE, inches = FALSE,
squares = rep(1, nrow(PosNA)), fg = bg, bg = bg)
text(PosNA[,1], PosNA[,2], font = number.font,
col = na.label.col,
labels = na.label, cex = number.cex, ...)
} else {
stop(paste("Maximum number of characters for NA label is:",
NA_LABEL_MAX_CHARS))
}
}
## pie
if (method == "pie" && plotCI == "n") {
# Issue #18: Corrplot background circle
symbols(Pos, add = TRUE, inches = FALSE,
circles = rep(0.5, len.DAT) * 0.85, fg = col.border)
pie.dat <- function(theta, length = 100) {
k <- seq(pi / 2, pi / 2 - theta, length = 0.5 * length * abs(theta) / pi)
x <- c(0, cos(k) / 2, 0)
y <- c(0, sin(k) / 2, 0)
cbind(rbind(x,y), c(NA, NA)) # pie.dat returned
}
PIE.dat <- lapply(DAT * 2 * pi, pie.dat)
len.pie <- unlist(lapply(PIE.dat, length)) / 2
PIE.dat2 <- 0.85 * matrix(unlist(PIE.dat), ncol = 2, byrow = TRUE)
PIE.dat2 <- PIE.dat2 + Pos[rep(1:length(DAT), len.pie),]
polygon(PIE.dat2, border = "black", col = col.fill)
}
## shade
if (method == "shade" && plotCI == "n") {
symbols(Pos, add = TRUE, inches = FALSE, squares = rep(1, len.DAT),
bg = col.fill, fg = addgrid.col)
shade.dat <- function(w) {
x <- w[1]
y <- w[2]
rho <- w[3]
x1 <- x - 0.5
x2 <- x + 0.5
y1 <- y - 0.5
y2 <- y + 0.5
dat <- NA
if ((addshade == "positive" || addshade == "all") && rho > 0) {
dat <- cbind(c(x1, x1, x), c(y, y1, y1),
c(x, x2, x2), c(y2, y2 ,y))
}
if ((addshade == "negative" || addshade == "all") && rho < 0) {
dat <- cbind(c(x1, x1, x), c(y, y2, y2),
c(x, x2, x2), c(y1, y1 ,y))
}
return(t(dat))
}
pos_corr <- rbind(cbind(Pos, DAT))
pos_corr2 <- split(pos_corr, 1:nrow(pos_corr))
SHADE.dat <- matrix(na.omit(unlist(lapply(pos_corr2, shade.dat))),
byrow = TRUE, ncol = 4)
segments(SHADE.dat[,1], SHADE.dat[,2], SHADE.dat[,3],
SHADE.dat[,4], col = shade.col, lwd = shade.lwd)
}
## square
if (method == "p.square" && plotCI == "n") {
if(!is.null(p.min)) p.mat[p.mat<p.min]<-p.min
p.mat_log <- -log10(p.mat)/max(-log10(p.mat))
draw_method_square(Pos, getPos.Dat(p.mat_log)[[2]], asp_rescale_factor, col.border, col.fill)
}
if (method == "square" && plotCI == "n") {
draw_method_square(Pos, getPos.Dat(p.mat)[[2]], asp_rescale_factor, col.border, col.fill)
}
## color
if (method == "color" && plotCI == "n") {
draw_method_color(Pos, col.border, col.fill)
}
## add grid
draw_grid(AllCoords, addgrid.col)
if (plotCI != "n") {
if (is.null(lowCI.mat) || is.null(uppCI.mat)) {
stop("Need lowCI.mat and uppCI.mat!")
}
if (order != "original") {
lowCI.mat <- lowCI.mat[ord, ord]
uppCI.mat <- uppCI.mat[ord, ord]
}
pos.lowNew <- getPos.Dat(lowCI.mat)[[1]]
lowNew <- getPos.Dat(lowCI.mat)[[2]]
pos.uppNew <- getPos.Dat(uppCI.mat)[[1]]
uppNew <- getPos.Dat(uppCI.mat)[[2]]
if (!method %in% c("circle", "square")) {
stop("Method shoud be circle or square if drawing confidence intervals.")
}
k1 <- (abs(uppNew) > abs(lowNew))
bigabs <- uppNew
bigabs[which(!k1)] <- lowNew[!k1]
smallabs <- lowNew
smallabs[which(!k1)] <- uppNew[!k1]
sig <- sign(uppNew * lowNew)
color_bigabs <- col[ceiling((bigabs + 1) * length(col) / 2)]
color_smallabs <- col[ceiling((smallabs + 1) * length(col) / 2)]
if (plotCI == "circle") {
symbols(pos.uppNew[,1], pos.uppNew[,2],
add = TRUE, inches = FALSE,
circles = 0.95 * abs(bigabs) ^ 0.5 / 2,
bg = ifelse(sig > 0, col.fill, color_bigabs),
fg = ifelse(sig > 0, col.fill, color_bigabs)
)
symbols(pos.lowNew[,1], pos.lowNew[,2],
add = TRUE, inches = FALSE,
circles = 0.95 * abs(smallabs) ^ 0.5 / 2,
bg = ifelse(sig > 0, bg, color_smallabs),
fg = ifelse(sig > 0, col.fill, color_smallabs))
}
if (plotCI == "square") {
symbols(pos.uppNew[,1], pos.uppNew[,2],
add = TRUE, inches = FALSE,
squares = abs(bigabs) ^ 0.5,
bg = ifelse(sig > 0, col.fill, color_bigabs),
fg = ifelse(sig > 0, col.fill, color_bigabs))
symbols(pos.lowNew[,1], pos.lowNew[,2],
add = TRUE, inches = FALSE,
squares = abs(smallabs) ^ 0.5,
bg = ifelse(sig > 0, bg, color_smallabs),
fg = ifelse(sig > 0, col.fill, color_smallabs))
}
if (plotCI == "rect") {
rect.width <- 0.25
rect(pos.uppNew[,1] - rect.width, pos.uppNew[,2] + smallabs / 2,
pos.uppNew[,1] + rect.width, pos.uppNew[,2] + bigabs / 2,
col = col.fill, border = col.fill)
segments(pos.lowNew[,1] - rect.width, pos.lowNew[,2] + DAT / 2,
pos.lowNew[,1] + rect.width, pos.lowNew[,2] + DAT / 2,
col = "black", lwd = 1)
segments(pos.uppNew[,1] - rect.width, pos.uppNew[,2] + uppNew / 2,
pos.uppNew[,1] + rect.width, pos.uppNew[,2] + uppNew / 2,
col = "black", lwd = 1)
segments(pos.lowNew[,1] - rect.width, pos.lowNew[,2] + lowNew / 2,
pos.lowNew[,1] + rect.width, pos.lowNew[,2] + lowNew / 2,
col = "black", lwd = 1)
segments(pos.lowNew[,1] - 0.5,pos.lowNew[,2],
pos.lowNew[,1] + 0.5, pos.lowNew[,2], col = "grey70", lty = 3)
}
}
if (!is.null(p.mat) && insig != "n") {
if (order != "original") {
p.mat <- p.mat[ord, ord]
}
pos.pNew <- getPos.Dat(p.mat)[[1]]
pNew <- getPos.Dat(p.mat)[[2]]
if (insig == "label_sig") {
# Unless another character is specified, mark sig with *
if (!is.character(pch))
pch <- "*"
place_points <- function(sig.locs, point) {
text(pos.pNew[,1][sig.locs], pos.pNew[,2][sig.locs],
labels = point, col = pch.col, cex = pch.cex, lwd = 2)
}
if (length(sig.level) == 1) {
place_points(sig.locs = which(pNew < sig.level), point = pch)
} else {
l <- length(sig.level)
for (i in seq_along(sig.level)) {
iter <- l + 1 - i
pchTmp <- paste(rep(pch, i), collapse = "")
if (i == length(sig.level)) {
locs <- which(pNew < sig.level[iter])
if (length(locs)) {
place_points(sig.locs = locs, point = pchTmp)
}
} else {
locs <- which(pNew < sig.level[iter] & pNew > sig.level[iter - 1])
if (length(locs)) {
place_points(sig.locs = locs, point = pchTmp)
}
}
}
}
} else {
ind.p <- which(pNew < sig.level)
p_inSig <- length(ind.p) > 0
if (insig == "pch" && p_inSig) {
points(pos.pNew[,1][ind.p], pos.pNew[,2][ind.p],
pch = pch, col = pch.col, cex = pch.cex, lwd = 2)
}
if (insig == "p-value" && p_inSig) {
text(pos.pNew[,1][ind.p], pos.pNew[,2][ind.p],
round(pNew[ind.p],2), col = pch.col)
}
if (insig == "blank" && p_inSig) {
symbols(pos.pNew[,1][ind.p], pos.pNew[,2][ind.p], inches = FALSE,
squares = rep(1, length(pos.pNew[,1][ind.p])),
fg = addgrid.col, bg = bg, add = TRUE)
}
}
}
### 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]
if (is.null(cl.length)) {
cl.length <- ifelse(length(colbar) > 20, 11, length(colbar) + 1)
}
labels <- round(seq(cl.lim[1], cl.lim[2], length = cl.length), 2)
labels[1] <- paste0("< ",labels[1])
labels[length(labels)] <- paste0(">",labels[length(labels)])
if (cl.pos == "r") {
vertical <- TRUE
xlim <- c(m2 + 0.5 + mm * 0.02, m2 + 0.5 + mm * cl.ratio)
ylim <- c(n1 - 0.5, n2 + 0.5)
}
if (cl.pos == "b") {
vertical <- FALSE
xlim <- c(m1 - 0.5, m2 + 0.5)
ylim <- c(n1 - 0.5 - nn * cl.ratio, n1 - 0.5 - nn * 0.02)
}
colorlegend(colbar = colbar, labels = labels,
offset = cl.offset, ratio.colbar = 0.3, cex = cl.cex,
xlim = xlim, ylim = ylim, vertical = vertical,
align = cl.align.text)
}
### square size legend
if (ssl.pos != "n") {
colRange <- assign.color(dat = cl.lim2)
ind1 <- which(col == colRange[1])
ind2 <- which(col == colRange[2])
colbar <- col[ind1:ind2]
if (is.null(cl.length)) {
cl.length <- ifelse(length(colbar) > 20, 11, length(colbar) + 1)
}
leg.p <- 10^-round(seq(1,max(-log10(p.mat)),length.out = ssl.lev))
leg.mat <-getPos.Dat(matrix(leg.p,length(leg.p),1))
leg.mat[[1]][,1] <-ncol(p.mat)+3
leg.mat[[1]][,2] <- 3:(2+length(leg.p))
symbols(leg.mat[[1]], add = TRUE, inches = FALSE,
squares = (-log10(leg.mat[[2]])/max(-log10(p.mat)) )^ 0.5,
bg = col[15], fg = "white")
leg.sig <-rep("",length(leg.p))
leg.sig[leg.p< sig.level] <- "*"
text(leg.mat[[1]],label =leg.sig)
leg.mat[[1]][,1] <-ncol(p.mat)+5
if(!is.null(p.min)) leg.mat[[2]][length(leg.mat[[2]])] <- paste0("<",leg.mat[[2]][length(leg.mat[[2]])])
leg.mat[[2]][ssl.lev] <- paste0("<",leg.mat[[2]][ssl.lev])
text(leg.mat[[1]],labels = leg.mat[[2]])
text(ncol(p.mat)+4,3+length(leg.p),labels = "p-value")
}
## add variable names and title
if (tl.pos != "n") {
pos.xlabel <- cbind(m1:m2, n2 + 0.5 + laboffset)
pos.ylabel <- cbind(m1 - 0.5, n2:n1)
if (tl.pos == "td") {
if (type != "upper") {
stop("type should be \"upper\" if tl.pos is \"dt\".")
}
pos.ylabel <- cbind(m1:(m1 + nn) - 0.5, n2:n1)
}
if (tl.pos == "ld") {
if (type != "lower") {
stop("type should be \"lower\" if tl.pos is \"ld\".")
}
pos.xlabel <- cbind(m1:m2, n2:(n2 - mm) + 0.5 + laboffset)
}
if (tl.pos == "d") {
pos.ylabel <- cbind(m1:(m1 + nn) - 0.5, n2:n1)
pos.ylabel <- pos.ylabel[1:min(n, m),]
symbols(pos.ylabel[,1] + 0.5, pos.ylabel[,2], add = TRUE,
bg = bg, fg = addgrid.col,
inches = FALSE, squares = rep(1, length(pos.ylabel[,1])))
text(pos.ylabel[,1] + 0.5, pos.ylabel[,2], newcolnames[1:min(n, m)],
col = tl.col, cex = tl.cex, ...)
} else {
text(pos.xlabel[,1], pos.xlabel[,2], newcolnames, srt = tl.srt,
adj = ifelse(tl.srt == 0, c(0.5,0), c(0,0)),
col = tl.col, cex = tl.cex, offset = tl.offset, ...)
text(pos.ylabel[,1], pos.ylabel[,2], newrownames,
col = tl.col, cex = tl.cex, pos = 2, offset = tl.offset, ...)
}
}
title(title, ...)
## add numbers
if (!is.null(addCoef.col) && method != "number") {
text(Pos[,1], Pos[,2], col = addCoef.col,
labels = round((DAT - int) * ifelse(addCoefasPercent, 100, 1) / zoom,
number.digits),
cex = number.cex, font = number.font)
}
## add grid, in case of the grid is ate when "diag=FALSE"
if (type == "full" && plotCI == "n" && !is.null(addgrid.col)) {
rect(m1 - 0.5, n1 - 0.5, m2 + 0.5, n2 + 0.5, border = addgrid.col)
}
## draws rectangles, call function corrRect.hclust
if (!is.null(addrect) && order == "hclust" && type == "full") {
corrRect.hclust(corr, k = addrect, method = hclust.method,
col = rect.col, lwd = rect.lwd)
}
invisible(corr) # reordered correlation matrix
}
#' @note pure function
#' @noRd
draw_method_square <- function(coords, values, asp_rescale_factor, fg, bg) {
symbols(coords, add = TRUE, inches = FALSE,
squares = asp_rescale_factor * abs(values) ^ 0.5,
bg = bg, fg = fg)
}
#' @note pure function
#' @noRd
draw_method_color <- function(coords, fg, bg) {
symbols(coords, squares = rep(1, nrow(coords)), fg = fg, bg = bg,
add = TRUE, inches = FALSE)
}
#' @note pure function
#' @noRd
draw_grid <- function(coords, fg) {
symbols(coords, add = TRUE, inches = FALSE, fg = fg, bg = NA,
rectangles = matrix(1, nrow = nrow(coords), ncol = 2))
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.