Nothing
grid.patternFill <- function(path, pattern = NULL, label = NULL,
alpha = 1, group = TRUE, redraw = FALSE,
strict = FALSE, grep = FALSE, global = FALSE) {
if (is.null(label) & is.null(pattern)) {
stop("At least one of 'label' or 'pattern' must be supplied")
} else if (is.null(label)) {
label <- getNewLabel("gridSVG.patternFill")
registerPatternFill(label, pattern)
pattern <- NULL # use the ref from now on
} else if (is.null(pattern)) {
checkForDefinition(label)
} else {
checkExistingDefinition(label)
registerPatternFill(label, pattern)
pattern <- NULL # use the ref from now on
}
grobApply(path, function(path) {
grid.set(path, patternFillGrob(grid.get(path), pattern = pattern,
label = label, alpha = alpha,
group = group),
redraw = redraw)
}, strict = strict, grep = grep, global = global)
invisible()
}
patternFillGrob <- function(x, pattern = NULL, label = NULL,
alpha = 1, group = TRUE) {
if (is.null(label) & is.null(pattern)) {
stop("At least one of 'label' or 'pattern' must be supplied")
} else if (is.null(label)) {
label <- getNewLabel("gridSVG.patternFill")
registerPatternFill(label, pattern)
} else if (is.null(pattern)) {
checkForDefinition(label)
} else {
checkExistingDefinition(label)
registerPatternFill(label, pattern)
}
if (length(alpha) != length(label))
alpha <- rep(alpha, length.out = length(label))
x$referenceLabel <- c(x$referenceLabel, label)
# Attribs to be garnished *at draw time*. In particular needs to be
# done because the label ID is not known until then, because of things
# like prefixes and separators.
x$patternFillLabel <- label
x$patternFillAlpha <- alpha
x$patternFillGroup <- group
class(x) <- unique(c("patternFilled.grob", class(x)))
x
}
pattern <- function(grob = NULL,
x = unit(0, "npc"), y = unit(0, "npc"),
width = unit(0.1, "npc"), height = unit(0.1, "npc"),
default.units = "npc",
just = "centre", hjust = NULL, vjust = NULL,
dev.width = 7, dev.height = 7) {
if (! is.unit(x))
x <- unit(x, default.units)
if (! is.unit(y))
y <- unit(y, default.units)
if (! is.unit(width))
width <- unit(width, default.units)
if (! is.unit(height))
height <- unit(height, default.units)
pattern <- list(grob = grob,
x = x, y = y,
width = width, height = height,
just = just, hjust = hjust, vjust = vjust,
dev.width = dev.width, dev.height = dev.height)
class(pattern) <- "pattern"
pattern
}
registerPatternFill <- function(label, pattern = NULL, ...) {
checkExistingDefinition(label)
refDefinitions <- get("refDefinitions", envir = .gridSVGEnv)
if (is.null(pattern)) {
pattern <- gridSVG::pattern(...)
} else if (! inherits(pattern, "pattern")) {
stop("'pattern' must be a 'pattern' object")
}
if (is.null(pattern$grob))
stop("A grob must be given for a fill pattern definition")
# Now convert *at time of definition* to absolute units (inches)
loc <- leftbottom(pattern$x, pattern$y, pattern$width, pattern$height,
pattern$just, pattern$hjust, pattern$vjust, NULL)
x <- loc$x
y <- loc$y
width <- convertWidth(pattern$width, "inches")
height <- convertHeight(pattern$height, "inches")
# ID will be overwritten later, because we might change
# the separator used for "id.sep"
defList <- list(
label = label,
id = getID(label, "ref"),
grob = pattern$grob,
vp = getAbsoluteVp(),
x = x,
y = y,
width = width,
height = height,
dev.width = pattern$dev.width,
dev.height = pattern$dev.height
)
class(defList) <- "patternFillDef"
refDefinitions[[label]] <- defList
assign("refDefinitions", refDefinitions, envir = .gridSVGEnv)
assign("refUsageTable",
rbind(get("refUsageTable", envir = .gridSVGEnv),
data.frame(label = label, used = FALSE,
stringsAsFactors = FALSE)),
envir = .gridSVGEnv)
# Return NULL invisibly because we don't actually care what the
# definition looks like until gridSVG tries to draw it.
invisible()
}
registerPatternFillRef <- function(label, refLabel, pattern = NULL, ...) {
checkExistingDefinition(label)
refDefinitions <- get("refDefinitions", envir = .gridSVGEnv)
if (! refLabel %in% names(refDefinitions))
stop(paste("The reference labelled", sQuote(label), "does not exist."))
if (is.null(pattern)) {
pattern <- gridSVG::pattern(...)
} else if (! inherits(pattern, "pattern")) {
stop("'pattern' must be a 'pattern' object")
}
# Now convert *at time of definition* to absolute units (inches)
offsets <- getAbsoluteOffset()
loc <- leftbottom(pattern$x, pattern$y,
pattern$width, pattern$height,
pattern$just, pattern$hjust, pattern$vjust, NULL)
x <- loc$x + offsets[1]
y <- loc$y + offsets[2]
width <- convertWidth(pattern$width, "inches")
height <- convertHeight(pattern$height, "inches")
defList <- list(
label = label,
refLabel = refLabel,
id = getID(label, "ref"),
x = x,
y = y,
width = width,
height = height
)
class(defList) <- "patternFillRefDef"
refDefinitions[[label]] <- defList
assign("refDefinitions", refDefinitions, envir = .gridSVGEnv)
assign("refUsageTable",
rbind(get("refUsageTable", envir = .gridSVGEnv),
data.frame(label = label, used = FALSE,
stringsAsFactors = FALSE)),
envir = .gridSVGEnv)
# Return NULL invisibly because we don't actually care what the
# definition looks like until gridSVG tries to draw it.
invisible()
}
primToDev.patternFilled.grob <- function(x, dev) {
setLabelUsed(x$referenceLabel)
label <- getLabelID(x$patternFillLabel)
# Allowing fill-opacity to be set by a garnish because
# grid only knows about a colour and its opacity. If we use a
# reference instead of a then nothing is known about the opacity.
# We want to ensure that we can still set it, so use the garnish
# to overwrite it.
pg <- garnishGrob(x, fill = paste0("url(#", label, ")"),
"fill-opacity" = x$patternFillAlpha,
group = x$patternFillGroup)
# Now need to remove all pattern fill appearances in the class list.
# This is safe because repeated pattern filling just clobbers existing
# attributes.
cl <- class(pg)
class(pg) <- cl[cl != "patternFilled.grob"]
primToDev(pg, dev)
}
drawDef.patternFillDef <- function(def, dev) {
svgdev <- dev@dev
# Convert grid coords to SVG coords
x <- round(cx(def$x, dev), 2)
y <- round(cy(def$y, dev), 2)
width <- round(cw(def$width, dev), 2)
height <- round(ch(def$height, dev), 2)
# Checking for flipped scales
if (width < 0) {
x <- x + width # shifts x to the left
width <- abs(width)
}
if (height < 0) {
y <- y + height # shifts y down
height <- abs(height)
}
# Attempt to use a known-safe prefix
# If the prefix is safe, then it will *always* be safe
# because the names are known *after* content is drawn
# and the referenced labels must be unique
prefix <- paste0("gridSVG.patternFill.", def$id)
# There is a little bit of replication going on from
# 'grid.export' but it avoids some problems.
# We could use 'grid.export' recursively but we lose the ability to
# definitely generate unique names if that is the case because usage
# tables would be wiped.
# A viewport and gTree are forced to ensure everything is unique because
# we want paths to be used.
# We do not care at this point whether it is strictly necessary to
# perform all of this because we just want unique IDs.
olddev <- dev.cur()
pdf(file = NULL, width = def$dev.width, height = def$dev.height)
newdev <- openSVGDev("", res = dev@res,
width = def$dev.width, height = def$dev.height)
pushViewport(viewport(name = getID(prefix, "vp")))
grid.draw(gTree(name = getID(prefix, "grob"),
children = gList(grid.force(def$grob)),
gp = get.gpar())) # Force gp to ensure correct styling
grid.force(redraw = FALSE)
gt <- grid.grab(name = "gridSVG", wrap = TRUE)
gridToDev(gt, newdev)
newroot <- devClose(newdev)
viewBox <- xmlGetAttr(newroot, "viewBox")
gridSVGNode <- prefixName("gridSVG")
# Clone this node so that when the pattern definition refers to
# namespaces (e.g. rasterGrobs have 'xlink:href'), the namespaces
# are not destroyed when this temporary device is closed.
gridSVGNode <-
xmlClone(getNodeSet(newroot,
paste0("//*[@id='", gridSVGNode, "']"))[[1]])
dev.off()
dev.set(olddev)
# Creating the pattern element
pattern <- newXMLNode("pattern",
attrs = list(id = def$id, x = x, y = y,
width = width, height = height,
viewBox = viewBox,
patternUnits = "userSpaceOnUse"),
parent = svgDevParent(svgdev))
# Assigning its children
xmlChildren(pattern) <- xmlChildren(gridSVGNode)
}
drawDef.patternFillRefDef <- function(def, dev) {
svgdev <- dev@dev
# Convert grid coords to SVG coords
x <- round(cx(def$x, dev), 2)
y <- round(cy(def$y, dev), 2)
width <- round(cw(def$width, dev), 2)
height <- round(ch(def$height, dev), 2)
# Checking for flipped scales
if (width < 0) {
x <- x + width # shifts x to the left
width <- abs(width)
}
if (height < 0) {
y <- y + height # shifts y down
height <- abs(height)
}
# Creating the pattern element
pattern <- newXMLNode("pattern",
attrs = list(id = def$id, x = x, y = y,
width = width, height = height,
"xlink:href" =
paste0("#", getLabelID(def$refLabel))),
parent = svgDevParent(svgdev))
}
# Ensure the patterns are retained on a forced grob
forceGrob.patternFilled.grob <- function(x) {
y <- NextMethod()
if (inherits(y, "forcedgrob")) {
y$referenceLabel <- x$referenceLabel
y$patternFillLabel <- x$patternFillLabel
y$patternFillAlpha <- x$patternFillAlpha
y$patternFillGroup <- x$patternFillGroup
class(y) <- unique(c("patternFilled.grob", class(y)))
}
y
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.