355 lines
13 KiB
R
355 lines
13 KiB
R
|
|
||
|
|
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
|
||
|
|
if (!inherits(info, "RGlyphInfo")) {
|
||
|
|
## List of infos
|
||
|
|
n <- length(info)
|
||
|
|
for (i in 1:n) {
|
||
|
|
vp <- viewport(y=i/(n+1))
|
||
|
|
pushViewport(vp)
|
||
|
|
grid.glyph(info[[i]], ...)
|
||
|
|
popViewport()
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
grid.glyph(info, ...)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
testGlyphGrob <- function(info, ...) {
|
||
|
|
testGlyphInfo[[length(testGlyphInfo) + 1]] <<- info
|
||
|
|
if (!inherits(info, "RGlyphInfo")) {
|
||
|
|
## List of infos
|
||
|
|
n <- length(info)
|
||
|
|
vps <- lapply(1:n, function(i) viewport(y=i/(n+1)))
|
||
|
|
do.call(grobTree,
|
||
|
|
mapply(function(x, vp) {
|
||
|
|
glyphGrob(x, ..., vp=vp)
|
||
|
|
},
|
||
|
|
info, vps))
|
||
|
|
} else {
|
||
|
|
glyphGrob(info, ...)
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
## 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)
|
||
|
|
|
||
|
|
## Two glyphInfo's in same image
|
||
|
|
## (particularly relevant for embedding fonts in pdf() output)
|
||
|
|
grid.newpage()
|
||
|
|
testGlyph(list(Montserrat, Roboto))
|
||
|
|
HersheyLabel("Montserrat glyphs plus Roboto glyphs
|
||
|
|
in separate glyph grobs")
|