RiDMC/R/ribbonGrobs.R

   1 #################
   2 ##Ribbon legend:#
   3 #################
   4 ribbonVps <- function(breaks, margin, scale) {
   5   breaks <- format(signif(breaks, 3))
   6   vpTree(
   7     viewport(name='layout', layout=grid.layout(3,4,
   8       widths=unit.c(margin, unit(1, 'lines'), max(unit(0.8, 'lines') + stringWidth(breaks), margin)),
   9       heights=unit.c(margin, unit(1,'null'), margin))),
  10       vpList(viewport(layout.pos.col=2, layout.pos.row=2, yscale=scale, name='ribbon'),
  11         viewport(layout.pos.col=3, layout.pos.row=2, yscale=scale, name='labels')
  12       )
  13   )
  14 }
  15
  16 ribbonKids <- function(breaks, cols, n=10) {
  17   scale <- range(breaks)
  18   nb <- length(breaks)
  19   tickloc <- seq(scale[1], scale[2], len=n)
  20   gList(rectGrob(y=unit(breaks[-1], 'native'), height=unit(diff(breaks), 'native'), just='top', gp=gpar(col=NA, fill=cols),
  21       vp=vpPath('layout','ribbon')),
  22     rectGrob(vp=vpPath('layout','ribbon')),
  23     segmentsGrob(x1=unit(0.5, 'lines'), y0=unit(tickloc, 'native'), y1=unit(tickloc, 'native'), vp=vpPath('layout','labels')),
  24     segmentsGrob(y0=unit(tickloc, 'native'), y1=unit(tickloc, 'native'), vp=vpPath('layout','ribbon')),
  25     textGrob(x=unit(0.8, 'lines'), y=unit(tickloc, 'native'), just='left', label=format(signif(tickloc, 3)), vp=vpPath('layout','labels'))
  26   )
  27 }
  28
  29 ribbonLegend <- function(breaks, cols, n=10, margin=unit(0.5, 'lines'), gp=NULL, vp=NULL, name=NULL) {
  30   scale <- range(breaks)
  31   gTree(breaks=breaks, cols=cols, n=n, children=ribbonKids(breaks, cols, n), childrenvp=ribbonVps(breaks, margin, scale),
  32     gp=gp, vp=vp, name=name, cl='ribbonLegend')
  33 }
  34
  35 widthDetails.ribbonLegend <- function(x)
  36   sum(layout.widths(viewport.layout(x$childrenvp[[1]])))
  37
  38 ##################
  39 ##Colors legend ##
  40 ##################
  41 colorLegendGrob <- function(colors, labels, x=unit(0,'npc'), y=unit(0, 'npc'), name=NULL, gp=NULL, vp=NULL) {
  42   nv <- length(colors)
  43   if(missing(labels))
  44     labels <- as.character(seq_along(colors))
  45   ys <- unit(1, 'npc') - unit(seq_len(nv) + 1, 'lines')
  46   xs0 <- unit(0.5, 'lines')
  47   xs1 <- unit(2, 'lines')
  48   rg <- rectGrob(x=xs0+x, y=ys-y, width=unit(0.6, 'lines'), height=unit(0.6, 'lines'), just=c('left','bottom'),
  49     gp=gpar(fill=colors), name='rect')
  50   lg <- textGrob(labels, x=xs1+x, y=ys-y, just=c('left','bottom'), name='text')
  51   gTree(colors=colors, labels=labels, x=x, y=y, name=name, gp=gp, vp=vp, children=gList(rg, lg), cl='colorLegendGrob')
  52 }
  53 grid.colorLegend <- function(...){
  54   grid.draw(colorLegendGrob(...))
  55 }
  56 editDetails.colorLegendGrob <- function(x, specs) {
  57   if(any(c('x','y') %in% names(specs))) {
  58     x <- colorLegendGrob(x$colors, x$labels,
  59       if(!is.null(specs$x)) specs$x else x$x,
  60       if(!is.null(specs$y)) specs$y else x$y)
  61   }
  62   if('colors' %in% names(specs)) {
  63     x <- editGrob(x, 'rect', gp=gpar(fill=specs$colors))
  64   }
  65   if('labels' %in% names(specs)) {
  66     x <- editGrob(x, 'text', label=specs$labels)
  67   }
  68   x
  69 }
  70
  71 widthDetails.colorLegendGrob <- function(x) {
  72   max(stringWidth(x$labels)) + unit(2, 'lines')
  73 }
  74 heightDetails.colorLegendGrob <- function(x) {
  75   unit(length(x$colors), 'lines')
  76 }