#' Excel-style figure displaying contents of a matrix
#'
#' Turn a matrix of data into an SVG of how it might look in Excel
#'
#' @param mat A matrix
#' @param file Optional file name (must have extension .svg, .png, .jpg, or .pdf)
#' @param cellwidth Width of each cell, in pixels
#' @param cellheight Height of each cell, in pixels
#' @param textsize Size for text (if `file` is provided or `direct2svg=TRUE`)
#' @param fig_width Width of figure, in pixels (if NULL, taken from `cellwidth`); ignored when `direct2svg=FALSE`
#' @param fig_height Height of figure, in pixels (if NULL, taken from `cellheight`); ignored when `direct2svg=FALSE`
#' @param border Color of border of cells for the body of the matrix
#' @param headcol Background color of cells on the top and left border
#' @param headborder Color of border of cells on the top and left border
#' @param headtextcol Color of text in cells on the top and left border
#' @param textcol Color of text in cells in body of the matrix
#' @param row_names If TRUE, and row names are present, include them as a first column
#' @param col_names If TRUE, and column names are present, include them as a first row
#' @param hilitcells Optional character vector of cells to highlight, like `"A1"` or `"D4"`
#' @param hilitcolor Color to highlight cells, a vector of length 1 or the same length as `hilitcells`
#' @param lwd Line width for rectangles
#' @param direct2svg If TRUE, rather than R graphics, just print an SVG directly with [base::cat()].
#' @param mar Plot margins, passed to [graphics::par()].
#'
#' @export
#' @importFrom grDevices svg png jpeg pdf
#' @importFrom graphics rect text par
#' @keywords hplot
#'
#' @examples
#' df <- data.frame(id= c(101, 102, 103),
#' sex= c("M", "F", "M"),
#' weight=c(22.3, 15.8, 19.7),
#' stringsAsFactors=FALSE)
#' excel_fig(df, col_names=TRUE)
excel_fig <-
function(mat, file=NULL, cellwidth=80, cellheight=26, textsize=16,
fig_width=NULL, fig_height=NULL,
border="#CECECE", headcol="#E9E9E9", headborder="#969696",
headtextcol="#626262", textcol="black",
row_names=FALSE, col_names=TRUE,
hilitcells=NULL, hilitcolor="#F0DCDB", lwd=1,
direct2svg=FALSE, mar=rep(0.1, 4))
{
if(row_names && !is.null(rownames(mat)))
mat <- cbind("row"=row_names, mat, stringsAsFactors=FALSE)
if(col_names && !is.null(colnames(mat)))
mat <- rbind(colnames(mat), mat)
n_row <- nrow(mat)
n_col <- ncol(mat)
if(length(cellheight)==1)
cellheight <- rep(cellheight, n_row + 1)
if(length(cellheight) != n_row+1)
stop("cellheight should have length 1 or ", n_row+1)
if(length(cellwidth)==1)
cellwidth <- rep(cellwidth, n_col + 1)
if(length(cellwidth) != n_col+1)
stop("cellwidth should have length 1 or ", n_col+1)
height <- sum(cellheight)
width <- sum(cellwidth)
if(is.null(fig_height)) fig_height <- height
if(is.null(fig_width)) fig_width <- width
celly <- cumsum(c(0,cellheight))
cellx <- cumsum(c(0,cellwidth))
if(!is.null(file)) {
if(grepl("\\.svg$", file))
svg(file, width=width/72, height=height/72, pointsize=textsize)
else if(grepl("\\.png$", file))
png(file, width=width, height=height, pointsize=textsize)
else if(grepl("\\.pdf$", file))
pdf(file, width=width/72, height=height/72, pointsize=textsize)
else if(grepl("\\.jpg$", file))
jpeg(file, width=width, height=height, pointsize=textsize)
else
stop("file must have extension .svg, .png, .jpg, or .pdf")
}
# matrix containing color of cells
colormat <- matrix("white", nrow=nrow(mat), ncol=ncol(mat))
if(!is.null(hilitcells)) {
# make sure hilitcolor is a vector of same length as hilitcells
if(length(hilitcolor) == 1)
hilitcolor <- rep(hilitcolor, length(hilitcells))
else if(length(hilitcolor) != length(hilitcells))
stop("length(hilitcolor) (", length(hilitcolor),
") != length(hilitcells) (", length(hilitcells), ")")
hilitcells <- toupper(hilitcells) # to upper-case
hilitcells <- strsplit(hilitcells, "") # split into characters
# check that cells are valid ("A4" "D05", etc)
sapply(hilitcells, function(a) {
let <- which(a %in% LETTERS)
num <- which(!(a %in% LETTERS))
if(length(let) == 0 || length(num) == 0 ||
any(sapply(let, function(a,b) any(a > b), num)))
stop("Invalid highlighted cell: ", paste(a, collapse=""))
})
# pull out letters and convert to column number
col <- vapply(hilitcells, function(a) {
b <- a[a %in% LETTERS] # pull out the letters
m <- match(b, LETTERS) # convert to digits
if(length(b) == 1) return(m) # if 1 letter, just use corresponding number
sum((26^((length(b)-1):0))*m) # otherwise, treat like base 26, offset by 26
}, 1)
# pull out the digits and convert back to row number
row <- vapply(hilitcells, function(a) as.numeric(paste(a[!(a %in% LETTERS)], collapse="")), 1)
# make a matrix
hilitcells <- cbind(row, col)
# change color of highlighted cells
for(i in 1:nrow(hilitcells))
colormat[hilitcells[i,1], hilitcells[i,2]] <- hilitcolor[i]
}
if(direct2svg) {
return( excel_fig_direct(mat, file,
cellx, celly, cellwidth, cellheight, width, height,
fig_width, fig_height,
textsize, border, headcol, headborder,
headtextcol, textcol,
colormat, lwd) )
}
# plot region
par(mar=mar)
plot(0,0,type="n", xlab="", ylab="", xaxt="n", yaxt="n",
xlim=c(0, width), ylim=c(height, 0), xaxs="i", yaxs="i")
for(i in n_row:0) {
for(j in n_col:0) {
# rectangles
rect(cellx[j+1], celly[i+1], cellx[j+2], celly[i+2],
border=ifelse(i==0 || j==0, headborder, border),
col=ifelse(i==0 || j==0, headcol, colormat[i,j]),
lwd=lwd)
# text
if(i==0 && j>0)
text(mean(cellx[j+1:2]), mean(celly[1:2]), LETTERS[j], col=headtextcol, font=2)
if(i>0 && j==0)
text(mean(cellx[1:2]), mean(celly[i+1:2]), i, col=headtextcol, font=2)
if(i>0 && j>0)
text(mean(cellx[j+1:2]), mean(celly[i+1:2]), mat[i,j], col=textcol)
}
}
if(!is.null(file))
grDevices::dev.off()
}
# a grid version, for internal use
excel_fig_direct <-
function(mat, file, cellx, celly, cellwidth, cellheight, width, height,
fig_width, fig_height,
textsize, border, headcol, headborder, headtextcol, textcol,
colormat, lwd)
{
# initiate the svg, padding things a bit
svg_start(width+lwd*2, height+lwd*2, fig_width+lwd*2, fig_height+lwd*2, file)
# shift a bit, due to padding
cellx <- cellx+lwd
celly <- celly+lwd
n_row <- nrow(mat)
n_col <- ncol(mat)
for(i in n_row:0) {
for(j in n_col:0) {
# rectangles
svg_rect(cellx[j+1], celly[i+1], cellwidth[j+1], cellheight[i+1],
border=ifelse(i==0 || j==0, headborder, border),
col=ifelse(i==0 || j==0, headcol, colormat[i,j]),
lwd=lwd, file=file)
# text
if(i==0 && j>0)
svg_text(mean(cellx[j+1:2]), mean(celly[1:2]), LETTERS[j],
col=headtextcol, textsize=textsize, file=file)
if(i>0 && j==0)
svg_text(mean(cellx[1:2]), mean(celly[i+1:2]), i,
col=headtextcol, textsize=textsize, file=file)
if(i>0 && j>0)
svg_text(mean(cellx[j+1:2]), mean(celly[i+1:2]), mat[i,j],
col=headtextcol, textsize=textsize, file=file)
}
}
# close off the svg
svg_end(file)
}
# use cat() to file if given otherwise plain
svg_cat <-
function(..., file=NULL, append=TRUE)
{
if(is.null(file))
cat(..., sep="")
else
cat(..., file=file, append=append, sep="")
}
# print the start of an SVG
svg_start <-
function(width, height, fig_width, fig_height, file=NULL)
{
svg_cat('<?xml version="1.0" encoding="UTF-8"?>\n', file=file, append=FALSE)
svg_cat('<svg ',
'width="', fig_width, 'px" ',
'height="', fig_height, 'px" ',
'viewBox="0 0 ', width, ' ', height, '" ',
'preserveAspectRatio="xMinYmin meet" ',
'xmlns="http://www.w3.org/2000/svg" ',
'xmlns:xlink="http://www.w3.org/1999/xlink" ',
'version="1.1">\n',
file=file, append=FALSE)
}
# print the end of an SVG
svg_end <-
function(file=NULL)
{
svg_cat('</svg>\n', file=file, append=TRUE)
}
# add a rectangle to an SVG
svg_rect <-
function(x, y, width, height, col="white", border="black", lwd=1,
file=NULL)
{
svg_cat(' <rect ',
'x="', x, '" ',
'y="', y, '" ',
'width="', width, '" ',
'height="', height, '" ',
'fill="', col, '" ',
'stroke="', border, '" ',
'stroke-width="', lwd, '" ',
'/>\n', file=file, append=TRUE)
}
# print text
svg_text <-
function(x, y, text, col="white", textsize=14, file=NULL)
{
svg_cat(' <text ',
'x="', x, '" ',
'y="', y, '" ',
'text-anchor="middle" ',
'dominant-baseline="middle" ',
'font-family="sans-serif" ',
'fill="', col, '" ',
'font-size="', textsize, 'px" ',
'>', text, '</text>\n', file=file, append=TRUE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.