R/corrplot.R
In taiyun/corrplot: Visualization of a Correlation Matrix
Defines functions
draw_grid
draw_method_color
draw_method_square
corrplot
Documented in
corrplot
#' A visualization of a correlation matrix.
#'
#' 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 col Vector, the colors of glyphs. They are distributed uniformly in
#' \code{col.lim} interval.
#' If \code{is.corr} is \code{TRUE}, the default value will be \code{COL2('RdBu', 200)}.
#' If \code{is.corr} is \code{FALSE} and \code{corr} is a non-negative or non-positive matrix,
#' the default value will be \code{COL1('YlOrBr', 200)};
#' otherwise (elements are partly positive and partly negative),
#' the default value will be \code{COL2('RdBu', 200)}.
#'
#' @param col.lim The limits \code{(x1, x2)} interval for assigning color by
#' \code{col}. If \code{NULL},
#' \code{col.lim} will be \code{c(-1, 1)} when \code{is.corr} is \code{TRUE},
#' \code{col.lim} will be \code{c(min(corr), max(corr))} when \code{is.corr}
#' is \code{FALSE}
#'
#' NOTICE: if you set \code{col.lim} when \code{is.corr} is \code{TRUE}, the assigning colors
#' are still distributed uniformly in [-1, 1], it only affect the display
#' on color-legend.
#'
#' @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 bg The background color.
#'
#' @param title Character, title of the graph.
#'
#'
#' @param add Logical, if \code{TRUE}, the graph is added to an existing plot,
#' otherwise a new plot will be created.
#'
#' @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{'l'} means left,
#' \code{'d'} means diagonal, \code{'n'} means don't add text-label.
#'
#' @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-legend; 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 color-legend.
#'
#' @param cl.length Integer, the number of number-text in color-legend, 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 color-legend, passed to
#' \code{\link{colorlegend}}.
#'
#' @param cl.ratio Numeric, to justify the width of color-legend, 0.1~0.2 is
#' suggested.
#'
#' @param cl.align.text Character, \code{'l'}, \code{'c'} (default) or
#' \code{'r'}, for number-label in color-legend, \code{'l'} means left,
#' \code{'c'} means center, and \code{'r'} means right.
#'
#' @param cl.offset Numeric, for number-label in color-legend, see
#' \code{\link{text}}.
#'
#' @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 transKeepSign Logical, whether or not to keep matrix values' sign when
#' transforming non-corr matrix for plotting.
#' Only valid when \code{is.corr = FALSE}. The default value is \code{TRUE}.
#'
#' NOTE: If \code{FALSE},the non-corr matrix will be
#'
#' @param p.mat Matrix of p-value, if \code{NULL}, parameter \code{sig.level},
#' \code{insig}, \code{pch}, \code{pch.col}, \code{pch.cex} are 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. 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 \code{list(corr, corrTrans, arg)}.
#' \code{corr} is a reordered correlation matrix for plotting.
#' \code{corrPos} is a data frame with \code{xName, yName, x, y, corr} and
#' \code{p.value}(if p.mat is not NULL)
#' column, which x and y are the position on the correlation matrix plot.
#' \code{arg} is a list of some corrplot() input parameters' value.
#' Now \code{type} is in.
#'
#' @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.
#'
#' @example vignettes/example-corrplot.R
#' @import graphics grDevices stats
#' @export
corrplot = function(corr,
method = c('circle', 'square', 'ellipse', 'number', 'shade', 'color', 'pie'),
type = c('full', 'lower', 'upper'), col = NULL, col.lim = NULL, is.corr = TRUE,
bg = 'white', title = '', add = FALSE, 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.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',
transKeepSign = TRUE,
p.mat = NULL, sig.level = 0.05,
insig = c('pch', 'p-value', 'blank', 'n', 'label_sig'),
pch = 4, pch.col = 'black', pch.cex = 3,
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(!is.corr & !transKeepSign & method %in% c('circle', 'square', 'ellipse', 'shade', 'pie')) {
stop("method should not be in c('circle', 'square', 'ellipse', 'shade', 'pie') when transKeepSign = FALSE")
}
# Issue #142
# checks for all values that are not missing
if (any(corr[!is.na(corr)] < col.lim[1]) || any(corr[!is.na(corr)] > col.lim[2])) {
stop('color limits should cover matrix')
}
if (is.null(col.lim)) {
if (is.corr) {
# if the matrix is expected to be a correlation matrix
# it MUST be within the interval [-1,1]
col.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
if(!diag) {
diag(corr) = NA
}
col.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 ^ 0.75 ||
max(corr, na.rm = TRUE) > 1 + .Machine$double.eps ^ 0.75) {
stop('The matrix is not in [-1, 1]!')
}
SpecialCorr = 1
if(col.lim[1] < -1 | col.lim[2] > 1) {
stop('col.lim should be within the interval [-1, 1]')
}
}
intercept = 0
zoom = 1
if (!is.corr) {
c_max = max(corr, na.rm = TRUE)
c_min = min(corr, na.rm = TRUE)
if((col.lim[1] > c_min) | (col.lim[2] < c_max))
{
stop('Wrong color: matrix should be in col.lim interval!')
}
if(diff(col.lim)/(c_max - c_min)> 2) {
warning('col.lim interval too wide, please set a suitable value')
}
# all negative or positive or NOT transkeepSign, trans to [0, 1]
if (c_max <= 0 | c_min>=0 | !transKeepSign) {
intercept = - col.lim[1]
zoom = 1 / (diff(col.lim))
#if(col.lim[1] * col.lim[2] < 0) {
# warning('col.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 remaining case
stopifnot(c_min < 0 && c_max > 0)
intercept = 0
zoom = 1 / max(abs(col.lim))
SpecialCorr = 1
}
corr = (intercept + corr) * zoom
}
col.lim2 = (intercept + col.lim) * zoom
int = intercept * zoom
if (is.null(col) & is.corr) {
col = COL2('RdBu', 200)
}
if (is.null(col) & !is.corr) {
if(col.lim[1] * col.lim[2] < 0) {
col = COL2('RdBu', 200)
} else {
col = COL1('YlOrBr', 200)
}
}
n = nrow(corr)
m = ncol(corr)
min.nm = min(n, m)
ord = 1: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) = 1:n
}
if (is.null(colnames(corr))) {
colnames(corr) = 1: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
PosName = ind
PosName[, 1] = colnames(mat)[ind[, 2]]
PosName[, 2] = rownames(mat)[ind[, 1]]
return(list(Pos, Dat, PosName))
}
# 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)
}
testTemp = getPos.Dat(corr)
Pos = getPos.Dat(corr)[[1]]
PosName = getPos.Dat(corr)[[3]]
# 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
## assign colors
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
}
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) +
ylabwidth * abs(sin(tl.srt * pi / 180)) * (type=='lower') * grepl('d', tl.pos)
) #+ c(-0.15, 0)
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)) {
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 == 'square' && plotCI == 'n') {
draw_method_square(Pos, DAT, 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]]
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)
}
}
## 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)
}
if (!is.null(p.mat)) {
pos.pNew = getPos.Dat(p.mat)[[1]]
pNew = getPos.Dat(p.mat)[[2]]
}
if (!is.null(p.mat) && insig != 'n') {
if (order != 'original') {
p.mat = p.mat[ord, ord]
}
if(!is.null(rownames(p.mat)) | !is.null(rownames(p.mat))) {
if(!all(colnames(p.mat)==colnames(corr)) |
!all(rownames(p.mat)==rownames(corr))) {
warning('p.mat and corr may be not paired, their rownames and colnames are not totally same!')
}
}
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], number.digits), 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 = col.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 = seq(col.lim[1], col.lim[2], length = cl.length)
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 = round(labels, 2),
offset = cl.offset, ratio.colbar = 0.3, cex = cl.cex,
xlim = xlim, ylim = ylim, vertical = vertical,
align = cl.align.text)
}
## 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 {
if(tl.pos != 'l') {
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 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)
}
corrPos = data.frame(PosName, Pos, DAT)
colnames(corrPos) = c('xName', 'yName', 'x', 'y', 'corr')
if(!is.null(p.mat)) {
corrPos = cbind(corrPos, pNew)
colnames(corrPos)[6] = c('p.value')
}
corrPos = corrPos[order(corrPos[, 3], -corrPos[, 4]), ]
rownames(corrPos) = NULL
res = list(corr = corr, corrPos = corrPos, arg = list(type = type))
invisible(res) # reordered correlation matrix, and Position
}
#' @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)
}
#' @noRd
draw_method_color = function(coords, fg, bg) {
symbols(coords, squares = rep(1, nrow(coords)), fg = fg, bg = bg,
add = TRUE, inches = FALSE)
}
#' @noRd
draw_grid = function(coords, fg) {
symbols(coords, add = TRUE, inches = FALSE, fg = fg, bg = NA,
rectangles = matrix(1, nrow = nrow(coords), ncol = 2))
}
taiyun/corrplot documentation built on Sept. 3, 2022, 6:51 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
#' A visualization of a correlation matrix.
#'
#' 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 col Vector, the colors of glyphs. They are distributed uniformly in
#' \code{col.lim} interval.
#' If \code{is.corr} is \code{TRUE}, the default value will be \code{COL2('RdBu', 200)}.
#' If \code{is.corr} is \code{FALSE} and \code{corr} is a non-negative or non-positive matrix,
#' the default value will be \code{COL1('YlOrBr', 200)};
#' otherwise (elements are partly positive and partly negative),
#' the default value will be \code{COL2('RdBu', 200)}.
#'
#' @param col.lim The limits \code{(x1, x2)} interval for assigning color by
#' \code{col}. If \code{NULL},
#' \code{col.lim} will be \code{c(-1, 1)} when \code{is.corr} is \code{TRUE},
#' \code{col.lim} will be \code{c(min(corr), max(corr))} when \code{is.corr}
#' is \code{FALSE}
#'
#' NOTICE: if you set \code{col.lim} when \code{is.corr} is \code{TRUE}, the assigning colors
#' are still distributed uniformly in [-1, 1], it only affect the display
#' on color-legend.
#'
#' @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 bg The background color.
#'
#' @param title Character, title of the graph.
#'
#'
#' @param add Logical, if \code{TRUE}, the graph is added to an existing plot,
#' otherwise a new plot will be created.
#'
#' @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{'l'} means left,
#' \code{'d'} means diagonal, \code{'n'} means don't add text-label.
#'
#' @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-legend; 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 color-legend.
#'
#' @param cl.length Integer, the number of number-text in color-legend, 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 color-legend, passed to
#' \code{\link{colorlegend}}.
#'
#' @param cl.ratio Numeric, to justify the width of color-legend, 0.1~0.2 is
#' suggested.
#'
#' @param cl.align.text Character, \code{'l'}, \code{'c'} (default) or
#' \code{'r'}, for number-label in color-legend, \code{'l'} means left,
#' \code{'c'} means center, and \code{'r'} means right.
#'
#' @param cl.offset Numeric, for number-label in color-legend, see
#' \code{\link{text}}.
#'
#' @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 transKeepSign Logical, whether or not to keep matrix values' sign when
#' transforming non-corr matrix for plotting.
#' Only valid when \code{is.corr = FALSE}. The default value is \code{TRUE}.
#'
#' NOTE: If \code{FALSE},the non-corr matrix will be
#'
#' @param p.mat Matrix of p-value, if \code{NULL}, parameter \code{sig.level},
#' \code{insig}, \code{pch}, \code{pch.col}, \code{pch.cex} are 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. 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 \code{list(corr, corrTrans, arg)}.
#' \code{corr} is a reordered correlation matrix for plotting.
#' \code{corrPos} is a data frame with \code{xName, yName, x, y, corr} and
#' \code{p.value}(if p.mat is not NULL)
#' column, which x and y are the position on the correlation matrix plot.
#' \code{arg} is a list of some corrplot() input parameters' value.
#' Now \code{type} is in.
#'
#' @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.
#'
#' @example vignettes/example-corrplot.R
#' @import graphics grDevices stats
#' @export
corrplot = function(corr,
method = c('circle', 'square', 'ellipse', 'number', 'shade', 'color', 'pie'),
type = c('full', 'lower', 'upper'), col = NULL, col.lim = NULL, is.corr = TRUE,
bg = 'white', title = '', add = FALSE, 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.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',
transKeepSign = TRUE,
p.mat = NULL, sig.level = 0.05,
insig = c('pch', 'p-value', 'blank', 'n', 'label_sig'),
pch = 4, pch.col = 'black', pch.cex = 3,
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(!is.corr & !transKeepSign & method %in% c('circle', 'square', 'ellipse', 'shade', 'pie')) {
stop("method should not be in c('circle', 'square', 'ellipse', 'shade', 'pie') when transKeepSign = FALSE")
}
# Issue #142
# checks for all values that are not missing
if (any(corr[!is.na(corr)] < col.lim[1]) || any(corr[!is.na(corr)] > col.lim[2])) {
stop('color limits should cover matrix')
}
if (is.null(col.lim)) {
if (is.corr) {
# if the matrix is expected to be a correlation matrix
# it MUST be within the interval [-1,1]
col.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
if(!diag) {
diag(corr) = NA
}
col.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 ^ 0.75 ||
max(corr, na.rm = TRUE) > 1 + .Machine$double.eps ^ 0.75) {
stop('The matrix is not in [-1, 1]!')
}
SpecialCorr = 1
if(col.lim[1] < -1 | col.lim[2] > 1) {
stop('col.lim should be within the interval [-1, 1]')
}
}
intercept = 0
zoom = 1
if (!is.corr) {
c_max = max(corr, na.rm = TRUE)
c_min = min(corr, na.rm = TRUE)
if((col.lim[1] > c_min) | (col.lim[2] < c_max))
{
stop('Wrong color: matrix should be in col.lim interval!')
}
if(diff(col.lim)/(c_max - c_min)> 2) {
warning('col.lim interval too wide, please set a suitable value')
}
# all negative or positive or NOT transkeepSign, trans to [0, 1]
if (c_max <= 0 | c_min>=0 | !transKeepSign) {
intercept = - col.lim[1]
zoom = 1 / (diff(col.lim))
#if(col.lim[1] * col.lim[2] < 0) {
# warning('col.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 remaining case
stopifnot(c_min < 0 && c_max > 0)
intercept = 0
zoom = 1 / max(abs(col.lim))
SpecialCorr = 1
}
corr = (intercept + corr) * zoom
}
col.lim2 = (intercept + col.lim) * zoom
int = intercept * zoom
if (is.null(col) & is.corr) {
col = COL2('RdBu', 200)
}
if (is.null(col) & !is.corr) {
if(col.lim[1] * col.lim[2] < 0) {
col = COL2('RdBu', 200)
} else {
col = COL1('YlOrBr', 200)
}
}
n = nrow(corr)
m = ncol(corr)
min.nm = min(n, m)
ord = 1: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) = 1:n
}
if (is.null(colnames(corr))) {
colnames(corr) = 1: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
PosName = ind
PosName[, 1] = colnames(mat)[ind[, 2]]
PosName[, 2] = rownames(mat)[ind[, 1]]
return(list(Pos, Dat, PosName))
}
# 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)
}
testTemp = getPos.Dat(corr)
Pos = getPos.Dat(corr)[[1]]
PosName = getPos.Dat(corr)[[3]]
# 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
## assign colors
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
}
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) +
ylabwidth * abs(sin(tl.srt * pi / 180)) * (type=='lower') * grepl('d', tl.pos)
) #+ c(-0.15, 0)
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)) {
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 == 'square' && plotCI == 'n') {
draw_method_square(Pos, DAT, 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]]
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)
}
}
## 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)
}
if (!is.null(p.mat)) {
pos.pNew = getPos.Dat(p.mat)[[1]]
pNew = getPos.Dat(p.mat)[[2]]
}
if (!is.null(p.mat) && insig != 'n') {
if (order != 'original') {
p.mat = p.mat[ord, ord]
}
if(!is.null(rownames(p.mat)) | !is.null(rownames(p.mat))) {
if(!all(colnames(p.mat)==colnames(corr)) |
!all(rownames(p.mat)==rownames(corr))) {
warning('p.mat and corr may be not paired, their rownames and colnames are not totally same!')
}
}
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], number.digits), 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 = col.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 = seq(col.lim[1], col.lim[2], length = cl.length)
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 = round(labels, 2),
offset = cl.offset, ratio.colbar = 0.3, cex = cl.cex,
xlim = xlim, ylim = ylim, vertical = vertical,
align = cl.align.text)
}
## 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 {
if(tl.pos != 'l') {
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 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)
}
corrPos = data.frame(PosName, Pos, DAT)
colnames(corrPos) = c('xName', 'yName', 'x', 'y', 'corr')
if(!is.null(p.mat)) {
corrPos = cbind(corrPos, pNew)
colnames(corrPos)[6] = c('p.value')
}
corrPos = corrPos[order(corrPos[, 3], -corrPos[, 4]), ]
rownames(corrPos) = NULL
res = list(corr = corr, corrPos = corrPos, arg = list(type = type))
invisible(res) # reordered correlation matrix, and Position
}
#' @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)
}
#' @noRd
draw_method_color = function(coords, fg, bg) {
symbols(coords, squares = rep(1, nrow(coords)), fg = fg, bg = bg,
add = TRUE, inches = FALSE)
}
#' @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.