######################################
# Default COLLECTION of grobs
######################################
draw.details.collection <- function(x, x.wrapped, recording=TRUE) {
  # A collection draws all of its children
  lapply(x$children, grid.draw, recording=FALSE)
}

# Have a draw=T argument because "only" other alternative is to
# have a separate make.collection function with identical argument
# list (i.e., duplicated entry point).  Not such an issue here,
# but just gets worse the more complex the graphical object gets.
grid.collection <- function(..., gp=gpar(), draw=TRUE, vp=NULL) {
  children <- list(...)
  # Allow for single argument of a list of grobs (rather than
  # multiple grobs as separate arguments)
  if (!is.grob(children[[1]]) && is.list(children[[1]]))
    children <- children[[1]]
  collection <- list(children=children, gp=gp, vp=vp)
  cl <- "collection"
  grid.grob(collection, cl, draw)
}

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

# Axes are extended from the "collection" class
# They have named children and the same grobs stored in their
# children slot.  This means that the standard (e.g., draw.details)
# methods for collections will apply, but axes can allow more
# convenient access and more sophisticated control of their
# child grobs AS WELL

# The children of an axis are fixed to be:
# [[1]] major line
# [[2]] tick marks
# [[3]] tick labels

# 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.

draw.details.xaxis <- function(x, x.wrapped, recording=TRUE) {
  # We may have to create the children if there was not
  # enough information available at creation time
  if (is.null(x$at)) {
    # FIXME:  There should be a grid.pretty rather than
    # forcing users to use grid.Call
    at <- grid.pretty(current.viewport()$xscale)
    # We edit the grob itself so that the change is permanent
    grid.edit(x.wrapped, at=at, redraw=FALSE)
    # Then we make sure the current draw is aware of the change
    x <- grid.get(x.wrapped)
  }
  NextMethod()
}

# 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, new.values) {
  slot.names <- names(new.values)
  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)) {
      x$major <- make.xaxis.major(x$at, x$main)
      x$ticks <- make.xaxis.ticks(x$at, x$main)
      if (x$label)
        x$labels <- make.xaxis.labels(x$at, x$main)
      else
        x$labels <- NULL
      x$children <- list(x$major, x$ticks, x$labels)
    }
  }
  # FIXME:  Handle "label=" and "main=" too ?
  x
}

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

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")
  }
  grid.segments(unit(at, "native"), tick.y0,
                unit(at, "native"), tick.y1,
                draw=FALSE)
}

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")
  grid.text(as.character(at), unit(at, "native"), label.y,
                    just="centre", rot=0,
                    check.overlap=TRUE, draw=FALSE)
}

# 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, gp=gpar(),
                   draw=TRUE, vp=NULL) {
  if (is.null(at))
    if (is.null(vp)) {
      # We do not have enough information to make the ticks and labels
      major <- NULL
      ticks <- NULL
      labels <- NULL
    }
    else
      at <- grid.pretty(vp$xscale)
  if (!is.null(at)) {
    major <- make.xaxis.major(at, main)
    ticks <- make.xaxis.ticks(at, main)
    if (label)
      labels <- make.xaxis.labels(at, main)
    else
      labels <- NULL
  }
  grid.grob(list(at=at, children=list(major, ticks, labels),
                 major=major, ticks=ticks, labels=labels,
                 label=label, gp=gp, main=main, vp=vp),
            c("xaxis", "axis", "collection"), draw)
}

draw.details.yaxis <- function(x, x.wrapped, recording=TRUE) {
  # We may have to create the children if there was not
  # enough information available at creation time
  if (is.null(x$at)) {
    at <- grid.pretty(current.viewport()$yscale)
    grid.edit(x.wrapped, at=at, redraw=FALSE)
    x <- grid.get(x.wrapped)
  }
  NextMethod()
}

editDetails.yaxis <- function(x, new.values) {
  slot.names <- names(new.values)
  if (match("at", slot.names, nomatch=0)) {
    if (!is.null(x$at)) {
      x$major <- make.yaxis.major(x$at, x$main)
      x$ticks <- make.yaxis.ticks(x$at, x$main)
      if (x$label)
        x$labels <- make.yaxis.labels(x$at, x$main)
      else
        x$labels <- NULL
      x$children <- list(x$major, x$ticks, x$labels)
    }
  }
  x
}

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

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")
  }
  grid.segments(tick.x0, unit(at, "native"),
                tick.x1, unit(at, "native"),
                draw=FALSE)
}

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")
  grid.text(as.character(at), label.x, unit(at, "native"),
        just=just, rot=0, check.overlap=TRUE, draw=FALSE)
}

# 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, gp=gpar(),
                   draw=TRUE, vp=NULL) {
  if (is.null(at))
    if (is.null(vp)) {
      # We do not have enough information to make the ticks and labels
      major <- NULL
      ticks <- NULL
      labels <- NULL
    }
    else
      at <- grid.pretty(vp$yscale)
  if (!is.null(at)) {
    major <- make.yaxis.major(at, main)
    ticks <- make.yaxis.ticks(at, main)
    if (label)
      labels <- make.yaxis.labels(at, main)
    else
      labels <- NULL
  }
  grid.grob(list(at=at, major=major, ticks=ticks, labels=labels,
                 children=list(major, ticks, labels),
                 label=label, gp=gp, main=main, vp=vp),
            c("yaxis", "axis", "collection"), draw)
}

######################################
# 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))
    push.viewport(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))
    pop.viewport()
}

######################################
# Stuff for lpack()
######################################

width.details.frame <- function(x) {
  sum(layout.widths(viewport.layout(x$frame.vp)))
}

height.details.frame <- function(x) {
  sum(layout.heights(viewport.layout(x$frame.vp)))
}

draw.frame.child <- function(grob) {
  temp.vp <- viewport(layout.pos.col=grob$col,
                      layout.pos.row=grob$row)
  push.viewport(temp.vp, recording=FALSE)
  if (!is.null(grob$border))
    push.viewport(viewport(x=grob$border[2],
                           y=grob$border[1],
                           width=unit(1, "npc") - sum(grob$border[c(2,4)]),
                           height=unit(1, "npc") - sum(grob$border[c(1,3)]),
                           just=c("left", "bottom")),
                  recording=FALSE)
  grid.draw(grob, recording=FALSE)
  if (!is.null(grob$border))
    pop.viewport(recording=FALSE)
  pop.viewport(recording=FALSE)
}

draw.details.frame <- function(x, x.wrapped, recording=TRUE) {
  if (!is.null(x$frame.vp))
    push.viewport(x$frame.vp, recording=FALSE)
  lapply(x$children, draw.frame.child)
  if (!is.null(x$frame.vp))
    pop.viewport(recording=FALSE)
}

# NOTE that this never produces any actual graphical output
# (there is nothing to draw) BUT it is important to use
# draw=TRUE if you want to pack the frame interactively.
# This ensures that the frame is on the .grid.display.list
# so that the editing that occurs in grid.pack() will redraw the
# frame when it forces a draw.all()
grid.frame <- function(layout=NULL, vp=NULL, gp=gpar(), draw=FALSE) {
  if (!is.null(layout))
    frame.vp <- viewport(layout=layout)
  else
    frame.vp <- NULL
  grid.grob(list(children=NULL, vp=vp, gp=gp, frame.vp=frame.vp),
        c("frame", "collection"), draw=draw)
}

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(grob, added.col) {
  old.col <- grob$col
  # If grob$col is a range ...
  if (length(old.col) == 2) {
    if (added.col <= old.col[2])
      grob$col <- c(old.col[1], old.col[2] + 1)
  }
  else
    if (added.col <= old.col)
      grob$col <- old.col + 1
  grob
}

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

# This guy is just a simpler interface to grid.pack(), with
# the focus more on just "placing" a grob within the existing
# layout of a frame, without modifying that layout in any way
# In this way, it is basically just a more convenient way of
# locating grobs within a viewport with a layout
# NOTE that it relies on intimate knowledge of grid.pack
# to make the minimum impact on the existing layout
# THEREFORE it is fragile if grid.pack changes
# In particular, it makes sure that the widths/heights of
# the layout are untouched by specifying the row and col as
# a range
grid.place <- function(frame, grob, grob.name="", draw=TRUE,
                       row=1, col=1) {
  if (length(row) == 1)
    row <- rep(row, 2)
  if (length(col) == 1)
    col <- rep(col, 2)
  grid.pack(frame, grob, grob.name, draw,
            col=col, row=row,
            # Just dummy values;  they will be ignored by grid.pack
            width=unit(1, "null"), height=unit(1, "null"))
}

# Pack a child grob within a frame grob
# (a special sort of editing just for frame grobs)
# FIXME:  Allow specification of respect for new row/col
grid.pack <- function(frame, grob, grob.name="", draw=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) {
  # 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 <- grid.get(frame, "frame.vp")
  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)
  
  # (iii) If width and height are not given, take them from the child
  if (is.null(width))
    if (is.null(grob))
      width <- unit(1, "null")
    else
      width <- unit(1, "grobwidth", grob)
  if (is.null(height))
    if (is.null(grob))
      height <- unit(1, "null")
    else
      height <- unit(1, "grobheight", grob)
  # 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)
  }
  # NOT SURE WHAT THIS WAS DOING HERE
  # respect <- layout.respect(lay)
  frame.vp$layout <- grid.layout(ncol=ncol, nrow=nrow,
                                 widths=widths, height=heights)
  children <- grid.get(frame, "children")
  # Modify the locations (row, col) of existing children in the frame
  if (new.col)
    children <- lapply(children, updateCol, col)
  if (new.row)
    children <- lapply(children, updateRow, row)
  if (!is.null(grob)) {
    # Give the new grob a record of its location (row, col) in the frame
    grob$row <- row
    grob$col <- col
    grob$border <- border
    children <- c(children, list(grob))
  }
  grid.edit(frame, grid.prop.list(children=children, frame.vp=frame.vp), redraw=draw)
}


# 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
}

saved.pars <- function(pars) {
  list(prev=NULL, pars=pars)
}
push.saved.gpars <- function(gpars) {
  sp <- saved.pars(gpars)
  sp$prev <- grid.Call("L_getGPsaved")
  grid.Call("L_setGPsaved", sp)
}

pop.saved.gpars <- function() {
  grid.Call("L_setGPsaved", grid.Call("L_getGPsaved")$prev)
}

# 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 .grid.gpars to keep grid record of current settings
set.gpar <- function(gp) {
  if (!is.gpar(gp))
    stop("Argument must be a 'gpar' object")
  subset <- match(names(gp), .grid.gpar.names)
  cur.gpars <- grid.Call("L_getGPar")
  push.saved.gpars(cur.gpars[subset])
  temp <- cur.gpars
  temp[subset] <- gp
  # Do this as a .Call.graphics to get it onto the base display list
  grid.Call.graphics("L_setGPar", temp)
}

unset.gpar <- function(gp) {
  if (!is.gpar(gp))
    stop("Argument must be a 'gpar' object")
  # for debugging really
  subset <- match(names(gp), .grid.gpar.names)
  saved.gpars <- grid.Call("L_getGPsaved")
  if (length(subset) != length(saved.gpars$pars))
    stop(paste("Trying to reset", names(gp),
               "with", saved.gpars$pars))
  temp <- grid.Call("L_getGPar")
  temp[subset] <- saved.gpars$pars
  # Do this as a .Call.graphics to get it onto the base display list
  grid.Call.graphics("L_setGPar", temp)
  pop.saved.gpars()
}  

get.gpar <- function(gpar.name) {
  grid.Call("L_getGPar")[[gpar.name]]
}



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

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

push.vp <- function(vps, index, len, recording) {
  vp <- vps[[index]]
  if (is.null(vp))
    stop("Illegal to push NULL viewport")
  # Record on the display list
  if (recording)
    record(vp)
  # Enforce gpar settings
  set.gpar(vp$gp)
  # Later, we will query the viewport to ask "what were the gpar
  # settings when you were drawn".  This is NOT the same as asking
  # the viewport for its gpar settings because the viewport may only
  # specify some gpar values.  So we record the default settings
  # we will need to know about
  vp$cur.fontfamily <- get.gpar("fontfamily")
  vp$cur.font <- get.gpar("font")
  vp$cur.fontsize <- get.gpar("fontsize")
  vp$cur.lineheight <- get.gpar("lineheight")
  # Calculate viewport transform
  # NOTE that we will have modified "vp" within L_setviewport
  # to record the current transformation and layout
  grid.Call.graphics("L_setviewport", vp, TRUE)
  # Push further viewports if required
  if (index < len)
    push.vp(vps, index+1, len, recording)
}

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

pop.vp <- function(last.one, recording) {
  vp <- grid.Call("L_currentViewport")
  # Fail if trying to pop top-level viewport
  if (is.null(vp$parent))
    stop("Illegal to pop top-level viewport")
  # Unset gpar settings
  unset.gpar(vp$gp)
  # Allow for recalculation of viewport transform if necessary
  grid.Call.graphics("L_unsetviewport", last.one)
}

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

# Function to obtain the current viewport
current.viewport <- function(vp=NULL) {
  if (is.null(vp))
    grid.Call("L_currentViewport")
  else {
    warning("The vp argument is going to be deprecated")
    vp
  }
}

# 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", 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")
}

###########
# 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()
}

# 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, ...) {
  .Call.graphics("L_gridDirty", PACKAGE="grid")
  .Call.graphics(fnname, ..., PACKAGE="grid")
}

######################################
# Grid graphical primitives
#######################################

# A graphical object is a unique object (i.e., we refer to it by pointer)
# so that it can be edited
# NOTE that cl is the class of the list.struct and "grob" is
# the class of the reference object
# The aim is to have user code only deal with the list.struct
# and hide the handling of pointers
# NOTE also that we stick class "glist" onto the list structure
# so that we can do generic things with them too.
grid.grob <- function(list.struct, cl=NULL, draw=TRUE) {
  class(list.struct) <- c(cl, "glist")
  ptr <- .Call("L_CreateSEXPPtr", list.struct, PACKAGE="grid")
  grob <- list(ptr)
  class(grob) <- "grob"
  if (draw)
    grid.draw(grob)
  invisible(grob)
}

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

get.value <- function(x, child.specs=NULL) {
  UseMethod("get.value")
}

get.value.default <- function(x, child.specs=NULL) {
  if (is.list(x) && length(child.specs) > 0)
      get.value(x[[child.specs[[1]]]], child.specs[-1])
  else
    x
}

get.value.grob <- function(x, child.specs=NULL) {
  # Remove check when have NAMESPACE (?)
  if (!is.grob(x))
    stop("Cannot get value of non-grob")
  result <- .Call("L_GetSEXPPtr", x[[1]], PACKAGE="grid")
  if (length(child.specs) > 0) 
    result <- get.value(result[[child.specs[[1]]]],
                        child.specs[-1])
  result
}

# Unwrap a list.struct from within a grob external pointer
grid.get <- function(grob, ...) {
  if (!is.grob(grob))
    stop("Cannot get value of non-grob")
  get.value.grob(grob, list(...))
}

# FIXME:  Replace with "<-.grob" method ?
set.value.grob <- function(grob, child.specs, list.struct) {
  ncs <- length(child.specs)  
  if (ncs == 0)
    target <- grob
  else
    target <- get.value.grob(grob, child.specs[-ncs])[[child.specs[[ncs]]]]
  .Call("L_SetSEXPPtr", target[[1]], list.struct, PACKAGE="grid")
}

# Wrap a list.struct within a grob external pointer
# Destructively set value of a grob
grid.set <- function(grob, ...) {
  if (!is.grob(grob))
    stop("Cannot set value of non-grob")
  args <- list(...)
  nargs <- length(args)
  if (nargs == 0)
    stop("No list.struct value specified")
  set.value.grob(grob, args[-nargs], args[[nargs]])
}

# Use this function to produce a list of new.values for grid.edit()
grid.prop.list <- function(...) {
  result <- list(...)
  class(result) <- "prop.list"
  result
}

# The ... part consists of zero or more child.specs, plus a single
# new.value or a list of new.values
grid.edit <- function(grob, ..., redraw=TRUE) {
  # If grob is NULL, do nothing, but don't give an error
  # This allows grobs to have NULL components
  if (!is.null(grob)) {
    if (!inherits(grob, "grob"))
      stop("Cannot edit value of non-grob")
    args <- list(...)
    nargs <- length(args)
    if (nargs == 0)
      stop("No new value specified")
    new.values <- args[nargs]
    # Handle list of new values
    if (inherits(new.values[[1]], "prop.list")) 
      new.values <- new.values[[1]]
    # Make sure that when grid.edit is called again from within
    # an edit.details method, that the new.values is a prop.list
    class(new.values) <- "prop.list"
    # If there are no new.values, just do nothing
    # This is possible, e.g., axis consumes at= and passes empty
    # new.values to axis$major etc
    if (length(new.values) > 0 && !is.null(names(new.values))) {
      child.specs <- args[-nargs]
      list.struct <- get.value.grob(grob, child.specs)
      slot.names <- names(new.values)
      for (i in 1:length(new.values)) 
        # If there is no slot with the argument name, just ignore that argument
        if (match(slot.names[i], names(list.struct), nomatch=0)) {
          list.struct[[slot.names[i]]] <- new.values[[i]]
          # If the new value was NULL, we have just erased the slot
          # from the list.struct.  Here we put it back.
          # FIXME: there must be a better way to do this !
          if (is.null(new.values[[i]])) {
            cl <- class(list.struct)
            temp <- list(NULL)
            names(temp) <- slot.names[i]
            list.struct <- c(list.struct, temp)
            class(list.struct) <- cl
          }
        }
      # Do any class-specific editing
      list.struct <- editDetails(list.struct, new.values)
      set.value.grob(grob, child.specs, list.struct)
      # FIXME:  This needs to draw ldisplay.list for all devices where
      # grob appears
      if (redraw)
        draw.all()
    }
  }
}

editDetails <- function(x, new.values) {
  UseMethod("editDetails")
}

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

# 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()
# All drawing methods have to extract the grob value at the start and
# record if necessary at the end.  The approach below means that custom
# drawing methods don't have to bother about this;  they just have to
# write a draw.details method
# Assume that all grobs have a slot called "vp" containing a viewport
# and a slot "gpar" containing a gpar
grid.draw <- function(x, recording=TRUE) {
  if (!is.null(x)) {
      list.struct <- get.value(x)
      # automatically push/pop the viewport and set/unset the gpar
      if (!is.null(list.struct$vp))
        push.viewport(list.struct$vp, recording=FALSE)
      if (!is.null(list.struct$gp))
        set.gpar(list.struct$gp)
      # Do any class-specific drawing
      draw.details(list.struct, x, recording)
      if (!is.null(list.struct$gp))
        unset.gpar(list.struct$gp)
      if (!is.null(list.struct$vp))
          pop.viewport(recording=FALSE)
      if (recording)
        record(x)
  }
}

draw.all <- function() {
  grid.newpage(recording=FALSE)
  lapply(grid.Call("L_getDisplayList"), grid.draw, recording=FALSE)
  NULL
}

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

# When there is a pop.viewport, the number of viewports popped
# gets put on the display list
draw.details.default <- function(x, x.wrapped, recording) {
  pop.viewport(x, recording)
}

draw.details.glist <- function(x, x.wrapped, recording) {
}

draw.details.viewport <- function(x, x.wrapped, recording) {
  push.viewport(x, recording=FALSE)
}

print.grob <- function(x, ...) {
  cl <- class(get.value.grob(x))
  print(paste(cl[1:(length(cl)-1)], collapse=" "))
}

# Make an explicit copy of a grob (i.e., not just another reference
# to the same grob)
grid.copy <- function(grob) {
  list.struct <- grid.get(grob)
  cl <- class(list.struct)
  cl <- cl[1:(length(cl)-1)]
  grid.grob(list.struct, cl, draw=FALSE)
}

######################################
# 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))
    push.viewport(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))
    pop.viewport()
}  

grid.panel <- function(x = runif(10), y = runif(10),
                   zrange = c(0, 1), zbin = 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))
    push.viewport(vp)
  temp.vp <- viewport(layout=grid.layout(2, 1,
                         heights=unit(c(1, 1), c("lines", "null"))))
  push.viewport(temp.vp)
  strip.vp <- viewport(layout.pos.row=1, layout.pos.col=1,
                        xscale=xscale)
  push.viewport(strip.vp)
  grid.strip(range.full=zrange, range.thumb=zbin)
  grid.rect()
  if (axis.top)
    grid.xaxis(main=FALSE, label=axis.top.label)
  pop.viewport()
  plot.vp <- viewport(layout.pos.row=2, layout.pos.col=1,
                       xscale=xscale, yscale=yscale)
  push.viewport(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)
  pop.viewport(2)
  if (!is.null(vp))
    pop.viewport()
  invisible(list(strip.vp = strip.vp, plot.vp = plot.vp))
}

grid.multipanel <- function(x=runif(90), y=runif(90), z=runif(90),
                            nrow=2, ncol=5, nplots=9,
                            newpage=TRUE, vp=NULL) {
  if (newpage)
    grid.newpage()
  if (!is.null(vp))
    push.viewport(vp)
  temp.vp <- viewport(layout=grid.layout(nrow, ncol))
  push.viewport(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)
  pop.viewport()
  if (!is.null(vp))
    pop.viewport()
}

grid.show.layout <- function(l, newpage=TRUE,
                         cell.border="blue", cell.fill="light blue",
                         cell.label=TRUE, vp=NULL) {
  if (newpage)
    grid.newpage()
  if (!is.null(vp))
    push.viewport(vp)
  grid.rect(gp=gpar(col=NULL, fill="light grey"))
  vp.mid <- viewport(0.5, 0.5, 0.8, 0.8, layout=l)
  push.viewport(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)
      push.viewport(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) 
      pop.viewport()
    }
  pop.viewport()
  if (!is.null(vp))
    pop.viewport()
  # 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))
      push.viewport(vp)
    vp.mid <- grid.show.layout(parent.layout,
                           cell.border="grey", cell.fill="white",
                           cell.label=FALSE, newpage=newpage)
    push.viewport(vp.mid)
    push.viewport(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)
    pop.viewport(2)
    if (!is.null(vp))
      pop.viewport()
  } else {
    if (newpage)
      grid.newpage()
    if (!is.null(vp))
      push.viewport(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)
    push.viewport(vp.mid)
    grid.rect(gp=gpar(fill="white"))
    x <- v$x
    y <- v$y
    w <- v$width
    h <- v$height
    push.viewport(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"))
    pop.viewport()
    # 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)
    pop.viewport()
    if (!is.null(vp))
      pop.viewport()
  }
}

# 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))))
  gf <- grid.frame(layout=legend.layout, vp=vp, gp=gp, draw=FALSE)
  for (i in 1:nkeys) {
    grid.place(gf, grid.points(.5, .5, pch=pch[i], draw=FALSE),
               col=1, row=i, draw=FALSE)
    grid.place(gf, grid.text(labels[i], x=0, y=.5, just=c("left", "centre"),
                             draw=FALSE),
               col=2, row=i, draw=FALSE)
  }
  if (draw) 
    grid.draw(gf)
  gf
}

# 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)
  push.viewport(top.vp)
  x <- runif(10)
  y1 <- runif(10)
  y2 <- runif(10)
  pch <- 1:3
  labels <- c("Girls", "Boys", "Other")
  lf <- grid.frame(draw=TRUE)
  plot <- grid.collection(grid.rect(draw=FALSE),
                      grid.points(x, y1, pch=1, draw=FALSE),
                      grid.points(x, y2, pch=2, draw=FALSE),
                      grid.xaxis(draw=FALSE),
                      grid.yaxis(draw=FALSE),
                      draw=FALSE)
  grid.pack(lf, plot)
  grid.pack(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(viewport.transform(current.viewport()))
  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=grid.convertX(location[1], unit),
       y=grid.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) {
  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)
  }
  l <- list(nrow = nrow, ncol = ncol,
            widths = widths, heights = heights,
            respect = respect, valid.respect=as.integer(respect),
            respect.mat = respect.mat)
  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)
{
  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)
}

####################
# 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
######################################
draw.details.move.to <- function(x, x.wrapped, recording=TRUE) {
  grid.Call.graphics("L_moveTo", x$x, x$y)
}

grid.move.to <- function(x=0, y=0,
                         default.units="npc",
                         draw=TRUE, vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  # Make sure that x and y are of length 1
  if (unit.length(x) > 1 | unit.length(y) > 1)
    stop("x and y must have length 1")
  grid.grob(list(x=x, y=y, vp=vp), "move.to", draw)
}

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

grid.line.to <- function(x=1, y=1,
                         default.units="npc",
                         draw=TRUE, gp=gpar(), vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  # Make sure that x and y are of length 1
  if (unit.length(x) > 1 | unit.length(y) > 1)
    stop("x and y must have length 1")
  grid.grob(list(x=x, y=y, gp=gp, vp=vp), "line.to", draw)
}

######################################
# LINES primitive
######################################
draw.details.lines <- function(x, x.wrapped, recording=TRUE) {
  grid.Call.graphics("L_lines", x$x, x$y)
}

# 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,
                   gp=gpar(), draw=TRUE, 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)
  l <- list(x=x, y=y, gp=gp, vp=vp)
  cl <- "lines"
  grid.grob(l, cl, draw)
}

######################################
# SEGMENTS primitive
######################################
draw.details.segments <- function(x, x.wrapped, 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
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,
                      gp=gpar(), draw=TRUE, 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)
  s <- list(x0=x0, y0=y0, x1=x1, y1=y1, gp=gp, vp=vp)
  cl <- "segments"
  grid.grob(s, cl, draw)
}

######################################
# ARROWS primitive
######################################
draw.details.arrows <- function(x, x.wrapped, recording=TRUE) {
  if (is.null(x$x)) { # y should be null too
    if (!is.null(x$y))
      stop("Corrupt arrows object")
    list.struct <- get.value(x$grob)
#    cl <- class(list.struct)
    # 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(list.struct, "line.to")) {
      x1 <- NULL
      x2 <- list.struct$x
      y1 <- NULL
      y2 <- list.struct$y
      xnm1 <- NULL
      xn <- list.struct$x
      ynm1 <- NULL
      yn <- list.struct$y
    } else if (inherits(list.struct, "lines")) {
      # x or y may be recycled
      n <- max(unit.length(list.struct$x),
               unit.length(list.struct$y))
      xx <- unit.rep(list.struct$x, length=2)
      x1 <- xx[1]
      x2 <- xx[2]
      xx <- unit.rep(list.struct$x, length=n)
      xnm1 <- xx[n - 1]
      xn <- xx[n]
      yy <- unit.rep(list.struct$y, length=2)
      y1 <- yy[1]
      y2 <- yy[2]
      yy <- unit.rep(list.struct$y, length=n)
      ynm1 <- yy[n - 1]
      yn <- yy[n]
    } else { # inherits(list.struct, "segments")
      x1 <- list.struct$x0
      x2 <- list.struct$x1
      xnm1 <- list.struct$x0
      xn <- list.struct$x1
      y1 <- list.struct$y0
      y2 <- list.struct$y1
      ynm1 <- list.struct$y0
      yn <- list.struct$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)
}

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",
                        gp=gpar(), draw=TRUE, vp=NULL) {
  # If grob is specified, that overrides any x and y values
  if (!is.null(grob)) {
    if (!is.grob(grob))
      stop("The grob argument must be of class grob")
    list.struct <- get.value(grob)
    cl <- class(list.struct)
    # The grob can only be a "lines" or "segments"
    # (splines would be another candidate if they existed)
    if (!(inherits(list.struct, "lines") ||
          inherits(list.struct, "segments") ||
          inherits(list.struct, "line.to")))
      stop("The grob argument must be a line.to, lines, or segments grob")
    x <- y <- NULL
  } else {
    if (!is.unit(x))
      x <- unit(x, default.units)
    if (!is.unit(y))
      y <- unit(y, default.units)
  }
  if (!is.unit(length))
    stop("Length must be a unit object")
  ends <- as.integer(match(ends, c("first", "last", "both")))
  type <- as.integer(match(type, c("open", "closed")))
  if (any(is.na(ends)) || any(is.na(type)))
    stop("Invalid ends or type argument")
  a <- list(x=x, y=y, grob=grob,
            angle=as.numeric(angle), length=length,
            ends=ends, type=type, gp=gp, vp=vp)
  cl <- "arrows"
  grid.grob(a, cl, draw)
}

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

draw.details.polygon <- function(x, x.wrapped, recording=TRUE) {
  grid.Call.graphics("L_polygon", x$x, x$y)
}

grid.polygon <- function(x=c(0, 0.5, 1, 0.5), y=c(0.5, 1, 0.5, 0),
                         default.units="npc",
                         gp=gpar(),draw=TRUE, vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  p <- list(x=x, y=y, gp=gp, vp=vp)
  cl <- "polygon"
  grid.grob(p, cl, draw)
}

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

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

grid.circle <- function(x=0.5, y=0.5, r=0.5,
                         default.units="npc",
                         gp=gpar(),draw=TRUE, 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)
  c <- list(x=x, y=y, r=r, gp=gp, vp=vp)
  cl <- "circle"
  grid.grob(c, cl, draw)
}

######################################
# RECT primitive
######################################
draw.details.rect <- function(x, x.wrapped, recording=TRUE) {
  grid.Call.graphics("L_rect", x$x, x$y, x$width, x$height,
                     valid.just(x$just))
}

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

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

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",
                      gp=gpar(),draw=TRUE, 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)
  r <- list(x=x, y=y, width=width, height=height, just=just, gp=gp, vp=vp)
  cl <- "rect"
  grid.grob(r, cl, draw)
}

######################################
# TEXT primitive
######################################
draw.details.text <- function(x, x.wrapped, recording=TRUE) {
  # FIXME:  Need type checking for "rot" and "check.overlap"
  grid.Call.graphics("L_text", x$label, x$x, x$y,
                 valid.just(x$just), x$rot, x$check.overlap)
}

width.details.text <- function(x) {
  unit(1, "mystrwidth", data=x$label)
}

height.details.text <- function(x) {
  unit(1, "mystrheight", data=x$label)
}

grid.text <- function(label, x=unit(0.5, "npc"), y=unit(0.5, "npc"),
                  just="centre", rot=0, check.overlap=FALSE,
                  default.units="npc", gp=gpar(), draw=TRUE, vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  if (!is.expression(label))
    label <- as.character(label)
  rot <- as.numeric(rot)
  if (!is.finite(rot))
    stop("Invalid rot value")
  txt <- list(label=label, x=x, y=y, gp=gp,
              just=just, rot=rot, check.overlap=check.overlap,
              vp=vp)
  cl <- "text"
  grid.grob(txt, cl, draw)
}

######################################
# POINTS primitive
######################################
draw.details.points <- function(x, x.wrapped, recording=TRUE) {
  grid.Call.graphics("L_points", x$x, x$y, x$pch, x$size)
}

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
}

grid.points <- function(x=runif(10),
                        y=runif(10),
                        pch=1, size=unit(1, "char"),
                        default.units="native", gp=gpar(),
                        draw=TRUE, vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  if (unit.length(x) != unit.length(y))
    stop("x and y must be unit objects and have the same length")
  p <- list(x=x, y=y, pch=valid.pch(pch), size=size, gp=gp, vp=vp)
  cl <- "points"
  grid.grob(p, cl, draw)
}

# These functions are used to evaluate "grobwidth" and
# "grobheight" units.
# They are actually called from within the C code
# (specifically, from within unit.c) and should NOT be called
# from the command line in normal use.
# The width.pre function sets up the correct graphical context (
# gpar settings) for the grob.  The basic idea is that the width
# of a grob has to be evaluated within the same context as would
# be used to draw the grob.  For simple grobs, there should be
# nothing to do beyond the default given here.

# NOTE that we do NOT push any viewports.  That would probably create
# an infinite loop (because push.viewport would call set.viewport
# which would attempt to recalculate the entire viewport transform,
# which may get back to here if we originally got here due to
# calculating a viewport transform;  i.e., if we started with a
# viewport or layout that was using "grobwidth" or "grobheight" units)

# NOTE that the above note implies that we should NOT return a unit
# in the width.details method that relies on having the correct
# viewport set up.  In other words we should only return "absolute"
# units;  there is a function at the end of this file to help with this.

# For complex grobs, e.g., ones which
# construct their own viewports, it may be necessary to do extra
# setting up by writing a width.pre.details method.
# The width function just returns a unit object.
# The width.post function is important for reversing all of the
# setting up that was done in the width.pre function.  Again, for
# simple grobs there should be nothing to do beyond the default.

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

# NOTE that I have to do this in R rather than C code because
# I can't set par() values from C (yet !)
# ALSO NOTE that I have to set par() values for "strwidth" and 
# "strheight" units to work;  they rely on GStrWidth/Height which
# refer to par() values
# We are just setting graphical parameters
# We do NOT push any viewports !!
width.pre <- function(x) {
  list.struct <- get.value(x)
  # If the grob has a viewport, then we treat it as if we want
  # the width of the viewport rather than width of the grob
  if (!is.null(list.struct$vp))
    gp <- list.struct$vp$gp
  else
    gp <- list.struct$gp
  if (!is.null(gp))
    set.gpar(gp)
  if (!is.null(list.struct$vp))
    width.pre.details(list.struct$vp)
  else
    width.pre.details(list.struct)
}

width.pre.details <- function(x) {
  UseMethod("width.pre.details")
}

width.pre.details.default <- function(x) {}

width <- function(x) {
  list.struct <- get.value(x)
  # If the grob has a viewport, then we treat it as if we want
  # the width of the viewport rather than width of the grob
  if (!is.null(list.struct$vp))
    width.details(list.struct$vp)
  else
    width.details(list.struct)
}

width.details <- function(x) {
  UseMethod("width.details", x)
}

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

# We are just unsetting graphical parameters
# We do NOT pop any viewports !!
width.post <- function(x) {
  list.struct <- get.value(x)
  # If the grob has a viewport, then we treat it as if we want
  # the width of the viewport rather than width of the grob
  if (!is.null(list.struct$vp))
    width.post.details(list.struct$vp)
  else
    width.post.details(list.struct)
  if (!is.null(list.struct$vp))
    gp <- list.struct$vp$gp
  else
    gp <- list.struct$gp
  if (!is.null(gp))
    unset.gpar(gp)
}

width.post.details <- function(x) {
  UseMethod("width.post.details")
}

width.post.details.default <- function(x) {}

#########
# HEIGHTS
#########

# We are just setting graphical parameters
# We do NOT push any viewports !!
height.pre <- function(x) {
  list.struct <- get.value(x)
  # If the grob has a viewport, then we treat it as if we want
  # the height of the viewport rather than height of the grob
  if (!is.null(list.struct$vp))
    gp <- list.struct$vp$gp
  else
    gp <- list.struct$gp
  if (!is.null(gp))
    set.gpar(gp)
  if (!is.null(list.struct$vp))
    height.pre.details(list.struct$vp)
  else
    height.pre.details(list.struct)
}

height.pre.details <- function(x) {
  UseMethod("height.pre.details")
}

height.pre.details.default <- function(x) {}

height <- function(x) {
  list.struct <- get.value(x)
  # If the grob has a viewport, then we treat it as if we want
  # the height of the viewport rather than height of the grob
  if (!is.null(list.struct$vp))
    height.details(list.struct$vp)
  else
    height.details(list.struct)
}

height.details <- function(x) {
  UseMethod("height.details", x)
}

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

# We are just unsetting graphical parameters
# We do NOT pop any viewports !!
height.post <- function(x) {
  list.struct <- get.value(x)
  # If the grob has a viewport, then we treat it as if we want
  # the height of the viewport rather than height of the grob
  if (!is.null(list.struct$vp))
    height.post.details(list.struct$vp)
  else
    height.post.details(list.struct)
  if (!is.null(list.struct$vp))
    gp <- list.struct$vp$gp
  else
    gp <- list.struct$gp
  if (!is.null(gp))
    unset.gpar(gp)
}

height.post.details <- function(x) {
  UseMethod("height.post.details")
}

height.post.details.default <- function(x) {}

#########
# 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
# I outlaw them;  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")
#
# NOTE that I included "lines" amongst the absolute units above, even
# though these depend on the parent context in the sense that the
# parent may specify a value for lineheight or fontsize.
# This is ok because these are "absolute" graphical parameters that do not
# themselves depend on the parent's size (by contrast, "npc" units
# and "native" units depend on the parent's size).

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)
  if (is.character(data) || is.expression(data) || is.grob(data))
    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) {
  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) {
  grid.convert(x, unitTo, "x", "location", "x", "location",
               valueOnly=valueOnly)
}

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

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

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

convertNative <- function(unit, dimension="x", type="location") {
  .Deprecated("grid.convert")
  grid.convert(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]])))
        stop("No grob supplied for `grobwidth' unit")
    }
  grob.units <- units == "grobheight"
  if (any(grob.units != 0))
    for (i in (1:n)[grob.units]) {
      if (!(length(data) >= i && is.grob(data[[i]])))
        stop("No grob supplied for `grobheight' unit")
    }
  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
        unit.arithmetic(.Generic, e2, e1)
      else
        stop("Non-unit operand must be numeric")
    } else {
      if (is.numeric(e1))
        unit.arithmetic(.Generic, 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),
         "*"=x$arg1 *
             "["(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)
}

#########################
# 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)))
}



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")
}


valid.viewport <- function(x, y, width, height, just, 
                           gp, clip,
                           xscale, yscale, angle,
                           layout, layout.pos.row, layout.pos.col) {
  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")
  clip <- as.logical(clip)
  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.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))
  # Put all the valid things first so that are found quicker
  vp <- list(x = x, y = y, width = width, height = height,
             valid.just = valid.just(just),
             layout = layout,
             valid.pos.row = layout.pos.row,
             valid.pos.col = layout.pos.col,
             gp = gp,
             clip = clip,
             # A viewport may have a specification of fontsize
             # and lineheight in the gpar, BUT it does not have to
             # If it does not, then that means it will just use
             # whatever is the "current" setting of fontsize
             # and lineheight.
             # "current" means at drawing time, which means when
             # L_setviewport is called.
             # We record here the "current" value so that we can
             # reset the value when a child viewport is popped.
             # Ditto font.
             cur.fontfamily = NULL,
             cur.font = NULL,
             cur.fontsize = NULL,
             cur.lineheight = NULL,
             # When L_setviewport is called, we also record
             # the transformation and layout for the viewport
             # so that we don't have to recalculate it every
             # time (until the device changes size)
             cur.trans = NULL,
             cur.widths = NULL,
             cur.heights = NULL,
             cur.width.cm = NULL,
             cur.height.cm = NULL,
             cur.rotation = NULL,
             cur.clip = NULL,
             xscale = xscale,
             yscale = yscale,
             angle = angle,
             parent = NULL,
             justification = just,
             layout.pos.row = layout.pos.row,
             layout.pos.col = layout.pos.col)
  class(vp) <- "viewport"
  vp
}

print.viewport <- function(x, ...) {
  print(class(x))
}

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

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

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

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

viewport.transform <- function(vp) {
  vp$cur.trans
}

####################
# 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 = FALSE,
                     # 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) {
  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)
}

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

#############
# 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.


.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)
}
