#  File src/library/grid/R/grob.R
#  Part of the R package, http://www.R-project.org
#
#  Copyright (C) 1995-2013 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
#  http://www.r-project.org/Licenses/

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

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

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

grobAutoName <- initGrobAutoName()

# Function for user to call to get "autogenerated" grob name
grobName <- function(grob=NULL, prefix="GRID") {
    if (is.null(grob))
        grobAutoName(prefix)
    else {
        if (!is.grob(grob))
            stop("invalid 'grob' argument")
        else
            grobAutoName(prefix, class(grob)[1L])
    }
}

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

checkNameSlot <- function(x) {
  # Supply a default name if one is not given
  if (is.null(x$name))
    grobAutoName(suffix=class(x)[1L])
  else
    as.character(x$name)
}

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

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

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

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

validGrob.grob <- function(x, ...) {
  # Validate class-specific slots
  x <- validDetails(x)
  # Validate standard grob slots
  x$name <- checkNameSlot(x)
  checkgpSlot(x$gp)
  if (!is.null(x$vp))
    x$vp <- checkvpSlot(x$vp)
  return(x)
}

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

grid.grob <- function(list.struct, cl=NULL, draw=TRUE) .Defunct("grob")

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

as.character.grob <- function(x, ...) {
  paste0(class(x)[1L], "[", x$name, "]")
}

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

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

gPathFromVector <- function(names) {
  if (any(bad <- !is.character(names)))
      stop(ngettext(sum(bad), "invalid grob name", "invalid grob names"),
           domain = NA)
  # Break out any embedded .grid.pathSep's
  names <- unlist(strsplit(names, .grid.pathSep))
  n <- length(names)
  if (n < 1L)
    stop("a 'grob' path must contain at least one 'grob' name")
  path <- list(path = if (n==1) NULL else
               paste(names[1L:(n-1)], collapse = .grid.pathSep),
               name = names[n], n = n)
  class(path) <- c("gPath", "path")
  path
}

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

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

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

as.gList <- function(x) {
    if (is.null(x)) {
        result <- list()
        class(result) <- "gList"
    } else if (is.grob(x)) {
        result <- list(x)
        class(result) <- "gList"
    } else if (is.gList(x)) {
        result <- x
    } else {
        stop("unable to coerce to \"gList\"")
    }
    result
}

gList <- function(...) {
    gl <- list(...)
    if (length(gl) == 0L ||
        all(sapply(gl, okGListelt, simplify=TRUE))) {
        # Ensure gList is "flat"
        # Don't want gList containing gList ...
        if (!all(sapply(gl, is.grob)))
            gl <- do.call("c", lapply(gl, as.gList))
        class(gl) <- c("gList")
        return(gl)
    } else {
        stop("only 'grobs' allowed in \"gList\"")
    }
}

addToGList <- function(x, gList) {
  UseMethod("addToGList")
}

addToGList.default <- function(x, gList) {
  if (is.null(x))
    gList
  else
    stop("invalid element to add to \"gList\"")
}

addToGList.grob <- function(x, gList) {
  if (is.null(gList))
    gList(x)
  else {
    gList[[length(gList) + 1L]] <- x
    return(gList)
  }
}

addToGList.gList <- function(x, gList) {
  gl <- c(gList, x)
  class(gl) <- "gList"
  return(gl)
}

as.character.gList <- function(x, ...) {
  paste0("(", paste(lapply(x, as.character), collapse=", "), ")")
}

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

`[.gList` <- function(x, index, ...) {
    cl <- class(x)
    result <- "["(unclass(x), index, ...)
    class(result) <- cl
    result
}

################
# gTree CLASS DEFN
################
# gTree extends grob
# A gTree has additional children slot
childName <- function(x) {
  x$name
}

setChildren <- function(x, children) {
  if (!inherits(x, "gTree"))
    stop("can only set 'children' for a \"gTree\"")
  if (!is.null(children) &&
      !inherits(children, "gList"))
    stop("'children' must be a \"gList\"")
  # Thin out NULL children
  if (!is.null(children)) {
    cl <- class(children)
    children <- children[!sapply(children, is.null)]
    class(children) <- cl
  }
  if (length(children)) {
    x$children <- children
    childNames <- sapply(children, childName)
    names(x$children) <- childNames
    x$childrenOrder <- childNames
  } else {
    x$children <- gList()
    x$childrenOrder <- character()
  }
  x
}

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

validGrob.gTree <- function(x, childrenvp, ...) {
  # Validate class-specific slots
  x <- validDetails(x)
  # Validate standard grob slots
  x$name <- checkNameSlot(x)
  checkgpSlot(x$gp)
  if (!is.null(x$vp))
    x$vp <- checkvpSlot(x$vp)
  # Only add childrenvp here so that gTree slots can
  # be validated before childrenvp get made
  # (making of childrenvp and children likely to depend
  #  on gTree slots)
  if (!is.null(childrenvp))
    x$childrenvp <- checkvpSlot(childrenvp)
  return(x)
}

gTree <- function(..., name=NULL, gp=NULL, vp=NULL,
                  children=NULL, childrenvp=NULL,
                  cl=NULL) {
  gt <- list(..., name=name, gp=gp, vp=vp)
  if (!is.null(cl) &&
      !is.character(cl))
    stop("invalid \"gTree\" class")
  class(gt) <- c(cl, "gTree", "grob", "gDesc")
  gt <- validGrob(gt, childrenvp)
  gt <- setChildren(gt, children)
  return(gt)
}

# A basic gTree that is JUST a collection of grobs
# (simply interface to gTree)
grobTree <- function(..., name=NULL, gp=NULL, vp=NULL,
                     childrenvp=NULL, cl=NULL) {
    gTree(children=gList(...),
          name=name, gp=gp, vp=vp,
          childrenvp=childrenvp, cl=cl)
}

################
# Getting just the names of the top-level grobs on the DL
################
getName <- function(elt) {
  if (inherits(elt, "grob"))
    elt$name
  else
    ""
}

getNames <- function() {
  dl <- grid.Call(L_getDisplayList)[1L:grid.Call(L_getDLindex)]
  names <- sapply(dl, getName)
  names[nzchar(names)]
}

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

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

# Get a grob from the display list
grid.get <- function(gPath, strict=FALSE, grep=FALSE, global=FALSE,
                     allDevices=FALSE) {
  if (allDevices)
    stop("'allDevices' not yet implemented")
  if (is.character(gPath))
    gPath <- gPath(gPath)
  if (!inherits(gPath, "gPath"))
    stop("invalid 'gPath'")
  if (!is.logical(grep))
    stop("invalid 'grep' value")
  grep <- rep(grep, length.out=depth(gPath))
  getDLfromGPath(gPath, strict, grep, global)
}

# Just different defaults to grid.get for convenience
# Justified by usage patterns of Hadley Wickham
grid.gget <- function(..., grep=TRUE, global=TRUE) {
    grid.get(..., grep=grep, global=global)
}

# Get a child (of a child, of a child, ...) of a grob
getGrob <- function(gTree, gPath, strict=FALSE,
                    grep=FALSE, global=FALSE) {
  if (!inherits(gTree, "gTree"))
    stop("it is only valid to get a child from a \"gTree\"")
  if (is.character(gPath))
    gPath <- gPath(gPath)
  if (!inherits(gPath, "gPath"))
    stop("invalid 'gPath'")
  if (depth(gPath) == 1 && strict) {
    gTree$children[[gPath$name]]
  } else {
    if (!is.logical(grep))
      stop("invalid 'grep' value")
    grep <- rep(grep, length.out=depth(gPath))
    getGTree(gTree, NULL, gPath, strict, grep, global)
  }
}

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

# Set a grob
# nor is it valid to specify a global destination (i.e., no global arg)
setGrob <- function(gTree, gPath, newGrob, strict=FALSE, grep=FALSE) {
  if (!inherits(gTree, "gTree"))
    stop("it is only valid to set a child of a \"gTree\"")
  if (!inherits(newGrob, "grob"))
    stop("it is only valid to set a 'grob' as child of a \"gTree\"")
  if (is.character(gPath))
    gPath <- gPath(gPath)
  if (!inherits(gPath, "gPath"))
    stop("invalid 'gPath'")
  if (!is.logical(grep))
    stop("invalid 'grep' value")
  grep <- rep(grep, length.out=depth(gPath))
  if (depth(gPath) == 1 && strict) {
    # gPath must specify an existing child
    if (old.pos <- nameMatch(gPath$name, gTree$childrenOrder, grep)) {
      # newGrob name must match existing name
      if (match(gTree$childrenOrder[old.pos], newGrob$name, nomatch=0L)) {
        gTree$children[[newGrob$name]] <- newGrob
      } else {
          stop(gettextf("New 'grob' name (%s) does not match 'gPath' (%s)",
                        newGrob$name, gPath), domain = NA)
      }
    } else {
        stop("'gPath' does not specify a valid child")
    }
  } else {
    gTree <- setGTree(gTree, NULL, gPath, newGrob, strict, grep)
    if (is.null(gTree))
      stop("'gPath' does not specify a valid child")
  }
  gTree
}

# Add a grob to a grob on the display list
grid.add <- function(gPath, child, strict=FALSE,
                     grep=FALSE, global=FALSE, allDevices=FALSE,
                     redraw=TRUE) {
  if (allDevices)
    stop("'allDevices' not yet implemented")
  if (is.character(gPath))
    gPath <- gPath(gPath)
  if (!inherits(gPath, "gPath"))
    stop("invalid 'gPath'")
  if (!is.logical(grep))
    stop("invalid 'grep' value")
  grep <- rep(grep, length.out=depth(gPath))
  addDLfromGPath(gPath, child, strict, grep, global, redraw)
}

# Add a grob to a gTree (or a child of a (child of a ...) gTree)
addGrob <- function(gTree, child, gPath=NULL, strict=FALSE,
                    grep=FALSE, global=FALSE, warn=TRUE) {
    if (!inherits(child, "grob"))
        stop("it is only valid to add a 'grob' to a \"gTree\"")
    if (is.null(gPath)) {
        addToGTree(gTree, child)
    } else {
        if (is.character(gPath))
            gPath <- gPath(gPath)
        # Only makes sense to specify a gPath for a gTree
        if (!inherits(gTree, "gTree"))
            stop("it is only valid to add a child to a \"gTree\"")
        if (!is.logical(grep))
            stop("invalid 'grep' value")
        grep <- rep(grep, length.out=depth(gPath))
        # result will be NULL if no match
        result <- addGTree(gTree, child, NULL, gPath, strict, grep, global)
        if (is.null(result)) {
            if (warn)
                warning(gettextf("'gPath' (%s) not found",
                                 as.character(gPath)),
                        domain = NA)
            gTree
        } else {
            result
        }
    }
}

# Remove a grob (or child of ...) from the display list
grid.remove <- function(gPath, warn=TRUE, strict=FALSE,
                        grep=FALSE, global=FALSE, allDevices=FALSE,
                        redraw=TRUE) {
  if (allDevices)
    stop("'allDevices' not yet implemented")
  if (is.character(gPath))
    gPath <- gPath(gPath)
  if (!inherits(gPath, "gPath"))
    stop("invalid 'gPath'")
  if (!is.logical(grep))
    stop("invalid 'grep' value")
  grep <- rep(grep, length.out=depth(gPath))
  if (depth(gPath) == 1) {
    removeNameFromDL(gPath$name, strict, grep, global, warn, redraw)
  } else {
    name <- gPath$name
    gPath <- gPath(gPath$path)
    greppath <- grep[-length(grep)]
    grepname <- grep[length(grep)]
    removeDLFromGPath(gPath, name, strict, greppath, grepname,
                      global, warn, redraw)
  }
}

# Just different defaults to grid.remove for convenience
# Justified by usage patterns of Hadley Wickham
grid.gremove <- function(..., grep=TRUE, global=TRUE) {
    grid.remove(..., grep=grep, global=global)
}

# Remove a child from a (child of ...) gTree
removeGrob <- function(gTree, gPath, strict=FALSE,
                       grep=FALSE, global=FALSE, warn=TRUE) {
    if (!inherits(gTree, "gTree"))
        stop("it is only valid to remove a child from a \"gTree\"")
    if (is.character(gPath))
        gPath <- gPath(gPath)
    if (!inherits(gPath, "gPath"))
        stop("invalid 'gPath'")
    if (!is.logical(grep))
        stop("invalid 'grep' value")
    grep <- rep(grep, length.out=depth(gPath))
    if (depth(gPath) == 1) {
        # result will be NULL if no match
        result <- removeName(gTree, gPath$name, strict, grep, global, warn)
    } else {
        name <- gPath$name
        gPath <- gPath(gPath$path)
        greppath <- grep[-length(grep)]
        grepname <- grep[length(grep)]
        # result will be NULL if no match
        result <- removeGTree(gTree, name, NULL, gPath, strict,
                              greppath, grepname, global, warn)
    }
    if (is.null(result)) {
        if (warn)
            warning(gettextf("'gPath' (%s) not found", as.character(gPath)),
                    domain = NA)
        gTree
    } else {
        result
    }
}

# Edit a grob on the display list
grid.edit <- function(gPath, ..., strict=FALSE,
                      grep=FALSE, global=FALSE, allDevices=FALSE,
                      redraw=TRUE) {
  if (allDevices)
    stop("'allDevices' not yet implemented")
  if (is.character(gPath))
    gPath <- gPath(gPath)
  if (!inherits(gPath, "gPath"))
    stop("invalid 'gPath'")
  if (!is.logical(grep))
    stop("invalid 'grep' value")
  grep <- rep(grep, length.out=depth(gPath))
  specs <- list(...)
  editDLfromGPath(gPath, specs, strict, grep, global, redraw)
}

# Just different defaults to grid.edit for convenience
# Justified by usage patterns of Hadley Wickham
grid.gedit <- function(..., grep=TRUE, global=TRUE) {
    grid.edit(..., grep=grep, global=global)
}

# Edit a (child of a ...) grob
editGrob <- function(grob, gPath=NULL, ..., strict=FALSE,
                     grep=FALSE, global=FALSE, warn=TRUE) {
    specs <- list(...)
    if (is.null(gPath)) {
        editThisGrob(grob, specs)
    } else {
        if (is.character(gPath))
            gPath <- gPath(gPath)
        # Only makes sense to specify a gPath for a gTree
        if (!inherits(grob, "gTree"))
            stop("it is only valid to edit a child of a \"gTree\"")
        if (!is.logical(grep))
            stop("invalid 'grep' value")
        grep <- rep(grep, length.out=depth(gPath))
        # result will be NULL if no match
        result <- editGTree(grob, specs, NULL, gPath, strict, grep, global)
        if (is.null(result)) {
            if (warn)
                warning(gettextf("'gPath' (%s) not found",
                                 as.character(gPath)),
                        domain = NA)
            grob
        } else {
            result
        }
    }
}

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

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

editDetails.gTree <- function(x, specs) {
  # Disallow editing children or childrenOrder slots directly
  if (any(specs %in% c("children", "childrenOrder")))
    stop("it is invalid to directly edit the 'children' or 'childrenOrder' slot")
  x
}

#########
# Helper functions for getting/adding/removing/editing grobs
#
# ASSUME down here that the grep argument has been replicated
# up to the length of the gPath argument
#########

# Find a "match" between a path$name and a grob$name
nameMatch <- function(pathName, grobName, grep) {
  if (grep) {
    pos <- grep(pathName, grobName)
    (length(pos) && pos == 1)
  } else {
    match(pathName, grobName, nomatch=0L)
  }
}

# Return the position of path$name in vector of names
# Return FALSE if not found
# If grep=TRUE, the answer may be a vector!
namePos <- function(pathName, names, grep) {
  if (grep) {
    pos <- grep(pathName, names)
    if (length(pos) == 0L)
      pos <- FALSE
  } else {
    pos <- match(pathName, names, nomatch=0L)
  }
  pos
}

partialPathMatch <- function(pathsofar, path, strict=FALSE, grep) {
  if (strict) {
    if (!any(grep))
      length(grep(paste0("^", pathsofar), path)) > 0L
    else {
      pathSoFarElts <- explode(pathsofar)
      pathElts <- explode(path)
      ok <- TRUE
      npsfe <- length(pathSoFarElts)
      index <- 1
      while (ok & index <= npsfe) {
        if (grep[index])
          ok <- (grep(pathSoFarElts[index], pathElts[index]) == 1)
        else
          ok <- match(pathSoFarElts[index], pathElts[index], nomatch=0L)
        index <- index + 1
      }
      ok
    }
  } else {
    # If we're not doing strict matching then anything from a full
    # path match to absolutely no match means a partial match
    # (i.e., keep looking)
    TRUE
  }
}

fullPathMatch <- function(pathsofar, gPath, strict, grep) {
  if (is.null(pathsofar))
    match <- (depth(gPath) == 1)
  else {
    path <- gPath$path
    if (!any(grep))
      if (strict)
        match <- match(pathsofar, path, nomatch=0L)
      else
        match <- (length(grep(paste0(path, "$"), pathsofar)) > 0L)
    else {
      pathSoFarElts <- explode(pathsofar)
      pathElts <- explode(path)
      npsfe <- length(pathSoFarElts)
      npe <- length(pathElts)
      if (npe > npsfe) {
        match <- FALSE
      } else {
        match <- TRUE
        index <- 1
        if (strict) {# pathSoFar same length as gPath
        } else {# pathSoFar could be longer than gPath
          pathSoFarElts <- pathSoFarElts[(npsfe - npe + 1):npsfe]
        }
        while (match && index <= npe) {
          if (grep[index])
            match <- (length(grep(pathElts[index], pathSoFarElts[index])) > 0L)
          else
            match <- match(pathSoFarElts[index], pathElts[index], nomatch = 0L)
          index <- index + 1
        }
      }
    }
  }
  match
}

#####
##### Get support
#####

# Add a grob to a result
growResult <- function(result, x) {
  UseMethod("growResult")
}

# Should only be when result is NULL
growResult.default <- function(result, x) {
  if (!is.null(result))
    stop("invalid 'result'")
  x
}

growResult.grob <- function(result, x) {
  if (is.grob(x))
    gList(result, x)
  else
    # x should be a gList
    addToGList(result, x)
}

growResult.gList <- function(result, x) {
  addToGList(x, result)
}

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

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

getGrobFromGPath.grob <- function(grob, pathsofar, gPath, strict,
                                  grep, global) {
  if (depth(gPath) > 1)
    NULL
  else {
    if (nameMatch(gPath$name, grob$name, grep))
      grob
    else
      NULL
  }
}

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

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

getDLfromGPath <- function(gPath, strict, grep, global) {
  dl.index <- grid.Call(L_getDLindex)
  result <- NULL
  index <- 1
  while (index < dl.index &&
         (is.null(result) || global)) {
    grob <- getGrobFromGPath(grid.Call(L_getDLelt,
                                       as.integer(index)),
                             NULL, gPath, strict,
                             grep, global)
    if (!is.null(grob))
      result <- growResult(result, grob)
    index <- index + 1
  }
  result
}

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

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

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

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

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

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

#####
##### Edit support
#####
editThisGrob <- function(grob, specs) {
  for (i in names(specs))
    if (nzchar(i))
      # Handle gp as special case
      if (match(i, "gp", nomatch=0))
        # Handle NULL as special case
        if (is.null(specs[[i]]))
          grob[i] <- list(gp=NULL)
        else
          grob$gp <- mod.gpar(grob$gp, specs$gp)
      # If there is no slot with the argument name, just ignore that argument
      else if (match(i, names(grob), nomatch=0))
        # Handle NULL as special case
        if (is.null(specs[[i]]))
          grob[i] <- eval(substitute(list(i=NULL)))
        else
          grob[[i]] <- specs[[i]]
      else
        warning(gettextf("slot '%s' not found", i), domain = NA)
  # Check grob slots are ok before trying to do anything with them
  # in editDetails
  # grob$childrenvp may be non-NULL for a gTree
  grob <- validGrob(grob, grob$childrenvp)
  editDetails(grob, specs)
}

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

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

editGrobFromGPath.grob <- function(grob, specs,
                                   pathsofar, gPath, strict,
                                   grep, global) {
  if (depth(gPath) > 1)
    NULL
  else {
    if (nameMatch(gPath$name, grob$name, grep))
      editThisGrob(grob, specs)
    else
      NULL
  }
}

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

editGrobFromGPath.gTree <- function(grob, specs,
                                    pathsofar, gPath, strict,
                                    grep, global) {
  if (depth(gPath) == 1) {
    if (nameMatch(gPath$name, grob$name, grep))
      editThisGrob(grob, specs)
    else
      if (strict)
        NULL
      else
        editGTree(grob, specs,
                  if (is.null(pathsofar)) grob$name else pathsofar,
                  gPath, strict, grep, global)
  } else {
    editGTree(grob, specs,
              if (is.null(pathsofar)) grob$name else pathsofar,
              gPath, strict, grep, global)
  }
}

editDLfromGPath <- function(gPath, specs, strict, grep, global, redraw) {
  dl.index <- grid.Call(L_getDLindex)
  index <- 1
  grob <- NULL
  found <- FALSE
  while (index < dl.index &&
         (is.null(grob) || global)) {
    grob <- editGrobFromGPath(grid.Call(L_getDLelt,
                                        as.integer(index)),
                              specs,
                              NULL, gPath, strict, grep, global)
    if (!is.null(grob)) {
      # Destructively modify the DL elt
      grid.Call(L_setDLindex, as.integer(index))
      grid.Call(L_setDLelt, grob)
      # Reset the DL index
      grid.Call(L_setDLindex, as.integer(dl.index))
      found <- TRUE
    }
    index <- index + 1
  }
  if (!found)
    stop(gettextf("'gPath' (%s) not found", as.character(gPath)), domain = NA)
  else if (redraw)
    draw.all()
}

#####
##### Add support
#####

# Assume that child is a grob
addToGTree <- function(gTree, child) {
  if (!inherits(gTree, "gTree"))
    stop("it is only valid to add a child to a \"gTree\"")
  gTree$children[[child$name]] <- child
  # Handle case where child name already exists (so will be overwritten)
  if (old.pos <- match(child$name, gTree$childrenOrder, nomatch=0))
    gTree$childrenOrder <- gTree$childrenOrder[-old.pos]
  gTree$childrenOrder <- c(gTree$childrenOrder, child$name)
  gTree
}

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

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

# If no match then fail
# If match then error!
addGrobFromGPath.grob <- function(grob, child,
                                  pathsofar, gPath, strict,
                                  grep, global) {
  if (depth(gPath) > 1)
    NULL
  else {
    if (nameMatch(gPath$name, grob$name, grep))
      stop("it is only valid to add a child to a \"gTree\"")
    else
      NULL
  }
}

# In this function, the grob being added is called "grob"
# (in all others it is called "child"
addGTree <- function(gTree, grob, pathsofar, gPath, strict,
                     grep, global) {
  # Try to find pathsofar at start of gPath
  # NOTE: may be called directly with pathsofar=NULL
  if (is.null(pathsofar) ||
      (!strict && depth(gPath) == 1) ||
      partialPathMatch(pathsofar, gPath$path, strict, grep)) {
    found <- FALSE
    index <- 1
    # Search children for match
    while (index <= length(gTree$childrenOrder) &&
           (!found || global)) {
      childName <- gTree$childrenOrder[index]
      child <- gTree$children[[childName]]
      # Special case when strict is FALSE and depth(gPath) is 1
      # Just check for gPath$name amongst children and recurse if no match
      if (!strict && depth(gPath) == 1) {
        if (nameMatch(gPath$name, childName, grep)) {
          gTree$children[[childName]] <- addToGTree(child, grob)
          found <- TRUE
        } else {
          if (is.null(pathsofar))
            newpathsofar <- child$name
          else
            newpathsofar <- paste0(pathsofar, .grid.pathSep, childName)
          if (!is.null(newChild <- addGrobFromGPath(child, grob,
                                                    newpathsofar,
                                                    gPath, strict,
                                                    grep, global))) {
            gTree$children[[childName]] <- newChild
            found <- TRUE
          }
        }
      } else {
        # Only check for match with child if have full match with pathsofar
        # If it's a complete match, look for gPath$name amongst child
        # NOTE: may be called directly with pathsofar=NULL
        if (fullPathMatch(pathsofar, gPath, strict, grep)) {
          if (nameMatch(gPath$name, childName, grep[depth(gPath)])) {
            gTree$children[[childName]] <- addToGTree(child, grob)
            found <- TRUE
          }
        # Otherwise recurse down child
        } else {
          # NOTE: may be called directly with pathsofar=NULL
          if (is.null(pathsofar))
            newpathsofar <- child$name
          else
            newpathsofar <- paste0(pathsofar, .grid.pathSep, childName)
          if (!is.null(newChild <- addGrobFromGPath(child, grob,
                                                    newpathsofar,
                                                    gPath, strict,
                                                    grep, global))) {
            gTree$children[[childName]] <- newChild
            found <- TRUE
          }
        }
      }
      index <- index + 1
    }
    if (found)
      gTree
    else
      NULL
  } else {
    NULL
  }
}

addGrobFromGPath.gTree <- function(grob, child,
                                   pathsofar, gPath, strict,
                                   grep, global) {
  if (depth(gPath) == 1) {
    if (nameMatch(gPath$name, grob$name, grep))
      addToGTree(grob, child)
    else
      if (strict)
        NULL
      else
        addGTree(grob, child,
                 if (is.null(pathsofar)) grob$name else pathsofar,
                 gPath, strict, grep, global)
  } else {
    addGTree(grob, child,
             if (is.null(pathsofar)) grob$name else pathsofar,
             gPath, strict, grep, global)
  }
}

addDLfromGPath <- function(gPath, child, strict, grep, global, redraw) {
  dl.index <- grid.Call(L_getDLindex)
  index <- 1
  grob <- NULL
  found <- FALSE
  while (index < dl.index &&
         (is.null(grob) || global)) {
    grob <- addGrobFromGPath(grid.Call(L_getDLelt,
                                       as.integer(index)),
                             child,
                             NULL, gPath, strict, grep, global)
    if (!is.null(grob)) {
      # Destructively modify the DL elt
      grid.Call(L_setDLindex, as.integer(index))
      grid.Call(L_setDLelt, grob)
      # Reset the DL index
      grid.Call(L_setDLindex, as.integer(dl.index))
      found <- TRUE
    }
    index <- index + 1
  }
  if (!found)
    stop(gettextf("'gPath' (%s) not found", gPath), domain = NA)
  else if (redraw)
    draw.all()
}

#####
##### Remove support
#####

removeFromGTree <- function(gTree, name, grep) {
  if (!inherits(gTree, "gTree"))
    stop("it is only valid to remove a child from a \"gTree\"")
  if (grep) {
    old.pos <- grep(name, gTree$childrenOrder)
    if (length(old.pos) == 0L)
      old.pos <- 0
  } else {
    old.pos <- match(name, gTree$childrenOrder, nomatch=0)
  }
  if (old.pos > 0) {
    # name might be a regexp so use real name
    gTree$children[[gTree$childrenOrder[old.pos]]] <- NULL
    gTree$childrenOrder <- gTree$childrenOrder[-old.pos]
    gTree
  } else {
    NULL
  }
}

# A gPath may specify the child of a gTree
# (or the child of a child of a gTree, or ...)
removeGrobFromGPath <- function(grob, name, pathsofar, gPath, strict,
                                grep, grepname, global, warn) {
  UseMethod("removeGrobFromGPath")
}

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

# ALWAYS fail
# (either no match or match but grob has no children!)
removeGrobFromGPath.grob <- function(grob, name,
                                     pathsofar, gPath, strict,
                                     grep, grepname, global, warn) {
  NULL
}

removeGTree <- function(gTree, name, pathsofar, gPath, strict,
                        grep, grepname, global, warn) {
  # Try to find pathsofar at start of gPath
  # NOTE: may be called directly with pathsofar=NULL
  if (is.null(pathsofar) ||
      (!strict && depth(gPath) == 1) ||
      partialPathMatch(pathsofar, gPath$path, strict, grep)) {
    found <- FALSE
    index <- 1
    # Search children for match
    while (index <= length(gTree$childrenOrder) &&
           (!found || global)) {
      childName <- gTree$childrenOrder[index]
      child <- gTree$children[[childName]]
      # Special case when strict is FALSE and depth(gPath) is 1
      # Just check for gPath$name amongst children and recurse if no match
      if (!strict && depth(gPath) == 1) {
        # NOTE: child has to be a gTree if we hope to find a child in it!
        if (inherits(child, "gTree") &&
            nameMatch(gPath$name, childName, grep)) {
          newchild <- removeFromGTree(child, name, grepname)
          if (!is.null(newchild)) {
            gTree$children[[childName]] <- newchild
            found <- TRUE
          }
        } else {
          if (is.null(pathsofar))
            newpathsofar <- child$name
          else
            newpathsofar <- paste0(pathsofar, .grid.pathSep, childName)
          if (!is.null(newChild <- removeGrobFromGPath(child, name,
                                                       newpathsofar,
                                                       gPath, strict,
                                                       grep, grepname,
                                                       global, warn))) {
            gTree$children[[childName]] <- newChild
            found <- TRUE
          }
        }
      } else {
        # Only check for match with child if have full match with pathsofar
        # If it's a complete match, look for gPath$name amongst child
        # NOTE: may be called directly with pathsofar=NULL
        if (fullPathMatch(pathsofar, gPath, strict, grep)) {
          # NOTE: child has to be a gTree if we hope to find a child in it!
          if (inherits(child, "gTree") &&
              nameMatch(gPath$name, childName, grep[depth(gPath)])) {
            newchild <- removeFromGTree(child, name, grepname)
            if (!is.null(newchild)) {
              gTree$children[[childName]] <- newchild
              found <- TRUE
            }
          }
        # Otherwise recurse down child
        } else {
          # NOTE: may be called directly with pathsofar=NULL
          if (is.null(pathsofar))
            newpathsofar <- child$name
          else
            newpathsofar <- paste0(pathsofar, .grid.pathSep, childName)
          if (!is.null(newChild <- removeGrobFromGPath(child, name,
                                                       newpathsofar,
                                                       gPath, strict,
                                                       grep, grepname,
                                                       global, warn))) {
            gTree$children[[childName]] <- newChild
            found <- TRUE
          }
        }
      }
      index <- index + 1
    }
    if (found)
      gTree
    else
      NULL
  } else {
    NULL
  }
}

removeGrobFromGPath.gTree <- function(grob, name,
                                      pathsofar, gPath, strict,
                                      grep, grepname, global, warn) {
  if (depth(gPath) == 1) {
    if (nameMatch(gPath$name, grob$name, grep))
      removeFromGTree(grob, name, grepname)
    else
      if (strict)
        NULL
      else
        removeGTree(grob, name,
                    if (is.null(pathsofar)) grob$name else pathsofar,
                    gPath, strict, grep, grepname, global, warn)
  } else {
    removeGTree(grob, name,
                if (is.null(pathsofar)) grob$name else pathsofar,
                gPath, strict, grep, grepname, global, warn)
  }
}

removeDLFromGPath <- function(gPath, name, strict, grep, grepname, global,
                              warn, redraw) {
  dl.index <- grid.Call(L_getDLindex)
  index <- 1
  grob <- NULL
  found <- FALSE
  while (index < dl.index &&
         (is.null(grob) || global)) {
    grob <- removeGrobFromGPath(grid.Call(L_getDLelt, as.integer(index)),
                                name,
                                NULL, gPath, strict, grep, grepname,
                                global, warn)
    if (!is.null(grob)) {
      # Destructively modify the DL elt
      grid.Call(L_setDLindex, as.integer(index))
      grid.Call(L_setDLelt, grob)
      # Reset the DL index
      grid.Call(L_setDLindex, as.integer(dl.index))
      found <- TRUE
    }
    index <- index + 1
  }
  if (!found)
    stop(gettextf("gPath (%s) not found",
                  paste(gPath, name, sep=.grid.pathSep)),
                  domain = NA)
  else if (redraw)
    draw.all()
}

#####
##### Remove NAME support
#####

# NEVER called when strict=TRUE
removeGrobFromName <- function(grob, name, grep, global, warn) {
  UseMethod("removeGrobFromName")
}

removeGrobFromName.grob <- function(grob, name, grep, global, warn) {
  NULL
}

# For a gTree, just recurse straight back to removeName
removeGrobFromName.gTree <- function(grob, name, grep, global, warn) {
    removeName(grob, name, FALSE, grep, global, warn)
}

removeName <- function(gTree, name, strict, grep, global, warn) {
  found <- FALSE
  index <- 1
  # Search children for match
  while (index <= length(gTree$childrenOrder) &&
         (!found || global)) {
    childName <- gTree$childrenOrder[index]
    child <- gTree$children[[childName]]
    # Just check child name and recurse if no match
    if (nameMatch(name, childName, grep)) {
      # name might be a regexp, so get real name
      gTree$children[[gTree$childrenOrder[index]]] <- NULL
      gTree$childrenOrder <- gTree$childrenOrder[-index]
      found <- TRUE
      # If deleted the child, do NOT increase index!
    } else if (strict) {
      NULL
      index <- index + 1
    } else {
      if (!is.null(newChild <- removeGrobFromName(child, name,
                                                  grep, global, warn))) {
        gTree$children[[childName]] <- newChild
        found <- TRUE
      }
      index <- index + 1
    }
  }
  if (found)
    gTree
  else
    NULL
}

removeNameFromDL <- function(name, strict, grep, global, warn, redraw) {
  dl.index <- grid.Call(L_getDLindex)
  index <- 1
  grob <- NULL
  found <- FALSE
  while (index < dl.index &&
         (is.null(grob) || global)) {
    grob <- grid.Call(L_getDLelt, as.integer(index))
    if (inherits(grob, "grob")) {
      # If match top-level grob, remove it from DL
      if (nameMatch(name, grob$name, grep)) {
        # Destructively modify the DL elt
        grid.Call(L_setDLindex, as.integer(index))
        grid.Call(L_setDLelt, NULL)
        # Reset the DL index
        grid.Call(L_setDLindex, as.integer(dl.index))
        found <- TRUE
      # Otherwise search down it for match
      } else {
        if (!strict) {
          grob <- removeGrobFromName(grob, name, grep, global, warn)
          if (!is.null(grob)) {
            # Destructively modify the DL elt
            grid.Call(L_setDLindex, as.integer(index))
            grid.Call(L_setDLelt, grob)
            # Reset the DL index
            grid.Call(L_setDLindex, as.integer(dl.index))
            found <- TRUE
          }
        }
      }
    } else {
      grob <- NULL
    }
    index <- index + 1
  }
  if (!found) {
    if (warn)
        stop(gettextf("gPath (%s) not found", name), domain = NA)
  } else if (redraw)
    draw.all()
}

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

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

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

findGrobinDL <- function(name) {
  dl.index <- grid.Call(L_getDLindex)
  result <- NULL
  index <- 1
  while (index < dl.index && is.null(result)) {
    result <- findgrob(grid.Call(L_getDLelt, as.integer(index)), name)
    index <- index + 1
  }
  if (is.null(result))
    stop(gettextf("grob '%s' not found", name), domain = NA)
  result
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

makeContext.default <- function(x) {
    x
}

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

makeContent.default <- function(x) {
    x
}

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

preDraw.gTree <- function(x) {
    # Allow customisation of x$vp (and x$childrenvp)
    x <- makeContext(x)
    # Make this gTree the "current grob" for evaluation of
    # grobwidth/height units via gPath
    # Do this as a .Call.graphics to get it onto the base display list
    grid.Call.graphics(L_setCurrentGrob, x)
    # automatically push/pop the viewport
    pushvpgp(x)
    # Push then "up" childrenvp
    if (!is.null(x$childrenvp)) {
        # Save any x$gp gpar settings
        tempgp <- grid.Call(L_getGPar)
        pushViewport(x$childrenvp, recording=FALSE)
        upViewport(depth(x$childrenvp), recording=FALSE)
        # reset the x$gp gpar settings
        # The upViewport above may have overwritten them with
        # the previous vp$gp settings
        grid.Call.graphics(L_setGPar, tempgp)
    }
    preDrawDetails(x)
    x
}

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

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

drawGrob <- function(x) {
    # Temporarily turn off the grid DL so that
    # nested calls to drawing code do not get recorded
    dlon <- grid.Call(L_setDLon, FALSE)
    # If get error or user-interrupt, need to reset state
    # Need to turn grid DL back on (if it was on)
    on.exit(grid.Call(L_setDLon, dlon))
    # Save current gpar
    tempgpar <- grid.Call(L_getGPar)
    # If get error or user-interrupt, need to reset state
    # Need to restore current grob (gtree predraw sets current grob)
    # Need to restore gpar settings (set by gtree itself and/or its vp)
    # This does not need to be a grid.Call.graphics() because
    # we are nested within a recordGraphics()
    # Do not call set.gpar because set.gpar accumulates cex
    on.exit(grid.Call(L_setGPar, tempgpar), add=TRUE)
    # Setting up the drawing context may involve modifying the grob
    # (typically only x$vp) but the modified grob is needed for postDraw()
    x <- preDraw(x)
    # Allow customisation of x
    # (should only return a basic grob that has a drawDetails()
    #  method, otherwise nothing will be drawn)
    x <- makeContent(x)
    # Do any class-specific drawing
    drawDetails(x, recording=FALSE)
    postDraw(x)
}

grid.draw.grob <- function(x, recording=TRUE) {
    engineDLon <- grid.Call(L_getEngineDLon)
    if (engineDLon)
        recordGraphics(drawGrob(x),
                       list(x=x),
                       getNamespace("grid"))
    else
        drawGrob(x)
    if (recording)
        record(x)
    invisible()
}

drawGList <- function(x) {
    # DO NOT turn off grid DL.
    # A top-level gList does not itself go on the DL,
    # but its children do.
    # A gList which is part of some other grob (e.g., children
    # of a gTree) will be "protected" by the gTree
    # turning off the DL.
    lapply(x, grid.draw)
}

grid.draw.gList <- function(x, recording=TRUE) {
    engineDLon <- grid.Call(L_getEngineDLon)
    if (engineDLon)
        recordGraphics(drawGList(x),
                       list(x=x),
                       getNamespace("grid"))
    else
        drawGList(x)
    invisible()
}

drawGTree <- function(x) {
    # Temporarily turn off the grid DL so that
    # nested calls to drawing code do not get recorded
    dlon <- grid.Call(L_setDLon, FALSE)
    # If get error or user-interrupt, need to reset state
    # Need to turn grid DL back on (if it was on)
    on.exit(grid.Call(L_setDLon, dlon))
    # Save current grob and current gpar
    tempgrob <- grid.Call(L_getCurrentGrob)
    tempgpar <- grid.Call(L_getGPar)
    # If get error or user-interrupt, need to reset state
    # Need to restore current grob (gtree predraw sets current grob)
    # Need to restore gpar settings (set by gtree itself and/or its vp)
    # This does not need to be a grid.Call.graphics() because
    # we are nested within a recordGraphics()
    # Do not call set.gpar because set.gpar accumulates cex
    on.exit({ grid.Call(L_setGPar, tempgpar)
              grid.Call(L_setCurrentGrob, tempgrob)
            }, add=TRUE)
    # Setting up the drawing context may involve modifying the grob
    # (typically only x$vp) but the modified grob is needed for postDraw()
    x <- preDraw(x)
    # Allow customisation of x (should be confined to x$children)
    x <- makeContent(x)
    # Do any class-specific drawing
    drawDetails(x, recording=FALSE)
    # Draw all children IN THE RIGHT ORDER
    for (i in x$childrenOrder)
      grid.draw(x$children[[i]], recording=FALSE)
    postDraw(x)
}

grid.draw.gTree <- function(x, recording=TRUE) {
    engineDLon <- grid.Call(L_getEngineDLon)
    if (engineDLon)
        recordGraphics(drawGTree(x),
                       list(x=x),
                       getNamespace("grid"))
    else
        drawGTree(x)
    if (recording)
        record(x)
    invisible()
}

draw.all <- function() {
    grid.newpage(recording=FALSE)
    dl.index <- grid.Call(L_getDLindex)
    if (dl.index > 1)
        # Start at 2 because first element is viewport[ROOT]
        for (i in 2:dl.index) {
            grid.draw(grid.Call(L_getDLelt, as.integer(i - 1)),
                      recording=FALSE)
        }
}

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

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

preDrawDetails.grob <- function(x) {
}

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

postDrawDetails.grob <- function(x) {
}

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

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

grid.copy <- function(grob) {
    warning("this function is redundant and will disappear in future versions",
            domain = NA)
    grob
}

################################
# Flattening a grob

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

# The default action is to leave 'x' untouched
# BUT it is also necessary to enforce the drawing context
# for viewports and vpPaths
forceGrob.default <- function(x) {
    grid.draw(x, recording=FALSE)
    x
}

# This allows 'x' to be modified, but may not
# change 'x' at all
forceGrob.grob <- function(x) {
    # Copy of the original object to allow a "revert"
    originalX <- x
    # Same set up as drawGrob()
    dlon <- grid.Call(L_setDLon, FALSE)
    on.exit(grid.Call(L_setDLon, dlon))
    tempgpar <- grid.Call(L_getGPar)
    on.exit(grid.Call(L_setGPar, tempgpar), add=TRUE)
    # Same drawing context set up as drawGrob()
    # including enforcing the drawing context
    x <- preDraw(x)
    # Same drawing content set up as drawGrob() ...
    x <- makeContent(x)
    # BUT NO DRAWING
    # Same context clean up as drawGrob()
    postDraw(x)
    # If 'x' has not changed, just return original 'x'
    # Also, do not bother with saving original
    # If 'x' has changed ...
    if (!identical(x, originalX)) {
        # Store the original object to allow a "revert"
        x$.ORIGINAL <- originalX
        # Return the 'x' that would have been drawn
        # This will typically be a standard R primitive
        # (which do not have makeContext() or makeContent()
        #  methods, only drawDetails())
        # BUT ot be safe add "forcedgrob" class so that subsequent
        # draws will NOT run makeContext() or makeContent()
        # methods
        class(x) <- c("forcedgrob", class(x))
    }
    x
}

# This allows 'x' to be modified, but may not
# change 'x' at all
forceGrob.gTree <- function(x) {
    # Copy of the original object to allow a "revert"
    originalX <- x
    # Same set up as drawGTree()
    dlon <- grid.Call(L_setDLon, FALSE)
    on.exit(grid.Call(L_setDLon, dlon))
    tempgrob <- grid.Call(L_getCurrentGrob)
    tempgpar <- grid.Call(L_getGPar)
    on.exit({ grid.Call(L_setGPar, tempgpar)
              grid.Call(L_setCurrentGrob, tempgrob)
            }, add=TRUE)
    # Same drawing context set up as drawGTree(),
    # including enforcing the drawing context
    x <- preDraw(x)
    # Same drawing content set up as drawGTree() ...
    x <- makeContent(x)
    # Ensure that children are also forced
    x$children <- do.call("gList", lapply(x$children, forceGrob))
    # BUT NO DRAWING
    # Same context clean up as drawGTree()
    postDraw(x)
    # If 'x' has changed ...
    if (!identical(x, originalX)) {
        # Store the original object to allow a "revert"
        x$.ORIGINAL <- originalX
        # Return the 'x' that would have been drawn
        # This will typically be a vanilla gTree with children to draw
        # (which will not have makeContext() or makeContent() methods)
        # BUT to be safe add "forcedgrob" class so that subsequent
        # draws will NOT run makeContext() or makeContent()
        # methods
        class(x) <- c("forcedgrob", class(x))
    }
    x
}

# A "forcedgrob" does NOT modify context or content at
# drawing time
makeContext.forcedgrob <- function(x) x

makeContent.forcedgrob <- function(x) x

grid.force <- function(x, ...) {
    UseMethod("grid.force")
}

grid.force.default <- function(x, redraw = FALSE, ...) {
    if (!missing(x))
        stop("Invalid force target")
    # Must upViewport(0) otherwise you risk running the display
    # list from something other than the ROOT viewport
    oldcontext <- upViewport(0, recording=FALSE)
    dl.index <- grid.Call(L_getDLindex)
    if (dl.index > 1) {
        # Start at 2 because first element is viewport[ROOT]
        for (i in 2:dl.index) {
            grid.Call(L_setDLindex, as.integer(i - 1))
            grid.Call(L_setDLelt,
                      forceGrob(grid.Call(L_getDLelt, as.integer(i - 1))))
        }
        grid.Call(L_setDLindex, dl.index)
    }
    if (redraw) {
        draw.all()
    }
    # Try to go back to original context
    if (length(oldcontext)) {
        seekViewport(oldcontext, recording=FALSE)
    }
}

grid.force.grob <- function(x, draw = FALSE, ...) {
    fx <- forceGrob(x)
    if (draw)
        grid.draw(fx)
    fx
}

grid.force.character <- function(x, ...) {
    grid.force(gPath(x), ...)
}

grid.force.gPath <- function(x,
                             strict=FALSE, grep=FALSE, global=FALSE,
                             redraw = FALSE, ...) {
    # Use viewports=TRUE so that get vpPaths in result
    paths <- grid.grep(x, viewports = TRUE,
                       strict = strict, grep = grep, global = global)
    f <- function(path, ...) {
        # Only force grobs or gTrees
        # (might have vpPaths because we said grid.grep(viewports=TRUE))
        if (!inherits(path, "gPath")) return()
        target <- grid.get(path, strict=TRUE)
        vpPath <- attr(path, "vpPath")
        depth <- 0
        if (nchar(vpPath))
            depth <- downViewport(vpPath, recording=FALSE)
        forcedgrob <- forceGrob(target, ...)
        if (depth > 0)
            upViewport(depth, recording=FALSE)
        grid.set(path, strict=TRUE, forcedgrob)
    }
    if (length(paths)) {
        # To get the force happening in the correct context ...
        oldcontext <- upViewport(0, recording=FALSE)
        if (global) {
            lapply(paths, f, ...)
        } else {
            f(paths, ...)
        }
        if (redraw) {
            draw.all()
        }
        # Try to go back to original context
        if (length(oldcontext))
            seekViewport(oldcontext, recording=FALSE)
    }
    invisible()
}

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

revert.default <- function(x) {
    x
}

# Only need to revert "forcedgrob"s
revert.forcedgrob <- function(x) {
    x$.ORIGINAL
}

# No need for recursion for gTree because if top-level grob
# changed its children then top-level grob will have retained
# revert version of its entire self (including children)

# NOTE that things will get much trickier if allow
# grid.revert(gPath = ...)
grid.revert <- function(x, ...) {
    UseMethod("grid.revert")
}

grid.revert.default <- function(x, redraw=FALSE, ...) {
    if (!missing(x))
        stop("Invalid revert target")
    dl.index <- grid.Call(L_getDLindex)
    if (dl.index > 1) {
        # Start at 2 because first element is viewport[ROOT]
        for (i in 2:dl.index) {
            grid.Call(L_setDLindex, as.integer(i - 1))
            grid.Call(L_setDLelt,
                      revert(grid.Call(L_getDLelt, as.integer(i - 1))))
        }
        grid.Call(L_setDLindex, dl.index)
    }
    if (redraw) {
        draw.all()
    }
}

grid.revert.grob <- function(x, draw=FALSE, ...) {
    rx <- revert(x)
    if (draw) {
        grid.draw(x)
    }
    rx
}

grid.revert.character <- function(x, ...) {
    grid.revert(gPath(x), ...)
}

grid.revert.gPath <- function(x,
                              strict=FALSE, grep=FALSE, global=FALSE,
                              redraw = FALSE, ...) {
    paths <- grid.grep(x, strict = strict, grep = grep, global = global)
    f <- function(path, ...) {
        grid.set(path, strict=TRUE,
                 revert(grid.get(path, strict=TRUE), ...))
    }
    if (length(paths)) {
        if (global) {
            lapply(paths, f, ...)
        } else {
            f(paths, ...)
        }
        if (redraw) {
            draw.all()
        }
    }
    invisible()
}

###############################
# Reordering grobs

# Reorder the children of a gTree
# Order may be specified as a character vector
#   Character vector MUST name existing children
# Order may be specified as a numeric vector
#   (which makes it easy to say something like
#    "make last child the first child")
#   Numeric vector MUST be within range 1:numChildren
# Only unique order values used
# Any children NOT specified by order are appended to
#   front or back of order (depending on 'front' argument)
# Order is ALWAYS back-to-front
reorderGrob <- function(x, order, back=TRUE) {
    if (!inherits(x, "gTree"))
        stop("can only reorder 'children' for a \"gTree\"")
    order <- unique(order)
    oldOrder <- x$childrenOrder
    N <- length(oldOrder)
    if (is.character(order)) {
        # Convert to numeric
        order <- match(order, x$childrenOrder)
    }
    if (is.numeric(order)) {
        if (any(!is.finite(order)) ||
            !(all(order %in% 1:N))) {
            stop("Invalid 'order'")
        }
        if (back) {
            newOrder <- c(x$childrenOrder[order],
                          x$childrenOrder[-order])
        } else {
            newOrder <- c(x$childrenOrder[-order],
                          x$childrenOrder[order])
        }
    }
    x$childrenOrder <- newOrder
    x
}

# Reorder the children of a gTree on the display list
# (identified by a gPath)
# NOTE that it is possible for this operation to produce a grob
# that no longer draws (because it relies on another grob that
# used to be drawn before it, e.g., when the width of grob "b"
# is calculated from the width of grob "a")
# Do NOT allow reordering of grobs on the display list
# (it is not even clear what should happen in terms of reordering
#  grobs mixed with viewports PLUS the potential for ending up with
#  something that will not draw is pretty high)
# IF you want to reorder the grobs on the DL, do a grid.grab()
# first and then reorder the children of the resulting gTree
grid.reorder <- function(gPath, order, back=TRUE, grep=FALSE, redraw=TRUE) {
    grob <- grid.get(gPath, grep=grep)
    grid.set(gPath, reorderGrob(grob, order, back=back),
             grep=grep, redraw=redraw)
}