lo <- function (rown, coln, nrow, ncol, cellheight = NA, cellwidth = NA
, treeheight_col = 50, treeheight_row = 0, legend, main = NULL, sub = NULL, info = NULL
, fontsize, fontsize_row, fontsize_col = cexCol * fontsize, ...){
#annotation_colors <- annTracks$colors
#row_annotation <- annTracks$annRow
#annotation <- annTracks$annCol
coln_height <- unit(10, "bigpts")
if(!is.null(coln)){
longest_coln = which.max(nchar(coln))
gp = gpar(fontsize = fontsize_col, ...)
coln_height <- coln_height + unit(1.1, "grobheight", textGrob(coln[longest_coln], rot = 90, gp = gp))
}
rown_width <- rown_width_min <- unit(10, "bigpts")
if(!is.null(rown)){
longest_rown = which.max(nchar(rown))
gp = gpar(fontsize = fontsize_row, ...)
rown_width <- rown_width_min + unit(1.2, "grobwidth", textGrob(rown[longest_rown], gp = gp))
}
gp = list(fontsize = fontsize, ...)
# Legend position
if( !is_NA(legend) ){
longest_break = which.max(nchar(as.character(legend)))
longest_break = unit(1.1, "grobwidth", textGrob(as.character(legend)[longest_break], gp = do.call(gpar, gp)))
# minimum fixed width: plan for 2 decimals and a sign
min_lw = unit(1.1, "grobwidth", textGrob("-00.00", gp = do.call(gpar, gp)))
longest_break = max(longest_break, min_lw)
title_length = unit(1.1, "grobwidth", textGrob("Scale", gp = gpar(fontface = "bold", ...)))
legend_width = unit(12, "bigpts") + longest_break * 1.2
legend_width = max(title_length, legend_width)
}
else{
legend_width = unit(0, "bigpts")
}
#.annLegend.dim <- function(annotation, fontsize){
# Width of the corresponding legend
# longest_ann <- unlist(lapply(annotation, names))
# longest_ann <- longest_ann[which.max(nchar(longest_ann))]
# annot_legend_width = unit(1, "grobwidth", textGrob(longest_ann, gp = gpar(fontsize=fontsize, ...))) + unit(10, "bigpts")
# width of the legend title
# annot_legend_title <- names(annotation)[which.max(nchar(names(annotation)))]
# annot_legend_title_width = unit(1, "grobwidth", textGrob(annot_legend_title, gp = gpar(fontface = "bold", fontsize=fontsize, ...)))
#
# total width
# max(annot_legend_width, annot_legend_title_width) + unit(5, "bigpts")
#}
# Column annotations
#if( !is_NA(annotation) ){
# Column annotation height
# annot_height = unit(ncol(annotation) * (8 + 2) + 2, "bigpts")
#}
#else{
annot_height = unit(0, "bigpts")
#}
# add a viewport for the row annotations
#if ( !is_NA(row_annotation) ) {
# Row annotation width
# row_annot_width = unit(ncol(row_annotation) * (8 + 2) + 2, "bigpts")
#}
#else {
row_annot_width = unit(0, "bigpts")
#}
# Width of the annotation legend
annot_legend_width <- unit(0, "bigpts")
#annot_legend_width <-
# if( annotation_legend && !is_NA(annotation_colors) ){
# .annLegend.dim(annotation_colors, fontsize)
# }else unit(0, "bigpts")
# Tree height
treeheight_col = unit(treeheight_col, "bigpts") + unit(5, "bigpts")
treeheight_row = unit(treeheight_row, "bigpts") + unit(5, "bigpts")
# main title
main_height <- if(!is.null(main)) unit(1, "grobheight", main) + unit(20, "bigpts") else unit(0, "bigpts")
# sub title
sub_height <- if(!is.null(sub)) unit(1, "grobheight", sub) + unit(10, "bigpts") else unit(0, "bigpts")
# info panel
if( !is.null(info) ){
info_height <- unit(1, "grobheight", info) + unit(20, "bigpts")
info_width <- unit(1, "grobwidth", info) + unit(10, "bigpts")
}else{
info_height <- unit(0, "bigpts")
info_width <- unit(0, "bigpts")
}
# Set cell sizes
if(is.na(cellwidth)){
matwidth = unit(1, "npc") - rown_width - legend_width - row_annot_width - treeheight_row - annot_legend_width
}
else{
matwidth = unit(cellwidth * ncol, "bigpts")
}
if(is.na(cellheight)){
matheight = unit(1, "npc") - treeheight_col - annot_height - main_height - coln_height - sub_height - info_height
# recompute the cell width depending on the automatic fontsize
if( is.na(cellwidth) && !is.null(rown) ){
cellheight <- convertHeight(unit(1, "grobheight", rectGrob(0,0, matwidth, matheight)), "bigpts", valueOnly = T) / nrow
fontsize_row <- convertUnit(min(unit(fontsize_row, 'points'), unit(0.6*cellheight, 'bigpts')), 'points')
rown_width <- rown_width_min + unit(1.2, "grobwidth", textGrob(rown[longest_rown], gp = gpar(fontsize=fontsize_row, ...)))
matwidth <- unit(1, "npc") - rown_width - legend_width - row_annot_width - treeheight_row - annot_legend_width
}
}
else{
matheight = unit(cellheight * nrow, "bigpts")
}
# HACK:
# - use 6 instead of 5 column for the row_annotation
# - take into account the associated legend's width
# Produce layout()
unique.name <- vplayout(NULL)
lo <- grid.layout(nrow = 7, ncol = 6
, widths = unit.c(treeheight_row, row_annot_width, matwidth, rown_width, legend_width, annot_legend_width)
, heights = unit.c(main_height, treeheight_col, annot_height, matheight, coln_height, sub_height, info_height))
hvp <- viewport( name=paste('aheatmap', unique.name, sep='-'), layout = lo)
pushViewport(hvp)
#grid.show.layout(lo); stop('sas')
# Get cell dimensions
vplayout('mat')
cellwidth = convertWidth(unit(1, "npc"), "bigpts", valueOnly = T) / ncol
cellheight = convertHeight(unit(1, "npc"), "bigpts", valueOnly = T) / nrow
upViewport()
height <- as.numeric(convertHeight(sum(lo$height), "inches"))
width <- as.numeric(convertWidth(sum(lo$width), "inches"))
# Return minimal cell dimension in bigpts to decide if borders are drawn
mindim = min(cellwidth, cellheight)
return( list(width=width, height=height, vp=hvp, mindim=mindim, cellwidth=cellwidth, cellheight=cellheight) )
}
vplayout <- function ()
{
graphic.name <- NULL
function(x, y, verbose = getOption('verbose') ){
# initialize the graph name
if( is.null(x) ){
graphic.name <<- grid:::vpAutoName()
return(graphic.name)
}
name <- NULL
if( !is.numeric(x) ){
name <- paste(graphic.name, x, sep='-')
if( !missing(y) && is(y, 'viewport') ){
y$name <- name
return(pushViewport(y))
}
if( !is.null(tryViewport(name, verbose=verbose)) )
return()
switch(x
, main={x<-1; y<-3;}
, ctree={x<-2; y<-3;}
, cann={x<-3; y<-3;}
, rtree={x<-4; y<-1;}
, rann={x<-4; y<-2;}
, mat={x<-4; y<-3;}
, rnam={x<-4; y<-4;}
, leg={x<-4; y<-5;}
, aleg={x<-4; y<-6;}
, cnam={x<-5; y<-3;}
, sub={x<-6; y<-3;}
, info={x<-7; y<-3;}
, stop("aheatmap - invalid viewport name")
)
}
if( verbose ) message("vp - create ", name)
pushViewport(viewport(layout.pos.row = x, layout.pos.col = y, name=name))
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.