RiDMC/R/imageGrobs.R

   1 #############
   2 ##Image map #
   3 #############
   4 imageGrob <- function(colors, name=NULL, gp=NULL, vp=NULL) {
   5   nc <- NCOL(colors)
   6   nr <- NROW(colors)
   7   xx <- seq_len(nc)/nc
   8   yy <- seq_len(nr)/nr
   9   right <- rep(xx, each=nr)
  10   top <- rep(yy, nc)
  11   if(is.null(gp))
  12     gp <- gpar(col=NA, fill=as.vector(colors))
  13   ans <- extend(rectGrob(x=right, y=top, width=1/nc, height=1/nr, just=c('right','top'),
  14     gp=gp, name=name, vp=vp), 'image', colors=colors)
  15   return(ans)
  16 }
  17 editDetails.image <- function(x, specs){
  18   x <- imageGrob(specs$colors)
  19   update(x, specs)
  20 }
  21 imageContentsGrob <- function(colors, xlim=0:1, ylim=0:1, respect = TRUE, name = NULL, gp=NULL, vp=NULL)
  22   contentsGrob(imageGrob(colors, name=name, gp=gp, vp=vp), xlim=xlim, ylim=ylim, respect=respect)
  23
  24 imageScaleGrob <- function(values, breaks, palette, name=NULL, gp=NULL, vp=NULL) {
  25   colors <- array(palette[as.numeric(cut(values, breaks=breaks))], dim(values))
  26   extend(imageGrob(colors=colors, name=name, gp=gp, vp=vp), 'imageScale', values=values, breaks=breaks, palette=palette)
  27 }
  28 editDetails.imageScale <- function(x, specs){
  29   if(any(c('values','breaks','palette') %in% names(specs))) {
  30     values <- specs$values
  31     breaks <- specs$breaks
  32     palette <- specs$palette
  33     if(is.null(values))
  34       values <- getField(x,'values')
  35     if(is.null(breaks))
  36       breaks <- getField(x, 'breaks')
  37     if(is.null(palette))
  38       palette <- getField(x, 'palette')
  39     x <- imageScaleGrob(values=values, breaks=breaks, palette=palette)
  40   }
  41   update(x, specs)
  42 }
  43 imageScaleContentsGrob <- function(..., xlim=0:1, ylim=0:1, respect=TRUE, name=NULL, gp=NULL, vp=NULL)
  44   contentsGrob(imageScaleGrob(..., name=name, gp=gp, vp=vp), xlim=xlim, ylim=ylim, respect=respect)
  45
  46 ###########################
  47 ##Complete image map grob##
  48 ###########################
  49 ##Has optional axes and legend. Space is accomodated accordingly
  50 imageMapGrob <- function(values, breaks, colors, xlim=0:1, ylim=0:1, axes=TRUE, legend=TRUE, name=NULL, gp=NULL, vp=NULL) {
  51   stop('TODO')
  52 }
  53 grid.imageMap <- function(...)
  54   grid.draw(imageMapGrob(...))