grid.collection <- function(..., gp=gpar(), draw=TRUE, vp=NULL) {
  .Deprecated("gTree")
  gc <- gTree(children=gList(...), gp=gp, vp=vp, cl="collection")
  if (draw)
    grid.draw(gc)
  gc
}

######################################
# AXES
######################################

# Axes are extended from the "gTree" class
# This means that the standard (e.g., draw.details)
# methods for gTrees will apply

# The children of an axis are fixed to be:

# NOTE that the `at' parameter is numeric (i.e., NOT a unit) for
# grid.xaxis and grid.yaxis.  These functions assume a unit for the `at'
# values rather than letting the user specify a unit.

validDetails.axis <- function(x) {
  if (!is.null(x$at))
    x$at <- as.numeric(x$at)
  x$label <- as.logical(x$label)
  x$main <- as.logical(x$main)
  x
}

drawDetails.xaxis <- function(x, recording=TRUE) {
  # If x$at is NULL, then we must calculate the
  # tick marks on-the-fly
  if (is.null(x$at)) {
    at <- grid.pretty(current.viewport()$xscale)
    grid.draw(make.xaxis.major(at, x$main), recording=FALSE)
    grid.draw(make.xaxis.ticks(at, x$main), recording=FALSE)
    if (x$label)
      grid.draw(make.xaxis.labels(at, x$main), recording=FALSE)
    return(x)
  }
}

# NOTE that this can't be for all axes because it needs to
# call make.XAXIS.ticks and make.XAXIS.labels
editDetails.xaxis <- function(x, specs) {
  slot.names <- names(specs)
  if (match("at", slot.names, nomatch=0)) {
    # NOTE that grid.edit has already set x$at to the new value
    # We might set at to NULL to get ticks recalculated at redraw
    if (is.null(x$at)) {
      removeGrob(x, "main", warn=FALSE)
      removeGrob(x, "ticks", warn=FALSE)
      removeGrob(x, "labels", warn=FALSE)
    } else {
      x <- addGrob(x, make.xaxis.major(x$at, x$main))
      x <- addGrob(x, make.xaxis.ticks(x$at, x$main))
      if (x$label)
        x <- addGrob(x, make.xaxis.labels(x$at, x$main))
      else
        x <- removeGrob(x, "labels", warn=FALSE)
    }
  }
  if (match("label", slot.names, nomatch=0)) {
    if (x$label)
      x <- addGrob(x, make.xaxis.labels(x$at, x$main))
    else
      x <- removeGrob(x, "labels", warn=FALSE)    
  }
  # FIXME:  Handle "label=" and "main=" too ?
  x
}

make.xaxis.major <- function(at, main) {
  if (main)
    y <- c(0, 0)
  else
    y <- c(1, 1)
  linesGrob(unit(c(min(at), max(at)), "native"),
            unit(y, "npc"), name="major")
}

make.xaxis.ticks <- function(at, main) {
  if (main) {
    tick.y0 <- unit(0, "npc")
    tick.y1 <- unit(-.5, "lines")
  }
  else {
    tick.y0 <- unit(1, "npc")
    tick.y1 <- unit(1, "npc") + unit(.5, "lines")
  }
  segmentsGrob(unit(at, "native"), tick.y0,
               unit(at, "native"), tick.y1,
               name="ticks")
}

make.xaxis.labels <- function(at, main) {
  # FIXME:  labels only character versions of "at"
  if (main)
    label.y <- unit(-1.5, "lines")
  else
    label.y <- unit(1, "npc") + unit(1.5, "lines")
  textGrob(as.character(at), unit(at, "native"), label.y,
           just="centre", rot=0,
           check.overlap=TRUE, name="labels")
}

xaxisGrob <- function(at=NULL, label=TRUE, main=TRUE,
                       name=NULL, gp=gpar(), vp=NULL) {
  grid.xaxis(at=at, label=label, main=main,
             name=name, gp=gp, draw=FALSE, vp=vp)
}

# The "main" x-axis is on the bottom when vp$origin is "bottom.*"
# and on the top when vp$origin is "top.*"
grid.xaxis <- function(at=NULL, label=TRUE, main=TRUE,
                       name=NULL, gp=gpar(),
                       draw=TRUE, vp=NULL) {
  if (is.null(at)) {
    # We do not have enough information to make the ticks and labels
    major <- NULL
    ticks <- NULL
    labels <- NULL
  } else {
    major <- make.xaxis.major(at, main)
    ticks <- make.xaxis.ticks(at, main)
    if (label)
      labels <- make.xaxis.labels(at, main)
    else
      labels <- NULL
  }
  xg <- gTree(at=at, label=label, main=main,
              children=gList(major, ticks, labels),
              name=name, gp=gp, vp=vp,
              cl=c("xaxis", "axis"))
  if (draw)
    grid.draw(xg)
  invisible(xg)
}

drawDetails.yaxis <- function(x, recording=TRUE) {
  # If x$at is NULL, then we must calculate and draw the
  # tick marks on-the-fly
  if (is.null(x$at)) {
    at <- grid.pretty(current.viewport()$yscale)
    grid.draw(make.yaxis.major(at, x$main), recording=FALSE)
    grid.draw(make.yaxis.ticks(at, x$main), recording=FALSE)
    if (x$label)
      grid.draw(make.yaxis.labels(at, x$main), recording=FALSE)
    return(x)
  }
}

editDetails.yaxis <- function(x, specs) {
  slot.names <- names(specs)
  if (match("at", slot.names, nomatch=0)) {
    if (is.null(x$at)) {
      removeGrob(x, "main", warn=FALSE)
      removeGrob(x, "ticks", warn=FALSE)
      removeGrob(x, "labels", warn=FALSE)
    } else {
      x <- addGrob(x, make.yaxis.major(x$at, x$main))
      x <- addGrob(x, make.yaxis.ticks(x$at, x$main))
      if (x$label)
        x <- addGrob(x, make.yaxis.labels(x$at, x$main))
      else
        x <- removeGrob(x, "labels", warn=FALSE)
    }
  }
  if (match("label", slot.names, nomatch=0)) {
    if (x$label)
      x <- addGrob(x, make.xaxis.labels(x$at, x$main))
    else
      x <- removeGrob(x, "labels", warn=FALSE)    
  }
  x
}

make.yaxis.major <- function(at, main) {
  if (main)
    x <- c(0, 0)
  else
    x <- c(1, 1)
  linesGrob(unit(x, "npc"), unit(c(min(at), max(at)), "native"),
            name="major")
}

make.yaxis.ticks <- function(at, main) {
  if (main) {
    tick.x0 <- unit(0, "npc")
    tick.x1 <- unit(-.5, "lines")
  }
  else {
    tick.x0 <- unit(1, "npc")
    tick.x1 <- unit(1, "npc") + unit(.5, "lines")
  }
  segmentsGrob(tick.x0, unit(at, "native"),
               tick.x1, unit(at, "native"),
               name="ticks")
}

make.yaxis.labels <- function(at, main) {
  if (main) {
    hjust <- "right"
    label.x <- unit(-1, "lines")
  }
  else {
    hjust <- "left"
    label.x <- unit(1, "npc") + unit(1, "lines")
  }
  just <- c(hjust, "centre")
  textGrob(as.character(at), label.x, unit(at, "native"),
           just=just, rot=0, check.overlap=TRUE, name="labels")
}

yaxisGrob <- function(at=NULL, label=TRUE, main=TRUE,
                      name=NULL, gp=gpar(), vp=NULL) {
  grid.yaxis(at=at, label=label, main=main,
             name=name, gp=gp, draw=FALSE, vp=vp)
}

# The "main" y-axis is on the left when vp$origin is "*.left"
# and on the right when vp$origin is "*.right"
grid.yaxis <- function(at=NULL, label=TRUE, main=TRUE,
                       name=NULL, gp=gpar(),
                       draw=TRUE, vp=NULL) {
  if (is.null(at)) {
    # We do not have enough information to make the ticks and labels
    major <- NULL
    ticks <- NULL
    labels <- NULL
  } else {
    major <- make.yaxis.major(at, main)
    ticks <- make.yaxis.ticks(at, main)
    if (label)
      labels <- make.yaxis.labels(at, main)
    else
      labels <- NULL
  }
  yg <- gTree(at=at, label=label, main=main, 
              children=gList(major, ticks, labels),
              name=name, gp=gp, vp=vp,
              cl=c("yaxis", "axis"))
  if (draw)
    grid.draw(yg)
  invisible(yg)
}

######################################
# Simple "side-effect" plotting functions
######################################

grid.grill <- function(h=unit(seq(0.25, 0.75, 0.25), "npc"),
                       v=unit(seq(0.25, 0.75, 0.25), "npc"),
                       default.units="npc",
                       gp=gpar(col="grey"), vp=NULL) {
  if (!is.unit(h))
    h <- unit(h, default.units)
  if (!is.unit(v))
    v <- unit(v, default.units)
  # FIXME:  Should replace for loop and call to grid.lines with call to grid.segments
  # once the latter exists
  if (!is.null(vp))
    pushViewport(vp)
  grid.segments(v, unit(0, "npc"), v, unit(1, "npc"), gp=gp)
  grid.segments(unit(0, "npc"), h, unit(1, "npc"), h, gp=gp)
  if (!is.null(vp))
    popViewport()
}

################
# frame class
################
# NOTE: make framevp separate slot (rather than combining with
# normal vp slot) so that it can be edited (e.g., by grid.pack)
frameGrob <- function(layout=NULL, name=NULL, gp=gpar(), vp=NULL) {
  if (!is.null(layout)) 
    framevp <- viewport(layout=layout)
  else 
    framevp <- NULL
  gTree(framevp=framevp, name=name, gp=gp, vp=vp,
        cl="frame")
}

# draw=TRUE will not draw anything, but will mean that
# additions to the frame are drawn
grid.frame <- function(layout=NULL, name=NULL, gp=gpar(), vp=NULL,
                       draw=TRUE) {
  fg <- frameGrob(layout=layout, name=name, gp=gp, vp=vp)
  if (draw)
    grid.draw(fg)
  invisible(fg)
}

preDrawDetails.frame <- function(x) {
  if (!is.null(x$framevp))
    pushViewport(x$framevp, recording=FALSE)
}

postDrawDetails.frame <- function(x) {
  if (!is.null(x$framevp))
    popViewport(recording=FALSE)
}

widthDetails.frame <- function(x) {
  if (is.null(x$framevp))
    unit(1, "null")
  else
    sum(layout.widths(viewport.layout(x$framevp)))
}

heightDetails.frame <- function(x) {
  if (is.null(x$framevp))
    unit(1, "null")
  else
    sum(layout.heights(viewport.layout(x$framevp)))
}

frameDim <- function(frame) {
  if (is.null(frame$framevp))
    rep(0, 2)
  else
    c(layout.nrow(viewport.layout(frame$framevp)),
      layout.ncol(viewport.layout(frame$framevp)))
}

################
# cellGrob class
################
cellViewport <- function(col, row, border) {
  vp <- viewport(layout.pos.col=col, layout.pos.row=row)
  if (!is.null(border))
    vp <- vpStack(vp,
                  viewport(x=border[2],
                           y=border[1],
                           width=unit(1, "npc") - sum(border[c(2,4)]),
                           height=unit(1, "npc") - sum(border[c(1,3)]),
                           just=c("left", "bottom")))
  vp
}

cellGrob <- function(col, row, border, grob, dynamic, vp) {
  gTree(col=col, row=row, border=border, dynamic=dynamic,
        children=gList(grob), vp=vp, cl="cellGrob")
}

# For dynamically packed grobs, need to be able to
# recalculate cell sizes
widthDetails.cellGrob <- function(x) {
  if (x$dynamic)
    unit(1, "grobwidth", gPath(x$children[[1]]$name))
  else
    unit(1, "grobwidth", x$children[[1]])
}

heightDetails.cellGrob <- function(x) {
  if (x$dynamic)
    unit(1, "grobheight", gPath(x$children[[1]]$name))
  else
    unit(1, "grobheight", x$children[[1]])
}

################
# grid.place
################
# Place an object into an already existing cell of a frame ...
# ... for a grob on the display list
grid.place <- function(gPath, grob,
                       row=1, col=1,
                       redraw=TRUE) {
  grid.set(gPath,
           placeGrob(grid.get(gPath), grob, row, col),
           redraw)
}
  
# ... for a grob description
placeGrob <- function(frame, grob,
                      row=NULL, col=NULL) {
  if (!inherits(frame, "frame"))
    stop("Invalid frame")
  if (!is.grob(grob))
    stop("Invalid grob")
  dim <- frameDim(frame)
  if (is.null(row))
    row <- c(1, dim[1])
  if (is.null(col))
    col <- c(1, dim[2])
  if (length(row) == 1)
    row <- rep(row, 2)
  if (length(col) == 1)
    col <- rep(col, 2)
  if (min(row) < 1 || max(row) > dim[1] ||
      min(col) < 1 || max(col) > dim[2])
    stop("Invalid row and/or col (no such cell in frame layout)")
  cgrob <- cellGrob(col, row, NULL, grob, FALSE,
                    cellViewport(col, row, NULL))
  addGrob(frame, cgrob)
}

################
# grid.pack
################
num.col.specs <- function(side, col, col.before, col.after) {
  4 - sum(is.null(side) || any(c("top", "bottom") %in% side),
          is.null(col), is.null(col.before), is.null(col.after))
}

# We are assuming that checking has been done so that only one
# of these specifications has been given
col.spec <- function(side, col, col.before, col.after, ncol) {
  if (!is.null(side)) {
    if (side == "left")
      col <- 1
    else if (side == "right")
      col <- ncol + 1
  }
  else if (!is.null(col.before))
    col <- col.before
  else if (!is.null(col.after))
    col <- col.after + 1
  col
}

# We are assuming that checking has been done so that only one
# of these specifications has been given
new.col <- function(side, col, col.before, col.after, ncol) {
  # Special case ncol==0 for first grob added to frame
  result <- TRUE
  if (!is.null(col)) {
    # It is an error to specify a range for col which is outside 1..ncol
    if (length(col) == 2) 
      if (col[1] < 1 || col[2] > ncol)
        stop("`col' can only be a range of existing columns")
      else
        result <- FALSE
    # It is also an error to specify a single col outside 1..ncol+1
    else
      if (col < 1 || col > ncol + 1)
        stop("Invalid column specification")
      else
        result <- col == ncol+1
  }
  result
}

num.row.specs <- function(side, row, row.before, row.after) {
  4 - sum(is.null(side) || any(c("left", "right") %in% side),
          is.null(row), is.null(row.before), is.null(row.after))
}

# We are assuming that checking has been done so that only one
# of these specifications has been given
row.spec <- function(side, row, row.before, row.after, nrow) {
  if (!is.null(side)) {
    if (side == "top")
      row <- 1
    else if (side == "bottom")
      row <- nrow + 1
  }
  else if (!is.null(row.before))
    row <- row.before
  else if (!is.null(row.after))
    row <- row.after + 1
  row
}

# We are assuming that checking has been done so that only one
# of these specifications has been given
new.row <- function(side, row, row.before, row.after, nrow) {
  # Special case nrow==0 for first grob added to frame
  result <- TRUE
  if (!is.null(row)) {
    # It is an error to specify a range for row which is outside 1..nrow
    if (length(row) == 2) 
      if (row[1] < 1 || row[2] > nrow)
        stop("`row' can only be a range of existing rows")
      else
        result <- FALSE
    # It is also an error to specify a single row outside 1..nrow+1
    else
      if (row < 1 || row > nrow + 1)
        stop("Invalid row specification")
      else
        result <- row == nrow+1
  }
  result
}

mod.dims <- function(dim, dims, index, new.index, nindex, force) {
  # If adding a new row/col, add the new width/height to the list
  if (new.index)
    if (index == 1)
      dims <- unit.c(dim, dims)
    else if (index == nindex)
      dims <- unit.c(dims, dim)
    else
      dims <- unit.c(dims[1:(index-1)], dim, dims[index:nindex])
  # Otherwise, if force=TRUE, we override previous width/heights for the
  # row/col, otherotherwise, the width/height of the existing row/col
  # is the maximum of the previous width/height and the new width/height
  else {
    if (!force)
      dim <- max(dim, dims[index])
    if (index==1)
      if (nindex == 1)
        dims <- dim
      else
        dims <- unit.c(dim, dims[2:nindex])
    else if (index==nindex)
      dims <- unit.c(dims[1:(nindex-1)], dim)
    else
      dims <- unit.c(dims[1:(index-1)], dim, dims[(index+1):nindex])
  }
  dims
}

updateCol <- function(col, added.col) {
  old.col <- col
  # If grob$col is a range ...
  if (length(old.col) == 2) {
    if (added.col <= old.col[2])
      col <- c(old.col[1], old.col[2] + 1)
  }
  else
    if (added.col <= old.col)
      col <- old.col + 1
  col
}

updateRow <- function(row, added.row) {
  old.row <- row
  # If grob$row is a range ...
  if (length(old.row) == 2) {
    if (added.row <= old.row[2])
      row <- c(old.row[1], old.row[2] + 1)
  }
  else
    if (added.row <= old.row)
      row <- old.row + 1
  row
}

# FIXME:  Allow specification of respect for new row/col
# Pack a child grob within a frame grob ... 
# (a special sort of editing just for frame grobs)
# ... for a grob on the display list
grid.pack <- function(gPath, grob, redraw=TRUE,
                      side=NULL,
                      row=NULL, row.before=NULL, row.after=NULL,
                      col=NULL, col.before=NULL, col.after=NULL,
                      width=NULL, height=NULL,
                      force.width=FALSE, force.height=FALSE,
                      border=NULL, dynamic=FALSE) {
  grid.set(gPath,
           packGrob(grid.get(gPath), grob, side,
                    row, row.before, row.after,
                    col, col.before, col.after,
                    width, height, force.width, force.height,
                    border),
           redraw)
}

packGrob <- function(frame, grob,
                     side=NULL,
                     row=NULL, row.before=NULL, row.after=NULL,
                     col=NULL, col.before=NULL, col.after=NULL,
                     width=NULL, height=NULL,
                     force.width=FALSE, force.height=FALSE,
                     border=NULL, dynamic=FALSE) {
  if (!inherits(frame, "frame"))
    stop("Invalid frame")
  if (!is.grob(grob))
    stop("Invalid grob")
  # col/row can be given as a range, but I only want to know
  # about the min and max
  if (!is.null(col) & length(col) > 1) {
    col <- range(col)
    col.range <- TRUE
  }
  else
    col.range <- FALSE
  if (!is.null(row) & length(row) > 1) {
    row <- range(row)
    row.range <- TRUE
  }
  else
    row.range <- FALSE
  
  frame.vp <- frame$framevp
  if (is.null(frame.vp))
    frame.vp <- viewport()
  lay <- viewport.layout(frame.vp)
  if (is.null(lay)) {
    ncol <- 0
    nrow <- 0
  } else {
    ncol <- layout.ncol(lay) 
    nrow <- layout.nrow(lay) 
  }
  
  # (i) Check that the specifications of the location of the grob
  # give a unique location
  ncs <- num.col.specs(side, col, col.before, col.after)
  # If user does not specify a col, assume it is all cols
  if (ncs == 0) {
    # Allow for fact that this might be first grob packed
    if (ncol > 0) {
      col <- c(1, ncol)
      col.range <- TRUE
    }
    else
      col <- 1
    ncs <- 1
  }
  if (ncs != 1) 
    stop("Cannot specify more than one of side=[\"left\", \"right\"], col, col.before, or col.after")
  nrs <- num.row.specs(side, row, row.before, row.after)
  # If user does not specify a row, assume it is all rows
  if (nrs == 0) {
    # Allow for fact that this might be first grob packed
    if (nrow > 0) {
      row <- c(1, nrow)
      row.range <- TRUE
    }
    else
      row <- 1
    nrs <- 1
  }
  if (nrs != 1)
    stop("Must specify exactly one of side=[\"top\", \"bottom\"], row, row.before, or row.after")

  # (ii) Determine that location and check that it is valid
  new.col <- new.col(side, col, col.before, col.after, ncol)
  col <- col.spec(side, col, col.before, col.after, ncol)
  new.row <- new.row(side, row, row.before, row.after, nrow)
  row <- row.spec(side, row, row.before, row.after, nrow)

  # Wrap the child in a "cellGrob" to maintain additional info
  # (like row and col occupied in frame)
  # Need to do this here so can create widths/heights based on this cell grob
  if (!is.null(grob))
    cgrob <- cellGrob(col, row, border, grob, dynamic,
                      cellViewport(col, row, border))
  
  # (iii) If width and height are not given, take them from the child
  #       NOTE:  if dynamic is TRUE then use a gPath to the child
  if (is.null(width))
    if (is.null(grob))
      width <- unit(1, "null")
    else
      if (dynamic)
        width <- unit(1, "grobwidth", gPath(cgrob$name))
      else
        width <- unit(1, "grobwidth", cgrob)
  if (is.null(height))
    if (is.null(grob))
      height <- unit(1, "null")
    else
      if (dynamic)
        height <- unit(1, "grobheight", gPath(cgrob$name))
      else
        height <- unit(1, "grobheight", cgrob)
  # If there is a border, include it in the width/height
  if (!is.null(border)) {
    width <- sum(border[2], width, border[4])
    height <- sum(border[1], height, border[3])
  }
  
  # (iv) Update the frame.vp of the frame (possibly add new row/col,
  # possibly update existing widths/heights and respect)
  if (new.col) ncol <- ncol + 1
  if (new.row) nrow <- nrow + 1
  # If we are creating the frame.vp$layout for the first time then
  # we have to initialise the layout widths and heights
  if (is.null(lay)) {
    widths <- width
    heights <- height
  } else {
    # DO NOT modify widths/heights if the grob is being added to
    # multiple columns/rows
    if (col.range)
      widths <- layout.widths(lay)
    else
      widths <- mod.dims(width, layout.widths(lay), col, new.col, ncol,
                         force.width)
    if (row.range)
      heights <- layout.heights(lay)
    else
      heights <- mod.dims(height, layout.heights(lay), row, new.row, nrow,
                          force.height)
  }
  frame.vp$layout <- grid.layout(ncol=ncol, nrow=nrow,
                                 widths=widths, height=heights)

  # Modify the locations (row, col) of existing children in the frame
  if (new.col || new.row) {
    for (i in childNames(frame)) {
      child <- getGrob(frame, i)
      if (new.col) {
        newcol <- updateCol(child$col, col)
        child <- editGrob(child, col=newcol,
                          vp=cellViewport(newcol, child$row, child$border))
      }
      if (new.row) {
        newrow <- updateRow(child$row, row)
        child <- editGrob(child, row=newrow,
                          vp=cellViewport(child$col, newrow, child$border))
      }
      frame <- addGrob(frame, child)
    }
  }

  # Add the new grob to the frame
  if (!is.null(grob)) {
    frame <- addGrob(frame, cgrob)
  }
  
  editGrob(frame, framevp=frame.vp)
}


# A "gpar" object is a list of graphics parameters
# A graphics parameter is a name-value pair

gpar <- function(...) {
  gp <- validGP(list(...))
  class(gp) <- "gpar"
  gp
}

is.gpar <- function(x) {
  inherits(x, "gpar")
}

validGP <- function(gpars) {
  # Check a (non-NULL) gpar is not of length 0
  check.length <- function(gparname) {
    if (length(gpars[[gparname]]) == 0)
      stop(paste("gpar element", gparname, "must not be length 0"))
  }
  # Check a gpar is numeric and not NULL
  numnotnull <- function(gparname) {
    if (!is.na(match(gparname, names(gpars)))) {
      if (is.null(gpars[[gparname]]))
        gpars[[gparname]] <<- NULL
      else {
        check.length(gparname)
        gpars[[gparname]] <<- as.numeric(gpars[[gparname]])
      }
    }
  }
  # fontsize, lineheight, cex, lwd should be numeric and not NULL
  numnotnull("fontsize")
  numnotnull("lineheight")
  numnotnull("cex")
  numnotnull("lwd")
  numnotnull("gamma")
  numnotnull("alpha")
  # col and fill are converted in C code
  # so is lty, BUT still want to check for NULL
  if (!is.na(match("lty", names(gpars)))) {
    if (is.null(gpars$lty))
      gpars$lty <- NULL
    else
      check.length("lty")
  }
  # font should be integer and not NULL
  if (!is.na(match("font", names(gpars)))) {
    if (is.null(gpars$font))
      gpars$font <- NULL
    else {
      check.length("font")
      gpars$font <- as.integer(gpars$font)
    }
  }
  # fontfamily should be character
  if (!is.na(match("fontfamily", names(gpars)))) {
    if (is.null(gpars$fontfamily))
      gpars$fontfamily <- NULL
    else {
      check.length("fontfamily")
      gpars$fontfamily <- as.character(gpars$fontfamily)
    }
  }
  # fontface can be character or integer;  map character to integer
  # store value in font
  # Illegal to specify both font and fontface
  if (!is.na(match("fontface", names(gpars)))) {
    if (!is.na(match("font", names(gpars))))
      stop("Must specify only one of font and fontface")
    if (is.null(gpars$fontface))
      gpars$font <- NULL
    else {
      check.length("fontface")
      if (is.numeric(gpars$fontface))
        gpars$font <- as.integer(gpars$fontface)
      else {
        temp.char <- as.character(gpars$fontface)
        temp.num <- 0
        for (i in 1:length(temp.char))
          temp.num[i] <- switch(temp.char[i],
                                plain=1,
                                italic=3,
                                oblique=3,
                                bold=2,
                                bold.italic=4,
                                symbol=5,
                                # These are Hershey variants
                                cyrillic=5,
                                cyrillic.oblique=6,
                                EUC=7)
        gpars$font <- as.integer(temp.num)
      }
    }
  }
  gpars
}

# possible gpar names
# The order must match the GP_* values in grid.h
.grid.gpar.names <- c("fill", "col", "gamma", "lty", "lwd", "cex",
                      "fontsize", "lineheight", "font", "fontfamily",
                      "alpha",
                      # Keep fontface at the end because it is never
                      # used in C code (it gets mapped to font)
                      "fontface")

set.gpar <- function(gp) {
  if (!is.gpar(gp))
    stop("Argument must be a 'gpar' object")
  temp <- grid.Call("L_getGPar")
  temp[names(gp)] <- gp
  # Do this as a .Call.graphics to get it onto the base display list
  grid.Call.graphics("L_setGPar", temp)
}

get.gpar <- function(names=NULL) {
  if (is.null(names))
    result <- grid.Call("L_getGPar")
  else {
    if (!is.character(names) ||
        !all(names %in% .grid.gpar.names))
      stop("Must specify only valid gpar names")
    result <- grid.Call("L_getGPar")[names]
  }
  class(result) <- "gpar"
  result
}



# FIXME:  all grid functions should check that .grid.started is TRUE
.grid.loaded <- FALSE

push.vp <- function(vp, recording) {
  UseMethod("push.vp")
}

push.vp.default <- function(vp, recording) {
  stop("Only valid to push viewports")
}

push.vp.viewport <- function(vp, recording) {
  # Record on the display list
  if (recording)
    record(vp)
  # Create a pushedvp object for the system to keep track of
  pvp <- pushedvp(vp)
  # Store the entire set of gpar settings JUST PRIOR to push
  # We refer to this when calculating the viewport transform
  # We cannot simply rely on parent's gpar because we may be
  # being pushed from within a gTree which has enforced gpar
  # settings (i.e., the gTree$gp is enforced between this viewport
  # and the this viewport's parent$gp)
  pvp$parentgpar <- grid.Call("L_getGPar")
  # Enforce gpar settings
  set.gpar(vp$gp)
  # Store the entire set of gpar settings for this viewport
  pvp$gpar <- grid.Call("L_getGPar")
  # Pass in the pushedvp structure which will be used to store
  # things like the viewport transformation, parent-child links, ...
  grid.Call.graphics("L_setviewport", pvp, TRUE)
}

# For all but the last viewport, push the
# viewport then pop it
# For the last viewport, just push
push.vp.vpList <- function(vp, recording) {
  push.vp.parallel <- function(vp, recording) {
    push.vp(vp, recording)
    upViewport(depth(vp), recording)
  }
  if (length(vp) == 1)
    push.vp(vp[[1]], recording)
  else {
    lapply(vp[1:(length(vp) - 1)], push.vp.parallel, recording)
    push.vp(vp[[length(vp)]], recording)
  }
}

# Push viewports in series
push.vp.vpStack <- function(vp, recording) {
  lapply(vp, push.vp, recording)
}

# Push parent
# Children are a vpList
push.vp.vpTree <- function(vp, recording) {
  # Special case if user has saved the entire vpTree
  # parent will be the ROOT viewport, which we don't want to
  # push (grid ensures it is ALWAYS there)
  if (!(vp$paren$name %in% "ROOT"))
    push.vp(vp$parent, recording)
  push.vp(vp$children, recording)
}

push.viewport <- function(..., recording=TRUE) {
  .Deprecated("pushViewport")
  pushViewport(..., recording=recording)
}

pushViewport <- function(..., recording=TRUE) {
  if (missing(...))
    stop("Must specify at least one viewport")
  else {
    vps <- list(...)
    lapply(vps, push.vp, recording)
  }
  current.viewport()
}

# Helper functions called from C
no.children <- function(children) {
  length(ls(env=children, all.names=TRUE)) == 0
}

child.exists <- function(name, children) {
  exists(name, env=children, inherits=FALSE)
}

child.list <- function(children) {
  ls(env=children, all.names=TRUE)
}

pathMatch <- function(path, pathsofar, strict) {
  if (is.null(pathsofar))
    is.null(path)
  else {
    if (strict)
      pattern <- paste("^", path, "$", sep="")
    else
      pattern <- paste(path, "$", sep="")
    regexpr(pattern, pathsofar) > 0
  }
}

growPath <- function(pathsofar, name) {
  paste(pathsofar, name, sep=.grid.pathSep)
}

# Rather than pushing a new viewport, navigate down to one that has
# already been pushed
downViewport <- function(name, strict=FALSE, recording=TRUE) {
  UseMethod("downViewport")
}

# For interactive use, allow user to specify
# vpPath directly (i.e., w/o calling vpPath)
downViewport.default <- function(name, strict=FALSE, recording=TRUE) {
  name <- as.character(name)
  downViewport(vpPathDirect(name), strict, recording=recording)
}

downViewport.vpPath <- function(name, strict=FALSE, recording=TRUE) {
  if (name$n == 1)
    result <- grid.Call.graphics("L_downviewport", name$name, strict)
  else
    result <- grid.Call.graphics("L_downvppath", name$path, name$name, strict)
  if (result) {
    # Enforce the gpar settings for the viewport 
    pvp <- grid.Call("L_currentViewport")
    set.gpar(pvp$gpar)
    # Record the viewport operation
    if (recording) {
      record(name)
    }
  } else {
    stop(paste("Viewport", name, "was not found"))
  }
  current.viewport()
}

# Similar to down.viewport() except it starts searching from the
# top-level viewport, so the result may be "up" or even "across"
# the current viewport tree
seekViewport <- function(name, recording=TRUE) {
  # up to the top-level
  upViewport(0, recording=recording)
  downViewport(name, recording=recording)
}

# Depth of the current viewport
vpDepth <- function() {
  pvp <- grid.Call("L_currentViewport")
  count <- 0
  while (!is.null(pvp$parent)) {
    pvp <- pvp$parent
    count <- count + 1
  }
  count
}

pop.vp <- function(last.one, recording) {
  pvp <- grid.Call("L_currentViewport")
  # Fail if trying to pop top-level viewport
  if (is.null(pvp$parent))
    stop("Illegal to pop top-level viewport")
  # Assert the gpar settings of the parent (which is about to become "current")
  pgpar <- pvp$parent$gpar
  set.gpar(pgpar)
  # Allow for recalculation of viewport transform if necessary
  # and do things like updating parent/children slots in
  # stored pushedvps
  grid.Call.graphics("L_unsetviewport", last.one)
}

pop.viewport <- function(n=1, recording=TRUE) {
  .Deprecated("popViewport")
  popViewport(n, recording=recording)
}

popViewport <- function(n=1, recording=TRUE) {
  if (n < 0)
    stop("Must pop at least one viewport")
  if (n == 0)
    n <- vpDepth()
  if (n > 0) {
    for (i in 1:n)
      pop.vp(i==n, recording)
    # Record on the display list
    if (recording) {
      class(n) <- "pop"
      record(n)
    }
  }
  current.viewport()
}

up.vp <- function(last.one, recording) {
  pvp <- grid.Call("L_currentViewport")
  # Fail if trying to up top-level viewport
  if (is.null(pvp$parent))
    stop("Illegal to navigate up past top-level viewport")
  # Assert the gpar settings of the parent (which is about to become "current")
  pgpar <- pvp$parent$gpar
  class(pgpar) <- "gpar"
  set.gpar(pgpar)
  # Allow for recalculation of viewport transform if necessary
  grid.Call.graphics("L_upviewport", last.one)
}

# Rather than removing the viewport from the viewport stack (tree),
# simply navigate up, leaving pushed viewports in place.
upViewport <- function(n=1, recording=TRUE) {
  if (n < 0)
    stop("Must navigate up at least one viewport")
  if (n == 0)
    n <- vpDepth()
  if (n > 0) {
    for (i in 1:n)
      up.vp(i==n, recording)
    # Record on the display list
    if (recording) {
      class(n) <- "up"
      record(n)
    }
  }
  current.viewport()
}

# Function to obtain the current viewport
current.viewport <- function(vp=NULL) {
  if (is.null(vp))
    # The system stores a pushedvp;  the user should only
    # ever see normal viewports, so convert.
    vpFromPushedvp(grid.Call("L_currentViewport"))
  else {
    warning("The vp argument is deprecated")
    vp
  }
}

vpListFromNode <- function(node) {
  childnames <- ls(env=node$children, all.names=TRUE)
  n <- length(childnames)
  children <- vector("list", n)
  index <- 1
  for (i in childnames) {
    children[[index]] <- vpTreeFromNode(get(i, env=node$children))
    index <- index + 1
  }
  vpListFromList(children)
}

vpTreeFromNode <- function(node) {
  # If no children then just return viewport
  if (length(ls(env=node$children, all.names=TRUE)) == 0)
    vpFromPushedvp(node)
  # Otherwise return vpTree
  else
    vpTree(vpFromPushedvp(node),
           vpListFromNode(node))
}

# Obtain the current viewport tree
# Either from the current location in the tree down
# or ALL of the tree
current.vpTree <- function(all=TRUE) {
  cpvp <- grid.Call("L_currentViewport")
  moving <- all && vpDepth() > 0
  if (moving) {
    savedname <- cpvp$name
    upViewport(0, recording=FALSE)
    cpvp <- grid.Call("L_currentViewport")
  }
  tree <- vpTreeFromNode(cpvp)
  if (moving) {
    downViewport(savedname, recording=FALSE)
  }
  tree
}

current.transform <- function() {
  grid.Call("L_currentViewport")$trans
}

# Call this function if you want the graphics device erased or moved
# on to a new page.  High-level plotting functions should call this.
# NOTE however, that if you write a function which calls grid.newpage,
# you should provide an argument to allow people to turn it off
# so that they can use your function within a parent viewport
# (rather than the whole device) if they want to.
grid.newpage <- function(recording=TRUE) {
  # NOTE that we do NOT do grid.Call here because we have to do
  # things slightly differently if grid.newpage is the first grid operation
  # on a new device
  .Call("L_newpagerecording", graphics::par("ask"), PACKAGE="grid")
  .Call("L_newpage", PACKAGE="grid")
  .Call("L_initGPar", PACKAGE="grid")
  .Call("L_initViewportStack", PACKAGE="grid")
  if (recording) {
    .Call("L_initDisplayList", PACKAGE="grid")
    for (fun in getHook("grid.newpage")) try(fun())
  }
  invisible()
}

###########
# DISPLAY LIST FUNCTIONS
###########

# Keep a list of all drawing operations (since last grid.newpage()) so
# that we can redraw upon edit.

inc.display.list <- function() {
  display.list <- grid.Call("L_getDisplayList")
  dl.index <- grid.Call("L_getDLindex")
  dl.index <- dl.index + 1
  n <- length(display.list)
  # The " - 1" below is because dl.index is now stored internally
  # so is a C-style zero-based index rather than an R-style
  # 1-based index
  if (dl.index > (n - 1)) {
    temp <- display.list
    display.list <- vector("list", n+100)
    display.list[1:n] <- temp
  }
  grid.Call("L_setDisplayList", display.list)
  grid.Call("L_setDLindex", as.integer(dl.index))
}

# This will either ...
#   (i) turn on AND INITIALISE the display list or ...
#   (ii) turn off AND ERASE the display list
grid.display.list <- function(on=TRUE) {
  grid.Call("L_setDLon", as.logical(on))
  if (on) {
    grid.Call("L_setDisplayList", vector("list", 100))
    grid.Call("L_setDLindex", as.integer(0))
  }
  else
    grid.Call("L_setDisplayList", NULL)
}

record <- function(x) {
  if (grid.Call("L_getDLon"))
    UseMethod("record")
}

# When there is a pop.viewport, the number of viewports popped
# gets put on the display list
record.default <- function(x) {
  if (!is.numeric(x))
    stop("Invalid object inserted on the display list")
  grid.Call("L_setDLelt", x)
  inc.display.list()
}

record.grob <- function(x) {
  grid.Call("L_setDLelt", x)
  inc.display.list()
}

record.viewport <- function(x) {
  grid.Call("L_setDLelt", x)
  inc.display.list()
}

record.vpPath <- function(x) {
  grid.Call("L_setDLelt", x)
  inc.display.list()
}

# This controls whether grid is using the graphics engine's display list
engine.display.list <- function(on=TRUE) {
  grid.Call("L_setEngineDLon", as.logical(on))
}

# Wrapper for .Call and .Call.graphics
# Used to make sure that grid-specific initialisation occurs just before
# the first grid graphics output OR the first querying of grid state
# (on the current device)
# The general rule is you should use these rather than .Call or
# .Call.graphics unless you have a good reason and you know what
# you are doing -- this will be a bit of overkill, but is for safety
grid.Call <- function(fnname, ...) {
  .Call("L_gridDirty", PACKAGE="grid")
  .Call(fnname, ..., PACKAGE="grid")
}

grid.Call.graphics <- function(fnname, ...) {
  # Only record graphics operations on the graphics engine's display
  # list if the engineDLon flag is set
  engineDLon <- grid.Call("L_getEngineDLon")
  if (engineDLon) {
    # Avoid recording graphics operations on the engine's display list
    # when we are already recording!
    engineRecording <- grid.Call("L_getEngineRecording")
    if (engineRecording) {
      .Call("L_gridDirty", PACKAGE="grid")
      result <- .Call(fnname, ..., PACKAGE="grid")
    } else {
      # NOTE: we MUST record the fact that we are already recording
      # otherwise when we replay the engine display list, we will
      # not know that at this point we were recording (my brain hurts)
      # NOTE that it is ok to .Call.graphics("L_gridDirty")
      # before .Call.graphics("L_setEngineRecording") because we
      # know that .Call.graphics("L_gridDirty") does not make
      # a further .Call.graphics() call itself
      # It is also appropriate that the first grid operation on
      # the graphics engine display list is a gridDirty call.
      .Call.graphics("L_gridDirty", PACKAGE="grid")
      .Call.graphics("L_setEngineRecording", TRUE, PACKAGE="grid")
      result <- .Call.graphics(fnname, ..., PACKAGE="grid")
      .Call.graphics("L_setEngineRecording", FALSE, PACKAGE="grid")
    }
  } else {
    .Call("L_gridDirty", PACKAGE="grid")
    result <- .Call(fnname, ..., PACKAGE="grid")
  }
  result
}

######################################
# Grid graphical objects
#######################################

################
# CLASS DEFN
################
# A "virtual" class "gDesc" underlies both "grob" and "gPath"

initGrobAutoName <- function() {
  index <- 0
  function() {
    index <<- index + 1
    paste("GRID.GROB.", index, sep="")
  }
}

grobAutoName <- initGrobAutoName()

################
# CLASS DEFN
################
# A grob has a name, a gp, and a vp
# grob inherits from gDesc
checkvpSlot <- function(vp) {
  # vp can be a viewport, a viewport name, or a viewport path
  if (!is.null(vp))
    if (!inherits(vp, "viewport") &&
        !inherits(vp, "vpPath") &&
        !is.character(vp))
      stop("Invalid vp slot")
  # For interactive use, allow user to specify
  # vpPath directly (i.e., w/o calling vpPath)
  if (is.character(vp))
    vp <- vpPathDirect(vp)
  vp
}

checkNameSlot <- function(name) {
  # Supply a default name if one is not given
  if (is.null(name))
    grobAutoName()
  else
    as.character(name)
}

checkgpSlot <- function(gp) {
  # gp must be a gpar
  if (!is.null(gp))
    if (!inherits(gp, "gpar"))
      stop("Invalid gp slot")
}

validDetails <- function(x) {
  UseMethod("validDetails")
}

validDetails.grob <- function(x) {
  x
}

validGrob <- function(x) {
  x$name <- checkNameSlot(x$name)
  checkgpSlot(x$gp)
  x$vp <- checkvpSlot(x$vp)
  # Validate other grob slots
  x <- validDetails(x)
  return(x)
}

# This actually creates a new class derived from grob
# and returns an instance of that new class, all in one step
grob <- function(..., name=NULL, gp=NULL, vp=NULL, cl=NULL) {
  g <- list(..., name=name, gp=gp, vp=vp)
  if (!is.null(cl) &&
      !is.character(cl))
    stop("Invalid grob class")
  class(g) <- c(cl, "grob", "gDesc")
  validGrob(g)
}

grid.grob <- function(list.struct, cl=NULL, draw=TRUE) {
  warning("grid.grob() is deprecated; please use grob() instead")
  g <- do.call("grob", c(list.struct, cl=cl))
  if (draw)
    grid.draw(g)
  invisible(g)
}

is.grob <- function(x) {
  inherits(x, "grob")
}

print.grob <- function(x, ...) {
  print(paste(class(x)[1], "[", x$name, "]", sep=""))
}

################
# gPath CLASS DEFN
################
# gPath is a concatenated list of names specifying a path to a grob
# Functions for creating "paths" of viewport names

gPathFromVector <- function(names) {
  n <- length(names)
  if (n < 1)
    stop("A grob path must contain at least one grob name")
  if (!all(is.character(names)))
    stop("Invalid grob name(s)")
  path <- list(path=if (n==1) NULL else
               paste(names[1:(n-1)], collapse=.grid.pathSep),
               name=names[n],
               n=n)
  class(path) <- c("gPath", "path")
  path
}

gPath <- function(...) {
  names <- c(...)
  gPathFromVector(names)
}

# Create gPath from string with embedded .grid.pathSep(s)
gPathDirect <- function(path) {
  names <- unlist(strsplit(path, .grid.pathSep))
  gPathFromVector(names)
}

################
# gList CLASS DEFN
################
# Just a list of grobs
okGListelt <- function(x) {
  is.grob(x) || is.null(x)
}

gList <- function(...) {
  gl <- list(...)
  if (length(gl) == 0 ||
      all(sapply(gl, okGListelt, simplify=TRUE))) {
    class(gl) <- c("gList")
    return(gl)
  } else {
    stop("Only grobs allowed in gList")
  }
  return(gl)
}

################
# gTree CLASS DEFN
################
# gTree extends grob
# A gTree has additional children slot
gTree <- function(..., name=NULL, gp=NULL, vp=NULL,
                  children=NULL, childrenvp=NULL,
                  cl=NULL) {
  gt <- list(..., name=name, gp=gp, vp=vp, childrenvp=childrenvp)
  if (!is.null(children) &&
      !inherits(children, "gList"))
    stop("Children must be a gList")
  gt$children <- list()
  gt$childrenOrder <- character()
  if (!is.null(cl) &&
      !is.character(cl))
    stop("Invalid gTree class")
  class(gt) <- c(cl, "gTree", "grob", "gDesc")
  # Make sure basic slots are ok before trying to add children
  gt$name <- checkNameSlot(gt$name)
  checkgpSlot(gt$gp)
  gt$vp <- checkvpSlot(gt$vp)
  checkvpSlot(gt$childrenvp)
  # Add children before calling validGrob!
  if (length(children) > 0)
    for (i in 1:length(children))
      if (!is.null(children[[i]]))
        gt <- addGrob(gt, children[[i]])
  gt <- validGrob(gt)
  return(gt)
}

################
# Getting/adding/removing/editing (children of [children of ...]) a gTree
################

# NOTE:  In order to cut down on repeated code, some of these
# (i.e., all but get and set) are inefficient and call get/set
# to do their work.  If speed becomes an issue, may have to
# revert to individual support for each function with highly
# repetitive code

childNames <- function(gTree) {
  if (!inherits(gTree, "gTree"))
    stop("It is only valid to get children from a gTree")
  gTree$childrenOrder
}

# Get a grob from the display list
grid.get <- function(gPath, strict=FALSE, grep=FALSE, global=FALSE,
                     allDevices=FALSE) {
  if (any(grep, global, allDevices))
    stop("grep, global, and allDevices not yet implemented")
  if (is.character(gPath))
    gPath <- gPathDirect(gPath)
  if (!inherits(gPath, "gPath"))
    stop("Invalid path")
  getDLfromGPath(gPath, strict)
}

# Get a child (of a child, of a child, ...) of a grob
getGrob <- function(gTree, gPath, strict=FALSE,
                    grep=FALSE, global=FALSE) {
  if (grep || global)
    stop("grep and global options not yet implemented")
  if (!inherits(gTree, "gTree"))
    stop("It is only valid to get a child from a gTree")
  if (is.character(gPath))
    gPath <- gPathDirect(gPath)
  if (!inherits(gPath, "gPath"))
    stop("Invalid path")
  if (depth(gPath) == 1 && strict) {
    gTree$children[[gPath$name]]
  } else {
    getGTree(gTree, NULL, gPath, strict)
  }
}

# Set a grob on the display list
# It is NOT valid to specify an ambiguous gPath (i.e., no grep arg)
# nor is it valid to specify a global destination (i.e., no global arg)
grid.set <- function(gPath, newGrob, strict=FALSE,
                     redraw=TRUE) {
  if (is.character(gPath))
    gPath <- gPathDirect(gPath)
  if (!inherits(gPath, "gPath"))
    stop("Invalid path")
  result <- setDLfromGPath(gPath, newGrob, strict)
  # result$index will be non-zero if matched the gPath
  if (result$index) {
    # Get the current DL index
    dl.index <- grid.Call("L_getDLindex")
    # Destructively modify the DL elt
    grid.Call("L_setDLindex", as.integer(result$index))
    grid.Call("L_setDLelt", result$grob)
    # Reset the DL index
    grid.Call("L_setDLindex", as.integer(dl.index))
    if (redraw)
      draw.all()
  } else {
    stop("gPath does not specify a valid child")
  }
}

# Set a grob
# It is NOT valid to specify an ambiguous gPath (i.e., no grep arg)
# nor is it valid to specify a global destination (i.e., no global arg)
setGrob <- function(gTree, gPath, newGrob, strict=FALSE) {
  if (!inherits(gTree, "gTree"))
    stop("It is only valid to set a child of a gTree")
  if (!inherits(newGrob, "grob"))
    stop("It is only valid to set a grob as child of a gTree")
  if (is.character(gPath))
    gPath <- gPathDirect(gPath)
  if (!inherits(gPath, "gPath"))
    stop("Invalid path")
  if (depth(gPath) == 1 && strict) {
    # gPath must specify an existing child
    if (old.pos <- match(gPath$name, gTree$childrenOrder, nomatch=FALSE)) {
      # newGrob name must match gPath
      if (match(gPath$name, newGrob$name, nomatch=FALSE)) {
        gTree$children[[newGrob$name]] <- newGrob
      } else {
        stop(paste("New grob name (", newGrob$name,
                   ") does not match gPath (", gPath, ")", sep=""))
      }
    } else {
      stop("gPath does not specify a valid child")
    }
  } else {
    gTree <- setGTree(gTree, NULL, gPath, newGrob, strict)
    if (is.null(gTree))
      stop("gPath does not specify a valid child")
  }
  gTree
}

# Add a grob to a grob on the display list
grid.add <- function(gPath, child, strict=FALSE,
                     grep=FALSE, global=FALSE, allDevices=FALSE,
                     redraw=TRUE) {
  if (any(grep, global, allDevices))
    stop("grep, global, and allDevices not yet implemented")
  gTree <- grid.get(gPath, strict)
  if (!inherits(gTree, "gTree"))
    stop("It is only valid to add a child to a gTree")
  if (!inherits(child, "grob"))
    stop("It is only valid to add a grob to a gTree")
  gTree$children[[child$name]] <- child
  # Handle case where child name already exists (so will be overwritten)
  if (old.pos <- match(child$name, gTree$childrenOrder, nomatch=0))
    gTree$childrenOrder <- gTree$childrenOrder[-old.pos]
  gTree$childrenOrder <- c(gTree$childrenOrder, child$name)
  grid.set(gPath, gTree, strict, redraw)
}

# Add a grob to a gTree (or a child of a (child of a ...) gTree)
addGrob <- function(gTree, child, gPath=NULL, strict=FALSE,
                    grep=FALSE, global=FALSE) {
  if (grep || global)
    stop("grep and global options not yet implemented")
  if (!is.null(gPath)) {
    origTree <- gTree
    gTree <- getGrob(gTree, gPath, strict)
  }
  if (!inherits(gTree, "gTree"))
    stop("It is only valid to add a child to a gTree")
  if (!inherits(child, "grob"))
    stop("It is only valid to add a grob to a gTree")
  gTree$children[[child$name]] <- child
  # Handle case where child name already exists (so will be overwritten)
  if (old.pos <- match(child$name, gTree$childrenOrder, nomatch=0))
    gTree$childrenOrder <- gTree$childrenOrder[-old.pos]
  gTree$childrenOrder <- c(gTree$childrenOrder, child$name)
  if (!is.null(gPath)) 
    gTree <- setGrob(origTree, gPath, gTree, strict)
  gTree
}

# Remove a grob (or child of ...) from the display list
grid.remove <- function(gPath, warn=TRUE, strict=FALSE,
                        grep=FALSE, global=FALSE, allDevices=FALSE,
                        redraw=TRUE) {
  if (any(grep, global, allDevices))
    stop("grep, global, and allDevices not yet implemented")
  if (is.character(gPath))
    gPath <- gPathDirect(gPath)
  if (!inherits(gPath, "gPath"))
    stop("Invalid path")
  if (depth(gPath) == 1) {
    removeGrobFromDL(gPath, warn, strict, redraw)
  } else {
    gTree <- grid.get(gPath$path, strict)
    if (!inherits(gTree, "gTree"))
      stop("It is only valid to remove a child from a gTree")
    # Handle case where child name already exists (so will be overwritten)
    if (old.pos <- match(gPath$name, gTree$childrenOrder, nomatch=0)) {
      gTree$childrenOrder <- gTree$childrenOrder[-old.pos]
      gTree$children[[gPath$name]] <- NULL
    } else {
      if (warn)
        stop(paste("gPath (", gPath, ") not found"))
    }
    grid.set(gPath$path, gTree, strict, redraw)
  }
}

# Remove a child from a (child of ...) gTree
removeGrob <- function(gTree, gPath, strict=FALSE,
                       grep=FALSE, global=FALSE, warn=TRUE) {
  if (grep || global)
    stop("grep and global options not yet implemented")
  if (!inherits(gTree, "gTree"))
    stop("It is only valid to remove a child from a gTree")
  if (is.character(gPath))
    gPath <- gPathDirect(gPath)
  if (!inherits(gPath, "gPath"))
    stop("Invalid path")
  if (depth(gPath) == 1) {
    if (strict) {
      if (old.pos <- match(gPath$name, gTree$childrenOrder, nomatch=0)) {
        gTree$childrenOrder <- gTree$childrenOrder[-old.pos]
        gTree$children[[gPath$name]] <- NULL
      } else {
        if (warn)
          stop(paste("gPath (", gPath, ") not found"))
      }
    } else {
      result <- removeGrobfromGPath(gTree, gPath)
      if (is.null(result)) {
        if (warn)
          stop(paste("gPath (", gPath, ") not found"))
      } else {
        gTree <- result
      }
    }
  } else {
    orig.gTree <- gTree
    gTree <- getGrob(gTree, gPath$path, strict)
    if (!inherits(gTree, "gTree"))
      stop("It is only valid to remove a child from a gTree")
    if (old.pos <- match(gPath$name, gTree$childrenOrder, nomatch=0)) {
      gTree$childrenOrder <- gTree$childrenOrder[-old.pos]
      gTree$children[[gPath$name]] <- NULL
      gTree <- setGrob(orig.gTree, gPath$path, gTree, strict)
    } else {
      if (warn)
        stop(paste("gPath (", gPath, ") not found"))
      gTree <- orig.gTree
    }      
  }
  gTree
}

# Edit a grob on the display list
grid.edit <- function(gPath, ..., strict=FALSE,
                      grep=FALSE, global=FALSE, allDevices=FALSE,
                      redraw=TRUE) {
  if (any(grep, global, allDevices))
    stop("grep, global, and allDevices not yet implemented")
  if (is.character(gPath))
    gPath <- gPathDirect(gPath)
  if (!inherits(gPath, "gPath"))
    stop("Invalid path")
  specs <- list(...)
  grob <- getDLfromGPath(gPath, strict)
  if (is.null(grob)) {
    stop(paste("gPath (", gPath, ") not found"))
  } else {
    result <- setDLfromGPath(gPath, editThisGrob(grob, specs), strict)
    # Get the current DL index
    dl.index <- grid.Call("L_getDLindex")
    # Destructively modify the DL elt
    grid.Call("L_setDLindex", as.integer(result$index))
    grid.Call("L_setDLelt", result$grob)
    # Reset the DL index
    grid.Call("L_setDLindex", as.integer(dl.index))
    if (redraw)
      draw.all()
  }
}

# Edit a (child of a ...) grob
editGrob <- function(grob, gPath=NULL, ..., strict=FALSE,
                     grep=FALSE, global=FALSE) {
  if (grep || global)
    stop("grep and global options not yet implemented")
  specs <- list(...)
  if (is.null(gPath)) {
    editThisGrob(grob, specs)
  } else {
    if (is.character(gPath))
      gPath <- gPathDirect(gPath)
    # Only makes sense to specify a gPath for a gTree
    if (!inherits(grob, "gTree"))
      stop("It is only valid to edit a child of a gTree")
    setGrob(grob, gPath,
            editThisGrob(getGTree(grob, NULL, gPath, strict), specs))
  }
}

#########
# Generic "hook" to allow customised action on edit
#########
editDetails <- function(x, specs) {
  UseMethod("editDetails")
}

editDetails.default <- function(x, specs) {
  # Do nothing BUT return object being edited
  x
}

editDetails.gTree <- function(x, specs) {
  # Disallow editing children or childrenOrder slots directly
  if (any(match(specs, c("children", "childrenOrder"), nomatch=FALSE)))
    stop("It is invalid to directly edit the children or childrenOrder slot")
  x
}

#########
# Helper functions for getting/adding/removing/editing grobs
#########

# A gPath may specify the child of a gTree
# (or the child of a child of a gTree, or ...)
getGrobFromGPath <- function(grob, pathsofar, gPath, strict) {
  UseMethod("getGrobFromGPath")
}

# If it's not a grob then fail
# Handles case when traversing DL
getGrobFromGPath.default <- function(grob, pathsofar, gPath, strict) {
  NULL
}

getGrobFromGPath.grob <- function(grob, pathsofar, gPath, strict) {
  if (depth(gPath) > 1)
    NULL
  else {
    if (match(gPath$name, grob$name, nomatch=0))
      grob
    else
      NULL
  }
}

partialPathMatch <- function(pathsofar, path, strict=FALSE) {
  if (strict) {
    length(grep(paste("^", pathsofar, sep=""), gPath$path)) > 0
  } else {
    # If we're not doing strict matching then anything from a full
    # path match to absolutely no match means a partial match
    # (i.e., keep looking)
    TRUE
  }
}

getGTree <- function(gTree, pathsofar, gPath, strict) {
  # Try to find pathsofar at start of gPath
  # NOTE: may be called directly with pathsofar=NULL
  if (is.null(pathsofar) ||
      (!strict && depth(gPath) == 1) ||
      partialPathMatch(pathsofar, gPath$path, strict)) {
    found <- FALSE
    index <- 1
    # Search children for match
    while (index <= length(gTree$childrenOrder) && !found) {
      childName <- gTree$childrenOrder[index]
      child <- gTree$children[[childName]]
      # Special case when strict is FALSE and depth(gPath) is 1
      # Just check for gPath$name amongst children and recurse if no match
      if (!strict && depth(gPath) == 1) {
        if (match(gPath$name, childName, nomatch=0)) {
          grob <- child
          found <- TRUE
        } else {
          if (is.null(pathsofar))
            newpathsofar <- child$name
          else
            newpathsofar <- paste(pathsofar, .grid.pathSep, childName, sep="")
          if (!is.null(newChild <- getGrobFromGPath(child, newpathsofar,
                                                    gPath, strict))) {
            grob <- newChild
            found <- TRUE
          }
        }
      } else {
        # Only check for match with child if have full match with pathsofar
        # If it's a complete match, look for gPath$name amongst child
        # NOTE: may be called directly with pathsofar=NULL
        if (is.null(pathsofar))
          fullmatch <- depth(gPath) == 1
        else
          if (strict)
            fullmatch <- match(pathsofar, gPath$path, nomatch=FALSE)
          else
            fullmatch <- 
              length(grep(paste(gPath$path, "$", sep=""), pathsofar)) > 0
        if (fullmatch) {
          if (match(gPath$name, childName, nomatch=0)) {
            grob <- child
            found <- TRUE
          }
        # Otherwise recurse down child
        } else {
          # NOTE: may be called directly with pathsofar=NULL
          if (is.null(pathsofar))
            newpathsofar <- child$name
          else
            newpathsofar <- paste(pathsofar, .grid.pathSep, childName, sep="")
          if (!is.null(newChild <- getGrobFromGPath(child, newpathsofar,
                                                    gPath, strict))) {
            grob <- newChild
            found <- TRUE
          }
        }
      }
      index <- index + 1
    }
    if (found)
      grob
    else
      NULL
  } else {
    NULL
  }
}

getGrobFromGPath.gTree <- function(grob, pathsofar, gPath, strict) {
  if (depth(gPath) == 1) {
    if (match(gPath$name, grob$name, nomatch=FALSE))
      grob
    else
      if (strict)
        NULL
      else
        getGTree(grob,
                 if (is.null(pathsofar)) grob$name else pathsofar,
                 gPath, strict)
  } else {
    getGTree(grob,
             if (is.null(pathsofar)) grob$name else pathsofar,
             gPath, strict)
  }
}

getDLfromGPath <- function(gPath, strict) {
  dl.index <- grid.Call("L_getDLindex")
  result <- NULL
  index <- 1
  while (index < dl.index && is.null(result)) {
    result <- getGrobFromGPath(grid.Call("L_getDLelt",
                                         as.integer(index)),
                               NULL, gPath, strict)
    index <- index + 1
  }
  result
}

# A gPath may specify the child of a gTree
# (or the child of a child of a gTree, or ...)
setGrobFromGPath <- function(grob, pathsofar, gPath, newGrob, strict) {
  UseMethod("setGrobFromGPath")
}

# Ignore DL elements which are not grobs
setGrobFromGPath.default <- function(grob, pathsofar, gPath, newGrob, strict) {
  NULL
}

setGrobFromGPath.grob <- function(grob, pathsofar, gPath, newGrob, strict) {
  if (depth(gPath) > 1)
    NULL
  else {
    if (match(gPath$name, grob$name, nomatch=FALSE))
      if (match(gPath$name, newGrob$name, nomatch=FALSE))
        newGrob
      else
        NULL
    else
      NULL
  }
}

# Try to match gPath in gTree children
# Return NULL if cant' find match
# Return modified gTree if can find match
setGTree <- function(gTree, pathsofar, gPath, newGrob, strict) {
  # Try to find pathsofar at start of gPath
  # NOTE: may be called directly with pathsofar=NULL
  if (is.null(pathsofar) ||
      (!strict && depth(gPath) == 1) ||
      partialPathMatch(pathsofar, gPath$path, strict)) {
    found <- FALSE
    index <- 1
    # Search children for match
    while (index <= length(gTree$childrenOrder) && !found) {
      childName <- gTree$childrenOrder[index]
      child <- gTree$children[[childName]]
      # Special case when strict is FALSE and depth(gPath) is 1
      # Just check for gPath$name amongst children and recurse if no match
      if (!strict && depth(gPath) == 1) {
        if (match(gPath$name, childName, nomatch=FALSE)) {
          if (match(gPath$name, newGrob$name, nomatch=FALSE)) {
            gTree$children[[newGrob$name]] <- newGrob
            found <- TRUE
          } else {
            stop("The new grob must have the same name as the old grob")
          }
        } else {
          if (is.null(pathsofar))
            newpathsofar <- child$name
          else
            newpathsofar <- paste(pathsofar, .grid.pathSep, childName, sep="")
          if (!is.null(newChild <- setGrobFromGPath(child, newpathsofar,
                                                    gPath, newGrob, strict))) {
            gTree$children[[childName]] <- newChild
            found <- TRUE
          }
        }
      } else {
        # Only check for match with child if have full match with pathsofar
        # If it's a complete match, look for gPath$name amongst child
        # NOTE: may be called directly with pathsofar=NULL
        if (is.null(pathsofar))
          fullmatch <- depth(gPath) == 1
        else
          if (strict)
            fullmatch <- match(pathsofar, gPath$path, nomatch=FALSE)
          else
            fullmatch <- 
              length(grep(paste(gPath$path, "$", sep=""), pathsofar)) > 0
        if (fullmatch) {
          if (match(gPath$name, childName, nomatch=FALSE)) {
            if (match(gPath$name, newGrob$name, nomatch=FALSE)) {
              gTree$children[[newGrob$name]] <- newGrob
              found <- TRUE
            }
          }
        # Otherwise recurse down child
        } else {
          # NOTE: may be called directly with pathsofar=NULL
          if (is.null(pathsofar))
            newpathsofar <- child$name
          else
            newpathsofar <- paste(pathsofar, .grid.pathSep, childName, sep="")
          if (!is.null(newChild <- setGrobFromGPath(child, newpathsofar,
                                                    gPath, newGrob, strict))) {
            gTree$children[[childName]] <- newChild
            found <- TRUE
          }
        }
      }
      index <- index + 1
    }
    if (found)
      gTree
    else
      NULL
  } else {
    NULL
  }
}

setGrobFromGPath.gTree <- function(grob, pathsofar, gPath, newGrob, strict) {
  if (depth(gPath) == 1) {
    if (match(gPath$name, grob$name, nomatch=FALSE))
      if (match(gPath$name, newGrob$name, nomatch=FALSE))
        newGrob
      else
        stop("The new grob must have the same name as the old grob")
    else
      if (strict)
        NULL
      else
        setGTree(grob,
                 if (is.null(pathsofar)) grob$name else pathsofar,
                 gPath, newGrob, strict)
  } else {
    setGTree(grob,
             # Initialise pathsofar if first time through
             if (is.null(pathsofar)) grob$name else pathsofar,
             gPath, newGrob, strict)
  }
}

setDLfromGPath <- function(gPath, newGrob, strict) {
  dl.index <- grid.Call("L_getDLindex")
  index <- 1
  result <- list(index=0, grob=NULL)
  while (index < dl.index &&
         result$index == 0) {
    result$grob <- setGrobFromGPath(grid.Call("L_getDLelt",
                                              as.integer(index)),
                                    NULL, gPath, newGrob, strict)
    if (!is.null(result$grob))
      result$index <- index
    index <- index + 1
  }
  result
}

editThisGrob <- function(grob, specs) {
  for (i in names(specs))
    if (nchar(i) > 0) 
      # If there is no slot with the argument name, just ignore that argument
      if (match(i, names(grob), nomatch=0)) 
        # Handle NULL as special case
        if (is.null(specs[[i]]))
          grob[i] <- eval(substitute(list(i=NULL)))
        else
          grob[[i]] <- specs[[i]]
      else
        warning(paste("Slot", i, "not found"))
  grob <- editDetails(grob, specs)
  validGrob(grob)
}

# Only called with grob is a gTree, gPath of depth 1, and strict = FALSE
removeGrobfromGPath <- function(grob, gPath) {
  UseMethod("removeGrobfromGPath")
}

removeGrobfromGPath.grob <- function(grob, gPath) {
  NULL
}
  
removeGrobfromGPath.gTree <- function(grob, gPath) {
  gTree <- NULL
  if (old.pos <- match(gPath$name, grob$childrenOrder, nomatch=0)) {
    grob$childrenOrder <- grob$childrenOrder[-old.pos]
    grob$children[[gPath$name]] <- NULL
    gTree <- grob
  } else {
    found <- FALSE
    index <- 1
    while (index <= length(grob$childrenOrder) && !found) {
      childName <- grob$childrenOrder[index]
      child <- grob$children[[childName]]
      gTree <- removeGrobfromGPath(child, gPath)
      if (!is.null(gTree))
        found <- TRUE
      index <- index + 1
    }
  }
  gTree
}

# Only called with gPath of depth 1 
removeGrobFromDL <- function(gPath, warn, strict, redraw) {
  # Look first for top-level match (force strict=TRUE)
  dl.index <- grid.Call("L_getDLindex")
  result <- NULL
  index <- 1
  while (index < dl.index && is.null(result)) {
    result <- getGrobFromGPath(grid.Call("L_getDLelt",
                                         as.integer(index)),
                               NULL, gPath, strict=TRUE)
    index <- index + 1
  }
  # If we have succeeded then we NULL the DL elt
  if (!is.null(result)) {
    grobIndex <- index - 1
    # Get the current DL index
    dl.index <- grid.Call("L_getDLindex")
    # Destructively modify the DL elt
    grid.Call("L_setDLindex", as.integer(grobIndex))
    grid.Call("L_setDLelt", NULL)
    # Reset the DL index
    grid.Call("L_setDLindex", as.integer(dl.index))
    if (redraw)
      draw.all()
  } else {
    # If strict=TRUE then we have failed 
    if (strict) {
      if (warn)
        stop(paste("gPath (", gPath, ") not found on display list", sep=""))
      else
        return()
    # If strict=FALSE we can try to look further down the DL
    } else {
      dl.index <- grid.Call("L_getDLindex")
      result <- NULL
      index <- 1
      while (index < dl.index && is.null(result)) {
        result <- getGrobFromGPath(grid.Call("L_getDLelt",
                                             as.integer(index)),
                                   NULL, gPath, strict=FALSE)
        if (!is.null(result))
          result <- removeGrob(grid.Call("L_getDLelt",
                                         as.integer(index)),
                               gPath)
        index <- index + 1
      }
      # If we found nothing, we have failed
      if (is.null(result))
        if (warn)
          stop(paste("gPath (", gPath, ") not found on display list", sep=""))
        else
          return()
      else {
        grobIndex <- index - 1
        # Get the current DL index
        dl.index <- grid.Call("L_getDLindex")
        # Destructively modify the DL elt
        grid.Call("L_setDLindex", as.integer(grobIndex))
        grid.Call("L_setDLelt", result)
        # Reset the DL index
        grid.Call("L_setDLindex", as.integer(dl.index))
        if (redraw)
          draw.all()
      } 
    }
  }
}

################
# Finding a grob from a grob name
################
findgrob <- function(x, name) {
  UseMethod("findgrob")
}

findgrob.default <- function(x, name) {
  NULL
}

findgrob.grob <- function(x, name) {
  if (match(name, x$name, nomatch=FALSE))
    x
  else
    NULL
}

findGrobinDL <- function(name) {
  dl.index <- grid.Call("L_getDLindex")
  result <- NULL
  index <- 1
  while (index < dl.index && is.null(result)) {
    result <- findgrob(grid.Call("L_getDLelt", as.integer(index)), name)
    index <- index + 1
  }
  if (is.null(result))
    stop("Grob ", name, " not found")
  result
}

findGrobinChildren <- function(name, children) {
  nc <- length(children)
  result <- NULL
  index <- 1
  while (index <= nc && is.null(result)) {
    result <- findgrob(children[[index]], name)
    index <- index + 1
  }
  if (is.null(result))
    stop("Grob ", name, " not found")
  result
}

################
# grid.draw 
################
# Use generic function "draw" rather than generic function "print"
# because want graphics functions to produce graphics output
# without having to be evaluated at the command-line AND without having
# to necessarily produce a single graphical object as the return value
# (i.e., so that simple procedural code can be written just for its
# side-effects).
# For example, so that the following code will draw
# a rectangle AND a line:
#   temp <- function() { grid.lines(); grid.rect() }
#   temp()
grid.draw <- function(x, recording=TRUE) {
  UseMethod("grid.draw")
}

grid.draw.default <- function(x, recording) {
  # Allow for "holes" in the DL if a grob has been removed
  if (!is.null(x))
    stop("Invalid element in the display list")
}

grid.draw.viewport <- function(x, recording) {
  pushViewport(x, recording=FALSE)
}

grid.draw.vpPath <- function(x, recording) {
  # Assumes strict=FALSE, BUT in order to get onto
  # display list it must have worked => strict same as non-strict
  downViewport(x, recording=FALSE)
}

grid.draw.pop <- function(x, recording) {
  popViewport(x, recording=FALSE)
}

grid.draw.up <- function(x, recording) {
  upViewport(x, recording=FALSE)
}

pushgrobvp <- function(vp) {
  UseMethod("pushgrobvp")
}

pushgrobvp.viewport <- function(vp) {
  pushViewport(vp, recording=FALSE)
}

pushgrobvp.vpPath <- function(vp) {
  downViewport(vp, strict=TRUE, recording=FALSE)
}

popgrobvp <- function(vp) {
  UseMethod("popgrobvp")
}

popgrobvp.viewport <- function(vp) {
  # NOTE that the grob's vp may be a vpStack/List/Tree
  popViewport(depth(vp), recording=FALSE)
}

popgrobvp.vpPath <- function(vp) {
  upViewport(depth(vp), recording=FALSE)
}

preDraw <- function(x) {
  UseMethod("preDraw")
}

pushvpgp <- function(x) {
  if (!is.null(x$vp))
    pushgrobvp(x$vp)
  if (!is.null(x$gp)) {
    set.gpar(x$gp)
  }
}

preDraw.grob <- function(x) {
  # automatically push/pop the viewport and set/unset the gpar
  pushvpgp(x)
  preDrawDetails(x)
}

preDraw.gTree <- function(x) {
  # Make this gTree the "current grob" for evaluation of
  # grobwidth/height units via gPath
  # Do this as a .Call.graphics to get it onto the base display list
  grid.Call.graphics("L_setCurrentGrob", x)
  # automatically push/pop the viewport and set/unset the gpar
  pushvpgp(x)
  # Push then "up" childrenvp
  if (!is.null(x$childrenvp)) {
    pushViewport(x$childrenvp, recording=FALSE)
    upViewport(depth(x$childrenvp), recording=FALSE)
  }  
  preDrawDetails(x)
}

postDraw <- function(x) {
  UseMethod("postDraw")
}

postDraw.grob <- function(x) {
  postDrawDetails(x)
  if (!is.null(x$vp))
    popgrobvp(x$vp)
}

# FIXME:  should be on.exit(set.gpar(tempgpar)) ??
grid.draw.grob <- function(x, recording=TRUE) {
  tempgpar <- get.gpar()
  preDraw(x)
  # Do any class-specific drawing
  temp <- drawDetails(x, recording)
  if (is.grob(temp))
    x <- temp
  postDraw(x)
  set.gpar(tempgpar)
  if (recording)
    record(x)
}

drawChildren <- function(x) {
  lapply(x$children, grid.draw, recording=FALSE)
}

# FIXME:  should be on.exit(set.gpar(tempgpar)) ??
grid.draw.gTree <- function(x, recording=TRUE) {
  tempgrob <- grid.Call("L_getCurrentGrob")
  tempgpar <- get.gpar()
  preDraw(x)
  # Do any class-specific drawing
  drawDetails(x, recording)
  # Draw all children
  drawChildren(x)
  postDraw(x)
  set.gpar(tempgpar)
  # Do this as a .Call.graphics to get it onto the base display list
  grid.Call.graphics("L_setCurrentGrob", tempgrob)
  if (recording)
    record(x)
}
               
draw.all <- function() {
  grid.newpage(recording=FALSE)
  dl.index <- grid.Call("L_getDLindex")
  if (dl.index > 1)
    # Start at 2 because first element is viewport[ROOT]
    for (i in 2:dl.index) {
      grid.draw(grid.Call("L_getDLelt", as.integer(i - 1)),
                recording=FALSE)
    }
}

draw.details <- function(x, recording) {
  .Deprecated("drawDetails")
  UseMethod("drawDetails")
}

preDrawDetails <- function(x) {
  UseMethod("preDrawDetails")
}

preDrawDetails.grob <- function(x) {
}

postDrawDetails <- function(x) {
  UseMethod("postDrawDetails")
}

postDrawDetails.grob <- function(x) {
}

drawDetails <- function(x, recording) {
  UseMethod("drawDetails")
}

drawDetails.grob <- function(x, recording) {
}

grid.copy <- function(grob) {
  warning("This function is redundant and will disappear in future versions.")
  grob
}

######################################
# Example applications of grid    #
######################################

grid.strip <- function(label="whatever", range.full=c(0, 1),
                   range.thumb=c(.3, .6),
                   fill="#FFBF00", thumb="#FF8000",
                   vp=NULL) {
  diff.full <- diff(range.full)
  diff.thumb <- diff(range.thumb)
  if (!is.null(vp))
    pushViewport(vp)
  grid.rect(gp=gpar(col=NULL, fill=fill))
  grid.rect((range.thumb[1] - range.full[1])/diff.full, 0,
            diff.thumb/diff.full, 1,
            just=c("left", "bottom"),
            gp=gpar(col=NULL, fill=thumb))
  grid.text(as.character(label))
  if (!is.null(vp))
    popViewport()
}

grid.panel <- function(x = stats::runif(10), y = stats::runif(10),
                   zrange = c(0, 1), zbin = stats::runif(2),
                   xscale = range(x)+c(-1,1)*.05*diff(range(x)),
                   yscale = range(y)+c(-1,1)*.05*diff(range(y)),
                   axis.left = TRUE, axis.left.label = TRUE,
                   axis.right = FALSE, axis.right.label = TRUE,
                   axis.bottom = TRUE, axis.bottom.label = TRUE,
                   axis.top = FALSE, axis.top.label = TRUE,
                   vp=NULL) {
  if (!is.null(vp))
    pushViewport(vp)
  temp.vp <- viewport(layout=grid.layout(2, 1,
                         heights=unit(c(1, 1), c("lines", "null"))))
  pushViewport(temp.vp)
  strip.vp <- viewport(layout.pos.row=1, layout.pos.col=1,
                        xscale=xscale)
  pushViewport(strip.vp)
  grid.strip(range.full=zrange, range.thumb=zbin)
  grid.rect()
  if (axis.top)
    grid.xaxis(main=FALSE, label=axis.top.label)
  popViewport()
  plot.vp <- viewport(layout.pos.row=2, layout.pos.col=1,
                       xscale=xscale, yscale=yscale)
  pushViewport(plot.vp)
  grid.grill()
  grid.points(x, y, gp=gpar(col="blue"))
  grid.rect()
  if (axis.left)
    grid.yaxis(label=axis.left.label)
  if (axis.right)
    grid.yaxis(main=FALSE, label=axis.right.label)
  if (axis.bottom)
    grid.xaxis(label=axis.bottom.label)
  popViewport(2)
  if (!is.null(vp))
    popViewport()
  invisible(list(strip.vp = strip.vp, plot.vp = plot.vp))
}

grid.multipanel <- function(x=stats::runif(90), y=stats::runif(90),
                            z=stats::runif(90),
                            nrow=2, ncol=5, nplots=9,
                            newpage=TRUE, vp=NULL) {
  if (newpage)
    grid.newpage()
  if (!is.null(vp))
    pushViewport(vp)
  temp.vp <- viewport(layout=grid.layout(nrow, ncol))
  pushViewport(temp.vp)
  xscale <- range(x)+c(-1,1)*.05*diff(range(x))
  yscale <- range(y)+c(-1,1)*.05*diff(range(y))
  breaks <- seq(min(z), max(z), length=nplots + 1)
  for (i in 1:nplots) {
    col <- (i - 1) %% ncol + 1
    row <- (i - 1) %/% ncol + 1
    panel.vp <- viewport(layout.pos.row=row,
                         layout.pos.col=col)
    panelx <- x[z >= breaks[i] & z <= breaks[i+1]]
    panely <- y[z >= breaks[i] & z <= breaks[i+1]]
    grid.panel(panelx, panely, range(z), c(breaks[i], breaks[i+1]),
           xscale, yscale,
           axis.left=(col==1), axis.left.label=is.odd(row),
           axis.right=(col==ncol || i==nplots),
           axis.right.label=is.even(row),
           axis.bottom=(row==nrow), axis.bottom.label=is.odd(col),
           axis.top=(row==1), axis.top.label=is.even(col),
           vp=panel.vp)
  }
  grid.text("Compression Ratio", unit(.5, "npc"), unit(-4, "lines"),
        gp=gpar(fontsize=20),
        just="center", rot=0)
  grid.text("NOx (micrograms/J)", unit(-4, "lines"), unit(.5, "npc"),
        gp=gpar(fontsize=20),
        just="centre", rot=90)
  popViewport()
  if (!is.null(vp))
    popViewport()
}

grid.show.layout <- function(l, newpage=TRUE,
                         cell.border="blue", cell.fill="light blue",
                         cell.label=TRUE, vp=NULL) {
  if (!is.layout(l))
    stop("l must be a layout")
  if (newpage)
    grid.newpage()
  if (!is.null(vp))
    pushViewport(vp)
  grid.rect(gp=gpar(col=NULL, fill="light grey"))
  vp.mid <- viewport(0.5, 0.5, 0.8, 0.8, layout=l)
  pushViewport(vp.mid)
  grid.rect(gp=gpar(fill="white"))
  gp.red <- gpar(col="red")
  for (i in 1:l$nrow)
    for (j in 1:l$ncol) {
      vp.inner <- viewport(layout.pos.row=i, layout.pos.col=j)
      pushViewport(vp.inner)
      grid.rect(gp=gpar(col=cell.border, fill=cell.fill))
      if (cell.label)
        grid.text(paste("(", i, ", ", j, ")", sep=""), gp=gpar(col="blue"))
      if (j==1)
        grid.text(as.character(l$heights[i]), gp=gp.red,
              just=c("right", "centre"),
              x=unit(-.05, "inches"), y=unit(.5, "npc"), rot=0)
      if (i==l$nrow)
        grid.text(as.character(l$widths[j]), gp=gp.red,
              just=c("centre", "top"),
              x=unit(.5, "npc"), y=unit(-.05, "inches"), rot=0)
      if (j==l$ncol)
        grid.text(as.character(l$heights[i]), gp=gp.red,
              just=c("left", "centre"),
              x=unit(1, "npc") + unit(.05, "inches"), y=unit(.5, "npc"),
              rot=0)
      if (i==1)
        grid.text(as.character(l$widths[j]), gp=gp.red,
              just=c("centre", "bottom"),
              x=unit(.5, "npc"), y=unit(1, "npc") + unit(.05, "inches"),
              rot=0)
      popViewport()
    }
  popViewport()
  if (!is.null(vp))
    popViewport()
  # return the viewport used to represent the parent viewport
  invisible(vp.mid)
}

grid.show.viewport <- function(v, parent.layout=NULL, newpage=TRUE, vp=NULL) {
  # if the viewport has a non-NULL layout.pos.row or layout.pos.col
  # AND the viewport has a parent AND the parent has a layout
  # represent the location of the viewport in the parent's layout ...
  if ((!is.null(v$layout.pos.row) || !is.null(v$layout.pos.col)) &&
      !is.null(parent.layout)) {
    if (!is.null(vp))
      pushViewport(vp)
    vp.mid <- grid.show.layout(parent.layout,
                           cell.border="grey", cell.fill="white",
                           cell.label=FALSE, newpage=newpage)
    pushViewport(vp.mid)
    pushViewport(v)
    gp.red <- gpar(col="red")
    grid.rect(gp=gpar(col="blue", fill="light blue"))
    at <- grid.pretty(v$xscale)
    grid.xaxis(at=c(min(at), max(at)), gp=gp.red)
    at <- grid.pretty(v$yscale)
    grid.yaxis(at=c(min(at), max(at)), gp=gp.red)
    popViewport(2)
    if (!is.null(vp))
      popViewport()
  } else {
    if (newpage)
      grid.newpage()
    if (!is.null(vp))
      pushViewport(vp)
    grid.rect(gp=gpar(col=NULL, fill="light grey"))
    # generate a viewport within the "top" viewport (vp) to represent the
    # parent viewport of the viewport we are "show"ing (v).
    # This is so that annotations at the edges of the
    # parent viewport will be at least partially visible
    vp.mid <- viewport(0.5, 0.5, 0.8, 0.8)
    pushViewport(vp.mid)
    grid.rect(gp=gpar(fill="white"))
    x <- v$x
    y <- v$y
    w <- v$width
    h <- v$height
    pushViewport(v)
    grid.rect(gp=gpar(col="blue", fill="light blue"))
    # represent the "native" scale
    gp.red <- gpar(col="red")
    at <- grid.pretty(v$xscale)
    grid.xaxis(at=c(min(at), max(at)), gp=gp.red)
    at <- grid.pretty(v$yscale)
    grid.yaxis(at=c(min(at), max(at)), gp=gp.red)
    grid.text(as.character(w), gp=gp.red,
          just=c("centre", "bottom"),
          x=unit(.5, "npc"), y=unit(1, "npc") + unit(.05, "inches"))
    grid.text(as.character(h), gp=gp.red,
          just=c("left", "centre"),
          x=unit(1, "npc") + unit(.05, "inches"), y=unit(.5, "npc"))
    popViewport()
    # annotate the location and dimensions of the viewport
    grid.lines(unit.c(x, x), unit.c(unit(0, "npc"), y),
           gp=gpar(col="red", lty="dashed"))
    grid.lines(unit.c(unit(0, "npc"), x), unit.c(y, y),
           gp=gpar(col="red", lty="dashed"))
    grid.text(as.character(x), gp=gp.red,
          just=c("centre", "top"),
          x=x, y=unit(-.05, "inches"))
    grid.text(as.character(y), gp=gp.red,
          just=c("right", "centre"),
          x=unit(-.05, "inches"), y=y)
    popViewport()
    if (!is.null(vp))
      popViewport()
  }
}

# old grid.legend <-
function(pch, labels, frame=TRUE,
                        hgap=unit(0.5, "lines"), vgap=unit(0.5, "lines"),
                        default.units="lines",
                        gp=gpar(), draw=TRUE,
                        vp=NULL) {
  # Type checking on arguments
  labels <- as.character(labels)
  nkeys <- length(labels)
  if (length(pch) != nkeys)
    stop("pch and labels not the same length")
  if (!is.unit(hgap))
    hgap <- unit(hgap, default.units)
  if (length(hgap) != 1)
    stop("hgap must be single unit")
  if (!is.unit(vgap))
    vgap <- unit(vgap, default.units)
  if (length(vgap) != 1)
    stop("vgap must be single unit")
  gf <- grid.frame(layout=grid.layout(nkeys, 2), vp=vp, gp=gp, draw=FALSE)
  for (i in 1:nkeys) {
    if (i==1) {
      symbol.border <- unit.c(vgap, hgap, vgap, hgap)
      text.border <- unit.c(vgap, unit(0, "npc"), vgap, hgap)
    }
    else {
      symbol.border <- unit.c(vgap, hgap, unit(0, "npc"), hgap)
      text.border <- unit.c(vgap, unit(0, "npc"), unit(0, "npc"), hgap)
    }
    grid.pack(gf, grid.points(.5, .5, pch=pch[i], draw=FALSE),
              col=1, row=i, border=symbol.border,
              width=unit(1, "lines"), height=unit(1, "lines"),
              force.width=TRUE, draw=FALSE)
    grid.pack(gf, grid.text(labels[i], x=0, y=.5, just=c("left", "centre"),
                            draw=FALSE),
              col=2, row=i, border=text.border, draw=FALSE)
  }
  if (draw)
    grid.draw(gf)
  gf
}

grid.legend <-
function(pch, labels, frame=TRUE,
                        hgap=unit(0.5, "lines"), vgap=unit(0.5, "lines"),
                        default.units="lines",
                        gp=gpar(), draw=TRUE,
                        vp=NULL) {
  # Type checking on arguments
  labels <- as.character(labels)
  nkeys <- length(labels)
  if (length(pch) != nkeys)
    stop("pch and labels not the same length")
  if (!is.unit(hgap))
    hgap <- unit(hgap, default.units)
  if (length(hgap) != 1)
    stop("hgap must be single unit")
  if (!is.unit(vgap))
    vgap <- unit(vgap, default.units)
  if (length(vgap) != 1)
    stop("vgap must be single unit")
  legend.layout <-
    grid.layout(nkeys, 3,
                widths=unit.c(unit(2, "lines"),
                  max(unit(rep(1, nkeys), "strwidth", as.list(labels))),
                  hgap),
                heights=unit.pmax(unit(2, "lines"),
                  vgap + unit(rep(1, nkeys), "strheight", as.list(labels))))
  fg <- frameGrob(layout=legend.layout, vp=vp, gp=gp)
  for (i in 1:nkeys) {
    fg <- placeGrob(fg, pointsGrob(.5, .5, pch=pch[i]), col=1, row=i)
    fg <- placeGrob(fg, textGrob(labels[i], x=0, y=.5,
                                 just=c("left", "centre")),
                    col=2, row=i)
  }
  if (draw)
    grid.draw(fg)
  fg
}

# Just a wrapper for a sample series of grid commands
grid.plot.and.legend <- function() {
  grid.newpage()
  top.vp <- viewport(w=0.8, h=0.8)
  pushViewport(top.vp)
  x <- stats::runif(10)
  y1 <- stats::runif(10)
  y2 <- stats::runif(10)
  pch <- 1:3
  labels <- c("Girls", "Boys", "Other")
  lf <- frameGrob()
  plot <- gTree(children=gList(rectGrob(),
                  pointsGrob(x, y1, pch=1),
                  pointsGrob(x, y2, pch=2),
                  xaxisGrob(),
                  yaxisGrob()))
  lf <- packGrob(lf, plot)
  lf <- packGrob(lf, grid.legend(pch, labels, draw=FALSE),
                 height=unit(1,"null"), side="right")
  grid.draw(lf)
}


grid.locator <- function(unit="native") {
  location <- c(grid.Call("L_locator"), 1)
  transform <- solve(current.transform())
  location <- (location %*% transform)
  # The inverse viewport transform is from device coordinates into
  # inches relative to the current viewport
  location <- unit(location/location[3], "inches")
  list(x=convertX(location[1], unit),
       y=convertY(location[2], unit))
}

# NOTE: the order of the strings in these conversion functions must
# match the order of the enums in ../src/lattice.h
# NOTE: the result of match() is an integer, but subtracting 1 converts
# to real => have to convert back to integer for passing to C code

# If the user specifies two values, the first is horizontal
# justification and the second is vertical

# If the user specifies only one value, use the following
# conversion table to give a second default value
#
# bottom  -->  centre, bottom
# left    -->  left,   centre
# right   -->  right,  centre
# top     -->  centre, top
# centre  -->  centre, centre

 valid.just <- function(just, n=2) {
   if (length(just) < n)
     just <- rep(just, length.out=n)
   just <- as.integer(match(just, c("left", "right", "bottom", "top",
                                    "centre", "center")) - 1)
   if (any(is.na(just)))
     stop("Invalid justification")
   just
 }

valid.just <- function(just) {
  if (length(just) == 1) {
    # single value may be any valid just
    just <- as.integer(match(just[1], c("left", "right", "bottom", "top",
                                           "centre", "center")) - 1)
    if (any(is.na(just)))
      stop("Invalid justification")
  } else if (length(just) > 1) {
    # first value must be one of "left", "right", "centre", or "center"
    just[1] <- as.integer(match(just[1], c("left", "right", "bottom", "top",
                                           "centre", "center")) - 1)
    if (!(just[1] %in% c(0, 1, 4, 5)))
      stop("Invalid horizontal justification")
    # second value must be one of "bottom", "top", "centre", or "center"
    just[2] <- as.integer(match(just[2], c("left", "right", "bottom", "top",
                                           "centre", "center")) - 1)
    if (!(just[2] %in% c(2, 3, 4, 5)))
      stop("Invalid vertical justification")
  }
  # Extend to length 2 if necessary
  if (length(just) < 2) {
    if (length(just) == 0)
      just <- c(4, 4)
    else
      just <- switch (just[1] + 1,
                      c(0, 4), # left
                      c(1, 4), # right
                      c(4, 2), # bottom
                      c(4, 3), # top
                      c(4, 4), # centre
                      c(4, 4)) # center
  }
  as.integer(just)
}


is.layout <- function(l) {
  inherits(l, "layout")
}

# FIXME:  The internal C code now does a lot of recycling of
# unit values, units, and data.  Can some/most/all of the
# recycling stuff below be removed ?
valid.layout <- function(nrow, ncol, widths, heights, respect, just) {
  nrow <- as.integer(nrow)
  ncol <- as.integer(ncol)
  # make sure we're dealing with a unit object
  if (!is.logical(respect)) {
    respect <- as.matrix(respect)
    if (!is.matrix(respect) || any(dim(respect) != c(nrow, ncol))) 
      stop("'respect' must be logical or an 'nrow' by 'ncol' matrix")
    }
  if (is.matrix(respect)) {
    respect.mat <- matrix(as.integer(respect),
                          dim(respect)[1],
                          dim(respect)[2])
    respect <- 2
  }
  else {
    respect.mat <- matrix(as.integer(0), nrow, ncol)
  }
  valid.just <- valid.just(just)
  l <- list(nrow = nrow, ncol = ncol,
            widths = widths, heights = heights,
            respect = respect, valid.respect=as.integer(respect),
            respect.mat = respect.mat,
            just=just, valid.just=valid.just)
  class(l) <- "layout"
  l
}

layout.torture <- function() {
  top.vp <- viewport(y=0, height=unit(1, "npc") - unit(1.5, "lines"),
                     just=c("centre", "bottom"))
  do.label <- function(label) {
    grid.rect(y=1, height=unit(1.5, "lines"),
              just=c("center", "top"))
    grid.text(label,
              y=unit(1, "npc") - unit(1, "lines"),
              gp=gpar(font=2))
  }
  # 1 = all relative widths and heights
  grid.show.layout(grid.layout(3,2), vp=top.vp)
  do.label("All dimensions relative -- no respect")
  # (1) with full respect
  grid.show.layout(grid.layout(3,2, respect=TRUE), vp=top.vp)
  do.label("All dimensions relative -- full respect")
  # (1) with partial respect
  grid.show.layout(grid.layout(3,2,respect=matrix(c(1,0,0,0,0,0), 3, 2, TRUE)),
                   vp=top.vp)
  do.label("All dimensions relative -- only top-left cell respected")
  # (1) with slightly weirder partial respect
  grid.show.layout(grid.layout(3,2,respect=matrix(c(1,0,0,0,0,1), 3, 2, TRUE)),
                   vp=top.vp)
  do.label("All relative -- top-left, bottom-right respected")
  # 2 = combination of absolute and relative widths and heights
  grid.show.layout(grid.layout(2, 3,
                       widths=unit(c(2,4,1), c("null", "cm", "null")),
                       heights=unit(c(6,4), c("cm", "null"))),
                   vp=top.vp)
  do.label("Absolute and relative -- no respect")
  # (2) with full respect
  grid.show.layout(grid.layout(2, 3, 
                       widths=unit(c(2,4,1), c("null", "cm", "null")),
                       heights=unit(c(6,4), c("cm", "null")), respect=TRUE),
                   vp=top.vp)
  do.label("Absolute and relative -- full respect")
  # (2) with partial respect
  grid.show.layout(grid.layout(2, 3, 
                       widths=unit(c(2,4,1), c("null", "cm", "null")),
                       heights=unit(c(6,4), c("cm", "null")),
                       respect=matrix(c(0,0,0,0,0,1), 2, 3, TRUE)),
                   vp=top.vp)
  do.label("Absolute and relative -- bottom-right respected")
}

# Return the region allocated by the layout of the current viewport
layoutRegion <- function(layout.pos.row=1, layout.pos.col=1) {
  region <- grid.Call("L_layoutRegion",
                      # This conversion matches the vailidity check in
                      # valid.viewport()
                      if (is.null(layout.pos.row)) layout.pos.row
                      else as.integer(rep(layout.pos.row, length.out=2)),
                      if (is.null(layout.pos.col)) layout.pos.col
                      else as.integer(rep(layout.pos.col, length.out=2)))
  list(left=unit(region[1], "npc"),
       bottom=unit(region[2], "npc"),
       width=unit(region[3], "npc"),
       height=unit(region[4], "npc"))
}

####################
# Accessors
####################

layout.nrow <- function(lay) {
  lay$nrow
}

layout.ncol <- function(lay) {
  lay$ncol
}

layout.widths <- function(lay) {
  lay$widths
}

layout.heights <- function(lay) {
  lay$heights
}

layout.respect <- function(lay) {
  switch(lay$respect + 1,
         FALSE,
         TRUE,
         lay$respect.mat)
}

####################
# Public constructor function
####################
grid.layout <- function (nrow = 1, ncol = 1,
                         widths = unit(rep(1, ncol), "null"), 
                         heights = unit(rep(1, nrow), "null"),
                         default.units = "null",
                         respect = FALSE,
                         just="centre")
{
  if (!is.unit(widths))
    widths <- unit(widths, default.units)
  if (!is.unit(heights))
    heights <- unit(heights, default.units) 
  valid.layout(nrow, ncol, widths, heights, respect, just)
}

####################
# Utility Functions
####################

valid.origin <- function(origin) {
  origin <- as.integer(match(origin,
                             c("bottom.left", "top.left",
                               "bottom.right", "top.right")) - 1)
  if (any(is.na(origin)))
    stop("Invalid origin")
  origin
}

origin.left <- function(origin) {
  switch (origin,
          bottom.left = TRUE,
          bottom.right = FALSE,
          top.left = TRUE,
          top.right = FALSE)
}

origin.right <- function(origin) {
  switch (origin,
          bottom.left = FALSE,
          bottom.right = TRUE,
          top.left = FALSE,
          top.right = TRUE)
}

origin.bottom <- function(origin) {
  switch (origin,
          bottom.left = TRUE,
          bottom.right = TRUE,
          top.left = FALSE,
          top.right = FALSE)
}

origin.top <- function(origin) {
  switch (origin,
          bottom.left = FALSE,
          bottom.right = FALSE,
          top.left = TRUE,
          top.right = TRUE)
}
  
swap.origin.horizontal <- function(origin) {
  switch (origin,
          bottom.left = "bottom.right",
          bottom.right = "bottom.left",
          top.left = "top.right",
          top.right = "top.left")
}

swap.origin.vertical <- function(origin) {
  switch (origin,
          bottom.left = "top.left",
          bottom.right = "top.right",
          top.left = "bottom.left",
          top.right = "bottom.right")
}

######################################
# move-to and line-to primitives
######################################
validDetails.move.to <- function(x) {
  if (!is.unit(x$x) ||
      !is.unit(x$y))
    stop("x and y must be units")
  # Make sure that x and y are of length 1
  if (unit.length(x$x) > 1 | unit.length(x$y) > 1)
    stop("x and y must have length 1")
  x
}

drawDetails.move.to <- function(x, recording=TRUE) {
  grid.Call.graphics("L_moveTo", x$x, x$y)
}

moveToGrob <- function(x=0, y=0,
                       default.units="npc",
                       name=NULL, vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  grob(x=x, y=y, 
       name=name, vp=vp, cl="move.to")
}

grid.move.to <- function(x=0, y=0,
                         default.units="npc",
                         name=NULL, draw=TRUE, vp=NULL) {
  mtg <- moveToGrob(x=x, y=y, default.units=default.units,
                    name=name, vp=vp)
  if (draw)
    grid.draw(mtg)
  invisible(mtg)
}

validDetails.line.to <- function(x) {
  if (!is.unit(x$x) ||
      !is.unit(x$y))
    stop("x and y must be units")
  # Make sure that x and y are of length 1
  if (unit.length(x$x) > 1 | unit.length(x$y) > 1)
    stop("x and y must have length 1")
  x
}

drawDetails.line.to <- function(x, recording=TRUE) {
  grid.Call.graphics("L_lineTo", x$x, x$y)
}

lineToGrob <- function(x=1, y=1,
                       default.units="npc",
                       name=NULL, gp=gpar(), vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  grob(x=x, y=y, 
       name=name, gp=gp, vp=vp, cl="line.to")
}

grid.line.to <- function(x=1, y=1,
                         default.units="npc",
                         name=NULL, gp=gpar(), draw=TRUE, vp=NULL) {
  ltg <- lineToGrob(x=x, y=y, default.units=default.units,
                    name=name, gp=gp, vp=vp)
  if (draw)
    grid.draw(ltg)
  invisible(ltg)
}

######################################
# LINES primitive
######################################
validDetails.lines <- function(x) {
  if (!is.unit(x$x) ||
      !is.unit(x$y))
    stop("x and y must be units")
  x
}

drawDetails.lines <- function(x, recording=TRUE) {
  grid.Call.graphics("L_lines", x$x, x$y)
}

linesGrob <- function(x=unit(c(0, 1), "npc", units.per.obs),
                      y=unit(c(0, 1), "npc", units.per.obs),
                      default.units="npc", units.per.obs=FALSE,
                      name=NULL, gp=gpar(), vp=NULL) {
  # Allow user to specify unitless vector;  add default units
  if (!is.unit(x))
    x <- unit(x, default.units, units.per.obs)
  if (!is.unit(y))
    y <- unit(y, default.units, units.per.obs)
  grob(x=x, y=y, name=name, gp=gp, vp=vp, cl="lines")
}

# Specify "units.per.obs=TRUE" to give a unit or units per (x, y) pair
grid.lines <- function(x=unit(c(0, 1), "npc", units.per.obs),
                       y=unit(c(0, 1), "npc", units.per.obs),
                       default.units="npc", units.per.obs=FALSE,
                       name=NULL, gp=gpar(), draw=TRUE, vp=NULL) {
  lg <- linesGrob(x=x, y=y, default.units=default.units,
                  units.per.obs=units.per.obs,
                  name=name, gp=gp, vp=vp)
  if (draw)
    grid.draw(lg)
  invisible(lg)
}

######################################
# SEGMENTS primitive
######################################
validDetails.segments <- function(x) {
  if (!is.unit(x$x0) || !is.unit(x$x1) ||
      !is.unit(x$y0) || !is.unit(x$y1))
    stop("x0, y0, x1, and y1 must be units")
  x
}

drawDetails.segments <- function(x, recording=TRUE) {
  grid.Call.graphics("L_segments", x$x0, x$y0, x$x1, x$y1)
}

# Specify "units.per.obs=TRUE" to give a unit or units per (x, y) pair
segmentsGrob <- function(x0=unit(0, "npc"), y0=unit(0, "npc"),
                         x1=unit(1, "npc"), y1=unit(1, "npc"),
                         default.units="npc", units.per.obs=FALSE,
                         name=NULL, gp=gpar(), vp=NULL) {
  # Allow user to specify unitless vector;  add default units
  if (!is.unit(x0))
    x0 <- unit(x0, default.units, units.per.obs)
  if (!is.unit(x1))
    x1 <- unit(x1, default.units, units.per.obs)
  if (!is.unit(y0))
    y0 <- unit(y0, default.units, units.per.obs)
  if (!is.unit(y1))
    y1 <- unit(y1, default.units, units.per.obs)
  grob(x0=x0, y0=y0, x1=x1, y1=y1, name=name, gp=gp, vp=vp,
       cl="segments")
}

grid.segments <- function(x0=unit(0, "npc"), y0=unit(0, "npc"),
                      x1=unit(1, "npc"), y1=unit(1, "npc"),
                      default.units="npc", units.per.obs=FALSE,
                      name=NULL, gp=gpar(), draw=TRUE, vp=NULL) {
  sg <- segmentsGrob(x0=x0, y0=y0, x1=x1, y1=y1,
                     default.units=default.units,
                     units.per.obs=units.per.obs,
                     name=name, gp=gp, vp=vp)
  if (draw)
    grid.draw(sg)
  invisible(sg)
}

######################################
# ARROWS primitive
######################################

validDetails.arrows <- function(x) {
  # If grob is specified, that overrides any x and y values
  grobName <- childNames(x)
  if (length(grobName) == 0) {
    if (!is.unit(x$x) ||
        !is.unit(x$y))
      stop("x and y must be units")
  } else {
    lineThing <- getGrob(x, grobName)
    cl <- class(lineThing)
    # The grob can only be a "lines" or "segments"
    # (splines would be another candidate if they existed)
    if (!(inherits(lineThing, "lines") ||
          inherits(lineThing, "segments") ||
          inherits(lineThing, "line.to")))
      stop("The grob argument must be a line.to, lines, or segments grob")
    x$x <- x$y <- NULL
  }
  if (!is.unit(x$length))
    stop("Length must be a unit object")
  x$ends <- as.integer(match(x$ends, c("first", "last", "both")))
  x$type <- as.integer(match(x$type, c("open", "closed")))
  if (any(is.na(x$ends)) || any(is.na(x$type)))
    stop("Invalid ends or type argument")
  x
}

drawDetails.arrows <- function(x, recording=TRUE) {
  if (is.null(x$x)) { # y should be null too
    if (!is.null(x$y))
      stop("Corrupt arrows object")
    lineThing <- getGrob(x, childNames(x))
    # This could be done via method dispatch, but that really
    # seemed like overkill
    # OTOH, this is NOT user-extensible
    # AND the code for, e.g., "lines" is not located with
    # the other grid.lines code so changes there are unlikely
    # to propagate to here (e.g., add an id arg to grid.lines?
    if (inherits(lineThing, "line.to")) {
      x1 <- NULL
      x2 <- lineThing$x
      y1 <- NULL
      y2 <- lineThing$y
      xnm1 <- NULL
      xn <- lineThing$x
      ynm1 <- NULL
      yn <- lineThing$y
    } else if (inherits(lineThing, "lines")) {
      # x or y may be recycled
      n <- max(unit.length(lineThing$x),
               unit.length(lineThing$y))
      xx <- unit.rep(lineThing$x, length=2)
      x1 <- xx[1]
      x2 <- xx[2]
      xx <- unit.rep(lineThing$x, length=n)
      xnm1 <- xx[n - 1]
      xn <- xx[n]
      yy <- unit.rep(lineThing$y, length=2)
      y1 <- yy[1]
      y2 <- yy[2]
      yy <- unit.rep(lineThing$y, length=n)
      ynm1 <- yy[n - 1]
      yn <- yy[n]
    } else { # inherits(lineThing, "segments")
      x1 <- lineThing$x0
      x2 <- lineThing$x1
      xnm1 <- lineThing$x0
      xn <- lineThing$x1
      y1 <- lineThing$y0
      y2 <- lineThing$y1
      ynm1 <- lineThing$y0
      yn <- lineThing$y1
    }
  } else {
    # x or y may be recycled
    n <- max(unit.length(x$x), unit.length(x$y))
    xx <- unit.rep(x$x, length=2)
    x1 <- xx[1]
    x2 <- xx[2]
    xx <- unit.rep(x$x, length=n)
    xnm1 <- xx[n - 1]
    xn <- xx[n]
    yy <- unit.rep(x$y, length=2)
    y1 <- yy[1]
    y2 <- yy[2]
    yy <- unit.rep(x$y, length=n)
    ynm1 <- yy[n - 1]
    yn <- yy[n]
    grid.Call.graphics("L_lines", x$x, x$y)
  }
  grid.Call.graphics("L_arrows", x1, x2, xnm1, xn, y1, y2, ynm1, yn,
                     x$angle, x$length, x$ends, x$type)
}

arrowsGrob <- function(x=c(0.25, 0.75), y=0.5,
                        default.units="npc",
                        grob=NULL,
                        angle=30, length=unit(0.25, "inches"),
                        ends="last", type="open",
                        name=NULL, gp=gpar(), vp=NULL) {
  if (is.null(grob)) {
    if (!is.unit(x))
      x <- unit(x, default.units)
    if (!is.unit(y))
      y <- unit(y, default.units)
  }
  gTree(x=x, y=y, children=if (is.null(grob)) NULL else gList(grob),
       angle=as.numeric(angle), length=length,
       ends=ends, type=type,
       name=name, gp=gp, vp=vp, cl="arrows")
}

grid.arrows <- function(x=c(0.25, 0.75), y=0.5,
                        default.units="npc",
                        grob=NULL,
                        angle=30, length=unit(0.25, "inches"),
                        ends="last", type="open",
                        name=NULL, gp=gpar(), draw=TRUE, vp=NULL) {
  ag <- arrowsGrob(x=x, y=y, 
                   default.units=default.units,
                   grob=grob, angle=angle, length=length,
                   ends=ends, type=type,
                   name=name, gp=gp, vp=vp)
  if (draw)
    grid.draw(ag)
  invisible(ag)
}

######################################
# POLYGON primitive
######################################

validDetails.polygon <- function(x) {
  if (!is.unit(x$x) ||
      !is.unit(x$y))
    stop("x and y must be units")
  if (!is.null(x$id) && !is.null(x$id.lengths))
    stop("It is invalid to specify both id and id.lenths")
  if (unit.length(x$x) != unit.length(x$y))
    stop("x and y must be same length")
  if (!is.null(x$id) && (length(x$id) != unit.length(x$x)))
    stop("x and y and id must all be same length")
  if (!is.null(x$id))
    x$id <- as.integer(x$id)
  if (!is.null(x$id.lengths) && (sum(x$id.lengths) != unit.length(x$x)))
    stop("x and y and id.lengths must specify same overall length")
  if (!is.null(x$id.lengths))
    x$id.lengths <- as.integer(x$id.lengths)
  x
}

drawDetails.polygon <- function(x, recording=TRUE) {
  if (is.null(x$id) && is.null(x$id.lengths))
    grid.Call.graphics("L_polygon", x$x, x$y,
                       list(as.integer(1:length(x$x))))
  else {
    if (is.null(x$id)) {
      n <- length(x$id.lengths)
      id <- rep(1:n, x$id.lengths)
    } else {
      n <- length(unique(x$id))
      id <- x$id
    }
    index <- vector("list", n)
    count <- 1
    for (i in unique(id)) {
      index[[count]] <- as.integer((1:length(x$x))[id == i])
      count <- count + 1
    } 
    grid.Call.graphics("L_polygon", x$x, x$y, index)
  }
}

polygonGrob <- function(x=c(0, 0.5, 1, 0.5), y=c(0.5, 1, 0.5, 0),
                        id=NULL, id.lengths=NULL,
                        default.units="npc",
                        name=NULL, gp=gpar(), vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  grob(x=x, y=y, id=id,
       id.lengths=id.lengths,
       name=name, gp=gp, vp=vp, cl="polygon")
}

grid.polygon <- function(x=c(0, 0.5, 1, 0.5), y=c(0.5, 1, 0.5, 0),
                         id=NULL, id.lengths=NULL,
                         default.units="npc",
                         name=NULL, gp=gpar(), draw=TRUE, vp=NULL) {
  pg <- polygonGrob(x=x, y=y, id=id, id.lengths=id.lengths,
                    default.units=default.units,
                    name=name, gp=gp, vp=vp)
  if (draw)
    grid.draw(pg)
  invisible(pg)
}

######################################
# CIRCLE primitive
######################################

validDetails.circle <- function(x) {
  if (!is.unit(x$x) ||
      !is.unit(x$y) ||
      !is.unit(x$r))
    stop("x, y, and r must be units")
  x
}

drawDetails.circle <- function(x, recording=TRUE) {
  grid.Call.graphics("L_circle", x$x, x$y, x$r)
}

circleGrob <- function(x=0.5, y=0.5, r=0.5,
                       default.units="npc",
                       name=NULL, gp=gpar(), vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  if (!is.unit(r))
    r <- unit(r, default.units)
  grob(x=x, y=y, r=r, name=name, gp=gp, vp=vp, cl="circle")
}
              
grid.circle <- function(x=0.5, y=0.5, r=0.5,
                        default.units="npc",
                        name=NULL, gp=gpar(), draw=TRUE, vp=NULL) {
  cg <- circleGrob(x=x, y=y, r=r,
                   default.units=default.units,
                   name=name, gp=gp, vp=vp)
  if (draw)
    grid.draw(cg)
  invisible(cg)
}

######################################
# RECT primitive
######################################
validDetails.rect <- function(x) {
  if (!is.unit(x$x) ||
      !is.unit(x$y) ||
      !is.unit(x$width) ||
      !is.unit(x$height))
    stop("x, y, width, and height must be units")
  valid.just(x$just)
  x
}

drawDetails.rect <- function(x, recording=TRUE) {
  grid.Call.graphics("L_rect", x$x, x$y, x$width, x$height,
                     valid.just(x$just))
}

widthDetails.rect <- function(x) {
  absolute.size(x$width)
}

heightDetails.rect <- function(x) {
  absolute.size(x$height)
}

rectGrob <- function(x=unit(0.5, "npc"), y=unit(0.5, "npc"),
                     width=unit(1, "npc"), height=unit(1, "npc"),
                     just="centre", default.units="npc",
                     name=NULL, gp=gpar(), vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  if (!is.unit(width))
    width <- unit(width, default.units)
  if (!is.unit(height))
    height <- unit(height, default.units)
  grob(x=x, y=y, width=width, height=height, just=just,
       name=name, gp=gp, vp=vp, cl="rect")
}
            
grid.rect <- function(x=unit(0.5, "npc"), y=unit(0.5, "npc"),
                      width=unit(1, "npc"), height=unit(1, "npc"),
                      just="centre", default.units="npc",
                      name=NULL, gp=gpar(), draw=TRUE, vp=NULL) {
  rg <- rectGrob(x=x, y=y, width=width, height=height, just=just,
                 default.units=default.units,
                 name=name, gp=gp, vp=vp)
  if (draw)
    grid.draw(rg)
  invisible(rg)
}

######################################
# TEXT primitive
######################################
validDetails.text <- function(x) {
  if (!is.expression(x$label))
    x$label <- as.character(x$label)
  if (!is.unit(x$x) ||
      !is.unit(x$y))
    stop("x and y must be units")
  x$rot <- as.numeric(x$rot)
  if (!all(is.finite(x$rot)))
    stop("Invalid rot value")
  valid.just(x$just)
  x$check.overlap <- as.logical(x$check.overlap)
  x
}

drawDetails.text <- function(x, recording=TRUE) {
  grid.Call.graphics("L_text", x$label, x$x, x$y,
                     valid.just(x$just), x$rot, x$check.overlap)
}

widthDetails.text <- function(x) {
  unit(1, "strwidth", data=x$label)
}

heightDetails.text <- function(x) {
  unit(1, "strheight", data=x$label)
}

textGrob <- function(label, x=unit(0.5, "npc"), y=unit(0.5, "npc"),
                     just="centre", rot=0, check.overlap=FALSE,
                     default.units="npc",
                     name=NULL, gp=gpar(), vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  grob(label=label, x=x, y=y, 
       just=just, rot=rot, check.overlap=check.overlap,
       name=name, gp=gp, vp=vp, cl="text")
}

grid.text <- function(label, x=unit(0.5, "npc"), y=unit(0.5, "npc"),
                      just="centre", rot=0, check.overlap=FALSE,
                      default.units="npc",
                      name=NULL, gp=gpar(), draw=TRUE, vp=NULL) {
  tg <- textGrob(label=label, x=x, y=y, just=just, rot=rot,
                 check.overlap=check.overlap,
                 default.units=default.units,
                 name=name, gp=gp, vp=vp)
  if (draw)
    grid.draw(tg)
  invisible(tg)
}

######################################
# POINTS primitive
######################################
valid.pch <- function(pch) {
  if (length(pch) == 0)
    stop("zero-length pch")
  if (is.null(pch))
    pch <- as.integer(1)
  else if (!is.character(pch))
    pch <- as.integer(pch)
  pch
}

validDetails.points <- function(x) {
  if (!is.unit(x$x) ||
      !is.unit(x$y) ||
      !is.unit(x$size))
    stop("x, y and size must be units")
  if (unit.length(x$x) != unit.length(x$y))
    stop("x and y must be unit objects and have the same length")
  x$pch <- valid.pch(x$pch)
  x
}

drawDetails.points <- function(x, recording=TRUE) {
  grid.Call.graphics("L_points", x$x, x$y, x$pch, x$size)
}

pointsGrob <- function(x=runif(10),
                       y=runif(10),
                       pch=1, size=unit(1, "char"),
                       default.units="native",
                       name=NULL, gp=gpar(), vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  grob(x=x, y=y, pch=pch, size=size,
       name=name, gp=gp, vp=vp, cl="points")
}

grid.points <- function(x=runif(10),
                        y=runif(10),
                        pch=1, size=unit(1, "char"),
                        default.units="native",
                        name=NULL, gp=gpar(),
                        draw=TRUE, vp=NULL) {
  pg <- pointsGrob(x=x, y=y, pch=pch, size=size, 
                   default.units=default.units,
                   name=name, gp=gp, vp=vp)
  if (draw)
    grid.draw(pg)
  invisible(pg)
}












# These functions are used to evaluate "grobwidth" and
# "grobheight" units.
# They are usually called from within the C code
# (specifically, from within unit.c)
# It should be noted that they only give the width/height
# of the grob in the grob's drawing context
# (i.e., evaluating the width/height in another context
#  will not necessarily give the same result)

# The C code to evaluate "grobwidth" and "grobheight" calls
# the preDrawDetails and postDrawDetails generics before and
# after the call to width/height() to allow for complex grobs which
# construct their own viewports.

#########
# WIDTHS
#########

# We are doing this in R code to provide generics like widthDetails
# so that users can customise the behaviour for complex grobs by
# writing their own (R code!) methods
width <- function(x) {
  widthDetails(x)
}

widthDetails <- function(x) {
  UseMethod("widthDetails", x)
}

widthDetails.default <- function(x) {
  unit(1, "null")
}

#########
# HEIGHTS
#########
height <- function(x) {
  heightDetails(x)
}

heightDetails <- function(x) {
  UseMethod("heightDetails", x)
}

heightDetails.default <- function(x) {
  unit(1, "null")
}

#########
# Some functions that might be useful for determining the sizes
# of your grobs
#########

# Dimensions which depend on the parent context EITHER don't make
# sense (e.g., no good to have the parent width depend on the child's
# width unit(1, "grobwidth", <child>), which depends on the parent's
# width unit(.1, "npc"), ...) OR are slightly ambiguous
# (e.g., gf <- grid.frame(); grid.pack(gf, grid.rect(width=unit(.1, "npc")))
# makes the area allocated to the rectangle .1 of the frame area, but
# then the rectangle only occupies .1 of _that_ allocated area;  my head
# hurts !).  The first sort will actually lead to infinite loops so
# watch out for that;  the second sort I just don't want to have to deal with.
#
# On the other hand, dimensions which do not depend on the parent context
# are much easier to deal with (e.g., "inches", "cm", "lines", ...)
#
# So this function takes a unit and returns absolute values
# untouched and replaces other values with unit(1, "null")

absolute.size <- function(unit) {
  absolute.units(unit)
}


recycle.data <- function(data, data.per, max.n) {
  # VERY IMPORTANT:  Even if there is only one data specified
  # and/or only one data needed, we want this to be a LIST of
  # data values so that a single data and several data can be
  # handled equivalently
  # The test for whether it is only a single value currently
  # consists of a check for mode="character" (i.e., a single
  # string) or mode="expression" (i.e., a single expression)
  # or class="grob" (i.e., a single grob) or class="gPath"
  if (is.character(data) || is.expression(data) ||
      is.grob(data) || inherits(data, "gPath"))
    data <- list(data)
  if (data.per)
    n <- max.n
  else
    n <- length(data)
  original <- data
  index <- 1
  while (length(data) < n) {
    data <- c(data, list(original[[(index - 1) %% length(original) + 1]]))
    index <- index + 1
  }
  data
}

# Create an object of class "unit"
# Simple units are of the form `unit(1, "cm")' or `unit(1:3, "cm")' or
# `unit(c(1,3,6), c("cm", "inch", "npc"))'
# More complicated units are of the form `unit(1, "string", "a string")'
# or `unit(1, "grob", a.grob)'
unit <- function(x, units, data=NULL) {
  if (!is.numeric(x))
    stop("x must be numeric")
  units <- as.character(units)
  if (length(x) == 0 || length(units) == 0)
    stop("x and units must have length > 0")
  valid.unit(x, units, recycle.data(data, FALSE, length(x)))
}

valid.unit <- function(x, units, data) {
  valid.units <- valid.units(units)
  data <- valid.data(rep(units, length.out=length(x)), data)
  attr(x, "unit") <- units
  attr(x, "valid.unit") <- valid.units
  attr(x, "data") <- data
  class(x) <- "unit"
  x
}

grid.convert <- function(x, unitTo, axisFrom="x", typeFrom="location",
                         axisTo=axisFrom, typeTo=typeFrom,
                         valueOnly=FALSE) {
  .Deprecated("convertUnit")
  convertUnit(x, unitTo, axisFrom, typeFrom, axisTo, typeTo, valueOnly)
}

convertUnit <- function(x, unitTo, axisFrom="x", typeFrom="location",
                        axisTo=axisFrom, typeTo=typeFrom,
                        valueOnly=FALSE) {
  whatfrom <- match(axisFrom, c("x", "y")) - 1 +
    2*(match(typeFrom, c("location", "dimension")) - 1)
  whatto <- match(axisTo, c("x", "y")) - 1 +
    2*(match(typeTo, c("location", "dimension")) - 1)
  if (!is.unit(x))
    stop("`x' argument must be a unit object")
  if (is.na(whatfrom) || is.na(whatto))
    stop("Invalid axis or type")
  value <- grid.Call("L_convert", x, as.integer(whatfrom),
                 as.integer(whatto), valid.units(unitTo))
  if (!valueOnly)
    unit(value, unitTo)
  else
    value
}

grid.convertX <- function(x, unitTo, valueOnly=FALSE) {
  .Deprecated("convertX")
  convertX(x, unitTo, valueOnly)
}

convertX <- function(x, unitTo, valueOnly=FALSE) {
  convertUnit(x, unitTo, "x", "location", "x", "location",
              valueOnly=valueOnly)
}

grid.convertY <- function(x, unitTo, valueOnly=FALSE) {
  .Deprecated("convertY")
  convertY(x, unitTo, valueOnly)
}

convertY <- function(x, unitTo, valueOnly=FALSE) {
  convertUnit(x, unitTo, "y", "location", "y", "location",
              valueOnly=valueOnly)
}

grid.convertWidth <- function(x, unitTo, valueOnly=FALSE) {
  .Deprecated("convertWidth")
  convertWidth(x, unitTo, valueOnly)
}

convertWidth <- function(x, unitTo, valueOnly=FALSE) {
  convertUnit(x, unitTo, "x", "dimension", "x", "dimension",
              valueOnly=valueOnly)
}

grid.convertHeight <- function(x, unitTo, valueOnly=FALSE) {
  .Deprecated("convertHeight")
  convertHeight(x, unitTo, valueOnly)
}

convertHeight <- function(x, unitTo, valueOnly=FALSE) {
  convertUnit(x, unitTo, "y", "dimension", "y", "dimension",
              valueOnly=valueOnly)
}

convertNative <- function(unit, dimension="x", type="location") {
  .Deprecated("convertUnit")
  convertUnit(unit, "native", dimension, type, dimension, type,
              valueOnly=TRUE)
}

# NOTE: the order of the strings in these conversion functions must
# match the order of the enums in ../src/grid.h
.grid.unit.list <- c("npc", "cm", "inches", "lines",
                     "native", "null", "snpc", "mm",
                     "points", "picas", "bigpts",
                     "dida", "cicero", "scaledpts",
                     "strwidth", "strheight",
                     "vplayoutwidth", "vplayoutheight", "char",
                     "grobwidth", "grobheight",
                     "mylines", "mychar", "mystrwidth", "mystrheight")

# Make sure that and "str*" and "grob*" units have data
valid.data <- function(units, data) {
  n <- length(units)
  str.units <- (units == "strwidth" | units == "mystrwidth")
  if (any(str.units != 0))
    for (i in (1:n)[str.units])
      if (!(length(data) >= i &&
            (is.character(data[[i]]) || is.expression(data[[i]]))))
        stop("No string supplied for `strwidth' unit")
  str.units <- (units == "strheight" | units == "mystrheight")
  if (any(str.units != 0))
    for (i in (1:n)[str.units])
      if (!(length(data) >= i &&
            (is.character(data[[i]]) || is.expression(data[[i]]))))
        stop("No string supplied for `strheight' unit")
  # Make sure that a grob has been specified
  grob.units <- units == "grobwidth"
  if (any(grob.units != 0))
    for (i in (1:n)[grob.units]) {
      if (!(length(data) >= i &&
            (is.grob(data[[i]]) || inherits(data[[i]], "gPath") ||
             is.character(data[[i]]))))
        stop("No grob supplied for `grobwidth' unit")
      if (is.character(data[[i]]))
        data[[i]] <- gPathDirect(data[[i]])
      if (inherits(data[[i]], "gPath"))
        if (depth(data[[i]]) > 1)
          stop("gPath must have depth 1 in grobwidth/height units")
    }
  grob.units <- units == "grobheight"
  if (any(grob.units != 0))
    for (i in (1:n)[grob.units]) {
      if (!(length(data) >= i &&
            (is.grob(data[[i]]) || inherits(data[[i]], "gPath") ||
             is.character(data[[i]]))))
        stop("No grob supplied for `grobheight' unit")
      if (is.character(data[[i]]))
        data[[i]] <- gPathDirect(data[[i]])
      if (inherits(data[[i]], "gPath"))
        if (depth(data[[i]]) > 1)
          stop("gPath must have depth 1 in grobwidth/height units")
    }
  data
}

valid.units <- function(units) {
  .Call("validUnits", units, PACKAGE="grid")
}

as.character.unit <- function(unit) {
  class(unit) <- NULL
  paste(unit, attr(unit, "unit"), sep="")
}

#########################
# UNIT ARITHMETIC STUFF
#########################

unit.arithmetic <- function(func.name, arg1, arg2=NULL) {
  ua <- list(fname=func.name, arg1=arg1, arg2=arg2)
  class(ua) <- c("unit.arithmetic", "unit")
  ua
}

Ops.unit <- function(e1, e2) {
  ok <- switch(.Generic, "+"=TRUE, "-"=TRUE, "*"=TRUE, FALSE)
  if (!ok)
    stop(paste("Operator", .Generic, "not meaningful for units"))
  if (.Generic == "*")
    # can only multiply a unit by a scalar
    if (nchar(.Method[1])) {
      if (nchar(.Method[2]))
        stop("Only one operand may be a unit")
      else if (is.numeric(e2))
        # NOTE that we always put the scalar first
        # Use as.numeric to force e2 to be REAL
        unit.arithmetic(.Generic, as.numeric(e2), e1)
      else
        stop("Non-unit operand must be numeric")
    } else {
      if (is.numeric(e1))
        # Use as.numeric to force e1 to be REAL
        unit.arithmetic(.Generic, as.numeric(e1), e2)
      else
        stop("Non-unit operand must be numeric")
    }
  else
    # Check that both arguments are units
    if (nchar(.Method[1]) && nchar(.Method[2]))
      unit.arithmetic(.Generic, e1, e2)
    else
      stop("Both operands must be units")
}

## <FIXME>
## The na.rm arg is ignored here, and the S3 groupGeneric is
## Summary(x, ...)
## </FIXME>
Summary.unit <- function(..., na.rm=FALSE) {
  # NOTE that this call to unit.c makes sure that arg1 is
  # a single unit object
  x <- unit.c(...)
  ok <- switch(.Generic, "max"=TRUE, "min"=TRUE, "sum"=TRUE, FALSE)
  if (!ok)
    stop(paste("Summary function", .Generic, "not meaningful for units"))
  unit.arithmetic(.Generic, x)
}

is.unit.arithmetic <- function(x) {
  inherits(x, "unit.arithmetic")
}

as.character.unit.arithmetic <- function(ua) {
  # bit too customised for my liking, but whatever ...
  # NOTE that paste coerces arguments to mode character hence
  # this will recurse.
  fname <- ua$fname
  if (fname == "+" || fname == "-" || fname == "*")
    paste(ua$arg1, fname, ua$arg2, sep="")
  else
    paste(fname, "(", paste(ua$arg1, collapse=", "), ")", sep="")
}

unit.pmax <- function(...) {

  select.i <- function(unit, i) {
    "["(unit, i, top=FALSE)
  }

  x <- list(...)
  numargs <- length(x)
  if (numargs == 0)
    stop("Zero arguments where at least one expected")
  # how long will the result be?
  maxlength <- 0
  for (i in 1:numargs)
    if (unit.length(x[[i]]) > maxlength)
      maxlength <- unit.length(x[[i]])
  # maxlength guaranteed >= 1
  result <- max(unit.list.from.list(lapply(x, select.i, 1)))
  for (i in 2:maxlength)
    result <- unit.c(result, max(unit.list.from.list(lapply(x, select.i, i))))
  result
}

unit.pmin <- function(...) {

  select.i <- function(unit, i) {
    "["(unit, i, top=FALSE)
  }

  x <- list(...)
  numargs <- length(x)
  if (numargs == 0)
    stop("Zero arguments where at least one expected")
  # how long will the result be?
  maxlength <- 0
  for (i in 1:numargs)
    if (unit.length(x[[i]]) > maxlength)
      maxlength <- unit.length(x[[i]])
  # maxlength guaranteed >= 1
  result <- min(unit.list.from.list(lapply(x, select.i, 1)))
  for (i in 2:maxlength)
    result <- unit.c(result, min(unit.list.from.list(lapply(x, select.i, i))))
  result
}

#########################
# UNIT LISTS
# The idea with these is to allow arbitrary combinations
# of unit objects and unit arithmetic objects
#########################

# create a unit list from a unit, unit.arithmetic, or unit.list object
unit.list <- function(unit) {
  if (is.unit.list(unit))
    unit
  else {
    l <- unit.length(unit)
    result <- list()
    for (i in 1:l)
      result[[i]] <- unit[i]
    class(result) <- c("unit.list", "unit")
    result
  }
}

is.unit.list <- function(x) {
  inherits(x, "unit.list")
}

as.character.unit.list <- function(ul) {
  l <- unit.length(ul)
  result <- rep("", l)
  for (i in 1:unit.length(ul))
    result[i] <- as.character(ul[[i]])
  result
}

#########################
# These work on any sort of unit object
#########################

is.unit <- function(unit) {
  inherits(unit, "unit")
}

print.unit <- function(x, ...) {
  print(as.character(x), quote=FALSE)
}

#########################
# Unit subsetting
#########################

# The idea of the "top" argument is to allow the function to
# know if it has been called from the command-line or from
# a previous (recursive) call to "[.unit" or "[.unit.arithmetic"
# this allows recycling beyond the end of the unit object
# except at the top level

# NOTE that "unit" and "data" attributes will be recycled
"[.unit" <- function(x, index, top=TRUE, ...) {
  this.length <- length(x)
  if (is.logical(index))
    index <- (1:this.length)[index]
  if (top && index > this.length)
    stop("Index out of bounds (unit subsetting)")
  cl <- class(x);
  units <- attr(x, "unit")
  valid.units <- attr(x, "valid.unit")
  data <- attr(x, "data")
  class(x) <- NULL;
  # The line below may seem slightly odd, but it should only be
  # used to recycle values when this method is called to
  # subset an argument in a unit.arithmetic object
  x <- x[(index - 1) %% this.length + 1]
  attr(x, "unit") <- units[(index - 1) %% length(units) + 1]
  attr(x, "valid.unit") <- valid.units[(index - 1) %% length(valid.units) + 1]
  data.list <- data[(index - 1) %% length(data) + 1]
  attr(x, "data") <- data.list
  class(x) <- cl
  x
}

# NOTE that units will be recycled to the length of the largest
# of the arguments
"[.unit.arithmetic" <- function(x, index, top=TRUE, ...) {
  this.length <- unit.length(x)
  if (is.logical(index))
    index <- (1:this.length)[index]
  if (top && index > this.length)
    stop("Index out of bounds (unit arithmetic subsetting)")
  switch(x$fname,
         "+"="["(x$arg1, (index - 1) %% this.length + 1, top=FALSE) +
             "["(x$arg2, (index - 1) %% this.length + 1, top=FALSE),
         "-"="["(x$arg1, (index - 1) %% this.length + 1, top=FALSE) -
             "["(x$arg2, (index - 1) %% this.length + 1, top=FALSE),
         # Recycle multiplier if necessary
         "*"=x$arg1[(index - 1) %% length(x$arg1) + 1] *
             "["(x$arg2, (index - 1) %% this.length + 1, top=FALSE),
         "min"=x,
         "max"=x,
         "sum"=x)
}

"[.unit.list" <- function(x, index, top=TRUE, ...) {
  this.length <- unit.length(x)
  if (is.logical(index))
    index <- (1:this.length)[index]
  if (top && index > this.length)
    stop("Index out of bounds (unit list subsetting)")
  cl <- class(x)
  result <- unclass(x)[(index - 1) %% this.length + 1]
  class(result) <- cl
  result
}

# Write "[<-.unit" methods too ??

#########################
# "c"ombining unit objects
#########################

# NOTE that I have not written methods for c()
# because method dispatch occurs on the first argument to
# "c" so c(unit(...), ...) would come here, but c(whatever, unit(...), ...)
# would go who-knows-where.
# A particularly nasty example is:  c(1, unit(1, "npc")) which will
# produce the same result as c(1, 1)
# Same problem for trying to control c(<unit>, <unit.arithmetic>)
# versus c(<unit.arithmetic>, <unit>), etc ...

# If any arguments are unit.arithmetic or unit.list, then the result will be
# unit.list
unit.c <- function(...) {
  x <- list(...)
  ual <- FALSE
  for (i in 1:length(x))
    if (inherits(x[[i]], "unit.list") ||
        inherits(x[[i]], "unit.arithmetic"))
      ual <- TRUE
  if (ual)
    unit.list.from.list(x)
  else {
    values <- NULL
    units <- NULL
    data <- NULL
    for (i in 1:length(x))
      if (is.unit(x[[i]])) {
        values <- c(values, x[[i]])
        units <- c(units, rep(attr(x[[i]], "unit"), length.out=length(x[[i]])))
        data <- c(data, recycle.data(attr(x[[i]], "data"), TRUE,
                                     length(x[[i]])))
      }
      else
        stop("It is invalid to combine unit objects with other types")
    unit(values, units, data=data)
  }
}

unit.list.from.list <- function(x) {
  if (length(x) == 1)
    unit.list(x[[1]])
  else {
    result <- c(unit.list(x[[1]]), unit.list.from.list(x[2:length(x)]))
    class(result) <- c("unit.list", "unit")
    result
  }
}

# OLD unit.list.from.list <-
function(x) {
  result <- unit.list(x[[1]])
  i <- 2
  while (i < length(x) + 1) {
    result <- c(result, unit.list(x[[i]]))
    i <- i + 1
  }
  class(result) <- c("unit.list", "unit")
  result
}

#########################
# rep'ing unit objects
#########################

# NOTE that rep() is not a generic -- it does have different "methods"
# for some different data types, but this is ALL handled internally
# in seq.c

unit.arithmetic.rep <- function(x, times) {
  switch(x$fname,
         "+"=unit.rep(x$arg1, times) + unit.rep(x$arg2, times),
         "-"=unit.rep(x$arg1, times) - unit.rep(x$arg2, times),
         "*"=x$arg1 * unit.rep(x$arg2, times),
         "min"=unit.list.rep(unit.list(x), times),
         "max"=unit.list.rep(unit.list(x), times),
         "sum"=unit.list.rep(unit.list(x), times))
}

unit.list.rep <- function(x, times) {
  # Make use of the subsetting code to replicate the unit list
  # top=FALSE allows the subsetting to go beyond the original length
  "["(x, 1:(unit.length(x)*times), top=FALSE)
}

unit.rep <- function (x, times, length.out)
{
  if (unit.length(x) == 0)
    return(x)
  if (missing(times))
    times <- ceiling(length.out/length(x))

  if (is.unit.list(x))
    unit <- unit.list.rep(x, times)
  else if (is.unit.arithmetic(x))
    unit <- unit.arithmetic.rep(x, times)
  else {
    values <- rep(x, times)
    # Do I need to replicate the "unit"s?
    unit <- attr(x, "unit")
    # If there are any data then they must be explicitly replicated
    # because the list of data must be the same length as the
    # vector of values
    data <- recycle.data(attr(x, "data"), TRUE, length(values))
    unit <- unit(values, unit, data=data)
  }
  if (!missing(length.out))
    return(unit[if (length.out > 0) 1:length.out else integer(0)])
  unit
}

#########################
# Length of unit objects
#########################

unit.length <- function(unit) {
  UseMethod("unit.length")
}

unit.length.unit <- function(unit) {
  length(unit)
}

unit.length.unit.list <- function(unit) {
  length(unit)
}

unit.length.unit.arithmetic <- function(unit) {
  switch(unit$fname,
         "+"=max(unit.length(unit$arg1), unit.length(unit$arg2)),
         "-"=max(unit.length(unit$arg1), unit.length(unit$arg2)),
         "*"=max(length(unit$arg1), unit.length(unit$arg2)),
         "min"=1,
         "max"=1,
         "sum"=1)
}

#########################
# Convenience functions 
#########################

stringWidth <- function(string) {
  string <- as.character(string)
  unit(rep(1, length(string)), "strwidth", data=as.list(string))
}

stringHeight <- function(string) {
  string <- as.character(string)
  unit(rep(1, length(string)), "strheight", data=as.list(string))
}

grobWidth <- function(x) {
  UseMethod("grobWidth")
}

grobWidth.grob <- function(x) {
  unit(1, "grobwidth", data=x)
}

grobWidth.gList <- function(x) {
  unit(rep(1, length(gList)), "grobwidth", data=x)
}

grobHeight <- function(x) {
  UseMethod("grobHeight")
}

grobHeight.grob <- function(x) {
  unit(1, "grobheight", data=x)
}

grobHeight.gList <- function(x) {
  unit(rep(1, length(gList)), "grobheight", data=x)
}

#########################
# Function to decide which values in a unit are "absolute" (do not depend
# on parent's drawing context or size)
#########################

# Only deals with unit of unit.length() 1
absolute <- function(unit) {
  !is.na(match(attr(unit, "unit"),
               c("cm", "inches", "lines", "null",
                 "mm", "points", "picas", "bigpts",
                 "dida", "cicero", "scaledpts",
                 "strwidth", "strheight", "char",
                 "mylines", "mychar", "mystrwidth", "mystrheight")))
}

# OLD absolute.unit
absolute.units <- function(unit) {
  UseMethod("absolute.units")
}

absolute.units.unit <- function(unit) {
  n <- unit.length(unit)
  if (absolute(unit[1]))
    abs.unit <- unit[1]
  else
    abs.unit <- unit(1, "null")
  new.unit <- abs.unit
  count <- 1
  while (count < n) {
    count <- count + 1
    new.unit <- unit.c(new.unit, absolute.units(unit[count]))
  }
  new.unit
}

absolute.units.unit.list <- function(unit) {
  cl <- class(unit)
  abs.ul <- lapply(unit, absolute.units)
  class(abs.ul) <- cl
  abs.ul
}

absolute.units.unit.arithmetic <- function(unit) {
  switch(unit$fname,
         "+"=unit.arithmetic("+", absolute.units(unit$arg1),
           absolute.units(unit$arg2)),
         "-"=unit.arithmetic("-", absolute.units(unit$arg1),
           absolute.units(unit$arg2)),
         "*"=unit.arithmetic("*", unit$arg1, absolute.units(unit$arg2)),
         "min"=unit.arithmetic("min", absolute.units(unit$arg1)),
         "max"=unit.arithmetic("max", absolute.units(unit$arg1)),
         "sum"=unit.arithmetic("sum", absolute.units(unit$arg1)))
}



# Define a convenience function that is easy to call from C code
grid.top.level.vp <- function() {
  pushedvp(viewport(clip=TRUE, name="ROOT"))
}

# An accessor for getting at the grid global state structure
# to make debugging easier for me;  all I have to type is grid:::STATE()
STATE <- function() {
  get(".GRID.STATE", envir=.GridEvalEnv)
}

is.odd <- function(x) {
  x %% 2
}

is.even <- function(x) {
  !is.odd(x)
}

grid.pretty <- function(range) {
  if (!is.numeric(range))
    stop("range must be numeric")
  .Call("L_pretty", range, PACKAGE="grid")
}


initvpAutoName <- function() {
  index <- 0
  function() {
    index <<- index + 1
    paste("GRID.VP.", index, sep="")
  }
}

vpAutoName <- initvpAutoName()

# NOTE: The order of the elements in viewports and pushedvps are
# VERY IMPORTANT because the C code accesses them using constant
# indices (i.e., if you change the order here the world will end!
valid.viewport <- function(x, y, width, height, just, 
                           gp, clip,
                           xscale, yscale, angle,
                           layout, layout.pos.row, layout.pos.col,
                           name) {
  if (unit.length(x) > 1 || unit.length(y) > 1 ||
      unit.length(width) > 1 || unit.length(height) > 1)
    stop("`x', `y', `width', and `height' must all be units of length 1")
  if (!is.gpar(gp))
    stop("Invalid graphics parameters")
  if (!is.logical(clip)) 
    clip <- switch(as.character(clip),
                   on=TRUE,
                   off=NA,
                   inherit=FALSE,
                   stop("Invalid clip value"))
  if (!is.numeric(xscale) || length(xscale) != 2)
    stop("Invalid xscale in viewport")
  if (!is.numeric(yscale) || length(yscale) != 2)
    stop("Invalid yscale in viewport")
  if (!is.numeric(angle) || length(angle) != 1)
    stop("Invalid angle in viewport")
  if (!(is.null(layout) || is.layout(layout)))
    stop("Invalid layout in viewport")
  if (!is.null(layout.pos.row))
    layout.pos.row <- as.integer(rep(range(layout.pos.row), length.out=2))
  if (!is.null(layout.pos.col))
    layout.pos.col <- as.integer(rep(range(layout.pos.col), length.out=2))
  # If name is NULL then we give it a default
  # Otherwise it should be a valid R name
  if (is.null(name))
    name <- vpAutoName()
  else
    name <- make.names(name)
  # Put all the valid things first so that are found quicker
  vp <- list(x = x, y = y, width = width, height = height,
             justification = just,
             gp = gp,
             clip = clip,
             xscale = xscale,
             yscale = yscale,
             angle = angle,
             layout = layout,
             layout.pos.row = layout.pos.row,
             layout.pos.col = layout.pos.col,
             valid.just = valid.just(just),
             valid.pos.row = layout.pos.row,
             valid.pos.col = layout.pos.col,
             name=name)
  class(vp) <- "viewport"
  vp
}

# When a viewport is pushed, an internal copy is stored along
# with plenty of additional information relevant to the state
# at the time of being pushed (this is all used to return to this
# viewport without having to repush it)
pushedvp <- function(vp) {
  pvp <- c(vp, list(gpar = NULL,
                    trans = NULL,
                    widths = NULL,
                    heights = NULL,
                    width.cm = NULL,
                    height.cm = NULL,
                    rotation = NULL,
                    cliprect = NULL,
                    parent = NULL,
                    # Children of this pushedvp will be stored
                    # in an environment
                    children = new.env(hash=TRUE, parent=NULL),
                    # Initial value of 0 means that the viewport will
                    # be pushed "properly" the first time, calculating
                    # transformations, etc ...
                    devwidthcm = 0,
                    devheightcm = 0,
                    # This is down here because need to keep
                    # #defines in grid.h consistent with order here
                    parentgpar = NULL))
  class(pvp) <- c("pushedvp", class(vp))
  pvp
}

vpFromPushedvp <- function(pvp) {
  vp <- pvp[c("x", "y", "width", "height",
              "justification", "gp", "clip",
              "xscale", "yscale", "angle",
              "layout", "layout.pos.row", "layout.pos.col",
              "valid.just", "valid.pos.row", "valid.pos.col",
              "name")]
  class(vp) <- "viewport"
  vp
}

as.character.viewport <- function(x, ...) {
  paste("viewport[", x$name, "]", sep="")
}

as.character.vpList <- function(x, ...) {
  paste("(", paste(sapply(x, as.character, simplify=TRUE), collapse=", "),
        ")", sep="")
}

as.character.vpStack <- function(x, ...) {
  paste(sapply(x, as.character, simplify=TRUE), collapse="->")
}

as.character.vpTree <- function(x, ...) {
  paste(x$parent, x$children, sep="->")
}

print.viewport <- function(x, ...) {
  cat(as.character(x), "\n")
}

width.details.viewport <- function(x) {
  absolute.size(x$width)
}

height.details.viewport <- function(x) {
  absolute.size(x$height)
}

# How many "levels" in viewport object
depth <- function(vp) {
  UseMethod("depth")
}

depth.viewport <- function(vp) {
  1
}

depth.vpList <- function(vp) {
  # When pushed, the last element of the vpList is pushed last
  # so we are left whereever that leaves us
  depth(vp[[length(vp)]])
}

depth.vpStack <- function(vp) {
  # Elements in the stack may be vpStacks or vpLists or vpTrees
  # so need to sum all the depths
  sum(sapply(vp, depth, simplify=TRUE))
}

depth.vpTree <- function(vp) {
  # When pushed, the last element of the vpTree$children is
  # pushed last so we are left wherever that leaves us
  depth(vp$parent) + depth(vp$children[[length(vp$children)]])
}

depth.path <- function(path) {
  path$n
}

####################
# Accessors
####################

viewport.layout <- function(vp) {
  vp$layout
}

viewport.transform <- function(vp) {
  .Deprecated("current.transform")
}

####################
# Public Constructor
####################
viewport <- function(x = unit(0.5, "npc"),
                     y = unit(0.5, "npc"),
                     width = unit(1, "npc"),
                     height = unit(1, "npc"),
                     default.units = "npc",
                     just = "centre",
                     gp = gpar(),
                     clip = "inherit",
                     # FIXME: scales are only linear at the moment 
                     xscale = c(0, 1),
                     yscale = c(0, 1),
                     angle = 0,
                     # Layout for arranging children of this viewport
                     layout = NULL,
                     # Position of this viewport in parent's layout
                     layout.pos.row = NULL,
                     layout.pos.col = NULL,
                     # This is down here to avoid breaking
                     # existing code
                     name=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  if (!is.unit(width))
    width <- unit(width, default.units)
  if (!is.unit(height))
    height <- unit(height, default.units)
  valid.viewport(x, y, width, height, just, 
                 gp, clip, xscale, yscale, angle,
                 layout, layout.pos.row, layout.pos.col, name)
}

is.viewport <- function(vp) {
  inherits(vp, "viewport")
}

#############
# Some classes derived from viewport
#############

vpListFromList <- function(vps) {
  if (all(sapply(vps, is.viewport, simplify=TRUE))) {
    class(vps) <- c("vpList", "viewport")
    vps
  } else {
    stop("Only viewports allowed in vpList")
  }
}

# Viewports will be pushed in parallel
vpList <- function(...) {
  vps <- list(...)
  vpListFromList(vps)
}

# Viewports will be pushed in series
vpStack <- function(...) {
  vps <- list(...)
  if (all(sapply(vps, is.viewport, simplify=TRUE))) {
    class(vps) <- c("vpStack", "viewport")
    vps
  } else {
    stop("Only viewports allowed in vpStack")
  }
}

# Viewports will be pushed as a tree
vpTree <- function(parent, children) {
  if (is.viewport(parent) && inherits(children, "vpList")) {
    tree <- list(parent=parent, children=children)
    class(tree) <- c("vpTree", "viewport")
    tree
  } else {
    stop("Parent must be viewport and children must be vpList in vpTree")
  }
}

# A function for setting all gpars for vpStack/List/Tree
# Used in size.R
setvpgpar <- function(vp) {
  UseMethod("setvpgpar")
}

setvpgpar.viewport <- function(vp) {
  if (!is.null(vp$gp))
    set.gpar(vp$gp)
}

setvpgpar.vpStack <- function(vp) {
  lapply(vp, setvpgpar)
}

setvpgpar.vpList <- function(vp) {
  setvpgpar(vp[[length(vp)]])
}

setvpgpar.vpTree <- function(vp) {
  setvpgpar(vp$parent)
  setvpgpar(vp$children)
}

# Functions for creating "paths" of viewport names
.grid.pathSep <- "::"

vpPathFromVector <- function(names) {
  n <- length(names)
  if (n < 1)
    stop("A viewport path must contain at least one viewport name")
  if (!all(is.character(names)))
    stop("Invalid viewport name(s)")
  path <- list(path=if (n==1) NULL else
               paste(names[1:(n-1)], collapse=.grid.pathSep),
               name=names[n],
               n=n)
  class(path) <- c("vpPath", "path")
  path
}

vpPath <- function(...) {
  names <- c(...)
  vpPathFromVector(names)
}

# Create vpPath from string with embedded VpPathSep(s)
vpPathDirect <- function(path) {
  names <- unlist(strsplit(path, .grid.pathSep))
  vpPathFromVector(names)
}

as.character.path <- function(x, ...) {
  if (x$n == 1)
    x$name
  else
    paste(x$path, x$name, sep=.grid.pathSep)

}

print.path <- function(x, ...) {
  print(as.character(x))
}

#############
# Some handy viewport functions
#############

# Create a viewport with margins given in number of lines
plotViewport <- function(margins, ...) {
  margins <- rep(as.numeric(margins), length.out=4)
  viewport(x=unit(margins[2], "lines"),
           width=unit(1, "npc") - unit(sum(margins[c(2,4)]), "lines"),
           y=unit(margins[1], "lines"),
           height=unit(1, "npc") - unit(sum(margins[c(1,3)]), "lines"),
           just=c("left", "bottom"),
           ...)
}

# Create a viewport from data
# If xscale not specified then determine from x
# If yscale not specified then determine from y
dataViewport <- function(xData=NULL, yData=NULL, xscale=NULL, yscale=NULL,
                         extension=0.05, ...) {
  if (is.null(xscale)) {
    if (is.null(xData))
      stop("Must specify at least one of x or xscale")
    xscale <- range(xData) + c(-1, 1)*diff(range(xData))*extension
  }
  if (is.null(yscale)) {
    if (is.null(yData))
      stop("Must specify at least one of y or yscale")
    yscale <- range(yData) + c(-1, 1)*diff(range(yData))*extension
  }
  viewport(xscale=xscale, yscale=yscale, ...)
}
## environment used for evaluation in the C code
## assigned here to protect from GC, but otherwise unused at R level
.GridEvalEnv <- new.env()

# This should be the only grid global variable(?)
# It contains the list of state structures corresponding to the
# state for each device.
# The state structures are stored in here so that they do not
# get garbage collected.
assign(".GRID.STATE", vector("list", 64), envir = .GridEvalEnv)
## 64 comes from the maximum number of R devices allowed to be open at
## one time, see R_MaxDevices in Graphics.h.

.noGenerics <- TRUE

.onLoad <- function(lib, pkg)
{
    library.dynam( "grid", pkg, lib )
    ## want eval in C code to see unexported objects
    environment(.GridEvalEnv) <- asNamespace("grid")
    .Call("L_initGrid", .GridEvalEnv, PACKAGE="grid")
    .grid.loaded <<- TRUE
}

.onUnload <- function(libpath)
{
    if (.grid.loaded) {
        ## Kill all existing devices to avoid replay
        ## of display list which tries to run grid code
        ## Not very friendly to other registered graphics systems
        ## but its safety first for now
        graphics.off()
        .Call("L_killGrid", PACKAGE="grid")
    }
    library.dynam.unload("grid", libpath)
}
