#' @title Plots matrix as a heatmap
#'
#' @descripton This function tries to give the user a quick
#' overview for any matrix he is dealing with. It does so by
#' drawing a heatmap plot and also providing additional
#' information like e.g. the most frequent values in the matrix.
#' @param M Matrix to be plotted
#' @keywords matrix heatmap
#' @details
#' @examples
#' X <- replicate(10, rnorm(10)/10)
#' diag(X) <- rep(1,10)
#' pm(X)
pm <- function(M){
# prepare data for plotting
M <- as.matrix(M)
rownames(M) <- NULL
colnames(M) <- NULL
Mm <- as.data.table(melt(M))
names(Mm) <- c("row","col","value")
# aggregate info about matrix
## matrix name
name <- "M"
name <- bquote(atop(~ .(name)[.(dim(M)[1])~"x"~.(dim(M)[2]) ],~" "))
## matrix' unique values
unitot <- length(unique(c(M)))
uniond <- length(unique(diag(M)))
M2 <- M; diag(M2) <- NA
uniofd <- length(unique(c(M2)[!is.na(c(M2))]))
if(dim(M)[1]==dim(M)[2]){
caption <- paste0("unique elements: total=",unitot,"; on diag=",uniond,"; off diag=",uniofd)
}else{caption <- paste0("unique elements: total=",unitot)}
# Discrete Heatmap Plot #
#########################
if(length(unique(Mm$value)) < 10){
# as.factor
Mm$value <- as.factor(Mm$value)
# Force 0=white and 1=black
cols <- data.table(levels = levels(Mm$value),
colors = distinctColorPalette(length(levels(Mm$value))))
cols[levels==0, colors:="#FFFFFF"]; cols[levels==1, colors:="#000000"]
p <- ggplot(data = Mm, aes(x=col, y=row))
p <- p + geom_tile(aes(fill=value))
p <- p + scale_fill_manual(limits=cols$levels, values=cols$colors)
p <- p + guides(fill=guide_legend(title=name))
}
# Continuours Heatmap Plot #
############################
if(length(unique(Mm$value)) >= 10){
p <- ggplot(data = Mm, aes(x=col, y=row))
p <- p + geom_tile(aes(fill=value))
p <- p + scale_fill_continuous(breaks=c(as.vector(floor(quantile(Mm$value)[c(1,5)]))))
p <- p + guides(fill=guide_colorbar(title=name,barwidth = 0.5))
}
# ggplot in general
# y axis
if(dim(M)[1]>15){
rowbreaks <- floor(quantile(Mm$row, names=F))
p <- p + scale_y_continuous(expand=c(0,0))
suppressMessages(p <- p + scale_y_reverse(expand=c(0,0), breaks=rowbreaks))
}else if(dim(M)[1]==1){
suppressMessages(p <- p + scale_y_continuous(expand=c(0,0)))
suppressMessages(p <- p + scale_y_reverse(expand=c(0,0), breaks=c(1)))
}else{p <- p + scale_y_reverse(expand=c(0,0))}
# x axis
if(dim(M)[2]>15){
colbreaks <- floor(quantile(Mm$col, names=F))
p <- p + scale_x_continuous(expand=c(0,0), breaks=colbreaks)
}else if(dim(M)[2]==1){
suppressMessages(p <- p + scale_x_continuous(expand=c(0,0)))
suppressMessages(p <- p + scale_x_reverse(expand=c(0,0), breaks=c(1)))
}else{p <- p + scale_x_continuous(expand=c(0,0))}
p <- p + coord_fixed(ratio = 1)
p <- p + labs(title=caption)
p <- p + theme(panel.background = element_blank(),
panel.grid = element_blank(),
panel.border = element_blank(),
axis.title = element_blank(),
plot.title = element_text(size=8))
suppressMessages(print(p))
# print aggregated info
if(dim(M)[1]==dim(M)[2]){
diaginfo <- setnames(data.table(table(diag(M))), c("V1","N"),c(" Element on diagonal"," N"))
M2 <- M
diag(M2) <- NA
offdinfo <- setnames(data.table(table(c(M2))), c("V1","N"),c("Element off diagonal"," N"))
# Print
print(head(diaginfo))
print(head(offdinfo))
} else {
matinfo <- setnames(data.table(table(M)),c(1),c("Element"))
print(matinfo)
}
if(length(unique(Mm$value)) >= 10){print(caption)}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.