@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/library/grid/tests/glyphs.R

@@ -0,0 +1,325 @@
+
+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)

package/dist/vfs/usr/lib/R/library/grid/tests/grep.R

@@ -0,0 +1,49 @@
+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")

package/dist/vfs/usr/lib/R/library/grid/tests/grep.Rout.save

@@ -0,0 +1,100 @@
+
+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