The R Project SVN
R
(root)/trunk/src/library/grid/tests/glyphs.R – Rev 86937
Rev 84820 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
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 likeRobotoFont <- 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' bughAnchor = 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]] <<- infoif (!inherits(info, "RGlyphInfo")) {## List of infosn <- 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]] <<- infoif (!inherits(info, "RGlyphInfo")) {## List of infosn <- 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, ...)}}## glyphsgrid.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 valuesmissingIDinfo <- MontserratInfomissingIDinfo$id[1] <- NAmissingID <- 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 <- MontserratInfomissingXinfo$x[2] <- NAmissingX <- 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 <- MontserratInfomissingYinfo$y[3] <- NAmissingY <- 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 <- Robotonofile$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" objectmissingfile <- Robotomissingfile$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 colourcolourInfo <- MontserratInfocolourInfo$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 OKmissingColourInfo <- colourInfomissingColourInfo$col[4] <- NAmissingColour <- 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 alignmentgrid.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:### viewport rotationgrid.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 rotationrotationInfo <- MontserratInforotationInfo$rot <- rep(180, 6)rotation <- do.call(glyphInfo, rotationInfo)grid.newpage()grid.segments(0,.5,1,.5, gp=gpar(col="grey"))testGlyph(rotation)HersheyLabel("glyphs with rotation (180 degrees)", y=.2)# Different rotation for each glyph works as well:sepRotInfo <- MontserratInfosepRotInfo$id <- rep(499, 6)sepRotInfo$rot <- seq(from = 0, to = 90, length = 6)sepRot <- do.call(glyphInfo, sepRotInfo)grid.newpage()grid.segments(0,.5,1,.5, gp=gpar(col="grey"))testGlyph(sepRot)HersheyLabel("glyphs with different rotations", y=.2)# Rotation of glyphs inside a rotated viewport works: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(sepRot)popViewport()HersheyLabel("rotated glyphs inside rotated viewport", y=.2)## glyph x/y/width/heightgrid.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 patterngrid.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 pathgrid.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 maskgrid.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 groupgrid.newpage()grid.group(testGlyphGrob(Montserrat), "xor", segmentsGrob(gp=gpar(lwd=20)))HersheyLabel("glyphs in group (xor line)", y=.2)## glyphs in (transformed) groupgrid.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 pathgrid.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 glyphsgrid.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 glyphsin separate glyph grobs")