| # File src/library/grid/R/grob.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/ |
| |
| ###################################### |
| # 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(C_getDisplayList)[1L:grid.Call(C_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(C_getDLindex) |
| # Destructively modify the DL elt |
| grid.Call(C_setDLindex, as.integer(result$index)) |
| grid.Call(C_setDLelt, result$grob) |
| # Reset the DL index |
| grid.Call(C_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(C_getDLindex) |
| result <- NULL |
| index <- 1 |
| while (index < dl.index && |
| (is.null(result) || global)) { |
| grob <- getGrobFromGPath(grid.Call(C_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(C_getDLindex) |
| index <- 1 |
| result <- list(index=0, grob=NULL) |
| while (index < dl.index && |
| result$index == 0) { |
| result$grob <- setGrobFromGPath(grid.Call(C_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(C_getDLindex) |
| index <- 1 |
| grob <- NULL |
| found <- FALSE |
| while (index < dl.index && |
| (is.null(grob) || global)) { |
| grob <- editGrobFromGPath(grid.Call(C_getDLelt, |
| as.integer(index)), |
| specs, |
| NULL, gPath, strict, grep, global) |
| if (!is.null(grob)) { |
| # Destructively modify the DL elt |
| grid.Call(C_setDLindex, as.integer(index)) |
| grid.Call(C_setDLelt, grob) |
| # Reset the DL index |
| grid.Call(C_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(C_getDLindex) |
| index <- 1 |
| grob <- NULL |
| found <- FALSE |
| while (index < dl.index && |
| (is.null(grob) || global)) { |
| grob <- addGrobFromGPath(grid.Call(C_getDLelt, |
| as.integer(index)), |
| child, |
| NULL, gPath, strict, grep, global) |
| if (!is.null(grob)) { |
| # Destructively modify the DL elt |
| grid.Call(C_setDLindex, as.integer(index)) |
| grid.Call(C_setDLelt, grob) |
| # Reset the DL index |
| grid.Call(C_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(C_getDLindex) |
| index <- 1 |
| grob <- NULL |
| found <- FALSE |
| while (index < dl.index && |
| (is.null(grob) || global)) { |
| grob <- removeGrobFromGPath(grid.Call(C_getDLelt, as.integer(index)), |
| name, |
| NULL, gPath, strict, grep, grepname, |
| global, warn) |
| if (!is.null(grob)) { |
| # Destructively modify the DL elt |
| grid.Call(C_setDLindex, as.integer(index)) |
| grid.Call(C_setDLelt, grob) |
| # Reset the DL index |
| grid.Call(C_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(C_getDLindex) |
| index <- 1 |
| grob <- NULL |
| found <- FALSE |
| while (index < dl.index && |
| (is.null(grob) || global)) { |
| grob <- grid.Call(C_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(C_setDLindex, as.integer(index)) |
| grid.Call(C_setDLelt, NULL) |
| # Reset the DL index |
| grid.Call(C_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(C_setDLindex, as.integer(index)) |
| grid.Call(C_setDLelt, grob) |
| # Reset the DL index |
| grid.Call(C_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(C_getDLindex) |
| result <- NULL |
| index <- 1 |
| while (index < dl.index && is.null(result)) { |
| result <- findgrob(grid.Call(C_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) { |
| # If 'x' is NULL, draw nothing |
| if (!is.null(x)) |
| UseMethod("grid.draw") |
| } |
| |
| 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, engineDL=FALSE) |
| } |
| } |
| |
| 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(C_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(C_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(C_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(C_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(C_setDLon, dlon)) |
| # Save current gpar |
| tempgpar <- grid.Call(C_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(C_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(C_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(C_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(C_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(C_setDLon, dlon)) |
| # Save current grob and current gpar |
| tempgrob <- grid.Call(C_getCurrentGrob) |
| tempgpar <- grid.Call(C_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(C_setGPar, tempgpar) |
| grid.Call(C_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(C_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(C_getDLindex) |
| if (dl.index > 1) |
| # Start at 2 because first element is viewport[ROOT] |
| for (i in 2:dl.index) { |
| grid.draw(grid.Call(C_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(C_setDLon, FALSE) |
| on.exit(grid.Call(C_setDLon, dlon)) |
| tempgpar <- grid.Call(C_getGPar) |
| on.exit(grid.Call(C_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(C_setDLon, FALSE) |
| on.exit(grid.Call(C_setDLon, dlon)) |
| tempgrob <- grid.Call(C_getCurrentGrob) |
| tempgpar <- grid.Call(C_getGPar) |
| on.exit({ grid.Call(C_setGPar, tempgpar) |
| grid.Call(C_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(C_getDLindex) |
| if (dl.index > 1) { |
| # Start at 2 because first element is viewport[ROOT] |
| for (i in 2:dl.index) { |
| grid.Call(C_setDLindex, as.integer(i - 1)) |
| grid.Call(C_setDLelt, |
| forceGrob(grid.Call(C_getDLelt, as.integer(i - 1)))) |
| } |
| grid.Call(C_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(C_getDLindex) |
| if (dl.index > 1) { |
| # Start at 2 because first element is viewport[ROOT] |
| for (i in 2:dl.index) { |
| grid.Call(C_setDLindex, as.integer(i - 1)) |
| grid.Call(C_setDLelt, |
| revert(grid.Call(C_getDLelt, as.integer(i - 1)))) |
| } |
| grid.Call(C_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) |
| } |
| |
