RiDMC/R/grobs.R

   1 ##
   2 ##Helper functions for simulating inheritance
   3 ## (strongly inspired by the R.oo package)
   4 ##
   5 extend <- function(baseObj, className, ..., warningOnOverlap=TRUE)
   6   UseMethod('extend')
   7 extend.grob <- function(baseObj, className, ..., warningOnOverlap=TRUE) {
   8   ans <- baseObj
   9   attr.new <- list(...)
  10   nms <- names(attr.new)
  11   ovl <- intersect(nms, names(ans))
  12   if(warningOnOverlap && (length(ovl) > 0))
  13     warning('Attributes already in', class(baseObj)[1], 'object: ', paste(ovl, collapse=', '))
  14   for(nm in nms)
  15     ans[[nm]] <- attr.new[[nm]]
  16   class(ans) <- c(className, class(ans))
  17   ans
  18 }
  19
  20 update <- function(x, specs) UseMethod('update')
  21 update.grob <- function(x, specs) {
  22   for(nm in names(specs))
  23     x[[nm]] <- specs[[nm]]
  24   x
  25 }
  26
  27 ###############################
  28 ##Abstract contentsGrob class##
  29 ###############################
  30 contentsGrob <- function(baseGrob, xlim, ylim, respect=FALSE)
  31   extend(baseGrob, 'contents', xlim=xlim, ylim=ylim, respect=respect)
  32 getXlim <- function(x) UseMethod('getXlim')
  33 getXlim.grob <- function(x) 0:1
  34 getXlim.contents <- function(x) getField(x, 'xlim')
  35 getYlim <- function(x) UseMethod('getYlim')
  36 getYlim.grob <- function(x) 0:1
  37 getYlim.contents <- function(x) getField(x, 'ylim')
  38 getRespect <- function(x) UseMethod('getRespect')
  39 getRespect.grob <- function(x) FALSE
  40 getRespect.contents <- function(x) getField(x, 'respect')
  41
  42 ##Get field from specified object
  43 ##Warns if field isn't found
  44 getField <- function(obj, fieldName, warningOnNotFount=TRUE)
  45   UseMethod('getField')
  46 getField.grob <- function(obj, fieldName, warningOnNotFound=TRUE) {
  47   if(warningOnNotFound && (!(fieldName %in% names(obj))))
  48     stop('cannot find field ', fieldName, 'in ', deparse(substitute(obj)))
  49   return(obj[[fieldName]])
  50 }
  51
  52 ##
  53 ##Generic grob classes
  54 ##
  55 plotGrob <- function(contents=NULL, main=NULL, xlab=NULL, ylab=NULL,
  56   xlim=0:1, ylim=0:1, axes=FALSE, bty=TRUE, respect=NULL, mar=NULL, name=NULL, gp=NULL, vp=NULL) {
  57   cv <- mkPlotChildsAndViewports(contents=contents, main=main, xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim,
  58     axes=axes, bty=bty, respect = respect, mar=mar)
  59   gTree(contents=contents, main=main, xlab=xlab, ylab=ylab, xlim=xlim, ylim=ylim, mar=mar,
  60     children = cv$children, childrenvp = cv$viewports,
  61     name=name, gp=gp, vp=vp, cl='plotGrob')
  62 }
  63 editDetails.plotGrob <- function(x, specs) {
  64   do.call(plotGrob, specs)
  65 }
  66
  67 makePlotGrobViewports <- function(xlim, ylim, respect, mar) {
  68   ws <- unit(c(mar[2], diff(xlim), mar[4]), c('lines','null','lines'))
  69   hs <- unit(c(mar[3], diff(ylim), mar[1]), c('lines','null','lines'))
  70   ly <- grid.layout(3, 3, widths=ws, heights=hs)
  71   lyIso <- grid.layout(1, 1, widths= ws[2], heights= hs[2], respect=respect)
  72   vpStack(viewport(layout=lyIso, name='plotLayout'),
  73     viewport(layout.pos.col=1, layout.pos.row=1, layout=ly, name='rootArea', clip=FALSE),
  74       vpList(
  75         viewport(layout.pos.col=2, layout.pos.row=2, name='axesArea', xscale=xlim, yscale=ylim, clip=FALSE),
  76         viewport(layout.pos.col=2, layout.pos.row=2, name='plotArea', xscale=xlim, yscale=ylim, clip=TRUE),
  77         viewport(layout.pos.row=1, name='titleArea', gp=gpar(cex=par('cex.main'))),
  78         viewport(layout.pos.col=2, layout.pos.row=3, name='xlabArea'),
  79         viewport(layout.pos.col=1, layout.pos.row=2, name='ylabArea'),
  80         viewport(layout.pos.col=3, layout.pos.row=2, name='rightMarginArea')))
  81 }
  82
  83 mkPlotChildsAndViewports <- function(contents=NULL, main=NULL, xlab=NULL, ylab=NULL,
  84   xlim=NULL, ylim=NULL, respect=NULL, axes=FALSE, bty=TRUE, mar=NULL) {
  85   null.mar <- is.null(mar)
  86   if(null.mar)
  87     mar <- c(0,0,0,0)
  88   childs <- list()
  89   append <- function(lst, elt) {
  90     lst[[length(lst)+1]] <- elt
  91     lst
  92   }
  93   if(!is.null(main)) { ##reserve title space
  94     if(null.mar)
  95       mar[3] <- 4
  96     childs <- append(childs, textGrob(main, name='title', y=unit(3,'lines'), just=c('center','top'),
  97       vp=vpPath('plotLayout', 'rootArea', 'titleArea')))
  98   }
  99   if(!is.null(xlab)) { ##reserve xlab space
 100     if(null.mar)
 101       mar[1] <- 4
 102     childs <- append(childs, textGrob(xlab, y=unit(1, 'npc') - unit(3, 'lines'), name='xlab', just=c('center', 'bottom'),
 103       vp=vpPath('plotLayout', 'rootArea', 'xlabArea')))
 104   }
 105   if(!is.null(ylab)) { ##reserve ylab space
 106     if(null.mar)
 107       mar[2] <- 4
 108     childs <- append(childs, textGrob(ylab, x=unit(1, 'npc') - unit(3, 'lines'), rot=90, name='ylab',
 109       vp=vpPath('plotLayout', 'rootArea', 'ylabArea')))
 110   }
 111   if(axes) { ##add axes to main area
 112     if(null.mar) {
 113       mar[1] <- max(2, mar[1])
 114       mar[2] <- max(2, mar[2])
 115       mar[4] <- max(2, mar[4])
 116     }
 117     childs <- append(childs, xaxisGrob(name='xaxis', vp=vpPath('plotLayout','rootArea','axesArea')))
 118     childs <- append(childs, yaxisGrob(name='yaxis',
 119       edits=gEdit('labels', rot=90, just=c('center','bottom')),
 120       vp=vpPath('plotLayout', 'rootArea', 'axesArea')))
 121   }
 122   if(!is.null(contents)) {
 123     contents$vp <- vpPath('plotLayout','rootArea','plotArea')
 124     childs <- append(childs, contents)
 125   }
 126   if(bty) {
 127     childs <- append(childs, rectGrob(name='box', vp=vpPath('plotLayout','rootArea','plotArea')))
 128   }
 129   children <- do.call(gList, childs)
 130   if(is.null(xlim)) xlim <- getXlim(contents)
 131   if(is.null(ylim)) ylim <- getYlim(contents)
 132   if(is.null(respect)) respect <- getRespect(contents)
 133   viewports <- makePlotGrobViewports(xlim=xlim, ylim=ylim, respect=respect, mar=mar)
 134   list(children=children, viewports=viewports)
 135 }
 136
 137 ##x/y graph
 138 xyGrob <- function(x, y, type='l', name=NULL, gp=NULL, vp=NULL) {
 139   lgr <- linesGrob(x, y, name=paste(name, 'lines', sep='.'), default.units='native')
 140   pgr <- pointsGrob(x, y, name=paste(name, 'points', sep='.'), default.units='native')
 141   if(type=='l')
 142     comps <- list(lgr)
 143   else if(type=='p')
 144     comps <- list(pgr)
 145   else if (type=='b')
 146     comps <- list(lgr, pgr)
 147   xlim <- range(x, na.rm=TRUE)
 148   ylim <- range(y, na.rm=TRUE)
 149   if(is.null(vp))
 150     vp <- viewport(xscale=xlim, yscale=ylim)
 151   gTree(x=x, y=y, type=type, children=do.call(gList, comps),
 152     name=name, gp=gp, vp=vp, cl='xyGrob')
 153 }
 154
 155 tsGrob <- function(x, name=NULL, gp=NULL, vp=NULL) {
 156   x <- ts(x)
 157   xyGrob(time(x), x, type='l', name=name, gp=gp, vp=vp)
 158 }
 159
 160 xyPlotGrob <- function(x, y, type='l', name=NULL, gp=NULL, vp=NULL) {
 161   xyg <- xyGrob(x, y, type, name=paste(name,'xyGrob', sep='.'))
 162   box <- rectGrob()
 163
 164   gTree(x=x, y=y, type=type, children=gList(xyg, box))
 165 }
 166