library(grid)

# Physical units in viewport of height 0
pushViewport(viewport(height = 0))
stopifnot(is.finite(convertHeight(unit(72, "bigpts"), "inches", valueOnly = TRUE)))
popViewport()

# The gpar font settings for a grob should affect the grob itself
stopifnot(round(convertHeight(grobHeight(rectGrob(height=unit(1, "lines"), 
                                                  gp=gpar(lineheight=2))),
                              "inches", valueOnly=TRUE) -
                convertHeight(grobHeight(rectGrob(height=unit(1, "lines"),
                                                  vp=viewport(
                                                    gp=gpar(lineheight=2)))),
                              "inches", valueOnly=TRUE),
                digits=5) == 0)

# Calculation of size of packed grob with gp which is non-empty
gf1 <- frameGrob(gp=gpar(fontsize=20))
gf1 <- packGrob(gf1, textGrob("howdy"))
gf1 <- packGrob(gf1, rectGrob(), col=1, row=1)
gf2 <- frameGrob()
gf2 <- packGrob(gf2, gf1)
gf2 <- packGrob(gf2, rectGrob(gp=gpar(col="red")), col=1, row=1)
stopifnot(round(convertWidth(grobWidth(gf1),
                             "inches", valueOnly=TRUE) -
                convertWidth(grobWidth(gf2),
                             "inches", valueOnly=TRUE),
                digits=5) == 0)


library(grid)

HersheyLabel <- function(x, y=unit(.5, "npc")) {
    lines <- strsplit(x, "\n")[[1]]
    if (!is.unit(y))
        y <- unit(y, "npc")
    n <- length(lines)
    if (n > 1) {
        y <- y + unit(rev(seq(n)) - mean(seq(n)), "lines")
    }
    grid.text(lines, y=y, gp=gpar(fontfamily="HersheySans"))
}

################################################################################
## Enforce a clipping path on a viewport
grid.newpage()
pushViewport(viewport(clip=circleGrob()))
grid.rect(gp=gpar(fill="grey"))
HersheyLabel("push circle clipping path
rect
grey circle")

## NORMAL clipping(!)
grid.newpage()
pushViewport(viewport(width=.5, height=.5, clip=TRUE))
grid.circle(r=.6, gp=gpar(fill="grey"))
HersheyLabel("push clipping rect
circle
squared circle")

## A slightly more complex clipping path
grid.newpage()
pushViewport(viewport(clip=circleGrob(1:2/3, r=unit(.5, "in"))))
grid.rect(gp=gpar(fill="grey"))
popViewport()
HersheyLabel("push two circles clipping path
rect
two circles")
    
## Clip to a polygon
grid.newpage()
pushViewport(viewport(width=.5, height=.5,
                      clip=polygonGrob(c(.2, .4, .6, .2), c(.2, .6, .4, .1))))
grid.rect(gp=gpar(fill="grey"))
popViewport()
HersheyLabel("push clipping path
rect
grey wedge")

## Rotated clip rect!
grid.newpage()
pushViewport(viewport(width=.5, height=.6, angle=45, clip=rectGrob()))
grid.circle(r=.6, gp=gpar(fill="grey"))
HersheyLabel("push rotated viewport
with clipping path
circle
square-sided circle")

## Clipping gradient output
## (gradient on viewport)
grid.newpage()
pushViewport(viewport(clip=circleGrob(1:2/3, r=unit(.5, "in")),
                      gp=gpar(fill=linearGradient())))
grid.rect()
popViewport()
HersheyLabel("push clipping path
gradient on viewport
two circles (one gradient)")

## Clipping gradient output
## (gradient on grob)
grid.newpage()
pushViewport(viewport(clip=circleGrob(1:2/3, r=unit(.5, "in"))))
grid.rect(gp=gpar(fill=linearGradient()))
popViewport()
HersheyLabel("push clipping path
rect with gradient
two circles (one gradient)")

## Inheriting clipping paths (between viewports)
grid.newpage()
pushViewport(viewport(clip=circleGrob()))
pushViewport(viewport())
grid.rect(gp=gpar(fill="grey"))
HersheyLabel("push clipping path
push again (inherit clip path)
rect
grey circle")

## Restoring clipping paths (between viewports)
grid.newpage()
pushViewport(viewport(clip=circleGrob()))
pushViewport(viewport())
pushViewport(viewport())
upViewport()
grid.rect(gp=gpar(fill="grey"))
HersheyLabel("push clipping path
push again (inherit clip path)
push again (inherit clip path)
up (restore inherited clip path)
rect
grey circle")

## Revisiting clipping on a viewport
## upViewport()
grid.newpage()
pushViewport(viewport(clip=circleGrob()))
grid.rect(gp=gpar(fill="grey"))
upViewport()
grid.rect(gp=gpar(fill=rgb(0,0,1,.2)))
HersheyLabel("push clipping path
grey circle
upViewport
page all (translucent) blue")

## downViewport()
grid.newpage()
pushViewport(viewport(clip=circleGrob(), name="vp"))
grid.rect(height=.5, gp=gpar(fill="grey"))
upViewport()
downViewport("vp")
grid.rect(gp=gpar(fill=rgb(0,0,1,.2)))
HersheyLabel("push clipping path
rounded rect
upViewport
downViewport
blue (translucent) circle")

## clip rect to clip path back to clip rect
grid.newpage()
pushViewport(viewport(width=.5, height=.5, clip=TRUE))
pushViewport(viewport(clip=circleGrob()))
grid.rect(gp=gpar(fill="grey"))
upViewport()
grid.circle(r=.6, gp=gpar(fill=rgb(0,0,1,.2)))
HersheyLabel("push clipping rect
push clipping path
grey circle
upViewport
squared (translucent) blue circle")

## clip path to clip rect back to clip path
grid.newpage()
pushViewport(viewport(clip=circleGrob()))
pushViewport(viewport(width=.5, height=.5, clip=TRUE))
grid.circle(r=.6, gp=gpar(fill="grey"))
upViewport()
grid.rect(gp=gpar(fill=rgb(0,0,1,.2)))
HersheyLabel("push clipping path
push clipping rect
squared circle
upViewport
grey (translucent) blue circle")

## Clipping path makes the clipping region BIGGER
grid.newpage()
pushViewport(viewport(width=.5, height=.5, clip=TRUE))
grid.rect()
pushViewport(viewport(clip=circleGrob(r=.6)))
grid.rect(width=1.2, height=1.2, gp=gpar(fill=rgb(0,0,1,.2)))
HersheyLabel("push clip rect (small)
rect
push clip path (bigger)
rect (big)
blue (translucent) circle")

## Clipping path makes the clipping region BIGGER
## (even when clipping path contains viewport)
grid.newpage()
pushViewport(viewport(width=.5, height=.5, clip=TRUE))
grid.rect()
pushViewport(viewport(clip=circleGrob(r=.6, vp=viewport())))
grid.rect(width=1.2, height=1.2, gp=gpar(fill=rgb(0,0,1,.2)))
HersheyLabel("push clip rect (small)
rect
push clip path with viewport (bigger)
rect (big)
blue (translucent) circle")


######################################
## Replaying the graphics display list

## Resizing device
grid.newpage()
pushViewport(viewport(clip=circleGrob()))
grid.rect(gp=gpar(fill="grey"))
HersheyLabel("push clip path
rect
grey circle
(for resizing)")

## Record and replay
grid.newpage()
pushViewport(viewport(clip=circleGrob()))
grid.rect(gp=gpar(fill="grey"))
x <- recordPlot()
HersheyLabel("push clip path
rect
grey circle
(for recording)")
print(x)
HersheyLabel("push clip path
rect
record plot
replay plot
grey circle")


######################################
## Test of 'grid' display list

## Grabbing a grob with clipping
## (replaying the 'grid' display list)
grid.newpage()
pushViewport(viewport(clip=circleGrob()))
grid.rect(gp=gpar(fill="grey"))
HersheyLabel("push clip path
rect
grey circle
(for grid.grab)")
x <- grid.grab()
grid.newpage()
grid.draw(x)
HersheyLabel("push clip path
rect
grey circle
grid.grab
grid.draw
grey circle")



######################
## Check for outlawed behaviour
## (clipping and masks are turned off during clipping path resolution)

grid.newpage()
path <- circleGrob(r=.6,
                   vp=viewport(width=.5, height=.5, clip=TRUE))
pushViewport(viewport(clip=path))
grid.rect(gp=gpar(fill="grey"))
popViewport()
HersheyLabel("clipping path is circle with viewport with clip=TRUE
AND circle is larger than viewport
BUT viewport clipping is ignored within clipping path
SO clipping path is just circle
draw rect
result is grey circle")

grid.newpage()
path <- circleGrob(vp=viewport(clip=rectGrob(width=.8, height=.8)))
pushViewport(viewport(clip=path))
grid.rect(gp=gpar(fill="grey"))
popViewport()
HersheyLabel("clip path is circle with viewport with clip path
viewport clip path is rect that squares off the circle
BUT clip paths are ignored within clipping path (with warning)
SO clipping path is just circle
draw rect
result is grey circle")

grid.newpage()
path <- circleGrob(vp=viewport(mask=rectGrob(width=.8, height=.8,
                                             gp=gpar(fill="black"))))
pushViewport(viewport(clip=path))
grid.rect(gp=gpar(fill="grey"))
popViewport()
HersheyLabel("clip path is circle with viewport with mask
viewport mask is rect that squares off the circle
BUT masks are ignored within clipping path (with warning)
SO clipping path is just circle
draw rect
result is grey circle")

grid.newpage()
path <- circleGrob(vp=viewport(mask=rectGrob(width=.8, height=.8,
                                             gp=gpar(fill="black"))))
pushViewport(viewport(clip=path, name="test"))
upViewport()
downViewport("test")
grid.rect(gp=gpar(fill="grey"))
popViewport()
HersheyLabel("same as previous test
EXCEPT that push viewport then pop then down
(and only push should warn)
draw rect
result is grey circle")

## A clipping path within a makeContent() method
grid.newpage()
g <- gTree(cl="test")
makeContent.test <- function(x) {
    setChildren(x, gList(rectGrob(gp=gpar(fill="grey"),
                                  vp=viewport(clip=circleGrob()))))
}
grid.draw(g)
HersheyLabel("custom grob class with makeContent() method
makeContent() adds rectangle with viewport
viewport has circle clip path
result is grey circle")

## A clipping path that makes use of makeContent() method
grid.newpage()
path <- gTree(cl="test")
makeContent.test <- function(x) {
    setChildren(x, gList(circleGrob()))
}
pushViewport(viewport(clip=path))
grid.rect(gp=gpar(fill="grey"))
popViewport()
HersheyLabel("push viewport with clip path
clip path is grob with makeContent() method
makeContent() adds circle
draw rect
result is grey circle")


## save()/load() a recordedPlot containing a clipping path
grid.newpage()
pushViewport(viewport(clip=circleGrob()))
grid.rect(gp=gpar(fill="grey"))
x <- recordPlot()
HersheyLabel("push circle clipping path
rect
grey circle
(for save(recordPlot()))")
f <- tempfile()
saveRDS(x, file=f)
grid.newpage()
y <- readRDS(f)
replayPlot(y)
HersheyLabel("push circle clipping path
rect
grey circle
saveRDS(recordPlot())
replayPlot(readRDS())")

################################################################################
## Clipping paths from text

grid.newpage()
tg <- textGrob("testing", gp=gpar(fontface="bold", cex=4))
pushViewport(viewport(clip=tg))
grid.rect(gp=gpar(fill="grey"))
grid.rect(width=.1, gp=gpar(fill="2"))
popViewport()
HersheyLabel("clipping path from text
grey rect clipped to text
thin red rect (black border) also clipped to text", y=.9)

grid.newpage()
gt <- gTree(children=gList(circleGrob(),
                           textGrob("testing", gp=gpar(fontface="bold", cex=4)),
                           rectGrob(width=.8, height=.5)))
pushViewport(viewport(clip=as.path(gt, rule="evenodd")))
grid.rect(gp=gpar(fill="grey"))
grid.rect(width=.1, gp=gpar(fill="2"))
popViewport()
HersheyLabel("clipping path based on circle and text and rect
with even-odd rule
draw large grey rect and thin red rect
both clipped to text and space between circle and rect
(PDF will NOT include text in clipping path", y=.85)

grid.newpage()
gt <- gTree(children=gList(textGrob("testing", gp=gpar(fontface="bold", cex=4)),
                           circleGrob(),
                           rectGrob(width=.8, height=.5)))
pushViewport(viewport(clip=as.path(gt, rule="evenodd")))
grid.rect(gp=gpar(fill="grey"))
grid.rect(width=.1, gp=gpar(fill="2"))
popViewport()
HersheyLabel("clipping path based on text and circle and rect
with even-odd rule
draw large grey rect and thin red rect
both clipped to text and space between circle and rect
(PDF will ONLY include text in clipping path", y=.85)

######################
## Check resource exhaustion
grid.newpage()
for (i in 1:65) {
    pushViewport(viewport(clip=circleGrob()))
    grid.rect(gp=gpar(fill="grey"))
    HersheyLabel(paste0("viewport ", i, " with clip path
result is grey circle"))
    upViewport()
}

## Text being clipped by path
grid.newpage()
grid.text("testing", gp=gpar(col="grey", cex=3))
path <- circleGrob(r=.05, gp=gpar(fill=NA))
grid.draw(path)
pushViewport(viewport(clip=path))
grid.text("testing", gp=gpar(cex=3))
popViewport()
HersheyLabel("text clipped by circle", y=.8)
    
## Raster being clipped by path
grid.newpage()
grid.raster(matrix(c(.5, 1, 1, .5), nrow=2),
            width=.2, height=.2,
            interpolate=FALSE)
path <- circleGrob(r=.05, gp=gpar(fill=NA))
grid.draw(path)
pushViewport(viewport(clip=path))
grid.raster(matrix(c(0:1, 1:0), nrow=2),
            width=.2, height=.2,
            interpolate=FALSE)
popViewport()
HersheyLabel("raster clipped by circle", y=.8)





library(grid)

HersheyLabel <- function(x, y=unit(.5, "npc")) {
    lines <- strsplit(x, "\n")[[1]]
    if (!is.unit(y))
        y <- unit(y, "npc")
    n <- length(lines)
    if (n > 1) {
        y <- y + unit(rev(seq(n)) - mean(seq(n)), "lines")
    }
    grid.text(lines, y=y, gp=gpar(fontfamily="HersheySans"))
}

r1 <- rectGrob(x=1/3, y=2/3, width=.5, height=.5,
               gp=gpar(col=NA, fill=rgb(.7, 0, 0, .8)))
r2 <- rectGrob(x=2/3, y=1/3, width=.5, height=.5,
               gp=gpar(col=NA, fill=rgb(0, 0, .9, .4)))

group <- function(op) {
    grid.rect()
    grid.group(r2, op, r1)
    HersheyLabel(op, y=1/4)
}
porterDuff <- function() {
    grid.newpage()
    pushViewport(viewport(layout=grid.layout(3, 4, respect=TRUE)))
    pushViewport(viewport(layout.pos.row=1, layout.pos.col=1))
    group("over")
    popViewport()
    pushViewport(viewport(layout.pos.row=1, layout.pos.col=2))
    group("clear")
    popViewport()
    pushViewport(viewport(layout.pos.row=1, layout.pos.col=3))
    group("source")
    popViewport()
    pushViewport(viewport(layout.pos.row=1, layout.pos.col=4))
    group("in")
    popViewport()
    pushViewport(viewport(layout.pos.row=2, layout.pos.col=1))
    group("out")
    popViewport()
    pushViewport(viewport(layout.pos.row=2, layout.pos.col=2))
    group("atop")
    popViewport()
    pushViewport(viewport(layout.pos.row=2, layout.pos.col=3))
    group("dest")
    popViewport()
    pushViewport(viewport(layout.pos.row=2, layout.pos.col=4))
    group("dest.over")
    popViewport()
    pushViewport(viewport(layout.pos.row=3, layout.pos.col=1))
    group("dest.in")
    popViewport()
    pushViewport(viewport(layout.pos.row=3, layout.pos.col=2))
    group("dest.out")
    popViewport()
    pushViewport(viewport(layout.pos.row=3, layout.pos.col=3))
    group("dest.atop")
    popViewport()
    pushViewport(viewport(layout.pos.row=3, layout.pos.col=4))
    group("xor")
    popViewport()
}
blendModes <- function() {
    grid.newpage()
    pushViewport(viewport(layout=grid.layout(3, 4, respect=TRUE)))
    pushViewport(viewport(layout.pos.row=1, layout.pos.col=1))
    group("add")
    popViewport()
    pushViewport(viewport(layout.pos.row=1, layout.pos.col=2))
    group("saturate")
    popViewport()
    pushViewport(viewport(layout.pos.row=1, layout.pos.col=3))
    group("multiply")
    popViewport()
    pushViewport(viewport(layout.pos.row=1, layout.pos.col=4))
    group("screen")
    popViewport()
    pushViewport(viewport(layout.pos.row=2, layout.pos.col=1))
    group("overlay")
    popViewport()
    pushViewport(viewport(layout.pos.row=2, layout.pos.col=2))
    group("darken")
    popViewport()
    pushViewport(viewport(layout.pos.row=2, layout.pos.col=3))
    group("lighten")
    popViewport()
    pushViewport(viewport(layout.pos.row=2, layout.pos.col=4))
    group("color.dodge")
    popViewport()
    pushViewport(viewport(layout.pos.row=3, layout.pos.col=1))
    group("color.burn")
    popViewport()
    pushViewport(viewport(layout.pos.row=3, layout.pos.col=2))
    group("hard.light")
    popViewport()
    pushViewport(viewport(layout.pos.row=3, layout.pos.col=3))
    group("soft.light")
    popViewport()
    pushViewport(viewport(layout.pos.row=3, layout.pos.col=4))
    group("difference")
    popViewport()
}

porterDuff()
blendModes()
library(grid)

## Tests for grobCoords()

check <- function(coords, model) {
    stopifnot(isTRUE(all.equal(as.numeric(coords$x), model$x)) &&
              isTRUE(all.equal(as.numeric(coords$y), model$y)))
}

## Simple primitive 
coords <- grobCoords(rectGrob(0, 0, 1, 1,
                              just=c("left", "bottom"),
                              default.units="in"),
                     closed=TRUE)
check(coords[[1]], list(x=c(0, 0, 1, 1), y=c(0, 1, 1, 0)))

## Primitives that generate more points than grob description
coords <- grobCoords(circleGrob(0, 0, r=unit(1, "in")), n=4,
                     closed=TRUE)
check(coords[[1]], list(x=c(1, 0, -1, 0), y=c(0, 1, 0, -1)))

coords <- grobCoords(xsplineGrob(c(0, 1, 2), c(0, 1, 0),
                                 default.units="in"),
                     closed=FALSE)
check(coords[[1]], list(x=c(0, 1, 2), y=c(0, 1, 0)))

## grob with 'id'
coords <- grobCoords(polylineGrob(1:4, 1:4,
                                  id=rep(1:2, each=2),
                                  default.units="in"),
                     closed=FALSE)
check(coords[[1]], list(x=1:2, y=1:2))
check(coords[[2]], list(x=3:4, y=3:4))

## grob with 'pathId'
coords <- grobCoords(pathGrob(c(0, 0, 3, 3, 1, 1, 2, 2, 4, 4, 7, 7, 5, 5, 6, 6),
                              c(0, 3, 3, 0, 1, 2, 2, 1, 4, 7, 7, 4, 5, 6, 6, 5),
                              id=rep(rep(1:2, each=4), 2),
                              pathId=rep(1:2, each=8),
                              default.units="in"),
                     closed=TRUE)
check(coords[[1]], list(x=c(0, 0, 3, 3), y=c(0, 3, 3, 0)))
check(coords[[2]], list(x=c(1, 1, 2, 2), y=c(1, 2, 2, 1)))
check(coords[[3]], list(x=c(4, 4, 7, 7), y=c(4, 7, 7, 4)))
check(coords[[4]], list(x=c(5, 5, 6, 6), y=c(5, 6, 6, 5)))

## Mostly testing makeContent()
coords <- grobCoords(bezierGrob(c(0, 1, 2, 3), c(0, 1, 2, 3),
                                default.units="in"),
                     closed=FALSE)
coords <- lapply(coords[[1]], function(x) { x[c(1, length(x))] })
check(coords, list(x=c(0, 3), y=c(0, 3)))

## Text returns a bounding box if closed is TRUE
coords <- grobCoords(textGrob("test", 0, 0, just=c("left", "bottom")),
                     closed=TRUE)
w <- convertWidth(stringWidth("test"), "in", valueOnly=TRUE)
h <- convertHeight(stringHeight("test"), "in", valueOnly=TRUE)
check(coords[[1]], list(x=c(0, 0, w, w), y=c(0, h, h, 0)))
      
coords <- grobCoords(textGrob("test"), closed=FALSE)
check(coords[[1]], emptyCoords)

## All emptyCoords
coords <- grobCoords(moveToGrob(), closed=FALSE)
check(coords[[1]], emptyCoords)

coords <- grobCoords(lineToGrob(), closed=FALSE)
check(coords[[1]], emptyCoords)

coords <- grobCoords(nullGrob(), closed=FALSE)
check(coords[[1]], emptyCoords)

coords <- grobCoords(clipGrob(), closed=FALSE)
check(coords[[1]], emptyCoords)

coords <- grobCoords(rasterGrob(matrix(1)), closed=FALSE)
check(coords[[1]], emptyCoords)

#################################
#################################
## Start a Cairo PNG device to get reliable results
png("temp.png", type="cairo")
#################################
#################################

#################################
## Names on coords
checkNames <- function(grob, seq, closed=TRUE) {
    pts <- grobCoords(grob, closed=closed)
    stopifnot(as.numeric(names(pts)) == seq)
}
## Circles
grob <- circleGrob(1:2/3)
checkNames(grob, 1:2)
## Lines
grob <- linesGrob(1:2, 1:2)
checkNames(grob, 1, FALSE)
## Polyline
grob <- polylineGrob(1:2, 1:2)
checkNames(grob, 1, FALSE)
grob <- polylineGrob(1:4, 1:4, id=rep(1:2, 2))
checkNames(grob, 1:2, FALSE)
## Polygon
grob <- polygonGrob(1:2, 1:2)
checkNames(grob, 1)
grob <- polygonGrob(1:4, 1:4, id=rep(1:2, 2))
checkNames(grob, 1:2)
## Path
grob <- pathGrob(1:2, 1:2)
checkNames(grob, 1)
grob <- pathGrob(1:4, 1:4, id=rep(1:2, 2))
checkNames(grob, c(1, 1))
grob <- pathGrob(1:4, 1:4, pathId=rep(1:2, 2))
checkNames(grob, 1:2)
grob <- pathGrob(1:8, 1:8, id=rep(1:2, 4), pathId=rep(1:2, each=4))
checkNames(grob, c(1, 1, 2, 2))
## Rects
grob <- rectGrob(unit(c(1, 3), "in"),
                 width=unit(1, "in"), height=unit(1, "in"))
checkNames(grob, 1:2)
## Segments
grob <- segmentsGrob(1:2)
checkNames(grob, 1:2, FALSE)
## Xsplines
grob <- xsplineGrob(1:2, 1:2)
checkNames(grob, 1, FALSE)
grob <- xsplineGrob(1:3, 1:3, open=FALSE)
checkNames(grob, 1)
grob <- xsplineGrob(1:4, 1:4, id=rep(1:2, 2))
checkNames(grob, 1:2, FALSE)
grob <- xsplineGrob(1:6, 1:6, id=rep(1:2, 3), open=FALSE)
checkNames(grob, 1:2)
## Text
grob <- textGrob(1:2)
checkNames(grob, 1)

#################################
## Points grobs

## Constants in grid.c
SMALL <- 0.25
RADIUS <- 0.375
SQRC <- 0.88622692545275801364
DMDC <- 1.25331413731550025119
TRC0 <- 1.55512030155621416073
TRC1 <- 1.34677368708859836060
TRC2 <- 0.77756015077810708036

## pch="."
grob <- pointsGrob(1:3, 1:3, default.units="in", pch=".")
coords <- grobCoords(grob, closed=TRUE)
x <- c(.995, .995, 1.005, 1.005)
y <- c(.995, 1.005, 1.005, .995)
mapply(check,
       coords,
       list("1"=list(x=x, y=y), "2"=list(x=x+1, y=y+1), "3"=list(x=x+2, y=y+2)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=0
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=0)
coords <- grobCoords(grob, closed=TRUE)
x <- c(1 - RADIUS, 1 - RADIUS, 1 + RADIUS, 1 + RADIUS)
y <- c(1 - RADIUS, 1 + RADIUS, 1 + RADIUS, 1 - RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x, y=y), "2"=list(x=x+1, y=y+1), "3"=list(x=x+2, y=y+2)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=1
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=1)
coords <- grobCoords(grob, closed=TRUE, n=4)
mapply(check,
       lapply(coords, function(c) list(x=c$x[1], y=c$y[1])),
       list("1"=list(x=1 + RADIUS, y=1),
            "2"=list(x=2 + RADIUS, y=2),
            "3"=list(x=3 + RADIUS, y=3)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=2
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=2)
coords <- grobCoords(grob, closed=TRUE)
x <- c(1, 1 + TRC1*RADIUS, 1 - TRC1*RADIUS)
y <- c(1 + TRC0*RADIUS, 1 - TRC2*RADIUS, 1 - TRC2*RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x, y=y), "2"=list(x=x+1, y=y+1), "3"=list(x=x+2, y=y+2)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=3
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=3)
coords <- grobCoords(grob, closed=TRUE)
stopifnot(isEmptyCoords(coords))
coords <- grobCoords(grob, closed=FALSE)
x1 <- c(1 - sqrt(2)*RADIUS, 1 + sqrt(2)*RADIUS)
y1 <- c(1, 1)
x2 <- c(1, 1)
y2 <- c(1 - sqrt(2)*RADIUS, 1 + sqrt(2)*RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x1, y=y1), "1"=list(x=x2, y=y2),
            "2"=list(x=x1+1, y=y1+1), "2"=list(x=x2+1, y=y2+1),
            "3"=list(x=x1+2, y=y1+2), "3"=list(x=x2+2, y=y2+2)))
## pch=4
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=4)
coords <- grobCoords(grob, closed=TRUE)
stopifnot(isEmptyCoords(coords))
coords <- grobCoords(grob, closed=FALSE)
x1 <- c(1 - RADIUS, 1 + RADIUS)
y1 <- c(1 - RADIUS, 1 + RADIUS)
x2 <- c(1 - RADIUS, 1 + RADIUS)
y2 <- c(1 + RADIUS, 1 - RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x1, y=y1), "1"=list(x=x2, y=y2),
            "2"=list(x=x1+1, y=y1+1), "2"=list(x=x2+1, y=y2+1),
            "3"=list(x=x1+2, y=y1+2), "3"=list(x=x2+2, y=y2+2)))
## pch=5
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=5)
coords <- grobCoords(grob, closed=TRUE)
x <- c(1 - sqrt(2)*RADIUS, 1, 1 + sqrt(2)*RADIUS, 1)
y <- c(1, 1 + sqrt(2)*RADIUS, 1, 1 - sqrt(2)*RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x, y=y), "2"=list(x=x+1, y=y+1), "3"=list(x=x+2, y=y+2)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=6
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=6)
coords <- grobCoords(grob, closed=TRUE)
x <- c(1, 1 + TRC1*RADIUS, 1 - TRC1*RADIUS)
y <- c(1 - TRC0*RADIUS, 1 + TRC2*RADIUS, 1 + TRC2*RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x, y=y), "2"=list(x=x+1, y=y+1), "3"=list(x=x+2, y=y+2)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=7
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=7)
coords <- grobCoords(grob, closed=TRUE)
x <- c(1 - RADIUS, 1 - RADIUS, 1 + RADIUS, 1 + RADIUS)
y <- c(1 - RADIUS, 1 + RADIUS, 1 + RADIUS, 1 - RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x, y=y), "2"=list(x=x+1, y=y+1), "3"=list(x=x+2, y=y+2)))
coords <- grobCoords(grob, closed=FALSE)
x1 <- c(1 - RADIUS, 1 + RADIUS)
y1 <- c(1 - RADIUS, 1 + RADIUS)
x2 <- c(1 - RADIUS, 1 + RADIUS)
y2 <- c(1 + RADIUS, 1 - RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x1, y=y1), "1"=list(x=x2, y=y2),
            "2"=list(x=x1+1, y=y1+1), "2"=list(x=x2+1, y=y2+1),
            "3"=list(x=x1+2, y=y1+2), "3"=list(x=x2+2, y=y2+2)))
## pch=8
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=8)
coords <- grobCoords(grob, closed=TRUE)
stopifnot(isEmptyCoords(coords))
coords <- grobCoords(grob, closed=FALSE)
x1 <- c(1 - RADIUS, 1 + RADIUS)
y1 <- c(1 - RADIUS, 1 + RADIUS)
x2 <- c(1 - RADIUS, 1 + RADIUS)
y2 <- c(1 + RADIUS, 1 - RADIUS)
x3 <- c(1 - sqrt(2)*RADIUS, 1 + sqrt(2)*RADIUS)
y3 <- c(1, 1)
x4 <- c(1, 1)
y4 <- c(1 - sqrt(2)*RADIUS, 1 + sqrt(2)*RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x1, y=y1), "1"=list(x=x2, y=y2),
            "1"=list(x=x3, y=y3), "1"=list(x=x4, y=y4),
            "2"=list(x=x1+1, y=y1+1), "2"=list(x=x2+1, y=y2+1),
            "2"=list(x=x3+1, y=y3+1), "2"=list(x=x4+1, y=y4+1),
            "3"=list(x=x1+2, y=y1+2), "3"=list(x=x2+2, y=y2+2),
            "3"=list(x=x3+2, y=y3+2), "3"=list(x=x4+2, y=y4+2)))
## pch=9
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=9)
coords <- grobCoords(grob, closed=TRUE)
x <- c(1 - sqrt(2)*RADIUS, 1, 1 + sqrt(2)*RADIUS, 1)
y <- c(1, 1 + sqrt(2)*RADIUS, 1, 1 - sqrt(2)*RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x, y=y), "2"=list(x=x+1, y=y+1), "3"=list(x=x+2, y=y+2)))
coords <- grobCoords(grob, closed=FALSE)
x1 <- c(1 - sqrt(2)*RADIUS, 1 + sqrt(2)*RADIUS)
y1 <- c(1, 1)
x2 <- c(1, 1)
y2 <- c(1 - sqrt(2)*RADIUS, 1 + sqrt(2)*RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x1, y=y1), "1"=list(x=x2, y=y2),
            "2"=list(x=x1+1, y=y1+1), "2"=list(x=x2+1, y=y2+1),
            "3"=list(x=x1+2, y=y1+2), "3"=list(x=x2+2, y=y2+2)))
## pch=10
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=10)
coords <- grobCoords(grob, closed=TRUE, n=4)
mapply(check,
       lapply(coords, function(c) list(x=c$x[1], y=c$y[1])),
       list("1"=list(x=1 + RADIUS, y=1),
            "2"=list(x=2 + RADIUS, y=2),
            "3"=list(x=3 + RADIUS, y=3)))
coords <- grobCoords(grob, closed=FALSE)
x1 <- c(1 - RADIUS, 1 + RADIUS)
y1 <- c(1, 1)
x2 <- c(1, 1)
y2 <- c(1 - RADIUS, 1 + RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x1, y=y1), "1"=list(x=x2, y=y2),
            "2"=list(x=x1+1, y=y1+1), "2"=list(x=x2+1, y=y2+1),
            "3"=list(x=x1+2, y=y1+2), "3"=list(x=x2+2, y=y2+2)))
## pch=11
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=11)
coords <- grobCoords(grob, closed=TRUE)
x1 <- c(1, 1 + TRC1*RADIUS, 1 - TRC1*RADIUS)
y1 <- c(1 - TRC0*RADIUS,
        1 + .5*(TRC2*RADIUS + TRC0*RADIUS),
        1 + .5*(TRC2*RADIUS + TRC0*RADIUS))
x2 <- c(1, 1 + TRC1*RADIUS, 1 - TRC1*RADIUS)
y2 <- c(1 + TRC0*RADIUS, 
        1 - .5*(TRC2*RADIUS + TRC0*RADIUS),
        1 - .5*(TRC2*RADIUS + TRC0*RADIUS))
mapply(check,
       coords,
       list("1"=list(x=x1, y=y1), "1"=list(x=x2, y=y2),
            "2"=list(x=x1+1, y=y1+1), "2"=list(x=x2+1, y=y2+1),
            "3"=list(x=x1+2, y=y1+2), "3"=list(x=x2+2, y=y2+2)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=12
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=12)
coords <- grobCoords(grob, closed=TRUE)
x <- c(1 - RADIUS, 1 - RADIUS, 1 + RADIUS, 1 + RADIUS)
y <- c(1 - RADIUS, 1 + RADIUS, 1 + RADIUS, 1 - RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x, y=y), "2"=list(x=x+1, y=y+1), "3"=list(x=x+2, y=y+2)))
coords <- grobCoords(grob, closed=FALSE)
x1 <- c(1 - RADIUS, 1 + RADIUS)
y1 <- c(1, 1)
x2 <- c(1, 1)
y2 <- c(1 - RADIUS, 1 + RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x1, y=y1), "1"=list(x=x2, y=y2),
            "2"=list(x=x1+1, y=y1+1), "2"=list(x=x2+1, y=y2+1),
            "3"=list(x=x1+2, y=y1+2), "3"=list(x=x2+2, y=y2+2)))
## pch=13
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=13)
coords <- grobCoords(grob, closed=TRUE, n=4)
mapply(check,
       lapply(coords, function(c) list(x=c$x[1], y=c$y[1])),
       list("1"=list(x=1 + RADIUS, y=1),
            "2"=list(x=2 + RADIUS, y=2),
            "3"=list(x=3 + RADIUS, y=3)))
coords <- grobCoords(grob, closed=FALSE)
x1 <- c(1 - RADIUS, 1 + RADIUS)
y1 <- c(1 - RADIUS, 1 + RADIUS)
x2 <- c(1 - RADIUS, 1 + RADIUS)
y2 <- c(1 + RADIUS, 1 - RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x1, y=y1), "1"=list(x=x2, y=y2),
            "2"=list(x=x1+1, y=y1+1), "2"=list(x=x2+1, y=y2+1),
            "3"=list(x=x1+2, y=y1+2), "3"=list(x=x2+2, y=y2+2)))
## pch=14
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=14)
coords <- grobCoords(grob, closed=TRUE)
x1 <- c(1 - RADIUS, 1 - RADIUS, 1 + RADIUS, 1 + RADIUS)
y1 <- c(1 - RADIUS, 1 + RADIUS, 1 + RADIUS, 1 - RADIUS)
x2 <- c(1, 1 + RADIUS, 1 - RADIUS)
y2 <- c(1 + RADIUS, 1 - RADIUS, 1 - RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x1, y=y1), "1"=list(x=x2, y=y2),
            "2"=list(x=x1+1, y=y1+1), "2"=list(x=x2+1, y=y2+1),
            "3"=list(x=x1+2, y=y1+2), "3"=list(x=x2+2, y=y2+2)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=15
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=15)
coords <- grobCoords(grob, closed=TRUE)
x <- c(1 - RADIUS, 1 + RADIUS, 1 + RADIUS, 1 - RADIUS)
y <- c(1 - RADIUS, 1 - RADIUS, 1 + RADIUS, 1 + RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x, y=y), "2"=list(x=x+1, y=y+1), "3"=list(x=x+2, y=y+2)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=16
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=16)
coords <- grobCoords(grob, closed=TRUE, n=4)
mapply(check,
       lapply(coords, function(c) list(x=c$x[1], y=c$y[1])),
       list("1"=list(x=1 + RADIUS, y=1),
            "2"=list(x=2 + RADIUS, y=2),
            "3"=list(x=3 + RADIUS, y=3)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=17
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=17)
coords <- grobCoords(grob, closed=TRUE)
x <- c(1, 1 + TRC1*RADIUS, 1 - TRC1*RADIUS)
y <- c(1 + TRC0*RADIUS, 1 - TRC2*RADIUS, 1 - TRC2*RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x, y=y), "2"=list(x=x+1, y=y+1), "3"=list(x=x+2, y=y+2)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=18
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=18)
coords <- grobCoords(grob, closed=TRUE)
x <- c(1 - RADIUS, 1, 1 + RADIUS, 1)
y <- c(1, 1 + RADIUS, 1, 1 - RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x, y=y), "2"=list(x=x+1, y=y+1), "3"=list(x=x+2, y=y+2)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=19
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=19)
coords <- grobCoords(grob, closed=TRUE, n=4)
mapply(check,
       lapply(coords, function(c) list(x=c$x[1], y=c$y[1])),
       list("1"=list(x=1 + RADIUS, y=1),
            "2"=list(x=2 + RADIUS, y=2),
            "3"=list(x=3 + RADIUS, y=3)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=20
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=20)
coords <- grobCoords(grob, closed=TRUE, n=4)
mapply(check,
       lapply(coords, function(c) list(x=c$x[1], y=c$y[1])),
       list("1"=list(x=1 + SMALL, y=1),
            "2"=list(x=2 + SMALL, y=2),
            "3"=list(x=3 + SMALL, y=3)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=21
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=21)
coords <- grobCoords(grob, closed=TRUE)
mapply(check,
       lapply(coords, function(c) list(x=c$x[1], y=c$y[1])),
       list(list(x=1 + RADIUS, y=1),
            list(x=2 + RADIUS, y=2),
            list(x=3 + RADIUS, y=3)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=22
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=22)
coords <- grobCoords(grob, closed=TRUE)
x <- c(1 - RADIUS*SQRC, 1 - RADIUS*SQRC, 1 + RADIUS*SQRC, 1 + RADIUS*SQRC)
y <- c(1 - RADIUS*SQRC, 1 + RADIUS*SQRC, 1 + RADIUS*SQRC, 1 - RADIUS*SQRC)
mapply(check,
       coords,
       list("1"=list(x=x, y=y), "2"=list(x=x+1, y=y+1), "3"=list(x=x+2, y=y+2)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=23
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=23)
coords <- grobCoords(grob, closed=TRUE)
x <- c(1, 1 + RADIUS*DMDC, 1, 1 - RADIUS*DMDC)
y <- c(1 - RADIUS*DMDC, 1, 1 + RADIUS*DMDC, 1)
mapply(check,
       coords,
       list("1"=list(x=x, y=y), "2"=list(x=x+1, y=y+1), "3"=list(x=x+2, y=y+2)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=24
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=24)
coords <- grobCoords(grob, closed=TRUE)
x <- c(1, 1 + TRC1*RADIUS, 1 - TRC1*RADIUS)
y <- c(1 + TRC0*RADIUS, 1 - TRC2*RADIUS, 1 - TRC2*RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x, y=y), "2"=list(x=x+1, y=y+1), "3"=list(x=x+2, y=y+2)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))
## pch=25
grob <- pointsGrob(1:3, 1:3, size=unit(1, "in"), default.units="in", pch=25)
coords <- grobCoords(grob, closed=TRUE)
x <- c(1, 1 + TRC1*RADIUS, 1 - TRC1*RADIUS)
y <- c(1 - TRC0*RADIUS, 1 + TRC2*RADIUS, 1 + TRC2*RADIUS)
mapply(check,
       coords,
       list("1"=list(x=x, y=y), "2"=list(x=x+1, y=y+1), "3"=list(x=x+2, y=y+2)))
coords <- grobCoords(grob, closed=FALSE)
stopifnot(isEmptyCoords(coords))

#################################
## coords from gTrees 
## gridCoords(c(.2, .2, .8, .8), c(.2, .8, .8, .2))
## gridPoints(list(gridCoords(c(.2, .2, .8, .8), c(.2, .8, .8, .2)),
##                 gridCoords(c(.4, .4, .6, .6), c(.4, .6, .6, .4))))
gtCheck <- function(x, y) {
    stopifnot(identical(x, y))
}
x <- c(.5, .5, 1.5, 1.5)
y <- c(.5, 1.5, 1.5, .5)
gtCheck(grobPoints(rectGrob(1, 1, 1, 1, default.units="in", name="r"),
                   closed=TRUE),
        gridGrobCoords(list("1"=gridCoords(x, y)), "r"))
gtCheck(grobPoints(rectGrob(1:2, 1, 1, 1,
                            default.units="in", name="r"),
                   closed=TRUE),
        gridGrobCoords(list("1"=gridCoords(x, y),
                            "2"=gridCoords(x + 1, y)),
                       "r"))
gtCheck(grobPoints(linesGrob(1:2, 1:2, default.units="in", name="l"),
                   closed=FALSE),
        gridGrobCoords(list("1"=gridCoords(1:2, 1:2)), "l"))
gtCheck(grobPoints(polylineGrob(1:2, 1:2, default.units="in", name="pl"),
                   closed=FALSE),
        gridGrobCoords(list("1"=gridCoords(1:2, 1:2)), "pl"))
gtCheck(grobPoints(polylineGrob(1:4, 1:4, id=rep(1:2, each=2),
                                default.units="in", name="pl"),
                   closed=FALSE),
        gridGrobCoords(list("1"=gridCoords(1:2, 1:2),
                            "2"=gridCoords(3:4, 3:4)), "pl"))
gtCheck(grobPoints(polygonGrob(1:2, 1:2, default.units="in", name="p"),
                   closed=TRUE),
        gridGrobCoords(list("1"=gridCoords(1:2, 1:2)), "p"))
gtCheck(grobPoints(polygonGrob(1:4, 1:4, id=rep(1:2, each=2),
                                default.units="in", name="p"),
                   closed=TRUE),
        gridGrobCoords(list("1"=gridCoords(1:2, 1:2),
                            "2"=gridCoords(3:4, 3:4)), "p"))
gtCheck(grobPoints(pathGrob(1:2, 1:2, default.units="in", name="p"),
                   closed=TRUE),
        gridGrobCoords(list("1"=gridCoords(1:2, 1:2)), "p", "winding"))
gtCheck(grobPoints(pathGrob(1:4, 1:4, id=rep(1:2, each=2),
                                default.units="in", name="p"),
                   closed=TRUE),
        gridGrobCoords(list("1"=gridCoords(1:2, 1:2),
                            "1"=gridCoords(3:4, 3:4)), "p", "winding"))
gtCheck(grobPoints(pathGrob(1:4, 1:4, pathId=rep(1:2, each=2),
                                default.units="in", name="p"),
                   closed=TRUE),
        gridGrobCoords(list("1"=gridCoords(1:2, 1:2),
                            "2"=gridCoords(3:4, 3:4)), "p", "winding"))
gtCheck(grobPoints(pathGrob(1:8, 1:8, id=rep(rep(1:2, each=2), 2),
                            pathId=rep(1:2, each=4),
                            default.units="in", name="p"),
                   closed=TRUE),
        gridGrobCoords(list("1"=gridCoords(1:2, 1:2),
                            "1"=gridCoords(3:4, 3:4),
                            "2"=gridCoords(5:6, 5:6),
                            "2"=gridCoords(7:8, 7:8)),
                       "p", "winding"))
gtCheck(grobPoints(segmentsGrob(1:2, 1, 3, 2, default.units="in", name="s"),
                   closed=FALSE),
        gridGrobCoords(list("1"=gridCoords(c(1, 3), 1:2),
                            "2"=gridCoords(c(2, 3), 1:2)), "s"))
x <- c(.5, .5, 1.5, 1.5)
y <- c(.5, 1.5, 1.5, .5)
r <- function(i) {
    rectGrob(1, 1, 1, 1, default.units="in", name=paste0("r", i))
}
r1 <- r(1)
r2 <- r(2)
r3 <- r(3)
gc <- function(i) {
    gridGrobCoords(list("1"=gridCoords(x, y)), paste0("r", i))
}
gc1 <- gc(1)
gc2 <- gc(2)
gc3 <- gc(3)
gtCheck(grobPoints(gTree(children=gList(r1), name="gt1"), closed=TRUE),
        gridGTreeCoords(list(gc1), "gt1"))
gtCheck(grobPoints(gTree(children=gList(r1, r2), name="gt1"), closed=TRUE),
        gridGTreeCoords(list(gc1, gc2),
                        "gt1"))
gtCheck(grobPoints(gTree(children=gList(r1,
                                        gTree(children=gList(r2), name="gt2"),
                                        r3),
                         name="gt1"), closed=TRUE),
        gridGTreeCoords(list(gc1,
                             gridGTreeCoords(list(gc2), "gt2"),
                             gc3),
                        "gt1"))
gtCheck(grobPoints(gTree(children=gList(gTree(children=gList(r1),
                                              name="gt2")),
                         name="gt1"),
                   closed=TRUE),
        gridGTreeCoords(list(gridGTreeCoords(list(gc1), "gt2")), "gt1"))
stopifnot(isEmptyCoords(grobPoints(gTree())))
stopifnot(isEmptyCoords(grobPoints(gTree(children=gList(segmentsGrob(0, 0:1,
                                                                     1, 1:0))),
                                   closed=TRUE)))

#################################
#################################
## Close PNG device
dev.off()
#################################
#################################

library(grDevices)
library(grid)

HersheyLabel <- function(x, y=unit(.5, "npc")) {
    lines <- strsplit(x, "\n")[[1]]
    if (!is.unit(y))
        y <- unit(y, "npc")
    n <- length(lines)
    if (n > 1) {
        y <- y + unit(rev(seq(n)) - mean(seq(n)), "lines")
    }
    grid.text(lines, y=y, gp=gpar(fontfamily="HersheySans"))
}

## NOTE that we make use of a font that has a free licence so
## that we can distribute the font along with 'grid' to standardize testing

## Values found from textshaping::shape_text(), but stored manually
## to avoid dependency on 'textshaping'
## 
## textshaping::shape_text("glyphs",
##                         path="Fonts/Montserrat/static/Montserrat-Medium.ttf")

## Do NOT use normalizePath() because it generates
## a path /home/staff/paul that ghostscript does NOT like

RobotoFont <- glyphFont(system.file("fonts", "Roboto", "Roboto-Medium.ttf",
                                    package="grDevices"),
                        0, "Roboto Medium", 400, "normal")
                        
RobotoInfo <- list(id = c(75, 80, 93, 84, 76, 87),
                   x = c(0, 6.796875, 9.859375, 15.703125,
                         22.453125, 29.109375),
                   y = rep(0, 6),
                   font = 1,
                   size = rep(12, 6),
                   fontList = glyphFontList(RobotoFont),
                   width = 35.29688,
                   height = 25.21875/2, ## divide by 2 cos of 'textshaping' bug 
                   hAnchor = glyphAnchor(0, "left"),
                   vAnchor = glyphAnchor(-(25.21875/2 - 11.14062), "bottom"))
Roboto <- do.call(glyphInfo, RobotoInfo)

MontserratFont <- glyphFont(system.file("fonts", "Montserrat", "static",
                                        "Montserrat-Medium.ttf",
                                        package="grDevices"),
                            0, "Montserrat Medium", 400, "normal")

MontserratInfo <- list(id = c(461, 499, 620, 556, 469, 567),
                       x = c(0.00000, 8.28125, 11.62500, 18.32812,
                             26.51562, 34.68750),
                       y = rep(0, 6),
                       font = 1,
                       size = rep(12, 6),
                       fontList = glyphFontList(MontserratFont),
                       width = glyphWidth(c(40.70312,
                                            40.70312 - 0.5 - 0.359375),
                                          label=c("width", "tight"),
                                          left=c("left", "leftBearing")),
                       height = glyphHeight(c(26.23438/2,
                                              26.23438/2 - 2.703125 - 0.609375),
                                            label=c("height", "tight"),
                                            bottom=c("bottom",
                                                     "bottomBearing")),
                       hAnchor = glyphAnchor(c(0, 0.5),
                                             label=c("left", "leftBearing")),
                       vAnchor = glyphAnchor(c(0,
                                               -(26.23438/2 - 11.60938),
                                               -(26.23438/2 - 11.60938 -
                                                 0.609375)),
                                             label=c("baseline", "bottom",
                                                     "bottomBearing")))
Montserrat <- do.call(glyphInfo, MontserratInfo)

## Set up "global" 'testGlyphInfo' so that pdfEmbeddedRecording() device
## can use it in call to embedGlyphs()
testGlyphInfo <- list()
testGlyph <- function(info, ...) {
    testGlyphInfo[[length(testGlyphInfo) + 1]] <<- info
    grid.glyph(testGlyphInfo[[length(testGlyphInfo)]], ...)
}
testGlyphGrob <- function(info, ...) {
    testGlyphInfo[[length(testGlyphInfo) + 1]] <<- info
    glyphGrob(testGlyphInfo[[length(testGlyphInfo)]], ...)
}

## glyphs
grid.newpage()
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
testGlyph(Montserrat)
HersheyLabel("Montserrat glyphs", y=.2)

grid.newpage()
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
testGlyph(Roboto)
HersheyLabel("Roboto glyphs", y=.2)

## glyphs with NA/non-finite values
missingIDinfo <- MontserratInfo
missingIDinfo$id[1] <- NA
missingID <- do.call(glyphInfo, missingIDinfo)
grid.newpage()
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
testGlyph(missingID)
HersheyLabel("Missing glyph id ('g' missing)", y=.2)

missingXinfo <- MontserratInfo
missingXinfo$x[2] <- NA
missingX <- do.call(glyphInfo, missingXinfo)
grid.newpage()
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
testGlyph(missingX)
HersheyLabel("Missing glyph x ('l' missing)", y=.2)

missingYinfo <- MontserratInfo
missingYinfo$y[3] <- NA
missingY <- do.call(glyphInfo, missingYinfo)
grid.newpage()
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
testGlyph(missingY)
HersheyLabel("Missing glyph y ('y' missing)", y=.2)

## glyphs with font file non-existent (should produce warning)
## (output is unpredictable, but likely to be weird because the glyph ids
##  are unlikely to match the glyph ids in the substituted font)
nofile <- Roboto
nofile$fonts[[1]]$file <- "road/to/nowhere"
grid.newpage()
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
testGlyph(nofile)
HersheyLabel("Font file not found - output will be weird", y=.2)

## Manual hack of "RGlyphInfo" object
missingfile <- Roboto
missingfile$fonts[[1]]$file <- as.character(NA)
grid.newpage()
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
testGlyph(missingfile)
HersheyLabel("Font file not found - output will be weird", y=.2)

## glyphs with colour
colourInfo <- MontserratInfo
colourInfo$col <- rep("red", 6)
colour <- do.call(glyphInfo, colourInfo)
grid.newpage()
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
testGlyph(colour)
HersheyLabel("glyphs with colour (red)", y=.2)
    
## Missing colour is OK
missingColourInfo <- colourInfo
missingColourInfo$col[4] <- NA
missingColour <- do.call(glyphInfo, missingColourInfo)
grid.newpage()
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
testGlyph(missingColour)
HersheyLabel("glyphs with one colour missing (red -> black)", y=.2)

## glyphs with alignment
grid.newpage()
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
grid.segments(.5,0, .5,1, gp=gpar(col="grey"))
testGlyph(Montserrat, hjust="left", vjust="bottom")
HersheyLabel("left bottom justification", y=.2)

grid.newpage()
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
grid.segments(.5,0, .5,1, gp=gpar(col="grey"))
testGlyph(Montserrat, hjust="left", vjust="baseline")
HersheyLabel("(left) baseline justification", y=.2)

grid.newpage()
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
grid.segments(.5,0, .5,1, gp=gpar(col="grey"))
testGlyph(Montserrat, hjust=glyphJust(0, "tight"), vjust="baseline")
HersheyLabel("tight left (baseline) justification\n(tiny bit further left)",
             y=.2)

## rotated glyphs
grid.newpage()
pushViewport(viewport(angle=30))
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
grid.segments(.5,0, .5,1, gp=gpar(col="grey"))
testGlyph(Montserrat)
popViewport()
HersheyLabel("rotated glyphs", y=.2)

grid.newpage()
pushViewport(viewport(angle=30))
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
grid.segments(.5,0, .5,1, gp=gpar(col="grey"))
testGlyph(Montserrat, hjust="left", vjust="baseline")
popViewport()
HersheyLabel("rotated (left baseline justified) glyphs", y=.2)

## glyph x/y/width/height
grid.newpage()
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
grid.segments(.5,0, .5,1, gp=gpar(col="grey"))
testGlyph(Montserrat, name="glyph")
grid.segments(0, .5, grobX("glyph", 180), .5, gp=gpar(col="red"))
grid.segments(1, 1, grobX("glyph", 45), grobY("glyph", 45), gp=gpar(col="red"))
grid.rect(width=grobWidth("glyph"), height=grobHeight("glyph"),
          gp=gpar(fill=NA))
HersheyLabel("glyph x/y/width/height", y=.2)

grid.newpage()
pushViewport(viewport(angle=30))
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
grid.segments(.5,0, .5,1, gp=gpar(col="grey"))
testGlyph(Montserrat, hjust="left", vjust="baseline", name="glyph")
grid.segments(0, .5, grobX("glyph", 180), .5, gp=gpar(col="red"))
grid.segments(1, 1, grobX("glyph", 45), grobY("glyph", 45), gp=gpar(col="red"))
popViewport()
HersheyLabel("(rotated left baseline justified) glyph x/y/width/height", y=.2)

## glyphs in tiling pattern
grid.newpage()
pat <- pattern(gTree(children=gList(rectGrob(width=unit(2, "cm"),
                                             height=unit(1, "cm"),
                                             gp=gpar(fill="grey")),
                                    testGlyphGrob(Montserrat))),
               width=unit(2, "cm"), height=unit(1, "cm"),
               extend="repeat")
grid.circle(r=.3, gp=gpar(fill=pat))
HersheyLabel("glyphs as tiling pattern", y=.1)

## glyphs as clipping path
grid.newpage()
pushViewport(viewport(clip=testGlyphGrob(Montserrat)))
grid.segments(0, unit(.5, "npc") + unit(seq(-5, 5), "mm"),
              1, unit(.5, "npc") + unit(seq(-5, 5), "mm"),
              gp=gpar(col=c("red", "blue"), lwd=2))
popViewport()
HersheyLabel("glyphs as clipping path", y=.2)

## glyphs as mask
grid.newpage()
grid.segments(gp=gpar(col="red", lwd=20))
pushViewport(viewport(mask=testGlyphGrob(Montserrat,
                                         gp=gpar(col=rgb(0,0,0,.5)))))
grid.rect(gp=gpar(fill="black"))
popViewport()
HersheyLabel("glyphs as mask", y=.2)
                      
## glyphs in group
grid.newpage()
grid.group(testGlyphGrob(Montserrat), "xor", segmentsGrob(gp=gpar(lwd=20)))
HersheyLabel("glyphs in group (xor line)", y=.2)

## glyphs in (transformed) group 
grid.newpage()
grid.define(testGlyphGrob(Montserrat), name="glyphs")
pushViewport(viewport(width=2, height=4))
grid.use("glyphs")
popViewport()
HersheyLabel("glyphs in transformed group", y=.2)

## glyphs as path
grid.newpage()
grid.stroke(testGlyphGrob(Montserrat), gp=gpar(lwd=.5))
HersheyLabel("glyphs as (stroked) path", y=.2)

## multiple fonts
## printVals <- function(x) {
##     cat(paste0("c(", paste(temp$shape[[x]], collapse=", "), ")\n"))
## }
## 
## library(textshaping)
## temp <-
##     shape_text(c("hello ", "world!"),
##                id=1,
##                bold=c(FALSE, TRUE),
##                italic=c(FALSE, TRUE),
##                path=c("Fonts/Montserrat/static/Montserrat-Medium.ttf",
##                       "Fonts/Montserrat/static/Montserrat-BoldItalic.ttf"))
## printVals("index")
Montserrat2 <-
    glyphFontList(glyphFont(system.file("fonts", "Montserrat", "static",
                                        "Montserrat-Medium.ttf",
                                        package="grDevices"),
                            0, "Montserrat-Medium", 400, "normal"),
                  glyphFont(system.file("fonts", "Montserrat", "static",
                                        "Montserrat-BoldItalic.ttf",
                                        package="grDevices"),
                            0, "Montserrat-BoldItalic", 700, "italic"))
MontserratInfo2 <-
    list(id = c(469, 434, 499, 499, 521, 1642, 614, 521, 559, 499, 427, 1606),
         x = c(0, 8.171875, 15.515625, 18.859375, 22.203125, 29.828125,
               33.0625, 44.171875, 52.015625, 57.125, 60.734375, 69.03125),
         y = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0),
         font = rep(1:2, each=6),
         fontList = Montserrat2,
         size = rep(12, 12),
         width = glyphWidth(c(72.5,
                              72.5 - 1.09375 - -0.421875),
                            label=c("width", "tight"),
                            left=c("left", "leftBearing")),
         height = glyphHeight(c(26.23438/2,
                                26.23438/2 - 2.703125 - 2.921875),
                              label=c("height", "tight"),
                              bottom=c("bottom",
                                       "bottomBearing")),
         hAnchor = glyphAnchor(c(0, 1.09375),
                               label=c("left", "leftBearing")),
         vAnchor = glyphAnchor(c(0,
                                 -(26.23438/2 - 11.60938),
                                 -(26.23438/2 - 11.60938 -
                                   2.921875)),
                               label=c("baseline", "bottom",
                                       "bottomBearing")))
Montserrat2 <- do.call(glyphInfo, MontserratInfo2)

grid.newpage()
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
testGlyph(Montserrat2)
HersheyLabel("Montserrat glyphs (mixed style)", y=.2)

## Normal text plus glyphs 
grid.newpage()
grid.segments(0,.5,1,.5, gp=gpar(col="grey"))
grid.text("test", y=3/4)
testGlyph(Montserrat)
HersheyLabel("Montserrat glyphs plus normal text", y=.2)
library(grid)

## Set up
grid.newpage()
pushViewport(viewport(name="a.vp"))
grid.rect(name="a.grob")

## Default finds only grobs (no vpPath)
result <- grid.grep("a", grep=TRUE, global=TRUE)
result
attr(result[[1]], "vpPath")

## 'viewports = TRUE' (and 'vpPath = TRUE')
## finds grobs and viewports (AND vpPath on grobs)
result <- grid.grep("a", grep=TRUE, global=TRUE, viewports=TRUE)
result
attr(result[[2]], "vpPath")

## 'viewports = FALSE' and 'vpPath = TRUE'
## finds only grobs AND vpPath on grobs
result <- grid.grep("a", grep=TRUE, global=TRUE, vpPath=TRUE)
result
attr(result[[1]], "vpPath")

## 'viewports = TRUE' and 'vpPath = FALSE'
## finds viewports and grobs (no vpPath)
result <- grid.grep("a", grep=TRUE, global=TRUE, viewports=TRUE, vpPath=FALSE)
result
attr(result[[2]], "vpPath")

###########################
## global=FALSE versions

## grob (no vpPath)
result <- grid.grep("a", grep=TRUE)
result
attr(result, "vpPath")
## viewport (NULL vpPath)
result <- grid.grep("a", grep=TRUE, viewports=TRUE)
result
attr(result, "vpPath")
## grob with vpPath
result <- grid.grep("a", grep=TRUE, vpPath=TRUE)
result
attr(result, "vpPath")
## viewport (NULL vpPath)
result <- grid.grep("a", grep=TRUE, viewports=TRUE, vpPath=FALSE)
result
attr(result, "vpPath")

R Under development (unstable) (2022-03-19 r81942) -- "Unsuffered Consequences"
Copyright (C) 2022 The R Foundation for Statistical Computing
Platform: x86_64-pc-linux-gnu (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> library(grid)
> 
> ## Set up
> grid.newpage()
> pushViewport(viewport(name="a.vp"))
> grid.rect(name="a.grob")
> 
> ## Default finds only grobs (no vpPath)
> result <- grid.grep("a", grep=TRUE, global=TRUE)
> result
[[1]]
a.grob 

> attr(result[[1]], "vpPath")
[1] ""
> 
> ## 'viewports = TRUE' (and 'vpPath = TRUE')
> ## finds grobs and viewports (AND vpPath on grobs)
> result <- grid.grep("a", grep=TRUE, global=TRUE, viewports=TRUE)
> result
[[1]]
a.vp 

[[2]]
a.grob 

> attr(result[[2]], "vpPath")
[1] "a.vp"
> 
> ## 'viewports = FALSE' and 'vpPath = TRUE'
> ## finds only grobs AND vpPath on grobs
> result <- grid.grep("a", grep=TRUE, global=TRUE, vpPath=TRUE)
> result
[[1]]
a.grob 

> attr(result[[1]], "vpPath")
[1] "a.vp"
> 
> ## 'viewports = TRUE' and 'vpPath = FALSE'
> ## finds viewports and grobs (no vpPath)
> result <- grid.grep("a", grep=TRUE, global=TRUE, viewports=TRUE, vpPath=FALSE)
> result
[[1]]
a.vp 

[[2]]
a.grob 

> attr(result[[2]], "vpPath")
[1] ""
> 
> ###########################
> ## global=FALSE versions
> 
> ## grob (no vpPath)
> result <- grid.grep("a", grep=TRUE)
> result
a.grob 
> attr(result, "vpPath")
[1] ""
> ## viewport (NULL vpPath)
> result <- grid.grep("a", grep=TRUE, viewports=TRUE)
> result
a.vp 
> attr(result, "vpPath")
NULL
> ## grob with vpPath
> result <- grid.grep("a", grep=TRUE, vpPath=TRUE)
> result
a.grob 
> attr(result, "vpPath")
[1] "a.vp"
> ## viewport (NULL vpPath)
> result <- grid.grep("a", grep=TRUE, viewports=TRUE, vpPath=FALSE)
> result
a.vp 
> attr(result, "vpPath")
NULL
> 
> proc.time()
   user  system elapsed 
  0.270   0.046   0.300 

library(grid)

HersheyLabel <- function(x, y=unit(.5, "npc")) {
    lines <- strsplit(x, "\n")[[1]]
    if (!is.unit(y))
        y <- unit(y, "npc")
    n <- length(lines)
    if (n > 1) {
        y <- y + unit(rev(seq(n)) - mean(seq(n)), "lines")
    }
    grid.text(lines, y=y, gp=gpar(fontfamily="HersheySans"))
}

devMask <- function(aMask, lMask) {
    support <- dev.capabilities()$masks
    if (is.character(support)) {
        if ("alpha" %in% support) {
            aMask
        } else {
            if ("luminance" %in% support) {
                as.mask(lMask, type="luminance")
            } else {
                FALSE
            }
        }
    } else {
        FALSE
    }
}

################################################################################
## Basic sanity checks

## Simple group grob (same as a normal grob)
grid.newpage()
grid.group(rectGrob(width=.5, height=.5, gp=gpar(fill="grey")))
HersheyLabel("Group = single rect
half-width, half-height, grey fill
same as normal rect")


################################################################################
## Compositing operators

source("compositing.R")


################################################################################
## Isolated groups

## Apply mask to isolated group
grid.newpage()
pushViewport(viewport(layout=grid.layout(2, 2)))
pushViewport(viewport(layout.pos.row=1, layout.pos.col=1))
grid.rect(height=.5, gp=gpar(fill="red"))
grid.rect(width=.5, gp=gpar(fill="blue"))
HersheyLabel("no mask
each shape composite over")
popViewport()
pushViewport(viewport(layout.pos.row=1, layout.pos.col=2),
             viewport(mask=devMask(circleGrob(gp=gpar(col=NA,
                                                      fill=rgb(0,0,0,.5))),
                                   circleGrob(gp=gpar(col=NA,
                                                      fill=grey(.5))))))
grid.rect(height=.5, gp=gpar(fill="red"))
grid.rect(width=.5, gp=gpar(fill="blue"))
popViewport()
HersheyLabel("mask
each shape masked then composite over")
popViewport()
pushViewport(viewport(layout.pos.row=2, layout.pos.col=1),
             viewport(mask=devMask(circleGrob(gp=gpar(col=NA,
                                                      fill=rgb(0,0,0,.5))),
                                   circleGrob(gp=gpar(col=NA,
                                                      fill=grey(.5))))))
grid.group(rectGrob(width=.5, gp=gpar(fill="blue")),
               "over",
               rectGrob(height=.5, gp=gpar(fill="red")))
popViewport()
HersheyLabel("mask and group
each shape composite over in group
group masked")
popViewport()


## Grobs that draw more than one shape
## Circle of small circles, draw over and then compose with alpha mask
grid.newpage()
t <- seq(30, 360, 30)
x <- .5 + .3*cos(pi*t/180)
y <- .5 + .3*sin(pi*t/180)
circles <- circleGrob(x, y, r=.1, gp=gpar(fill="black"))
pushViewport(viewport(layout=grid.layout(2, 2)))
pushViewport(viewport(layout.pos.row=1, layout.pos.col=1))
grid.draw(circles)
HersheyLabel("circle grob")
popViewport()
pushViewport(viewport(layout.pos.row=1, layout.pos.col=2,
                      mask=devMask(rectGrob(gp=gpar(col=NA,
                                                    fill=rgb(0,0,0,.5))),
                                   rectGrob(gp=gpar(col=NA,
                                                    fill=grey(.5))))))
grid.draw(circles)
HersheyLabel("masked
circle grob")
popViewport()
pushViewport(viewport(layout.pos.row=2, layout.pos.col=1))
grid.group(circles)
HersheyLabel("group
circle grob")
popViewport()
pushViewport(viewport(layout.pos.row=2, layout.pos.col=2,
                      mask=devMask(rectGrob(gp=gpar(col=NA,
                                                    fill=rgb(0,0,0,.5))),
                                   rectGrob(gp=gpar(col=NA,
                                                    fill=grey(.5))))))
grid.group(circles)
HersheyLabel("masked
group
circle grob")
popViewport()


################################################################################
## Inheritance of graphics settings

## Compositing groups inherit graphics settings from "parent"
grid.newpage()
pushViewport(viewport(gp=gpar(fill="pink")))
grid.rect(x=1/4, width=1/2)
grid.group(rectGrob(x=3/4, width=1/2))
HersheyLabel("group inherits current gpar
(right rect pink)")
popViewport()

## Watch out for alpha level accumulating
grid.newpage()
pushViewport(viewport(gp=gpar(fill=rgb(1,0,0,.5))))
grid.rect(x=1/4, width=1/2)
grid.group(rectGrob(x=3/4, width=1/2))
HersheyLabel("group inherits current gpar
(right rect trans red)
test with alpha")
popViewport()


################################################################################
## gTrees

## The trick here is that the rectangle is drawn within a viewport,
## which means that there is an upViewport() within the drawing
## of the group, which means 'grid' has to have guards against that
## upViewport() resetting any mask that is in effect outside the group.
##
## This is a proxy for drawing complex things like 'ggplot2' plot gTrees
## within a group (which also works, I just cannot make it a test within
## the 'grid' package).
grid.newpage()
gt <- gTree(children=gList(rectGrob(vp=viewport()),
                           circleGrob(1:2/3, r=.3, gp=gpar(fill="black"))))
pushViewport(viewport(mask=devMask(rectGrob(gp=gpar(col=NA,
                                                    fill=rgb(0,0,0,.5))),
                                   rectGrob(gp=gpar(col=NA,
                                                    fill=grey(.5))))))
grid.group(gt)
HersheyLabel("group is gTree with child with vp
group drawn with mask", y=.9)
HersheyLabel("mask NOT reset within group definition
(circles NOT masked within group)", y=.1)
popViewport()


################################################################################
## Reuse

## Use group in smaller viewport (translate and scale)
grid.newpage()
grid.group(rectGrob(width=unit(1, "in"), height=unit(1, "in"),
                     gp=gpar(fill="grey")),
            name="rectGroup")
HersheyLabel("draw named group", y=.75)
pushViewport(viewport(x=.75, y=.25, width=.5, height=.5))
grid.rect(gp=gpar(fill=NA, lty="dashed"))
grid.use("rectGroup")
HersheyLabel("reuse group
(in smaller viewport)
shrunk AND thinner border", y=.25)
popViewport()

## Just translate
grid.newpage()
grid.define(rectGrob(width=unit(1, "in"), height=unit(1, "in"),
                     gp=gpar(fill="grey")),
            name="rectGroup")
grid.use("rectGroup")
HersheyLabel("draw named group", y=.75)
pushViewport(viewport(x=.75, y=.25, width=.5, height=.5))
grid.rect(gp=gpar(fill=NA, lty="dashed"))
grid.use("rectGroup", viewportTranslate)
HersheyLabel("reuse group
just with translate transform
(in smaller viewport)
just shifted", y=.25)
popViewport()

## Just scale
grid.newpage()
grid.define(rectGrob(width=unit(1, "in"), height=unit(1, "in"),
                     gp=gpar(fill="grey")),
            name="rectGroup")
grid.use("rectGroup")
HersheyLabel("draw named group", y=.75)
pushViewport(viewport(x=.75, y=.25, width=.5, height=.5))
grid.rect(gp=gpar(fill=NA, lty="dashed"))
grid.use("rectGroup", viewportScale)
HersheyLabel("reuse group
just with scale transform
(in smaller viewport)
just scaled", y=.25)
popViewport()

## Just translate BUT viewport x/y is NOT "centre"
grid.newpage()
grid.define(rectGrob(width=unit(1, "in"), height=unit(1, "in"),
                     gp=gpar(fill="grey")),
            name="rectGroup")
grid.use("rectGroup")
HersheyLabel("draw named group", y=.75)
pushViewport(viewport(x=1, y=0, width=.5, height=.5, just=c("right", "bottom")))
grid.rect(gp=gpar(fill=NA, lty="dashed"))
grid.use("rectGroup", viewportTranslate)
HersheyLabel("reuse group
just with translate transform
with vp x/y at bottom-right
(in smaller viewport)
shifted to new vp x/y", y=.25)
popViewport()

## Just scale (which ignores the fact that x/y is NOT "centre")
grid.newpage()
grid.define(rectGrob(width=unit(1, "in"), height=unit(1, "in"),
                     gp=gpar(fill="grey")),
            name="rectGroup")
grid.use("rectGroup")
HersheyLabel("draw named group", y=.75)
pushViewport(viewport(x=1, y=0, width=.5, height=.5, just=c("right", "bottom")))
grid.rect(gp=gpar(fill=NA, lty="dashed"))
grid.use("rectGroup", viewportScale)
HersheyLabel("reuse group
just with scale transform
with vp x/y at bottom-right
(in smaller viewport)
just scaled
(new vp x/y ignored)", y=.25)
popViewport()

## Rotation
grid.newpage()
grid.define(rectGrob(width=unit(1, "in"), height=unit(1, "in"),
                     gp=gpar(fill="grey")),
            name="rectGroup")
grid.use("rectGroup")
pushViewport(viewport(angle=15))
grid.rect(gp=gpar(lty="dashed", fill=NA))
grid.use("rectGroup")
popViewport()
HersheyLabel("reuse group
rotated viewport
rotated group", y=.25)

## Shear 
grid.newpage()
grid.define(rectGrob(width=unit(1, "in"), height=unit(1, "in"),
                     gp=gpar(fill="grey")),
            name="rectGroup")
grid.use("rectGroup")
trans <- function(group, ...) {
    viewportTransform(group, shear=groupShear(.5, 0))
}
grid.use("rectGroup", transform=trans)
HersheyLabel("reuse group
shear (skewX) transform
sheared group", y=.25)

grid.newpage()
grid.define(rectGrob(width=unit(1, "in"), height=unit(1, "in"),
                     gp=gpar(fill="grey")),
            name="rectGroup")
grid.use("rectGroup")
trans <- function(group, ...) {
    viewportTransform(group, shear=groupShear(0, .5))
}
grid.use("rectGroup", transform=trans)
HersheyLabel("reuse group
shear (skewY) transform
sheared group", y=.25)

grid.newpage()
pushViewport(viewport(gp=gpar(col=2)))
grid.define(circleGrob(r=.1), name="c", gp=gpar(lwd=5))
grid.use("c")
pushViewport(viewport(x=.25, gp=gpar(col="green")))
grid.use("c")
popViewport()
pushViewport(viewport(x=.75, gp=gpar(col="blue")))
grid.use("c")
popViewport()
popViewport()
HersheyLabel("define circle (no colour)
(red from viewport)
left viewport sets green
(circle stays red)
right viewport sets blue
(cirlce stays red)", y=.25)

grid.newpage()
grid.define(rectGrob(gp=gpar(col=NA, fill=radialGradient())),
            name="gradient")
grid.use("gradient")
pushViewport(viewport(y=.1, height=.2))
grid.rect(gp=gpar(lty="dashed", fill=NA))
grid.use("gradient")
popViewport()
HersheyLabel("group with gradient fill
reused in viewport with different scale
distorted gradient", y=.9)

################################################################################
## Combinations (masks in groups, groups in groups, ...)

## Text in group
grid.newpage()
group <- gTree(children=gList(rectGrob(width=.8, height=.5),
                              textGrob("testing", gp=gpar(cex=3))))
grid.group(group)
HersheyLabel("group with text", y=.8)
    
## Pattern in group
grid.newpage()
grid.group(rectGrob(width=.8, height=.5, gp=gpar(fill=linearGradient())))
HersheyLabel("group with gradient fill", y=.8)

## Clipping path in group
grid.newpage()
vp <- viewport(clip=circleGrob())
grid.group(rectGrob(gp=gpar(fill="grey")), vp=vp)
HersheyLabel("group with vp
vp is viewport with clipping path
result is grey circle")

grid.newpage()
vp <- viewport(clip=circleGrob())
grid.group(rectGrob(gp=gpar(fill="grey"), vp=vp))
HersheyLabel("group with grob with vp
vp is viewport with clipping path
result is grey circle")
           
## Mask in group
grid.newpage()
vp <- viewport(mask=devMask(circleGrob(gp=gpar(fill="black")),
                            circleGrob(gp=gpar(col="white", fill="white"))))
grid.group(rectGrob(gp=gpar(fill="grey")), vp=vp)
HersheyLabel("group with vp
vp is viewport with mask
result is grey circle")

grid.newpage()
vp <- viewport(mask=devMask(circleGrob(gp=gpar(fill="black")),
                            circleGrob(gp=gpar(col="white", fill="white"))))
grid.group(rectGrob(gp=gpar(fill="grey"), vp=vp))
HersheyLabel("group with grob with vp
vp is viewport with mask
result is grey circle")
    
## Path in group
grid.newpage()
grid.group(fillGrob(circleGrob(1:2/3, r=.3), gp=gpar(fill="grey")))
HersheyLabel("group with (filled) path")
    
## Group in group
grid.newpage()
gt <- gTree(children=gList(rectGrob(width=.5, gp=gpar(fill=rgb(1,0,0,.5))),
                           groupGrob(rectGrob(height=.5,
                                              gp=gpar(fill=rgb(0,0,1,.5))))))
grid.group(gt)
HersheyLabel("group containing group
both groups semitransparent
see overlap between groups")

grid.newpage()
rects <- gTree(children=gList(rectGrob(width=unit(5, "mm"),
                                       height=unit(5, "mm"),
                                       just=c("left", "bottom"),
                                       gp=gpar(fill="black")),
                              rectGrob(width=unit(5, "mm"),
                                       height=unit(5, "mm"),
                                       just=c("right", "top"),
                                       gp=gpar(fill="black"))))
pat <- pattern(rects,
               width=unit(1, "cm"), height=unit(1, "cm"),
               extend="repeat")
grid.rect(gp=gpar(fill=pat))
gt1 <- gTree(children=gList(rectGrob(width=.5, gp=gpar(fill=2)),
                            rectGrob(height=.5, gp=gpar(fill=4))))
vp <- viewport(mask=devMask(rectGrob(gp=gpar(col=NA, fill=rgb(0,0,0,.7))),
                            rectGrob(gp=gpar(col=NA, fill=grey(.7)))))
g1 <- groupGrob(gt1, vp=vp)
gt2 <- gTree(children=gList(g1, segmentsGrob(gp=gpar(lwd=100))))
g2 <- groupGrob(gt2, vp=vp)
grid.draw(g2)
grid.rect(width=.8, height=.4, gp=gpar(col=NA, fill=rgb(1,1,1,.7)))
HersheyLabel("group containing group
inner group overlapping rects
inner group drawn with semitransparent mask
(see through blue rect - no overlap visible)
outer group thick black line
outer group drawn with semitransparent mask
(see through black line - no overlap visible)
[white rect just background for this label]")

## Group used with transform in group used with transform
grid.newpage()
vp1 <- viewport(x=.3, y=.2, width=.3, height=.3)
vp2 <- viewport(x=.5, y=.6, width=.1, height=.3)
vp3 <- viewport(x=.7, y=.2, width=.3, height=.3)
pushViewport(vp1)
grid.rect(gp=gpar(col="grey"))
grid.define(polygonGrob(c(.2, .5, .8), c(.2, .8, .2),
                        gp=gpar(lwd=10, col=2, fill=3)),
            name="p")
grid.use("p")
popViewport()
pushViewport(vp2)
grid.rect(gp=gpar(col="grey"))
grid.use("p")
grid.define(useGrob("p"), name="g")
popViewport()
pushViewport(vp3)
grid.rect(gp=gpar(col="grey"))
grid.use("g")
popViewport()
HersheyLabel("bottom left is group-1 definition
top is reuse of group-1 with horiz squash
top is also group-2 definition
bottom right is reuse of group-2 with horiz stretch", y=.9)

grid.newpage()
vp1 <- viewport(x=.2, y=.2, width=.3, height=.3)
vp2 <- viewport(x=.3, y=.5, width=.1, height=.2, angle=-30)
vp3 <- viewport(x=.7, y=.7, width=.5, height=.5)
pushViewport(vp1)
grid.rect(gp=gpar(col="grey"))
grid.define(polygonGrob(c(.2, .5, .8), c(.2, .8, .2),
                        gp=gpar(lwd=10, col=2, fill=3)),
            name="r")
grid.use("r")
popViewport()
pushViewport(vp2)
grid.rect(gp=gpar(lty="dotted"))
popViewport()
g <- useGrob("r", vp=vp2)
grid.draw(g)
pushViewport(vp3)
grid.rect()
pushViewport(vp1)
grid.rect(gp=gpar(col="grey"))
popViewport()
pushViewport(vp2)
grid.rect(gp=gpar(lty="dotted"))
popViewport()
grid.define(g, name="g")
grid.use("g")
popViewport()
pushViewport(viewport(.7, .2, width=.5, height=.3))
grid.rect()
grid.use("g")
popViewport()
HersheyLabel("bottom-left is group-1 definition
group-1 reused with horiz. stretch and rotation
top-right is group-2 definition (based on group-1)
bottom-right is group-2 reused with vert. squash", y=.85)

## Raster in group
grid.newpage()
group <- gTree(children=gList(rectGrob(width=.8, height=.5),
                              rasterGrob(matrix(c(0:1, 1:0), nrow=2),
                                         width=.2, height=.2,
                                         interpolate=FALSE)))
grid.group(group)
HersheyLabel("group with raster", y=.8)
    
## Group with rect with gradient fill
grid.newpage()
grid.group(rectGrob(width=.5, height=.5,
                    gp=gpar(fill=linearGradient())))
HersheyLabel("group based on rect
rect has linear gradient", y=.1)

## Group with gradient fill
grid.newpage()
grid.group(rectGrob(width=.5, height=.5),
           gp=gpar(fill=linearGradient()))
HersheyLabel("group based on rect
GROUP has linear gradient", y=.1)

## Group with multiple shapes with gradient fill
grid.newpage()
grid.group(gTree(children=gList(rectGrob(.25, .25, .5, .5),
                                rectGrob(.75, .75, .5, .5))),
           gp=gpar(fill=linearGradient()))
HersheyLabel("group based on two rects
GROUP has linear gradient", y=.1)

## Subtler problem (need fill captured on definition)
grid.newpage()
grid.define(rectGrob(width=.5, height=.5),
            gp=gpar(fill=linearGradient()), name="g")
grid.use("g")
HersheyLabel("group based on rect
GROUP has linear gradient
group defined then used", y=.1)

## Group points/coords include src and dst even if they are not drawn
## (so linear gradient starts at bottom left of page NOT at centre of page)
grid.newpage()
grid.group(circleGrob(.25, .25, .5, gp=gpar(fill="black")),
           "dest.out",
           rectGrob(.75, .75, .5, .5),
           gp=gpar(fill=linearGradient()))
HersheyLabel("group based on circle and rect
circle clears rect
GROUP has linear gradient
gradient extent is rect AND circle extent", y=.3)

## Group with shapes that do NOT start at bottom-left
grid.newpage()
grid.group(circleGrob(3:4/5, 3:4/5, r=.1),
           gp=gpar(fill=linearGradient()))
HersheyLabel("group based on circles
GROUP has linear gradient
gradient extent is circle extent", y=.3)

################################################################################

TODO <- function() {

    
}

library(grid)

HersheyLabel <- function(x, y=unit(.5, "npc")) {
    lines <- strsplit(x, "\n")[[1]]
    if (!is.unit(y))
        y <- unit(y, "npc")
    n <- length(lines)
    if (n > 1) {
        y <- y + unit(rev(seq(n)) - mean(seq(n)), "lines")
    }
    grid.text(lines, y=y, gp=gpar(fontfamily="HersheySans"))
}

devMask <- function(aMask, lMask) {
    support <- dev.capabilities()$masks
    if (is.character(support)) {
        if ("alpha" %in% support) {
            aMask
        } else {
            if ("luminance" %in% support) {
                as.mask(lMask, type="luminance")
            } else {
                FALSE
            }
        }
    } else {
        FALSE
    }
}

################################################################################

## Simple mask
mask <- devMask(circleGrob(r=.3, gp=gpar(fill="black")),
                circleGrob(r=.3, gp=gpar(col="white", fill="white")))
grid.newpage()
pushViewport(viewport(mask=mask))
grid.rect(width=.5, gp=gpar(fill="black"))
popViewport()
HersheyLabel("solid black rectangle with circle mask", y=.1)

## VERY thin mask
mask <- devMask(circleGrob(r=.3, gp=gpar(fill=NA)),
                circleGrob(r=.3, gp=gpar(col="white", fill=NA)))
grid.newpage()
pushViewport(viewport(mask=mask))
grid.rect(width=.5, gp=gpar(fill="black"))
popViewport()
HersheyLabel("solid black rectangle with circle BORDER mask", y=.1)

## Multiple grobs mask
mask <- devMask(circleGrob(x=1:3/4, y=1:3/4, r=.1, gp=gpar(fill="black")),
                circleGrob(x=1:3/4, y=1:3/4, r=.1, gp=gpar(col="white",
                                                           fill="white")))
grid.newpage()
pushViewport(viewport(mask=mask))
grid.rect(width=.5, gp=gpar(fill="black"))
popViewport()
HersheyLabel("solid black rectangle with three-circle mask", y=.1)

## Mask with gradient on single grob
mask <- devMask(circleGrob(gp=gpar(col=NA,
                                   fill=radialGradient(c("black",
                                                         "transparent")))),
                circleGrob(gp=gpar(col=NA,
                                   fill=radialGradient(c("white",
                                                         "black")))))
grid.newpage()
pushViewport(viewport(mask=mask))
grid.rect(width=.5, gp=gpar(fill="black"))
popViewport()
HersheyLabel("solid black rectangle with radial gradient mask", y=.1)

## Mask with gradient on multiple grobs
grid.newpage()
pushViewport(viewport(mask=mask))
grid.rect(x=1:2/3, width=.2, gp=gpar(fill="black"))
popViewport()
HersheyLabel("two solid black rectangles with radial gradient mask", y=.1)

## Mask with clipping path
mask <- devMask(gTree(children=gList(rectGrob(gp=gpar(fill="black"))),
                      vp=viewport(clip=circleGrob(r=.4))),
                gTree(children=gList(rectGrob(gp=gpar(col="white",
                                                      fill="white"))),
                      vp=viewport(clip=circleGrob(r=.4))))
grid.newpage()
pushViewport(viewport(mask=mask))
grid.rect(width=.5, gp=gpar(fill="grey"))
popViewport()
HersheyLabel("rect is half width and filled grey
mask is full rect with circle clipping path
result is half width rect with rounded top and bottom", y=.1)

## Mask with a mask
mask <- devMask(gTree(children=gList(rectGrob(gp=gpar(fill="black"))),
                      vp=viewport(mask=circleGrob(r=.4,
                                                  gp=gpar(fill="black")))),
                gTree(children=gList(rectGrob(gp=gpar(col="white",
                                                      fill="white"))),
                      vp=viewport(mask=as.mask(circleGrob(r=.4,
                                                          gp=gpar(col="white",
                                                                  fill="white")),
                                               type="luminance"))))
grid.newpage()
pushViewport(viewport(mask=mask))
grid.rect(width=.5, gp=gpar(fill="grey"))
popViewport()
HersheyLabel("rect is half width and filled grey
mask is full rect with circle mask
result is half width rect with rounded top and bottom", y=.1)

## A mask from two grobs, with ONE grob making use of a clipping path 
grid.newpage()
mask <- devMask(gTree(children=gList(rectGrob(x=.25, width=.3, height=.8,
                                              gp=gpar(fill="black"),
                                              vp=viewport(clip=circleGrob(r=.4))),
                                     rectGrob(x=.75, width=.3, height=.8,
                                              gp=gpar(fill="black")))),
                gTree(children=gList(rectGrob(x=.25, width=.3, height=.8,
                                              gp=gpar(col="white",
                                                      fill="white"),
                                              vp=viewport(clip=circleGrob(r=.4))),
                                     rectGrob(x=.75, width=.3, height=.8,
                                              gp=gpar(col="white",
                                                      fill="white")))))
pushViewport(viewport(mask=mask))
grid.rect(gp=gpar(fill="grey"))
popViewport()
HersheyLabel("mask is two grobs, ONE with its own (circle) clip path
push mask
rect
result is one slice of circle and one rectangle")

## A mask that is equivalent to ...
## A clipping path that itself makes use of a clipping path !?
grid.newpage()
mask <- devMask(rectGrob(gp=gpar(fill="black"),
                         vp=viewport(width=.5, height=.5, clip=circleGrob())),
                rectGrob(gp=gpar(col="white", fill="white"),
                         vp=viewport(width=.5, height=.5, clip=circleGrob())))
pushViewport(viewport(mask=mask))
grid.rect(gp=gpar(fill="grey"))
HersheyLabel("mask includes clip path
(clip path is circle)
push mask
rect
small grey circle")

## A mask that is equivalent to ...
## A clipping path that itself makes use of a rectangular clipping !?
grid.newpage()
mask <- devMask(circleGrob(r=.6,
                           gp=gpar(fill="black"),
                           vp=viewport(width=.5, height=.5, clip=TRUE)),
                circleGrob(r=.6,
                           gp=gpar(col="white", fill="white"),
                           vp=viewport(width=.5, height=.5, clip=TRUE)))
pushViewport(viewport(mask=mask))
grid.rect(gp=gpar(fill="grey"))
HersheyLabel("mask includes clip rect
(mask is squared circle)
push mask
rect
grey squared circle")

## Inheriting masks (between viewports)
grid.newpage()
pushViewport(viewport(mask=devMask(circleGrob(gp=gpar(fill="black")),
                                   circleGrob(gp=gpar(col="white",
                                                      fill="white")))))
pushViewport(viewport())
grid.rect(gp=gpar(fill="grey"))
HersheyLabel("push mask
push again (inherit mask)
rect
grey circle")

## Restoring masks (between viewports)
grid.newpage()
pushViewport(viewport(mask=devMask(circleGrob(gp=gpar(fill="black")),
                                   circleGrob(gp=gpar(col="white",
                                                      fill="white")))))
pushViewport(viewport())
pushViewport(viewport())
upViewport()
grid.rect(gp=gpar(fill="grey"))
HersheyLabel("push mask
push again (inherit mask)
push again (inherit mask)
up (restore inherited mask)
rect
grey circle")

## Revisiting mask on a viewport
## upViewport()
grid.newpage()
pushViewport(viewport(mask=devMask(circleGrob(gp=gpar(fill="black")),
                                   circleGrob(gp=gpar(col="white",
                                                      fill="white")))))
grid.rect(gp=gpar(fill="grey"))
upViewport()
grid.rect(gp=gpar(fill=rgb(0,0,1,.2)))
HersheyLabel("push mask
grey circle
upViewport
page all (translucent) blue")

## downViewport()
grid.newpage()
pushViewport(viewport(mask=devMask(circleGrob(gp=gpar(fill="black")),
                                   circleGrob(gp=gpar(col="white",
                                                      fill="white"))),
                      name="vp"))
grid.rect(height=.5, gp=gpar(fill="grey"))
upViewport()
downViewport("vp")
grid.rect(gp=gpar(fill=rgb(0,0,1,.2)))
HersheyLabel("push mask
rounded rect
upViewport
downViewport
blue (translucent) circle")

######################################
## Replaying the graphics display list

## Resizing device
grid.newpage()
pushViewport(viewport(mask=devMask(circleGrob(gp=gpar(fill="black")),
                                   circleGrob(gp=gpar(col="white",
                                                      fill="white")))))
grid.rect(gp=gpar(fill="grey"))
HersheyLabel("push mask
rect
grey circle
(for resizing)")

## Record and replay
grid.newpage()
pushViewport(viewport(mask=devMask(circleGrob(gp=gpar(fill="black")),
                                   circleGrob(gp=gpar(col="white",
                                                      fill="white")))))
grid.rect(gp=gpar(fill="grey"))
x <- recordPlot()
HersheyLabel("push mask
rect
grey circle
(for recording)")
print(x)
HersheyLabel("push mask
rect
record plot
replay plot
grey circle")

######################################
## Test of 'grid' display list

## Grabbing a grob with mask
## (replaying the 'grid' display list)
grid.newpage()
pushViewport(viewport(mask=devMask(circleGrob(gp=gpar(fill="black")),
                                   circleGrob(gp=gpar(col="white",
                                                      fill="white")))))
grid.rect(gp=gpar(fill="grey"))
x <- grid.grab()
HersheyLabel("push mask
rect
grey circle
(for grid.grab)")
grid.newpage()
grid.draw(x)
HersheyLabel("push mask
rect
grey circle
grid.grab
grid.draw
grey circle")

## A mask from two grobs, with ONE grob making use of a mask
grid.newpage()
mask <- devMask(gTree(children=gList(rectGrob(x=.25, width=.3, height=.8,
                                              gp=gpar(fill="black"),
                                              vp=viewport(mask=circleGrob(r=.4,
                                                                          gp=gpar(fill="black")))),
                                     rectGrob(x=.75, width=.3, height=.8,
                                              gp=gpar(fill="black")))),
                gTree(children=gList(rectGrob(x=.25, width=.3, height=.8,
                                              gp=gpar(col="white",
                                                      fill="white"),
                                              vp=viewport(mask=as.mask(circleGrob(r=.4,
                                                                                  gp=gpar(col="white", fill="white")),
                                                                       type="luminance"))),
                                     rectGrob(x=.75, width=.3, height=.8,
                                              gp=gpar(col="white",
                                                      fill="white")))))
pushViewport(viewport(mask=mask))
grid.rect(gp=gpar(fill="grey"))
popViewport()
HersheyLabel("mask is two grobs, ONE with its own (circle) mask
push mask
rect
result is one slice of circle and one rectangle")

## A mask within a makeContent() method
grid.newpage()
g <- gTree(cl="test")
makeContent.test <- function(x) {
    mask <- devMask(circleGrob(gp=gpar(fill="black")),
                    circleGrob(gp=gpar(col="white", fill="white")))
    setChildren(x, gList(rectGrob(gp=gpar(fill="grey"),
                                  vp=viewport(mask=mask))))
}
grid.draw(g)
HersheyLabel("custom grob class with makeContent() method
makeContent() adds rectangle with viewport
viewport has circle mask
result is grey circle")

## A mask that makes use of makeContent() method
grid.newpage()
mask <- devMask(gTree(cl="test"), gTree(cl="testLuminance"))
makeContent.test <- function(x) {
    setChildren(x, gList(circleGrob(gp=gpar(fill="black"))))
}
makeContent.testLuminance <- function(x) {
    setChildren(x, gList(circleGrob(gp=gpar(col="white", fill="white"))))
}
pushViewport(viewport(mask=mask))
grid.rect(gp=gpar(fill="grey"))
popViewport()
HersheyLabel("push viewport with mask
mask is grob with makeContent() method
makeContent() adds circle
draw rect
result is grey circle")

######################
## Check resource exhaustion
grid.newpage()
for (i in 1:65) {
    pushViewport(viewport(mask=devMask(circleGrob(gp=gpar(fill="black")),
                                       circleGrob(gp=gpar(col="white",
                                                          fill="white")))))
    grid.rect(gp=gpar(fill="grey"))
    HersheyLabel(paste0("viewport ", i, " with mask
result is grey circle"))
    popViewport()
}

## Bug from 4.1.0 (mask should NOT be applied to pattern)
grid.newpage()
pat <- pattern(circleGrob(r=.1),
               width=.17, height=.17,
               extend="repeat")
mask <- devMask(rectGrob(0:1/2, 0:1/2, width=.5, height=.5,
                         just=c("left", "bottom"),
                         gp=gpar(fill=rgb(0,0,0,1:2/2))),
                rectGrob(0:1/2, 0:1/2, width=.5, height=.5,
                         just=c("left", "bottom"),
                         gp=gpar(col="white", fill=grey(1:2/2))))
pushViewport(viewport(mask=mask))
grid.rect(gp=gpar(fill=pat))

## Mask from text
grid.newpage()
mask <- devMask(textGrob("test", gp=gpar(cex=10)),
                textGrob("test", gp=gpar(col="white", cex=10)))
pushViewport(viewport(mask=mask))
grid.rect(width=.5, height=.5, gp=gpar(fill=linearGradient()))
popViewport()
HersheyLabel("rect filled with linear gradient
masked by text", y=.8)
    
## Text being masked
grid.newpage()
mask <- devMask(rectGrob(width=.5, height=.5,
                         gp=gpar(fill=linearGradient(c("black",
                                                       "transparent")))),
                rectGrob(width=.5, height=.5,
                         gp=gpar(fill=linearGradient(c("white",
                                                       "black")))))
grid.segments(gp=gpar(col=2, lwd=50))
pushViewport(viewport(mask=mask))
grid.text("test", gp=gpar(cex=10))
popViewport()
HersheyLabel("text with mask
mask is rect with semitransparent linear gradient", y=.8)

## Mask from raster
grid.newpage()
mask <- devMask(rasterGrob(matrix(rgb(0,0,0,1:3/4), nrow=1), interpolate=FALSE),
                rasterGrob(matrix(grey(1:3/4), nrow=1), interpolate=FALSE))
grid.segments(gp=gpar(col=2, lwd=100))
pushViewport(viewport(mask=mask))
grid.circle(r=.4, gp=gpar(fill="black"))
popViewport()
HersheyLabel("circle with mask
mask is semitransparent raster", y=.8)
    
## Raster being masked
grid.newpage()
mask <- devMask(circleGrob(r=.4, gp=gpar(col=NA, fill=rgb(0,0,0,.5))),
                circleGrob(r=.4, gp=gpar(col=NA, fill=grey(.5))))
grid.segments(gp=gpar(col=2, lwd=100))
pushViewport(viewport(mask=mask))
grid.raster(matrix(1:3/4, nrow=1), interpolate=FALSE)
popViewport()
HersheyLabel("raster with mask
mask is semitransparent circle", y=.8)
    

################################################################################
## Need to test ...


library(grid)

HersheyLabel <- function(x, y=unit(.5, "npc")) {
    lines <- strsplit(x, "\n")[[1]]
    if (!is.unit(y))
        y <- unit(y, "npc")
    n <- length(lines)
    if (n > 1) {
        y <- y + unit(rev(seq(n)) - mean(seq(n)), "lines")
    }
    grid.text(lines, y=y, gp=gpar(fontfamily="HersheySans"))
}

################################################################################
## Nesting of patterns, clipping paths, masks, groups, and paths
## ALL disallowed within a path or clipping path

grid.newpage()
pat <- pattern(circleGrob(r=unit(.5, "cm"), gp=gpar(fill="black")),
               width=unit(2, "cm"), height=unit(2, "cm"),
               extend="repeat")
path <- circleGrob(gp=gpar(fill=pat))
pushViewport(viewport(clip=path))
grid.rect(gp=gpar(fill="grey"))
HersheyLabel("clipping path is based on circle
circle has (tiling) pattern fill
result is grey circle")

grid.newpage()
pat <- linearGradient()
path <- circleGrob(gp=gpar(fill=pat))
pushViewport(viewport(clip=path))
grid.rect(gp=gpar(fill="grey"))
HersheyLabel("clipping path is based on circle
circle has gradeint fill
result is grey circle")

grid.newpage()
pat <- pattern(circleGrob(r=unit(.5, "cm"), gp=gpar(fill="black")),
               width=unit(2, "cm"), height=unit(2, "cm"),
               extend="repeat")
path <- circleGrob(gp=gpar(fill=pat))
grid.fillStroke(path, gp=gpar(fill="grey"))
HersheyLabel("path is based on circle
circle has (tiling) pattern fill
path is filled grey
result is filled grey circle
(pattern fill silently ignored)")

grid.newpage()
cpath <- circleGrob(r=.2)
path <- circleGrob(vp=viewport(clip=cpath))
grid.fillStroke(path, gp=gpar(fill="grey"))
HersheyLabel("path is based on circle
circle has viewport with
clipping path based on smaller circle
result is filled grey circle
(clipping path ignored with warning)")

grid.newpage()
mask <- circleGrob(r=.2, gp=gpar(fill="black"))
path <- circleGrob(vp=viewport(mask=mask))
grid.fillStroke(path, gp=gpar(fill="grey"))
HersheyLabel("path is based on circle
circle has viewport with
mask based on smaller circle
result is filled grey circle
(mask ignored with warning)")

grid.newpage()
group <- groupGrob(circleGrob(r=.2))
path <- gTree(children=gList(circleGrob(), group))
grid.fillStroke(path, gp=gpar(fill="grey"))
HersheyLabel("path is based on circle AND group
(group is smaller circle)
result is filled grey circle
(group ignored with warning)")

grid.newpage()
grid.define(circleGrob(r=.2), name="g")
path <- gTree(children=gList(circleGrob(), useGrob("g")))
grid.fillStroke(path, gp=gpar(fill="grey"))
HersheyLabel("path is based on circle AND group *use*
(group is smaller circle)
result is filled grey circle
(group ignored with warning)")

grid.newpage()
subpath <- strokeGrob(circleGrob(r=.2))
path <- gTree(children=gList(circleGrob(), subpath))
grid.fillStroke(path, gp=gpar(fill="grey"))
HersheyLabel("path is based on circle AND subpath
(subpath is smaller circle)
result is filled grey circle
(subpath ignored with warning)")

grid.newpage()
subpath <- strokeGrob(circleGrob(r=.2))
path <- gTree(children=gList(subpath, circleGrob()))
grid.fillStroke(path, gp=gpar(fill="grey"))
HersheyLabel("path is based on subpath AND circle
(subpath is smaller circle)
result is filled grey circle
(subpath ignored with warning)")


################################################################################
## TODO

notrun <- function() {

} ## notrun()

library(grid)

HersheyLabel <- function(x, y=unit(.5, "npc")) {
    lines <- strsplit(x, "\n")[[1]]
    if (!is.unit(y))
        y <- unit(y, "npc")
    n <- length(lines)
    if (n > 1) {
        y <- y + unit(rev(seq(n)) - mean(seq(n)), "lines")
    }
    grid.text(lines, y=y, gp=gpar(fontfamily="HersheySans"))
}

devMask <- function(aMask, lMask) {
    support <- dev.capabilities()$masks
    if (is.character(support)) {
        if ("alpha" %in% support) {
            aMask
        } else {
            if ("luminance" %in% support) {
                as.mask(lMask, type="luminance")
            } else {
                FALSE
            }
        }
    } else {
        FALSE
    }
}

################################################################################
## Paths that produce same result as normal drawing

grid.newpage()
grid.stroke(circleGrob())
HersheyLabel("Single circle stroked
same as normal drawing")

grid.newpage()
grid.stroke(circleGrob(1:2/3, r=.3))
HersheyLabel("Two overlapping circles stroked
same as normal drawing")

grid.newpage()
grid.stroke(circleGrob(1:2/3, r=.1))
HersheyLabel("Two distinct circles stroked
same as normal drawing")

grid.newpage()
grid.fillStroke(circleGrob(1:2/3, r=.3), gp=gpar(col=NA, fill="grey"))
HersheyLabel("Two overlapping circles filled ONLY
non-zero winding rule
same as normal drawing")

grid.newpage()
grid.fillStroke(circleGrob(1:2/3, r=.3), gp=gpar(fill="grey"))
HersheyLabel("Two overlapping circles filled and stroked
non-zero winding rule
same as normal drawing")

grid.newpage()
grid.fillStroke(circleGrob(r=c(.1, .3)), gp=gpar(fill="grey"))
HersheyLabel("Two nested circles stroked and filled
non-zero winding rule
same as normal drawing")

################################################################################
## Paths that produce DIFFERENT result compared to normal drawing

grid.newpage()
grid.stroke(circleGrob(gp=gpar(fill="grey")))
HersheyLabel("Filled circle stroked
NO fill!")

grid.newpage()
grid.fill(circleGrob(1:2/3, r=.3), gp=gpar(fill="grey"))
HersheyLabel("Two overlapping circles filled
non-zero winding rule
NO stroke!")

grid.newpage()
grid.segments(gp=gpar(lwd=10, col=4))
grid.fill(circleGrob(1:2/3, r=.3), gp=gpar(fill=rgb(1,0,0,.5)))
HersheyLabel("Two overlapping circles filled
non-zero winding rule
semitransparent fill
NO overlap!")

grid.newpage()
grid.fill(circleGrob(1:2/3, r=.3), gp=gpar(fill="grey"), rule="evenodd")
HersheyLabel("Two overlapping circles filled
even-odd rule
get a HOLE!")

grid.newpage()
grid.fillStroke(circleGrob(1:2/3, r=.3), gp=gpar(fill="grey"), rule="evenodd")
HersheyLabel("Two overlapping circles stroked and filled
even-odd rule
get a HOLE!")

grid.newpage()
grid.fillStroke(circleGrob(r=c(.1, .3)), gp=gpar(fill="grey"), rule="evenodd")
HersheyLabel("Two nested circles stroked and filled
even-odd rule
get a HOLE!")

grid.newpage()
grid.fillStroke(polylineGrob(c(.2, .5, .8), c(.2, .8, .2)),
                gp=gpar(lwd=5, fill="grey"))
HersheyLabel("Polyline (open)
stroked and filled
get filled region
(even though not closed)")
   
grid.newpage()
pushViewport(viewport(clip=as.path(circleGrob(r=c(.3, .1)), rule="evenodd")))
grid.rect(gp=gpar(fill="grey"))
HersheyLabel("Clipping path is nested circles
even-odd rule
clip filled rect
get donut", y=.7)

grid.newpage()
grid.stroke(textGrob("testing", gp=gpar(fontface="bold", cex=4)))
HersheyLabel("Path based on text
stroke produces glyph outlines", y=.8)

grid.newpage()
gt <- gTree(children=gList(circleGrob(),
                           textGrob("testing", gp=gpar(fontface="bold", cex=4)),
                           rectGrob(width=.8, height=.5)))
grid.fillStroke(gt, gp=gpar(fill="grey"), rule="evenodd")
HersheyLabel("Path based on circle and text and rect
stroked and filled with even-odd rule
all outlines and glyphs stroked and
glyphs filled and
space between circle and rect filled
(PDF will NOT draw text)", y=.85)

grid.newpage()
gt <- gTree(children=gList(textGrob("testing", gp=gpar(fontface="bold", cex=4)),
                           circleGrob(),
                           rectGrob(width=.8, height=.5)))
grid.fillStroke(gt, gp=gpar(fill="grey"), rule="evenodd")
HersheyLabel("Path based on text and circle and rect
stroked and filled with even-odd rule
all outlines and glyphs stroked and
glyphs filled and
space between circle and rect filled
(PDF will ONLY draw text)", y=.85)

grid.newpage()
grid.fill(pathGrob(c(.2, .2, .8, .8, .4, .4, .6, .6),
                   c(.2, .8, .8, .2, .4, .6, .6, .4),
                   id.lengths=c(4, 4),
                   rule="winding"),
          gp=gpar(fill="grey"))
HersheyLabel("Path based on pathGrob
same fill rule for both (winding)
no hole")

grid.newpage()
grid.fill(pathGrob(c(.2, .2, .8, .8, .4, .4, .6, .6),
                   c(.2, .8, .8, .2, .4, .6, .6, .4),
                   id.lengths=c(4, 4),
                   rule="winding"),
          rule="evenodd",
          gp=gpar(fill="grey"))
HersheyLabel("Path based on pathGrob
DIFFERENT fill rules
(grobPath has winding but path has even-odd)
get a hole!")

## Gradient in path
grid.newpage()
grad <- linearGradient(y1=.5, y2=.5)
grid.fill(circleGrob(1:2/3, r=.1), gp=gpar(fill=grad))
HersheyLabel("path (two circles) with gradient fill
gradient relative to circle bounds
(black at left to white at right)", y=.8)

## Pattern in path
grid.newpage()
rects <- gTree(children=gList(rectGrob(width=unit(5, "mm"),
                                       height=unit(5, "mm"),
                                       just=c("left", "bottom"),
                                       gp=gpar(fill="black")),
                              rectGrob(width=unit(5, "mm"),
                                       height=unit(5, "mm"),
                                       just=c("right", "top"),
                                       gp=gpar(fill="black"))))
checkerBoard <- pattern(rects,
                        width=unit(1, "cm"), height=unit(1, "cm"),
                        extend="repeat")
grid.fill(circleGrob(1:2/3, r=.1), gp=gpar(fill=checkerBoard))
HersheyLabel("path (two circles) with pattern fill", y=.8)
    
## Path that is clipped
grid.newpage()
pushViewport(viewport(clip=circleGrob(r=.2)))
grid.fill(circleGrob(1:2/3, r=.1), gp=gpar(fill="grey"))
popViewport()
HersheyLabel("filled path (two circles)
clipped by circle path
result is two half-moons", .8)
    
## path that is masked
grid.newpage()
pushViewport(viewport(mask=devMask(circleGrob(r=.2, gp=gpar(fill="black")),
                                   circleGrob(r=.2, gp=gpar(col="white",
                                                            fill="white")))))
grid.fill(circleGrob(1:2/3, r=.1), gp=gpar(fill="grey"))
popViewport()
HersheyLabel("filled path (two circles)
masked by filled circle 
result is two half-moons", .8)

## raster-based pattern in path
grid.newpage()
checkerBoard <- pattern(rasterGrob(matrix(c(0:1, 1:0), nrow=2),
                                          width=.2, height=.2,
                                          interpolate=FALSE),
                        width=.2, height=.2,
                        extend="repeat")
grid.fill(circleGrob(1:2/3, r=.1), gp=gpar(fill=checkerBoard))
HersheyLabel("path (two circles) with pattern fill
pattern is (repeated) raster
(pattern size/shape relative to circle bbox)", y=.8)
    



################################################################################
## TODO

notrun <- function() {

## UTF8 text in path
    
} ## notrun()

library(grid)

HersheyLabel <- function(x, y=unit(.5, "npc")) {
    lines <- strsplit(x, "\n")[[1]]
    if (!is.unit(y))
        y <- unit(y, "npc")
    n <- length(lines)
    if (n > 1) {
        y <- y + unit(rev(seq(n)) - mean(seq(n)), "lines")
    }
    grid.text(lines, y=y, gp=gpar(fontfamily="HersheySans"))
}

devMask <- function(aMask, lMask) {
    support <- dev.capabilities()$masks
    if (is.character(support)) {
        if ("alpha" %in% support) {
            aMask
        } else {
            if ("luminance" %in% support) {
                as.mask(lMask, type="luminance")
            } else {
                FALSE
            }
        }
    } else {
        FALSE
    }
}

################################################################################
## Gradients

## Simple linear gradient on grob
grid.newpage()
grid.rect(gp=gpar(fill=linearGradient()))
HersheyLabel("default linear gradient
black bottom-left to white top-right")

## Test linearGradient() arguments
grid.newpage()
grid.rect(gp=gpar(fill=linearGradient(c("red", "yellow", "red"),
                                      c(0, .5, 1),
                                      x1=.5, y1=unit(1, "in"), 
                                      x2=.5, y2=1,
                                      extend="none")))
HersheyLabel("vertical linear gradient
1 inch from bottom
red-yellow-red")

## Gradient relative to grob
grid.newpage()
grid.rect(width=.5, height=.5,
          gp=gpar(fill=linearGradient()))
HersheyLabel("gradient on rect
black bottom-left to white top-right OF RECT")

## Gradient on viewport
grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient())))
grid.rect()
HersheyLabel("default linear gradient on viewport
black bottom-left to white top-right")

## Gradient relative to viewport
grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient())))
grid.rect(width=.5, height=.5)
HersheyLabel("linear gradient on viewport
viewport whole page
rect half height/width
darker grey (not black) bottom-left OF RECT
lighter grey (not white) top-right OF RECT")

grid.newpage()
pushViewport(viewport(width=.5, height=.5, gp=gpar(fill=linearGradient())))
grid.rect()
HersheyLabel("linear gradient on viewport
viewport half height/width
rect whole viewport
black bottom-left to white top-right OF RECT")

## Inherited gradient on viewport
## (should be relative to first, larger viewport)
grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient())))
pushViewport(viewport(width=.5, height=.5))
grid.rect()
HersheyLabel("gradient on viewport
viewport whole page
nested viewport half height/width
rect whole viewport
darker grey (not black) bottom-left OF RECT
lighter grey (not white) top-right OF RECT")

## Restore of gradient (just like any other gpar)
grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient())))
grid.rect(x=.2, width=.2, height=.5)
pushViewport(viewport(gp=gpar(fill="green")))
grid.rect(x=.5, width=.2, height=.5)
popViewport()
grid.rect(x=.8, width=.2, height=.5)
HersheyLabel("gradient on viewport
viewport whole page
rect left third (gradient from whole page)
nested viewport whole page
nested viewport green fill
rect centre (green)
pop to first viewport
rect right third (gradient from whole page)")

## Translucent gradient
grid.newpage()
grid.text("Reveal", gp=gpar(fontfamily="HersheySans",
                            fontface="bold", cex=3))
grid.rect(gp=gpar(fill=linearGradient(c("white", "transparent"),
                                      x1=.4, x2=.6, y1=.5, y2=.5)))
HersheyLabel("gradient from white to transparent
over text", y=.1)

## Radial gradient
grid.newpage()
grid.rect(gp=gpar(fill=radialGradient()))
HersheyLabel("default radial gradient
black centre to white radius", y=.1)

## Test radialGradient() arguments
grid.newpage()
grid.rect(gp=gpar(fill=radialGradient(c("white", "black"),
                                      cx1=.8, cy1=.8)))    
HersheyLabel("radial gradient
white to black
start centre top-right")

## Gradient on a gTree
grid.newpage()
grid.draw(gTree(children=gList(rectGrob(gp=gpar(fill=linearGradient())))))
HersheyLabel("gTree with rect child
gradient on rect
black bottom-left to white top-right")

grid.newpage()
grid.draw(gTree(children=gList(rectGrob()), gp=gpar(fill=linearGradient())))
HersheyLabel("gTree with rect child
gradient on gTree
black bottom-left to white top-right")

## Rotated gradient
grid.newpage()
pushViewport(viewport(width=.5, height=.5, angle=45,
                      gp=gpar(fill=linearGradient())))
grid.rect()
HersheyLabel("rotated gradient
black bottom-left to white top-right OF RECT")

######################################
## Tests of replaying graphics engine display list

## Resize graphics device
grid.newpage()
grid.rect(gp=gpar(fill=linearGradient()))
HersheyLabel("default gradient
(for resizing)
black bottom-left to white top-right")

grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient())))
grid.rect()
HersheyLabel("gradient on viewport
(for resizing)
black bottom-left to white top-right")

## Copy to new graphics device
grid.newpage()
grid.rect(gp=gpar(fill=linearGradient()))
x <- recordPlot()
HersheyLabel("default gradient
for recordPlot()
black bottom-left to white top-right")
replayPlot(x)
HersheyLabel("default gradient
from replayPlot()
black bottom-left to white top-right")
## (Resize that as well if you like)

grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient())))
grid.rect()
x <- recordPlot()
HersheyLabel("gradient on viewport
for recordPlot()
black bottom-left to white top-right")
replayPlot(x)
HersheyLabel("gradient on viewport
from replayPlot()
black bottom-left to white top-right")

## Replay on new device with gradient already defined
## (watch out for recorded grob using existing gradient)
grid.newpage()
grid.rect(gp=gpar(fill=linearGradient()))
x <- recordPlot()
HersheyLabel("default gradient
for recordPlot()
black bottom-left to white top-right")
grid.newpage()
grid.rect(gp=gpar(fill=linearGradient(c("white", "red"))))
HersheyLabel("new rect with new gradient")
replayPlot(x)
HersheyLabel("default gradient
from replayPlot()
AFTER white-red gradient
(should be default gradient)")

## Similar to previous, except involving viewports
grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient())))
grid.rect()
x <- recordPlot()
HersheyLabel("gradient on viewport
for recordPlot()")
grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient(c("white", "red")))))
grid.rect()
HersheyLabel("new viewport with new gradient")
replayPlot(x)
HersheyLabel("gradient on viewport
from replayPlot()
AFTER white-red gradient
(should be default gradient)")

######################################
## Test of 'grid' display list

grid.newpage()
grid.rect(name="r")
HersheyLabel("empty rect")
grid.edit("r", gp=gpar(fill=linearGradient()))
HersheyLabel("edited rect
to add gradient", y=.1)

grid.newpage()
grid.rect(gp=gpar(fill=linearGradient()))
HersheyLabel("rect with gradient
(for grab)")
x <- grid.grab()
grid.newpage()
grid.draw(x)
HersheyLabel("default gradient
from grid.grab()")

grid.newpage()
pushViewport(viewport(width=.5, height=.5, gp=gpar(fill=linearGradient())))
grid.rect()
HersheyLabel("gradient on viewport
viewport half height/width
for grid.grab")
x <- grid.grab()
grid.newpage()
grid.draw(x)
HersheyLabel("gradient on viewport
viewport half height/width
from grid.grab")

######################################
## Tests of "efficiency"
## (are patterns being resolved only as necessary)

## 
trace(grid:::resolveFill.GridPattern, print=FALSE,
      function(...) cat("*** RESOLVE:  Viewport pattern resolved\n"))
trace(grid:::resolveFill.GridGrobPattern, print=FALSE,
      function(...) cat("*** RESOLVE:  Grob pattern resolved\n"))

## ONCE for rect grob
traceHead <- "ONE resolve for rect grob with gradient"
grid.newpage()
traceOutput <- capture.output(grid.rect(gp=gpar(fill=linearGradient())))
HersheyLabel("default gradient
for tracing", y=.9)
HersheyLabel(paste(traceHead, paste(traceOutput, collapse="\n"), sep="\n"))


## ONCE for multiple rects from single grob
traceHead <- "ONE resolve for multiple rects from rect grob with gradient"
grid.newpage()
traceOutput <- capture.output(grid.rect(x=1:5/6, y=1:5/6, width=1/8, height=1/8,
                                        gp=gpar(fill=linearGradient())))
HersheyLabel("gradient on five rects
for tracing", y=.9)
HersheyLabel(paste(traceHead, paste(traceOutput, collapse="\n"), sep="\n"))

## ONCE for viewport with rect
traceHead <- "ONE resolve for rect grob in viewport with gradient"
grid.newpage()
traceOutput <- capture.output({
    pushViewport(viewport(width=.5, height=.5, gp=gpar(fill=linearGradient())))
    grid.rect()
})
HersheyLabel("gradient on viewport
viewport half height/width
for tracing", y=.8)
HersheyLabel(paste(traceHead, paste(traceOutput, collapse="\n"), sep="\n"))

## ONCE for viewport with rect, revisiting multiple times
traceHead <- "ONE resolve for rect grob in viewport with gradient\nplus nested viewport\nplus viewport revisited"
grid.newpage()
traceOutput <- capture.output({
    pushViewport(viewport(width=.5, height=.5, gp=gpar(fill=linearGradient()),
                          name="vp"))
    grid.rect(gp=gpar(lwd=8))
    pushViewport(viewport(width=.5, height=.5))
    grid.rect()
    upViewport()
    grid.rect(gp=gpar(col="red", lwd=4))
    upViewport()
    downViewport("vp")
    grid.rect(gp=gpar(col="blue", lwd=2))
})
HersheyLabel("gradient on viewport
viewport half width/height
rect (thick black border)
nested viewport (inherits gradient)
rect (medium red border)
navigate to original viewport
rect (thin blue border)", y=.9)
HersheyLabel(paste(traceHead, paste(traceOutput, collapse="\n"), sep="\n"))

untrace(grid:::resolveFill.GridPattern)
untrace(grid:::resolveFill.GridGrobPattern)

################################################################################
## Grob-based patterns

## Simple circle grob as pattern in rect
grid.newpage()
grid.rect(gp=gpar(fill=pattern(circleGrob(gp=gpar(fill="grey")))))
HersheyLabel("single grey filled circle pattern")

## Multiple circles as pattern in rect
grid.newpage()
pat <- circleGrob(1:3/4, r=unit(1, "cm"))
grid.rect(gp=gpar(fill=pattern(pat)))
HersheyLabel("three unfilled circles pattern")

## Pattern on rect scales with rect
grid.newpage()
grid.rect(width=.5, height=.8, gp=gpar(fill=pattern(pat)))
HersheyLabel("pattern on rect scales with rect")

## Pattern on viewport
grid.newpage()
pushViewport(viewport(gp=gpar(fill=pattern(pat))))
grid.rect()
HersheyLabel("pattern on viewport
applied to rect")

## Pattern on viewport stays fixed for rect
grid.newpage()
pushViewport(viewport(gp=gpar(fill=pattern(pat))))
grid.rect(width=.5, height=.8)
HersheyLabel("pattern on viewport
applied to rect
pattern does not scale with rect")

## Patterns have colour
grid.newpage()
pat <- circleGrob(1:3/4, r=unit(1, "cm"),
                  gp=gpar(fill=c("red", "green", "blue")))
grid.rect(gp=gpar(fill=pattern(pat)))
HersheyLabel("pattern with colour")

## Pattern with gradient
grid.newpage()
pat <- circleGrob(1:3/4, r=unit(1, "cm"),
                  gp=gpar(fill=linearGradient()))
grid.rect(gp=gpar(fill=pattern(pat)))
HersheyLabel("pattern with gradient")

## Pattern with a clipping path
grid.newpage()
pat <- circleGrob(1:3/4, r=unit(1, "cm"),
                  vp=viewport(clip=rectGrob(height=unit(1, "cm"))),
                  gp=gpar(fill=linearGradient()))
grid.rect(gp=gpar(fill=pattern(pat)))
HersheyLabel("pattern with clipping path
and gradient")

## Tiling patterns
grid.newpage()
grob <- circleGrob(r=unit(2, "mm"),
                   gp=gpar(col=NA, fill="grey"))
pat <- pattern(grob,
               width=unit(5, "mm"),
               height=unit(5, "mm"),
               extend="repeat")
grid.rect(gp=gpar(fill=pat))
HersheyLabel("pattern that tiles page")

grid.newpage()
pushViewport(viewport(gp=gpar(fill=pat)))
grid.rect(width=.5)
HersheyLabel("pattern that fills viewport
but only drawn within rectangle
pattern relative to viewport")

grid.newpage()
grob <- circleGrob(x=0, y=0, r=unit(2, "mm"),
                   gp=gpar(col=NA, fill="grey"))
pat <- pattern(grob,
               x=0, y=0, 
               width=unit(5, "mm"),
               height=unit(5, "mm"),
               extend="repeat")
grid.rect(width=.5, gp=gpar(fill=pat))
HersheyLabel("pattern as big as the viewport
but only drawn within rectangle
pattern relative to rectangle
(starts at bottom left of rectangle)")

## More tests
grid.newpage()
grid.circle(gp=gpar(fill=linearGradient(y1=.5, y2=.5)))
HersheyLabel("circle with horizontal gradient
black left to white right")

grid.newpage()
grid.polygon(c(.2, .8, .7, .5, .3),
             c(.8, .8, .2, .4, .2),
             gp=gpar(fill=linearGradient(y1=.5, y2=.5)))
HersheyLabel("polygon with horizontal gradient
black left to white right")

grid.newpage()
grid.path(c(.2, .8, .3, .5, .7),
          c(.8, .8, .2, .4, .2),
          gp=gpar(fill=linearGradient(y1=.5, y2=.5)))
HersheyLabel("path with horizontal gradient
black left to white right")

grid.newpage()
grid.text("Reveal", gp=gpar(fontfamily="HersheySans",
                            fontface="bold", cex=3))
grid.rect(gp=gpar(col=NA,
                  fill=radialGradient(c("white", "transparent"),
                                      r2=.3)))
HersheyLabel("text with semitransparent radial gradient
centre of text should be dissolved", y=.2)

grid.newpage()
pat <-
    pattern(circleGrob(gp=gpar(col=NA, fill="grey"),
                       vp=viewport(width=.2, height=.2,
                                   mask=devMask(rectGrob(x=c(1, 3)/4,
                                                         width=.3,
                                                         gp=gpar(fill="black")),
                                                rectGrob(x=c(1, 3)/4,
                                                         width=.3,
                                                         gp=gpar(col="white",
                                                                 fill="white"))))),
            width=1/4, height=1/4,
            extend="repeat")
grid.rect(width=.5, height=.5, gp=gpar(fill=pat))
HersheyLabel("rect in centre with pattern fill
pattern is circle drawn in smaller viewport
pattern is masked by two tall thin rects
pattern repeats", y=.15)

grid.newpage()
pat1 <-
    pattern(circleGrob(r=.1, gp=gpar(col="black", fill="grey")),
            width=.2, height=.2,
            extend="repeat")
pat2 <-
    pattern(circleGrob(r=1/4, gp=gpar(col="black", fill=pat1)),
            width=1/2, height=1/2,
            extend="repeat")
grid.rect(width=.5, height=.5, gp=gpar(fill=pat2))
HersheyLabel("rect in centre with pattern fill
pattern is small circle with pattern fill
nested pattern is smaller circle (grey)
both patterns repeat", y=.15)

######################################
## Test for expanding pattern resources
grid.newpage()
for (i in 1:21) {
    grid.rect(gp=gpar(fill=linearGradient()))
    HersheyLabel(paste0("rect ", i, " with gradient
pattern released every time"))
}

grid.newpage()
for (i in 1:65) {
    pushViewport(viewport(gp=gpar(fill=linearGradient())))
    grid.rect()
    HersheyLabel(paste0("viewport ", i, " with gradient
new pattern every time"))
}

grid.newpage()
for (i in 1:21) {
    grid.rect(gp=gpar(fill=linearGradient()))
    HersheyLabel(paste0("rect ", i, " with gradient
AFTER grid.newpage()
pattern released every time"))
}

####################################
## Additional tests

## gTree with gradient fill
grid.newpage()
gt <- gTree(children=gList(circleGrob(1:2/3, r=.1)),
            gp=gpar(fill=linearGradient(y1=.5, y2=.5)))
grid.draw(gt)
HersheyLabel("gTree with circles as children
gTree has gradient fill
gradient relative to circle bounds
(black at left to white at right)", y=.8)

## gTree with gradient fill with gTree 
grid.newpage()
gt <- gTree(children=gList(gTree(children=gList(circleGrob(1:2/3, r=.1)))),
            gp=gpar(fill=linearGradient(y1=.5, y2=.5)))
grid.draw(gt)
HersheyLabel("gTree with gTree as child
inner gTree has circles as children
outer gTree has gradient fill
gradient relative to circle bounds
(black at left to white at right)", y=.8)

## Pattern including text
grid.newpage()
pat <- pattern(textGrob("test"),
               width=1.2*stringWidth("test"),
               height=unit(1, "lines"),
               extend="repeat")
grid.circle(r=.3, gp=gpar(fill=pat))
HersheyLabel("circle filled with pattern
pattern based on (repeating) text", y=.9)

## Text (path) filled with pattern
grid.newpage()
rects <- gTree(children=gList(rectGrob(width=unit(2, "mm"),
                                       height=unit(2, "mm"),
                                       just=c("left", "bottom"),
                                       gp=gpar(fill="black")),
                              rectGrob(width=unit(2, "mm"),
                                       height=unit(2, "mm"),
                                       just=c("right", "top"),
                                       gp=gpar(fill="black"))))
checkerBoard <- pattern(rects,
                        width=unit(4, "mm"), height=unit(4, "mm"),
                        extend="repeat")
grid.fill(textGrob("test", gp=gpar(fontface="bold", cex=10)),
          gp=gpar(fill=checkerBoard))
HersheyLabel("stroked path based on text
filled with checkerboard pattern", y=.8)
    
## Pattern including raster
grid.newpage()
rg <- rasterGrob(matrix(c(0:1, 1:0), nrow=2),
                 width=unit(1, "cm"), height=unit(1, "cm"),
                 interpolate=FALSE)
pat <- pattern(rg, 
               width=unit(1, "cm"), height=unit(1, "cm"),
               extend="repeat")
grid.circle(r=.2, gp=gpar(fill=pat))
HersheyLabel("circle filled with pattern
pattern is based on raster (checkerboard)", y=.8)

## Radial gradient where start circle and final circle overlap
grid.newpage()
x1 <- .7
y1 <- .7
r1 <- .2
x2 <- .4
y2 <- .4
r2 <- .4
grid.circle(x1, y1, r=r1, gp=gpar(col="green", fill=NA, lwd=2))
grid.circle(x2, y2, r=r2, gp=gpar(col="red", fill=NA, lwd=2))
grid.rect(gp=gpar(fill=radialGradient(rgb(0:1, 1:0, 0, .5),
                                      cx1=x1, cy1=y1, r1=r1,
                                      cx2=x2, cy2=y2, r2=r2)))
HersheyLabel("radial gradient with overlapping start and final circles
gradient is from semitransparent green
to semitransparent red
start circle is green
final circle is red")

## Text (path) filled with pattern
grid.newpage()
grid.fill(textGrob("test", gp=gpar(fontface="bold", cex=10)),
          gp=gpar(fill=linearGradient(2:3)))
HersheyLabel("stroked path based on text
filled with linear gradient", y=.8)
    
################################################################################
## Points

## Points filled with gradient
grid.newpage()
grid.points(1:9/10, 1:9/10, default.units="npc",
            pch=21, gp=gpar(fill=linearGradient()))
HersheyLabel("points (pch=21)
filled with linear gradient
(gradient based on ALL points)", y=.8)

## Points filled with gradient (point not filled)
grid.newpage()
grid.points(1:9/10, 1:9/10, default.units="npc",
            pch=1, gp=gpar(fill=linearGradient()))
HersheyLabel("points (pch=1)
filled with linear gradient
(fill ignored)", y=.8)

## Individual points filled with gradient (gradient recycled)
grid.newpage()
grid.points(1:3/4, 1:3/4, default.units="npc",
            pch=21, gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("points (pch=21)
filled with linear gradient
(gradient based on EACH point)", y=.8)

## Individual points filled with individual gradients
grid.newpage()
gradients <- lapply(2:4, function(x) linearGradient(c(x, "white"), group=FALSE))
grid.points(1:3/4, 1:3/4, default.units="npc",
            pch=21, gp=gpar(fill=gradients))
HersheyLabel("points (pch=21)
filled with linear gradient
(different gradient for EACH point)", y=.8)

## points inheriting single gradient
grid.newpage()
pushViewport(viewport(gp=gpar(fill=linearGradient())))
grid.points(1:2, 1:2, default.units="in", pch=21)
HersheyLabel("points (pch=21)
filled with linear gradient
gradient inherited from viewport
(so gradient relative to viewport)")

## points inheriting multiple gradients
grid.newpage()
pushViewport(viewport(gp=gpar(fill=list(linearGradient(1:2),
                                        radialGradient(3:4)))))
grid.points(1:2, 1:2, default.units="in", pch=21)
HersheyLabel("points (pch=21)
filled with multiple linear gradients
gradients inherited from viewport
(so gradients relative to viewport)")

## points recycling inherited multiple gradients
grid.newpage()
pushViewport(viewport(gp=gpar(fill=list(linearGradient(1:2),
                                        radialGradient(3:4)))))
grid.points(1:9/10, 1:9/10, default.units="npc", pch=21)
HersheyLabel("points (pch=21)
filled with linear gradients
gradients inherited from viewport
(so gradient relative to viewport)
more points than gradients
(so gradients recycled)")

## points recycling inherited multiple gradients with group=FALSE
## so pattern just passed through and resolved relative to points grob
grid.newpage()
pushViewport(viewport(gp=gpar(fill=list(linearGradient(1:2, group=FALSE),
                                        radialGradient(3:4, group=FALSE)))))
grid.points(1:9/10, 1:9/10, default.units="npc", pch=21)
HersheyLabel("points (pch=21)
filled with linear gradients
group=FALSE
gradients inherited from viewport
(but unresolved so resolved on EACH point)
more points than gradients
(so gradients recycled)")

## Using tracing to check that fills are not being resolved more than necessary
trace(grid:::resolveFill.GridPattern, print=FALSE,
      function(...) cat("*** RESOLVE:  Viewport pattern resolved\n"))
trace(grid:::resolveFill.GridPatternList, print=FALSE,
      function(...) cat("*** RESOLVE:  Viewport pattern list resolved\n"))
trace(grid:::resolveFill.GridGrobPattern, print=FALSE,
      function(...) cat("*** RESOLVE:  Grob pattern resolved\n"))
trace(grid:::resolveFill.GridGrobPatternList, print=FALSE,
      function(...) cat("*** RESOLVE:  Grob pattern list resolved\n"))
doTrace <- function(head, f) {
    traceOutput <- capture.output(f())    
    HersheyLabel(paste(head, paste(traceOutput, collapse="\n"), sep="\n"))
}

grid.newpage()
doTrace("points grob (pch=21)\nwith gradient\nONE resolve",
        function() {
            grid.points(1:9/10, 1:9/10, default.units="npc",
                        pch=21,
                        gp=gpar(fill=linearGradient()))
        })

grid.newpage()
doTrace("points grob (pch=1)\nwith gradient\nONE resolve\n(even though unused)",
        function() {
            grid.points(1:9/10, 1:9/10, default.units="npc",
                        pch=1, gp=gpar(fill=linearGradient()))
        })

grid.newpage()
doTrace("points grob (pch=21)\nwith gradient (group=FALSE)\nTHREE resolves\n(resolve per point)",
        function() {
            grid.points(1:3/4, 1:3/4, default.units="npc",
                        pch=21, gp=gpar(fill=linearGradient(group=FALSE)))
        })

grid.newpage()
gradients <- lapply(2:4, function(x) linearGradient(c(x, "white"), group=FALSE))
doTrace("points grob (pch=21)\nwith gradient list (group=FALSE)\nONE resolve\n(all gradients resolved at once)",
        function() {
            grid.points(1:3/4, 1:3/4, default.units="npc",
                        pch=21, gp=gpar(fill=gradients))
        })

grid.newpage()
doTrace("points grob (pch=21)\nwith inherited gradient\nONE resolve\n(gradient resolved when vp pushed)",
        function() {
            pushViewport(viewport(gp=gpar(fill=linearGradient())))
            grid.points(1:2, 1:2, default.units="in", pch=21)
        })

grid.newpage()
doTrace("points grob (pch=21)\nwith inherited gradient list\nTWO resolves\n(gradient list resolved when vp pushed\nAND gradient list resolved when points drawn\n[no-op because already resolved])",
        function() {
            pushViewport(viewport(gp=gpar(fill=list(linearGradient(1:2),
                                                    radialGradient(3:4)))))
            grid.points(1:2, 1:2, default.units="in", pch=21)
        })

grid.newpage()
doTrace("points grob (pch=21)\nwith inherited gradient list\nAND recycling of gradients\nTWO resolves\n(gradient list resolved when vp pushed\nAND gradient list resolved when points drawn\n[no-op because already resolved])",
        function() {
            pushViewport(viewport(gp=gpar(fill=list(linearGradient(1:2),
                                                    radialGradient(3:4)))))
            grid.points(1:9/10, 1:9/10, default.units="npc", pch=21)
        })

## Individual points filled with individual gradients
## *some* group = TRUE and *some* group = FALSE
grid.newpage()
gradients <- lapply(2:4, function(x) linearGradient(c(x, "white"),
                                                    group = x %% 2))
grid.points(1:3/4, 1:3/4, default.units="npc",
            pch=21, gp=gpar(fill=gradients))
HersheyLabel("points (pch=21)
filled with linear gradient
(different gradient for EACH point)
first and third resolved on individual points
second resolved on ALL points", y=.8)

## Points filled with pattern (recycled), multiple pch
grid.newpage()
grid.points(1:3/4, 1:3/4, default.units="npc",
            pch=21:23, gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("points (pch=21:23)
single gradient (group=FALSE)
each different point gets its own gradient", y=.8)

################################################################################
## Rects
grid.newpage()
grid.rect(x=1:3/4, y=1:3/4, width=.2, height=.2,
          gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("single gradient fill
group = FALSE", y=.8)

grid.newpage()
grid.rect(x=1:3/4, y=1:3/4, width=.2, height=.2,
          gp=gpar(fill=list(linearGradient(group=FALSE),
                            radialGradient(group=FALSE),
                            linearGradient())))
HersheyLabel("list of gradient fills
linear (group=FALSE)
radial (group=FALSE)
linear (group=TRUE)", y=.8)

################################################################################
## Circles
grid.newpage()
grid.circle(x=1:3/4, y=1:3/4, r=.1,
            gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("single gradient fill
group = FALSE", y=.8)

grid.newpage()
grid.circle(x=1:3/4, y=1:3/4, r=.1,
            gp=gpar(fill=list(linearGradient(group=FALSE),
                              radialGradient(group=FALSE),
                              linearGradient())))
HersheyLabel("list of gradient fills
linear (group=FALSE)
radial (group=FALSE)
linear (group=TRUE)", y=.8)

################################################################################
## Polygons
grid.newpage()
grid.polygon(x=c(.2, .4, .3,
                 .4, .6, .5,
                 .6, .8, .7),
             y=c(.2, .2, .4,
                 .4, .4, .6,
                 .6, .6, .8),
             id=rep(1:3, each=3),
             gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("single gradient fill
group = FALSE", y=.8)

grid.newpage()
grid.polygon(x=c(.2, .4, .3,
                 .4, .6, .5,
                 .6, .8, .7),
             y=c(.2, .2, .4,
                 .4, .4, .6,
                 .6, .6, .8),
             id=rep(1:3, each=3),
             gp=gpar(fill=list(linearGradient(group=FALSE),
                               radialGradient(group=FALSE),
                               linearGradient())))
HersheyLabel("list of gradient fills
linear (group=FALSE)
radial (group=FALSE)
linear (group=TRUE)", y=.8)

################################################################################
## Segments
grid.newpage()
grid.segments(x0=c(.2, .4, .6),
              y0=c(.2, .5, .8),
              x1=c(.4, .6, .8),
              y1=c(.2, .5, .8),
              gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("single gradient fill
group = FALSE", y=.8)

grid.newpage()
grid.segments(x0=c(.2, .4, .6),
              y0=c(.2, .5, .8),
              x1=c(.4, .6, .8),
              y1=c(.2, .5, .8),
             gp=gpar(fill=list(linearGradient(group=FALSE),
                               radialGradient(group=FALSE),
                               linearGradient())))
HersheyLabel("list of gradient fills
linear (group=FALSE)
radial (group=FALSE)
linear (group=TRUE)", y=.8)

################################################################################
## Xsplines
grid.newpage()
grid.xspline(x=c(.2, .4, .3,
                 .4, .6, .5,
                 .6, .8, .7),
             y=c(.2, .2, .4,
                 .4, .4, .6,
                 .6, .6, .8),
             id=rep(1:3, each=3),
             shape=-1, open=FALSE,
             gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("single gradient fill
group = FALSE", y=.8)

grid.newpage()
grid.xspline(x=c(.2, .4, .3,
                 .4, .6, .5,
                 .6, .8, .7),
             y=c(.2, .2, .4,
                 .4, .4, .6,
                 .6, .6, .8),
             id=rep(1:3, each=3),
             shape=-1, open=FALSE,
             gp=gpar(fill=list(linearGradient(group=FALSE),
                               radialGradient(group=FALSE),
                               linearGradient())))
HersheyLabel("list of gradient fills
linear (group=FALSE)
radial (group=FALSE)
linear (group=TRUE)", y=.8)

################################################################################
## Lines
##
## NOTE that polylines are handled by same underlying C code
grid.newpage()
grid.lines(x=c(.2, .4, .3),
           y=c(.2, .2, .4),
           gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("single gradient fill
group = FALSE", y=.8)

grid.newpage()
grid.lines(x=c(.2, .4, .3),
           y=c(.2, .2, .4),
           gp=gpar(fill=list(linearGradient(group=FALSE),
                             radialGradient(group=FALSE),
                             linearGradient())))
HersheyLabel("list of gradient fills
linear (group=FALSE)
radial (group=FALSE)
linear (group=TRUE)", y=.8)

################################################################################
## MoveTo/LineTo
grid.newpage()
grid.move.to(x=.2, y=.2)
grid.line.to(x=.4, y=.4,
             gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("single gradient fill
group = FALSE", y=.8)

grid.newpage()
grid.move.to(x=.2, y=.2)
grid.line.to(x=.4, y=.4,
             gp=gpar(fill=list(linearGradient(group=FALSE),
                               radialGradient(group=FALSE),
                               linearGradient())))
HersheyLabel("list of gradient fills
linear (group=FALSE)
radial (group=FALSE)
linear (group=TRUE)", y=.8)

################################################################################
## Paths

## Pattern fill on single path consisting of distinct shapes
grid.newpage()
grid.path(c(.2, .2, .4, .4, .6, .6, .8, .8),
          c(.2, .4, .4, .2, .6, .8, .8, .6),
          id=rep(1:2, each=4),
          gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("single gradient fill
group = FALSE
single path", y=.8)

## Pattern fill on multiple paths, each consisting of distinct shapes
grid.newpage()
grid.path(c(.2, .2, .4, .4,
            .25, .25, .35, .35,
            .6, .6, .8, .8,
            .65, .65, .75, .75),
          c(.2, .4, .4, .2,
            .25, .35, .35, .25,
            .6, .8, .8, .6,
            .65, .75, .75, .65),
          rule="evenodd",
          id=rep(1:4, each=4),
          pathId=rep(1:2, each=8),
          gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("single gradient fill
group = FALSE
multiple paths", y=.8)

## Same thing, list of patterns
grid.newpage()
grid.path(c(.2, .2, .4, .4,
            .25, .25, .35, .35,
            .6, .6, .8, .8,
            .65, .65, .75, .75),
          c(.2, .4, .4, .2,
            .25, .35, .35, .25,
            .6, .8, .8, .6,
            .65, .75, .75, .65),
          rule="evenodd",
          id=rep(1:4, each=4),
          pathId=rep(1:2, each=8),
          gp=gpar(fill=list(linearGradient(group=FALSE),
                            radialGradient(group=FALSE))))
HersheyLabel("mulitple gradient fills
group = FALSE
multiple paths", y=.8)

################################################################################
## Raster
grid.newpage()
grid.raster(matrix(1:4/5, ncol=2),
            interpolate=FALSE,
            width=.5, height=.5,
            gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("single gradient fill
group = FALSE", y=.8)

grid.newpage()
grid.raster(matrix(1:4/5, ncol=2),
            interpolate=FALSE,
            width=.5, height=.5,
            gp=gpar(fill=list(linearGradient(group=FALSE),
                              radialGradient(group=FALSE),
                              linearGradient())))
HersheyLabel("list of gradient fills
linear (group=FALSE)
radial (group=FALSE)
linear (group=TRUE)", y=.8)

################################################################################
## Text
grid.newpage()
grid.text(letters[1:3], x=1:3/4, y=1:3/4, 
          gp=gpar(fontfamily="HersheySans",
                  fill=linearGradient(group=FALSE)))
HersheyLabel("single gradient fill
group = FALSE", y=.8)

grid.newpage()
grid.text(letters[1:3], x=1:3/4, y=1:3/4, 
          gp=gpar(fontfamily="HersheySans",
                  fill=list(linearGradient(group=FALSE),
                            radialGradient(group=FALSE),
                            linearGradient())))
HersheyLabel("list of gradient fills
linear (group=FALSE)
radial (group=FALSE)
linear (group=TRUE)", y=.8)

################################################################################
## Arrows
grid.newpage()
grid.segments(x0=c(.2, .4, .6),
              y0=c(.2, .5, .8),
              x1=c(.4, .6, .8),
              y1=c(.2, .5, .8),
              arrow=arrow(type="closed"),
              gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("Lines with (closed) arrows
gradient fill disallowed on arrow", y=.8)

grid.newpage()
grid.xspline(x=c(.2, .4, .3,
                 .4, .6, .5,
                 .6, .8, .7),
             y=c(.2, .2, .4,
                 .4, .4, .6,
                 .6, .6, .8),
             id=rep(1:3, each=3),
             shape=-1,
             arrow=arrow(type="closed"),
             gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("Lines with (closed) arrows
gradient fill disallowed on arrow", y=.8)

grid.newpage()
grid.lines(x=c(.2, .4, .3),
           y=c(.2, .2, .4),
           arrow=arrow(type="closed"),
           gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("Lines with (closed) arrows
gradient fill disallowed on arrow", y=.8)

grid.newpage()
grid.move.to(x=.2, y=.2)
grid.line.to(x=.4, y=.4,
             arrow=arrow(type="closed"),
             gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("Lines with (closed) arrows
gradient fill disallowed on arrow", y=.8)

################################################################################
## Test more complex coords from more complex grobs (gTrees)

################################################################################
## grobCoords() also used when resolving patterns to generate a bbox
## for temporary viewport (so the pattern is resolved relative to the
## grob bbox).  Hence ...
##
## grid/R/patterns.R
library(grid)

## Test gTree with pattern fill
## Children are distinct rectangles, pattern is resolved on gTree
## so relative to bbox around both rectangles
gt <- gTree(children=gList(rectGrob(1/3, width=.2, height=.2),
                           rectGrob(2/3, width=.2, height=.2)),
            gp=gpar(fill=linearGradient()))
grid.newpage()
grid.draw(gt)
HersheyLabel("gTree with two rects
fill resolved on bbox of both rects", y=.8)

## Test gTree with pattern fill with children that push vp
## (to test that the resolution happens in the gTree context
##  NOT the child's vp context)
## Both rects should be filled with gradient that fills whole page
gt <- gTree(children=gList(rectGrob(),
                           rectGrob(vp=viewport(width=.5, height=.5))),
            gp=gpar(fill=linearGradient()))
grid.newpage()
grid.draw(gt)
HersheyLabel("gTree with two rects
one rect has vp
fill resolved on gTree
both rects same fill")

## Test gTree with pattern fill with children with pattern fill
## Left rect gets its own gradient;  right rect gets gradient
## relative to both rects
gt <- gTree(children=gList(rectGrob(1/3, width=.2, height=.2,
                                    gp=gpar(fill=linearGradient())),
                           rectGrob(2/3, width=.2, height=.2)),
            gp=gpar(fill=linearGradient()))
grid.newpage()
grid.draw(gt)
HersheyLabel("gTree with pattern fill
one rect also has pattern fill
one rect has gTree pattern fill
(resolved on both rects)
one rect has its own pattern fill", y=.8)

## Test gTree with pattern fill with gTree as child
## (same result as first gTree test)
gt <- gTree(children=gList(gTree(children=gList(rectGrob(1/3,
                                                         width=.2,
                                                         height=.2),
                                                rectGrob(2/3,
                                                         width=.2,
                                                         height=.2)))),
            gp=gpar(fill=linearGradient()))
grid.newpage()
grid.draw(gt)
HersheyLabel("gTree with pattern fill
child is gTree with children
pattern resolved on parent gTree" ,y=.8)

## Test gTree with gTree with pattern fill as child
## (same result as first gTree test)
gt <- gTree(children=gList(gTree(children=gList(rectGrob(1/3,
                                                         width=.2,
                                                         height=.2),
                                                rectGrob(2/3,
                                                         width=.2,
                                                         height=.2)),
                                 gp=gpar(fill=linearGradient()))))
grid.newpage()
grid.draw(gt)
HersheyLabel("gTree child gTree
child gTree has pattern fill
pattern resolved on child gTree" ,y=.8)

## Test gTree with pattern fill with group = FALSE
## (so pattern fill is resolved separately on each child)
gt <- gTree(children=gList(rectGrob(1/3, width=.2, height=.2),
                           rectGrob(2/3, width=.2, height=.2)),
            gp=gpar(fill=linearGradient(group=FALSE)))
grid.newpage()
grid.draw(gt)
HersheyLabel("gTree with pattern fill
with group=FALSE
pattern resolved on each child rect", y=.8)

################################################################################
## groups and (stroked and filled) paths generate gTrees to calculate
## grobCoords(), so they are affected.  Hence ...
##
## grid/R/group.R
## grid/R/path.R
library(grid)
r1 <- rectGrob(x=0, y=0, width=.5, height=.5, just=c("left", "bottom"))
r2 <- rectGrob(x=1, y=1, width=.75, height=.75, just=c("right", "top"),
               gp=gpar(fill="black"))

## Path with hole filled with pattern
grid.newpage()
grid.fill(gTree(children=gList(r1, r2)),
          rule="evenodd",
          gp=gpar(fill=linearGradient()))
HersheyLabel("path from two rects
pattern fill resolved on bbox of both rects", y=.8)

## Remove r2 from r1 with "group" and fill with gradient
## (bbox is from BOTH rects, hence whole page)
grid.newpage()
grid.group(r2, "dest.out", r1, gp=gpar(fill=linearGradient()))
HersheyLabel("group of two rects
big rect takes bite out of small rect
pattern fill resolved on bbox of both rects", y=.8)

## NOTE that setting 'gp' on group use has no effect on group
## (graphical parameter settings were fixed at group definition)
grid.newpage()
grid.define(r1, name="r1")
pushViewport(viewport(x=1, y=1))
grid.use("r1", gp=gpar(fill=linearGradient()))
upViewport()
HersheyLabel("group use with pattern fill
pattern IGNORED", y=.2)

## BUT if put the fill on the grob in the group it works ?
grid.newpage()
grid.define(editGrob(r1, gp=gpar(fill=linearGradient())), name="r1")
pushViewport(viewport(x=1, y=1))
grid.use("r1")
upViewport()
HersheyLabel("group use imposes transformation
rect within group has pattern fill
pattern resolved on rect on use", y=.2)
## ... even with scaling (as well as translation) transformation
grid.newpage()
grid.define(editGrob(r1, gp=gpar(fill=linearGradient())), name="r1")
pushViewport(viewport(x=1, y=1, width=.5, height=.5))
grid.use("r1")
upViewport()
HersheyLabel("group use imposes transformation AND scaling
rect within group has pattern fill
pattern resolved on rect on use", y=.2)

################################################################################
## Tests of gTree with LIST of patterns

## gTree with LIST of patterns, group = TRUE
## Test gTree with pattern fill with group = FALSE
## (so pattern fill is resolved separately on each child)
gt <- gTree(children=gList(rectGrob(1:2/3, 1/3, width=.2, height=.2),
                           rectGrob(1:2/3, 2/3, width=.2, height=.2)),
            gp=gpar(fill=list(linearGradient(), radialGradient())))
grid.newpage()
grid.draw(gt)
HersheyLabel("gTree with LIST of pattern fills
with group=TRUE
patterns resolved on gTree
each SHAPE within each child gets different pattern", y=.8)

## gTree with LIST of patterns, group = FALSE
gt <- gTree(children=gList(rectGrob(1:2/3, 1/3, width=.2, height=.2),
                           rectGrob(1:2/3, 2/3, width=.2, height=.2)),
            gp=gpar(fill=list(linearGradient(group=FALSE),
                              radialGradient(group=FALSE))))
grid.newpage()
grid.draw(gt)
HersheyLabel("gTree with LIST of pattern fills
with group=FALSE
patterns resolved on children
each SHAPE within each child RESOLVES different pattern", y=.8)

## gTree with LIST of patterns, group = mix of TRUE/FALSE
gt <- gTree(children=gList(rectGrob(1:2/3, 1/3, width=.2, height=.2),
                           rectGrob(1:2/3, 2/3, width=.2, height=.2)),
            gp=gpar(fill=list(linearGradient(group=TRUE),
                              radialGradient(group=FALSE))))
grid.newpage()
grid.draw(gt)
HersheyLabel("gTree with LIST of pattern fills
with group=TRUE and FALSE
patterns resolved on gTree AND children
each SHAPE within each child gets OR resolves different pattern", y=.8)

## gTree with LIST of patterns, group = TRUE
## but NO children that have a fill!
gt <- gTree(children=gList(segmentsGrob(0, 0:1, 1, 1:0)),
            gp=gpar(fill=list(linearGradient(),
                              radialGradient())))
grid.newpage()
grid.draw(gt)
HersheyLabel("gTree with LIST of pattern fills
with group=TRUE
BUT no children that have a fill
patterns resolved on gTree
no (pattern) fill", y=.8)

## gTree with LIST of patterns, group = FALSE
## but NO children that have a fill!
gt <- gTree(children=gList(segmentsGrob(0, 0:1, 1, 1:0)),
            gp=gpar(fill=list(linearGradient(group=FALSE),
                              radialGradient(group=FALSE))))
grid.newpage()
grid.draw(gt)
HersheyLabel("gTree with LIST of pattern fills
with group=FALSE
BUT no children that have a fill
patterns resolved on children
no (pattern) fill", y=.8)

## gTree with LIST of patterns, group = mix of TRUE/FALSE
## and MIX of children that have a fill!
## (all combinations of group and child-has-fill)
gt <- gTree(children=gList(segmentsGrob(0, 0:1, 1, 1:0),
                           rectGrob(1:2/3, 2/3, width=.2, height=.2)),
            gp=gpar(fill=list(linearGradient(group=TRUE),
                              radialGradient(group=FALSE))))
grid.newpage()
grid.draw(gt)
HersheyLabel("gTree with LIST of pattern fills
with group=FALSE
BUT no children that have a fill
patterns resolved on children
no (pattern) fill", y=.8)

################################################################################
## More groups and (stroked and filled) paths 
library(grid)
r1 <- rectGrob(x=0, y=0, width=.5, height=.5, just=c("left", "bottom"))
r2 <- rectGrob(x=1, y=1, width=.75, height=.75, just=c("right", "top"),
               gp=gpar(fill="black"))

## Path with hole filled with pattern, group = FALSE
## Path is a "single shape" so result should be same as group = TRUE
grid.newpage()
grid.fill(gTree(children=gList(r1, r2)),
          rule="evenodd",
          gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("path from two rects
group = FALSE
pattern fill resolved on bbox of both rects", y=.8)

## Remove r2 from r1 with "group" and fill with gradient, group = FALSE
## Gradient should be applied to individual rects
grid.newpage()
grid.group(r2, "dest.out", r1, gp=gpar(fill=linearGradient(group=FALSE)))
HersheyLabel("group of two rects
group = FALSE
big rect takes bite out of small rect
pattern fill resolved on each rect", y=.8)

## fill on the grob in the group
grid.newpage()
grid.define(r2, "dest.out",
            editGrob(r1, gp=gpar(fill=linearGradient())),
            name="r1")
pushViewport(viewport(x=1, y=1))
grid.use("r1")
upViewport()
HersheyLabel("group use imposes transformation
rect within group has pattern fill
pattern resolved on rect on use", y=.2)
## ... even with scaling (as well as translation) transformation
grid.newpage()
grid.define(r2, "dest.out",
            editGrob(r1, gp=gpar(fill=linearGradient())),
            name="r1")
pushViewport(viewport(x=1, y=1, width=.5, height=.5))
grid.use("r1")
upViewport()
HersheyLabel("group use imposes transformation AND scaling
rect within group has pattern fill
pattern resolved on rect on use", y=.2)

## fill on the grob in the group, group = FALSE
grid.newpage()
grid.define(r2, "dest.out",
            editGrob(r1, gp=gpar(fill=linearGradient(group=FALSE))),
            name="gt")
pushViewport(viewport(x=1, y=1))
grid.use("gt")
upViewport()
HersheyLabel("group use imposes transformation
rect within group has pattern fill
group = FALSE (no effect)
pattern resolved on rect on use", y=.2)
## ... even with scaling (as well as translation) transformation, group=FALSE
grid.newpage()
grid.define(r2, "dest.out",
            editGrob(r1, gp=gpar(fill=linearGradient(group=FALSE))),
            name="gt")
pushViewport(viewport(x=1, y=1, width=.5, height=.5))
grid.use("gt")
upViewport()
HersheyLabel("group use imposes transformation AND scaling
rect within group has pattern fill
group = FALSE (no effect)
pattern resolved on rect on use", y=.2)

## Test gTree with pattern fill with children that push vp, group = FALSE
## SO child with vp should get different fill
gt <- gTree(children=gList(rectGrob(),
                           rectGrob(vp=viewport(width=.5, height=.5))),
            gp=gpar(fill=linearGradient(group=FALSE)))
grid.newpage()
grid.draw(gt)
HersheyLabel("gTree with two rects
one rect has vp
fill resolved on each rect
rects get different fill")

## gTree with group as child, fill resolved on gTree bbox
## (so needs group bbox)
grid.newpage()
group <- groupGrob(r1)
gt <- gTree(children=gList(r2, group),
            gp=gpar(fill=linearGradient()))
grid.draw(gt)
HersheyLabel("gTree has group as child
gTree has pattern fill
pattern resolved on gTree", y=.2)

## gTree with group USE as child, fill resolved on gTree bbox
## (so needs group USE bbox)
grid.newpage()
r3 <- rectGrob(width=.5, height=.5)
group <- grid.define(r1, name="r")
use <- useGrob("r", vp=viewport(1, 1))
gt <- gTree(children=gList(r3, use),
            gp=gpar(fill=linearGradient()))
grid.rect(.25, .25, .75, .75, just=c("left", "bottom"),
          gp=gpar(col=NA, fill=linearGradient()))
grid.draw(gt)
HersheyLabel("gTree has group USE as child
gTree has pattern fill
pattern resolved on gTree
(rect behind shows correct gradient)", y=.2)

## Check grobCoords() from transform with skew produces same outline
grid.newpage()
c <- circleGrob(r=c(.3, .4))
pts <- grobCoords(c, closed=TRUE)
p <- pathGrob(c(pts[[1]]$x, pts[[2]]$x),
              c(pts[[1]]$y, pts[[2]]$y),
              default.units="in",
              id=rep(1:2, each=100),
              rule="evenodd",
              gp=gpar(fill="grey"))
grid.draw(p)
grid.define(p, name="path")
use <- useGrob("path",
               transform=function(group, ...)
                   viewportTransform(group,
                                     shear=groupShear(.5),
                                     ...))
newPts <- grobCoords(use, closed=TRUE)
newPath <- circleGrob(c(newPts[[1]][[1]][[1]]$x, newPts[[1]][[1]][[2]]$x),
                      c(newPts[[1]][[1]][[1]]$y, newPts[[1]][[1]][[2]]$y),
                      default.units="in",
                      r=unit(.5, "mm"),
                      gp=gpar(col="red", fill="red"))
grid.draw(use)
grid.draw(newPath)

library(grid)

# Unit conversions
stopifnot(round(convertX(unit(1, "inches"), "inches", valueOnly=TRUE) - 1,
                digits=5) == 0)
stopifnot(round(convertX(unit(2.54, "cm"), "inches", valueOnly=TRUE) - 1,
                digits=5) == 0)
stopifnot(round(convertX(unit(25.4, "mm"), "inches", valueOnly=TRUE) - 1,
                digits=5) == 0)
stopifnot(round(convertX(unit(72.27, "points"), "inches", valueOnly=TRUE) - 1,
                digits=5) == 0)
stopifnot(round(convertX(unit(1/12*72.27, "picas"), "inches",
                         valueOnly=TRUE) - 1, digits=5) == 0)
stopifnot(round(convertX(unit(72, "bigpts"), "inches", valueOnly=TRUE) - 1,
                digits=5) == 0)
stopifnot(round(convertX(unit(1157/1238*72.27, "dida"), "inches",
                         valueOnly=TRUE) - 1, digits=5) == 0)
stopifnot(round(convertX(unit(1/12*1157/1238*72.27, "cicero"), "inches",
                         valueOnly=TRUE) - 1, digits=5) == 0)
stopifnot(round(convertX(unit(65536*72.27, "scaledpts"), "inches",
                         valueOnly=TRUE) - 1, digits=5) == 0)
stopifnot(round(convertX(unit(1/2.54, "inches"), "cm", valueOnly=TRUE) - 1,
                digits=5) == 0)
stopifnot(round(convertX(unit(1/25.4, "inches"), "mm", valueOnly=TRUE) - 1,
                digits=5) == 0)
stopifnot(round(convertX(unit(1/72.27, "inches"), "points",
                         valueOnly=TRUE) - 1, digits=5) == 0)
stopifnot(round(convertX(unit(1/(1/12*72.27), "inches"), "picas",
                         valueOnly=TRUE) - 1, digits=5) == 0)
stopifnot(round(convertX(unit(1/72, "inches"), "bigpts", valueOnly=TRUE) - 1,
                digits=5) == 0)
stopifnot(round(convertX(unit(1/(1157/1238*72.27), "inches"), "dida",
                         valueOnly=TRUE) - 1, digits=5) == 0)
stopifnot(round(convertX(unit(1/(1/12*1157/1238*72.27), "inches"), "cicero",
                         valueOnly=TRUE) - 1, digits=5) == 0)
stopifnot(round(convertX(unit(1/(65536*72.27), "inches"), "scaledpts",
                         valueOnly=TRUE) - 1, digits=5) == 0)

pushViewport(viewport(width=unit(1, "inches"),
                       height=unit(2, "inches"),
                       xscale=c(0, 1),
                       yscale=c(1, 3)))
  ## Location versus dimension
stopifnot(round(convertY(unit(2, "native"), "inches", valueOnly=TRUE) -
                1, digits=5) == 0)
stopifnot(round(convertHeight(unit(2, "native"), "inches", valueOnly=TRUE) -
                2, digits=5) == 0)
  ## From "x" to "y" (the conversion is via "inches")
stopifnot(round(convertUnit(unit(1, "native"), "native",
                            axisFrom="x", axisTo="y", valueOnly=TRUE) -
                2, digits=5) == 0)
  ## Convert several values at once
stopifnot(all(round(convertX(unit(c(0.5, 2.54), c("npc", "cm")),
                             c("inches", "native"), valueOnly=TRUE) -
                    c(0.5, 1), digits=5) == 0))
popViewport()

# packing a frame inside a frame
fg <- frameGrob()
fg <- packGrob(fg, textGrob("Hi there"))

fg2 <- frameGrob()
fg2 <- packGrob(fg2, fg)
fg2 <- packGrob(fg2, rectGrob(), side="bottom")
fg2 <- packGrob(fg2, rectGrob(height=unit(1, "inches")), side="top")

stopifnot(convertHeight(fg2$framevp$layout$heights, "inches",
                        valueOnly=TRUE)[2] < 1)

# Regression tests for:

# A: grob[X|Y|Width|Height]

# B: grid.[circle|lines|segments|rect|polygon|text|xspline|points]

# C: at angles seq(0, 360, 45)[-1]

# D: single AND multiple output 

# In each casem, set up a situation where the answer is (easily) known,
# then compare the numeric answer

test <- function(x, y) {
    on.exit(cat(paste("x =", x, " ; y =", y, "\n")))
    stopifnot(isTRUE(all.equal(x, y)))
}

testX <- function(x1, x2) {
    test(convertX(x1, "inches", valueOnly=TRUE),
         convertX(x2, "inches", valueOnly=TRUE))
}

testY <- function(y1, y2) {
    test(convertY(y1, "inches", valueOnly=TRUE),
         convertY(y2, "inches", valueOnly=TRUE))
}

testWidth <- function(w1, w2) {
    test(convertWidth(w1, "inches", valueOnly=TRUE),
         convertWidth(w2, "inches", valueOnly=TRUE))
}

testHeight <- function(h1, h2) {
    test(convertHeight(h1, "inches", valueOnly=TRUE),
         convertHeight(h2, "inches", valueOnly=TRUE))
}

########
# CIRCLE
########
# A = X;  B = circle; C = ALL; D = BOTH
for (theta in seq(0, 360, 45)[-1]) {
    testX(grobX(circleGrob(r=unit(.5, "inches")), theta),
          unit(.5, "npc") + cos(theta/180*pi)*unit(.5, "inches"))
    # Bounding box is 1" by 1"
    testX(grobX(circleGrob(x=unit(.5, "npc") + unit(c(-.25, .25), "inches"),
                           y=unit(.5, "npc") + unit(c(-.25, .25), "inches"),
                           r=unit(.25, "inches")),
                theta),
          switch(as.character(theta),
                 "360"=, "315"=,
                 "45"=unit(.5, "npc") + unit(.5, "inches"),
                 "180"=, "225"=,
                 "135"=unit(.5, "npc") - unit(.5, "inches"),
                 "90"=,
                 "270"=unit(.5, "npc")))
}

# A = Y;  B = circle; C = ALL; D = BOTH
for (theta in seq(0, 360, 45)[-1]) {
    testY(grobY(circleGrob(r=unit(.5, "inches")), theta),
          unit(.5, "npc") + sin(theta/180*pi)*unit(.5, "inches"))
    # Bounding box is 1" by 1"
    testY(grobY(circleGrob(x=unit(.5, "npc") + unit(c(-.25, .25), "inches"),
                           y=unit(.5, "npc") + unit(c(-.25, .25), "inches"),
                           r=unit(.25, "inches")),
                theta),
          switch(as.character(theta),
                 "90"=, "135"=,
                 "45"=unit(.5, "npc") + unit(.5, "inches"),
                 "270"=, "315"=,
                 "225"=unit(.5, "npc") - unit(.5, "inches"),
                 "180"=,
                 "360"=unit(.5, "npc")))
}

# A = Width;  B = circle; C = ALL; D = BOTH
testWidth(grobWidth(circleGrob(r=unit(.5, "inches"))),
          unit(1, "inches"))
testWidth(grobWidth(circleGrob(x=unit(.5, "npc") +
                               unit(c(-.25, .25), "inches"),
                               y=unit(.5, "npc") +
                               unit(c(-.25, .25), "inches"),
                               r=unit(.25, "inches"))),
          unit(1, "inches"))          
                    
# A = Height;  B = circle; C = ALL; D = BOTH
testHeight(grobHeight(circleGrob(r=unit(.5, "inches"))),
          unit(1, "inches"))
testHeight(grobHeight(circleGrob(x=unit(.5, "npc") +
                                 unit(c(-.25, .25), "inches"),
                                 y=unit(.5, "npc") +
                                 unit(c(-.25, .25), "inches"),
                                 r=unit(.25, "inches"))),
           unit(1, "inches"))          
                    
########
# RECT
########
# A = X;  B = rect; C = ALL; D = BOTH
for (theta in seq(0, 360, 45)[-1]) {
    testX(grobX(rectGrob(width=unit(1, "inches"),
                         height=unit(1, "inches")), theta),
          switch(as.character(theta),
                 "360"=, "315"=,
                 "45"=unit(.5, "npc") + unit(.5, "inches"),
                 "180"=, "225"=,
                 "135"=unit(.5, "npc") - unit(.5, "inches"),
                 "90"=,
                 "270"=unit(.5, "npc")))
    # Bounding box is 1" by 1"
    testX(grobX(rectGrob(x=unit(.5, "npc") + unit(c(-.25, .25), "inches"),
                         y=unit(.5, "npc") + unit(c(-.25, .25), "inches"),
                         width=unit(.5, "inches"),
                         height=unit(.5, "inches")),
                theta),
          switch(as.character(theta),
                 "360"=, "315"=,
                 "45"=unit(.5, "npc") + unit(.5, "inches"),
                 "180"=, "225"=,
                 "135"=unit(.5, "npc") - unit(.5, "inches"),
                 "90"=,
                 "270"=unit(.5, "npc")))
}

# A = Y;  B = rect; C = ALL; D = BOTH
for (theta in seq(0, 360, 45)[-1]) {
    testY(grobY(rectGrob(width=unit(1, "inches"),
                         height=unit(1, "inches")), theta),
          switch(as.character(theta),
                 "90"=, "135"=,
                 "45"=unit(.5, "npc") + unit(.5, "inches"),
                 "270"=, "315"=,
                 "225"=unit(.5, "npc") - unit(.5, "inches"),
                 "180"=,
                 "360"=unit(.5, "npc")))
    # Bounding box is 1" by 1"
    testY(grobY(rectGrob(x=unit(.5, "npc") + unit(c(-.25, .25), "inches"),
                         y=unit(.5, "npc") + unit(c(-.25, .25), "inches"),
                         width=unit(.5, "inches"),
                         height=unit(.5, "inches")),
                theta),
          switch(as.character(theta),
                 "90"=, "135"=,
                 "45"=unit(.5, "npc") + unit(.5, "inches"),
                 "270"=, "315"=,
                 "225"=unit(.5, "npc") - unit(.5, "inches"),
                 "180"=,
                 "360"=unit(.5, "npc")))
}

# A = Width;  B = rect; C = ALL; D = BOTH
testWidth(grobWidth(rectGrob(width=unit(1, "inches"),
                             height=unit(1, "inches"))),
          unit(1, "inches"))
testWidth(grobWidth(rectGrob(x=unit(.5, "npc") +
                             unit(c(-.25, .25), "inches"),
                             y=unit(.5, "npc") +
                             unit(c(-.25, .25), "inches"),
                             width=unit(.5, "inches"),
                             height=unit(.5, "inches"))),
          unit(1, "inches"))          
                    
# A = Height;  B = rect; C = ALL; D = BOTH
testHeight(grobHeight(rectGrob(width=unit(1, "inches"),
                               height=unit(1, "inches"))),
           unit(1, "inches"))
testHeight(grobHeight(rectGrob(x=unit(.5, "npc") +
                               unit(c(-.25, .25), "inches"),
                               y=unit(.5, "npc") +
                               unit(c(-.25, .25), "inches"),
                               width=unit(.5, "inches"),
                               height=unit(.5, "inches"))),
           unit(1, "inches"))          
                    
########
# polygon
# Four locations in a diamond
########
# A = X;  B = polygon; C = ALL; D = BOTH
for (theta in seq(0, 360, 45)[-1]) {
    testX(grobX(polygonGrob(x=unit(.5, "npc") +
                            unit(c(-.5, 0, .5, 0), "inches"),
                            y=unit(.5, "npc") +
                            unit(c(0, -.5, 0, .5), "inches")),
                theta),
          switch(as.character(theta),
                 "45"=,
                 "315"=unit(.5, "npc") + unit(.25, "inches"),
                 "90"=,
                 "270"=unit(.5, "npc"),
                 "135"=,
                 "225"=unit(.5, "npc") - unit(.25, "inches"),
                 "180"=unit(.5, "npc") - unit(.5, "inches"),
                 "360"=unit(.5, "npc") + unit(.5, "inches")))
    # NOTE:  for polygons, even if there are multiple polygons,
    # we still produce edge of hull for ALL points
    testX(grobX(polygonGrob(x=unit(.5, "npc") +
                            unit(c(-.5, -.25, 0, -.25,
                                   0, .25, .5, .25), "inches"),
                            y=unit(.5, "npc") +
                            unit(c(-.25, -.5, -.25, 0,
                                   .25, 0, .25, .5), "inches"),
                            id=rep(1:2, each=4)),
                theta),
          switch(as.character(theta),
                 "45"=unit(.5, "npc") + unit(.375, "inches"),
                 "90"=unit(.5, "npc"),
                 "135"=unit(.5, "npc") - unit(.125, "inches"),
                 "180"=unit(.5, "npc") - unit(.25, "inches"),
                 "225"=unit(.5, "npc") - unit(.375, "inches"),
                 "270"=unit(.5, "npc"),
                 "315"=unit(.5, "npc") + unit(.125, "inches"),
                 "360"=unit(.5, "npc") + unit(.25, "inches")))
}

# A = Y;  B = polygon; C = ALL; D = BOTH
for (theta in seq(0, 360, 45)[-1]) {
    testY(grobY(polygonGrob(x=unit(.5, "npc") +
                            unit(c(-.5, 0, .5, 0), "inches"),
                            y=unit(.5, "npc") +
                            unit(c(0, -.5, 0, .5), "inches")),
                theta),
          switch(as.character(theta),
                 "45"=,
                 "135"=unit(.5, "npc") + unit(.25, "inches"),
                 "90"=unit(.5, "npc") + unit(.5, "inches"),
                 "180"=,
                 "360"=unit(.5, "npc"),
                 "225"=,
                 "315"=unit(.5, "npc") - unit(.25, "inches"),
                 "270"=unit(.5, "npc") - unit(.5, "inches")))
    # NOTE:  for polygons, even if there are multiple polygons,
    # we still produce edge of hull for ALL points
    testY(grobY(polygonGrob(x=unit(.5, "npc") +
                            unit(c(-.5, -.25, 0, -.25,
                                   0, .25, .5, .25), "inches"),
                            y=unit(.5, "npc") +
                            unit(c(-.25, -.5, -.25, 0,
                                   .25, 0, .25, .5), "inches"),
                            id=rep(1:2, each=4)),
                theta),
          switch(as.character(theta),
                 "45"=unit(.5, "npc") + unit(.375, "inches"),
                 "90"=unit(.5, "npc") + unit(.25, "inches"),
                 "135"=unit(.5, "npc") + unit(.125, "inches"),
                 "180"=unit(.5, "npc"),
                 "225"=unit(.5, "npc") - unit(.375, "inches"),
                 "270"=unit(.5, "npc") - unit(.25, "inches"),
                 "315"=unit(.5, "npc") - unit(.125, "inches"),
                 "360"=unit(.5, "npc")))
}

# A = Width;  B = polygon; C = ALL; D = BOTH
testWidth(grobWidth(polygonGrob(x=unit(.5, "npc") +
                            unit(c(-.5, 0, .5, 0), "inches"),
                            y=unit(.5, "npc") +
                            unit(c(0, -.5, 0, .5), "inches"))),
          unit(1, "inches"))
testWidth(grobWidth(polygonGrob(x=unit(.5, "npc") +
                            unit(c(-.5, -.25, 0, -.25,
                                   0, .25, .5, .25), "inches"),
                            y=unit(.5, "npc") +
                            unit(c(-.25, -.5, -.25, 0,
                                   .25, 0, .25, .5), "inches"),
                            id=rep(1:2, each=4))),
          unit(1, "inches"))          
                    
# A = Height;  B = polygon; C = ALL; D = BOTH
testHeight(grobHeight(polygonGrob(x=unit(.5, "npc") +
                            unit(c(-.5, 0, .5, 0), "inches"),
                            y=unit(.5, "npc") +
                            unit(c(0, -.5, 0, .5), "inches"))),
          unit(1, "inches"))
testHeight(grobHeight(polygonGrob(x=unit(.5, "npc") +
                            unit(c(-.5, -.25, 0, -.25,
                                   0, .25, .5, .25), "inches"),
                            y=unit(.5, "npc") +
                            unit(c(-.25, -.5, -.25, 0,
                                   .25, 0, .25, .5), "inches"),
                            id=rep(1:2, each=4))),
           unit(1, "inches"))          
                    
########
# TEXT
########
# A = X;  B = text; C = ALL; D = BOTH
str <- "testcase"
strw <- stringWidth(str)
strh <- stringHeight(str)
for (theta in seq(0, 360, 45)[-1]) {
    testX(grobX(textGrob(str), theta),
          switch(as.character(theta),
                 "360"=unit(.5, "npc") + 0.5*strw,
                 "135"=,
                 "45"=unit(.5, "npc") + 1/tan(theta/180*pi)*0.5*strh,
                 "315"=,
                 "225"=unit(.5, "npc") - 1/tan(theta/180*pi)*0.5*strh,
                 "180"=unit(.5, "npc") - 0.5*strw,
                 "90"=,
                 "270"=unit(.5, "npc")))
    # Bounding box is 1" by 1"
    testX(grobX(textGrob(str,
                         x=unit(.5, "npc") + unit(c(-.5, .5), "inches"),
                         y=unit(.5, "npc") + unit(c(-.5, .5), "inches"),
                         hjust=c(0, 1), vjust=c(0, 1)),
                theta),
          switch(as.character(theta),
                 "360"=, "315"=,
                 "45"=unit(.5, "npc") + unit(.5, "inches"),
                 "180"=, "225"=,
                 "135"=unit(.5, "npc") - unit(.5, "inches"),
                 "90"=,
                 "270"=unit(.5, "npc")))
}

# A = Y;  B = text; C = ALL; D = BOTH
for (theta in seq(0, 360, 45)[-1]) {
    testY(grobY(textGrob(str), theta),
          switch(as.character(theta),
                 "90"=, "135"=,
                 "45"=unit(.5, "npc") + 0.5*strh,
                 "270"=, "315"=,
                 "225"=unit(.5, "npc") - 0.5*strh,
                 "180"=,
                 "360"=unit(.5, "npc")))
    # Bounding box is 1" by 1"
    testY(grobY(textGrob(str,
                         x=unit(.5, "npc") + unit(c(-.5, .5), "inches"),
                         y=unit(.5, "npc") + unit(c(-.5, .5), "inches"),
                         hjust=c(0, 1), vjust=c(0, 1)),
                theta),
          switch(as.character(theta),
                 "90"=, "135"=,
                 "45"=unit(.5, "npc") + unit(.5, "inches"),
                 "270"=, "315"=,
                 "225"=unit(.5, "npc") - unit(.5, "inches"),
                 "180"=,
                 "360"=unit(.5, "npc")))
}

# A = Width;  B = text; C = ALL; D = BOTH
testWidth(grobWidth(textGrob(str)),
          strw)
testWidth(grobWidth(textGrob(str,
                             x=unit(.5, "npc") + unit(c(-.5, .5), "inches"),
                             y=unit(.5, "npc") + unit(c(-.5, .5), "inches"),
                             hjust=c(0, 1), vjust=c(0, 1))),
          unit(1, "inches"))          
                    
# A = Height;  B = text; C = ALL; D = BOTH
testHeight(grobHeight(textGrob(str)),
          strh)
testHeight(grobHeight(textGrob(str,
                               x=unit(.5, "npc") + unit(c(-.5, .5), "inches"),
                               y=unit(.5, "npc") + unit(c(-.5, .5), "inches"),
                               hjust=c(0, 1), vjust=c(0, 1))),
           unit(1, "inches"))

# Determining unit lengths
stopifnot(length(unit.c(unit(1, "npc") + unit(1, "cm"), unit(2, "cm"))) == 2)
stopifnot(length(unit.c(unit(1, "npc") + unit(1, "cm"), unit(2:4, "cm"))) == 4)
stopifnot(length(unit.c(unit(1:3, "npc") + unit(1, "cm"), unit(2:4, "cm"))) == 6)
library(grid)

# Test hole in DL (deleted grob)
grid.lines(name="foo")
grid.lines(x=1:0, name="foo2")
grid.ls()
grid.remove("foo")
grid.ls()
# New blank page
grid.newpage()


#######
# GROBS
#######
# Plain grob
grid.ls(grob(name="g1"))
# gList
grid.ls(gList(grob(name="gl1"), grob(name="gl2")))
# gTree
grid.ls(gTree(children=gList(grob(name="child")),
              name="parent"))
grid.ls(gTree(children=gList(grob(name="child1"), grob(name="child1")),
              name="parent"))

###########
# VIEWPORTS
###########
# Plain viewport
grid.ls(viewport(name="vp1"),
        view=TRUE)
# vpList
grid.ls(vpList(viewport(name="vpl1")),
        view=TRUE)
grid.ls(vpList(viewport(name="vpl1"), viewport(name="vpl2")),
        view=TRUE)
grid.ls(vpList(viewport(name="vpl1"), viewport(name="vpl2"),
               viewport(name="vpl3")),
        view=TRUE)
# vpStack
grid.ls(vpStack(viewport(name="vps1"), viewport(name="vps2")),
        view=TRUE)
grid.ls(vpStack(viewport(name="vps1"), viewport(name="vps2"),
                viewport(name="vps3")),
        view=TRUE)
# vpTrees
grid.ls(vpTree(viewport(name="parentvp"), vpList(viewport(name="childvp"))),
        view=TRUE)
grid.ls(vpTree(viewport(name="parentvp"),
               vpList(viewport(name="cvp1"), viewport(name="cvp2"))),
        view=TRUE)
# vpPaths
grid.ls(vpPath("A"),
        view=TRUE)
grid.ls(vpPath("A", "B"),
        view=TRUE)
grid.ls(vpPath("A", "B", "C"),
        view=TRUE)

##########
# MIXTURES
##########
# grob with vp viewport
g1 <- grob(vp=viewport(name="gvp"), name="g1")
grid.ls(g1, view=TRUE, full=TRUE)
grid.ls(g1, view=TRUE, full=TRUE, grob=FALSE)
# grob with vp vpList
grid.ls(grob(vp=vpList(viewport(name="vpl")), name="g1"),
        view=TRUE, full=TRUE)
grid.ls(grob(vp=vpList(viewport(name="vpl1"), viewport(name="vpl2")),
             name="g1"),
        view=TRUE, full=TRUE)
# grob with vp vpStack
grid.ls(grob(vp=vpStack(viewport(name="vps1"), viewport(name="vps2")),
             name="g1"),
        view=TRUE, full=TRUE)
grid.ls(grob(vp=vpStack(viewport(name="vps1"), viewport(name="vps2"),
               viewport(name="vps3")),
             name="g1"),
        view=TRUE)
# grob with vp vpTree
grid.ls(grob(vp=vpTree(viewport(name="parentvp"),
               vpList(viewport(name="cvp"))),
             name="g1"),
        view=TRUE, full=TRUE)
grid.ls(grob(vp=vpTree(viewport(name="parentvp"),
               vpList(viewport(name="cvp1"), viewport(name="cvp2"))),
             name="g1"),
        view=TRUE, full=TRUE)
# gTree with vp viewport
# and child grob with vp viewport
grid.ls(gTree(children=gList(grob(vp=viewport(name="childvp"), name="cg1"),
                grob(name="cg2")),
              name="parent",
              vp=viewport(name="parentvp")),
        view=TRUE)
# gTree with childrenvp viewport
grid.ls(gTree(childrenvp=viewport(name="vp"), name="gtree"),
        view=TRUE, full=TRUE)
grid.ls(gTree(childrenvp=viewport(name="vp"), name="gtree"),
        view=TRUE, full=TRUE, grob=FALSE)
grid.ls(gTree(children=gList(grob(name="child")),
              name="parent",
              childrenvp=viewport(name="vp")),
        view=TRUE, full=TRUE)
grid.ls(gTree(children=gList(grob(name="child1"), grob(name="child2")),
              name="parent",
              childrenvp=viewport(name="vp")),
        view=TRUE, full=TRUE)
grid.ls(gTree(children=gList(grob(name="child")),
              childrenvp=viewport(name="vp"),
              name="parent"), 
        view=TRUE, full=TRUE)
grid.ls(gTree(children=gList(grob(name="child1"), grob(name="child2")),
              name="parent",
              childrenvp=viewport(name="vp")),
        view=TRUE, full=TRUE, grob=FALSE)
# gTree with childrenvp vpTree
grid.ls(gTree(childrenvp=vpTree(parent=viewport(name="vp1"),
                children=vpList(viewport(name="vp2"))),
              name="gtree"),
        view=TRUE, full=TRUE)
grid.ls(gTree(children=gList(grob(name="child")),
              name="parent",
              childrenvp=vpTree(parent=viewport(name="vp1"),
                children=vpList(viewport(name="vp2")))),
        view=TRUE, full=TRUE)
# gTree with childrenvp vpTree
# and child grob with vp vpPath
# A gTree, called "parent", with childrenvp vpTree (vp2 within vp1)
# and child grob, called "child", with vp vpPath (down to vp2)
sampleGTree <- gTree(name="parent",
                     children=gList(grob(name="child", vp="vp1::vp2")),
                     childrenvp=vpTree(parent=viewport(name="vp1"),
                                       children=vpList(viewport(name="vp2"))))
grid.ls(sampleGTree)
# Show viewports too
grid.ls(sampleGTree, view=TRUE)
# Only show viewports
grid.ls(sampleGTree, view=TRUE, grob=FALSE)
# Alternate displays
# nested listing, custom indent
grid.ls(sampleGTree, view=TRUE, print=nestedListing, gindent="--")
# path listing
grid.ls(sampleGTree, view=TRUE, print=pathListing)
# path listing, without grobs aligned
grid.ls(sampleGTree, view=TRUE, print=pathListing, gAlign=FALSE)
# grob path listing 
grid.ls(sampleGTree, view=TRUE, print=grobPathListing)
# path listing, grobs only
grid.ls(sampleGTree, print=pathListing)
# path listing, viewports only
grid.ls(sampleGTree, view=TRUE, grob=FALSE, print=pathListing)
# raw flat listing
str(grid.ls(sampleGTree, view=TRUE, print=FALSE))




R Under development (unstable) (2022-03-19 r81942) -- "Unsuffered Consequences"
Copyright (C) 2022 The R Foundation for Statistical Computing
Platform: x86_64-pc-linux-gnu (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> library(grid)
> 
> # Test hole in DL (deleted grob)
> grid.lines(name="foo")
> grid.lines(x=1:0, name="foo2")
> grid.ls()
foo
foo2
> grid.remove("foo")
> grid.ls()
foo2
> # New blank page
> grid.newpage()
> 
> 
> #######
> # GROBS
> #######
> # Plain grob
> grid.ls(grob(name="g1"))
g1
> # gList
> grid.ls(gList(grob(name="gl1"), grob(name="gl2")))
gl1
gl2
> # gTree
> grid.ls(gTree(children=gList(grob(name="child")),
+               name="parent"))
parent
  child
> grid.ls(gTree(children=gList(grob(name="child1"), grob(name="child1")),
+               name="parent"))
parent
  child1
  child1
> 
> ###########
> # VIEWPORTS
> ###########
> # Plain viewport
> grid.ls(viewport(name="vp1"),
+         view=TRUE)
vp1
> # vpList
> grid.ls(vpList(viewport(name="vpl1")),
+         view=TRUE)
vpl1
> grid.ls(vpList(viewport(name="vpl1"), viewport(name="vpl2")),
+         view=TRUE)
vpl1
  1
vpl2
> grid.ls(vpList(viewport(name="vpl1"), viewport(name="vpl2"),
+                viewport(name="vpl3")),
+         view=TRUE)
vpl1
  1
vpl2
  1
vpl3
> # vpStack
> grid.ls(vpStack(viewport(name="vps1"), viewport(name="vps2")),
+         view=TRUE)
vps1
  vps2
> grid.ls(vpStack(viewport(name="vps1"), viewport(name="vps2"),
+                 viewport(name="vps3")),
+         view=TRUE)
vps1
  vps2
    vps3
> # vpTrees
> grid.ls(vpTree(viewport(name="parentvp"), vpList(viewport(name="childvp"))),
+         view=TRUE)
parentvp
  childvp
> grid.ls(vpTree(viewport(name="parentvp"),
+                vpList(viewport(name="cvp1"), viewport(name="cvp2"))),
+         view=TRUE)
parentvp
  cvp1
    1
  cvp2
> # vpPaths
> grid.ls(vpPath("A"),
+         view=TRUE)
A
> grid.ls(vpPath("A", "B"),
+         view=TRUE)
A
  B
> grid.ls(vpPath("A", "B", "C"),
+         view=TRUE)
A
  B
    C
> 
> ##########
> # MIXTURES
> ##########
> # grob with vp viewport
> g1 <- grob(vp=viewport(name="gvp"), name="g1")
> grid.ls(g1, view=TRUE, full=TRUE)
viewport[gvp]
  grob[g1]
  upViewport[1]
> grid.ls(g1, view=TRUE, full=TRUE, grob=FALSE)
viewport[gvp]
  upViewport[1]
> # grob with vp vpList
> grid.ls(grob(vp=vpList(viewport(name="vpl")), name="g1"),
+         view=TRUE, full=TRUE)
viewport[vpl]
  grob[g1]
  upViewport[1]
> grid.ls(grob(vp=vpList(viewport(name="vpl1"), viewport(name="vpl2")),
+              name="g1"),
+         view=TRUE, full=TRUE)
viewport[vpl1]
  upViewport[1]
viewport[vpl2]
  grob[g1]
  upViewport[1]
> # grob with vp vpStack
> grid.ls(grob(vp=vpStack(viewport(name="vps1"), viewport(name="vps2")),
+              name="g1"),
+         view=TRUE, full=TRUE)
viewport[vps1]
  viewport[vps2]
    grob[g1]
    upViewport[2]
> grid.ls(grob(vp=vpStack(viewport(name="vps1"), viewport(name="vps2"),
+                viewport(name="vps3")),
+              name="g1"),
+         view=TRUE)
vps1
  vps2
    vps3
      g1
      3
> # grob with vp vpTree
> grid.ls(grob(vp=vpTree(viewport(name="parentvp"),
+                vpList(viewport(name="cvp"))),
+              name="g1"),
+         view=TRUE, full=TRUE)
viewport[parentvp]
  viewport[cvp]
    grob[g1]
    upViewport[2]
> grid.ls(grob(vp=vpTree(viewport(name="parentvp"),
+                vpList(viewport(name="cvp1"), viewport(name="cvp2"))),
+              name="g1"),
+         view=TRUE, full=TRUE)
viewport[parentvp]
  viewport[cvp1]
    upViewport[1]
  viewport[cvp2]
    grob[g1]
    upViewport[2]
> # gTree with vp viewport
> # and child grob with vp viewport
> grid.ls(gTree(children=gList(grob(vp=viewport(name="childvp"), name="cg1"),
+                 grob(name="cg2")),
+               name="parent",
+               vp=viewport(name="parentvp")),
+         view=TRUE)
parentvp
  parent
    childvp
      cg1
      1
    cg2
  1
> # gTree with childrenvp viewport
> grid.ls(gTree(childrenvp=viewport(name="vp"), name="gtree"),
+         view=TRUE, full=TRUE)
gTree[gtree]
  viewport[vp]
    upViewport[1]
> grid.ls(gTree(childrenvp=viewport(name="vp"), name="gtree"),
+         view=TRUE, full=TRUE, grob=FALSE)
viewport[vp]
  upViewport[1]
> grid.ls(gTree(children=gList(grob(name="child")),
+               name="parent",
+               childrenvp=viewport(name="vp")),
+         view=TRUE, full=TRUE)
gTree[parent]
  viewport[vp]
    upViewport[1]
  grob[child]
> grid.ls(gTree(children=gList(grob(name="child1"), grob(name="child2")),
+               name="parent",
+               childrenvp=viewport(name="vp")),
+         view=TRUE, full=TRUE)
gTree[parent]
  viewport[vp]
    upViewport[1]
  grob[child1]
  grob[child2]
> grid.ls(gTree(children=gList(grob(name="child")),
+               childrenvp=viewport(name="vp"),
+               name="parent"), 
+         view=TRUE, full=TRUE)
gTree[parent]
  viewport[vp]
    upViewport[1]
  grob[child]
> grid.ls(gTree(children=gList(grob(name="child1"), grob(name="child2")),
+               name="parent",
+               childrenvp=viewport(name="vp")),
+         view=TRUE, full=TRUE, grob=FALSE)
viewport[vp]
  upViewport[1]
> # gTree with childrenvp vpTree
> grid.ls(gTree(childrenvp=vpTree(parent=viewport(name="vp1"),
+                 children=vpList(viewport(name="vp2"))),
+               name="gtree"),
+         view=TRUE, full=TRUE)
gTree[gtree]
  viewport[vp1]
    viewport[vp2]
      upViewport[2]
> grid.ls(gTree(children=gList(grob(name="child")),
+               name="parent",
+               childrenvp=vpTree(parent=viewport(name="vp1"),
+                 children=vpList(viewport(name="vp2")))),
+         view=TRUE, full=TRUE)
gTree[parent]
  viewport[vp1]
    viewport[vp2]
      upViewport[2]
  grob[child]
> # gTree with childrenvp vpTree
> # and child grob with vp vpPath
> # A gTree, called "parent", with childrenvp vpTree (vp2 within vp1)
> # and child grob, called "child", with vp vpPath (down to vp2)
> sampleGTree <- gTree(name="parent",
+                      children=gList(grob(name="child", vp="vp1::vp2")),
+                      childrenvp=vpTree(parent=viewport(name="vp1"),
+                                        children=vpList(viewport(name="vp2"))))
> grid.ls(sampleGTree)
parent
  child
> # Show viewports too
> grid.ls(sampleGTree, view=TRUE)
parent
  vp1
    vp2
      2
  vp1
    vp2
      child
      2
> # Only show viewports
> grid.ls(sampleGTree, view=TRUE, grob=FALSE)
vp1
  vp2
    2
vp1
  vp2
    2
> # Alternate displays
> # nested listing, custom indent
> grid.ls(sampleGTree, view=TRUE, print=nestedListing, gindent="--")
parent
--vp1
----vp2
------2
--vp1
----vp2
------child
------2
> # path listing
> grid.ls(sampleGTree, view=TRUE, print=pathListing)
            | parent
vp1
vp1::vp2
vp1::vp2::2
vp1
vp1::vp2
vp1::vp2    | parent::child
vp1::vp2::2
> # path listing, without grobs aligned
> grid.ls(sampleGTree, view=TRUE, print=pathListing, gAlign=FALSE)
 | parent
vp1
vp1::vp2
vp1::vp2::2
vp1
vp1::vp2
vp1::vp2 | parent::child
vp1::vp2::2
> # grob path listing 
> grid.ls(sampleGTree, view=TRUE, print=grobPathListing)
         | parent
vp1::vp2 | parent::child
> # path listing, grobs only
> grid.ls(sampleGTree, print=pathListing)
 | parent
 | parent::child
> # path listing, viewports only
> grid.ls(sampleGTree, view=TRUE, grob=FALSE, print=pathListing)
vp1
vp1::vp2
vp1::vp2::2
vp1
vp1::vp2
vp1::vp2::2
> # raw flat listing
> str(grid.ls(sampleGTree, view=TRUE, print=FALSE))
List of 6
 $ name   : chr [1:8] "parent" "vp1" "vp2" "2" ...
 $ gDepth : num [1:8] 0 1 1 1 1 1 1 1
 $ vpDepth: num [1:8] 0 0 1 2 0 1 2 2
 $ gPath  : chr [1:8] "" "parent" "parent" "parent" ...
 $ vpPath : chr [1:8] "" "" "vp1" "vp1::vp2" ...
 $ type   : chr [1:8] "gTreeListing" "vpListing" "vpListing" "vpUpListing" ...
 - attr(*, "class")= chr "flatGridListing"
> 
> 
> 
> 
> proc.time()
   user  system elapsed 
  0.310   0.053   0.349 

library(grid)

unitCheck <- function(u1, u2) {
    stopifnot(identical(as.character(u1), as.character(u2)))
}

# Mixture of rep() arguments based on example(rep) examples

# simple tests
simpleUnit <- unit(1:4, "npc")

unitCheck(rep(simpleUnit, 2),
          unit(rep(1:4, 2), "npc"))
unitCheck(rep(simpleUnit, each=2),
          unit(rep(1:4, each=2), "npc"))
unitCheck(rep(simpleUnit, c(2, 1, 2, 1)),
          unit(rep(1:4, c(2, 1, 2, 1)), "npc"))
unitCheck(rep(simpleUnit, each=2, length.out=4),
          unit(rep(1:4, each=2, length.out=4), "npc"))
unitCheck(rep(simpleUnit, each=2, length.out=10),
          unit(rep(1:4, each=2, length.out=10), "npc"))
unitCheck(rep(simpleUnit, each=2, times=3),
          unit(rep(1:4, each=2, times=3), "npc"))

simpleUnitMixed <- unit(1:4, c("npc", "cm"))

unitCheck(rep(simpleUnitMixed, 2),
          unit(rep(1:4, 2), c("npc", "cm")))
unitCheck(rep(simpleUnitMixed, each=2),
          unit(rep(1:4, each=2),
               rep(c("npc", "cm"), each=2)))
unitCheck(rep(simpleUnitMixed, c(2, 1, 2, 1)),
          unit(rep(1:4, c(2, 1, 2, 1)),
               rep(c("npc", "cm"), c(2, 1))))
unitCheck(rep(simpleUnitMixed, each=2, length.out=4),
          unit(rep(1:4, each=2, length.out=4),
               rep(c("npc", "cm"), each=2, length.out=4)))
unitCheck(rep(simpleUnitMixed, each=2, length.out=10),
          unit(rep(1:4, each=2, length.out=10),
               rep(c("npc", "cm"), each=2, length.out=10)))
unitCheck(rep(simpleUnitMixed, each=2, times=3),
          unit(rep(1:4, each=2, times=3),
               rep(c("npc", "cm"), each=2, times=3)))

units <- c("npc", "inch", "strwidth", "cm")
dataL <- list(NULL, NULL, "test", NULL)
unitWithData <- unit(1:4, units, data=dataL)
unitCheck(rep(unitWithData, 2),
          unit(rep(1:4, 2),
               rep(units, 2),
               rep(dataL, 2)))
unitCheck(rep(unitWithData, each=2),
          unit(rep(1:4, each=2),
               rep(units, each=2),
               rep(dataL, each=2)))
unitCheck(rep(unitWithData, c(2, 1, 2, 1)),
          unit(rep(1:4, c(2, 1, 2, 1)),
               rep(units, c(2, 1, 2, 1)),
               rep(dataL, c(2, 1, 2, 1))))
unitCheck(rep(unitWithData, each=2, length.out=4),
          unit(rep(1:4, each=2, length.out=4),
               rep(units, each=2, length.out=4),
               rep(dataL, each=2, length.out=4)))
unitCheck(rep(unitWithData, each=2, length.out=10),
          unit(rep(1:4, each=2, length.out=10),
               rep(units, each=2, length.out=10),
               rep(dataL, each=2, length.out=10)))
unitCheck(rep(unitWithData, each=2, times=3),
          unit(rep(1:4, each=2, times=3),
               rep(units, each=2, times=3),
               rep(dataL, each=2, times=3)))

# unit.arithmetic
unitArith <- unit(1, "npc") + unit(1:2, "inch")

unitCheck(rep(unitArith, 2),
          unit(1, "npc") + unit(rep(1:2, 2), "inch"))
unitCheck(rep(unitArith, each=2),
          unit(1, "npc") + unit(rep(1:2, each=2), "inch"))
unitCheck(rep(unitArith, c(2, 1)),
          unit(1, "npc") + unit(rep(1:2, c(2 ,1)), "inch"))
unitCheck(rep(unitArith, each=2, length.out=3),
          unit(1, "npc") + unit(rep(1:2, each=2, length.out=3), "inch"))
unitCheck(rep(unitArith, each=2, length.out=5),
          unit(1, "npc") + unit(rep(1:2, each=2, length.out=5), "inch"))
unitCheck(rep(unitArith, each=2, times=3),
          unit(1, "npc") + unit(rep(1:2, each=2, times=3), "inch"))

# unit.list
arg1 <- unit(1, "npc") + unit(1:2, "inch")
arg2 <- unit(3, "cm")
unitList <- unit.c(arg1, arg2)

unitCheck(rep(unitList, 2),
          unit.c(arg1, arg2, arg1, arg2))
unitCheck(rep(unitList, each=2),
          unit.c(rep(arg1, each=2), rep(arg2, 2)))
unitCheck(rep(unitList, c(2, 1, 2)),
          unit.c(rep(arg1, c(2, 1)), rep(arg2, 2)))
unitCheck(rep(unitList, each=2, length.out=4),
          rep(arg1, each=2))
unitCheck(rep(unitList, each=2, length.out=8),
          unit.c(rep(arg1, each=2), rep(arg2, 2), rep(arg1, each=2, length.out=2)))
unitCheck(rep(unitList, each=2, times=3),
          unit.c(rep(arg1, each=2), rep(arg2, 2),
                 rep(arg1, each=2), rep(arg2, 2),
                 rep(arg1, each=2), rep(arg2, 2)))

# Special test
# rep() unit.arithmetic where operands have different lengths
uaDiffLength <- unit(1:2, "npc") + unit(1:3, "npc")
uaSameLength <- unit(c(1, 2, 1), "npc") + unit(1:3, "npc")
unitCheck(rep(uaDiffLength, 2),
          rep(uaSameLength, 2))


# Bug report PR#14170 test

x <- unit.c(unit(5,"mm"),unit(3,"npc"))
rep(x, 2)
rep(x, each=2)
rep(x, c(2, 2))

x <- x - unit(1,"mm")
rep(x, 2)
rep(x, each=2)
rep(x, c(2, 2))


## grid::unit.pmax, PR#14443
x <- unit(1, "cm")
stopifnot(length(unit.pmax(x)) == 1L, length(unit.pmin(x)) == 1L)
## was 3 in R <= 2.12.0

# Unit subassignment
a <- unit(1:3, c("cm", "in", "npc"))
b <- a + unit(1, "npc")
a[2] <- unit(2,"pt")
b[2] <- unit(2,"npc")

unitCheck(a, unit(1:3, c("cm", "pt", "npc")))
unitCheck(b, unit.c(unit(1, "cm") + unit(1, "npc"),
                    unit(2, "npc"),
                    unit(3, "npc") + unit(1, "npc")))

c <- unit(1:10, "mm")

# assign to range
c[5:9] <- unit(9:5, "pt")
unitCheck(c, unit(c(1:4, 9:5, 10),
                  c(rep("mm", 4), rep("pt", 5), "mm")))

# recycle
c[2:3] <- unit(1, "in") + unit(.5, "npc")
unitCheck(c, unit.c(unit(1, "mm"),
                    rep(unit(1, "in") + unit(.5, "npc"), 2),
                    unit(4, "mm"),
                    unit(9:5, "pt"),
                    unit(10, "mm")))

# recycle non-multiple
c[6:8] <- stringWidth(c("a", "b"))
unitCheck(c, unit.c(unit(1, "mm"),
                    rep(unit(1, "in") + unit(.5, "npc"), 2),
                    unit(4, "mm"),
                    unit(9, "pt"),
                    stringWidth(c("a", "b", "a")),
                    unit(5, "pt"),
                    unit(10, "mm")))

## Bug fix for sum() of complex units
u1 = 0.4*sum(unit(1, "inch"), unit(1, "mm"))
u2 = 0.1*sum(unit(1, "inch"), unit(1, "mm"))
unitCheck(u1 + u2,
          0.5*sum(unit(1, "inch"), unit(1, "mm")))
unitCheck(sum(u1, u2),
          sum(unit(c(0.4, .4, .1, .1), c("in", "mm", "in", "mm"))))
unitCheck(sum(unit.c(u1, u2)),
          sum(unit(c(0.4, .4, .1, .1), c("in", "mm", "in", "mm"))))
