R/primitives.R

In thomasp85/grid: The Grid Graphics Package

#  File src/library/grid/R/primitives.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2018 The R Core Team
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/


# Function that creates a description of an arrow head
# to add to a line
arrow <- function(angle=30, length=unit(0.25, "inches"),
                  ends="last", type="open") {
    angle <- as.numeric(angle)
    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 (anyNA(ends) || anyNA(type) ||
        length(ends) == 0 || length(type) == 0)
        stop("invalid 'ends' or 'type' argument")
    a <- list(angle=angle, length=length,
              ends=ends, type=type)
    class(a) <- "arrow"
    a
}

length.arrow <- function(x) {
    max(do.call("max", lapply(x, length)),
                length(x$length))
}

rep.arrow <- function(x, ...) {
    maxn <- length(x)
    newa <- list(angle=rep(x$angle, length.out=maxn),
                 length=rep(x$length, length.out=maxn),
                 ends=rep(x$ends, length.out=maxn),
                 type=rep(x$type, length.out=maxn))
    newa <- lapply(newa, rep, ...)
    class(newa) <- "arrow"
    newa
}

# Method for subsetting "arrow" objects
`[.arrow` <- function(x, index, ...) {
    if (length(index) == 0)
        return(NULL)
    maxn <- length(x)
    newa <- list(angle=rep(x$angle, length.out=maxn),
                 length=rep(x$length, length.out=maxn),
                 ends=rep(x$ends, length.out=maxn),
                 type=rep(x$type, length.out=maxn))
    newa <- lapply(X = newa, FUN = "[", index, ...)
    class(newa) <- "arrow"
    newa
}

str.arrow <- function(object, ...) {
  o <- oldClass(object)
  oldClass(object) <- setdiff(o, "arrow")
  str(object)
}

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

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

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

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

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

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

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

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

######################################
# LINES primitive
######################################
validDetails.lines <- function(x) {
  if (!is.unit(x$x) ||
      !is.unit(x$y))
    stop("'x' and 'y' must be units")
  if (!(is.null(x$arrow) || inherits(x$arrow, "arrow")))
      stop("invalid 'arrow' argument")
  x
}

drawDetails.lines <- function(x, recording=TRUE) {
    grid.Call.graphics(C_lines, x$x, x$y,
                       list(as.integer(1L:max(length(x$x), length(x$y)))),
                       x$arrow)
}

xDetails.lines <- function(x, theta) {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[1L], "inches")
}

yDetails.lines <- function(x, theta) {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[2L], "inches")
}

widthDetails.lines <- function(x) {
  bounds <- grid.Call(C_locnBounds, x$x, x$y, 0)
  if (is.null(bounds))
    unit(0, "inches")
  else
    unit(bounds[3L], "inches")
}

heightDetails.lines <- function(x) {
  bounds <- grid.Call(C_locnBounds, x$x, x$y, 0)
  if (is.null(bounds))
    unit(0, "inches")
  else
    unit(bounds[4L], "inches")
}

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

grid.lines <- function(x=unit(c(0, 1), "npc"),
                       y=unit(c(0, 1), "npc"),
                       default.units="npc",
                       arrow=NULL,
                       name=NULL, gp=gpar(), draw=TRUE, vp=NULL) {
  lg <- linesGrob(x=x, y=y,
                  default.units=default.units, arrow=arrow,
                  name=name, gp=gp, vp=vp)
  if (draw)
    grid.draw(lg)
  invisible(lg)
}

######################################
# POLYLINES primitive
######################################
# Very similar to LINES primitive, but allows
# multiple polylines via 'id' and 'id.lengths' args
# as per POLYGON primitive
validDetails.polyline <- function(x) {
  if (!is.unit(x$x) ||
      !is.unit(x$y))
      stop("'x' and 'y' must be units")
  if (!is.null(x$id) && !is.null(x$id.lengths))
      stop("it is invalid to specify both 'id' and 'id.lengths'")
  if (length(x$x) != length(x$y))
      stop("'x' and 'y' must be same length")
  if (!is.null(x$id) && (length(x$id) != length(x$x)))
      stop("'x' and 'y' and 'id' must all be same length")
  if (!is.null(x$id))
      x$id <- as.integer(x$id)
  if (!is.null(x$id.lengths) && (sum(x$id.lengths) != length(x$x)))
      stop("'x' and 'y' and 'id.lengths' must specify same overall length")
  if (!is.null(x$id.lengths))
      x$id.lengths <- as.integer(x$id.lengths)
  if (!(is.null(x$arrow) || inherits(x$arrow, "arrow")))
      stop("invalid 'arrow' argument")
  x
}

drawDetails.polyline <- function(x, recording=TRUE) {
    if (is.null(x$id) && is.null(x$id.lengths))
        grid.Call.graphics(C_lines, x$x, x$y,
                           list(as.integer(seq_along(x$x))),
                           x$arrow)
    else {
        if (is.null(x$id)) {
            n <- length(x$id.lengths)
            id <- rep(1L:n, x$id.lengths)
        } else {
            n <- length(unique(x$id))
            id <- x$id
        }
        index <- split(as.integer(seq_along(x$x)), id)
        grid.Call.graphics(C_lines, x$x, x$y, index, x$arrow)
    }
}

xDetails.polyline <- function(x, theta) {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[1L], "inches")
}

yDetails.polyline <- function(x, theta) {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[2L], "inches")
}

widthDetails.polyline <- function(x) {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, 0)
    if (is.null(bounds))
        unit(0, "inches")
    else
        unit(bounds[3L], "inches")
}

heightDetails.polyline <- function(x) {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, 0)
    if (is.null(bounds))
        unit(0, "inches")
    else
        unit(bounds[4L], "inches")
}

polylineGrob <- function(x=unit(c(0, 1), "npc"),
                         y=unit(c(0, 1), "npc"),
                         id=NULL, id.lengths=NULL,
                         default.units="npc",
                         arrow=NULL,
                         name=NULL, gp=gpar(), vp=NULL) {
    # Allow user to specify unitless vector;  add default units
    if (!is.unit(x))
        x <- unit(x, default.units)
    if (!is.unit(y))
        y <- unit(y, default.units)
    grob(x=x, y=y, id=id, id.lengths=id.lengths,
         arrow=arrow, name=name, gp=gp, vp=vp, cl="polyline")
}

grid.polyline <- function(...) {
    grid.draw(polylineGrob(...))
}

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

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

segmentBounds <- function(x, theta) {
    n <- max(length(x$x0), length(x$x1),
             length(x$y0), length(x$y1))
    x0 <- rep(x$x0, length.out=n)
    x1 <- rep(x$x1, length.out=n)
    y0 <- rep(x$y0, length.out=n)
    y1 <- rep(x$y1, length.out=n)
    grid.Call(C_locnBounds, unit.c(x0, x1), unit.c(y0, y1), theta)
}

xDetails.segments <- function(x, theta) {
    bounds <- segmentBounds(x, theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[1L], "inches")
}

yDetails.segments <- function(x, theta) {
    bounds <- segmentBounds(x, theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[2L], "inches")
}

widthDetails.segments <- function(x) {
    bounds <- segmentBounds(x, 0)
    if (is.null(bounds))
        unit(0, "inches")
    else
        unit(bounds[3L], "inches")
}

heightDetails.segments <- function(x) {
    bounds <- segmentBounds(x, 0)
    if (is.null(bounds))
        unit(0, "inches")
    else
        unit(bounds[4L], "inches")
}

segmentsGrob <- function(x0=unit(0, "npc"), y0=unit(0, "npc"),
                         x1=unit(1, "npc"), y1=unit(1, "npc"),
                         default.units="npc",
                         arrow=NULL,
                         name=NULL, gp=gpar(), vp=NULL) {
  # Allow user to specify unitless vector;  add default units
  if (!is.unit(x0))
    x0 <- unit(x0, default.units)
  if (!is.unit(x1))
    x1 <- unit(x1, default.units)
  if (!is.unit(y0))
    y0 <- unit(y0, default.units)
  if (!is.unit(y1))
    y1 <- unit(y1, default.units)
  grob(x0=x0, y0=y0, x1=x1, y1=y1, arrow=arrow, name=name, gp=gp, vp=vp,
       cl="segments")
}

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

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

# Superceded by 'arrow' arg to line-drawing primitives
# which contains an "arrow" object
validDetails.arrows <- function(x) {
  if ((!is.null(x$x) && !is.unit(x$x)) ||
      (!is.null(x$y) && !is.unit(x$y)))
    stop("'x' and 'y' must be units or NULL")
  if (!is.unit(x$length))
    stop("'length' must be a 'unit' object")
  x$ends <- as.integer(match(x$ends, c("first", "last", "both")))
  x$type <- as.integer(match(x$type, c("open", "closed")))
  if (any(is.na(x$ends)) || any(is.na(x$type)))
    stop("invalid 'ends' or 'type' argument")
  x
}

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

widthDetails.arrows <- function(x) {
  if (is.null(x$x)) { # y should be null too
    if (!is.null(x$y))
      stop("corrupt 'arrows' object")
    lineThing <- getGrob(x, childNames(x))
    widthDetails(lineThing)
  } else {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, 0)
    if (is.null(bounds))
      unit(0, "inches")
    else
      unit(bounds[3L], "inches")
  }
}

heightDetails.arrows <- function(x) {
  if (is.null(x$x)) { # y should be null too
    if (!is.null(x$y))
      stop("corrupt 'arrows' object")
    lineThing <- getGrob(x, childNames(x))
    heightDetails(lineThing)
  } else {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, 0)
    if (is.null(bounds))
      unit(0, "inches")
    else
      unit(bounds[4L], "inches")
  }
}

arrowsGrob <- function(x=c(0.25, 0.75), y=0.5,
                       default.units="npc",
                       grob=NULL,
                       angle=30, length=unit(0.25, "inches"),
                       ends="last", type="open",
                       name=NULL, gp=gpar(), vp=NULL) {
    .Defunct(msg="'arrowsGrob' is defunct; use 'arrow' arguments to line drawing functions")
}

grid.arrows <- function(x=c(0.25, 0.75), y=0.5,
                        default.units="npc",
                        grob=NULL,
                        angle=30, length=unit(0.25, "inches"),
                        ends="last", type="open",
                        name=NULL, gp=gpar(), draw=TRUE, vp=NULL) {
    .Defunct(msg="'grid.arrows' is defunct; use 'arrow' arguments to line drawing functions")
}

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

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

drawDetails.polygon <- function(x, recording=TRUE) {
  if (is.null(x$id) && is.null(x$id.lengths))
    grid.Call.graphics(C_polygon, x$x, x$y,
                       list(as.integer(seq_along(x$x))))
  else {
    if (is.null(x$id)) {
      n <- length(x$id.lengths)
      id <- rep(1L:n, x$id.lengths)
    } else {
      n <- length(unique(x$id))
      id <- x$id
    }
    index <- split(as.integer(seq_along(x$x)), id)
    grid.Call.graphics(C_polygon, x$x, x$y, index)
  }
}

xDetails.polygon <- function(x, theta) {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[1L], "inches")
}

yDetails.polygon <- function(x, theta) {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[2L], "inches")
}

widthDetails.polygon <- function(x) {
  bounds <- grid.Call(C_locnBounds, x$x, x$y, 0)
  if (is.null(bounds))
    unit(0, "inches")
  else
    unit(bounds[3L], "inches")
}

heightDetails.polygon <- function(x) {
  bounds <- grid.Call(C_locnBounds, x$x, x$y, 0)
  if (is.null(bounds))
    unit(0, "inches")
  else
    unit(bounds[4L], "inches")
}

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

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

######################################
# PATH primitive
######################################

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

xDetails.pathgrob <- function(x, theta) {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[1L], "inches")
}

yDetails.pathgrob <- function(x, theta) {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[2L], "inches")
}

widthDetails.pathgrob <- function(x) {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, 0)
    if (is.null(bounds))
        unit(0, "inches")
    else
        unit(bounds[3L], "inches")
}

heightDetails.pathgrob <- function(x) {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, 0)
    if (is.null(bounds))
        unit(0, "inches")
    else
        unit(bounds[4L], "inches")
}


drawDetails.pathgrob <- function(x, recording=TRUE) {
    hasMultiple <- !(is.null(x$pathId) && is.null(x$pathId.lengths))
    if (hasMultiple) {
        if (is.null(x$pathId)) {
            n <- length(x$pathId.lengths)
            pathId <- rep(1L:n, x$pathId.lengths)
        } else {
            pathId <- x$pathId
        }
    }
    if (is.null(x$id) && is.null(x$id.lengths)) {
        if (hasMultiple) {
            grid.Call.graphics(C_polygon, x$x, x$y,
                               split(as.integer(seq_along(x$x)), pathId))
        } else {
            grid.Call.graphics(C_polygon, x$x, x$y,
                               list(as.integer(seq_along(x$x))))
        }
    } else {
        if (is.null(x$id)) {
            n <- length(x$id.lengths)
            id <- rep(1L:n, x$id.lengths)
        } else {
            n <- length(unique(x$id))
            id <- x$id
        }
        if (hasMultiple) {
            index <- mapply(split,
                            x=split(as.integer(seq_along(x$x)), pathId), 
                            f=split(id, pathId),
                            SIMPLIFY = FALSE, USE.NAMES = FALSE)
        } else {
            index <- list(split(as.integer(seq_along(x$x)), id))
        }
        grid.Call.graphics(C_path, x$x, x$y, index,
                           switch(x$rule, winding=1L, evenodd=0L))
    }
}

pathGrob <- function(x, y,
                     id=NULL, id.lengths=NULL,
                     pathId=NULL, pathId.lengths=NULL,
                     rule="winding",
                     default.units="npc",
                     name=NULL, gp=gpar(), vp=NULL) {
    if (!is.unit(x))
        x <- unit(x, default.units)
    if (!is.unit(y))
        y <- unit(y, default.units)
    grob(x=x, y=y, id=id, id.lengths=id.lengths,
         pathId=pathId, pathId.lengths=pathId.lengths,
         rule=rule,
         name=name, gp=gp, vp=vp, cl="pathgrob")
}

grid.path <- function(...) {
  grid.draw(pathGrob(...))
}

######################################
# XSPLINE primitive
######################################

validDetails.xspline <- function(x) {
  if (!is.unit(x$x) ||
      !is.unit(x$y))
    stop("x and y must be units")
  if (!is.null(x$id) && !is.null(x$id.lengths))
    stop("it is invalid to specify both 'id' and 'id.lengths'")
  nx <- length(x$x)
  ny <- length(x$y)
  if (nx != ny)
    stop("'x' and 'y' must be same length")
  if (!is.null(x$id) && (length(x$id) != nx))
    stop("'x' and 'y' and 'id' must all be same length")
  if (!is.null(x$id))
    x$id <- as.integer(x$id)
  if (!is.null(x$id.lengths) && (sum(x$id.lengths) != nx))
    stop("'x' and 'y' and 'id.lengths' must specify same overall length")
  if (!is.null(x$id.lengths))
    x$id.lengths <- as.integer(x$id.lengths)
  if (!(is.null(x$arrow) || inherits(x$arrow, "arrow")))
      stop("invalid 'arrow' argument")
  if (any(x$shape < -1 | x$shape > 1))
    stop("'shape' must be between -1 and 1")
  x$open <- as.logical(x$open)
  # Force all first and last shapes to be 0 for open xsplines
  if (x$open) {
      x$shape <- rep(x$shape, length.out=nx)
      # Watch out for id or id.length!
      index <- xsplineIndex(x)
      first <- sapply(index, min)
      last <- sapply(index, max)
      x$shape[c(first, last)] <- 0
  }
  x
}

xsplineIndex <- function(x) {
  if (is.null(x$id) && is.null(x$id.lengths))
      list(as.integer(seq_along(x$x)))
  else {
    if (is.null(x$id)) {
      n <- length(x$id.lengths)
      id <- rep(1L:n, x$id.lengths)
    } else {
      n <- length(unique(x$id))
      id <- x$id
    }
    split(as.integer(seq_along(x$x)), id)
  }
}

drawDetails.xspline <- function(x, recording=TRUE) {
    grid.Call.graphics(C_xspline, x$x, x$y, x$shape, x$open, x$arrow,
                       x$repEnds, xsplineIndex(x))
}

xDetails.xspline <- function(x, theta) {
  bounds <- grid.Call(C_xsplineBounds, x$x, x$y, x$shape, x$open, x$arrow,
                      x$repEnds, xsplineIndex(x), theta)
  if (is.null(bounds))
    unit(0.5, "npc")
  else
    unit(bounds[1L], "inches")
}

yDetails.xspline <- function(x, theta) {
  bounds <- grid.Call(C_xsplineBounds, x$x, x$y, x$shape, x$open, x$arrow,
                      x$repEnds, xsplineIndex(x), theta)
  if (is.null(bounds))
    unit(0.5, "npc")
  else
    unit(bounds[2L], "inches")
}

widthDetails.xspline <- function(x) {
  bounds <- grid.Call(C_xsplineBounds, x$x, x$y, x$shape, x$open, x$arrow,
                      x$repEnds, list(as.integer(seq_along(x$x))), 0)
  if (is.null(bounds))
    unit(0, "inches")
  else
    unit(bounds[3L], "inches")
}

heightDetails.xspline <- function(x) {
  bounds <- grid.Call(C_xsplineBounds, x$x, x$y, x$shape, x$open, x$arrow,
                      x$repEnds, list(as.integer(seq_along(x$x))), 0)
  if (is.null(bounds))
    unit(0, "inches")
  else
    unit(bounds[4L], "inches")
}

xsplineGrob <- function(x=c(0, 0.5, 1, 0.5), y=c(0.5, 1, 0.5, 0),
                        id=NULL, id.lengths=NULL,
                        default.units="npc",
                        shape=0, open=TRUE, arrow=NULL, repEnds=TRUE,
                        name=NULL, gp=gpar(), vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  grob(x=x, y=y, shape=shape, open=open,
       id=id, id.lengths=id.lengths, arrow=arrow, repEnds=repEnds,
       name=name, gp=gp, vp=vp, cl="xspline")
}

grid.xspline <- function(...) {
  grid.draw(xsplineGrob(...))
}

xsplinePoints <- function(x) {
    # Mimic drawGrob() to ensure x$vp and x$gp enforced
    dlon <- grid.Call(C_setDLon, FALSE)
    on.exit(grid.Call(C_setDLon, dlon))
    tempgpar <- grid.Call(C_getGPar)
    on.exit(grid.Call(C_setGPar, tempgpar), add=TRUE)
    preDraw(x)
    # Raw pts in dev coords
    devPoints <- grid.Call(C_xsplinePoints,
                           x$x, x$y, x$shape, x$open, x$arrow,
                           x$repEnds, xsplineIndex(x), 0)
    postDraw(x)
    # Convert to units in inches
    unitPoints <- lapply(devPoints,
                         function(x) {
                             names(x) <- c("x", "y")
                             x$x <- unit(x$x, "inches")
                             x$y <- unit(x$y, "inches")
                             x
                         })
    if (length(unitPoints) == 1)
        unitPoints <- unitPoints[[1]]
    unitPoints
}

######################################
# BEZIER primitive
######################################

# A bezier grob that works of a (not-100% accurate) approximation
# using X-splines

# X-Spline approx to Bezier
Ms <- 1/6*rbind(c(1, 4, 1, 0),
                c(-3, 0, 3, 0),
                c(3, -6, 3, 0),
                c(-1, 3, -3, 1))
Msinv <- solve(Ms)
# Bezier control matrix
Mb <- rbind(c(1, 0, 0, 0),
            c(-3, 3, 0, 0),
            c(3, -6, 3, 0),
            c(-1, 3, -3, 1))

splinePoints <- function(xb, yb, idIndex) {
    xs <- unlist(lapply(idIndex,
                        function(i) {
                            Msinv %*% Mb %*% xb[i]
                        }))
    ys <- unlist(lapply(idIndex,
                        function(i) {
                            Msinv %*% Mb %*% yb[i]
                        }))
    list(x=xs, y=ys)
}

splinegrob <- function(x) {
    xx <- convertX(x$x, "inches", valueOnly=TRUE)
    yy <- convertY(x$y, "inches", valueOnly=TRUE)
    sp <- splinePoints(xx, yy, xsplineIndex(x))
    xsplineGrob(sp$x, sp$y, default.units="inches",
                id=x$id, id.lengths=x$id.lengths,
                shape=1, repEnds=FALSE,
                arrow=x$arrow, name=x$name,
                gp=x$gp, vp=x$vp)
}

validDetails.beziergrob <- function(x) {
    if (!is.unit(x$x) ||
        !is.unit(x$y))
        stop("x and y must be units")
    if (!is.null(x$id) && !is.null(x$id.lengths))
        stop("it is invalid to specify both 'id' and 'id.lengths'")
    nx <- length(x$x)
    ny <- length(x$y)
    if (nx != ny)
        stop("'x' and 'y' must be same length")
    if (!is.null(x$id) && (length(x$id) != nx))
        stop("'x' and 'y' and 'id' must all be same length")
    if (!is.null(x$id))
        x$id <- as.integer(x$id)
    if (!is.null(x$id.lengths) && (sum(x$id.lengths) != nx))
        stop("'x' and 'y' and 'id.lengths' must specify same overall length")
    if (!is.null(x$id.lengths))
        x$id.lengths <- as.integer(x$id.lengths)
    if (is.null(x$id) && is.null(x$id.lengths)) {
        if (length(x$x) != 4L)
            stop("must have exactly 4 control points")
    } else {
        if (is.null(x$id)) {
            n <- length(x$id.lengths)
            id <- rep(1L:n, x$id.lengths)
        } else {
            id <- x$id
        }
        xper <- split(x$x, id)
        if (any(lengths(xper) != 4L))
            stop("must have exactly 4 control points per Bezier curve")
    }
    if (!(is.null(x$arrow) || inherits(x$arrow, "arrow")))
        stop("invalid 'arrow' argument")
    x
}

makeContent.beziergrob <- function(x) {
    splinegrob(x)
}

xDetails.beziergrob <- function(x, theta) {
    xDetails(splinegrob(x), theta)
}

yDetails.beziergrob <- function(x, theta) {
    yDetails(splinegrob(x), theta)
}

widthDetails.beziergrob <- function(x) {
    widthDetails(splinegrob(x))
}

heightDetails.beziergrob <- function(x) {
    heightDetails(splinegrob(x))
}

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

grid.bezier <- function(...) {
    grid.draw(bezierGrob(...))
}

bezierPoints <- function(x) {
    sg <- splinegrob(x)
    # splinegrob() does not make use of x$vp
    sg$vp <- x$vp
    xsplinePoints(sg)
}


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

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

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

xDetails.circle <- function(x, theta) {
  bounds <- grid.Call(C_circleBounds, x$x, x$y, x$r, theta)
  if (is.null(bounds))
    unit(0.5, "npc")
  else
    unit(bounds[1L], "inches")
}

yDetails.circle <- function(x, theta) {
  bounds <- grid.Call(C_circleBounds, x$x, x$y, x$r, theta)
  if (is.null(bounds))
    unit(0.5, "npc")
  else
    unit(bounds[2L], "inches")
}

widthDetails.circle <- function(x) {
  bounds <- grid.Call(C_circleBounds, x$x, x$y, x$r, 0)
  if (is.null(bounds))
    unit(0, "inches")
  else
    unit(bounds[3L], "inches")
}

heightDetails.circle <- function(x) {
  bounds <- grid.Call(C_circleBounds, x$x, x$y, x$r, 0)
  if (is.null(bounds))
    unit(0, "inches")
  else
    unit(bounds[4L], "inches")
}

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

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

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

drawDetails.rect <- function(x, recording=TRUE) {
  grid.Call.graphics(C_rect, x$x, x$y, x$width, x$height,
                     resolveHJust(x$just, x$hjust),
                     resolveVJust(x$just, x$vjust))
}

xDetails.rect <- function(x, theta) {
  bounds <- grid.Call(C_rectBounds, x$x, x$y, x$width, x$height,
                      resolveHJust(x$just, x$hjust),
                      resolveVJust(x$just, x$vjust),
                      theta)
  if (is.null(bounds))
    unit(0.5, "npc")
  else
    unit(bounds[1L], "inches")
}

yDetails.rect <- function(x, theta) {
  bounds <- grid.Call(C_rectBounds, x$x, x$y, x$width, x$height,
                      resolveHJust(x$just, x$hjust),
                      resolveVJust(x$just, x$vjust),
                      theta)
  if (is.null(bounds))
    unit(0.5, "npc")
  else
    unit(bounds[2L], "inches")
}

widthDetails.rect <- function(x) {
  bounds <- grid.Call(C_rectBounds, x$x, x$y, x$width, x$height,
                      resolveHJust(x$just, x$hjust),
                      resolveVJust(x$just, x$vjust),
                      0)
  if (is.null(bounds))
    unit(0, "inches")
  else
    unit(bounds[3L], "inches")
}

heightDetails.rect <- function(x) {
  bounds <- grid.Call(C_rectBounds, x$x, x$y, x$width, x$height,
                      resolveHJust(x$just, x$hjust),
                      resolveVJust(x$just, x$vjust),
                      0)
  if (is.null(bounds))
    unit(0, "inches")
  else
    unit(bounds[4L], "inches")
}

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

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

######################################
# RASTER primitive
######################################

validDetails.rastergrob <- function(x) {
    if (!(is.raster(x$raster) || inherits(x$raster, "nativeRaster")))
        x$raster <- as.raster(x$raster)
    if (!is.unit(x$x) ||
        !is.unit(x$y) ||
        (!is.null(x$width) && !is.unit(x$width)) ||
        (!is.null(x$height) && !is.unit(x$height)))
        stop("'x', 'y', 'width', and 'height' must be units")
    valid.just(x$just)
    if (!is.null(x$hjust))
        x$hjust <- as.numeric(x$hjust)
    if (!is.null(x$vjust))
        x$vjust <- as.numeric(x$vjust)
    x
}

resolveRasterSize <- function(x) {
    if (is.null(x$width)) {
        if (is.null(x$height)) {
            rasterRatio <- dim(x$raster)[1]/dim(x$raster)[2]
            vpWidth <- convertWidth(unit(1, "npc"), "inches", valueOnly=TRUE)
            vpHeight <- convertHeight(unit(1, "npc"), "inches", valueOnly=TRUE)
            vpRatio <- vpHeight/vpWidth
            if (rasterRatio > vpRatio) {
                x$height <- unit(vpHeight, "inches")
                x$width <- unit(vpHeight*dim(x$raster)[2]/dim(x$raster)[1],
                                "inches")
            } else {
                x$width <- unit(vpWidth, "inches")
                x$height <- unit(vpWidth*dim(x$raster)[1]/dim(x$raster)[2],
                                 "inches")
            }
        } else {
            h <- convertHeight(x$height, "inches", valueOnly=TRUE)
            x$width <- unit(h*dim(x$raster)[2]/dim(x$raster)[1],
                            "inches")
        }
    } else {
        if (is.null(x$height)) {
            w <- convertWidth(x$width, "inches", valueOnly=TRUE)
            x$height <- unit(w*dim(x$raster)[1]/dim(x$raster)[2],
                             "inches")
        }
    }
    x
}

drawDetails.rastergrob <- function(x, recording=TRUE) {
    # At this point resolve NULL width/height based on
    # image dimensions
    x <- resolveRasterSize(x)
    if (is.null(x$width)) {
        if (is.null(x$height)) {
            rasterRatio <- dim(x$raster)[1]/dim(x$raster)[2]
            vpWidth <- convertWidth(unit(1, "npc"), "inches", valueOnly=TRUE)
            vpHeight <- convertHeight(unit(1, "npc"), "inches", valueOnly=TRUE)
            vpRatio <- vpHeight/vpWidth
            if (rasterRatio > vpRatio) {
                x$height <- unit(vpHeight, "inches")
                x$width <- unit(vpHeight*dim(x$raster)[2]/dim(x$raster)[1],
                                "inches")
            } else {
                x$width <- unit(vpWidth, "inches")
                x$height <- unit(vpWidth*dim(x$raster)[1]/dim(x$raster)[2],
                                 "inches")
            }
        } else {
            h <- convertHeight(x$height, "inches", valueOnly=TRUE)
            x$width <- unit(h*dim(x$raster)[2]/dim(x$raster)[1],
                            "inches")
        }
    } else {
        if (is.null(x$height)) {
            w <- convertWidth(x$width, "inches", valueOnly=TRUE)
            x$height <- unit(w*dim(x$raster)[1]/dim(x$raster)[2],
                             "inches")
        }
    }
    grid.Call.graphics(C_raster, x$raster,
                       x$x, x$y, x$width, x$height,
                       resolveHJust(x$just, x$hjust),
                       resolveVJust(x$just, x$vjust),
                       x$interpolate)
}

xDetails.rastergrob <- function(x, theta) {
    x <- resolveRasterSize(x)
    bounds <- grid.Call(C_rectBounds, x$x, x$y, x$width, x$height,
                        resolveHJust(x$just, x$hjust),
                        resolveVJust(x$just, x$vjust),
                        theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[1L], "inches")
}

yDetails.rastergrob <- function(x, theta) {
    x <- resolveRasterSize(x)
    bounds <- grid.Call(C_rectBounds, x$x, x$y, x$width, x$height,
                        resolveHJust(x$just, x$hjust),
                        resolveVJust(x$just, x$vjust),
                        theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[2L], "inches")
}

widthDetails.rastergrob <- function(x) {
    x <- resolveRasterSize(x)
    bounds <- grid.Call(C_rectBounds, x$x, x$y, x$width, x$height,
                        resolveHJust(x$just, x$hjust),
                        resolveVJust(x$just, x$vjust),
                        0)
    if (is.null(bounds))
        unit(0, "inches")
    else
        unit(bounds[3L], "inches")
}

heightDetails.rastergrob <- function(x) {
    x <- resolveRasterSize(x)
    bounds <- grid.Call(C_rectBounds, x$x, x$y, x$width, x$height,
                        resolveHJust(x$just, x$hjust),
                        resolveVJust(x$just, x$vjust),
                        0)
    if (is.null(bounds))
        unit(0, "inches")
    else
        unit(bounds[4L], "inches")
}

rasterGrob <- function(image,
                       x=unit(0.5, "npc"), y=unit(0.5, "npc"),
                       width=NULL, height=NULL,
                       just="centre", hjust=NULL, vjust=NULL,
                       interpolate=TRUE,
                       default.units="npc",
                       name=NULL, gp=gpar(), vp=NULL) {

    if (inherits(image, "nativeRaster"))
        raster <- image
    else
        raster <- as.raster(image)
    if (!is.unit(x))
        x <- unit(x, default.units)
    if (!is.unit(y))
        y <- unit(y, default.units)
    if (!is.null(width) && !is.unit(width))
        width <- unit(width, default.units)
    if (!is.null(height) && !is.unit(height))
        height <- unit(height, default.units)
    grob(raster=raster, x=x, y=y, width=width, height=height, just=just,
         hjust=hjust, vjust=vjust, interpolate=interpolate,
         name=name, gp=gp, vp=vp, cl="rastergrob")
}

grid.raster <- function(image,
                        x=unit(0.5, "npc"), y=unit(0.5, "npc"),
                        width=NULL, height=NULL,
                        just="centre", hjust=NULL, vjust=NULL,
                        interpolate=TRUE,
                        default.units="npc",
                        name=NULL, gp=gpar(), vp=NULL) {
    rg <- rasterGrob(image,
                     x=x, y=y, width=width, height=height, just=just,
                     hjust=hjust, vjust=vjust, interpolate=interpolate,
                     default.units=default.units,
                     name=name, gp=gp, vp=vp)
    grid.draw(rg)
}

######################################
# TEXT primitive
######################################
validDetails.text <- function(x) {
  if (!is.language(x$label))
    x$label <- as.character(x$label)
  if (!is.unit(x$x) ||
      !is.unit(x$y))
    stop("'x' and 'y' must be units")
  x$rot <- as.numeric(x$rot)
  if (!all(is.finite(x$rot)) || length(x$rot) == 0)
    stop("invalid 'rot' value")
  valid.just(x$just)
  if (!is.null(x$hjust))
    x$hjust <- as.numeric(x$hjust)
  if (!is.null(x$vjust))
    x$vjust <- as.numeric(x$vjust)
  x$check.overlap <- as.logical(x$check.overlap)
  x
}

drawDetails.text <- function(x, recording=TRUE) {
  grid.Call.graphics(C_text, as.graphicsAnnot(x$label),
                     x$x, x$y,
                     resolveHJust(x$just, x$hjust),
                     resolveVJust(x$just, x$vjust),
                     x$rot, x$check.overlap)
}

xDetails.text <- function(x, theta) {
  bounds <- grid.Call(C_textBounds, as.graphicsAnnot(x$label),
                      x$x, x$y,
                      resolveHJust(x$just, x$hjust),
                      resolveVJust(x$just, x$vjust),
                      x$rot, theta)
  if (is.null(bounds))
    unit(0.5, "npc")
  else
    unit(bounds[1L], "inches")
}

yDetails.text <- function(x, theta) {
  bounds <- grid.Call(C_textBounds, as.graphicsAnnot(x$label),
                      x$x, x$y,
                      resolveHJust(x$just, x$hjust),
                      resolveVJust(x$just, x$vjust),
                      x$rot, theta)
  if (is.null(bounds))
    unit(0.5, "npc")
  else
    unit(bounds[2L], "inches")
}

widthDetails.text <- function(x) {
  bounds <- grid.Call(C_textBounds, as.graphicsAnnot(x$label),
                      x$x, x$y,
                      resolveHJust(x$just, x$hjust),
                      resolveVJust(x$just, x$vjust),
                      x$rot, 0)
  if (is.null(bounds))
    unit(0, "inches")
  else
    unit(bounds[3L], "inches")
}

heightDetails.text <- function(x) {
  bounds <- grid.Call(C_textBounds, as.graphicsAnnot(x$label),
                      x$x, x$y,
                      resolveHJust(x$just, x$hjust),
                      resolveVJust(x$just, x$vjust),
                      x$rot, 0)
  if (is.null(bounds))
    unit(0, "inches")
  else
    unit(bounds[4L], "inches")
}

ascentDetails.text <- function(x) {
    if (length(x$label) == 1) {
        metrics <- grid.Call(C_stringMetric, as.graphicsAnnot(x$label))
        unit(metrics[[1]], "inches")
    } else {
        heightDetails(x)
    }
}

descentDetails.text <- function(x) {
    if (length(x$label) == 1) {
        metrics <- grid.Call(C_stringMetric, as.graphicsAnnot(x$label))
        unit(metrics[[2]], "inches")
    } else {
        unit(0, "inches")
    }
}

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

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

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

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

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

# FIXME:  does not take into account the size of the symbols
xDetails.points <- function(x, theta) {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[1L], "inches")
}

yDetails.points <- function(x, theta) {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[2L], "inches")
}

widthDetails.points <- function(x) {
  bounds <- grid.Call(C_locnBounds, x$x, x$y, 0)
  if (is.null(bounds))
    unit(0, "inches")
  else
    unit(bounds[3L], "inches")
}

heightDetails.points <- function(x) {
  bounds <- grid.Call(C_locnBounds, x$x, x$y, 0)
  if (is.null(bounds))
    unit(0, "inches")
  else
    unit(bounds[4L], "inches")
}

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

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

######################################
# CLIP primitive
######################################
validDetails.clip <- function(x) {
  if (!is.unit(x$x) ||
      !is.unit(x$y) ||
      !is.unit(x$width) ||
      !is.unit(x$height))
    stop("'x', 'y', 'width', and 'height' must be units")
  if (length(x$x) > 1 || length(x$y) > 1 ||
      length(x$width) > 1 || length(x$height) > 1)
    stop("'x', 'y', 'width', and 'height' must all be units of length 1")
  valid.just(x$just)
  if (!is.null(x$hjust))
    x$hjust <- as.numeric(x$hjust)
  if (!is.null(x$vjust))
    x$vjust <- as.numeric(x$vjust)
  x
}

drawDetails.clip <- function(x, recording=TRUE) {
  grid.Call.graphics(C_clip, x$x, x$y, x$width, x$height,
                     resolveHJust(x$just, x$hjust),
                     resolveVJust(x$just, x$vjust))
}

clipGrob <- function(x=unit(0.5, "npc"), y=unit(0.5, "npc"),
                     width=unit(1, "npc"), height=unit(1, "npc"),
                     just="centre", hjust=NULL, vjust=NULL,
                     default.units="npc",
                     name=NULL, vp=NULL) {
  if (!is.unit(x))
    x <- unit(x, default.units)
  if (!is.unit(y))
    y <- unit(y, default.units)
  if (!is.unit(width))
    width <- unit(width, default.units)
  if (!is.unit(height))
    height <- unit(height, default.units)
  grob(x=x, y=y, width=width, height=height, just=just,
       hjust=hjust, vjust=vjust,
       name=name, vp=vp, cl="clip")
}

grid.clip <- function(...) {
  grid.draw(clipGrob(...))
}


######################################
# NULL primitive
######################################

validDetails.null <- function(x) {
  if (!is.unit(x$x) ||
      !is.unit(x$y))
    stop("'x' and 'y' must be units")
  if (length(x$x) > 1 || length(x$y) > 1)
    stop("'x' and 'y' must all be units of length 1")
  x
}

drawDetails.null <- function(x, recording=TRUE) {
    # Deliberate null op.
    # NOTE: nothing will go on the graphics engine DL
    # This is ok I think because these grobs are only
    # useful on the grid DL (for other grid code to query
    # their size or location).
}

xDetails.null <- function(x, theta) {
    bounds <- grid.Call(C_locnBounds, x$x, x$y, theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[1L], "inches")
}

yDetails.null <- function(x, theta) {
    bounds <- grid.Call( C_locnBounds, x$x, x$y, theta)
    if (is.null(bounds))
        unit(0.5, "npc")
    else
        unit(bounds[2L], "inches")
}

# Deliberately ZERO
widthDetails.null <- function(x) {
    unit(0, "inches")
}

heightDetails.null <- function(x) {
    unit(0, "inches")
}

# A grob with GUARANTEED zero-width
# also GUARANTEED NOT to draw anything
nullGrob <- function(x=unit(0.5, "npc"), y=unit(0.5, "npc"),
                     default.units="npc",
                     name=NULL, vp=NULL) {
    if (!is.unit(x))
        x <- unit(x, default.units)
    if (!is.unit(y))
        y <- unit(y, default.units)
    grob(x=x, y=y, name=name, vp=vp, cl="null")
}

# Convenient way to get nullGrob on the grid display list
grid.null <- function(...) {
    grid.draw(nullGrob(...))
}