R/grid.R

In thomasp85/grid: The Grid Graphics Package

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


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

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

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

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

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

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

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

# "push"ing a vpPath is just a downViewport(..., strict=TRUE)
push.vp.vpPath <- function(vp, recording) {
    downViewport(vp, strict=TRUE, recording)
}

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

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

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

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

child.list <- function(children) {
  ls(children, all.names=TRUE) # sorted (needed ?)
}

pathMatch <- function(path, pathsofar, strict) {
  if (is.null(pathsofar))
    is.null(path)
  else {
    pattern <- paste0(if(strict) "^", path, "$")
    grepl(pattern, pathsofar)
  }
}

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

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

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

# Build vpPath from one (pushed) viewport up to another (pushed) viewport
# 'anc' is assumed to be an ancestor of 'desc'
# 'depth' is the depth that the final depth should have
buildPath <- function(desc, anc, depth) {
    path <- desc$name
    while (!identical(desc$parent, anc)) {
        if (is.null(desc$parent))
            stop("Down viewport failed to record on display list")
        desc <- desc$parent
        path <- c(desc$name, path)
    }
    result <- vpPath(path)
    if (depth(result) != depth)
        warning("Down viewport incorrectly recorded on display list")
    result
}

downViewport.vpPath <- function(name, strict=FALSE, recording=TRUE) {
    start <- grid.Call(C_currentViewport)
    if (name$n == 1)
        result <- grid.Call.graphics(C_downviewport, name$name, strict)
    else
        result <- grid.Call.graphics(C_downvppath,
                                     name$path, name$name, strict)
    # If the downViewport() fails, there is an error in C code
    # so none of the following code will be run

    # Enforce the gpar settings for the viewport
    pvp <- grid.Call(C_currentViewport)
    # Do not call set.gpar because set.gpar accumulates cex
    grid.Call.graphics(C_setGPar, pvp$gpar)
    # Record the viewport operation
    # ... including the depth navigated down
    if (recording) {
        attr(name, "depth") <- result
        # Record the strict path down
        path <- buildPath(pvp, start, result)
        record(path)
    }
    invisible(result)
}

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

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

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

popViewport <- function(n=1, recording=TRUE) {
  if (n < 0)
    stop("must pop at least one viewport")
  if (n == 0)
    n <- vpDepth()
  if (n > 0) {
    grid.Call.graphics(C_unsetviewport, as.integer(n))
    # Record on the display list
    if (recording) {
      class(n) <- "pop"
      record(n)
    }
  }
  invisible()
}

# Rather than removing the viewport from the viewport stack (tree),
# simply navigate up, leaving pushed viewports in place.
upViewport <- function(n=1, recording=TRUE) {
  if (n < 0)
    stop("must navigate up at least one viewport")
  if (n == 0) {
    n <- vpDepth()
    upPath <- current.vpPath()
  }
  if (n > 0) {
    path <- current.vpPath()
    upPath <- path[(depth(path) - n + 1):depth(path)]
    grid.Call.graphics(C_upviewport, as.integer(n))
    # Record on the display list
    if (recording) {
      class(n) <- "up"
      record(n)
    }
  }
  invisible(upPath)
}

# Return the full vpPath to the current viewport
current.vpPath <- function() {
  names <- NULL
  pvp <- grid.Call(C_currentViewport)
  while (!rootVP(pvp)) {
    names <- c(names, pvp$name)
    pvp <- pvp$parent
  }
  if (!is.null(names))
    vpPathFromVector(rev(names))
  else
    names
}

# Function to obtain the current viewport
current.viewport <- function() {
    # The system stores a pushedvp;  the user should only
    # ever see normal viewports, so convert.
    vpFromPushedvp(grid.Call(C_currentViewport))
}

# Return the parent of the current viewport
# (could be NULL)
current.parent <- function(n=1) {
    if (n < 1)
        stop("Invalid number of generations")
    vp <- grid.Call(C_currentViewport)
    generation <- 1
    while (generation <= n) {
        if (is.null(vp))
            stop("Invalid number of generations")
        vp <- vp$parent
        generation <- generation + 1
    }
    if (!is.null(vp))
        vpFromPushedvp(vp)
    else
        vp
}

vpListFromNode <- function(node) {
  vpListFromList(eapply(node$children, vpTreeFromNode, all.names=TRUE))
}

vpTreeFromNode <- function(node) {
  # If no children then just return viewport
  if (no.children(node$children))
    vpFromPushedvp(node)
  # Otherwise return vpTree
  else
    vpTree(vpFromPushedvp(node),
           vpListFromNode(node))
}

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

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

current.rotation <- function() {
    grid.Call(C_currentViewport)$rotation
}

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

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

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

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

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

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

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

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

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

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

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

# Rerun the grid DL
grid.refresh <- function() {
  draw.all()
}

# Call a function on each element of the grid display list
# AND replace the element with the result
# This is blood-curdlingly dangerous for the state of the
# display list
# Two token efforts at safety are made:
#   - generate all of the new elements first THEN assign them all
#     (so if there is an error in generating any one element
#      you don't end up with a trashed display list)
#   - check that the new element is either NULL or the same
#     class as the element it is replacing
grid.DLapply <- function(FUN, ...) {
    FUN <- match.fun(FUN)
    # Traverse DL and do something to each entry
#    gridDL <- grid.Call(C_getDisplayList)
    gridDLindex <- grid.Call(C_getDLindex)
    newDL <- vector("list", gridDLindex)
    for (i in 1:(gridDLindex - 1)) {
        elt <- grid.Call(C_getDLelt, i)
        newElt <- FUN(elt, ...)
        if (!(is.null(newElt) || inherits(newElt, class(elt))))
            stop("invalid modification of the display list")
        newDL[[i]] <- newElt
    }
    for (i in 1:(gridDLindex - 1)) {
        grid.Call(C_setDLindex, i)
        grid.Call(C_setDLelt, newDL[[i]])
    }
    grid.Call(C_setDLindex, gridDLindex)
}

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

grid.Call.graphics <- function(fnname, ...) {
  # Only record graphics operations on the graphics engine's display
  # list if the engineDLon flag is set
  engineDLon <- grid.Call(C_getEngineDLon)
  if (engineDLon) {
    # NOTE that we need a .Call.graphics(C_gridDirty) so that
    # the first thing on the engine display list is a dirty
    # operation;  this is necessary in case the display list is
    # played on another device (e.g., via replayPlot() or dev.copy())
    .Call.graphics(C_gridDirty)
    result <- .Call.graphics(dontCheck(fnname), ...)
  } else {
    .Call(C_gridDirty)
    result <- .Call(dontCheck(fnname), ...)
  }
  result
}

# A call to recordGraphics() outside of [pre|post]drawDetails methods
# will not record the expr on the grid DL.
# If a user REALLY wants to call recordGraphics(), they should use
# grid.record() instead
drawDetails.recordedGrob <- function(x, recording) {
  eval(x$expr, x$list, getNamespace("grid"))
}

grid.record <- function(expr, list,
                        name=NULL, gp=NULL, vp=NULL) {
  grid.draw(grob(expr=substitute(expr), list=list,
                 name=name, gp=gp, vp=vp, cl="recordedGrob"))
}

recordGrob <- function(expr, list,
                       name=NULL, gp=NULL, vp=NULL) {
  grob(expr=substitute(expr), list=list,
       name=name, gp=gp, vp=vp, cl="recordedGrob")
}

# Must only generate a grob, not modify drawing context
makeContent.delayedgrob <- function(x) {
    grob <- eval(x$expr, x$list, getNamespace("grid"))
    if (is.grob(grob)) {
        children <- gList(grob)
    } else if (is.gList(grob)) {
        children <- grob
    } else {
        stop("'expr' must return a grob or gList")
    }
    x <- setChildren(x, children)
    x
}

grid.delay <- function(expr, list,
                       name=NULL, gp=NULL, vp=NULL) {
    grid.draw(gTree(expr=substitute(expr), list=list,
                    name=name, gp=gp, vp=vp, cl="delayedgrob"))
}

delayGrob <- function(expr, list,
                      name=NULL, gp=NULL, vp=NULL) {
    gTree(expr=substitute(expr), list=list,
          name=name, gp=gp, vp=vp, cl="delayedgrob")
}