src/library/grid/R/grab.R - R - Git at Google

 #  File src/library/grid/R/grab.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/

 #########
 # Generate a gTree from the current display list
 #
 # Or from an expression
 # (recording on to a null graphics device)
 #########
 rootVP <- function(pvp) {
   match(pvp$name, "ROOT", nomatch=FALSE)
 }

 # List the children of the current vp (as a vpList)
 current.vpList <- function() {
   cpvp <- grid.Call(C_currentViewport)
   if (no.children(cpvp$children))
     NULL
   else
     vpListFromNode(cpvp)
 }

 current.vpNames <- function() {
   ls(grid.Call(C_currentViewport)$children)
 }

 # vp might be a viewport, or a vpList, or a vpStack, or a vpTree
 vpExists <- function(vp) {
   UseMethod("vpExists")
 }

 vpExists.viewport <- function(vp) {
   exists(vp$name, .Call(C_currentViewport)$children)
 }

 vpExists.vpStack <- function(vp) {
   vpExists(vp[[1L]])
 }

 vpExists.vpList <- function(vp) {
   any(vapply(vp, vpExists, logical(1L), simplify=TRUE))
 }

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

 # Handle vpPaths in a vpStack or vpTree
 # Not a problem to downViewport() to a viewport that already exists
 vpExists.vpPath <- function(vp) {
     FALSE
 }

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

 wrap.default <- function(x, ...) {
   if (!is.null(x))
     stop("invalid display list element")
   NULL
 }

 wrap.grob <- function(x, grobs=FALSE, ...) {
     if (grobs) {
         recordGrob(grid.draw(x), list(x=x))
     } else {
         x
     }
 }

 wrap.viewport <- function(x, ...) {
   recordGrob(pushViewport(vp), list(vp=x))
 }

 wrap.pop <- function(x, ...) {
   recordGrob(popViewport(n), list(n=x))
 }

 wrap.up <- function(x, ...) {
   recordGrob(upViewport(n), list(n=x))
 }

 wrap.vpPath <- function(x, ...) {
   recordGrob(downViewport(path), list(path=x))
 }

 # Grab the display list on the current device
 # ... are passed to gTree
 # If warn is 0, issue no warnings
 # If warn is 1, issue warnings about situations that are definitely
 #   NOT captured correctly (e.g., reuse of top-level grob name)
 # If warn is 2, issue warnings about situations that
 #   MAY not get captured correctly (e.g., top-level downViewport)
 # If wrap is TRUE, grab will wrap all pushes and grobs
 #   in a gTree
 grabDL <- function(warn, wrap, wrap.grobs=FALSE, ...) {
   gList <- NULL
   dl.index <- grid.Call(C_getDLindex)
   if (dl.index > 1) {
       if (warn > 0 && !wrap.grobs) {
           names <- getNames()
           ## Check for overwriting existing grob
           if (length(unique(names)) != length(names))
               warning("one or more grobs overwritten (grab WILL not be faithful; try 'wrap.grobs = TRUE')")
       }
       if (!wrap) {
           grid.newpage(recording=FALSE)
       }
       ## Start at 2 because first element is viewport[ROOT]
       for (i in 2:dl.index) {
           ## Do all of this as a big ifelse rather than
           ## dispatching to a function call per element because
           ## we need to work with whole DL at times, not
           ## just individual elements
           elt <- grid.Call(C_getDLelt, as.integer(i - 1))
           if (wrap)
               gList <- addToGList(wrap(elt, grobs=wrap.grobs), gList)
           else {
               ## ####################
               ## grabGrob
               ## ####################
               if (inherits(elt, "grob")) {
                   ## Enforce grob$vp now and set grob$vp to NULL
                   ## Will be replaced later with full vpPath
                   tempvp <- elt$vp
                   if (warn > 1) {
                       ## Check to see if about to push a viewport
                       ## with existing viewport name
                       if (inherits(tempvp, "viewport") &&
                           vpExists(tempvp))
                           warning("viewport overwritten (grab MAY not be faithful)")
                   }
                   if (!is.null(tempvp))
                       tempdepth <- depth(tempvp)
                   grid.draw(tempvp, recording=FALSE)
                   ## vpPath after grob$vp slot has been pushed
                   ## Has to be recorded here in case grob drawing
                   ## pushes (and does not pop) more viewports
                   drawPath <- current.vpPath()
                   elt$vp <- NULL
                   grid.draw(elt, recording=FALSE)
                   if (warn > 1) {
                       ## Compare new vpPath
                       ## If not same, the grob has pushed some viewports
                       ## and not popped or upped them
                       pathSame <- TRUE
                       if (!(is.null(drawPath) && is.null(current.vpPath()))) {
                           if (is.null(drawPath))
                               pathSame <- FALSE
                           else if (is.null(current.vpPath()))
                               pathSame <- FALSE
                           else if (as.character(drawPath) !=
                                    as.character(current.vpPath()))
                               pathSame <- FALSE
                       }
                       if (!pathSame)
                           warning("grob pushed viewports and did not pop/up them (grab MAY not be faithful)")
                   }
                   elt$vp <- drawPath
                   if (!is.null(tempvp))
                       upViewport(tempdepth, recording=FALSE)
                   gList <- addToGList(elt, gList)
                   ## ####################
                   ## grabViewport
                   ## ####################
               } else if (inherits(elt, "viewport")) {
                   ## Includes viewports, vpLists, vpTrees, and vpStacks
                   ## Check to see if about to push a viewport
                   ## with existing viewport name
                   if (warn > 1) {
                       if (vpExists(elt))
                           warning("viewport overwritten (grab MAY not be faithful)")
                   }
                   grid.draw(elt, recording=FALSE)
                   ## ####################
                   ## grabPop
                   ## ####################
               } else if (inherits(elt, "pop")) {
                   ## Replace pop with up
                   upViewport(elt, recording=FALSE)

                   ## ####################
                   ## grabDefault
                   ## ####################
               } else {
                   grid.draw(elt, recording=FALSE)
               }
           } ## matches if (wrap)
       }
       ## Go to top level
       upViewport(0, recording=FALSE)
       gTree(children=gList, childrenvp=current.vpList(), ...)
   } else {
       NULL
   }
 }

 # expr is ignored if dev is NULL
 # otherwise, it should be an expression, like postscript("myfile.ps")
 grid.grab <- function(warn=2, wrap=wrap.grobs, wrap.grobs=FALSE, ...) {
   grabDL(warn, wrap, wrap.grobs, ...)
 }

 offscreen <- function(width, height) {
     pdf(file=NULL, width=width, height=height)
 }

 grid.grabExpr <- function(expr, warn=2, wrap=wrap.grobs, wrap.grobs=FALSE,
                           width=7, height=7, device=offscreen, ...) {
     ## Start an "offline" PDF device for this function
     cd <- dev.cur()
     device(width, height)
     grabd <- dev.cur()
     on.exit({ dev.set(grabd); dev.off(); dev.set(cd) })
     ## Run the graphics code in expr
     ## Rely on lazy evaluation for correct "timing"
     eval(expr)
     ## Grab the DL on the new device
     grabDL(warn, wrap, wrap.grobs, ...)
 }

 #########################
 # A different sort of capture ...
 # Just grab the screen raster image
 #########################

 grid.cap <- function() {
     # This does not need recording on the display list
     grid.Call(C_cap)
 }
	# File src/library/grid/R/grab.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/

	#########
	# Generate a gTree from the current display list
	#
	# Or from an expression
	# (recording on to a null graphics device)
	#########
	rootVP <- function(pvp) {
	match(pvp$name, "ROOT", nomatch=FALSE)
	}

	# List the children of the current vp (as a vpList)
	current.vpList <- function() {
	cpvp <- grid.Call(C_currentViewport)
	if (no.children(cpvp$children))
	NULL
	else
	vpListFromNode(cpvp)
	}

	current.vpNames <- function() {
	ls(grid.Call(C_currentViewport)$children)
	}

	# vp might be a viewport, or a vpList, or a vpStack, or a vpTree
	vpExists <- function(vp) {
	UseMethod("vpExists")
	}

	vpExists.viewport <- function(vp) {
	exists(vp$name, .Call(C_currentViewport)$children)
	}

	vpExists.vpStack <- function(vp) {
	vpExists(vp[[1L]])
	}

	vpExists.vpList <- function(vp) {
	any(vapply(vp, vpExists, logical(1L), simplify=TRUE))
	}

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

	# Handle vpPaths in a vpStack or vpTree
	# Not a problem to downViewport() to a viewport that already exists
	vpExists.vpPath <- function(vp) {
	FALSE
	}

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

	wrap.default <- function(x, ...) {
	if (!is.null(x))
	stop("invalid display list element")
	NULL
	}

	wrap.grob <- function(x, grobs=FALSE, ...) {
	if (grobs) {
	recordGrob(grid.draw(x), list(x=x))
	} else {
	x
	}
	}

	wrap.viewport <- function(x, ...) {
	recordGrob(pushViewport(vp), list(vp=x))
	}

	wrap.pop <- function(x, ...) {
	recordGrob(popViewport(n), list(n=x))
	}

	wrap.up <- function(x, ...) {
	recordGrob(upViewport(n), list(n=x))
	}

	wrap.vpPath <- function(x, ...) {
	recordGrob(downViewport(path), list(path=x))
	}

	# Grab the display list on the current device
	# ... are passed to gTree
	# If warn is 0, issue no warnings
	# If warn is 1, issue warnings about situations that are definitely
	# NOT captured correctly (e.g., reuse of top-level grob name)
	# If warn is 2, issue warnings about situations that
	# MAY not get captured correctly (e.g., top-level downViewport)
	# If wrap is TRUE, grab will wrap all pushes and grobs
	# in a gTree
	grabDL <- function(warn, wrap, wrap.grobs=FALSE, ...) {
	gList <- NULL
	dl.index <- grid.Call(C_getDLindex)
	if (dl.index > 1) {
	if (warn > 0 && !wrap.grobs) {
	names <- getNames()
	## Check for overwriting existing grob
	if (length(unique(names)) != length(names))
	warning("one or more grobs overwritten (grab WILL not be faithful; try 'wrap.grobs = TRUE')")
	}
	if (!wrap) {
	grid.newpage(recording=FALSE)
	}
	## Start at 2 because first element is viewport[ROOT]
	for (i in 2:dl.index) {
	## Do all of this as a big ifelse rather than
	## dispatching to a function call per element because
	## we need to work with whole DL at times, not
	## just individual elements
	elt <- grid.Call(C_getDLelt, as.integer(i - 1))
	if (wrap)
	gList <- addToGList(wrap(elt, grobs=wrap.grobs), gList)
	else {
	## ####################
	## grabGrob
	## ####################
	if (inherits(elt, "grob")) {
	## Enforce grob$vp now and set grob$vp to NULL
	## Will be replaced later with full vpPath
	tempvp <- elt$vp
	if (warn > 1) {
	## Check to see if about to push a viewport
	## with existing viewport name
	if (inherits(tempvp, "viewport") &&
	vpExists(tempvp))
	warning("viewport overwritten (grab MAY not be faithful)")
	}
	if (!is.null(tempvp))
	tempdepth <- depth(tempvp)
	grid.draw(tempvp, recording=FALSE)
	## vpPath after grob$vp slot has been pushed
	## Has to be recorded here in case grob drawing
	## pushes (and does not pop) more viewports
	drawPath <- current.vpPath()
	elt$vp <- NULL
	grid.draw(elt, recording=FALSE)
	if (warn > 1) {
	## Compare new vpPath
	## If not same, the grob has pushed some viewports
	## and not popped or upped them
	pathSame <- TRUE
	if (!(is.null(drawPath) && is.null(current.vpPath()))) {
	if (is.null(drawPath))
	pathSame <- FALSE
	else if (is.null(current.vpPath()))
	pathSame <- FALSE
	else if (as.character(drawPath) !=
	as.character(current.vpPath()))
	pathSame <- FALSE
	}
	if (!pathSame)
	warning("grob pushed viewports and did not pop/up them (grab MAY not be faithful)")
	}
	elt$vp <- drawPath
	if (!is.null(tempvp))
	upViewport(tempdepth, recording=FALSE)
	gList <- addToGList(elt, gList)
	## ####################
	## grabViewport
	## ####################
	} else if (inherits(elt, "viewport")) {
	## Includes viewports, vpLists, vpTrees, and vpStacks
	## Check to see if about to push a viewport
	## with existing viewport name
	if (warn > 1) {
	if (vpExists(elt))
	warning("viewport overwritten (grab MAY not be faithful)")
	}
	grid.draw(elt, recording=FALSE)
	## ####################
	## grabPop
	## ####################
	} else if (inherits(elt, "pop")) {
	## Replace pop with up
	upViewport(elt, recording=FALSE)

	## ####################
	## grabDefault
	## ####################
	} else {
	grid.draw(elt, recording=FALSE)
	}
	} ## matches if (wrap)
	}
	## Go to top level
	upViewport(0, recording=FALSE)
	gTree(children=gList, childrenvp=current.vpList(), ...)
	} else {
	NULL
	}
	}

	# expr is ignored if dev is NULL
	# otherwise, it should be an expression, like postscript("myfile.ps")
	grid.grab <- function(warn=2, wrap=wrap.grobs, wrap.grobs=FALSE, ...) {
	grabDL(warn, wrap, wrap.grobs, ...)
	}

	offscreen <- function(width, height) {
	pdf(file=NULL, width=width, height=height)
	}

	grid.grabExpr <- function(expr, warn=2, wrap=wrap.grobs, wrap.grobs=FALSE,
	width=7, height=7, device=offscreen, ...) {
	## Start an "offline" PDF device for this function
	cd <- dev.cur()
	device(width, height)
	grabd <- dev.cur()
	on.exit({ dev.set(grabd); dev.off(); dev.set(cd) })
	## Run the graphics code in expr
	## Rely on lazy evaluation for correct "timing"
	eval(expr)
	## Grab the DL on the new device
	grabDL(warn, wrap, wrap.grobs, ...)
	}

	#########################
	# A different sort of capture ...
	# Just grab the screen raster image
	#########################

	grid.cap <- function() {
	# This does not need recording on the display list
	grid.Call(C_cap)
	}