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