gridGraphics/0000755000176200001440000000000013765502603012667 5ustar liggesusersgridGraphics/NAMESPACE0000654000176200001440000000113313301414127014072 0ustar liggesusers importFrom("grDevices", "axisTicks", "col2rgb", "contourLines", "dev.control", "dev.cur", "dev.list", "dev.new", "dev.off", "dev.set", "palette", "pdf", "png", "recordPlot", "replayPlot", "rgb", "trans3d") importFrom("graphics", "axTicks", "par", "plot.new") import("grid") export("grid.echo", "echoGrob") # For test code in ./tests/ export("plotdiffInit") export("plotdiff") export("plotdiffResult") S3method("grid.echo", "default") S3method("grid.echo", "recordedplot") S3method("grid.echo", "function") S3method("makeContent", "echogrob") gridGraphics/README.md0000654000176200001440000000010412434731555014144 0ustar liggesusersgridgraphics ============ Redraw base graphics using grid graphics gridGraphics/man/0000755000176200001440000000000013764276260013450 5ustar liggesusersgridGraphics/man/grid.echo.Rd0000654000176200001440000000436713323234017015575 0ustar liggesusers\name{grid.echo} \alias{grid.echo} \alias{echoGrob} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Echo \pkg{graphics} output using \pkg{grid} graphics } \description{ Convert a scene that was drawn using the \pkg{graphics} package to an identical scene drawn with the \pkg{grid} package. } \usage{ grid.echo(x = NULL, newpage = TRUE, prefix = NULL, device = offscreen) echoGrob(x = NULL, prefix = NULL, device = offscreen, name = NULL) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ Either \code{NULL}, a recorded plot, or a function. If \code{NULL}, the current graphics device is echoed. } \item{newpage}{ A logical value indicating whether to start a new page. If \code{FALSE}, echoing occurs in the current \pkg{grid} viewport. } \item{prefix}{ A character value used as a prefix for all grob and viewport names. The default prefix is \code{"graphics"}. } \item{device}{ A function that opens a graphics device for \code{grid.echo()} to work on. By default this is an off-screen, in-memory device based on the \code{pdf} device. This default device may not be satisfactory when using custom fonts. } \item{name}{ A character identifier. } } \details{ If the first argument is a function, it must be a function with zero arguments. If the function needs access to non-global data, use a closure. The function should not call functions that create or destroy graphics devices, or change the current graphics device. } \value{ The \code{echoGrob} function returns a grob that will echo \code{x} when it is drawn. The \code{grid.echo} function is called for its side-effect of drawing on the current graphics device. } \author{ Paul Murrell } \examples{ \dontrun{ # Echo existing drawing plot(1) grid.echo() # Echo result of call to a plotting function plotfun <- function() plot(1:10) grid.echo(plotfun) # Echo result of a plotting function (anonymous) into current viewport grid.newpage() pushViewport(viewport(x=0, width=.5, just="left")) grid.rect(gp=gpar(col=NA, fill="grey")) grid.echo(function() plot(1:10), newpage=FALSE) } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ dplot } gridGraphics/man/plotdiff.Rd0000654000176200001440000000575212556251523015551 0ustar liggesusers\name{plotdiff} \alias{plotdiff} \alias{plotdiffInit} \alias{plotdiffResult} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Test for identical output from \code{grid.echo()} } \description{ Functions to generate a scene using the \pkg{graphics} package, reproduce the scene using \code{grid.echo()}, test whether the two results are identical, and report on any differences. } \usage{ plotdiff(expr, label, dev = "pdf", antialias = TRUE, density = 100, width = 7, height = 7) plotdiffInit() plotdiffResult(warn = FALSE) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{expr}{ An expression that draws something using the \pkg{graphics} package. } \item{label}{ A character value that is used to label files generated during testing. } \item{dev}{ The graphics device used for drawing and echoing. Currently can only be either \code{"pdf"} or \code{"png"}. } \item{antialias}{ A logical value indicating whether to perform antialiasing when converting from PDF to PNG. } \item{density}{ A numeric value indicating the resolution (dpi) to use when converting from PDF to PNG. } \item{width, height}{ Numeric values indicating the size of the device to test on. } \item{warn}{ A logical value indicating whether non-identical output should produce a warning or an error. } } \details{ In default usage, \code{plotdiff()} is used to generate two PDF files, one using the original expression and the other from a call to \code{grid.echo()}. The PDF files are then converted to PNG files and the PNG files are compared (using ImageMagick). If there are any differences, the comparison generates a further PNG file that shows the differences. All files are currently generated in the current working directory. Text messages are also generated by \code{plotdiff()} whenever a difference is found, but those messages are stored up rather than printed immediately. The \code{plotdiffResult()} function prints out all messages since the last call to \code{plotdiffInit()}. Standard usage involves calling \code{plotdiffInit()}, followed by one or more \code{plotdiff()} calls, then finally a call to \code{plotdiffResult()}. Examples of the usage of these functions are provided in the numerous test scripts in the \code{test-scripts} directory of the package. } \value{ All functions are run for their side effects. In the case of \code{plotdiff()}, the generation of PDF and PNG files and the accumulation of differences about messages. In the case of \code{plotdiffResult()}, a print out of the accumulated messages, plus possibly either an error or warning. } %% ~Make other sections like Warning with \section{Warning }{....} ~ \author{ Paul Murrell } \seealso{ \code{\link{grid.echo}} } \examples{ \dontrun{ plotdiff(expression(plot(1)), "plot") } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ dplot } gridGraphics/DESCRIPTION0000654000176200001440000000201713765502603014376 0ustar liggesusersPackage: gridGraphics Title: Redraw Base Graphics Using 'grid' Graphics Version: 0.5-1 Authors@R: c(person("Paul", "Murrell", role = c("cre", "aut"), email = "paul@stat.auckland.ac.nz"), person("Zhijian", "Wen", role = "aut", email = "jwen246@aucklanduni.ac.nz")) Description: Functions to convert a page of plots drawn with the 'graphics' package into identical output drawn with the 'grid' package. The result looks like the original 'graphics'-based plot, but consists of 'grid' grobs and viewports that can then be manipulated with 'grid' functions (e.g., edit grobs and revisit viewports). Depends: grid, graphics Imports: grDevices Suggests: magick (>= 1.3), pdftools (>= 1.6) License: GPL (>= 2) URL: https://github.com/pmur002/gridgraphics NeedsCompilation: no Packaged: 2020-12-10 01:41:04 UTC; pmur002 Author: Paul Murrell [cre, aut], Zhijian Wen [aut] Maintainer: Paul Murrell Repository: CRAN Date/Publication: 2020-12-13 21:20:03 UTC gridGraphics/tests/0000755000176200001440000000000013764276260014037 5ustar liggesusersgridGraphics/tests/aardvark.Rin0000654000176200001440000000520413115376323016275 0ustar liggesusers tests <- unlist(strsplit(Sys.getenv("R_GRIDGRAPHICS_TESTS"), ",")) testfiles <- character(0) # Will look for test targets in test-scripts/ # e.g., 'R_GRIDGRAPHICS_TESTS=abline' will copy "test-abline.R" test script files <- list.files(system.file("test-scripts", package="gridGraphics")) for (i in tests) { matches <- gsub("^test-|[.]R$", "", files) %in% tests if (any(matches)) { testfiles <- c(testfiles, files[matches]) } } # A set of tests for the graphics package # Core C-level entry points graphics.pkg.core <- c("test-abline.R", "test-arrows.R", "test-axis.R", "test-box.R", "test-clip.R", "test-contour.R", "test-image.R", "test-layout.R", "test-mtext.R", "test-palette.R", "test-par.R", "test-path.R", "test-plot.window.R", "test-polygon.R", "test-rect.R", "test-raster.R", "test-segments.R", "test-text.R", "test-title.R", "test-xspline.R") # Higher-level plot functions graphics.pkg <- c("test-assocplot.R", "test-axis.POSIXct.R", "test-axTicks.R", "test-barplot.R", "test-boxplot.matrix.R", "test-boxplot.R", "test-bxp.R", "test-cdplot.R", "test-coplot.R", "test-curve.R", "test-dotchart.R", "test-fourfold.R", "test-grid.R", "test-hist.POSIXt.R", "test-hist.R", "test-identify.R", "test-legend.R", "test-lines.R", "test-matplot.R", "test-mosaicplot.R", "test-pairs.R", "test-panel.smooth.R", "test-pie.R", "test-plot.data.frame.R", "test-plot.default.R", "test-plot.design.R", "test-plot.factor.R", "test-plot.formula.R", "test-plot.histogram.R", "test-plot.R", "test-plot.table.R", "test-points.R", "test-polypath.R", "test-rug.R", "test-screen.R", "test-smoothScatter.R", "test-spineplot.R", "test-stars.R", "test-stripchart.R", "test-sunflowerplot.R", "test-symbols.R", "test-units.R", "test-persp.R", "test-filled.contour.R") if ("graphics-pkg-core" %in% tests || "all" %in% tests) { testfiles <- c(testfiles, graphics.pkg.core) } if ("graphics-pkg" %in% tests || "all" %in% tests) { testfiles <- c(testfiles, graphics.pkg.core, graphics.pkg) } # Miscellaneous tests if ("all" %in% tests) { testfiles <- c(testfiles, "test-missing.R") } # Copy over the full set of selected test files (which will then be run) for (i in unique(testfiles)) { file.copy(system.file("test-scripts", i, package="gridGraphics"), ".") }gridGraphics/tests/demo-graphics.R0000654000176200001440000001103213625064646016701 0ustar liggesusersrequire(datasets) require(grDevices); require(graphics) library(gridGraphics) demo1 <- function() { x <- stats::rnorm(50) par(bg = "white") plot(x, ann = FALSE, type = "n") abline(h = 0, col = gray(.90)) lines(x, col = "green4", lty = "dotted") points(x, bg = "limegreen", pch = 21) title(main = "Simple Use of Color In a Plot", xlab = "Just a Whisper of a Label", col.main = "blue", col.lab = gray(.8), cex.main = 1.2, cex.lab = 1.0, font.main = 4, font.lab = 3) } demo2 <- function() { par(bg = "gray") pie(rep(1,24), col = rainbow(24), radius = 0.9) title(main = "A Sample Color Wheel", cex.main = 1.4, font.main = 3) title(xlab = "(Use this as a test of monitor linearity)", cex.lab = 0.8, font.lab = 3) } demo3 <- function() { pie.sales <- c(0.12, 0.3, 0.26, 0.16, 0.04, 0.12) names(pie.sales) <- c("Blueberry", "Cherry", "Apple", "Boston Cream", "Other", "Vanilla Cream") pie(pie.sales, col = c("purple","violetred1","green3","cornsilk","cyan","white")) title(main = "January Pie Sales", cex.main = 1.8, font.main = 1) title(xlab = "(Don't try this at home kids)", cex.lab = 0.8, font.lab = 3) } demo4 <- function() { par(bg="cornsilk") n <- 10 g <- gl(n, 100, n*100) x <- rnorm(n*100) + sqrt(as.numeric(g)) boxplot(split(x,g), col="lavender", notch=TRUE) title(main="Notched Boxplots", xlab="Group", font.main=4, font.lab=1) } demo5 <- function() { par(bg="white") n <- 100 x <- c(0,cumsum(rnorm(n))) y <- c(0,cumsum(rnorm(n))) xx <- c(0:n, n:0) yy <- c(x, rev(y)) plot(xx, yy, type="n", xlab="Time", ylab="Distance") polygon(xx, yy, col="gray") title("Distance Between Brownian Motions") } demo6 <- function() { x <- c(0.00, 0.40, 0.86, 0.85, 0.69, 0.48, 0.54, 1.09, 1.11, 1.73, 2.05, 2.02) par(bg="lightgray") plot(x, type="n", axes=FALSE, ann=FALSE) usr <- par("usr") rect(usr[1], usr[3], usr[2], usr[4], col="cornsilk", border="black") lines(x, col="blue") points(x, pch=21, bg="lightcyan", cex=1.25) axis(2, col.axis="blue", las=1) axis(1, at=1:12, lab=month.abb, col.axis="blue") box() title(main= "The Level of Interest in R", font.main=4, col.main="red") title(xlab= "1996", col.lab="red") } demo7 <- function() { par(bg="cornsilk") set.seed(1) x <- rnorm(1000) hist(x, xlim=range(-4, 4, x), col="lavender", main="") title(main="1000 Normal Random Variates", font.main=3) } demo8 <- function() { pairs(iris[1:4], main="Edgar Anderson's Iris Data", font.main=4, pch=19) } demo9 <- function() { pairs(iris[1:4], main="Edgar Anderson's Iris Data", pch=21, bg = c("red", "green3", "blue")[unclass(iris$Species)]) } demo10 <- function() { x <- 10*1:nrow(volcano) y <- 10*1:ncol(volcano) lev <- pretty(range(volcano), 10) par(bg = "lightcyan") pin <- par("pin") xdelta <- diff(range(x)) ydelta <- diff(range(y)) xscale <- pin[1]/xdelta yscale <- pin[2]/ydelta scale <- min(xscale, yscale) xadd <- 0.5*(pin[1]/scale - xdelta) yadd <- 0.5*(pin[2]/scale - ydelta) plot(numeric(0), numeric(0), xlim = range(x)+c(-1,1)*xadd, ylim = range(y)+c(-1,1)*yadd, type = "n", ann = FALSE) usr <- par("usr") rect(usr[1], usr[3], usr[2], usr[4], col="green3") clines <- contourLines(x, y, volcano, levels = lev) lapply(clines, lines, col="yellow", lty="solid") box() title("A Topographic Map of Maunga Whau", font= 4) title(xlab = "Meters North", ylab = "Meters West", font= 3) mtext("10 Meter Contour Spacing", side=3, line=0.35, outer=FALSE, at = mean(par("usr")[1:2]), cex=0.7, font=3) } demo11 <- function() { par(bg="cornsilk") coplot(lat ~ long | depth, data = quakes, pch = 21, bg = "green3") } ## Use old behaviour for drawing circular points ## (using real circles reveals TINY differences in circle radius ## which gets picked up every now and then in PDF -> PNG rasterisation) pdf.options(useDingbats=TRUE) plotdiff(expression(demo1()), "demo-1") plotdiff(expression(demo2()), "demo-2") plotdiff(expression(demo3()), "demo-3") plotdiff(expression(demo4()), "demo-4") plotdiff(expression(demo5()), "demo-5") plotdiff(expression(demo6()), "demo-6") plotdiff(expression(demo7()), "demo-7") plotdiff(expression(demo8()), "demo-8", width=10, height=10) plotdiff(expression(demo9()), "demo-9", width=10, height=10) plotdiff(expression(demo10()), "demo-10") plotdiff(expression(demo11()), "demo-11") plotdiffResult() gridGraphics/R/0000755000176200001440000000000013764276260013076 5ustar liggesusersgridGraphics/R/image.R0000654000176200001440000000153412432763141014275 0ustar liggesusers # image(x, y, z, col, breaks) C_image <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:6)]) dev.set(playDev()) # NOTE: Deliberately override par$xpd depth <- gotovp(FALSE) xx <- tx(x[[2]], par) yy <- ty(x[[3]], par) zz <- x[[4]] col <- FixupCol(x[[5]], NA, par$bg) # NOTE: 'breaks' not used # NOTE: 'z' is index into 'col' nx <- length(xx) ny <- length(yy) xxx <- rep(xx[-nx], (ny - 1)) www <- rep(diff(xx), (ny - 1)) yyy <- rep(yy[-ny], each=(nx - 1)) hhh <- rep(diff(yy), each=(nx - 1)) zzz <- zz + 1 zzz[zz < 1 & zz > length(col)] <- NA grid.rect(xxx, yyy, www, hhh, default.units="native", just=c("left", "bottom"), gp=gpar(col=NA, fill=col[zzz]), name=grobname("image-rect")) upViewport(depth) } gridGraphics/R/dend.R0000654000176200001440000000652213572016366014135 0ustar liggesusers ## A reasonably faithful translation of C code to allow ## for easy comparison of results when debugging ## (only some attempts to vectorise simple C loops) ## C_dend(n, merge, height, order, hang, labels, ...) ## C_dendwindow(n, merge, height, hang, labels, ...) drawdend <- function(node, merge, height, order, labels, offset, hang) { y <- height[node] ## left part k <- merge[node, 1] if (k > 0) { xy <- drawdend(k, merge, height, order, labels, offset, hang) xl <- xy$x yl <- xy$y } else { xl <- order[-k] yl <- if (hang >= 0) y - hang else 0 if (!is.na(labels[-k])) grid.text(labels[-k], xl, yl - offset, default.units="native", hjust=1, vjust=.3, rot=90) } ## right part k <- merge[node, 2] if (k > 0) { xy <- drawdend(k, merge, height, order, labels, offset, hang) xr <- xy$x yr <- xy$y } else { xr <- order[-k] yr <- if (hang >= 0) y - hang else 0 if (!is.na(labels[-k])) grid.text(labels[-k], xr, yr - offset, default.units="native", hjust=1, vjust=.3, rot=90) } grid.polyline(c(xl, xl, xr, xr), c(yl, y, y, yr), default.units="native") x <- 0.5 * (xl + xr) list(x=x, y=y) } C_dend <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:7)]) dev.set(playDev()) depth <- gotovp(NA) ## number of observations ? n <- x[[2]] ## Matrix n by 2 ## dnd_lptr is start of first row ## dnd_rptr is start of second row merge <- x[[3]] ## length = n height <- x[[4]] ## length = n + 1 order <- x[[5]] hang <- x[[6]]*(height[n] - height[1]) ## length = n + 1 labels <- x[[7]] offset <- convertHeight(stringWidth("m"), "native", valueOnly=TRUE) drawdend(n, merge, height, order, labels, offset, hang) upViewport(depth) } C_dendwindow <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:6)]) dev.set(playDev()) depth <- gotovp(par$xpd) n <- x[[2]] ## Matrix n by 2 merge <- x[[3]] ## length = n height <- x[[4]] hang <- x[[5]] ## length = n + 1 labels <- x[[6]] dnd_offset <- stringWidth("m") ymin <- min(height) ymax <- max(height) pin <- par$pin[2] ll <- convertWidth(stringWidth(labels) + dnd_offset, "in", valueOnly=TRUE) if (hang >= 0) { ymin <- ymax - (1 + hang) * (ymax - ymin) yrange = ymax - ymin y <- numeric(n + 1) for (i in 1:n) { if (merge[i, 1] < 0) y[-merge[i, 1] - 1] <- height[i]; if (merge[i, 2] < 0) y[-merge[i, 2] - 1] <- height[i]; } temp <- ((ymax - y)/yrange)*pin + ll imax <- which.max(temp) yval <- temp[imax] } else { yrange <- ymax temp <- pin + ll imax <- which.max(temp) yval <- temp[imax] } ymin = ymax - (pin/(pin - ll[imax])) * yrange; lim <- c(GScale(1, n + 1, par$xaxs), GScale(ymin, ymax, par$yaxs)) upViewport(depth) ## Set up new plot window dev.set(recordDev()) par(usr=lim) dev.set(playDev()) incrementWindowAlpha() setWindowPlotAlpha(plotAlpha()) setUpUsr(lim) } gridGraphics/R/plot.window.R0000654000176200001440000000202112430543177015472 0ustar liggesusers setUpUsr <- function(usr) { windowvp <- viewport(xscale=usr[1:2], yscale=usr[3:4], name=vpname("window")) downViewport(vpPath(vpname("root"), vpname("inner"), vpname("figure"), vpname("plot")), strict=TRUE) pushViewport(windowvp) upViewport(2) downViewport(vpname("plot", clip=TRUE), strict=TRUE) pushViewport(windowvp) upViewport(3) downViewport(vpPath(vpname("figure", clip=TRUE), vpname("plot")), strict=TRUE) pushViewport(windowvp) upViewport(5) } # C_plot_window(xlim, ylim, log, asp, ...) C_plot_window <- function(x) { dev.set(recordDev()) # NOTE: This takes care of 'asp' (and 'log') by setting par("usr") # appropriately and then we just cream those settings off # for the 'grid' viewports do.call("plot.window", x[-1]) usr <- par("usr") dev.set(playDev()) incrementWindowIndex() # Align windowPlotAlpha with plotAlpha setWindowPlotAlpha(plotAlpha()) setUpUsr(usr) } gridGraphics/R/par.R0000654000176200001440000000607613265736666014024 0ustar liggesusers C_par <- function(x) { dev.set(recordDev()) # Mimic call on off-screen device (so get the right answer when # query off-screen device in drawing functions) do.call("par", x[-1]) par <- par() dev.set(playDev()) parnames <- names(x[-1][[1]]) # Only remake viewports for highest-level change in par() if (any(c("oma", "omd", "omi") %in% parnames)) { incrementInnerAlpha() setUpInner(par) } else if (any(c("fig", "fin") %in% parnames)) { incrementFigureAlpha() setUpFigure(par) } else if (any(c("mex", "mai", "mar", "pin", "plt") %in% parnames)) { incrementPlotAlpha() setUpPlot(par) } else if (any(c("usr", "xlog", "ylog") %in% parnames)) { # IF we have reset par(usr), we need a new "window" viewport incrementWindowAlpha() # Align windowPlotAlpha with plotAlpha setWindowPlotAlpha(plotAlpha()) setUpUsr(par$usr) } } gparParNames <- c("font", "family", "bg", "fg", "col", "lheight", "lend", "ljoin", "lmitre", "ps", "cex", "lex", "lwd", "lty") gparNameFromParName <- function(x) { switch(x, font="fontface", family="fontfamily", bg="fill", fg="col", lheight="lineheight", lend="lineend", ljoin="linejoin", lmitre="linemitre", ps="fontsize", x) } # 'x' should be a result from calling par() to set new par() values # (i.e., a list of previous par() values) gparFromPar <- function(x) { gparNames <- sapply(names(x), gparNameFromParName) names(x) <- gparNames do.call(gpar, x) } # Attempt to behave like (C function) processInlinePars() currentPar <- function(inlinePars) { par <- par() # Drop any inlinePars that are NULL # (should never set a par to NULL ?) inlinePars <- inlinePars[!sapply(inlinePars, is.null)] if (length(inlinePars)) { par[names(inlinePars)] <- inlinePars } par } getInlinePar <- function(args, name) { if (name %in% names(args)) { args[[name]] } else { NULL } } FixupPch <- function(pch, dflt) { if (length(pch) == 0) { dflt } else { pch } } FixupLty <- function(lty, dflt) { if (length(lty) == 0) { dflt } else { lty } } FixupLwd <- function(lwd, dflt) { if (length(lwd) == 0) { dflt } else { ifelse(is.finite(lwd) | lwd >=0, lwd, NA) } } FixupCol <- function(col, dflt, bg) { if (length(col) == 0) { dflt } else { # col=0 means par$bg in 'graphics' if (is.numeric(col)) { col <- ifelse(col == 0, bg, col) } col } } FixupCex <- function(cex, dflt) { if (length(cex) == 0) { dflt } else { ifelse(is.finite(cex) & cex > 0, cex, NA) } } FixupFont <- function(font, dflt) { if (length(font) == 0) { dflt } else { if (is.numeric(font)) { ifelse(font < 1 | font > 5, NA, font) } else { font } } } gridGraphics/R/convert.R0000654000176200001440000000105013346311140014655 0ustar liggesusers # Handle log axes tx <- function(x, par) { if (par$xlog && !is.null(x)) { log10(x) } else { x } } ty <- function(x, par) { if (par$ylog && !is.null(x)) { log10(x) } else { x } } ## Make use of graphics::grconvert[X|Y]() grconvertX <- function(x, from, to) { dev.set(recordDev()) on.exit(dev.set(playDev())) graphics::grconvertX(x, from, to) } grconvertY <- function(x, from, to) { dev.set(recordDev()) on.exit(dev.set(playDev())) graphics::grconvertY(x, from, to) } gridGraphics/R/layout.R0000654000176200001440000000054512424017615014530 0ustar liggesusers # layout(num.rows, num.cols, mat, num.figures, col.widths, row.heights, # cm.widths, cm.heights, respect, respect.mat) C_layout <- function(x) { dev.set(recordDev()) # Mimic call on off-screen device (so get the right answer when # query off-screen device in drawing functions) do.call("layout", x[-1]) dev.set(playDev()) } gridGraphics/R/persp.R0000654000176200001440000006704513313050454014350 0ustar liggesusers## initialize and create a viewport prepare for drawing perInit = function(info, newpage = FALSE, dbox = TRUE) { ## [[1]] is the all the grapical information that transfer into grid ## [[3]] is the persp call information ## [[2]] is the plot details eg: x, y, z, xlim, ylim, zlim, col ... ## create a list that store all information from the persp ## then pass the information to per for drawing. ## x is [[2]]; y is [[3]]; z is [[4]] ## xr is [[5]]; yr is [[6]]; zr is [[7]] ## col is [[14]]; border is [[15]]; box is [[19]] ## axes is [[20]], nTicks is [[21]] ## tickType is [[22]] ## xlab/ylab/zlab = [[23]]/[[24]]/[[25]] ## main is in plot[[1]][[4]][[2]][[2]] ## shade is 0.8, ltheta/lphi = [[16]]/[[17]] ## expand is [[13]], scale is [[12]] out = list(x = info[[2]], y = info[[3]], z = info[[4]], xr = info[[5]], yr = info[[6]], zr = info[[7]], col = info[[14]], border = info[[15]][1], ##only allows one color for border dbox = info[[19]], newpage = newpage, phi = info[[9]], theta = info[[8]], r = info[[10]], d = info[[11]], axes = info[[20]], nTicks = info[[21]], tickType = info[[22]], xlab = info[[23]], ylab = info[[24]], zlab = info[[25]], ## parameters in 'par' that need added to per lwd = info$lwd, lty = info$lty, ## col.axis = info$col.axis, ## col.lab = info$col.lab, cex.lab = info$cex.lab, shade = info[[18]], ltheta = info[[16]], lphi = info[[17]], expand = info[[13]], scale = info[[12]] ##main = plot[[1]][[4]][[2]][[2]] ) if(out$newpage == TRUE) grid.newpage() out } ## main call C_persp = function(x) { dev.set(recordDev()) par = currentPar(x[-(1:25)]) dev.set(playDev()) #information extraction xc = yc = zc = xs = ys = zs = 0 x = perInit(x, newpage = FALSE) xr = x$xr; yr = x$yr; zr = x$zr xlab = x$xlab; ylab = x$ylab; zlab = x$zlab col.axis = x$col.axis; col.lab = x$col.lab; col = x$col; cex.lab = x$cex.lab nTicks = x$nTicks; tickType = x$tickType expand = x$expand ;scale = x$scale ltheta = x$ltheta; lphi = x$lphi main = x$main; axes = x$axes dbox = x$dbox; shade = x$shade r = x$r; d = x$d; phi = x$phi; theta = x$theta font.lab = par$font.lab font.axis = par$font.axis cex.axis = par$cex.axis family = par$family xs = LimitCheck(xr)[1] ys = LimitCheck(yr)[1] zs = LimitCheck(zr)[1] xc = LimitCheck(xr)[2] yc = LimitCheck(yr)[2] zc = LimitCheck(zr)[2] if(scale == FALSE){ s = xs if(s < ys) s = ys if (s < zs) s = zs xs = s ys = s zs = s } VT = diag(1, 4) VT = VT %*% Translate(-xc, -yc, -zc) VT = VT %*% Scale(1/xs, 1/ys, expand/zs) VT = VT %*% XRotate(-90.0) VT = VT %*% YRotate(-theta) VT = VT %*% XRotate(phi) VT = VT %*% Translate(0.0, 0.0, -r - d) trans = VT %*% Perspective(d) border = x$border[1]; if(is.null(x$lwd)) lwd = 1 else lwd = x$lwd if(is.null(x$lty)) lty = 1 else lty = x$lty if(any(!(is.numeric(xr) & is.numeric(yr) & is.numeric(zr)))) stop("invalid limits") if(any(!(is.finite(xr) & is.finite(yr) & is.finite(zr)))) stop("invalid limits") if(!scale) xs = ys = zs = max(xs, ys, zs) colCheck = col2rgb(col, alpha = TRUE)[4,1] == 255 if(is.finite(ltheta) && is.finite(lphi) && is.finite(shade) && colCheck) DoLighting = TRUE else DoLighting = FALSE ## check the first color act as Fixcols if (DoLighting) Light = SetUpLight(ltheta, lphi) # create a viewport inside a 'viewport' depth = gotovp(FALSE) lim = PerspWindow(xr, yr, zr, trans, 'r') #vp = viewport(0.5, 0.5, 1, 1, default.units = 'npc', # xscale = lim[1:2], yscale = lim[3:4]) upViewport(depth) incrementWindowAlpha() setWindowPlotAlpha(plotAlpha()) setUpUsr(lim) if (dbox == TRUE) { EdgeDone = rep(0, 12) if(axes == TRUE){ depth = gotovp(TRUE) PerspAxes(xr, yr, zr, ##x, y, z xlab, ylab, zlab, ## xlab, xenc, ylab, yenc, zlab, zenc nTicks, tickType, trans, ## nTicks, tickType, VT lwd, lty, col.axis, cex.axis, col.lab, cex.lab, font.lab, font.axis, family) upViewport(depth)} } else { EdgeDone = rep(1, 12) xr = yr = zr = c(0,0) } ## draw the behind face first ## return the EdgeDone inorder to not drawing the same Edege two times. depth = gotovp(TRUE) EdgeDone = PerspBox(0, xr, yr, zr, EdgeDone, trans, 1, lwd) upViewport(depth) depth = gotovp(FALSE) DrawFacets(plot = x, z = x$z, x = x$x, y = x$y, ## basic xs = 1/xs, ys = 1/ys, zs = expand/zs, ## Light col = col, ## cols ltheta = ltheta, lphi = lphi, Shade = shade, Light = Light, trans = trans, DoLighting = DoLighting) upViewport(depth) depth = gotovp(TRUE) EdgeDone = PerspBox(1, xr, yr, zr, EdgeDone, trans, 'dotted', lwd) upViewport(depth) } ####Shade function LimitCheck = function ( lim ) { ## not finished yet... s = 0.5 * abs(lim[2] - lim[1]) c = 0.5 * (lim[2] + lim[1]) c(s, c) } XRotate = function ( angle ) { TT = diag(1, 4) rad = angle * pi / 180 c = cos(rad) s = sin(rad) TT[2, 2] = c; TT[3, 2] = -s; TT[3, 3] = c; TT[2, 3] = s; TT } YRotate = function ( angle ) { TT = diag(1, 4) rad = angle * pi / 180 c = cos(rad) s = sin(rad) TT[1, 1] = c; TT[3, 1] = s; TT[3, 3] = c; TT[1, 3] = -s; TT } ZRotate = function ( angle ) { TT = diag(1, 4) rad = angle * pi / 180 c = cos(rad) s = sin(rad) TT[1, 1] = c; TT[2, 1] = -s; TT[2, 2] = c; TT[1, 2] = s; TT } Translate = function(x, y, z) { TT = diag(1,4) TT[4, 1] = x TT[4, 2] = y TT[4, 3] = z TT } Scale = function(x, y, z) { TT = diag(1,4) TT[1, 1] = x TT[2, 2] = y TT[3, 3] = z TT } Perspective = function(d) { TT = diag(1,4) TT[3, 4] = -1 / d TT } SetUpLight = function ( theta, phi ) { u = c(0, -1, 0, 1) VT = diag(1, 4) VT = VT %*% XRotate(-phi) VT = VT %*% ZRotate(theta) Light = u %*% VT } FacetShade = function( u, v, Shade, Light ) { nx = u[2] * v[3] - u[3] * v[2] ny = u[3] * v[1] - u[1] * v[3] nz = u[1] * v[2] - u[2] * v[1] sum = sqrt(nx * nx + ny * ny + nz * nz) if (is.finite(sum)){ if (sum == 0) sum = 1 }else{Shade = NA} nx = nx/sum ny = ny/sum nz = nz/sum sum = 0.5 * (nx * Light[1] + ny * Light[2] + nz * Light[3] + 1) sum^Shade } shadeCol = function( z, x, y, xs, ys, zs, col, ltheta, lphi, Shade, Light) { u = v = 0 shade = 0 nx = nrow(z) ny = ncol(z) nx1 = nx - 1 ny1 = ny - 1 cols = 0 ncol = length(col) indx = 0:(length(z)) Light = SetUpLight(ltheta, lphi) for(k in 1:(nx1 * ny1)){ nv = 0 i = (indx[k]) %% nx1 j = (indx[k]) %/% nx1 icol = (i + j * nx1) %% ncol + 1 u[1] = xs * (x[i + 2] - x[i + 1]) u[2] = ys * (y[j + 1] - y[j + 2]) u[3] = zs * (z[(i + 1)+ j * nx + 1] - z[i + (j + 1) * nx + 1]) v[1] = xs * (x[i + 2] - x[i + 1]) v[2] = ys * (y[j + 2] - y[j + 1]) v[3] = zs * (z[(i + 1) + (j + 1) * nx + 1] - z[i + j * nx + 1]) icol = (i + j * nx1) %% ncol shade[k] = FacetShade(u, v, Shade = Shade, Light = Light) shadedCol = col2rgb(col[icol + 1], alpha = TRUE) if(is.finite(shade[k])){ cols[k] = rgb(shade[k] * shadedCol[1], shade[k] * shadedCol[2], shade[k] * shadedCol[3], maxColorValue = 255) }else{ cols[k] = rgb(1,1,1,0) } } list(cols = cols, shade = shade) } ## shade end... PerspBox = function(front = 1, x, y, z, EdgeDone, VT, lty, lwd = lwd ) { u0 = u1 = u2 = u3 = 0 v0 = v1 = v2 = v3 = 0 for (f in 1:6) { p0 = Face[f, 1] p1 = Face[f, 2] p2 = Face[f, 3] p3 = Face[f, 4] u0[1] = x[Vertex[p0, 1]] u0[2] = y[Vertex[p0, 2]] u0[3] = z[Vertex[p0, 3]] u0[4] = 1 u1[1] = x[Vertex[p1, 1]] u1[2] = y[Vertex[p1, 2]] u1[3] = z[Vertex[p1, 3]] u1[4] = 1 u2[1] = x[Vertex[p2, 1]] u2[2] = y[Vertex[p2, 2]] u2[3] = z[Vertex[p2, 3]] u2[4] = 1 u3[1] = x[Vertex[p3, 1]] u3[2] = y[Vertex[p3, 2]] u3[3] = z[Vertex[p3, 3]] u3[4] = 1 v0 = TransVector(u0, VT) v1 = TransVector(u1, VT) v2 = TransVector(u2, VT) v3 = TransVector(u3, VT) v0 = v0/v0[4] v1 = v1/v1[4] v2 = v2/v2[4] v3 = v3/v3[4] d = v1 - v0 e = v2 - v1 nearby = (d[1]*e[2] - d[2]*e[1]) < 0 ## draw the face line by line rather than polygon if ((front && nearby) || (!front && !nearby)) { if (!EdgeDone[Edge[f, 1]]){ grid.lines(c(v0[1], v1[1]), c(v0[2], v1[2]), default.units = 'native', gp = gpar(lty = lty, lwd = lwd), name = grobname(paste0("persp-box-face-", f, "-edge-1"))) EdgeDone[Edge[f, 1]] = EdgeDone[Edge[f, 1]] + 1 } if (!EdgeDone[Edge[f, 2]]){ grid.lines(c(v1[1], v2[1]), c(v1[2], v2[2]), default.units = 'native', gp = gpar(lty = lty, lwd = lwd), name = grobname(paste0("persp-box-face-", f, "-edge-2"))) EdgeDone[Edge[f, 2]] = EdgeDone[Edge[f, 2]] + 1 } if (!EdgeDone[Edge[f, 3]]){ grid.lines(c(v2[1], v3[1]), c(v2[2], v3[2]), default.units = 'native', gp = gpar(lty = lty, lwd = lwd), name = grobname(paste0("persp-box-face-", f, "-edge-3"))) EdgeDone[Edge[f, 3]] = EdgeDone[Edge[f, 3]] + 1 } if (!EdgeDone[Edge[f, 4]]){ grid.lines(c(v3[1], v0[1]), c(v3[2], v0[2]), default.units = 'native', gp = gpar(lty = lty, lwd = lwd), name = grobname(paste0("persp-box-face-", f, "-edge-4"))) EdgeDone[Edge[f, 4]] = EdgeDone[Edge[f, 4]] + 1 } } } EdgeDone } dPolygon = function(x, y, z, col, trans){ ## the total number of polygon that we need to draw nx = length(x) ny = length(y) total = nx * ny stops = (nx - 1) * (ny - 1) ## set the temp value for x,y,z prepare for subsetting xTmp = rep(x, length(y)) yTmp = rep(y,each = nx) zTmp = as.numeric(z) ## the drawing order is along x-axis, and then along y-axis ## then create a vector like a 4Xn matrix, ## i.e the first column contain all the first points for every polygons ## the second column contain all the second points for every polygons and so on pBreak = c(1:total, 1 + 1:total, 1 + nx + 1:total, nx + 1:total) xBreak = xTmp[pBreak] yBreak = yTmp[pBreak] zBreak = zTmp[pBreak] ## draw the box if required ## the vectors now has four paths, every paths contain the information of every points of every polygon ## now we need to change the order of this vector, so that the first four index should be the order for drawing ## the first points, not the first four points for the first four polygon ## points subsetting plot.index = rep( c(1, 1 + total, 1 + 2 * total, 1 + 3 * total ), total) + rep(0:(total - 1), each = 4) ## sequence for 'problem's polygons index, e.g ## along x-axis, there are n-1 polygons, n is the number of points in x direction ## we don't want to draw the nth polygon, hence we deleted those polygon dp = rep((4 * seq(nx,total,nx)), each = 4) - (3:0) ## final subsetting xCoor = xBreak[plot.index][-dp][1 : (4 * stops)] yCoor = yBreak[plot.index][-dp][1 : (4 * stops)] zCoor = zBreak[plot.index][-dp][1 : (4 * stops)] ## vectorize the cols colRep = rep_len(col, length(xCoor)) ## use the first corner of every polygon to determind the order for drawing corn.id = 4* 1:(length(xCoor)/4) xc = xCoor[corn.id] yc = yCoor[corn.id] ## method for using the zdepth for changing the drawing order for every polygon orderTemp = cbind(xc, yc, 0, 1) %*% trans zdepth = orderTemp[, 4] ## the zdepth of a set of 4 points of each polygon a = order(zdepth, decreasing = TRUE) oo = rep(1:4, length(a)) + rep(a - 1, each = 4) * 4 xyCoor = trans3d(xCoor[oo], yCoor[oo], zCoor[oo], trans) colRep = colRep[a] ## record the total number of polygon pMax = length(xyCoor$x) / 4 pout = list(xyCoor = xyCoor, pMax = pMax, colRep = colRep, polygonOrder = a) pout } DrawFacets = function(plot, z, x, y, xs, ys, zs, col, ltheta, lphi, Shade, Light, trans, DoLighting) { pout = dPolygon(x, y, z, col, trans) xyCoor = pout$xyCoor pMax = pout$pMax; colRep = pout$colRep polygonOrder = pout$polygonOrder polygons = cbind(xyCoor$x, xyCoor$y) polygon.id = rep(1:pMax, each = 4) col = plot$col if (DoLighting == TRUE) { col[is.na(col)] = rgb(1, 1, 1) if(is.finite(Shade) && Shade <= 0 ) Shade = 1 shadding = shadeCol(z, x, y, ## x, y, z xs, ys, zs, ## xs, ys, zs col, ## col, ncol ltheta, lphi, Shade, Light = Light) ## ltheta, lphi, Shade(not shade) shadedCol = shadding[[1]] ## clean if any NA's Z-value shade = shadding[[2]][polygonOrder] misshade = !is.finite(shade) misindex = rep(misshade, each = 4) polygonOrder = polygonOrder[!misshade] polygons = polygons[!misindex,] polygon.id = polygon.id[!misindex] cols = shadedCol[polygonOrder] } else { cols = rep_len(col, length(polygons[,1]))[polygonOrder] } xrange = range(polygons[,1], na.rm = TRUE) yrange = range(polygons[,2], na.rm = TRUE) grid.polygon(polygons[,1], polygons[,2], id = polygon.id, default.units = 'native', gp = gpar(col = plot$border, fill = cols, lty = plot$lty, lwd = plot$lwd), name = grobname("persp-surface")) } TransVector = function(u, T) { u %*% T } lowest = function (y1, y2, y3, y4) { (y1 <= y2) && (y1 <= y3) && (y1 <= y4) } labelAngle = function(x1, y1, x2, y2){ dx = abs(x2 - x1) if ( x2 > x1 ) { dy = y2 - y1 } else { dy = y1 - y2 } if (dx == 0) { if( dy > 0 ) { angle = 90 } else { angle = 270 } } else { angle = 180/pi * atan2(dy, dx) } angle } PerspAxis = function(x, y, z, axis, axisType, nTicks, tickType, label, VT, lwd = 1, lty, col.axis = 1, cex.axis = 1, col.lab = 1, cex.lab = 1, font.lab, font.axis, family){ ## don't know how to use numeric on the switch... axisType = as.character(axisType) tickType = as.character(tickType) u1 = u2 = u3 = c(0.,0.,0.,0.) tickLength = .03 switch(axisType, '1' = {min = x[1]; max = x[2]; range = x}, '2' = {min = y[1]; max = y[2]; range = y}, '3' = {min = z[1]; max = z[2]; range = z} ) d_frac = 0.1 * (max - min) nint = nTicks - 1 if(!nint)nint = nint + 1 i = nint ticks = axisTicks(c(min, max), FALSE, nint = nint) min = ticks[1] max = ticks[length(ticks)] nint = length(ticks) - 1 ## but maybe not this one... haven't test yet... while((min < range[1] - d_frac || range[2] + d_frac < max) && i < 20) { nint = i + 1 ticks = axisTicks(c(min, max), FALSE) range = range(ticks) nint = length(ticks) - 1 } ## axp seems working... axp = 0 axp[1] = min axp[2] = max axp[3] = nint # Do the following calculations for both ticktypes # Vertex is a 8*3 matrix; i.e. the vertex of a box # AxisStart is a vector of length 8 # axis is a output # u1, u2 are the vectors in 3-d # the range of x,y,z switch (axisType, '1' = { u1[1] = min u1[2] = y[Vertex[AxisStart[axis], 2]] u1[3] = z[Vertex[AxisStart[axis], 3]] }, '2' = { u1[1] = x[Vertex[AxisStart[axis], 1]] u1[2] = min u1[3] = z[Vertex[AxisStart[axis], 3]] }, '3' = { u1[1] = x[Vertex[AxisStart[axis], 1]] u1[2] = y[Vertex[AxisStart[axis], 2]] u1[3] = min } ) u1[1] = u1[1] + tickLength*(x[2]-x[1])*TickVector[axis, 1] u1[2] = u1[2] + tickLength*(y[2]-y[1])*TickVector[axis, 2] u1[3] = u1[3] + tickLength*(z[2]-z[1])*TickVector[axis, 3] u1[4] = 1 ##axisType, 1 = 'draw x-axis' ## 2 = 'draw y-axis' ## 3 = 'draw z-axis' switch (axisType, '1' = { u2[1] = max u2[2] = u1[2] u2[3] = u1[3] }, '2' = { u2[1] = u1[1] u2[2] = max u2[3] = u1[3] }, '3' = { u2[1] = u1[1] u2[2] = u1[2] u2[3] = max } ) u2[4] = 1 switch(tickType, '1' = { u3[1] = u1[1] + tickLength*(x[2]-x[1])*TickVector[axis, 1] u3[2] = u1[2] + tickLength*(y[2]-y[1])*TickVector[axis, 2] u3[3] = u1[3] + tickLength*(z[2]-z[1])*TickVector[axis, 3] }, '2' = { u3[1] = u1[1] + 2.5*tickLength*(x[2]-x[1])*TickVector[axis, 1] u3[2] = u1[2] + 2.5*tickLength*(y[2]-y[1])*TickVector[axis, 2] u3[3] = u1[3] + 2.5*tickLength*(z[2]-z[1])*TickVector[axis, 3] } ) ## u3 is the the labels at the center of each axes switch(axisType, '1' = { u3[1] = (min + max)/2 }, '2' = { u3[2] = (min + max)/2 }, '3' = { u3[3] = (min + max)/2 } ) u3[4] = 1 ## transform the 3-d into 2-d v1 = TransVector(u1, VT) v2 = TransVector(u2, VT) v3 = TransVector(u3, VT) v1 = v1/v1[4] v2 = v2/v2[4] v3 = v3/v3[4] ## label at center of each axes srt = labelAngle(v1[1], v1[2], v2[1], v2[2]) #text(v3[1], v3[2], label, 0.5, srt = srt) labname <- switch(axisType, '1' = "x", '2' = "y", '3' = "z") grid.text(label = label, x = v3[1], y = v3[2], just = "centre", rot = srt, default.units = "native", #vp = 'clipoff', gp = gpar(col = col.lab, lwd = lwd, cex = cex.lab, font = font.lab, fontfamily = family), name = grobname(paste0("persp-", labname, "lab"))) ## tickType is not working.. when = '2' switch(tickType, '1' = { arrow = arrow(angle = 10, length = unit(0.1, "in"), ends = "last", type = "open") ## drawing the tick.. grid.lines(x = c(v1[1], v2[1]), y = c(v1[2], v2[2]), default.units = "native", arrow = arrow, ## vp = 'clipoff', gp = gpar(col = 1, lwd = lwd , lty = lty ), name = grobname(paste0("persp-", labname, "-axis-arrow"))) }, ## '2' seems working '2' = { at = axisTicks(range, FALSE, axp, nint = nint) lab = format(at, trim = TRUE) for(i in 1:length(at)){ switch(axisType, '1' = { u1[1] = at[i] u1[2] = y[Vertex[AxisStart[axis], 2]] u1[3] = z[Vertex[AxisStart[axis], 3]] }, '2' = { u1[1] = x[Vertex[AxisStart[axis], 1]] u1[2] = at[i] u1[3] = z[Vertex[AxisStart[axis], 3]] }, '3' = { u1[1] = x[Vertex[AxisStart[axis], 1]] u1[2] = y[Vertex[AxisStart[axis], 2]] u1[3] = at[i] } ) tickLength = 0.03 u1[4] = 1 u2[1] = u1[1] + tickLength*(x[2]-x[1])*TickVector[axis, 1] u2[2] = u1[2] + tickLength*(y[2]-y[1])*TickVector[axis, 2] u2[3] = u1[3] + tickLength*(z[2]-z[1])*TickVector[axis, 3] u2[4] = 1 u3[1] = u2[1] + tickLength*(x[2]-x[1])*TickVector[axis, 1] u3[2] = u2[2] + tickLength*(y[2]-y[1])*TickVector[axis, 2] u3[3] = u2[3] + tickLength*(z[2]-z[1])*TickVector[axis, 3] u3[4] = 1 v1 = TransVector(u1, VT) v2 = TransVector(u2, VT) v3 = TransVector(u3, VT) v1 = v1/v1[4] v2 = v2/v2[4] v3 = v3/v3[4] ## Draw tick line grid.lines(x = c(v1[1], v2[1]), y = c(v1[2], v2[2]), default.units = "native", ##vp = 'clipoff', gp = gpar(col = col.axis, lwd = lwd, lty = lty), name = grobname(paste0("persp-", labname, "-axis-ticks"))) ## Draw tick label grid.text(label = lab[i], x = v3[1], y = v3[2], just = "centre", default.units = "native", #vp = 'clipoff', gp = gpar(col = col.axis, adj = 1, pos = 0.5, cex = cex.axis, font = font.axis, fontfamily = family), name = grobname(paste0("persp-", labname, "-axis-labels"))) } }) } PerspAxes = function(x, y, z, xlab, ylab, zlab, nTicks, tickType, VT, ## parameters in par lwd = 1, lty = 1, col.axis = 1, cex.axis = 1, col.lab = 1, cex.lab = 1, font.lab, font.axis, family) { xAxis = yAxis = zAxis = 0 ## -Wall u0 = u1 = u2 = u3 = 0 u0[1] = x[1]; u0[2] = y[1]; u0[3] = z[1]; u0[4] = 1 u1[1] = x[2]; u1[2] = y[1]; u1[3] = z[1]; u1[4] = 1 u2[1] = x[1]; u2[2] = y[2]; u2[3] = z[1]; u2[4] = 1 u3[1] = x[2]; u3[2] = y[2]; u3[3] = z[1]; u3[4] = 1 v0 = TransVector(u0, VT) v1 = TransVector(u1, VT) v2 = TransVector(u2, VT) v3 = TransVector(u3, VT) v0 = v0/v0[4] v1 = v1/v1[4] v2 = v2/v2[4] v3 = v3/v3[4] if (lowest(v0[2], v1[2], v2[2], v3[2])) { xAxis = 1 yAxis = 2 } else if (lowest(v1[2], v0[2], v2[2], v3[2])) { xAxis = 1 yAxis = 4 } else if (lowest(v2[2], v1[2], v0[2], v3[2])) { xAxis = 3 yAxis = 2 } else if (lowest(v3[2], v1[2], v2[2], v0[2])) { xAxis = 3 yAxis = 4 } else warning("Axis orientation not calculated") ## drawing x and y axes PerspAxis(x, y, z, xAxis, '1', nTicks, tickType, xlab, VT, lwd = lwd, lty = lty, col.axis = col.axis, cex.axis = cex.axis, col.lab = col.lab, cex.lab = cex.lab, font.lab, font.axis, family) PerspAxis(x, y, z, yAxis, '2', nTicks, tickType, ylab, VT, lwd = lwd, lty = lty, col.axis = col.axis, cex.axis = cex.axis, col.lab = col.lab, cex.lab = cex.lab, font.lab, font.axis, family) ## Figure out which Z axis to draw if (lowest(v0[1], v1[1], v2[1], v3[1])) { zAxis = 5 }else if (lowest(v1[1], v0[1], v2[1], v3[1])) { zAxis = 6 }else if (lowest(v2[1], v1[1], v0[1], v3[1])) { zAxis = 7 }else if (lowest(v3[1], v1[1], v2[1], v0[1])) { zAxis = 8 }else warning("Axis orientation not calculated") ## drawing the z-axis PerspAxis(x, y, z, zAxis, '3', nTicks, tickType, zlab, VT, lwd = lwd, lty = lty, col.axis = col.axis, cex.axis = cex.axis, col.lab = col.lab, cex.lab = cex.lab, font.lab, font.axis, family) } PerspWindow = function(xlim, ylim, zlim, VT, style) { xmax = xmin = ymax = ymin = u = 0 u[4] = 1 for (i in 1:2) { u[1] = xlim[i] for (j in 1:2) { u[2] = ylim[j] for (k in 1:2) { u[3] = zlim[k] v = TransVector(u, VT) xx = v[1] / v[4] yy = v[2] / v[4] if (xx > xmax) xmax = xx if (xx < xmin) xmin = xx if (yy > ymax) ymax = yy if (yy < ymin) ymin = yy } } } pin1 = convertX(unit(1.0, 'npc'), 'inches', valueOnly = TRUE) pin2 = convertY(unit(1.0, 'npc'), 'inches', valueOnly = TRUE) xdelta = abs(xmax - xmin) ydelta = abs(ymax - ymin) xscale = pin1 / xdelta yscale = pin2 / ydelta scale = if(xscale < yscale) xscale else yscale xadd = .5 * (pin1 / scale - xdelta); yadd = .5 * (pin2 / scale - ydelta); ## GScale in C xrange = GScale(xmin - xadd, xmax + xadd, style) yrange = GScale(ymin - yadd, ymax + yadd, style) c(xrange, yrange) } GScale = function(min, max, style) { switch(style, 'r' = {temp = 0.04 * (max - min) min = min - temp max = max + temp }, 'i' = {} ) c(min, max) } ## global variables. TickVector = matrix(ncol = 3, byrow = TRUE, data = c( 0, -1, -1, -1, 0, -1, 0, 1, -1, 1, 0, -1, -1, -1, 0, 1, -1, 0, -1, 1, 0, 1, 1, 0 )) Vertex = matrix(ncol = 3, byrow = TRUE, data = c( 1, 1, 1, #xlim[1], ylim[1], zlim[1] 1, 1, 2, #xlim[1], ylim[1], zlim[2] 1, 2, 1, 1, 2, 2, 2, 1, 1, 2, 1, 2, 2, 2, 1, 2, 2, 2 )) Face = matrix (ncol = 4, byrow = TRUE, data = c( 1, 2, 6, 5, 3, 7, 8, 4, 1, 3, 4, 2, 5, 6, 8, 7, 1, 5, 7, 3, 2, 4, 8, 6 )) Edge = matrix (ncol = 4, byrow = TRUE, data = c( 0, 1, 2, 3, 4, 5, 6, 7, 8, 7, 9, 0, 2,10, 5,11, 3,11, 4, 8, 9, 6,10, 1)) + 1 AxisStart = c(1, 1, 3, 5, 1, 5, 3, 7) gridGraphics/R/contour.R0000654000176200001440000000224312427775331014712 0ustar liggesusers # contour(x, y, z, levels, labels, labcex, drawlabels, method, # vfont, col, lty, lwd) C_contour <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:13)]) dev.set(playDev()) depth <- gotovp(par$xpd) xx <- tx(x[[2]], par) yy <- ty(x[[3]], par) zz <- x[[4]] levels <- x[[5]] drawlabels <- x[[8]] col <- FixupCol(x[[11]], NA, par$bg) col <- ifelse(is.na(col), par$col, col) lty <- FixupLty(x[[12]], par$lty) lty <- ifelse(is.na(lty), par$lty, lty) lwd <- FixupLwd(x[[13]], par$lwd) lwd <- ifelse(is.na(lwd), par$lwd, lwd) if (drawlabels) { warning("gridGraphics cannot emulate labels on contour lines") } clines <- contourLines(xx, yy, zz, levels=levels) if (length(clines)) { for (i in 1:length(clines)) { c <- clines[[i]] grid.lines(c$x, c$y, default.units="native", gp=gpar(col=col, lty=lty, lwd=lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=paste(grobname("contour"), i, sep="-")) } } upViewport(depth) } gridGraphics/R/plotXY.R0000654000176200001440000000731713256041710014453 0ustar liggesusers # C_plotXY(xy, type, pch, lty, col, bg, cex, lwd, ...) C_plotXY <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:9)]) dev.set(playDev()) depth <- gotovp(par$xpd) xx <- tx(x[[2]]$x, par) yy <- ty(x[[2]]$y, par) type <- x[[3]] pch <- FixupPch(x[[4]], par$pch) lty <- FixupLty(x[[5]], par$lty) col <- FixupCol(x[[6]], 0, par$bg) bg <- FixupCol(x[[7]], NA, par$bg) # NOTE: cex multiplied by "base" cex cex <- FixupCex(x[[8]]*par$cex, 1) lwd <- FixupLwd(x[[9]], par$lwd) switch(type, n={ }, # do nothing p=points(xx, yy, pch, col, bg, cex, lwd, par), l=lines(xx, yy, lty, col, lwd, par), s=step(xx, yy, lty, col, lwd, par), S=Step(xx, yy, lty, col, lwd, par), h=bar(xx, yy, lty, col, lwd, par), c=brokenlines(xx, yy, lty, col, lwd, par), o={ lines(xx, yy, lty, col, lwd, par); points(xx, yy, pch, col, bg, cex, lwd, par) }, b={ brokenlines(xx, yy, lty, col, lwd, par); points(xx, yy, pch, col, bg, cex, lwd, par) }) upViewport(depth) } points <- function(x, y, pch, col, bg, cex, lwd, par) { if (length(x) > 0 && length(y) > 0) { grid.points(x, y, default.units="native", ## GSTR_0 dpptr(dd)->scale * dd->dev->cra[1] * 0.5 * dd->dev->ipr[1] * gpptr(dd)->cex size=unit(par$cin[2]*0.5*cex, "in"), pch=pch, gp=gpar(lty="solid", col=col, fill=bg, lwd=lwd, cex=cex, fontface=par$font), name=grobname("points")) } } lines <- function(x, y, lty, col, lwd, par) { grid.lines(x, y, default.units="native", gp=gpar(lty=lty, col=col, lwd=lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("lines")) } step <- function(x, y, lty, col, lwd, par) { n <- length(x) grid.lines(rep(x, each=2)[-1], rep(y, each=2, length.out=2*n - 1), default.units="native", gp=gpar(lty=lty, col=col, lwd=lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("step")) } Step <- function(x, y, lty, col, lwd, par) { n <- length(x) grid.lines(rep(x, each=2, length.out=2*n - 1), rep(y, each=2)[-1], default.units="native", gp=gpar(lty=lty, col=col, lwd=lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("Step")) } bar <- function(x, y, lty, col, lwd, par) { if (par$ylog) { root <- par$usr[3] } else { root <- 0 } grid.segments(x, root, x, y, default.units="native", gp=gpar(lty=lty, col=col, lwd=lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("spike")) } brokenlines <- function(x, y, lty, col, lwd, par) { d <- 0.5*par$cin[2]*par$cex xx <- convertX(unit(x, "native"), "in", valueOnly=TRUE) yy <- convertY(unit(y, "native"), "in", valueOnly=TRUE) dx <- diff(xx) dy <- diff(yy) hypot <- sqrt(dx^2 + dy^2) # If not enough room, setting to NA will mean no segment drawn f <- ifelse(d < 0.5*hypot, d/hypot, NA) n <- length(x) sx <- xx[-n] + f*dx sy <- yy[-n] + f*dy ex <- xx[-1] - f*dx ey <- yy[-1] - f*dy grid.segments(sx, sy, ex, ey, default.units="in", gp=gpar(lty=lty, col=col, lwd=lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("brokenline")) } gridGraphics/R/plotdiff.R0000654000176200001440000001206313764276062015033 0ustar liggesusers # Code used by test files plotcompare <- function(graphicsPNG, gridPNG, label) { diffFile <- paste0(label, "-diff.png") diff <- magick::image_compare(graphicsPNG, gridPNG, metric="AE") nDiff <- attr(diff, "distortion") if (nDiff > 0) { magick::image_write(diff, diffFile) graphicsFile <- paste0(label, "-graphics.png") magick::image_write(graphicsPNG, graphicsFile) gridFile <- paste0(label, "-grid.png") magick::image_write(gridPNG, gridFile) } nDiff } fungen <- function() { diffs <- NULL version <- getRversion() haveRecentR <- version >= "3.2.0" haveWarned <- FALSE pdInit <- function() { diffs <<- NULL } # Generate PDF because that is where 'gridGraphics' will mimic best # Convert to PNG for compare because that will provide a little bit # of tolerance for infinitessimal differences (?) pd <- function(expr, label, dev="pdf", antialias=TRUE, density=100, width=7, height=7) { suffix <- switch(dev, pdf=".pdf", png=".png", stop("I do not like your choice of device")) graphicsFile <- paste0(label, "-graphics", suffix) gridFile <- paste0(label, "-grid", suffix) curDev <- dev.cur() switch(dev, pdf=pdf(graphicsFile, width=width, height=height, compress=FALSE), png=png(graphicsFile, width=width*100, height=height*100)) graphicsDev <- dev.cur() dev.control("enable") tryCatch( { eval(expr) dl <- recordPlot() }, ## Try to clean up if we error out finally={ dev.set(graphicsDev) dev.off() ## Do not reset current device if there were no devices open if (curDev != 1) dev.set(curDev) }) switch(dev, pdf=pdf(gridFile, width=width, height=height, compress=FALSE), png=png(gridFile, width=width*100, height=height*100)) gridDev <- dev.cur() tryCatch( { grid.echo(dl) }, ## Try to clean up if we error out finally={ dev.set(gridDev) dev.off() ## Do not reset current device if there were no devices open if (curDev != 1) dev.set(curDev) }) # Only convert and compare if have the tools if (haveRecentR && requireNamespace("magick") && (dev == "png" || requireNamespace("pdftools"))) { if (dev == "png") { graphicsPNG <- magick::image_read(graphicsFile) gridPNG <- magick::image_read(gridFile) } else { ## ASSUME dev == "pdf" ## Check for multiple-page PDF ## If found, only compare the last page numPages <- pdftools::pdf_info(graphicsFile)$pages if (numPages > 1) { warning(paste0("Only comparing final page (of ", numPages, " pages)")) } # 'antialias' must be off to get reliable comparison of # images that include adjacent polygon fills graphicsBitmap <- pdftools::pdf_render_page(graphicsFile, page=numPages, dpi=density, antialias=antialias) graphicsImage <- magick::image_read(graphicsBitmap) graphicsPNG <- magick::image_convert(graphicsImage, "png") ## grid.echo() will only have captured final page gridBitmap <- pdftools::pdf_render_page(gridFile, dpi=density, antialias=antialias) gridImage <- magick::image_read(gridBitmap) gridPNG <- magick::image_convert(gridImage, "png") } result <- plotcompare(graphicsPNG[1], gridPNG[1], label) if (result > 0) { diffs <<- c(diffs, paste0(result, if (result == 1) " difference " else " differences ", "detected (", label, "-diff.png)")) } } else{ if (!haveWarned) { cat("Unable to test output for differences\n") haveWarned <<- TRUE } } } pdresult <- function(warn=FALSE) { if (length(diffs)) { cat(diffs, sep="\n") if (warn) { warning("Differences detected") } else { stop("Differences detected") } } } list(pdInit=pdInit, pd=pd, pdresult=pdresult) } funs <- fungen() plotdiffInit <- funs$pdInit plotdiff <- funs$pd plotdiffResult <- funs$pdresult gridGraphics/R/filled.contour.R0000654000176200001440000001167413256770122016152 0ustar liggesusers## vectorization version (main in used) FindPolygonVertices = function(low, high, x1, x2, y1, y2, z11, z21, z12, z22, colrep){ v1 = FindCutPoints(low, high, x1, y1, x2, y1, z11, z21) v2 = FindCutPoints(low, high, y1, x2, y2, x2, z21, z22) v3 = FindCutPoints(low, high, x2, y2, x1, y2, z22, z12) v4 = FindCutPoints(low, high, y2, x1, y1, x1, z12, z11) vx = cbind(v1[[1]], v2[[2]], v3[[1]], v4[[2]]) vy = cbind(v1[[2]], v2[[1]], v3[[2]], v4[[1]]) ## track the coordinate for x and y( if non-NA's) index = rowSums(!is.na(vx) ) ## keep if non-NAs row >= 2 (npt >= 2) vx = t(vx) vy = t(vy) xcoor.na = as.vector(vx[, index > 2]) ycoor.na = as.vector(vy[, index > 2]) ## delete all NA's, xcoor = xcoor.na[!is.na(xcoor.na)] ycoor = ycoor.na[!is.na(ycoor.na)] id.length = index[index > 2] cols = colrep[index > 2] out = list(x = xcoor, y = ycoor, id.length = id.length, cols = cols) outs = out out } FindCutPoints = function(low, high, x1, y1, x2, y2, z1, z2) { ## inner condiction begin ## first ocndiction c = (z1 - high) / (z1 - z2) cond1 = z1 < high cond2 = z1 == Inf cond3 = z2 > high | z1 < low x.1 = ifelse(cond1, x1, ifelse(cond2, x2, x1 + c * (x2 - x1))) x.1 = ifelse(cond3, NA, x.1) y.1 = ifelse(cond1, y1, ifelse(cond2, y1, y1)) y.1 = ifelse(cond3, NA, y.1) cond4 = z2 == -Inf cond5 = z2 <= low cond6 = z2 > high | z1 < low c = (z2 -low) / (z2 - z1) x.2 = ifelse(cond4, x1, ifelse(cond5, x2 - c * (x2 - x1), NA)) x.2 = ifelse(cond6, NA, x.2) y.2 = ifelse(cond4, y1, ifelse(cond5, y1, NA)) y.2 = ifelse(cond6, NA, y.2) ## second condiction cond7 = z1 > low cond8 = z1 == -Inf cond9 = z2 < low | z1 > high c = (z1 - low) / (z1 - z2) x_1 = ifelse(cond7, x1, ifelse(cond8, x2, x1 + c * (x2 - x1))) x_1 = ifelse(cond9, NA, x_1) y_1 = ifelse(cond7, y1, ifelse(cond8, y1, y1)) y_1 = ifelse(cond9, NA, y_1) cond10 = z2 < high cond11 = z2 == Inf cond12 = z2 < low | z1 > high c = (z2 - high) / (z2 - z1) x_2 = ifelse(cond10, NA, ifelse(cond11, x1, x2 - c * (x2 - x1))) x_2 = ifelse(cond12, NA, x_2) y_2 = ifelse(cond10, NA, ifelse(cond11, y1, y1)) y_2 = ifelse(cond12, NA, y_2) ## third condiction cond13 = low <= z1 & z1 <= high x..1 = ifelse(cond13, x1, NA) y..1 = ifelse(cond13, y1, NA) ## inner condiction end ## outer condiction cond14 = z1 > z2 cond15 = z1 < z2 xout.1 = ifelse(cond14, x.1, ifelse(cond15, x_1, x..1)) xout.2 = ifelse(cond14, x.2, ifelse(cond15, x_2, NA)) yout.1 = ifelse(cond14, y.1, ifelse(cond15, y_1, y..1)) yout.2 = ifelse(cond14, y.2, ifelse(cond15, y_2, NA)) ## outer condiction end ## return x1, x2, y1, y2 xout = cbind(xout.1, xout.2) yout = cbind(yout.1, yout.2) list(xout, yout) } C_filledcontour = function(plot) { dev.set(recordDev()) par = currentPar(NULL) dev.set(playDev()) x = plot[[2]] y = plot[[3]] z = plot[[4]] s = plot[[5]] cols = plot[[6]] ns = length(s) nx = length(x) ny = length(y) x1 = rep(x[-nx], each = ny - 1) x2 = rep(x[-1], each = ny - 1) y1 = rep(y[-ny], nx - 1) y2 = rep(y[-1], nx - 1) z11 = as.numeric(t(z[-nx, -ny])) z21 = as.numeric(t(z[-1, -ny ])) z12 = as.numeric(t(z[-nx, -1])) z22 = as.numeric(t(z[-1, -1])) x1 = rep(x1, each = ns - 1) x2 = rep(x2, each = ns - 1) y1 = rep(y1, each = ns - 1) y2 = rep(y2, each = ns - 1) z11 = rep(z11, each = ns - 1) z12 = rep(z12, each = ns - 1) z21 = rep(z21, each = ns - 1) z22 = rep(z22, each = ns - 1) low = rep(s[-ns], (nx - 1) * (ny - 1)) high = rep(s[-1], (nx - 1) * (ny - 1)) ## rep color until the same length of x, then subsetting if(length(cols) > ns){ cols = cols[1:(ns - 1)] }else { cols = rep_len(cols, ns - 1) } colrep = rep(cols[1:(ns - 1)], nx * ny) ## feed color as well as subseeting as x and y out = FindPolygonVertices( low = low, high = high, x1 = x1, x2 = x2, y1 = y1, y2 = y2, z11 = z11, z21 = z21, z12 = z12, z22 = z22, colrep = colrep) ## actual drawing depth = gotovp(FALSE) grid.polygon(out$x, out$y, default.units = 'native', id.lengths = out$id.length, gp = gpar(fill = out$cols, col = NA), name = grobname("filled-contour")) upViewport(depth) } gridGraphics/R/symbols.R0000654000176200001440000001606612434510072014704 0ustar liggesusers # C_symbols(x, y, type, data, inches, bg, fg, ...) C_symbols <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:8)]) dev.set(playDev()) depth <- gotovp(par$xpd) xx <- tx(x[[2]], par) yy <- ty(x[[3]], par) type <- x[[4]] p <- x[[5]] # FALSE becomes 0, TRUE becomes 1 inches <- as.numeric(x[[6]]) if (!is.finite(inches) || inches < 0) { inches <- 0 } bg <- FixupCol(x[[7]], NA, par$bg) fg <- FixupCol(x[[8]], NA, par$bg) if (type == 1) { # circles prange <- range(p, na.rm=TRUE) if (inches > 0) { r <- unit(p*inches/prange[2], "in") } else { r <- convertWidth(unit(p, "native"), "in") } grid.circle(xx, yy, r, default.units="native", gp=gpar(col=fg, fill=bg, lty=par$lty, lwd=par$lwd), name=grobname("symbols-circle")) } else if (type == 2) { # squares prange <- range(p, na.rm=TRUE) if (inches > 0) { w <- unit(p*inches/prange[2], "in") } else { w <- convertWidth(unit(p, "native"), "in") } grid.rect(xx, yy, width=w, height=w, default.units="native", gp=gpar(col=fg, fill=bg, lty=par$lty, lwd=par$lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("symbols-square")) } else if (type == 3) { # rectangles prange <- range(p, na.rm=TRUE) if (inches > 0) { w <- unit(p[, 1]*inches/prange[2], "in") h <- unit(p[, 2]*inches/prange[2], "in") } else { w <- unit(p[, 1], "native") h <- unit(p[, 2], "native") } grid.rect(xx, yy, width=w, height=h, default.units="native", gp=gpar(col=fg, fill=bg, lty=par$lty, lwd=par$lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("symbols-rect")) } else if (type == 4) { # stars prange <- range(p, na.rm=TRUE) nc <- ncol(p) nr <- nrow(p) p[is.na(p)] <- 0 if (inches > 0) { r <- p*inches/prange[2] } else { r <- convertWidth(unit(p, "native"), "in", valueOnly=TRUE) } xc <- rep(convertX(unit(xx, "native"), "in", valueOnly=TRUE), nc) yc <- rep(convertX(unit(yy, "native"), "in", valueOnly=TRUE), nc) t <- seq(0, 2*pi, length.out=nc + 1)[-1] grid.polygon(xc + r*cos(t), yc + r*sin(t), default.units="in", id.lengths=rep(1:nc, each=nr), gp=gpar(col=fg, fill=bg, lty=par$lty, lwd=par$lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("symbols-star")) } else if (type == 5) { # thermometers prange <- range(p[, 1:2], na.rm=TRUE) nc <- ncol(p) if (nc < 4) { p <- cbind(p, 0) } if (inches > 0) { w <- unit(p[, 1]*inches/prange[2], "in") h <- unit(p[, 2]*inches/prange[2], "in") } else { w <- convertWidth(unit(p[, 1], "native"), "in") h <- convertHeight(unit(p[, 2], "native"), "in") } grid.rect(xx, yy, width=w, height=h, default.units="native", gp=gpar(col=fg, fill=bg, lty=par$lty, lwd=par$lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("symbols-thermo-box")) grid.rect(unit(xx, "native"), unit(yy, "native") - (1 - 2*p[, 3])*0.5*h, width=w, height=(p[, 3] - p[, 4])*h, just="top", gp=gpar(col=fg, fill=fg, lty=par$lty, lwd=par$lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("symbols-thermo-fill")) grid.segments(unit(xx, "native") + 0.5*w, unit(yy, "native"), unit(xx, "native") + 0.75*w, unit(yy, "native"), gp=gpar(col=par$col, lty=par$lty, lwd=par$lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("symbols-thermo-whisker-right")) grid.segments(unit(xx, "native") - 0.5*w, unit(yy, "native"), unit(xx, "native") - 0.75*w, unit(yy, "native"), gp=gpar(col=par$col, lty=par$lty, lwd=par$lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("symbols-thermo-whisker-left")) } else if (type == 6) { # boxplots prange <- range(p[, 1:4], na.rm=TRUE) if (inches > 0) { w <- unit(p[, 1]*inches/prange[2], "in") h <- unit(p[, 2]*inches/prange[2], "in") lw <- unit(p[, 3]*inches/prange[2], "in") uw <- unit(p[, 4]*inches/prange[2], "in") } else { w <- unit(p[, 1], "native") h <- unit(p[, 2], "native") lw <- convertHeight(unit(p[, 3], "native"), "in") uw <- convertHeight(unit(p[, 4], "native"), "in") } grid.rect(xx, yy, width=w, height=h, default.units="native", gp=gpar(col=par$col, lty=par$lty, lwd=par$lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("symbols-boxplot-box")) grid.segments(unit(xx, "native"), unit(yy, "native") - 0.5*h, unit(xx, "native"), unit(yy, "native") - 0.5*h - lw, gp=gpar(col=par$col, lty=par$lty, lwd=par$lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("symbols-boxplot-lower-whisker")) grid.segments(unit(xx, "native"), unit(yy, "native") + 0.5*h, unit(xx, "native"), unit(yy, "native") + 0.5*h + uw, gp=gpar(col=par$col, lty=par$lty, lwd=par$lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("symbols-boxplot-upper-whisker")) grid.segments(unit(xx, "native") - 0.5*w, unit(yy, "native") - (1 - 2*p[, 3])*0.5*h, unit(xx, "native") + 0.5*w, unit(yy, "native") - (1 - 2*p[, 3])*0.5*h, gp=gpar(col=par$col, lty=par$lty, lwd=par$lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("symbols-boxplot-median")) } upViewport(depth) } gridGraphics/R/text.R0000654000176200001440000000570613546730555014216 0ustar liggesusers # C_text(xy.coords, labels, adj, pos, offset, vfont, cex, col, font, ...) C_text <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:10)]) dev.set(playDev()) # TODO: handle 'pos', 'offset', 'vfont' depth <- gotovp(par$xpd) xx <- tx(x[[2]]$x, par) yy <- ty(x[[2]]$y, par) labels <- x[[3]] adj <- x[[4]] just <- just(adj, par) adjx <- just[1] adjy <- just[2] pos <- x[[5]] offset <- unit(x[[6]]*par$cin[2]*par$cex, "in") ## NULL label generates no grob if (!is.null(labels)) { if (!is.null(pos)) { n <- length(labels) pos <- rep(pos, length.out=n) adjx <- rep(0.5, length.out=n) # 0.3333 = yCharOffset adjy <- rep(0.3333, length.out=n) xx <- rep(xx, length.out=n) yy <- rep(yy, length.out=n) xx[pos == 2] <- xx - convertWidth(offset, "native", valueOnly=TRUE) xx[pos == 4] <- xx + convertWidth(offset, "native", valueOnly=TRUE) yy[pos == 1] <- yy - convertHeight(offset, "native", valueOnly=TRUE) yy[pos == 3] <- yy + convertHeight(offset, "native", valueOnly=TRUE) adjx[pos == 2] <- 1 adjx[pos == 4] <- 0 adjy[pos == 1] <- 1 - (0.5 - 0.3333) adjy[pos == 3] <- 0 } vfont <- x[[7]] cex <- FixupCex(x[[8]]*par$cex, 1) cex <- ifelse(is.na(cex), par$cex, cex) col <- FixupCol(x[[9]], NA, par$bg) col <- ifelse(is.na(col), par$col, col) font <- FixupFont(x[[10]], NA) font <- ifelse(is.na(font), par$font, font) family <- par$family if (!is.null(vfont) && !is.language(labels)) { # Override 'font' and 'family' font <- vfont[2] family <- mapVfont(vfont[1]) } ## Protect against NA labels labels[is.na(labels)] <- "" grid.text(labels, xx, yy, default.units="native", hjust=adjx, vjust=adjy, rot=par$srt, gp=gpar(cex=cex, col=col, fontface=font, fontfamily=family, lineheight=par$lheight), name=grobname("text")) } upViewport(depth) } just <- function(adj, par) { if (is.null(adj) || length(adj) == 0) { adjx <- par$adj adjy <- NA } else { if (length(adj) == 1) { adjx <- adj adjy <- NA } else { adjx <- adj[1] adjy <- adj[2] } } c(adjx, adjy) } mapVfont <- function(vfont) { switch(vfont, "serif"="HersheySerif", "sans serif"="HersheySans", "script"="HersheyScript", "gothic english"="HersheyGothicEnglish", "gothic german"="HersheyGothicGerman", "gothic italian"="HersheyGothicItalian", "serif symbol"="HersheySymbol", "sans serif symbol"="HersheySansSymbol") } gridGraphics/R/identify.R0000654000176200001440000000215612432510505015021 0ustar liggesusers C_identify <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:9)]) dev.set(playDev()) depth <- gotovp(par$xpd) index <- x[[2]] pos <- x[[3]] xx <- unit(x[[4]], "native") yy <- unit(x[[5]], "native") offset <- unit(x[[6]]*par$cin[2]*par$cex, "in") label <- x[[7]] draw <- x[[8]] for (i in seq_along(xx)) { xxx <- switch(pos[i] + 1, xx[i], xx[i], xx[i] - offset, xx[i], xx[i] + offset) yyy <- switch(pos[i] + 1, yy[i], yy[i] - offset, yy[i], yy[i] + offset, yy[i]) xadj <- switch(pos[i] + 1, 0, 0.5, 1, 0.5, 0) # 0.3333 comes from dev->yCharOffset yadj <- switch(pos[i] + 1, 0, 1 - (0.5 - 0.3333), 0.3333, 0, 0.3333) if (index[i] && draw) { grid.text(label, xxx, yyy, default.units="native", hjust=xadj, vjust=yadj, gp=gpar(cex=par$cex, col=par$col, fontface=par$font, fontfamily=par$family, lineheight=par$lheight)) } } upViewport(depth) } gridGraphics/R/xspline.R0000654000176200001440000000155712427775362014716 0ustar liggesusers # C_xspline(x, y, s, open, repEnds, draw, col, border, ...) # TODO: handle NA's in x and/or y (see polygon.R) C_xspline <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:9)]) dev.set(playDev()) depth <- gotovp(par$xpd) xx <- tx(x[[2]], par) yy <- ty(x[[3]], par) s <- x[[4]] open <- x[[5]] repEnds <- x[[6]] draw <- x[[7]] col <- FixupCol(x[[8]], NA, par$bg) border <- FixupCol(x[[9]], par$fg, par$bg) if (draw) { grid.xspline(xx, yy, default.units="native", shape=s, open=open, repEnds=repEnds, gp=gpar(col=border, fill=col, lwd=par$lwd, lty=par$lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("xspline")) result <- NULL } upViewport(depth) } gridGraphics/R/rect.R0000654000176200001440000000162412432212071014137 0ustar liggesusers # C_rect(xleft, ybottom, xright, ytop, col, border, lty, lwd, ...) C_rect <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:9)]) dev.set(playDev()) depth <- gotovp(par$xpd) xleft <- tx(x[[2]], par) ybottom <- ty(x[[3]], par) xright <- tx(x[[4]], par) ytop <- ty(x[[5]], par) col <- FixupCol(x[[6]], NA, par$bg) border <- FixupCol(x[[7]], par$fg, par$bg) lty <- FixupLty(x[[8]], par$lty) lty <- ifelse(is.na(lty), par$lty, lty) lwd <- FixupLwd(x[[9]], par$lwd) lwd <- ifelse(is.na(lwd), par$lwd, lwd) grid.rect(xleft, ybottom, xright - xleft, ytop - ybottom, default.units="native", just=c("left", "bottom"), gp=gpar(col=border, fill=col, lty=lty, lwd=lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("rect")) upViewport(depth) } gridGraphics/R/graphics.R0000654000176200001440000001114413572017306015012 0ustar liggesusers dlDispatch <- function(x) { switch(x[[2]][[1]]$name, C_abline = C_abline(x[[2]]), C_plot_new = C_plot_new(x[[2]]), palette = C_palette(x[[2]]), palette2 = C_palette2(x[[2]]), C_plot_window = C_plot_window(x[[2]]), C_plotXY = C_plotXY(x[[2]]), C_axis = C_axis(x[[2]]), C_box = C_box(x[[2]]), C_title = C_title(x[[2]]), C_polygon = C_polygon(x[[2]]), C_text = C_text(x[[2]]), C_segments = C_segments(x[[2]]), C_rect = C_rect(x[[2]]), C_mtext = C_mtext(x[[2]]), C_arrows = C_arrows(x[[2]]), C_par = C_par(x[[2]]), C_image = C_image(x[[2]]), C_clip = C_clip(x[[2]]), C_xspline = C_xspline(x[[2]]), C_path = C_path(x[[2]]), C_raster = C_raster(x[[2]]), C_identify = C_identify(x[[2]]), C_symbols = C_symbols(x[[2]]), # These only partially supported C_contour = C_contour(x[[2]]), C_persp = C_persp(x[[2]]), C_filledcontour = C_filledcontour(x[[2]]), C_dend = C_dend(x[[2]]), C_dendwindow = C_dendwindow(x[[2]]), # These are ignored C_strWidth = NULL, C_strHeight = NULL, # Only affects next plot.new() that starts a new page # (so not relevant to current page) # (BUT may be on display list, e.g., as wrap-up of plot function) C_layout = NULL, warning("unsupported operation on the graphics display list")) } offscreen <- function(width, height) { pdf(NULL, width=width, height=height) dev.control("enable") } grid.echo <- function(x=NULL, newpage=TRUE, prefix=NULL, device=offscreen) { UseMethod("grid.echo") } grid.echo.default <- function(x=NULL, newpage=TRUE, prefix=NULL, device=offscreen) { if (!is.null(x)) { stop("Invalid graphics display list") } if (is.null(dev.list())) { stop("No graphics device") } grid.echo(recordPlot(), newpage, prefix, device) } grid.echo.recordedplot <- function(x=NULL, newpage=TRUE, prefix=NULL, device=offscreen) { assign("newpage", newpage, .gridGraphicsEnv) if (!is.null(prefix)) { op <- prefix() setPrefix(prefix) on.exit(setPrefix(op)) } if (newpage) { width <- NULL height <- NULL } else { width <- convertWidth(unit(1, "npc"), "in", valueOnly=TRUE) height <- convertHeight(unit(1, "npc"), "in", valueOnly=TRUE) } init(x, width, height, device) if (is.null(x[[1]][[2]])) { warning("No graphics to replay") } ## Make sure we clean up if we error out during DL replay ## (or once we have finished echoing) on.exit(shutdown()) lapply(x[[1]], dlDispatch) invisible() } grid.echo.function <- function(x=NULL, newpage=TRUE, prefix=NULL, device=offscreen) { if (newpage) { if (dev.cur() == 1) { width <- 7 height <- 7 } else { din <- par("din") width <- din[1] height <- din[2] } } else { width <- convertWidth(unit(1, "npc"), "in", valueOnly=TRUE) height <- convertHeight(unit(1, "npc"), "in", valueOnly=TRUE) } cd <- dev.cur() device(width, height) echod <- dev.cur() ## Make sure that the device is closed if running x() errors out on.exit({ dev.set(echod) dev.off() ## If we started with no Device, do not try to go back ## (that would open yet another device) if (cd > 1) dev.set(cd) }) x() dl <- recordPlot() ## Switch back to device we are echoing on dev.set(cd) grid.echo(dl, newpage, prefix) invisible() } ## The relationship between grid.echo() and echoGrob() is backwards ## compared to most grid.*()/*Grob() pairs. ## grid.echo() is the one that does the real work and echoGrob() ## just calls grid.echo() (eventually) echoGrob <- function(x=NULL, prefix=NULL, device=offscreen, name=NULL) { gTree(x=x, prefix=prefix, device=device, name=name, cl="echogrob") } makeContent.echogrob <- function(x) { width <- convertWidth(unit(1, "npc"), "in", valueOnly=TRUE) height <- convertHeight(unit(1, "npc"), "in", valueOnly=TRUE) grobs <- grid.grabExpr(grid.echo(x$x, newpage=FALSE, x$prefix, x$device), width=width, height=height, device=x$device, name=x$name) setChildren(x, gList(grobs)) } gridGraphics/R/arrows.R0000654000176200001440000000161212427775350014536 0ustar liggesusers # arrows(x0, y0, x1, y1, length, angle, code, col, lty, lwd, ...) C_arrows <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:11)]) dev.set(playDev()) depth <- gotovp(par$xpd) x0 <- tx(x[[2]], par) y0 <- ty(x[[3]], par) x1 <- tx(x[[4]], par) y1 <- ty(x[[5]], par) length <- x[[6]] angle <- x[[7]] code <- x[[8]] col <- FixupCol(x[[9]], NA, par$bg) lty <- FixupLty(x[[10]], par$lty) lwd <- FixupLwd(x[[11]], par$lwd) grid.segments(x0, y0, x1, y1, default.units="native", gp=gpar(col=col, lty=lty, lwd=lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), arrow=arrow(angle=angle, length=unit(length, "in"), ends=switch(code, "first", "last", "both")), name=grobname("arrows")) upViewport(depth) } gridGraphics/R/path.R0000654000176200001440000000137312427775251014161 0ustar liggesusers # C_path(x, y, lengths, rule, col, border, lty, ...) C_path <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:8)]) dev.set(playDev()) depth <- gotovp(par$xpd) xx <- tx(x[[2]], par) yy <- ty(x[[3]], par) lengths <- x[[4]] rule <- x[[5]] col <- FixupCol(x[[6]], NA, par$bg) border <- FixupCol(x[[7]], par$fg, par$bg) lty <- FixupLty(x[[8]], par$lty) lty <- ifelse(is.na(lty), par$lty, lty) grid.path(xx, yy, default="native", id.lengths=lengths, rule=rule, gp=gpar(col=border, fill=col, lty=lty, lwd=par$lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("path")) upViewport(depth) } gridGraphics/R/clip.R0000654000176200001440000000361612430542654014147 0ustar liggesusers # C_clip(x1, x2, y1, y2) # Just record this clipping setting and enforce it whenever subsequently # descend into window viewport C_clip <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:5)]) dev.set(playDev()) x1 <- tx(x[[2]], par) x2 <- tx(x[[3]], par) y1 <- ty(x[[4]], par) y2 <- ty(x[[5]], par) setClip(x1, y1, x2 - x1, y2 - y1) } # Navigate to the correct viewport based on 'xpd' setting # End up in either "plot" or "window" viewport gotovp <- function(xpd, end="window") { root <- vpname("root") inner <- vpname("inner") if (is.na(xpd)) { figure <- vpname("figure") plot <- vpname("plot") window <- vpname("window") windowplot <- vpname("windowplot") } else if (xpd) { figure <- vpname("figure", clip=TRUE) plot <- vpname("plot") window <- vpname("window") windowplot <- vpname("windowplot") } else { figure <- vpname("figure") plot <- vpname("plot", clip=TRUE) window <- vpname("window") windowplot <- vpname("windowplot", clip=TRUE) } # NOTE that the "window" vp goes via a separate "window" "plot" vp # so that box() can go to one "plot" vp and text() et al can # go to a different "plot" vp (e.g., following a par(mar)) path <- switch(end, window=vpPath(root, inner, figure, windowplot, window), plot=vpPath(root, inner, figure, plot), figure=vpPath(root, inner, figure), inner=vpPath(root, inner), outer=vpPath(root)) depth <- downViewport(path, strict=TRUE) if (end == "window" && !is.null(clipRegion <- getClip())) { grid.clip(clipRegion[1], clipRegion[2], clipRegion[3], clipRegion[4], default.units="native", just=c("left", "bottom"), name=grobname("clip")) } depth } gridGraphics/R/mtext.R0000654000176200001440000001600113467113735014356 0ustar liggesusers # C_mtext(text, side, line, outer, at, adj, padj, cex, col, font, ...) */ C_mtext <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:11)]) dev.set(playDev()) text <- x[[2]] side <- x[[3]] line <- x[[4]] outer <- x[[5]] adj <- ComputeAdjValue(x[[7]], side, par$las) at <- ComputeAtValue(x[[6]], adj, side, par$las) padj <- ComputePAdjValue(x[[8]], side, par$las) # NOTE: default is not par$cex, but 1.0 # NOTE: yes, mtext() really does override 'col=NA', 'cex=NA', and 'font=NA' cex <- FixupCex(x[[9]], 1) # NOTE: deliberately reverse any auto scaling of 0.66 or 0.83 cex <- ifelse(is.finite(cex), cex, unadjustedCex(par)) col <- FixupCol(x[[10]], NA, par$bg) col <- ifelse(is.na(col), par$col, col) font <- FixupFont(x[[11]], par$font) font <- ifelse(is.na(font), par$font, font) if (outer) { depth <- gotovp(NA, "inner") } else { # NOTE: there is a bug in C_mtext() in plot.c where it checks # "if (outer)" when 'outer' is still an SEXP, so the # result is ALWAYS TRUE, so xpd is ALWAYS set to 2 depth <- gotovp(NA, "window") # depth <- gotovp(if (is.na(par$xpd)) NA else TRUE, "window") } name <- paste0("mtext-", switch(side, "bottom", "left", "top", "right")) if (outer) name <- paste(name, "outer", sep="-") ## Allow 'gridGraphics' to be used pre-R 3.6.0, warts and all GMtext(text, side, line, outer, at, las=par$las, xadj=adj, yadj=padj, mex=par$mex, cin=par$cin, cex=cex, linecex=par$cex, font=font, family=par$family, col=col, lheight=par$lheight, par$ylbias, label=name) upViewport(depth) } # Helpers for C_mtext() unadjustedCex <- function(par) { # If par(mfrow/mfcol) is exactly 2x2 then there is a 0.83 scaling # If it is more than 3 in either dimension there is a 0.66 scaling # We want to reverse that scaling here nr <- par$mfrow[1] nc <- par$mfrow[2] if (nr == 2 && nc == 2) { par$cex/0.83 } else if (nr > 2 || nc > 2) { par$cex/0.66 } else { par$cex } } ComputeAdjValue <- function(adj, side, las) { if (is.finite(adj)) { adj } else { switch(las + 1, # las = 0 0.5, # las = 1 switch(side, 0.5, 1, 0.5, 0), # las = 2 switch(side, 1, 1, 0, 0), # las = 3 switch(side, 1, 0.5, 0, 0.5)) } } ComputePAdjValue <- function(padj, side, las) { if (is.finite(padj)) { padj } else { switch(las+ 1, # las = 0 0, # las = 1 switch(side, 0, 0.5, 0, 0.5), # las = 2 0.5, # las = 3 switch(side, 0.5, 0, 0.5, 0)) } } ComputeAtValue <- function(at, adj, side, las) { if (any(is.finite(at))) { unit(at, "native") } else { # If the text is parallel to the axis, use "adj" for "at" # Otherwise, centre the text unit(switch(las + 1, # parallel to axis adj, # horizontal switch(side, adj, 0.5, adj, 0.5), # perpendicular to axis 0.5, # vertical switch(side, 0.5, adj, 0.5, adj)), "npc") } } # Code to centralise the work that GMtext() does to mess around with # the (x, y) locations that it is sent # (so that those fiddly adjustments are not reproduced all over the place) # NOTE that 'mgp' is in 'mex' units # NOTE we use par("cin") rather than 'grid' "lines" # NOTE that 'linecex' attempts to capture the fact that line height is based # on 'mex'*'cexbase' NOT 'cex'*'cexbase' GMtext <- function(str, side, line, outer=FALSE, at, las, xadj, yadj, mex, cin, cex, linecex, font, family, col, lheight, yLineBias, allowOverlap=TRUE, label) { if (getRversion() < "3.6.0") { return(old_GMtext(str, side, line, outer, at, las, xadj, yadj, mex, cin, cex, linecex, font, family, col, lheight, yLineBias, allowOverlap, label)) } if (side == 1) { if (las == 2 || las == 3) { angle <- 90 } else { line <- line + 1/mex*(1 - yLineBias) angle <- 0 } x <- at y <- unit(-grconvertY(line, "lines", "in"), "in") } else if (side == 2) { if(las == 1 || las == 2) { angle <- 0 } else { line <- line + 1/mex*yLineBias angle <- 90 } x <- unit(-grconvertX(line, "lines", "in"), "in") y <- at } else if (side == 3) { if(las == 2 || las == 3) { angle <- 90 } else { line <- line + 1/mex*yLineBias angle <- 0 } x <- at y <- unit(1, "npc") + unit(grconvertY(line, "lines", "in"), "in") } else if (side == 4) { if(las == 1 || las == 2) { angle <- 0 } else { line <- line + 1/mex*(1 - yLineBias) angle <- 90 } x <- unit(1, "npc") + unit(grconvertX(line, "lines", "in"), "in") y <- at } else { stop("Invalid 'side'") } grid.text(str, x, y, hjust=xadj, vjust=yadj, rot=angle, gp=gpar(cex=cex, fontface=font, fontfamily=family, col=col, lineheight=lheight), check.overlap=!allowOverlap, name=grobname(label)) } ################################################################################ ## Version of GMtext() that does not depend on R 3.6.0 features old_GMtext <- function(str, side, line, outer=FALSE, at, las, xadj, yadj, mex, cin, cex, linecex, font, family, col, lheight, yLineBias, allowOverlap=TRUE, label) { if (side == 1) { if (las == 2 || las == 3) { angle <- 90 } else { line <- line + 1/mex*(1 - yLineBias) angle <- 0 } x <- at y <- unit(-line*cin[2]*linecex, "in") } else if (side == 2) { if(las == 1 || las == 2) { angle <- 0 } else { line <- line + 1/mex*yLineBias angle <- 90 } x <- unit(-line*cin[2]*linecex, "in") y <- at } else if (side == 3) { if(las == 2 || las == 3) { angle <- 90 } else { line <- line + 1/mex*yLineBias angle <- 0 } x <- at y <- unit(1, "npc") + unit(line*cin[2]*linecex, "in") } else if (side == 4) { if(las == 1 || las == 2) { angle <- 0 } else { line <- line + 1/mex*(1 - yLineBias) angle <- 90 } x <- unit(1, "npc") + unit(line*cin[2]*linecex, "in") y <- at } else { stop("Invalid 'side'") } grid.text(str, x, y, hjust=xadj, vjust=yadj, rot=angle, gp=gpar(cex=cex, fontface=font, fontfamily=family, col=col, lineheight=lheight), check.overlap=!allowOverlap, name=grobname(label)) } gridGraphics/R/segments.R0000654000176200001440000000130112427775161015041 0ustar liggesusers # C_segments(x0, y0, x1, y1, col=col, lty=lty, lwd=lwd, ...) C_segments <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:8)]) dev.set(playDev()) depth <- gotovp(par$xpd) x0 <- tx(x[[2]], par) y0 <- ty(x[[3]], par) x1 <- tx(x[[4]], par) y1 <- ty(x[[5]], par) col <- FixupCol(x[[6]], NA, par$bg) lty <- FixupLty(x[[7]], par$lty) lwd <- FixupLwd(x[[8]], par$lwd) grid.segments(x0, y0, x1, y1, default.units="native", gp=gpar(col=col, lty=lty, lwd=lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("segments")) upViewport(depth) } gridGraphics/R/raster.R0000654000176200001440000000130012424313603014475 0ustar liggesusers # C_raster(image, xl, yb, xr, yt, angle, interpolate, ...) C_raster <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:8)]) dev.set(playDev()) depth <- gotovp(par$xpd) image <- x[[2]] xl <- tx(x[[3]], par) yb <- ty(x[[4]], par) xr <- tx(x[[5]], par) yt <- ty(x[[6]], par) angle <- x[[7]] interpolate <- x[[8]] pushViewport(viewport(xl, yb, xr - xl, yt - yb, default.units="native", just=c("left", "bottom"), angle=angle, name=grobname("raster-vp"))) grid.raster(image, width=1, height=1, interpolate=interpolate, name=grobname("raster")) upViewport(depth + 1) } gridGraphics/R/plot.new.R0000654000176200001440000000701712432465236014767 0ustar liggesusers C_plot_new <- function(x) { # recordDev dev.set(recordDev()) page <- par("page") plot.new() par <- par() # playDev dev.set(playDev()) initFigureAlpha() incrementPlotIndex() initPlotAlpha() initWindowIndex() initWindowAlpha() initWindowPlotAlpha() initClip() nvp <- 0 if (page) { if (get("newpage", .gridGraphicsEnv)) grid.newpage() # If there is a non-transparent par(bg) in effect, we need # to draw an opaque background rect if (par$bg != "transparent") { grid.rect(width=1.5, height=1.5, gp=gpar(col=NA, fill=par$bg), name=grobname("background", unique=TRUE)) } pushViewport(viewport(# gp=gparFromPar(par[gparParNames]), name=vpname("root"))) upViewport() setUpInner(par) } else { setUpFigure(par) } } setUpInner <- function(par) { omi <- par$omi innervp <- viewport(x=unit(omi[2], "inches"), y=unit(omi[1], "inches"), width=unit(1, "npc") - unit(omi[2], "inches") - unit(omi[4], "inches"), height=unit(1, "npc") - unit(omi[1], "inches") - unit(omi[3], "inches"), just=c("left", "bottom"), name=vpname("inner")) downViewport(vpname("root"), strict=TRUE) pushViewport(innervp) upViewport(2) setUpFigure(par) } setUpFigure <- function(par) { fig <- par$fig figurevp <- viewport(x=unit(fig[1], "npc"), y=unit(fig[3], "npc"), width=unit(fig[2] - fig[1], "npc"), height=unit(fig[4] - fig[3], "npc"), just=c("left", "bottom"), name=vpname("figure")) figurevpclip <- viewport(x=unit(fig[1], "npc"), y=unit(fig[3], "npc"), width=unit(fig[2] - fig[1], "npc"), height=unit(fig[4] - fig[3], "npc"), just=c("left", "bottom"), clip=TRUE, name=vpname("figure", clip=TRUE)) downViewport(vpPath(vpname("root"), vpname("inner")), strict=TRUE) pushViewport(figurevp) upViewport() pushViewport(figurevpclip) upViewport(3) setUpPlot(par) } setUpPlot <- function(par) { plt <- par$plt plotvp <- viewport(x=unit(plt[1], "npc"), y=unit(plt[3], "npc"), width=unit(plt[2] - plt[1], "npc"), height=unit(plt[4] - plt[3], "npc"), just=c("left", "bottom"), name=vpname("plot")) plotvpclip <- viewport(x=unit(plt[1], "npc"), y=unit(plt[3], "npc"), width=unit(plt[2] - plt[1], "npc"), height=unit(plt[4] - plt[3], "npc"), just=c("left", "bottom"), clip=TRUE, name=vpname("plot", clip=TRUE)) downViewport(vpPath(vpname("root"), vpname("inner"), vpname("figure")), strict=TRUE) pushViewport(plotvp) upViewport(1) pushViewport(plotvpclip) upViewport(2) downViewport(vpname("figure", clip=TRUE), strict=TRUE) pushViewport(plotvp) upViewport(4) setUpUsr(par$usr) } gridGraphics/R/core.R0000654000176200001440000001271213256041705014143 0ustar liggesusers .gridGraphicsEnv <- new.env() init <- function(dl, width=NULL, height=NULL, device) { if (dev.cur() == 1) { dev.new() } # The graphics device we will draw onto assign("pd", dev.cur(), .gridGraphicsEnv) din <- par("din") if (is.null(width)) width <- din[1] if (is.null(height)) height <- din[2] # An off-screen graphics device device(width, height) assign("rd", dev.cur(), .gridGraphicsEnv) # NULL out the saved display list then replay it in order # to restore basic graphics settings (like device background) dlStub <- dl dlStub[1] <- list(NULL) replayPlot(dlStub) # Go back to device we will draw onto dev.set(playDev()) initInnerAlpha() initFigureAlpha() initPlotIndex() initPlotAlpha() initWindowIndex() initWindowAlpha() initWindowPlotAlpha() initClip() # Remove any grobname indices rm(list=ls(envir=.gridGraphicsEnv, pattern=".gridGraphicsIndex$"), envir=.gridGraphicsEnv) } shutdown <- function() { # Close the off-screen graphics device dev.set(recordDev()) dev.off() # Make sure we go back to the device we are replaying onto dev.set(playDev()) invisible() } initClip <- function() { assign("currentClip", NULL, .gridGraphicsEnv) } setClip <- function(x, y, w, h) { assign("currentClip", c(x, y, w, h), .gridGraphicsEnv) } getClip <- function() { get("currentClip", .gridGraphicsEnv) } playDev <- function() { get("pd", .gridGraphicsEnv) } recordDev <- function() { get("rd", .gridGraphicsEnv) } indexFuns <- function() { index <- 0 init <- function() { index <<- 0 } increment <- function() { index <<- index + 1 } get <- function() { index } list(init=init, increment=increment, get=get) } pif <- indexFuns() initPlotIndex <- pif$init incrementPlotIndex <- pif$increment plotIndex <- pif$get wif <- indexFuns() initWindowIndex <- wif$init incrementWindowIndex <- wif$increment windowIndex <- wif$get alphaIndexFuns <- function() { index <- 0 init <- function() { index <<- 0 } increment <- function() { index <<- index + 1 } get <- function() { if (index == 0) { "" } else { paste(rep(LETTERS[(index - 1) %% 26 + 1], (index - 1) %/% 26 + 1), collapse="") } } set <- function(x) { if (x == "") { index <<- 0 } else { n <- nchar(x) chars <- rev(strsplit(x, "")[[1]]) index <<- sum(sapply(chars, function(y) which(LETTERS == y))) } } list(init=init, increment=increment, get=get, set=set) } iiaf <- alphaIndexFuns() initInnerAlpha <- iiaf$init incrementInnerAlpha <- iiaf$increment innerAlpha <- iiaf$get fiaf <- alphaIndexFuns() initFigureAlpha <- fiaf$init incrementFigureAlpha <- fiaf$increment figureAlpha <- fiaf$get piaf <- alphaIndexFuns() initPlotAlpha <- piaf$init incrementPlotAlpha <- piaf$increment plotAlpha <- piaf$get wiaf <- alphaIndexFuns() initWindowAlpha <- wiaf$init incrementWindowAlpha <- wiaf$increment windowAlpha <- wiaf$get wpiaf <- alphaIndexFuns() initWindowPlotAlpha <- wpiaf$init windowPlotAlpha <- wpiaf$get setWindowPlotAlpha <- wpiaf$set prefixFuns <- function() { prefix <- "graphics" get <- function() { prefix } set <- function(x) { prefix <<- as.character(x) } list(get=get, set=set) } pf <- prefixFuns() prefix <- pf$get setPrefix <- pf$set grobname <- function(label, unique=FALSE) { if (unique) { paste(prefix(), label, sep="-") } else { stub <- paste(prefix(), "plot", plotIndex(), label, sep="-") indexName <- paste0(stub, ".gridGraphicsIndex") if (exists(indexName, .gridGraphicsEnv)) { index <- get(indexName, .gridGraphicsEnv) } else { index <- 1 } assign(indexName, index + 1, .gridGraphicsEnv) paste(stub, index, sep="-") } } vpname <- function(type, clip=FALSE) { switch(type, root=paste(prefix(), type, sep="-"), inner=paste(prefix(), paste0(type, innerAlpha()), sep="-"), figure={ if (clip) { paste(prefix(), type, paste0(plotIndex(), figureAlpha()), "clip", sep="-") } else { paste(prefix(), type, paste0(plotIndex(), figureAlpha()), sep="-") } }, plot={ if (clip) { paste(prefix(), type, paste0(plotIndex(), plotAlpha()), "clip", sep="-") } else { paste(prefix(), type, paste0(plotIndex(), plotAlpha()), sep="-") } }, window=paste(prefix(), type, plotIndex(), paste0(windowIndex(), windowAlpha()), sep="-"), # NOTE that the "window" "plot" vp uses a potentially different # alpha than the "plot" vp (see clip.R for why) windowplot={ if (clip) { paste(prefix(), "plot", paste0(plotIndex(), windowPlotAlpha()), "clip", sep="-") } else { paste(prefix(), "plot", paste0(plotIndex(), windowPlotAlpha()), sep="-") } }) } gridGraphics/R/abline.R0000654000176200001440000000476412432451274014456 0ustar liggesusers # C_abline(a, b, h, v, untf, col, lty, lwd, ...) C_abline <- function(x) { # TODO: handle 'untf' dev.set(recordDev()) par <- currentPar(x[-(1:9)]) dev.set(playDev()) depth <- gotovp(par$xpd) a <- x[[2]] b <- x[[3]] h <- ty(x[[4]], par) v <- tx(x[[5]], par) untf <- x[[6]] col <- FixupCol(x[[7]], NA, par$bg) lty <- FixupLty(x[[8]], par$lty) lwd <- FixupLwd(x[[9]], par$lwd) if (!is.null(a)) { if (is.null(b)) { a <- a[1] b <- a[2] } xx <- par$usr[1:2] if (untf && (par$xlog || par$ylog)) { # Draw a curve instead of straight line NS <- 100 if (par$xlog) { xx <- 10^xx xf <- xx[2]/.Machine$double.xmax xxx <- xx[1] <- max(xx[1], 1.01*xf) xf <- (xx[2]/xx[1])^(1/NS) xxx <- xxx*xf^(0:(NS - 1)) xxx[NS + 1] <- xx[2] } else { xstep <- (xx[2] - xx[1])/NS xxx <- seq(xx[1], xx[2], xstep) } yyy <- b*xxx + a if (par$xlog) { xxx <- log10(xxx) # xxx[xxx <= 0] <- NA } if (par$ylog) { yyy <- log10(yyy) # yyy[yyy <= 0] <- NA } xx <- xxx yy <- yyy } else { # If 'xlog' then par$usr is already "logged" # ditto for 'ylog' yy <- a + b*xx } # TODO: this will have to be smarter to handle drawing outside # the plot region grid.lines(xx, yy, default.units="native", gp=gpar(col=col, lty=lty, lwd=lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("abline-ab")) } if (!is.null(h)) { grid.segments(0, unit(h, "native"), 1, unit(h, "native"), gp=gpar(col=col, lty=lty, lwd=lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("abline-h")) } if (!is.null(v)) { grid.segments(unit(v, "native"), 0, unit(v, "native"), 1, gp=gpar(col=col, lty=lty, lwd=lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("abline-v")) } upViewport(depth) } gridGraphics/R/box.R0000654000176200001440000000625413265737655014027 0ustar liggesusers # C_box(which, lty, ...) C_box <- function(x) { dev.set(recordDev()) # NOTE: although 'lty' is passed in, it is not explicitly handled par <- currentPar(x[-(1:2)]) ## If specified non-NA or non-NULL 'col' use that inlineCol <- getInlinePar(x[-(1:2)], "col") if (!is.null(inlineCol) && !is.na(inlineCol[1])) { par$col <- inlineCol } else { ## Else if specified non-NA or non-NULL 'fg' use that inlineFg <- getInlinePar(x[-(1:2)], "fg") if (!is.null(inlineFg) && !is.na(inlineFg[1])) { par$col <- inlineFg } else { ## Else use par("col") par$col <- par("col") } } dev.set(playDev()) which <- x[[2]] if (which == 1) { # "plot" depth <- gotovp(NA, "plot") # NOTE: copy GBox which draws *polygon* (not rect) AND # explicitly sets fill to NA xy <- switch(par$bty, "o"=, "O"=list(x=c(0, 1, 1, 0), y=c(0, 0, 1, 1)), "l"=, "L"=list(x=c(0, 0, 1), y=c(1, 0, 0)), "7"=list(x=c(0, 1, 1), y=c(1, 1, 0)), "c"=, "C"=, "["=list(x=c(1, 0, 0, 1), y=c(1, 1, 0, 0)), "]"=list(x=c(0, 1, 1, 0), y=c(1, 1, 0, 0)), "u"=, "U"=list(x=c(0, 0, 1, 1), y=c(1, 0, 0, 1))) if (par$bty %in% c("n", "N")) { # do nothing } else if (par$bty %in% c("o", "O")) { grid.polygon(xy$x, xy$y, gp=gpar(col=par$col, lty=par$lty, lwd=par$lwd, fill=NA, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("box")) } else { grid.lines(xy$x, xy$y, gp=gpar(col=par$col, lty=par$lty, lwd=par$lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("box")) } } else if (which == 2) { # "figure" depth <- gotovp(NA, "figure") grid.polygon(c(0, 1, 1, 0), c(0, 0, 1, 1), gp=gpar(col=par$col, lty=par$lty, lwd=par$lwd, fill=NA, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("box-figure")) } else if (which == 3) { # "inner" depth <- gotovp(NA, "inner") grid.polygon(c(0, 1, 1, 0), c(0, 0, 1, 1), gp=gpar(col=par$col, lty=par$lty, lwd=par$lwd, fill=NA, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("box-inner")) } else { # "outer" depth <- gotovp(NA, "outer") grid.polygon(c(0, 1, 1, 0), c(0, 0, 1, 1), gp=gpar(col=par$col, lty=par$lty, lwd=par$lwd, fill=NA, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("box-outer")) } upViewport(depth) } gridGraphics/R/axis.R0000654000176200001440000007062113467115011014156 0ustar liggesusers # C_axis(side, at, labels, # tick, line, pos, outer, font, lty, lwd, lwd.ticks, col, # col.ticks, hadj, padj, ...) C_axis <- function(x) { ## Allow 'gridGraphics' to be used pre-R 3.6.0, warts and all if (getRversion() < "3.6.0") { ## Empty definition to satisfy R CMD check (pre-R 3.6.0) deviceLoc <- function(x, y, valueOnly) {} return(old_C_axis(x)) } dev.set(recordDev()) # Blank out x$cex because we want par$cex to be par$cexbase x$cex <- NULL par <- currentPar(x[-(1:16)]) dev.set(playDev()) depth <- gotovp(NA) side <- x[[2]] if (is.null(x[[3]])) { ticks <- defaultTicks(side, par) } else { ticks <- x[[3]] } labels <- x[[4]] doticks <- x[[5]] if (is.na(doticks)) doticks <- TRUE # [1] to guard against 'line' vector of length > 1 line <- x[[6]][1] pos <- x[[7]] # Not sure on the logic of the following, just emulating C code lineoff <- 0 if (!is.finite(line)) { line <- par$mgp[3] lineoff <- line } if (is.finite(pos)) lineoff <- 0 outer <- x[[8]] font <- FixupFont(x[[9]], NA) lty <- FixupLty(x[[10]], 0) lwd <- FixupLwd(x[[11]], 1) lwd.ticks <- FixupLwd(x[[12]], 1) col <- FixupCol(x[[13]], par$fg, par$bg) col.ticks <- FixupCol(x[[14]], col, par$bg) hadj <- x[[15]] padj <- x[[16]] # NOTE: the use of 'trim=TRUE' in format() to mimic use of, # e.g., EncodeReal0(), within labelformat() in plot.c if (is.null(labels)) { drawLabels <- TRUE labels <- format(ticks, trim=TRUE) } else if (is.logical(labels)) { if (labels) { drawLabels <- TRUE labels <- format(ticks, trim=TRUE) } else { drawLabels <- FALSE } } else { drawLabels <- TRUE } if (is.finite(par$tck)) { if (par$tck > 0.5) { tickLength <- unit(par$tck, "npc") } else { tickLength <- min(convertWidth(unit(par$tck, "npc"), "in"), convertHeight(unit(par$tck, "npc"), "in")) } } else { tickLength <- unit(grconvertX(par$tcl, "lines", "in"), "in") } ## font is 'font' arg if not NA, otherwise par("font.axis") if (is.na(font)) { font <- par$font.axis } if (side == 1 && par$xaxt != "n") { if (is.finite(pos)) { axis_base <- unit(pos, "native") } else { if (outer) { coords <- "nic" } else { coords <- "npc" } ## It may be the case that the calculation of axis base ## is working off different plot region than the ## original plot (e.g., if par(mex) has been modified ## AFTER plotting) ## Also, grconvertY(..., "in") is inches on the device ## (NOT inches within the current viewport) ## That is why this calculation looks complicated axis_base <- unit(grconvertY(0, coords, "in") - deviceLoc(unit(0, "npc"), unit(0, "npc"), valueOnly=TRUE)$y - grconvertY(line, "lines", "in"), "in") } # Now that have generated tick labels from tick locations # (if necessary), can transform tick locations (if necessary) # for log transforms ticks <- tx(ticks, par) # Clip ticks (and labels) to plot boundaries if (par$usr[1] < par$usr[2]) { ticksub <- ticks >= par$usr[1] & ticks <= par$usr[2] } else { ticksub <- ticks <= par$usr[1] & ticks >= par$usr[2] } if (doticks) { if (lwd > 0) { grid.segments(unit(min(par$usr[2], max(par$usr[1], min(ticks))), "native"), axis_base, unit(min(par$usr[2], max(par$usr[1], max(ticks))), "native"), axis_base, gp=gpar(col=col, lwd=lwd, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("bottom-axis-line")) } if (lwd.ticks > 0) { grid.segments(unit(ticks[ticksub], "native"), axis_base, unit(ticks[ticksub], "native"), axis_base + tickLength, gp=gpar(col=col.ticks, lwd=lwd.ticks, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("bottom-axis-ticks")) } } # NOTE: the following includes calculation based on par(mgp) # to get the margin line to draw on # PLUS adjustment made in GMtext() based on that line value if (drawLabels) { axis_base_in <- convertY(axis_base, "in", valueOnly=TRUE) labLine <- - grconvertY(axis_base_in, "in", "lines") + par$mgp[2] - lineoff GMtext(labels[ticksub], 1, line=labLine, at=unit(ticks[ticksub], "native"), las=par$las, xadj=computeXAdj(hadj, side, par$las), yadj=computePAdj(padj, side, par$las), mex=par$mex, cin=par$cin, cex=par$cex.axis*par$cex, linecex=par$mex*par$cex, font=font, family=par$family, col=par$col.axis, lheight=par$lheight, yLineBias=par$ylbias, allowOverlap=FALSE, label="bottom-axis-labels") } } else if (side == 2 && par$yaxt != "n") { if (is.finite(pos)) { axis_base <- unit(pos, "native") } else { if (outer) { coords <- "nic" } else { coords <- "npc" } axis_base <- unit(grconvertX(0, coords, "in") - deviceLoc(unit(0, "npc"), unit(0, "npc"), valueOnly=TRUE)$x - grconvertX(line, "lines", "in"), "in") } ticks <- ty(ticks, par) if (par$usr[3] < par$usr[4]) { ticksub <- ticks >= par$usr[3] & ticks <= par$usr[4] } else { ticksub <- ticks <= par$usr[3] & ticks >= par$usr[4] } if (doticks) { if (lwd > 0) { grid.segments(axis_base, unit(min(par$usr[4], max(par$usr[3], min(ticks))), "native"), axis_base, unit(min(par$usr[4], max(par$usr[3], max(ticks))), "native"), gp=gpar(col=col, lwd=lwd, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("left-axis-line")) } if (lwd.ticks > 0) { grid.segments(axis_base, unit(ticks[ticksub], "native"), axis_base + tickLength, unit(ticks[ticksub], "native"), gp=gpar(col=col.ticks, lwd=lwd.ticks, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("left-axis-ticks")) } } if (drawLabels) { axis_base_in <- convertX(axis_base, "in", valueOnly=TRUE) labLine <- - grconvertX(axis_base_in, "in", "lines") + par$mgp[2] - lineoff GMtext(labels[ticksub], 2, line=labLine, at=unit(ticks[ticksub], "native"), las=par$las, xadj=computeXAdj(hadj, side, par$las), yadj=computePAdj(padj, side, par$las), mex=par$mex, cin=par$cin, cex=par$cex.axis*par$cex, linecex=par$mex*par$cex, font=font, family=par$family, col=par$col.axis, lheight=par$lheight, yLineBias=par$ylbias, allowOverlap=FALSE, label="left-axis-labels") } } else if (side == 3 && par$xaxt != "n") { if (is.finite(pos)) { axis_base <- unit(pos, "native") } else { if (outer) { coords <- "nic" } else { coords <- "npc" } axis_base <- unit(grconvertY(1, coords, "in") - deviceLoc(unit(0, "npc"), unit(0, "npc"), valueOnly=TRUE)$y + grconvertY(line, "lines", "in"), "in") } ticks <- tx(ticks, par) if (par$usr[1] < par$usr[2]) { ticksub <- ticks >= par$usr[1] & ticks <= par$usr[2] } else { ticksub <- ticks <= par$usr[1] & ticks >= par$usr[2] } if (doticks) { if (lwd > 0) { grid.segments(unit(min(par$usr[2], max(par$usr[1], min(ticks))), "native"), axis_base, unit(min(par$usr[2], max(par$usr[1], max(ticks))), "native"), axis_base, gp=gpar(col=col, lwd=lwd, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("top-axis-line")) } if (lwd.ticks > 0) { grid.segments(unit(ticks[ticksub], "native"), axis_base, unit(ticks[ticksub], "native"), axis_base - tickLength, gp=gpar(col=col.ticks, lwd=lwd.ticks, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("top-axis-ticks")) } } if (drawLabels) { axis_base_in <- convertY(axis_base, "in", valueOnly=TRUE) plot_top_in <- convertY(unit(1, "npc"), "in", valueOnly=TRUE) labLine <- grconvertY(axis_base_in, "in", "lines") + par$mgp[2] - lineoff - grconvertY(plot_top_in, "in", "lines") GMtext(labels[ticksub], 3, line=labLine, at=unit(ticks[ticksub], "native"), las=par$las, xadj=computeXAdj(hadj, side, par$las), yadj=computePAdj(padj, side, par$las), mex=par$mex, cin=par$cin, cex=par$cex.axis*par$cex, linecex=par$mex*par$cex, font=font, family=par$family, col=par$col.axis, lheight=par$lheight, yLineBias=par$ylbias, allowOverlap=FALSE, label="top-axis-labels") } } else if (side == 4 && par$yaxt != "n") { if (is.finite(pos)) { axis_base <- unit(pos, "native") } else { if (outer) { coords <- "nic" } else { coords <- "npc" } axis_base <- unit(grconvertX(1, coords, "in") - deviceLoc(unit(0, "npc"), unit(0, "npc"), valueOnly=TRUE)$x + grconvertY(line, "lines", "in"), "in") } ticks <- ty(ticks, par) if (par$usr[3] < par$usr[4]) { ticksub <- ticks >= par$usr[3] & ticks <= par$usr[4] } else { ticksub <- ticks <= par$usr[3] & ticks >= par$usr[4] } if (doticks) { if (lwd > 0) { grid.segments(axis_base, unit(min(par$usr[4], max(par$usr[3], min(ticks))), "native"), axis_base, unit(min(par$usr[4], max(par$usr[3], max(ticks))), "native"), gp=gpar(col=col, lwd=lwd, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("right-axis-line")) } if (lwd.ticks > 0) { grid.segments(axis_base, unit(ticks[ticksub], "native"), axis_base - tickLength, unit(ticks[ticksub], "native"), gp=gpar(col=col.ticks, lwd=lwd.ticks, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("right-axis-ticks")) } } if (drawLabels) { axis_base_in <- convertX(axis_base, "in", valueOnly=TRUE) plot_right_in <- convertX(unit(1, "npc"), "in", valueOnly=TRUE) labLine <- grconvertX(axis_base_in, "in", "lines") + par$mgp[2] - lineoff - grconvertX(plot_right_in, "in", "lines") GMtext(labels[ticksub], 4, line=labLine, at=unit(ticks[ticksub], "native"), las=par$las, xadj=computeXAdj(hadj, side, par$las), yadj=computePAdj(padj, side, par$las), mex=par$mex, cin=par$cin, cex=par$cex.axis*par$cex, linecex=par$mex*par$cex, font=font, family=par$family, col=par$col.axis, lheight=par$lheight, yLineBias=par$ylbias, allowOverlap=FALSE, label="right-axis-labels") } } upViewport(depth) } defaultTicks <- function(side, par) { axp <- switch(side, par$xaxp, par$yaxp, par$xaxp, par$yaxp) usr <- switch(side, par$usr[1:2], par$usr[3:4], par$usr[1:2], par$usr[3:4]) log <- switch(side, par$xlog, par$ylog, par$xlog, par$ylog) axTicks(side, axp, usr, log) } computeXAdj <- function(hadj, side, las) { if (is.finite(hadj)) { xadj <- hadj } else { if (side == 1 || side == 3) { if (las == 2 || las == 3) { if (side == 1) { xadj <- 1 } else { xadj <- 0 } } else { xadj <- 0.5 } } else { if (las == 1 || las == 2) { if (side == 2) { xadj <- 1 } else { xadj <- 0 } } else { xadj <- 0.5 } } } xadj } computePAdj <- function(padj, side, las) { if (!is.finite(padj)) { padj <- switch(las + 1, 0, switch(side, 0, 0.5, 0, 0.5), 0.5, switch(side, 0.5, 0, 0.5, 0)) } padj } ################################################################################ ## Version of C_axis() that does not depend on R 3.6.0 features old_C_axis <- function(x) { dev.set(recordDev()) # Blank out x$cex because we want par$cex to be par$cexbase x$cex <- NULL par <- currentPar(x[-(1:16)]) dev.set(playDev()) depth <- gotovp(NA) side <- x[[2]] if (is.null(x[[3]])) { ticks <- defaultTicks(side, par) } else { ticks <- x[[3]] } labels <- x[[4]] doticks <- x[[5]] if (is.na(doticks)) doticks <- TRUE # [1] to guard against 'line' vector of length > 1 line <- x[[6]][1] pos <- x[[7]] # Not sure on the logic of the following, just emulating C code lineoff <- 0 if (!is.finite(line)) { line <- par$mgp[3] lineoff <- line } if (is.finite(pos)) lineoff <- 0 outer <- x[[8]] font <- FixupFont(x[[9]], NA) lty <- FixupLty(x[[10]], 0) lwd <- FixupLwd(x[[11]], 1) lwd.ticks <- FixupLwd(x[[12]], 1) col <- FixupCol(x[[13]], par$fg, par$bg) col.ticks <- FixupCol(x[[14]], col, par$bg) hadj <- x[[15]] padj <- x[[16]] # NOTE: the use of 'trim=TRUE' in format() to mimic use of, # e.g., EncodeReal0(), within labelformat() in plot.c if (is.null(labels)) { drawLabels <- TRUE labels <- format(ticks, trim=TRUE) } else if (is.logical(labels)) { if (labels) { drawLabels <- TRUE labels <- format(ticks, trim=TRUE) } else { drawLabels <- FALSE } } else { drawLabels <- TRUE } if (is.finite(par$tck)) { if (par$tck > 0.5) { tickLength <- unit(par$tck, "npc") } else { tickLength <- min(convertWidth(unit(par$tck, "npc"), "in"), convertHeight(unit(par$tck, "npc"), "in")) } } else { tickLength <- unit(par$cin[2]*par$tcl*par$cex, "in") } ## font is 'font' arg if not NA, otherwise par("font.axis") if (is.na(font)) { font <- par$font.axis } returnvp <- NULL if (side == 1 && par$xaxt != "n") { if (is.finite(pos)) { axis_base <- unit(pos, "native") } else { if (outer) { returnvp <- pushTempViewport(side) } axis_base <- unit(0, "npc") - unit(line*par$cin[2]*par$cex, "in") } # Now that have generated tick labels from tick locations # (if necessary), can transform tick locations (if necessary) # for log transforms ticks <- tx(ticks, par) # Clip ticks (and labels) to plot boundaries ticksub <- ticks >= par$usr[1] & ticks <= par$usr[2] if (doticks) { if (lwd > 0) { grid.segments(unit(min(par$usr[2], max(par$usr[1], min(ticks))), "native"), axis_base, unit(min(par$usr[2], max(par$usr[1], max(ticks))), "native"), axis_base, gp=gpar(col=col, lwd=lwd, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("bottom-axis-line")) } if (lwd.ticks > 0) { grid.segments(unit(ticks[ticksub], "native"), axis_base, unit(ticks[ticksub], "native"), axis_base + tickLength, gp=gpar(col=col.ticks, lwd=lwd.ticks, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("bottom-axis-ticks")) } } # NOTE: the following includes calculation based on par(mgp) # to get the margin line to draw on # PLUS adjustment made in GMtext() based on that line value if (drawLabels) { labLine <- - (convertY(axis_base, "in", valueOnly=TRUE)/ (par$cin[2]*par$cex)) + par$mgp[2] - lineoff GMtext(labels[ticksub], 1, line=labLine, at=unit(ticks[ticksub], "native"), las=par$las, xadj=computeXAdj(hadj, side, par$las), yadj=computePAdj(padj, side, par$las), mex=par$mex, cin=par$cin, cex=par$cex.axis*par$cex, linecex=par$mex*par$cex, font=font, family=par$family, col=par$col.axis, lheight=par$lheight, yLineBias=par$ylbias, allowOverlap=FALSE, label="bottom-axis-labels") } } else if (side == 2 && par$yaxt != "n") { if (is.finite(pos)) { axis_base <- unit(pos, "native") } else { if (outer) { returnvp <- pushTempViewport(side) } axis_base <- unit(0, "npc") - unit(line*par$cin[2]*par$cex, "in") } ticks <- ty(ticks, par) ticksub <- ticks >= par$usr[3] & ticks <= par$usr[4] if (doticks) { if (lwd > 0) { grid.segments(axis_base, unit(min(par$usr[4], max(par$usr[3], min(ticks))), "native"), axis_base, unit(min(par$usr[4], max(par$usr[3], max(ticks))), "native"), gp=gpar(col=col, lwd=lwd, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("left-axis-line")) } if (lwd.ticks > 0) { grid.segments(axis_base, unit(ticks[ticksub], "native"), axis_base + tickLength, unit(ticks[ticksub], "native"), gp=gpar(col=col.ticks, lwd=lwd.ticks, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("left-axis-ticks")) } } if (drawLabels) { labLine <- - (convertX(axis_base, "in", valueOnly=TRUE)/ (par$cin[2]*par$cex)) + par$mgp[2] - lineoff GMtext(labels[ticksub], 2, line=labLine, at=unit(ticks[ticksub], "native"), las=par$las, xadj=computeXAdj(hadj, side, par$las), yadj=computePAdj(padj, side, par$las), mex=par$mex, cin=par$cin, cex=par$cex.axis*par$cex, linecex=par$mex*par$cex, font=font, family=par$family, col=par$col.axis, lheight=par$lheight, yLineBias=par$ylbias, allowOverlap=FALSE, label="left-axis-labels") } } else if (side == 3 && par$xaxt != "n") { if (is.finite(pos)) { axis_base <- unit(pos, "native") } else { if (outer) { returnvp <- pushTempViewport(side) } axis_base <- unit(1, "npc") + unit(line*par$cin[2]*par$cex, "in") } ticks <- tx(ticks, par) ticksub <- ticks >= par$usr[1] & ticks <= par$usr[2] if (doticks) { if (lwd > 0) { grid.segments(unit(min(par$usr[2], max(par$usr[1], min(ticks))), "native"), axis_base, unit(min(par$usr[2], max(par$usr[1], max(ticks))), "native"), axis_base, gp=gpar(col=col, lwd=lwd, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("top-axis-line")) } if (lwd.ticks > 0) { grid.segments(unit(ticks[ticksub], "native"), axis_base, unit(ticks[ticksub], "native"), axis_base - tickLength, gp=gpar(col=col.ticks, lwd=lwd.ticks, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("top-axis-ticks")) } } if (drawLabels) { labLine <- (convertY(axis_base, "in", valueOnly=TRUE)/ (par$cin[2]*par$cex)) + par$mgp[2] - lineoff - (convertY(unit(1, "npc"), "in", valueOnly=TRUE)/ (par$cin[2]*par$cex)) GMtext(labels[ticksub], 3, line=labLine, at=unit(ticks[ticksub], "native"), las=par$las, xadj=computeXAdj(hadj, side, par$las), yadj=computePAdj(padj, side, par$las), mex=par$mex, cin=par$cin, cex=par$cex.axis*par$cex, linecex=par$mex*par$cex, font=font, family=par$family, col=par$col.axis, lheight=par$lheight, yLineBias=par$ylbias, allowOverlap=FALSE, label="top-axis-labels") } } else if (side == 4 && par$yaxt != "n") { if (is.finite(pos)) { axis_base <- unit(pos, "native") } else { if (outer) { returnvp <- pushTempViewport(side) } axis_base <- unit(1, "npc") + unit(line*par$cin[2]*par$cex, "in") } ticks <- ty(ticks, par) ticksub <- ticks >= par$usr[3] & ticks <= par$usr[4] if (doticks) { if (lwd > 0) { grid.segments(axis_base, unit(min(par$usr[4], max(par$usr[3], min(ticks))), "native"), axis_base, unit(min(par$usr[4], max(par$usr[3], max(ticks))), "native"), gp=gpar(col=col, lwd=lwd, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("right-axis-line")) } if (lwd.ticks > 0) { grid.segments(axis_base, unit(ticks[ticksub], "native"), axis_base - tickLength, unit(ticks[ticksub], "native"), gp=gpar(col=col.ticks, lwd=lwd.ticks, lty=lty, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("right-axis-ticks")) } } if (drawLabels) { labLine <- (convertX(axis_base, "in", valueOnly=TRUE)/ (par$cin[2]*par$cex)) + par$mgp[2] - lineoff - (convertX(unit(1, "npc"), "in", valueOnly=TRUE)/ (par$cin[2]*par$cex)) GMtext(labels[ticksub], 4, line=labLine, at=unit(ticks[ticksub], "native"), las=par$las, xadj=computeXAdj(hadj, side, par$las), yadj=computePAdj(padj, side, par$las), mex=par$mex, cin=par$cin, cex=par$cex.axis*par$cex, linecex=par$mex*par$cex, font=font, family=par$family, col=par$col.axis, lheight=par$lheight, yLineBias=par$ylbias, allowOverlap=FALSE, label="right-axis-labels") } } # Undo any temporary "outer" viewport if (!is.null(returnvp)) { upViewport() downViewport(returnvp) } upViewport(depth) } pushTempViewport <- function(side) { cvp <- current.viewport() xscale <- cvp$xscale yscale <- cvp$yscale name <- cvp$name returnvp <- upViewport(2) if (side == 1 || side == 3) { pushViewport(viewport(x=grobX(rectGrob(vp=returnvp), "west"), width=grobWidth(rectGrob(vp=returnvp)), just="left", xscale=xscale, name=paste0(name, "-outer-axis"))) } else { # side == 2 || side == 4 pushViewport(viewport(y=grobY(rectGrob(vp=returnvp), "south"), height=grobHeight(rectGrob(vp=returnvp)), just="bottom", yscale=yscale, name=paste0(name, "-outer-axis"))) } returnvp } gridGraphics/R/palette.R0000654000176200001440000000076512432167461014661 0ustar liggesusers # NOTE that there is only one palette for all graphics devices in R # so only need to call these functions to replicate their effect # (does not matter which graphics device is current) C_palette <- function(x) { do.call("palette", x[-1]) } C_palette2 <- function(x) { hex <- sprintf("%08X", x[[2]]) alpha <- substring(hex, 1, 2) blue <- substring(hex, 3, 4) green <- substring(hex, 5, 6) red <- substring(hex, 7, 8) palette(paste0("#", red, green, blue, alpha)) } gridGraphics/R/title.R0000654000176200001440000001061312536421531014331 0ustar liggesusers # C_title(main, sub, xlab, ylab, line, outer, ...) C_title <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:7)]) dev.set(playDev()) mainArg <- GetTextArg(x[[2]], par$cex.main*par$cex, par$col.main, par$font.main, par$bg) main <- mainArg$txt subArg <- GetTextArg(x[[3]], par$cex.sub*par$cex, par$col.sub, par$font.sub, par$bg) sub <- subArg$txt xlabArg <- GetTextArg(x[[4]], par$cex.lab*par$cex, par$col.lab, par$font.lab, par$bg) xlab <- xlabArg$txt ylabArg <- GetTextArg(x[[5]], par$cex.lab*par$cex, par$col.lab, par$font.lab, par$bg) ylab <- ylabArg$txt line <- x[[6]] outer <- x[[7]] if (outer) { depth <- gotovp(NA, "inner") } else { depth <- gotovp(if (is.na(par$xpd)) NA else TRUE, "plot") } if (!is.null(main)) { if (outer) { if (is.finite(line)) { vpos <- line adjy <- 0 } else { vpos <- 0.5*par$oma[3] adjy = 0.5 } } else { if (is.finite(line)) { vpos = line adjy = 0 } else { vpos = 0.5*par$mar[3] adjy = 0.5 } } grid.text(main, x=unit(par$adj, "npc"), y=unit(1, "npc") + unit(vpos*par$cex*par$cin[2], "in"), vjust=adjy, gp=gpar(cex=mainArg$pars$cex, fontface=mainArg$pars$font, fontfamily=par$family, col=mainArg$pars$col, lineheight=par$lheight), name=grobname("main")) } if (!is.null(sub)) { cex <- if (is.null(subArg$pars$cex)) { par$cex } else { cex <- subArg$pars$cex } GMtext(sub, 1, line=par$mgp[1] + 1, at=0.5, las=0, xadj=0.5, yadj=0, mex=par$mex, cin=par$cin, cex=subArg$pars$cex, linecex=par$mex*par$cex, font=subArg$pars$font, family=par$family, col=subArg$pars$col, lheight=par$lheight, yLineBias=par$ylbias, label="sub") } if (!is.null(xlab)) { cex <- if (is.null(xlabArg$pars$cex)) { par$cex } else { cex <- xlabArg$pars$cex } GMtext(xlab, 1, line=par$mgp[1], at=0.5, las=0, xadj=0.5, yadj=0, mex=par$mex, cin=par$cin, cex=xlabArg$pars$cex, linecex=par$mex*par$cex, font=xlabArg$pars$font, family=par$family, col=xlabArg$pars$col, lheight=par$lheight, yLineBias=par$ylbias, label="xlab") } if (!is.null(ylab)) { cex <- if (is.null(ylabArg$pars$cex)) { par$cex } else { cex <- ylabArg$pars$cex } GMtext(ylab, 2, line=par$mgp[1], at=0.5, las=0, xadj=0.5, yadj=0, mex=par$mex, cin=par$cin, cex=ylabArg$pars$cex, linecex=par$mex*par$cex, font=ylabArg$pars$font, family=par$family, col=ylabArg$pars$col, lheight=par$lheight, yLineBias=par$ylbias, label="ylab") } upViewport(depth) } GetTextArg <- function(x, cex, col, font, bg) { # Text may be specified as list(text, col=, cex=, font=) pars <- list(cex=cex, col=col, font=font) if (is.null(x) || is.na(x)) { txt <- NULL } else if (is.language(x) || is.character(x)) { txt <- x } else { if (is.list(x)) { names <- names(x) if (length(names)) { parnames <- names %in% c("col", "cex", "font") if (any(parnames)) { if ("cex" %in% names) { pars$cex = x$cex } if ("col" %in% names) { pars$col <- FixupCol(x$col, NA, bg) } if ("font" %in% names) { pars$font <- FixupFont(x$font, NA) } } nonpars <- x[!parnames] if (length(nonpars)) { txt <- x[[length(nonpars)]] } else { txt <- NULL } } else { txt <- x[[1]] } } else { stop("Unrecognised text argument type") } } list(txt=txt, pars=pars) } gridGraphics/R/polygon.R0000654000176200001440000000251112427775275014715 0ustar liggesusers # C_polygon(x, y, col, border, lty, ...) C_polygon <- function(x) { dev.set(recordDev()) par <- currentPar(x[-(1:6)]) dev.set(playDev()) depth <- gotovp(par$xpd) xx <- tx(x[[2]], par) yy <- ty(x[[3]], par) col <- FixupCol(x[[4]], NA, par$bg) border <- FixupCol(x[[5]], par$fg, par$bg) lty <- FixupLty(x[[6]], par$lty) lty <- ifelse(is.na(lty), par$lty, lty) # NOTE: allow for NA values in x/y breaks <- which(is.na(xx) | is.na(yy)) if (length(breaks) == 0) { # Only one polygon grid.polygon(xx, yy, default.units="native", gp=gpar(col=border, fill=col, lty=lty, lwd=par$lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("polygon")) } else { nb <- length(breaks) lengths <- c(breaks[1] - 1, diff(breaks) - 1, length(xx) - breaks[nb]) grid.polygon(xx[-breaks], yy[-breaks], default.units="native", id.lengths=lengths, gp=gpar(col=border, fill=col, lty=lty, lwd=par$lwd, lineend=par$lend, linemitre=par$lmitre, linejoin=par$ljoin), name=grobname("polygon")) } upViewport(depth) } gridGraphics/MD50000644000176200001440000001413213765502603013200 0ustar liggesusersba7f0ccebae9d3f406818a93da5314c7 *DESCRIPTION bfd4484fad6d19b4901b1ddb62091a32 *NAMESPACE cc9163b8296eba1758f88db5f267e75d *R/abline.R cda81d05dd571a2b67d96a40fc678783 *R/arrows.R 3afa88334f11c3154e5fd382cb5b6851 *R/axis.R 8df6eee1a3a4cc5f196ef19981f7216b *R/box.R a0464cd853f4d166000572b7a27ded38 *R/clip.R 5f1488d059e0473e25904f8918818af7 *R/contour.R b99b9196347bc09f82135e4d68e05045 *R/convert.R 5bce155a5bcf0d4b2894cc03653624cc *R/core.R 2dddd77cb65d854949755381c0398576 *R/dend.R e384af9508ce181dca9ce57ab4d65330 *R/filled.contour.R be51e156985d8b6dadefcd731578f171 *R/graphics.R 3a3c38c5b32e060788f7a9c6fe15151a *R/identify.R 244fb60c148cf209666774f8bb07a8ee *R/image.R 943c08451567e7e1b95aebfd4e8ece5c *R/layout.R ef644a37eca89bd9285a7bfa8091ed7f *R/mtext.R 4b370b1ebd14667e39906a2812c0384d *R/palette.R c595006d188bb1a147218ef76e74de19 *R/par.R 500b23c7a26d0c2375473ba3a8a4f2ba *R/path.R 5367b84a1dd0525dc7bc2a1af8c88288 *R/persp.R d6b596d6929e0b5d12fa17bd722f76f5 *R/plot.new.R 2890e6fd83016f6ecb18936300dc29f3 *R/plot.window.R c3051254460b41a80a41b0e6dd32ea80 *R/plotXY.R 840819d88ff9eb89e69e600caabb31cb *R/plotdiff.R face413cc567e0f60ae872ae92ba6885 *R/polygon.R 18a264abc9131e95c722aa7df675cd90 *R/raster.R 90ad85850daeb29ee980ad4df9b6387d *R/rect.R fcc928eea54d63726995560531b9d0b4 *R/segments.R 51a8adf54b50ebe2e281a499a74d2c85 *R/symbols.R e3666c83fba91ec71d0538a061cf2d3a *R/text.R b1843c7075f73e5ae04dd1753ad4d52d *R/title.R 7a20f1336dec8a93948d836da0214964 *R/xspline.R 0c9e9fb82dd83c800f058e0a7dd5c449 *README.md ff0dced49c4f8665a066d93dc7fdda96 *inst/NEWS.Rd d6b3d783da7b60edb2ea7855d9f4292d *inst/test-scripts/test-abline.R a293a6478fecb2656b47ec4bddf43da6 *inst/test-scripts/test-arrows.R ce6e737df1ac01eaa121427624b90419 *inst/test-scripts/test-assocplot.R e524d0bb8be753687b5be2f3f324ec70 *inst/test-scripts/test-axTicks.R 2ddd61fc9089a10d2a1e6868f53645b5 *inst/test-scripts/test-axis.POSIXct.R 18b7ca4c4fe47f1340c39b8b783f49e0 *inst/test-scripts/test-axis.R a6cf2f780b663d2e6928debdc781315b *inst/test-scripts/test-barplot.R 4675e685d8e23430aa5083f36fd4640d *inst/test-scripts/test-box.R f0bec35e74c5caa5125185aad4049992 *inst/test-scripts/test-boxplot.R f501fb70eb4bfa3e43052a4dcc6708a8 *inst/test-scripts/test-boxplot.matrix.R c3ca769705d1d8c83201285733ce1425 *inst/test-scripts/test-bxp.R e53b61fb54249fda20b9a860fd2d4ba3 *inst/test-scripts/test-cdplot.R 1837f72e4b240d407c98fe83cd195817 *inst/test-scripts/test-clip.R 510f876160c2fdb8c7e33b2c58e325d8 *inst/test-scripts/test-contour.R 4461210ada56e765b9e6c592c381f28f *inst/test-scripts/test-coplot.R 6caef3ba4337fbe7035a339b4206b53f *inst/test-scripts/test-curve.R 841019074b1fb447ebc23f6f01807a3e *inst/test-scripts/test-dend.R 3996f9a077eea0036e2ecd1eec9feb39 *inst/test-scripts/test-dotchart.R 5675d7b05ad7663b76d25362a99cd99e *inst/test-scripts/test-filled.contour.R 74d9f5140343754ddafc0c2f44b8848a *inst/test-scripts/test-fourfold.R d92eb69dbae6e4aca039d18f5146c345 *inst/test-scripts/test-grid.R dc4715c549b70ebc9f5f5f4670d808b8 *inst/test-scripts/test-hist.POSIXt.R 79fec2a39bd77c8bd618939d83a73ea5 *inst/test-scripts/test-hist.R 23cedba4b9928dd28de1122958224f2d *inst/test-scripts/test-identify.R 48b768d828be1ddea690432423457cc1 *inst/test-scripts/test-image.R e25842b2429d2ccd938c3e0348f02f8f *inst/test-scripts/test-layout.R 7635e9628c753db5bb88417b3ca51d43 *inst/test-scripts/test-legend.R a4e720cb6866a451eba3e94ceec17263 *inst/test-scripts/test-lines.R 7cd7d0429480d08b41372606fae18c97 *inst/test-scripts/test-matplot.R e5ad665e859118a0a059b56220244f05 *inst/test-scripts/test-missing.R 3e4e6fc96543b2e9adc676fa11128455 *inst/test-scripts/test-mosaicplot.R 4e5cdb0c21fb3a4cd88eee1b9f37f0fd *inst/test-scripts/test-mtext.R 998b839eb6c52e1562baa69b76a2ffab *inst/test-scripts/test-pairs.R 77761753802b342559e2a5063c99c3a3 *inst/test-scripts/test-palette.R 3fec7fcad560c3985198b51e0f17201e *inst/test-scripts/test-panel.smooth.R a44c5dd4d8e8da2af74f439908826d6b *inst/test-scripts/test-par.R beaeca29f31ef8cd020bec9800289b0d *inst/test-scripts/test-path.R 5be96a756a6ec19bb614414976c9779f *inst/test-scripts/test-persp.R e0569fd72d79d622a46dd46e271b639d *inst/test-scripts/test-pie.R 3f6f989727f87abbd497c0b0adc29bc6 *inst/test-scripts/test-plot.R 9afdc6899bf4bdbd7972e774b9e9bab1 *inst/test-scripts/test-plot.data.frame.R bbccc3cfca01df6f1901af40d363e03d *inst/test-scripts/test-plot.default.R 50f7443f6652604d5af235cc5004d3d1 *inst/test-scripts/test-plot.design.R e55e0fce01317558e629033b8463a445 *inst/test-scripts/test-plot.factor.R 5e42d20fb8b8038c577e3cb43b38f24d *inst/test-scripts/test-plot.formula.R fee861bf6a830f82191cbb76edcbcf2f *inst/test-scripts/test-plot.histogram.R 7f671b500d1163bcf5d7fcae1407a874 *inst/test-scripts/test-plot.table.R 42c7cbb583a416f7f8f6a0b937aa2e3b *inst/test-scripts/test-plot.window.R 10782b65ff3d5fa4268ec13db03ceea3 *inst/test-scripts/test-points.R 354d52665534f9e9cee22f441854e750 *inst/test-scripts/test-polygon.R 12e9a1ddad963e6d32ba1eb6e3f1097e *inst/test-scripts/test-polypath.R c735dde0d4291ace61ca7a77f06d858c *inst/test-scripts/test-raster.R d182774b6f617cd860a2ec1b877451e4 *inst/test-scripts/test-rect.R 090caf05790841116974079a07b03f30 *inst/test-scripts/test-rug.R f2f501d4c19a76e155b8a75f51e37345 *inst/test-scripts/test-screen.R 9621af0cc82b199297978429a45b61ea *inst/test-scripts/test-segments.R 807952c86b9b10d48d8aec82bd0044c2 *inst/test-scripts/test-smoothScatter.R 907d70438495eb8cd72f0c6e393110c1 *inst/test-scripts/test-spineplot.R 4827ee6175ac07638a72540ed78e5e48 *inst/test-scripts/test-stars.R b91d96f64209b94c232d2a52b9e54089 *inst/test-scripts/test-stripchart.R 4b2a93b6f017f05452e0065d44876a5d *inst/test-scripts/test-sunflowerplot.R 2c7befd67aa244256a37ae4249ca09f6 *inst/test-scripts/test-symbols.R ba4a39ef1a55ec5d9345f927aaf1a261 *inst/test-scripts/test-text.R a4397d2d3e94861b980e5a64346e6f8b *inst/test-scripts/test-title.R 4e0768227d0ad035eecb928daef601bb *inst/test-scripts/test-units.R ed0e3d4318b82c5fb715dfa86f582252 *inst/test-scripts/test-xspline.R 32f010c99c034c11496121a20246f607 *man/grid.echo.Rd 6edd9fa6c514718bff722db69fd366a3 *man/plotdiff.Rd 91fa719af74a16eb63d6b4cc1f5a493b *tests/aardvark.Rin cd6f8f47dd7904d4ff2c5277d6119692 *tests/demo-graphics.R gridGraphics/inst/0000755000176200001440000000000013764276260013652 5ustar liggesusersgridGraphics/inst/test-scripts/0000755000176200001440000000000013764276260016316 5ustar liggesusersgridGraphics/inst/test-scripts/test-hist.POSIXt.R0000654000176200001440000000123312556246306021446 0ustar liggesusers library(gridGraphics) hist.POSIXt1 <- function() { hist(.leap.seconds, "years", freq = TRUE) } hist.POSIXt2 <- function() { hist(.leap.seconds[.leap.seconds < ISOdate(2020, 1, 1)], seq(ISOdate(1970, 1, 1), ISOdate(2020, 1, 1), "5 years")) } hist.POSIXt3 <- function() { ## 100 random dates in a 10-week period set.seed(1) random.dates <- as.Date("2001/1/1") + 70*stats::runif(100) hist(random.dates, "weeks", format = "%d %b") } plotdiff(expression(hist.POSIXt1()), "hist.POSIXt-1", width=15) plotdiff(expression(hist.POSIXt2()), "hist.POSIXt-2") plotdiff(expression(hist.POSIXt3()), "hist.POSIXt-3", width=10) plotdiffResult() gridGraphics/inst/test-scripts/test-cdplot.R0000654000176200001440000000253412426036365020702 0ustar liggesusers library(gridGraphics) ## NASA space shuttle o-ring failures fail <- factor(c(2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 2, 1, 2, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1), levels = 1:2, labels = c("no", "yes")) temperature <- c(53, 57, 58, 63, 66, 67, 67, 67, 68, 69, 70, 70, 70, 70, 72, 73, 75, 75, 76, 76, 78, 79, 81) cdplot1 <- function() { ## CD plot cdplot(fail ~ temperature) } cdplot2 <- function() { cdplot(fail ~ temperature, bw = 2) } cdplot3 <- function() { cdplot(fail ~ temperature, bw = "SJ") } cdplot4 <- function() { ## compare with spinogram (spineplot(fail ~ temperature, breaks = 3)) } cdplot5 <- function() { ## highlighting for failures cdplot(fail ~ temperature, ylevels = 2:1) } cdplot6 <- function() { ## scatter plot with conditional density cdens <- cdplot(fail ~ temperature, plot = FALSE) plot(I(as.numeric(fail) - 1) ~ jitter(temperature, factor = 2), xlab = "Temperature", ylab = "Conditional failure probability") lines(53:81, 1 - cdens[[1]](53:81), col = 2) } plotdiff(expression(cdplot1()), "cdplot-1") plotdiff(expression(cdplot2()), "cdplot-2") plotdiff(expression(cdplot3()), "cdplot-3") plotdiff(expression(cdplot4()), "cdplot-4", width=9) plotdiff(expression(cdplot5()), "cdplot-5") plotdiff(expression(cdplot6()), "cdplot-6") plotdiffResult() gridGraphics/inst/test-scripts/test-box.R0000654000176200001440000000040612425524347020202 0ustar liggesusers library(gridGraphics) box1 <- function() { set.seed(1) plot(1:7, abs(stats::rnorm(7)), type = "h", axes = FALSE) axis(1, at = 1:7, labels = letters[1:7]) box(lty = '1373', col = 'red') } plotdiff(expression(box1()), "box-1") plotdiffResult() gridGraphics/inst/test-scripts/test-mosaicplot.R0000654000176200001440000000216712427755613021576 0ustar liggesusers library(gridGraphics) require(stats) mosaicplot1 <- function() { mosaicplot(Titanic, main = "Survival on the Titanic", color = TRUE) } mosaicplot2 <- function() { ## Formula interface for tabulated data: mosaicplot(~ Sex + Age + Survived, data = Titanic, color = TRUE) } mosaicplot3 <- function() { mosaicplot(HairEyeColor, shade = TRUE) } mosaicplot4 <- function() { mosaicplot(HairEyeColor, shade = TRUE, margin = list(1:2, 3)) } mosaicplot5 <- function() { ## Formula interface for raw data: visualize cross-tabulation of numbers ## of gears and carburettors in Motor Trend car data. mosaicplot(~ gear + carb, data = mtcars, color = TRUE, las = 1) } mosaicplot6 <- function() { # color recycling mosaicplot(~ gear + carb, data = mtcars, color = 2:3, las = 1) } plotdiff(expression(mosaicplot1()), "mosaicplot-1") plotdiff(expression(mosaicplot2()), "mosaicplot-2") plotdiff(expression(mosaicplot3()), "mosaicplot-3") plotdiff(expression(mosaicplot4()), "mosaicplot-4") plotdiff(expression(mosaicplot5()), "mosaicplot-5") plotdiff(expression(mosaicplot6()), "mosaicplot-6") plotdiffResult() gridGraphics/inst/test-scripts/test-axTicks.R0000654000176200001440000000434112425560351021015 0ustar liggesusers library(gridGraphics) axTicks1 <- function() { plot(1:7, 10*21:27) axTicks(1) axTicks(2) } axTicks2 <- function() { ## Show how axTicks() and axis() correspond : par(mfrow = c(3, 1), mar = c(4, 4, 1, 1)) for(x in 9999 * c(1, 2, 8)) { plot(x, 9, log = "x") cat(formatC(par("xaxp"), width = 5),";", T <- axTicks(1),"\n") rug(T, col = adjustcolor("red", 0.5), lwd = 4) } } axTicks3 <- function() { x <- 9.9*10^(-3:10) plot(x, 1:14, log = "x") axTicks(1) # now length 5, in R <= 2.13.x gave the following axTicks(1, nintLog = Inf) # rather too many } axTicks4 <- function() { ## An example using axTicks() without reference to an existing plot ## (copying R's internal procedures for setting axis ranges etc.), ## You do need to supply _all_ of axp, usr, log, nintLog ## standard logarithmic y axis labels ylims <- c(0.2, 88) get_axp <- function(x) 10^c(ceiling(x[1]), floor(x[2])) ## mimic par("yaxs") == "i" usr.i <- log10(ylims) (aT.i <- axTicks(side = 2, usr = usr.i, axp = c(get_axp(usr.i), n = 3), log = TRUE, nintLog = 5)) ## mimic (default) par("yaxs") == "r" usr.r <- extendrange(r = log10(ylims), f = 0.04) (aT.r <- axTicks(side = 2, usr = usr.r, axp = c(get_axp(usr.r), 3), log = TRUE, nintLog = 5)) ## Prove that we got it right : plot(0:1, ylims, log = "y", yaxs = "i") } axTicks5 <- function() { ylims <- c(0.2, 88) get_axp <- function(x) 10^c(ceiling(x[1]), floor(x[2])) ## mimic par("yaxs") == "i" usr.i <- log10(ylims) (aT.i <- axTicks(side = 2, usr = usr.i, axp = c(get_axp(usr.i), n = 3), log = TRUE, nintLog = 5)) ## mimic (default) par("yaxs") == "r" usr.r <- extendrange(r = log10(ylims), f = 0.04) (aT.r <- axTicks(side = 2, usr = usr.r, axp = c(get_axp(usr.r), 3), log = TRUE, nintLog = 5)) plot(0:1, ylims, log = "y", yaxs = "r") } plotdiff(expression(axTicks1()), "axTicks-1") plotdiff(expression(axTicks2()), "axTicks-2", width=8, height=8) plotdiff(expression(axTicks3()), "axTicks-3") plotdiff(expression(axTicks4()), "axTicks-4") plotdiff(expression(axTicks5()), "axTicks-5") plotdiffResult() gridGraphics/inst/test-scripts/test-image.R0000654000176200001440000000256712424012714020473 0ustar liggesusers require(grDevices) # for colours library(gridGraphics) image1 <- function() { x <- y <- seq(-4*pi, 4*pi, len = 27) r <- sqrt(outer(x^2, y^2, "+")) z <- z <- cos(r^2)*exp(-r/6) image(z, col = gray((0:32)/32)) } image2 <- function() { x <- y <- seq(-4*pi, 4*pi, len = 27) r <- sqrt(outer(x^2, y^2, "+")) z <- z <- cos(r^2)*exp(-r/6) image(z, axes = FALSE, main = "Math can be beautiful ...", xlab = expression(cos(r^2) * e^{-r/6})) contour(z, add = TRUE, drawlabels = FALSE) } image3 <- function() { # Volcano data visualized as matrix. Need to transpose and flip # matrix horizontally. image(t(volcano)[ncol(volcano):1,]) } image4 <- function() { # A prettier display of the volcano x <- 10*(1:nrow(volcano)) y <- 10*(1:ncol(volcano)) image(x, y, volcano, col = terrain.colors(100), axes = FALSE) contour(x, y, volcano, levels = seq(90, 200, by = 5), drawlabels = FALSE, add = TRUE, col = "peru") axis(1, at = seq(100, 800, by = 100)) axis(2, at = seq(100, 600, by = 100)) box() title(main = "Maunga Whau Volcano", font.main = 4) } plotdiff(expression(image1()), "image-1", antialias=FALSE) plotdiff(expression(image2()), "image-2", antialias=FALSE) plotdiff(expression(image3()), "image-3", antialias=FALSE) plotdiff(expression(image4()), "image-4", antialias=FALSE) plotdiffResult() gridGraphics/inst/test-scripts/test-plot.table.R0000654000176200001440000000103412430006155021440 0ustar liggesusers library(gridGraphics) plot.table1 <- function() { ## 1-d tables (Poiss.tab <- table(N = stats::rpois(200, lambda = 5))) plot(Poiss.tab, main = "plot(table(rpois(200, lambda = 5)))") } plot.table2 <- function() { plot(table(state.division)) } plot.table3 <- function() { ## 4-D : plot(Titanic, main ="plot(Titanic, main= *)") } plotdiff(expression(plot.table1()), "plot.table-1") plotdiff(expression(plot.table2()), "plot.table-2", width=15) plotdiff(expression(plot.table3()), "plot.table-3") plotdiffResult() gridGraphics/inst/test-scripts/test-identify.R0000654000176200001440000000046112426552575021233 0ustar liggesusers # Unfortunately, this cannot be run non-interactively (or at least # I have not thought of a way to do so) library(gridGraphics) notrun <- function() { plot(1) identify(1) dl <- recordPlot() dev.off() plotdiff(expression(replayPlot(dl)), "identify") } gridGraphics/inst/test-scripts/test-polypath.R0000654000176200001440000000261012430012245021232 0ustar liggesusers library(gridGraphics) plotPath <- function(x, y, col = "grey", rule = "winding") { plot.new() plot.window(range(x, na.rm = TRUE), range(y, na.rm = TRUE)) polypath(x, y, col = col, rule = rule) if (!is.na(col)) mtext(paste("Rule:", rule), side = 1, line = 0) } plotRules <- function(x, y, title) { plotPath(x, y) plotPath(x, y, rule = "evenodd") mtext(title, side = 3, line = 0) plotPath(x, y, col = NA) } polypath1 <- function() { par(mfrow = c(5, 3), mar = c(2, 1, 1, 1)) plotRules(c(.1, .1, .9, .9, NA, .2, .2, .8, .8), c(.1, .9, .9, .1, NA, .2, .8, .8, .2), "Nested rectangles, both clockwise") plotRules(c(.1, .1, .9, .9, NA, .2, .8, .8, .2), c(.1, .9, .9, .1, NA, .2, .2, .8, .8), "Nested rectangles, outer clockwise, inner anti-clockwise") plotRules(c(.1, .1, .4, .4, NA, .6, .9, .9, .6), c(.1, .4, .4, .1, NA, .6, .6, .9, .9), "Disjoint rectangles") plotRules(c(.1, .1, .6, .6, NA, .4, .4, .9, .9), c(.1, .6, .6, .1, NA, .4, .9, .9, .4), "Overlapping rectangles, both clockwise") plotRules(c(.1, .1, .6, .6, NA, .4, .9, .9, .4), c(.1, .6, .6, .1, NA, .4, .4, .9, .9), "Overlapping rectangles, one clockwise, other anti-clockwise") } plotdiff(expression(polypath1()), "polypath-1") plotdiffResult() gridGraphics/inst/test-scripts/test-plot.data.frame.R0000654000176200001440000000153412427776535022406 0ustar liggesusers library(gridGraphics) plot.data.frame1 <- function() { plot(OrchardSprays[1], method = "jitter") } plot.data.frame2 <- function() { plot(OrchardSprays[c(4,1)]) } plot.data.frame3 <- function() { plot(OrchardSprays) } plot.data.frame4 <- function() { plot(iris) } plot.data.frame5 <- function() { plot(iris[5:4]) } plot.data.frame6 <- function() { plot(women) } plotdiff(expression(plot.data.frame1()), "plot.data.frame-1") plotdiff(expression(plot.data.frame2()), "plot.data.frame-2", antialias=FALSE) plotdiff(expression(plot.data.frame3()), "plot.data.frame-3", width=10, height=10) plotdiff(expression(plot.data.frame4()), "plot.data.frame-4", width=12, height=12) plotdiff(expression(plot.data.frame5()), "plot.data.frame-5") plotdiff(expression(plot.data.frame6()), "plot.data.frame-6") plotdiffResult() gridGraphics/inst/test-scripts/test-fourfold.R0000654000176200001440000000207112426327050021223 0ustar liggesusers library(gridGraphics) ## Use the Berkeley admission data as in Friendly (1995). x <- aperm(UCBAdmissions, c(2, 1, 3)) dimnames(x)[[2]] <- c("Yes", "No") names(dimnames(x)) <- c("Sex", "Admit?", "Department") fourfold1 <- function() { ## Fourfold display of data aggregated over departments, with ## frequencies standardized to equate the margins for admission ## and sex. ## Figure 1 in Friendly (1994). fourfoldplot(margin.table(x, c(1, 2))) } fourfold2 <- function() { ## Fourfold display of x, with frequencies in each table ## standardized to equate the margins for admission and sex. ## Figure 2 in Friendly (1994). fourfoldplot(x) } fourfold3 <- function() { ## Fourfold display of x, with frequencies in each table ## standardized to equate the margins for admission. but not ## for sex. ## Figure 3 in Friendly (1994). fourfoldplot(x, margin = 2) } plotdiff(expression(fourfold1()), "fourfold-1") plotdiff(expression(fourfold2()), "fourfold-2") plotdiff(expression(fourfold3()), "fourfold-3") plotdiffResult() gridGraphics/inst/test-scripts/test-layout.R0000654000176200001440000000326012425524410020717 0ustar liggesusers library(gridGraphics) layout1 <- function() { ## divide the device into two rows and two columns ## allocate figure 1 all of row 1 ## allocate figure 2 the intersection of column 2 and row 2 layout(matrix(c(1,1,0,2), 2, 2, byrow = TRUE)) ## show the regions that have been allocated to each plot layout.show(2) } layout2 <- function() { ## divide device into two rows and two columns ## allocate figure 1 and figure 2 as above ## respect relations between widths and heights nf <- layout(matrix(c(1,1,0,2), 2, 2, byrow = TRUE), respect = TRUE) layout.show(nf) } layout3 <- function() { ## create single figure which is 5cm square nf <- layout(matrix(1), widths = lcm(5), heights = lcm(5)) layout.show(nf) } layout4 <- function() { set.seed(1) x <- pmin(3, pmax(-3, stats::rnorm(50))) y <- pmin(3, pmax(-3, stats::rnorm(50))) xhist <- hist(x, breaks = seq(-3,3,0.5), plot = FALSE) yhist <- hist(y, breaks = seq(-3,3,0.5), plot = FALSE) top <- max(c(xhist$counts, yhist$counts)) xrange <- c(-3, 3) yrange <- c(-3, 3) nf <- layout(matrix(c(2,0,1,3),2,2,byrow = TRUE), c(3,1), c(1,3), TRUE) # layout.show(nf) par(mar = c(3,3,1,1)) plot(x, y, xlim = xrange, ylim = yrange, xlab = "", ylab = "") par(mar = c(0,3,1,1)) barplot(xhist$counts, axes = FALSE, ylim = c(0, top), space = 0) par(mar = c(3,0,1,1)) barplot(yhist$counts, axes = FALSE, xlim = c(0, top), space = 0, horiz = TRUE) } plotdiff(expression(layout1()), "layout-1") plotdiff(expression(layout2()), "layout-2") plotdiff(expression(layout3()), "layout-3") plotdiff(expression(layout4()), "layout-4") plotdiffResult() gridGraphics/inst/test-scripts/test-segments.R0000654000176200001440000000076012425527672021246 0ustar liggesusers library(gridGraphics) segments1 <- function() { set.seed(1) x <- stats::runif(12); y <- stats::rnorm(12) i <- order(x, y); x <- x[i]; y <- y[i] plot(x, y, main = "arrows(.) and segments(.)") ## draw arrows from point to point : s <- seq(length(x)-1) # one shorter than data arrows(x[s], y[s], x[s+1], y[s+1], col= 1:3) s <- s[-length(s)] segments(x[s], y[s], x[s+2], y[s+2], col= 'pink') } plotdiff(expression(segments1()), "segments-1") plotdiffResult() gridGraphics/inst/test-scripts/test-barplot.R0000654000176200001440000000567312425755504021071 0ustar liggesusers require(grDevices) # for colours library(gridGraphics) set.seed(1) tN <- table(Ni <- stats::rpois(100, lambda = 5)) barplot1 <- function() { r <- barplot(tN, col = rainbow(20)) #- type = "h" plotting *is* 'bar'plot lines(r, tN, type = "h", col = "red", lwd = 2) } barplot2 <- function() { barplot(tN, space = 1.5, axisnames = FALSE, sub = "barplot(..., space= 1.5, axisnames = FALSE)") } barplot3 <- function() { barplot(VADeaths, beside = TRUE) } barplot4 <- function() { mp <- barplot(VADeaths) # default tot <- colMeans(VADeaths) text(mp, tot + 3, format(tot), xpd = TRUE, col = "blue") } barplot5 <- function() { barplot(VADeaths, beside = TRUE, col = c("lightblue", "mistyrose", "lightcyan", "lavender", "cornsilk"), legend = rownames(VADeaths), ylim = c(0, 100)) title(main = "Death Rates in Virginia", font.main = 4) } barplot6 <- function() { hh <- t(VADeaths)[, 5:1] mybarcol <- "gray20" mp <- barplot(hh, beside = TRUE, col = c("lightblue", "mistyrose", "lightcyan", "lavender"), legend = colnames(VADeaths), ylim = c(0,100), main = "Death Rates in Virginia", font.main = 4, sub = "Faked upper 2*sigma error bars", col.sub = mybarcol, cex.names = 1.5) segments(mp, hh, mp, hh + 2*sqrt(1000*hh/100), col = mybarcol, lwd = 1.5) mtext(side = 1, at = colMeans(mp), line = -2, text = paste("Mean", formatC(colMeans(hh))), col = "red") } barplot7 <- function() { # Bar shading example barplot(VADeaths, angle = 15+10*1:5, density = 20, col = "black", legend = rownames(VADeaths)) title(main = list("Death Rates in Virginia", font = 4)) } barplot8 <- function() { # border : barplot(VADeaths, border = "dark blue") } barplot9 <- function() { # log scales (not much sense here): barplot(tN, col = heat.colors(12), log = "y") } barplot10 <- function() { barplot(tN, col = gray.colors(20), log = "xy") } barplot11 <- function() { # args.legend barplot(height = cbind(x = c(465, 91) / 465 * 100, y = c(840, 200) / 840 * 100, z = c(37, 17) / 37 * 100), beside = FALSE, width = c(465, 840, 37), col = c(1, 2), legend.text = c("A", "B"), args.legend = list(x = "topleft")) } plotdiff(expression(barplot1()), "barplot-1") plotdiff(expression(barplot2()), "barplot-2") plotdiff(expression(barplot3()), "barplot-3") plotdiff(expression(barplot4()), "barplot-4") plotdiff(expression(barplot5()), "barplot-5") plotdiff(expression(barplot6()), "barplot-6") plotdiff(expression(barplot7()), "barplot-7") plotdiff(expression(barplot8()), "barplot-8") plotdiff(expression(barplot9()), "barplot-9") plotdiff(expression(barplot10()), "barplot-10", width=14) plotdiff(expression(barplot11()), "barplot-11") plotdiffResult() gridGraphics/inst/test-scripts/test-points.R0000654000176200001440000000241312430012303020702 0ustar liggesusers library(gridGraphics) ## ------------ test code for various pch specifications ------------- # Try this in various font families (including Hershey) # and locales. Use sign = -1 asserts we want Latin-1. # Standard cases in a MBCS locale will not plot the top half. TestChars <- function(sign = 1, font = 1, ...) { MB <- l10n_info()$MBCS r <- if(font == 5) { sign <- 1; c(32:126, 160:254) } else if(MB) 32:126 else 32:255 if (sign == -1) r <- c(32:126, 160:255) par(pty = "s") plot(c(-1,16), c(-1,16), type = "n", xlab = "", ylab = "", xaxs = "i", yaxs = "i", main = sprintf("sign = %d, font = %d", sign, font)) grid(17, 17, lty = 1) ; mtext(paste("MBCS:", MB)) for(i in r) try(points(i%%16, i%/%16, pch = sign*i, font = font,...)) } points1 <- function() { TestChars() } points2 <- function() { try(TestChars(sign = -1)) } points3 <- function() { TestChars(font = 5) # Euro might be at 160 (0+10*16). # Mac OS has apple at 240 (0+15*16). } points4 <- function() { try(TestChars(-1, font = 2)) # bold } plotdiff(expression(points1()), "points-1") plotdiff(expression(points2()), "points-2") plotdiff(expression(points3()), "points-3") plotdiff(expression(points4()), "points-4") plotdiffResult() gridGraphics/inst/test-scripts/test-axis.R0000654000176200001440000000331313467114252020353 0ustar liggesusers library(gridGraphics) require(stats) # for rnorm axis1 <- function() { set.seed(1) plot(1:4, rnorm(4), axes = FALSE) axis(1, 1:4, LETTERS[1:4]) axis(2) box() #- to make it look "as usual" } axis2 <- function() { set.seed(1) plot(1:7, rnorm(7), main = "axis() examples", type = "s", xaxt = "n", frame = FALSE, col = "red") axis(1, 1:7, LETTERS[1:7], col.axis = "blue") # unusual options: axis(4, col = "violet", col.axis = "dark violet", lwd = 2) axis(3, col = "gold", lty = 2, lwd = 0.5) } axis3 <- function() { # one way to have a custom x axis plot(1:10, xaxt = "n") axis(1, xaxp = c(2, 9, 7)) } # Test axis drawn in outer margin axis4 <- function() { par(omi=rep(.5, 4)) plot(1:10) box("inner", lty="dashed") axis(1, outer=TRUE) axis(2, outer=TRUE) } plotdiff(expression(axis1()), "axis-1") plotdiff(expression(axis2()), "axis-2") plotdiff(expression(axis3()), "axis-3") plotdiff(expression(axis4()), "axis-4") if (getRversion() >= "3.6.0") { ## Dotchart test (dotchart() modifies then resets par()) axis5 <- function() { dotchart(1:10, cex=1.5) axis(1, at=1:9, cex.axis=1.5) } ## Tests of psychotic behaviour (modifying par() between plot() and axis()) axis6 <- function() { plot(1) par(cex=2) axis(1) } axis7 <- function() { plot(1) par(mex=2) axis(1) } axis8 <- function() { plot(1) par(mar=rep(4, 4)) axis(1) } plotdiff(expression(axis5()), "axis-5") plotdiff(expression(axis6()), "axis-6") plotdiff(expression(axis7()), "axis-7") plotdiff(expression(axis8()), "axis-8") } plotdiffResult() gridGraphics/inst/test-scripts/test-missing.R0000654000176200001440000000150012432522232021044 0ustar liggesusers library(gridGraphics) n <- 7 primtest2 <- function(nas, na) { angle <- seq(0, 2*pi, length=n+1)[-(n+1)] y <- 0.5 + 0.4*sin(angle) x <- 0.5 + 0.4*cos(angle) if (any(nas)) text(x[nas], y[nas], paste("NA", (1:n)[nas], sep=""), col="gray") x[nas] <- na y[nas] <- na polygon(x, y, col="light gray", border=NA) lines(x, y) } celltest <- function(r, c, nas, na) { plot.new() primtest2(nas, na) } cellnas <- function(i) { temp <- rep(FALSE, n) temp[i] <- TRUE temp[n-3+i] <- TRUE temp } missing1 <- function() { par(mfrow=c(2, 2), mar=rep(0, 4), pty="s") celltest(1, 1, rep(FALSE, n), NA) celltest(1, 2, cellnas(1), NA) celltest(2, 1, cellnas(2), NA) celltest(2, 2, cellnas(3), NA) } plotdiff(expression(missing1()), "missing-1") plotdiffResult() gridGraphics/inst/test-scripts/test-plot.factor.R0000654000176200001440000000142012430004700021620 0ustar liggesusers library(gridGraphics) require(grDevices) plot.factor1 <- function() { plot(weight ~ group, data = PlantGrowth) # numeric vector ~ factor } plot.factor2 <- function() { plot(cut(weight, 2) ~ group, data = PlantGrowth) # factor ~ factor ## passing "..." to spineplot() eventually: } plot.factor3 <- function() { plot(cut(weight, 3) ~ group, data = PlantGrowth, col = hcl(c(0, 120, 240), 50, 70)) } plot.factor4 <- function() { plot(PlantGrowth$group, axes = FALSE, main = "no axes") # extremely silly } plotdiff(expression(plot.factor1()), "plot.factor-1") plotdiff(expression(plot.factor2()), "plot.factor-2") plotdiff(expression(plot.factor3()), "plot.factor-3") plotdiff(expression(plot.factor4()), "plot.factor-4") plotdiffResult() gridGraphics/inst/test-scripts/test-clip.R0000654000176200001440000000052612425524372020342 0ustar liggesusers library(gridGraphics) clip1 <- function() { set.seed(1) x <- rnorm(1000) hist(x, xlim = c(-4,4)) usr <- par("usr") clip(usr[1], -2, usr[3], usr[4]) hist(x, col = 'red', add = TRUE) clip(2, usr[2], usr[3], usr[4]) hist(x, col = 'blue', add = TRUE) } plotdiff(expression(clip1()), "clip-1") plotdiffResult() gridGraphics/inst/test-scripts/test-palette.R0000654000176200001440000000213712431226655021051 0ustar liggesusers require(graphics) library(gridGraphics) palette1 <- function() { palette(gray(seq(0,.9,len = 25))) # gray scales matplot(outer(1:100, 1:30), type = "l", lty = 1,lwd = 2, col = 1:30, main = "Gray Scales Palette", sub = "palette(gray(seq(0, .9, len=25)))") } palette2 <- function() { ## on a device where alpha-transparency is supported, ## use 'alpha = 0.3' transparency with the default palette : palette(gray(seq(0,.9,len = 25))) # gray scales mycols <- adjustcolor(palette(), alpha.f = 0.3) opal <- palette(mycols) set.seed(1) x <- rnorm(1000); xy <- cbind(x, 3*x + rnorm(1000)) plot (xy, lwd = 2, main = "Alpha-Transparency Palette\n alpha = 0.3") xy[,1] <- -xy[,1] points(xy, col = 8, pch = 16, cex = 1.5) } palette3 <- function() { palette(rainbow(10)) plot(1:10, pch=16, col=1:10, cex=3) palette(heat.colors(10)) points(10:1, pch=16, col=1:10, cex=3) } plotdiff(expression(palette1()), "palette-1") plotdiff(expression(palette2()), "palette-2") plotdiff(expression(palette3()), "palette-3") plotdiffResult() gridGraphics/inst/test-scripts/test-boxplot.R0000654000176200001440000000455112425771334021106 0ustar liggesusers library(gridGraphics) boxplot1 <- function() { ## boxplot on a formula: boxplot(count ~ spray, data = InsectSprays, col = "lightgray") # *add* notches (somewhat funny here): boxplot(count ~ spray, data = InsectSprays, notch = TRUE, add = TRUE, col = "blue") } boxplot2 <- function() { boxplot(decrease ~ treatment, data = OrchardSprays, log = "y", col = "bisque") } boxplot3 <- function() { rb <- boxplot(decrease ~ treatment, data = OrchardSprays, col = "bisque") title("Comparing boxplot()s and non-robust mean +/- SD") mn.t <- tapply(OrchardSprays$decrease, OrchardSprays$treatment, mean) sd.t <- tapply(OrchardSprays$decrease, OrchardSprays$treatment, sd) xi <- 0.3 + seq(rb$n) points(xi, mn.t, col = "orange", pch = 18) arrows(xi, mn.t - sd.t, xi, mn.t + sd.t, code = 3, col = "pink", angle = 75, length = .1) } mat <- cbind(Uni05 = (1:100)/21, Norm = rnorm(100), `5T` = rt(100, df = 5), Gam2 = rgamma(100, shape = 2)) boxplot4 <- function() { ## boxplot on a matrix: boxplot(as.data.frame(mat), main = "boxplot(as.data.frame(mat), main = ...)") } boxplot5 <- function() { par(las = 1) # all axis labels horizontal boxplot(as.data.frame(mat), main = "boxplot(*, horizontal = TRUE)", horizontal = TRUE) } boxplot6 <- function() { ## Using 'at = ' and adding boxplots -- example idea by Roger Bivand : boxplot(len ~ dose, data = ToothGrowth, boxwex = 0.25, at = 1:3 - 0.2, subset = supp == "VC", col = "yellow", main = "Guinea Pigs' Tooth Growth", xlab = "Vitamin C dose mg", ylab = "tooth length", xlim = c(0.5, 3.5), ylim = c(0, 35), yaxs = "i") boxplot(len ~ dose, data = ToothGrowth, add = TRUE, boxwex = 0.25, at = 1:3 + 0.2, subset = supp == "OJ", col = "orange") legend(2, 9, c("Ascorbic acid", "Orange juice"), fill = c("yellow", "orange")) } plotdiff(expression(boxplot1()), "boxplot-1") plotdiff(expression(boxplot2()), "boxplot-2") # Was getting weird single-pixel difference in (anti-aliased) dashed line plotdiff(expression(boxplot3()), "boxplot-3", width=9, height=9) plotdiff(expression(boxplot4()), "boxplot-4") plotdiff(expression(boxplot5()), "boxplot-5") plotdiff(expression(boxplot6()), "boxplot-6") plotdiffResult() gridGraphics/inst/test-scripts/test-boxplot.matrix.R0000654000176200001440000000057012425765340022406 0ustar liggesusers library(gridGraphics) boxplot.matrix1 <- function() { set.seed(1) mat <- cbind(Uni05 = (1:100)/21, Norm = rnorm(100), T5 = rt(100, df = 5), Gam2 = rgamma(100, shape = 2)) boxplot(mat, main = "boxplot.matrix(...., main = ...)", notch = TRUE, col = 1:4) } plotdiff(expression(boxplot.matrix1()), "boxplot.matrix-1") plotdiffResult() gridGraphics/inst/test-scripts/test-legend.R0000654000176200001440000001431113256770123020646 0ustar liggesusers library(gridGraphics) require(stats) legend1 <- function() { ## Run the example in '?matplot' or the following: leg.txt <- c("Setosa Petals", "Setosa Sepals", "Versicolor Petals", "Versicolor Sepals") y.leg <- c(4.5, 3, 2.1, 1.4, .7) cexv <- c(1.2, 1, 4/5, 2/3, 1/2) matplot(c(1, 8), c(0, 4.5), type = "n", xlab = "Length", ylab = "Width", main = "Petal and Sepal Dimensions in Iris Blossoms") for (i in seq(cexv)) { text (1, y.leg[i] - 0.1, paste("cex=", formatC(cexv[i])), cex = 0.8, adj = 0) legend(3, y.leg[i], leg.txt, pch = "sSvV", col = c(1, 3), cex = cexv[i]) } } legend2 <- function() { ## 'merge = TRUE' for merging lines & points: x <- seq(-pi, pi, len = 65) plot(x, sin(x), type = "l", ylim = c(-1.2, 1.8), col = 3, lty = 2) points(x, cos(x), pch = 3, col = 4) lines(x, tan(x), type = "b", lty = 1, pch = 4, col = 6) title("legend(..., lty = c(2, -1, 1), pch = c(NA, 3, 4), merge = TRUE)", cex.main = 1.1) legend(-1, 1.9, c("sin", "cos", "tan"), col = c(3, 4, 6), text.col = "green4", lty = c(2, -1, 1), pch = c(NA, 3, 4), merge = TRUE, bg = "gray90") } legend3 <- function() { ## right-justifying a set of labels: thanks to Uwe Ligges x <- 1:5; y1 <- 1/x; y2 <- 2/x plot(rep(x, 2), c(y1, y2), type = "n", xlab = "x", ylab = "y") lines(x, y1); lines(x, y2, lty = 2) temp <- legend("topright", legend = c(" ", " "), text.width = strwidth("1,000,000"), lty = 1:2, xjust = 1, yjust = 1, title = "Line Types") text(temp$rect$left + temp$rect$w, temp$text$y, c("1,000", "1,000,000"), pos = 2) } legend4 <- function() { ##--- log scaled Examples ------------------------------ leg.txt <- c("a one", "a two") par(mfrow = c(2, 2)) for(ll in c("","x","y","xy")) { plot(2:10, log = ll, main = paste0("log = '", ll, "'")) abline(1, 1) lines(2:3, 3:4, col = 2) points(2, 2, col = 3) rect(2, 3, 3, 2, col = 4) text(c(3,3), 2:3, c("rect(2,3,3,2, col=4)", "text(c(3,3),2:3,\"c(rect(...)\")"), adj = c(0, 0.3)) legend(list(x = 2,y = 8), legend = leg.txt, col = 2:3, pch = 1:2, lty = 1, merge = TRUE) #, trace = TRUE) } } legend5 <- function() { ##-- Math expressions: ------------------------------ x <- seq(-pi, pi, len = 65) plot(x, sin(x), type = "l", col = 2, xlab = expression(phi), ylab = expression(f(phi))) abline(h = -1:1, v = pi/2*(-6:6), col = "gray90") lines(x, cos(x), col = 3, lty = 2) ex.cs1 <- expression(plain(sin) * phi, paste("cos", phi)) # 2 ways utils::str(legend(-3, .9, ex.cs1, lty = 1:2, plot = FALSE, adj = c(0, 0.6))) # adj y ! legend(-3, 0.9, ex.cs1, lty = 1:2, col = 2:3, adj = c(0, 0.6)) } legend6 <- function() { x <- rexp(100, rate = .5) hist(x, main = "Mean and Median of a Skewed Distribution") abline(v = mean(x), col = 2, lty = 2, lwd = 2) abline(v = median(x), col = 3, lty = 3, lwd = 2) ex12 <- expression(bar(x) == sum(over(x[i], n), i == 1, n), hat(x) == median(x[i], i == 1, n)) utils::str(legend(4.1, 30, ex12, col = 2:3, lty = 2:3, lwd = 2)) } legend7 <- function() { ## 'Filled' boxes -- for more, see example(plot.factor) op <- par(bg = "white") # to get an opaque box for the legend plot(cut(weight, 3) ~ group, data = PlantGrowth, col = NULL, density = 16*(1:3)) } legend8 <- function() { ## Using 'ncol' : x <- 0:64/64 matplot(x, outer(x, 1:7, function(x, k) sin(k * pi * x)), type = "o", col = 1:7, ylim = c(-1, 1.5), pch = "*") op <- par(bg = "antiquewhite1") legend(0, 1.5, paste("sin(", 1:7, "pi * x)"), col = 1:7, lty = 1:7, pch = "*", ncol = 4, cex = 0.8) legend(.8,1.2, paste("sin(", 1:7, "pi * x)"), col = 1:7, lty = 1:7, pch = "*", cex = 0.8) legend(0, -.1, paste("sin(", 1:4, "pi * x)"), col = 1:4, lty = 1:4, ncol = 2, cex = 0.8) legend(0, -.4, paste("sin(", 5:7, "pi * x)"), col = 4:6, pch = 24, ncol = 2, cex = 1.5, lwd = 2, pt.bg = "pink", pt.cex = 1:3) } legend9 <- function() { ## point covering line : x <- 0:64/64 y <- sin(3*pi*x) plot(x, y, type = "l", col = "blue", main = "points with bg & legend(*, pt.bg)") points(x, y, pch = 21, bg = "white") legend(.4,1, "sin(c x)", pch = 21, pt.bg = "white", lty = 1, col = "blue") } legend10 <- function() { ## legends with titles at different locations x <- 0:64/64 y <- sin(3*pi*x) plot(x, y, type = "n") legend("bottomright", "(x,y)", pch = 1, title = "bottomright") legend("bottom", "(x,y)", pch = 1, title = "bottom") legend("bottomleft", "(x,y)", pch = 1, title = "bottomleft") legend("left", "(x,y)", pch = 1, title = "left") legend("topleft", "(x,y)", pch = 1, title = "topleft, inset = .05", inset = .05) legend("top", "(x,y)", pch = 1, title = "top") legend("topright", "(x,y)", pch = 1, title = "topright, inset = .02", inset = .02) legend("right", "(x,y)", pch = 1, title = "right") legend("center", "(x,y)", pch = 1, title = "center") } legend11 <- function() { # using text.font (and text.col): par(mfrow = c(2, 2), mar = rep(2.1, 4)) c6 <- terrain.colors(10)[1:6] for(i in 1:4) { plot(1, type = "n", axes = FALSE, ann = FALSE); title(paste("text.font =",i)) legend("top", legend = LETTERS[1:6], col = c6, ncol = 2, cex = 2, lwd = 3, text.font = i, text.col = c6) } } plotdiff(expression(legend1()), "legend-1") ## Straight to PNG to avoid PDF->PNG funny business plotdiff(expression(legend2()), "legend-2", dev="png") plotdiff(expression(legend3()), "legend-3") plotdiff(expression(legend4()), "legend-4") plotdiff(expression(legend5()), "legend-5") plotdiff(expression(legend6()), "legend-6") plotdiff(expression(legend7()), "legend-7") plotdiff(expression(legend8()), "legend-8") plotdiff(expression(legend9()), "legend-9") plotdiff(expression(legend10()), "legend-10") plotdiff(expression(legend11()), "legend-11") plotdiffResult() gridGraphics/inst/test-scripts/test-lines.R0000654000176200001440000000040413256770123020520 0ustar liggesusers library(gridGraphics) lines1 <- function() { plot(cars, main = "Stopping Distance versus Speed") lines(stats::lowess(cars)) } ## Straight to PNG to avoid PDF->PNG funny business plotdiff(expression(lines1()), "lines-1", dev="png") plotdiffResult() gridGraphics/inst/test-scripts/test-assocplot.R0000654000176200001440000000040112425541466021415 0ustar liggesusers library(gridGraphics) assocplot1 <- function() { ## Aggregate over sex: x <- margin.table(HairEyeColor, c(1, 2)) assocplot(x, main = "Relation between hair and eye color") } plotdiff(expression(assocplot1()), "assocplot-1") plotdiffResult() gridGraphics/inst/test-scripts/test-plot.window.R0000654000176200001440000000065212425543332021674 0ustar liggesusers require(stats) # normally loaded library(gridGraphics) plot.window1 <- function() { loc <- cmdscale(eurodist) rx <- range(x <- loc[,1]) ry <- range(y <- -loc[,2]) plot(x, y, type = "n", asp = 1, xlab = "", ylab = "") abline(h = pretty(rx, 10), v = pretty(ry, 10), col = "lightgray") text(x, y, labels(eurodist), cex = 0.8) } plotdiff(expression(plot.window1()), "plot.window-1") plotdiffResult() gridGraphics/inst/test-scripts/test-plot.default.R0000654000176200001440000000342512430000316021774 0ustar liggesusers library(gridGraphics) Speed <- cars$speed Distance <- cars$dist plot.default1 <- function() { plot(Speed, Distance, panel.first = grid(8, 8), pch = 0, cex = 1.2, col = "blue") } plot.default2 <- function() { plot(Speed, Distance, panel.first = lines(stats::lowess(Speed, Distance), lty = "dashed"), pch = 0, cex = 1.2, col = "blue") } plot.default3 <- function() { ## Show the different plot types x <- 0:12 y <- sin(pi/5 * x) par(mfrow = c(3,3), mar = .1+ c(2,2,3,1)) for (tp in c("p","l","b", "c","o","h", "s","S","n")) { plot(y ~ x, type = tp, main = paste0("plot(*, type = \"", tp, "\")")) if(tp == "S") { lines(x, y, type = "s", col = "red", lty = 2) mtext("lines(*, type = \"s\", ...)", col = "red", cex = 0.8) } } } plot.default4 <- function() { ##--- Log-Log Plot with custom axes lx <- seq(1, 5, length = 41) yl <- expression(e^{-frac(1,2) * {log[10](x)}^2}) y <- exp(-.5*lx^2) par(mfrow = c(2,1), mar = c(5, 5, 1, 1)) plot(10^lx, y, log = "xy", type = "l", col = "purple", main = "Log-Log plot", ylab = yl, xlab = "x") plot(10^lx, y, log = "xy", type = "o", pch = ".", col = "forestgreen", main = "Log-Log plot with custom axes", ylab = yl, xlab = "x", axes = FALSE, frame.plot = TRUE) my.at <- 10^(1:5) axis(1, at = my.at, labels = formatC(my.at, format = "fg")) at.y <- 10^(-5:-1) axis(2, at = at.y, labels = formatC(at.y, format = "fg"), col.axis = "red") } plotdiff(expression(plot.default1()), "plot.default-1") plotdiff(expression(plot.default2()), "plot.default-2") plotdiff(expression(plot.default3()), "plot.default-3") plotdiff(expression(plot.default4()), "plot.default-4", height=12) plotdiffResult() gridGraphics/inst/test-scripts/test-path.R0000654000176200001440000000257312424037712020347 0ustar liggesusers library(gridGraphics) plotPath <- function(x, y, col = "grey", rule = "winding") { plot.new() plot.window(range(x, na.rm = TRUE), range(y, na.rm = TRUE)) polypath(x, y, col = col, rule = rule) if (!is.na(col)) mtext(paste("Rule:", rule), side = 1, line = 0) } plotRules <- function(x, y, title) { plotPath(x, y) plotPath(x, y, rule = "evenodd") mtext(title, side = 3, line = 0) plotPath(x, y, col = NA) } path1 <- function() { par(mfrow = c(5, 3), mar = c(2, 1, 1, 1)) plotRules(c(.1, .1, .9, .9, NA, .2, .2, .8, .8), c(.1, .9, .9, .1, NA, .2, .8, .8, .2), "Nested rectangles, both clockwise") plotRules(c(.1, .1, .9, .9, NA, .2, .8, .8, .2), c(.1, .9, .9, .1, NA, .2, .2, .8, .8), "Nested rectangles, outer clockwise, inner anti-clockwise") plotRules(c(.1, .1, .4, .4, NA, .6, .9, .9, .6), c(.1, .4, .4, .1, NA, .6, .6, .9, .9), "Disjoint rectangles") plotRules(c(.1, .1, .6, .6, NA, .4, .4, .9, .9), c(.1, .6, .6, .1, NA, .4, .9, .9, .4), "Overlapping rectangles, both clockwise") plotRules(c(.1, .1, .6, .6, NA, .4, .9, .9, .4), c(.1, .6, .6, .1, NA, .4, .4, .9, .9), "Overlapping rectangles, one clockwise, other anti-clockwise") } plotdiff(expression(path1()), "path-1") plotdiffResult() gridGraphics/inst/test-scripts/test-title.R0000654000176200001440000000250613256770123020534 0ustar liggesusers library(gridGraphics) title1 <- function() { plot(cars, main = "") # here, could use main directly title(main = "Stopping Distance versus Speed") } title2 <- function() { plot(cars, main = "") title(main = list("Stopping Distance versus Speed", cex = 1.5, col = "red", font = 3)) } title3 <- function() { ## Specifying "..." : plot(1, col.axis = "sky blue", col.lab = "thistle") title("Main Title", sub = "sub title", cex.main = 2, font.main= 4, col.main= "blue", cex.sub = 0.75, font.sub = 3, col.sub = "red") } title4 <- function() { x <- seq(-4, 4, len = 101) y <- cbind(sin(x), cos(x)) matplot(x, y, type = "l", xaxt = "n", main = expression(paste(plain(sin) * phi, " and ", plain(cos) * phi)), ylab = expression("sin" * phi, "cos" * phi), # only 1st is taken xlab = expression(paste("Phase Angle ", phi)), col.main = "blue") axis(1, at = c(-pi, -pi/2, 0, pi/2, pi), labels = expression(-pi, -pi/2, 0, pi/2, pi)) abline(h = 0, v = pi/2 * c(-1,1), lty = 2, lwd = .1, col = "gray70") } plotdiff(expression(title1()), "title-1", dev="png") plotdiff(expression(title2()), "title-2") plotdiff(expression(title3()), "title-3") plotdiff(expression(title4()), "title-4") plotdiffResult() gridGraphics/inst/test-scripts/test-par.R0000654000176200001440000000354212424531474020176 0ustar liggesusers require(grDevices) # for gray library(gridGraphics) par1 <- function() { par("ylog") # FALSE plot(1 : 12, log = "y") par("ylog") # TRUE } par2 <- function() { plot(1:2, xaxs = "i") # 'inner axis' w/o extra space par(c("usr", "xaxp")) } par3 <- function() { ( nr.prof <- c(prof.pilots = 16, lawyers = 11, farmers = 10, salesmen = 9, physicians = 9, mechanics = 6, policemen = 6, managers = 6, engineers = 5, teachers = 4, housewives = 3, students = 3, armed.forces = 1)) par(las = 3) barplot(rbind(nr.prof)) # R 0.63.2: shows alignment problem par(las = 0) # reset to default } par4 <- function() { ## 'fg' use: plot(1:12, type = "b", main = "'fg' : axes, ticks and box in gray", fg = gray(0.7), bty = "7" , sub = R.version.string) } ## Line types showLty <- function(ltys, xoff = 0, ...) { stopifnot((n <- length(ltys)) >= 1) op <- par(mar = rep(.5,4)); on.exit(par(op)) plot(0:1, 0:1, type = "n", axes = FALSE, ann = FALSE) y <- (n:1)/(n+1) clty <- as.character(ltys) mytext <- function(x, y, txt) text(x, y, txt, adj = c(0, -.3), cex = 0.8, ...) abline(h = y, lty = ltys, ...); mytext(xoff, y, clty) y <- y - 1/(3*(n+1)) abline(h = y, lty = ltys, lwd = 2, ...) mytext(1/8+xoff, y, paste(clty," lwd = 2")) } par5 <- function() { showLty(c("solid", "dashed", "dotted", "dotdash", "longdash", "twodash")) par(new = TRUE) # the same: showLty(c("solid", "44", "13", "1343", "73", "2262"), xoff = .2, col = 2) } par6 <- function() { showLty(c("11", "22", "33", "44", "12", "13", "14", "21", "31")) } plotdiff(expression(par1()), "par-1") plotdiff(expression(par2()), "par-2") plotdiff(expression(par3()), "par-3") plotdiff(expression(par4()), "par-4") plotdiff(expression(par5()), "par-5") plotdiff(expression(par6()), "par-6") plotdiffResult() gridGraphics/inst/test-scripts/test-abline.R0000654000176200001440000000275112432446170020644 0ustar liggesusers library(gridGraphics) abline1 <- function() { ## Setup up coordinate system (with x == y aspect ratio): plot(c(-2,3), c(-1,5), type = "n", xlab = "x", ylab = "y", asp = 1) ## the x- and y-axis, and an integer grid abline(h = 0, v = 0, col = "gray60") text(1,0, "abline( h = 0 )", col = "gray60", adj = c(0, -.1)) abline(h = -1:5, v = -2:3, col = "lightgray", lty = 3) abline(a = 1, b = 2, col = 2) text(1,3, "abline( 1, 2 )", col = 2, adj = c(-.1, -.1)) } abline2 <- function() { ## Simple Regression Lines: require(stats) sale5 <- c(6, 4, 9, 7, 6, 12, 8, 10, 9, 13) plot(sale5) abline(lsfit(1:10, sale5)) abline(lsfit(1:10, sale5, intercept = FALSE), col = 4) # less fitting } abline3 <- function() { z <- lm(dist ~ speed, data = cars) plot(cars) abline(z) # equivalent to abline(reg = z) or abline(coef = coef(z)) ## trivial intercept model abline(mC <- lm(dist ~ 1, data = cars)) ## the same as abline(a = coef(mC), b = 0, col = "blue") } # Test 'untf' and log scales abline4 <- function() { par(mfrow=c(2, 2), mar=c(5, 4, 2, 2)) plot(1:10) abline(1, 1) plot(1:10, log="x") abline(1, 1, untf=TRUE) plot(1:10, log="y") abline(1, 1, untf=TRUE) plot(1:10, log="xy") abline(1, 1, untf=TRUE) } plotdiff(expression(abline1()), "abline-1") plotdiff(expression(abline2()), "abline-2") plotdiff(expression(abline3()), "abline-3") plotdiff(expression(abline4()), "abline-4") plotdiffResult() gridGraphics/inst/test-scripts/test-dend.R0000654000176200001440000000200013572021005020277 0ustar liggesusers library(gridGraphics) require(stats) # for rnorm hc <- hclust(dist(USArrests), "ave") dend1 <- function() { plot(hc) } dend2 <- function() { plot(hc, hang = -1) } hc <- hclust(dist(USArrests)^2, "cen") memb <- cutree(hc, k = 10) cent <- NULL for(k in 1:10){ cent <- rbind(cent, colMeans(USArrests[memb == k, , drop = FALSE])) } hc1 <- hclust(dist(cent)^2, method = "cen", members = table(memb)) dend3 <- function() { opar <- par(mfrow = c(1, 2)) plot(hc, labels = FALSE, hang = -1, main = "Original Tree") plot(hc1, labels = FALSE, hang = -1, main = "Re-start from 10 clusters") par(opar) } hcity.D <- hclust(UScitiesD, "ward.D") # "wrong" hcity.D2 <- hclust(UScitiesD, "ward.D2") dend4 <- function() { opar <- par(mfrow = c(1, 2)) plot(hcity.D, hang=-1) plot(hcity.D2, hang=-1) par(opar) } plotdiff(expression(dend1()), "dend-1") plotdiff(expression(dend2()), "dend-2") plotdiff(expression(dend3()), "dend-3") plotdiff(expression(dend4()), "dend-4") plotdiffResult() gridGraphics/inst/test-scripts/test-plot.formula.R0000654000176200001440000000111712430005127022016 0ustar liggesusers library(gridGraphics) plot.formula1 <- function() { par(mfrow = c(2,1)) plot(Ozone ~ Wind, data = airquality, pch = as.character(Month)) plot(Ozone ~ Wind, data = airquality, pch = as.character(Month), subset = Month != 7) } plot.formula2 <- function() { ## text.formula() can be very natural: wb <- within(warpbreaks, { time <- seq_along(breaks); W.T <- wool:tension }) plot(breaks ~ time, data = wb, type = "b") } plotdiff(expression(plot.formula1()), "plot.formula-1") plotdiff(expression(plot.formula2()), "plot.formula-2") plotdiffResult() gridGraphics/inst/test-scripts/test-plot.design.R0000654000176200001440000000172012430003765021630 0ustar liggesusers library(gridGraphics) require(stats) plot.design1 <- function() { plot.design(warpbreaks) # automatic for data frame with one numeric var. } plot.design2 <- function() { Form <- breaks ~ wool + tension summary(fm1 <- aov(Form, data = warpbreaks)) plot.design( Form, data = warpbreaks, col = 2) # same as above } plot.design3 <- function() { ## More than one y : plot.design(esoph) ## two plots; if interactive you are "ask"ed } plot.design4 <- function() { ## or rather, compare mean and median: par(mfcol = 1:2) plot.design(ncases/ncontrols ~ ., data = esoph, ylim = c(0, 0.8)) plot.design(ncases/ncontrols ~ ., data = esoph, ylim = c(0, 0.8), fun = median) } plotdiff(expression(plot.design1()), "plot.design-1") plotdiff(expression(plot.design2()), "plot.design-2") plotdiff(expression(plot.design3()), "plot.design-3") plotdiff(expression(plot.design4()), "plot.design-4", width=10) plotdiffResult() gridGraphics/inst/test-scripts/test-axis.POSIXct.R0000654000176200001440000000370212425547253021611 0ustar liggesusers library(gridGraphics) attach(beaver1) axis.POSIXct1 <- function() { time <- strptime(paste(1990, day, time %/% 100, time %% 100), "%Y %j %H %M") plot(time, temp, type = "l") # axis at 4-hour intervals. } axis.POSIXct2 <- function() { time <- strptime(paste(1990, day, time %/% 100, time %% 100), "%Y %j %H %M") # now label every hour on the time axis plot(time, temp, type = "l", xaxt = "n") r <- as.POSIXct(round(range(time), "hours")) axis.POSIXct(1, at = seq(r[1], r[2], by = "hour"), format = "%H") } axis.POSIXct3 <- function() { plot(.leap.seconds, seq_along(.leap.seconds), type = "n", yaxt = "n", xlab = "leap seconds", ylab = "", bty = "n") rug(.leap.seconds) } axis.POSIXct4 <- function() { ## or as dates lps <- as.Date(.leap.seconds) plot(lps, seq_along(.leap.seconds), type = "n", yaxt = "n", xlab = "leap seconds", ylab = "", bty = "n") rug(lps) } axis.POSIXct5 <- function() { ## 100 random dates in a 10-week period set.seed(1) random.dates <- as.Date("2001/1/1") + 70*sort(stats::runif(100)) plot(random.dates, 1:100) } axis.POSIXct6 <- function() { # or for a better axis labelling set.seed(1) random.dates <- as.Date("2001/1/1") + 70*sort(stats::runif(100)) plot(random.dates, 1:100, xaxt = "n") axis.Date(1, at = seq(as.Date("2001/1/1"), max(random.dates)+6, "weeks")) axis.Date(1, at = seq(as.Date("2001/1/1"), max(random.dates)+6, "days"), labels = FALSE, tcl = -0.2) } plotdiff(expression(axis.POSIXct1()), "axis.POSIXct-1") plotdiff(expression(axis.POSIXct2()), "axis.POSIXct-2", width=8, height=8) plotdiff(expression(axis.POSIXct3()), "axis.POSIXct-3") plotdiff(expression(axis.POSIXct4()), "axis.POSIXct-4") plotdiff(expression(axis.POSIXct5()), "axis.POSIXct-5") plotdiff(expression(axis.POSIXct6()), "axis.POSIXct-6", width=9, height=9) detach(beaver1) plotdiffResult() gridGraphics/inst/test-scripts/test-units.R0000654000176200001440000000060312430022511020531 0ustar liggesusers library(gridGraphics) units1 <- function() { ## plot labels offset 0.12 inches to the right ## of plotted symbols in a plot with(mtcars, { plot(mpg, disp, pch = 19, main = "Motor Trend Cars") text(mpg + xinch(0.12), disp, row.names(mtcars), adj = 0, cex = .7, col = "blue") }) } plotdiff(expression(units1()), "units-1") plotdiffResult() gridGraphics/inst/test-scripts/test-coplot.R0000654000176200001440000000377712426231257020724 0ustar liggesusers library(gridGraphics) coplot1 <- function() { ## Tonga Trench Earthquakes coplot(lat ~ long | depth, data = quakes) } coplot2 <- function() { given.depth <- co.intervals(quakes$depth, number = 4, overlap = .1) coplot(lat ~ long | depth, data = quakes, given.v = given.depth, rows = 1) } ll.dm <- lat ~ long | depth * mag coplot3 <- function() { ## Conditioning on 2 variables: coplot(ll.dm, data = quakes) } coplot4 <- function() { coplot(ll.dm, data = quakes, number = c(4, 7), show.given = c(TRUE, FALSE)) } coplot5 <- function() { coplot(ll.dm, data = quakes, number = c(3, 7), overlap = c(-.5, .1)) # negative overlap DROPS values } Index <- seq(length = nrow(warpbreaks)) # to get nicer default labels coplot6 <- function() { ## given two factors coplot(breaks ~ Index | wool * tension, data = warpbreaks, show.given = 0:1) } coplot7 <- function() { coplot(breaks ~ Index | wool * tension, data = warpbreaks, col = "red", bg = "pink", pch = 21, bar.bg = c(fac = "light blue")) } coplot8 <- function() { ## Example with empty panels: with(data.frame(state.x77), { coplot(Life.Exp ~ Income | Illiteracy * state.region, number = 3, panel = function(x, y, ...) panel.smooth(x, y, span = .8, ...)) }) } coplot9 <- function() { ## y ~ factor -- not really sensible, but 'show off': with(data.frame(state.x77), { coplot(Life.Exp ~ state.region | Income * state.division, panel = panel.smooth) }) } plotdiff(expression(coplot1()), "coplot-1") plotdiff(expression(coplot2()), "coplot-2") plotdiff(expression(coplot3()), "coplot-3", height=14) plotdiff(expression(coplot4()), "coplot-4", height=10) plotdiff(expression(coplot5()), "coplot-5", height=15) plotdiff(expression(coplot6()), "coplot-6") plotdiff(expression(coplot7()), "coplot-7") plotdiff(expression(coplot8()), "coplot-8", height=10) plotdiff(expression(coplot9()), "coplot-9", width=10, height=15) plotdiffResult() gridGraphics/inst/test-scripts/test-plot.histogram.R0000654000176200001440000000122512430005366022353 0ustar liggesusers library(gridGraphics) (wwt <- hist(women$weight, nclass = 7, plot = FALSE)) plot.histogram1 <- function() { plot(wwt, labels = TRUE) # default main & xlab using wwt$xname } plot.histogram2 <- function() { plot(wwt, border = "dark blue", col = "light blue", main = "Histogram of 15 women's weights", xlab = "weight [pounds]") ## Fake "lines" example, using non-default labels: w2 <- wwt; w2$counts <- w2$counts - 1 lines(w2, col = "Midnight Blue", labels = ifelse(w2$counts, "> 1", "1")) } plotdiff(expression(plot.histogram1()), "plot.histogram-1") plotdiff(expression(plot.histogram2()), "plot.histogram-2") plotdiffResult() gridGraphics/inst/test-scripts/test-spineplot.R0000654000176200001440000000370512430020301021405 0ustar liggesusers library(gridGraphics) ## treatment and improvement of patients with rheumatoid arthritis treatment <- factor(rep(c(1, 2), c(43, 41)), levels = c(1, 2), labels = c("placebo", "treated")) improved <- factor(rep(c(1, 2, 3, 1, 2, 3), c(29, 7, 7, 13, 7, 21)), levels = c(1, 2, 3), labels = c("none", "some", "marked")) spineplot1 <- function() { ## (dependence on a categorical variable) (spineplot(improved ~ treatment)) } spineplot2 <- function() { ## applications and admissions by department at UC Berkeley ## (two-way tables) (spineplot(margin.table(UCBAdmissions, c(3, 2)), main = "Applications at UCB")) } spineplot3 <- function() { (spineplot(margin.table(UCBAdmissions, c(3, 1)), main = "Admissions at UCB")) } ## NASA space shuttle o-ring failures fail <- factor(c(2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 2, 1, 2, 1, 1, 1, 1, 2, 1, 1, 1, 1, 1), levels = c(1, 2), labels = c("no", "yes")) temperature <- c(53, 57, 58, 63, 66, 67, 67, 67, 68, 69, 70, 70, 70, 70, 72, 73, 75, 75, 76, 76, 78, 79, 81) spineplot4 <- function() { ## (dependence on a numerical variable) (spineplot(fail ~ temperature)) } spineplot5 <- function() { (spineplot(fail ~ temperature, breaks = 3)) } spineplot6 <- function() { (spineplot(fail ~ temperature, breaks = quantile(temperature))) } spineplot7 <- function() { ## highlighting for failures spineplot(fail ~ temperature, ylevels = 2:1) } plotdiff(expression(spineplot1()), "spineplot-1") plotdiff(expression(spineplot2()), "spineplot-2") plotdiff(expression(spineplot3()), "spineplot-3") plotdiff(expression(spineplot4()), "spineplot-4", width=10, height=10) plotdiff(expression(spineplot5()), "spineplot-5", width=10, height=10) plotdiff(expression(spineplot6()), "spineplot-6") plotdiff(expression(spineplot7()), "spineplot-7", width=10, height=10) plotdiffResult() gridGraphics/inst/test-scripts/test-dotchart.R0000654000176200001440000000060712426266042021221 0ustar liggesusers library(gridGraphics) dotchart1 <- function() { dotchart(VADeaths, main = "Death Rates in Virginia - 1940") } dotchart2 <- function() { par(xaxs = "i") # 0 -- 100\% dotchart(t(VADeaths), xlim = c(0,100), main = "Death Rates in Virginia - 1940") } plotdiff(expression(dotchart1()), "dotchart-1") plotdiff(expression(dotchart2()), "dotchart-2") plotdiffResult() gridGraphics/inst/test-scripts/test-screen.R0000654000176200001440000000245012430015674020664 0ustar liggesusers library(gridGraphics) screen1 <- function() { par(bg = "white") # default is likely to be transparent split.screen(c(2, 1)) # split display into two screens split.screen(c(1, 3), screen = 2) # now split the bottom half into 3 screen(1) # prepare screen 1 for output plot(10:1) screen(4) # prepare screen 4 for output plot(10:1) close.screen(all = TRUE) # exit split-screen mode } screen2 <- function() { split.screen(c(2, 1)) # split display into two screens split.screen(c(1, 2), 2) # split bottom half in two plot(1:10) # screen 3 is active, draw plot erase.screen() # forgot label, erase and redraw plot(1:10, ylab = "ylab 3") screen(1) # prepare screen 1 for output plot(1:10) screen(4) # prepare screen 4 for output plot(1:10, ylab = "ylab 4") screen(1, FALSE) # return to screen 1, but do not clear plot(10:1, axes = FALSE, lty = 2, ylab = "") # overlay second plot axis(4) # add tic marks to right-hand axis title("Plot 1") close.screen(all = TRUE) # exit split-screen mode } plotdiff(expression(screen1()), "screen-1", width=10) plotdiff(expression(screen2()), "screen-2") plotdiffResult() gridGraphics/inst/test-scripts/test-text.R0000654000176200001440000000321013256770123020370 0ustar liggesusers library(gridGraphics) text1 <- function() { plot(-1:1, -1:1, type = "n", xlab = "Re", ylab = "Im") K <- 16; text(exp(1i * 2 * pi * (1:K) / K), col = 2) } text2 <- function() { ## The following two examples use latin1 characters: these may not ## appear correctly (or be omitted entirely). plot(1:10, 1:10, main = "text(...) examples\n~~~~~~~~~~~~~~", sub = "R is GNU ©, but not ® ...") mtext("«Latin-1 accented chars»: éè øØ å<Å æ<Æ", side = 3) points(c(6,2), c(2,1), pch = 3, cex = 4, col = "red") text(6, 2, "the text is CENTERED around (x,y) = (6,2) by default", cex = .8) text(2, 1, "or Left/Bottom - JUSTIFIED at (2,1) by 'adj = c(0,0)'", adj = c(0,0)) text(4, 9, expression(hat(beta) == (X^t * X)^{-1} * X^t * y)) text(4, 8.4, "expression(hat(beta) == (X^t * X)^{-1} * X^t * y)", cex = .75) text(4, 7, expression(bar(x) == sum(frac(x[i], n), i==1, n))) ## Two more latin1 examples text(5, 10.2, "Le français, c'est façile: Règles, Liberté, Egalité, Fraternité...") text(5, 9.8, "Jetz no chli züritüütsch: (noch ein bißchen Zürcher deutsch)") } # Test 'family' text3 <- function() { plot(1:3, type="n") families <- c("sans", "serif", "mono") for (i in 1:3) text(i, i, "test", family=families[i]) } # Test 'vfont' text4 <- function() { plot(1, type="n") text(1, 1, "test", vfont=c("serif", "plain")) } plotdiff(expression(text1()), "text-1") plotdiff(expression(text2()), "text-2", dev="png") plotdiff(expression(text3()), "text-3") plotdiff(expression(text4()), "text-4") plotdiffResult() gridGraphics/inst/test-scripts/test-rug.R0000654000176200001440000000053512430014462020176 0ustar liggesusers library(gridGraphics) require(stats) # both 'density' and its default method rug1 <- function() { with(faithful, { plot(density(eruptions, bw = 0.15)) rug(eruptions) rug(jitter(eruptions, amount = 0.01), side = 3, col = "light blue") }) } plotdiff(expression(rug1()), "rug-1", antialias=FALSE) plotdiffResult() gridGraphics/inst/test-scripts/test-pie.R0000654000176200001440000000241412427770376020177 0ustar liggesusers library(gridGraphics) require(grDevices) pie1 <- function() { pie(rep(1, 24), col = rainbow(24), radius = 0.9) } pie.sales <- c(0.12, 0.3, 0.26, 0.16, 0.04, 0.12) names(pie.sales) <- c("Blueberry", "Cherry", "Apple", "Boston Cream", "Other", "Vanilla Cream") pie2 <- function() { pie(pie.sales) # default colours } pie3 <- function() { pie(pie.sales, col = c("purple", "violetred1", "green3", "cornsilk", "cyan", "white")) } pie4 <- function() { pie(pie.sales, col = gray(seq(0.4, 1.0, length = 6))) } pie5 <- function() { pie(pie.sales, density = 10, angle = 15 + 10 * 1:6) } pie6 <- function() { pie(pie.sales, clockwise = TRUE, main = "pie(*, clockwise = TRUE)") segments(0, 0, 0, 1, col = "red", lwd = 2) text(0, 1, "init.angle = 90", col = "red") } pie7 <- function() { n <- 200 pie(rep(1, n), labels = "", col = rainbow(n), border = NA, main = "pie(*, labels=\"\", col=rainbow(n), border=NA,..") } plotdiff(expression(pie1()), "pie-1") plotdiff(expression(pie2()), "pie-2") plotdiff(expression(pie3()), "pie-3") plotdiff(expression(pie4()), "pie-4") plotdiff(expression(pie5()), "pie-5") plotdiff(expression(pie6()), "pie-6") plotdiff(expression(pie7()), "pie-7") plotdiffResult() gridGraphics/inst/test-scripts/test-bxp.R0000654000176200001440000000510713256770123020204 0ustar liggesusers require(stats) library(gridGraphics) set.seed(753) bxp.data <- split(rt(100, 4), gl(5, 20)) bx.p <- boxplot(bxp.data, plot=FALSE) bxp1 <- function() { boxplot(bxp.data) } bxp2 <- function() { par(mfrow = c(2, 2)) bxp(bx.p, xaxt = "n") bxp(bx.p, notch = TRUE, axes = FALSE, pch = 4, boxfill = 1:5) bxp(bx.p, notch = TRUE, boxfill = "lightblue", frame = FALSE, outl = FALSE, main = "bxp(*, frame= FALSE, outl= FALSE)") bxp(bx.p, notch = TRUE, boxfill = "lightblue", border = 2:6, ylim = c(-4,4), pch = 22, bg = "green", log = "x", main = "... log = 'x', ylim = *") } bxp3 <- function() { par(mfrow = c(1, 2)) ## single group -- no label boxplot (weight ~ group, data = PlantGrowth, subset = group == "ctrl") ## with label bx <- boxplot(weight ~ group, data = PlantGrowth, subset = group == "ctrl", plot = FALSE) bxp(bx, show.names=TRUE) } set.seed(1) z <- split(rnorm(1000), rpois(1000, 2.2)) bxp4 <- function() { ## examples for new (S+ like) features boxplot(z, whisklty = 3, main = "boxplot(z, whisklty = 3)") } bxp5 <- function() { ## Colour support similar to plot.default: par(mfrow = 1:2, bg = "light gray", fg = "midnight blue") boxplot(z, col.axis = "skyblue3", main = "boxplot(*, col.axis=..,main=..)") plot(z[[1]], col.axis = "skyblue3", main = "plot(*, col.axis=..,main=..)") mtext("par(bg=\"light gray\", fg=\"midnight blue\")", outer = TRUE, line = -1.2) } bxp6 <- function() { ## Mimic S-Plus: splus <- list(boxwex = 0.4, staplewex = 1, outwex = 1, boxfill = "grey40", medlwd = 3, medcol = "white", whisklty = 3, outlty = 1, outpch = NA) boxplot(z, pars = splus) ## Recycled and "sweeping" parameters } bxp7 <- function() { par(mfrow = c(1,2)) boxplot(z, border = 1:5, lty = 3, medlty = 1, medlwd = 2.5) boxplot(z, boxfill = 1:3, pch = 1:5, lwd = 1.5, medcol = "white") } bxp8 <- function() { ## too many possibilities boxplot(z, boxfill = "light gray", outpch = 21:25, outlty = 2, bg = "pink", lwd = 2, medcol = "dark blue", medcex = 2, medpch = 20) } plotdiff(expression(bxp1()), "bxp-1") plotdiff(expression(bxp2()), "bxp-2") plotdiff(expression(bxp3()), "bxp-3") ## Antialiasing of the "t" in boxplot() is unreliable plotdiff(expression(bxp4()), "bxp-4", antialias=FALSE) plotdiff(expression(bxp5()), "bxp-5", width=8) plotdiff(expression(bxp6()), "bxp-6") plotdiff(expression(bxp7()), "bxp-7") plotdiff(expression(bxp8()), "bxp-8") plotdiffResult() gridGraphics/inst/test-scripts/test-polygon.R0000654000176200001440000000315312425540465021102 0ustar liggesusers library(gridGraphics) polygon1 <- function() { x <- c(1:9, 8:1) y <- c(1, 2*(5:3), 2, -1, 17, 9, 8, 2:9) par(mfcol = c(3, 1)) for(xpd in c(FALSE, TRUE, NA)) { plot(1:10, main = paste("xpd =", xpd)) box("figure", col = "pink", lwd = 3) polygon(x, y, xpd = xpd, col = "orange", lty = 2, lwd = 2, border = "red") } } polygon2 <- function() { n <- 100 xx <- c(0:n, n:0) set.seed(1) yy <- c(c(0, cumsum(stats::rnorm(n))), rev(c(0, cumsum(stats::rnorm(n))))) plot (xx, yy, type = "n", xlab = "Time", ylab = "Distance") polygon(xx, yy, col = "gray", border = "red") title("Distance Between Brownian Motions") } polygon3 <- function() { # Multiple polygons from NA values # and recycling of col, border, and lty par(mfrow = c(2, 1), mar=c(5, 4, 2, 2)) plot(c(1, 9), 1:2, type = "n") polygon(1:9, c(2,1,2,1,1,2,1,2,1), col = c("red", "blue"), border = c("green", "yellow"), lwd = 3, lty = c("dashed", "solid")) plot(c(1, 9), 1:2, type = "n") polygon(1:9, c(2,1,2,1,NA,2,1,2,1), col = c("red", "blue"), border = c("green", "yellow"), lwd = 3, lty = c("dashed", "solid")) } polygon4 <- function() { # Line-shaded polygons plot(c(1, 9), 1:2, type = "n") polygon(1:9, c(2,1,2,1,NA,2,1,2,1), density = c(10, 20), angle = c(-45, 45)) } plotdiff(expression(polygon1()), "polygon-1") plotdiff(expression(polygon2()), "polygon-2") plotdiff(expression(polygon3()), "polygon-3") plotdiff(expression(polygon4()), "polygon-4") plotdiffResult() gridGraphics/inst/test-scripts/test-hist.R0000654000176200001440000000246312426471573020371 0ustar liggesusers library(gridGraphics) require(utils) # for str require(stats) hist1 <- function() { par(mfrow = c(2, 2)) hist(islands) utils::str(hist(islands, col = "gray", labels = TRUE)) hist(sqrt(islands), breaks = 12, col = "lightblue", border = "pink") ##-- For non-equidistant breaks, counts should NOT be graphed unscaled: r <- hist(sqrt(islands), breaks = c(4*0:5, 10*3:5, 70, 100, 140), col = "blue1") text(r$mids, r$density, r$counts, adj = c(.5, -.5), col = "blue3") lines(r, lty = 3, border = "purple") # -> lines.histogram(*) } hist2 <- function() { hist(islands, breaks = c(12,20,36,80,200,1000,17000), freq = TRUE, main = "WRONG histogram") # and warning } hist3 <- function() { set.seed(14) x <- rchisq(100, df = 4) par(mfrow = 2:1, mgp = c(1.5, 0.6, 0), mar = .1 + c(3,3:1)) ## Comparing data with a model distribution should be done with qqplot()! qqplot(x, qchisq(ppoints(x), df = 4)); abline(0, 1, col = 2, lty = 2) ## if you really insist on using hist() ... : hist(x, freq = FALSE, ylim = c(0, 0.2)) curve(dchisq(x, df = 4), col = 2, lty = 2, lwd = 2, add = TRUE) } plotdiff(expression(hist1()), "hist-1", width=10, height=10) plotdiff(expression(hist2()), "hist-2") plotdiff(expression(hist3()), "hist-3") plotdiffResult() gridGraphics/inst/test-scripts/test-grid.R0000654000176200001440000000147312426327163020342 0ustar liggesusers library(gridGraphics) grid1 <- function() { plot(1:3) grid(NA, 5, lwd = 2) # grid only in y-direction } grid2 <- function() { ## maybe change the desired number of tick marks: par(lab = c(mx, my, 7)) par(mfcol = 1:2) with(iris, { plot(Sepal.Length, Sepal.Width, col = as.integer(Species), xlim = c(4, 8), ylim = c(2, 4.5), panel.first = grid(), main = "with(iris, plot(...., panel.first = grid(), ..) )") plot(Sepal.Length, Sepal.Width, col = as.integer(Species), panel.first = grid(3, lty = 1, lwd = 2), main = "... panel.first = grid(3, lty = 1, lwd = 2), ..") } ) } plotdiff(expression(grid1()), "grid-1") plotdiff(expression(grid2()), "grid-2", width=9) plotdiffResult() gridGraphics/inst/test-scripts/test-stars.R0000654000176200001440000000623113256770123020546 0ustar liggesusers library(gridGraphics) require(grDevices) stars1 <- function() { stars(mtcars[, 1:7], key.loc = c(14, 2), main = "Motor Trend Cars : stars(*, full = F)", full = FALSE) } stars2 <- function() { stars(mtcars[, 1:7], key.loc = c(14, 1.5), main = "Motor Trend Cars : full stars()", flip.labels = FALSE) } stars3 <- function() { ## 'Spider' or 'Radar' plot: stars(mtcars[, 1:7], locations = c(0, 0), radius = FALSE, key.loc = c(0, 0), main = "Motor Trend Cars", lty = 2) } stars4 <- function() { ## Segment Diagrams: palette(rainbow(12, s = 0.6, v = 0.75)) stars(mtcars[, 1:7], len = 0.8, key.loc = c(12, 1.5), main = "Motor Trend Cars", draw.segments = TRUE) } stars5 <- function() { stars(mtcars[, 1:7], len = 0.6, key.loc = c(1.5, 0), main = "Motor Trend Cars", draw.segments = TRUE, frame.plot = TRUE, nrow = 4, cex = .7) } ## scale linearly (not affinely) to [0, 1] USJudge <- apply(USJudgeRatings, 2, function(x) x/max(x)) Jnam <- row.names(USJudgeRatings) Snam <- abbreviate(substring(Jnam, 1, regexpr("[,.]",Jnam) - 1), 7) stars6 <- function() { stars(USJudge, labels = Jnam, scale = FALSE, key.loc = c(13, 1.5), main = "Judge not ...", len = 0.8) } stars7 <- function() { stars(USJudge, labels = Snam, scale = FALSE, key.loc = c(13, 1.5), radius = FALSE) } stars8 <- function() { loc <- stars(USJudge, labels = NULL, scale = FALSE, radius = FALSE, frame.plot = TRUE, key.loc = c(13, 1.5), main = "Judge not ...", len = 1.2) text(loc, Snam, col = "blue", cex = 0.8, xpd = TRUE) } stars9 <- function() { ## 'Segments': stars(USJudge, draw.segments = TRUE, scale = FALSE, key.loc = c(13,1.5)) } stars10 <- function() { ## 'Spider': stars(USJudgeRatings, locations = c(0, 0), scale = FALSE, radius = FALSE, col.stars = 1:10, key.loc = c(0, 0), main = "US Judges rated") } stars11 <- function() { ## Same as above, but with colored lines instead of filled polygons. stars(USJudgeRatings, locations = c(0, 0), scale = FALSE, radius = FALSE, col.lines = 1:10, key.loc = c(0, 0), main = "US Judges rated") } stars12 <- function() { ## 'Radar-Segments' stars(USJudgeRatings[1:10,], locations = 0:1, scale = FALSE, draw.segments = TRUE, col.segments = 0, col.stars = 1:10, key.loc = 0:1, main = "US Judges 1-10 ") } stars13 <- function() { stars(cbind(1:16, 10*(16:1)), draw.segments = TRUE, main = "A Joke -- do *not* use symbols on 2D data!") } plotdiff(expression(stars1()), "stars-1") plotdiff(expression(stars2()), "stars-2") plotdiff(expression(stars3()), "stars-3") plotdiff(expression(stars4()), "stars-4") plotdiff(expression(stars5()), "stars-5") plotdiff(expression(stars6()), "stars-6") plotdiff(expression(stars7()), "stars-7") plotdiff(expression(stars8()), "stars-8", dev="png") plotdiff(expression(stars9()), "stars-9") plotdiff(expression(stars10()), "stars-10", dev="png") plotdiff(expression(stars11()), "stars-11", dev="png") plotdiff(expression(stars12()), "stars-12") plotdiff(expression(stars13()), "stars-13") plotdiffResult() gridGraphics/inst/test-scripts/test-mtext.R0000654000176200001440000000141612424320051020536 0ustar liggesusers library(gridGraphics) mtext1 <- function() { plot(1:10, (-4:5)^2, main = "Parabola Points", xlab = "xlab") mtext("10 of them") for(s in 1:4) mtext(paste("mtext(..., line= -1, {side, col, font} = ", s, ", cex = ", (1+s)/2, ")"), line = -1, side = s, col = s, font = s, cex = (1+s)/2) mtext("mtext(..., line= -2)", line = -2) mtext("mtext(..., line= -2, adj = 0)", line = -2, adj = 0) } mtext2 <- function() { ##--- log axis : plot(1:10, exp(1:10), log = "y", main = "log =\"y\"", xlab = "xlab") for(s in 1:4) mtext(paste("mtext(...,side=", s ,")"), side = s) } plotdiff(expression(mtext1()), "mtext-1", width=10, height=10) plotdiff(expression(mtext2()), "mtext-2", width=10, height=10) plotdiffResult() gridGraphics/inst/test-scripts/test-matplot.R0000654000176200001440000000507412427753246021104 0ustar liggesusers library(gridGraphics) require(grDevices) matplot1 <- function() { matplot((-4:5)^2, main = "Quadratic") # almost identical to plot(*) } sines <- outer(1:20, 1:4, function(x, y) sin(x / 20 * pi * y)) matplot2 <- function() { matplot(sines, pch = 1:4, type = "o", col = rainbow(ncol(sines))) } matplot3 <- function() { matplot(sines, type = "b", pch = 21:23, col = 2:5, bg = 2:5, main = "matplot(...., pch = 21:23, bg = 2:5)") } x <- 0:50/50 matplot4 <- function() { matplot(x, outer(x, 1:8, function(x, k) sin(k*pi * x)), ylim = c(-2,2), type = "plobcsSh", main= "matplot(,type = \"plobcsSh\" )") } matplot5 <- function() { ## pch & type = vector of 1-chars : matplot(x, outer(x, 1:4, function(x, k) sin(k*pi * x)), pch = letters[1:4], type = c("b","p","o")) } matplot6 <- function() { lends <- c("round","butt","square") matplot(matrix(1:12, 4), type="c", lty=1, lwd=10, lend=lends) text(cbind(2.5, 2*c(1,3,5)-.4), lends, col= 1:3, cex = 1.5) } table(iris$Species) # is data.frame with 'Species' factor iS <- iris$Species == "setosa" iV <- iris$Species == "versicolor" matplot7 <- function() { par(bg = "bisque") matplot(c(1, 8), c(0, 4.5), type = "n", xlab = "Length", ylab = "Width", main = "Petal and Sepal Dimensions in Iris Blossoms") matpoints(iris[iS,c(1,3)], iris[iS,c(2,4)], pch = "sS", col = c(2,4)) matpoints(iris[iV,c(1,3)], iris[iV,c(2,4)], pch = "vV", col = c(2,4)) legend(1, 4, c(" Setosa Petals", " Setosa Sepals", "Versicolor Petals", "Versicolor Sepals"), pch = "sSvV", col = rep(c(2,4), 2)) } nam.var <- colnames(iris)[-5] nam.spec <- as.character(iris[1+50*0:2, "Species"]) iris.S <- array(NA, dim = c(50,4,3), dimnames = list(NULL, nam.var, nam.spec)) for(i in 1:3) iris.S[,,i] <- data.matrix(iris[1:50+50*(i-1), -5]) matplot8 <- function() { matplot(iris.S[, "Petal.Length",], iris.S[, "Petal.Width",], pch = "SCV", col = rainbow(3, start = 0.8, end = 0.1), sub = paste(c("S", "C", "V"), dimnames(iris.S)[[3]], sep = "=", collapse= ", "), main = "Fisher's Iris Data") } plotdiff(expression(matplot1()), "matplot-1") plotdiff(expression(matplot2()), "matplot-2") plotdiff(expression(matplot3()), "matplot-3") plotdiff(expression(matplot4()), "matplot-4") plotdiff(expression(matplot5()), "matplot-5") plotdiff(expression(matplot6()), "matplot-6") plotdiff(expression(matplot7()), "matplot-7") plotdiff(expression(matplot8()), "matplot-8") plotdiffResult() gridGraphics/inst/test-scripts/test-plot.R0000654000176200001440000000134312430006010020343 0ustar liggesusers library(gridGraphics) require(stats) plot1 <- function() { plot(cars) lines(lowess(cars)) } plot2 <- function() { plot(sin, -pi, 2*pi) # see ?plot.function } plot3 <- function() { ## Discrete Distribution Plot: plot(table(rpois(100, 5)), type = "h", col = "red", lwd = 10, main = "rpois(100, lambda = 5)") } plot4 <- function() { ## Simple quantiles/ECDF, see ecdf() {library(stats)} for a better one: plot(x <- sort(rnorm(47)), type = "s", main = "plot(x, type = \"s\")") points(x, cex = .5, col = "dark red") } plotdiff(expression(plot1()), "plot-1") plotdiff(expression(plot2()), "plot-2") plotdiff(expression(plot3()), "plot-3") plotdiff(expression(plot4()), "plot-4") plotdiffResult() gridGraphics/inst/test-scripts/test-smoothScatter.R0000654000176200001440000000207112434737245022254 0ustar liggesusers library(gridGraphics) library(KernSmooth) ## A largish data set set.seed(1) n <- 10000 x1 <- matrix(rnorm(n), ncol = 2) x2 <- matrix(rnorm(n, mean = 3, sd = 1.5), ncol = 2) x <- rbind(x1, x2) smoothScatter1 <- function() { par(mfrow = c(2, 2)) smoothScatter(x, nrpoints = 0) smoothScatter(x) ## a different color scheme: Lab.palette <- colorRampPalette(c("blue", "orange", "red"), space = "Lab") smoothScatter(x, colramp = Lab.palette) ## somewhat similar, using identical smoothing computations, ## but considerably *less* efficient for really large data: plot(x, col = densCols(x), pch = 20) } smoothScatter2 <- function() { ## use with pairs: set.seed(1) y <- matrix(rnorm(40000), ncol = 4) + 3*rnorm(10000) y[, c(2,4)] <- -y[, c(2,4)] pairs(y, panel = function(...) smoothScatter(..., nrpoints = 0, add = TRUE)) } plotdiff(expression(smoothScatter1()), "smoothScatter-1", antialias=FALSE) plotdiff(expression(smoothScatter2()), "smoothScatter-2", antialias=FALSE, width=10, height=10) plotdiffResult() gridGraphics/inst/test-scripts/test-symbols.R0000654000176200001440000000351713256770123021106 0ustar liggesusers library(gridGraphics) require(stats); require(grDevices) set.seed(1) x <- 1:10 y <- sort(10*runif(10)) z <- runif(10) z3 <- cbind(z, 2*runif(10), runif(10)) symbols1 <- function() { symbols(x, y, thermometers = cbind(.5, 1, z), inches = .5, fg = 1:10) } symbols2 <- function() { symbols(x, y, thermometers = z3, inches = FALSE) text(x, y, apply(format(round(z3, digits = 2)), 1, paste, collapse = ","), adj = c(-.2,0), cex = .75, col = "purple", xpd = NA) } ## Note that example(trees) shows more sensible plots! N <- nrow(trees) symbols3 <- function() { with(trees, { ## Girth is diameter in inches symbols(Height, Volume, circles = Girth/24, inches = FALSE, main = "Trees' Girth") # xlab and ylab automatically }) } symbols4 <- function() { ## Colours too: palette(rainbow(N, end = 0.9)) with(trees, { symbols(Height, Volume, circles = Girth/16, inches = FALSE, bg = 1:N, fg = "gray30", main = "symbols(*, circles = Girth/16, bg = 1:N)") }) } # Some of my own tests to cover the range of symbols symbols5 <- function() { symbols(mtcars$disp, mtcars$mpg, rect=as.matrix(abs(scale(mtcars[, c(3, 1)])))) } symbols6 <- function() { symbols(mtcars$disp, mtcars$mpg, stars=as.matrix(abs(scale(mtcars[, c(4:7, 10:11)])))) } symbols7 <- function() { x <- y <- w <- h <- lw <- uw <- 1:5 m <- 1:5/6 symbols(x, y, boxplots=cbind(w, h, lw, uw, m)) } plotdiff(expression(symbols1()), "symbols-1") plotdiff(expression(symbols2()), "symbols-2") plotdiff(expression(symbols3()), "symbols-3") plotdiff(expression(symbols4()), "symbols-4", dev="png") plotdiff(expression(symbols3()), "symbols-5") plotdiff(expression(symbols3()), "symbols-6") plotdiff(expression(symbols3()), "symbols-7") plotdiffResult() gridGraphics/inst/test-scripts/test-contour.R0000654000176200001440000000330212424012373021067 0ustar liggesusersrequire(grDevices) # for colours library(gridGraphics) contour1 <- function() { x <- -6:16 par(mfrow = c(2, 2)) contour(outer(x, x), drawlabels = FALSE) z <- outer(x, sqrt(abs(x)), FUN = "/") image(x, x, z) contour(x, x, z, col = "pink", add = TRUE, method = "edge", drawlabels = FALSE) contour(x, x, z, ylim = c(1, 6), method = "simple", xlab = quote(x[1]), ylab = quote(x[2]), drawlabels = FALSE) contour(x, x, z, ylim = c(-6, 6), nlev = 20, lty = 2, main = "20 levels", drawlabels = FALSE) } contour2 <- function() { ## Persian Rug Art: x <- y <- seq(-4*pi, 4*pi, len = 27) r <- sqrt(outer(x^2, y^2, "+")) par(mfrow = c(2, 2), mar = rep(0, 4)) for(f in pi^(0:3)) contour(cos(r^2)*exp(-r/f), drawlabels = FALSE, axes = FALSE, frame = TRUE) } contour3 <- function() { rx <- range(x <- 10*1:nrow(volcano)) ry <- range(y <- 10*1:ncol(volcano)) ry <- ry + c(-1, 1) * (diff(rx) - diff(ry))/2 tcol <- terrain.colors(12) par(pty = "s", bg = "lightcyan") plot(x = 0, y = 0, type = "n", xlim = rx, ylim = ry, xlab = "", ylab = "") u <- par("usr") rect(u[1], u[3], u[2], u[4], col = tcol[8], border = "red") contour(x, y, volcano, col = tcol[2], lty = "solid", add = TRUE, drawlabels = FALSE) title("A Topographic Map of Maunga Whau", font = 4) abline(h = 200*0:4, v = 200*0:4, col = "lightgray", lty = 2, lwd = 0.1) } # Disable antialiasing because of image() within contour1() plotdiff(expression(contour1()), "contour-1", antialias=FALSE) plotdiff(expression(contour2()), "contour-2") plotdiff(expression(contour3()), "contour-3") plotdiffResult() gridGraphics/inst/test-scripts/test-filled.contour.R0000654000176200001440000001347613256565063022357 0ustar liggesuserslibrary(gridGraphics) f1 = function(){ x = 10*1:nrow(volcano) y = 10*1:ncol(volcano) a = expand.grid(1:20, 1:20) b = matrix(a[,1] + a[,2], 20) filled.contour(x = 1:20, y = 1:20, z = b) } f2 = function(){ x = y = seq(-4*pi, 4*pi, len = 30) r = sqrt(outer(x^2, y^2, "+")) filled.contour(cos(r^2)*exp(-r/(2*pi)), axes = FALSE) } f3 = function() { x <- 10*1:nrow(volcano) y <- 10*1:ncol(volcano) filled.contour(x, y, volcano, color = terrain.colors, plot.title = title(main = "The Topography of Maunga Whau", xlab = "Meters North", ylab = "Meters West"), plot.axes = { axis(1, seq(100, 800, by = 100)) axis(2, seq(100, 600, by = 100)) }, key.title = title(main = "Height\n(meters)"), key.axes = axis(4, seq(90, 190, by = 10))) # maybe also asp = 1 } f4 = function() { x = y = seq(-4*pi, 4*pi, len = 60) r = sqrt(outer(x^2, y^2, "+")) filled.contour(cos(r^2)*exp(-r/(2*pi)), axes = FALSE, color = heat.colors) } f5 = function() { x = y = seq(-1, 1, len = 30) r = log(outer(x^2, y^2, "+")) filled.contour(cos(r^2)*exp(-r/(2*pi)), axes = FALSE, color = rainbow) } f6 = function() { d = c(0.4, 0.4, 0.7,-1.0,-0.1, 0.6,-0.4, 0.6,-0.4, 1.3, 0.7,-0.4, 1.1, 1.3, 0.6, 0.1,-0.0,-0.8,-0.8,-1.0 , 0.4,-0.4, 0.4,-1.2,-0.7, 0.4,-0.9, 0.5,-0.9, 1.2, 0.5,-1.0, 1.3, 1.1, 0.5,-0.0,-0.1,-1.2,-1.0,-0.9 , 0.7, 0.4, 0.1,-1.2,-0.2, 0.5,-0.6, 0.6,-0.2, 0.9, 0.6,-0.5, 1.1, 0.8, 0.6, 0.1,-0.4,-0.9,-0.7,-0.8 , -1.0,-1.2,-1.2,-4.4,-1.9,-0.8,-2.2,-1.0,-2.2, 0.0,-0.3,-2.0,-0.2, 0.2,-0.8,-1.6,-1.9,-2.4,-2.3,-2.6 , -0.1,-0.7,-0.2,-1.9,-2.0,-0.5,-1.9,-0.3,-1.7, 0.4,-0.2,-1.9, 0.3, 0.4,-0.3,-0.8,-0.9,-2.1,-1.8,-2.0 , 0.6, 0.4, 0.5,-0.8,-0.5,-0.1,-0.8, 0.6,-0.5, 1.0, 0.5,-0.7, 0.8, 1.0, 0.5, 0.1,-0.3,-0.9,-0.7,-1.1 , -0.4,-0.9,-0.6,-2.2,-1.9,-0.8,-2.7,-0.6,-2.0, 0.3,-0.3,-2.3,-0.0,-0.0,-0.6,-1.1,-1.3,-2.4,-2.0,-2.2 , 0.6, 0.5, 0.6,-1.0,-0.3, 0.6,-0.6, 0.1,-0.8, 1.3, 0.8,-0.8, 1.1, 1.3, 0.4, 0.1, 0.1,-0.8,-1.0,-1.0 , -0.4,-0.9,-0.2,-2.2,-1.7,-0.5,-2.0,-0.8,-2.9, 0.3,-0.4,-2.2,-0.0,-0.0,-0.7,-0.7,-1.3,-2.4,-2.1,-2.6 , 1.3, 1.2, 0.9, 0.0, 0.4, 1.0, 0.3, 1.3, 0.3, 1.1, 1.0, 0.2, 0.7, 1.9, 0.9,-0.2, 0.3, 0.1,-0.4,-0.2 , 0.7, 0.5, 0.6,-0.3,-0.2, 0.5,-0.3, 0.8,-0.4, 1.0, 0.3,-0.3, 1.0, 1.1, 0.6, 0.1, 0.3,-0.7,-0.5,-0.6 , -0.4,-1.0,-0.5,-2.0,-1.9,-0.7,-2.3,-0.8,-2.2, 0.2,-0.3,-2.7, 0.0,-0.0,-0.6,-1.0,-1.1,-2.3,-2.1,-2.4 , 1.1, 1.3, 1.1,-0.2, 0.3, 0.8,-0.0, 1.1,-0.0, 0.7, 1.0, 0.0, 1.6, 0.8, 1.0, 0.8, 0.7,-0.2,-0.2,-0.2 , 1.3, 1.1, 0.8, 0.2, 0.4, 1.0,-0.0, 1.3,-0.0, 1.9, 1.1,-0.0, 0.8, 1.2, 1.1, 0.0, 0.2,-0.1,-0.4, 0.0 , 0.6, 0.5, 0.6,-0.8,-0.3, 0.5,-0.6, 0.4,-0.7, 0.9, 0.6,-0.6, 1.0, 1.1,-0.2, 0.1,-0.0,-0.9,-0.6,-1.2 , 0.1,-0.0, 0.1,-1.6,-0.8, 0.1,-1.1, 0.1,-0.7,-0.2, 0.1,-1.0, 0.8, 0.0, 0.1,-0.6,-0.4,-1.2,-1.3,-1.4 , -0.0,-0.1,-0.4,-1.9,-0.9,-0.3,-1.3, 0.1,-1.3, 0.3, 0.3,-1.1, 0.7, 0.2,-0.0,-0.4,-1.3,-1.4,-1.6,-1.9 , -0.8,-1.2,-0.9,-2.4,-2.1,-0.9,-2.4,-0.8,-2.4, 0.1,-0.7,-2.3,-0.2,-0.1,-0.9,-1.2,-1.4,-3.0,-2.3,-2.5 , -0.8,-1.0,-0.7,-2.3,-1.8,-0.7,-2.0,-1.0,-2.1,-0.4,-0.5,-2.1,-0.2,-0.4,-0.6,-1.3,-1.6,-2.3,-2.3,-2.4 , -1.0,-0.9,-0.8,-2.6,-2.0,-1.1,-2.2,-1.0,-2.6,-0.2,-0.6,-2.4,-0.2, 0.0,-1.2,-1.4,-1.9,-2.5,-2.4,-3.3 ) d = matrix(d, nr = 20) filled.contour(d, axes = FALSE, color = heat.colors) } f7 = function() { sy = function(x) .08 * x * 1./ sqrt(1. + .0001 * x) sz = function(x) .06 * x * 1./ sqrt(1. + .0015 * x) x = seq(100,10000,200) y = seq(-500,500,50) ubar = 5. # mean wind speed height = 30. # stack height (in m!) qout = 1.0e6 # discharge ug/s gpm = function(a,b) { # the input variable "a" is X, the downwind distance # the input variable "b" is y, the crosswind distance # Model Input Parameters ubar = 5. # mean wind speed height = 30. # stack height (in m!) qout = 1.0e6 # discharge ug/s # Here is the actual GPM for ground level concentrations conc = qout / (pi * sy(a) * sz(a) * ubar) * exp(-1*(b*b/(2.*sy(a)*sy(a))+height*height/(2.*sz(a)*sz(a)))) # tell the function to return "conc" as its output return(conc) } conc = outer(x,y,gpm) filled.contour(x,y,conc, nlevels=20, col=rainbow(100), xlab="Downwind distance (m)", ylab="Crosswind distance (m)", main="Contours of Pollutant Concentration (ug/m^3)") } f8 = function() { x <- y <- seq(-8*pi, 8*pi, len = 40) r <- sqrt(outer(x^2, y^2, "+")) filled.contour(cos(r^2)*exp(-r/(2*pi)), axes=FALSE, color.palette=heat.colors, asp=1) } ## length(color) > nlevels f9 = function() { x <- y <- seq(-8*pi, 8*pi, len = 40) r <- sqrt(outer(x^2, y^2, "+")) filled.contour(cos(r^2)*exp(-r/(2*pi)), axes=FALSE, col = heat.colors(100), nlevels = 35, asp=1) } ## length(color) < nlevels f10 = function() { x <- y <- seq(-8*pi, 8*pi, len = 40) r <- sqrt(outer(x^2, y^2, "+")) filled.contour(cos(r^2)*exp(-r/(2*pi)), axes=FALSE, col = heat.colors(6), nlevels = 35, asp=1) } plotdiff(expression(f1()), "filled.contour-01") plotdiff(expression(f2()), "filled.contour-02") plotdiff(expression(f3()), "filled.contour-03") plotdiff(expression(f4()), "filled.contour-04") plotdiff(expression(f5()), "filled.contour-05") plotdiff(expression(f6()), "filled.contour-06") plotdiff(expression(f7()), "filled.contour-07") plotdiff(expression(f8()), "filled.contour-08") plotdiff(expression(f9()), "filled.contour-09") plotdiff(expression(f10()), "filled.contour-10") plotdiffResult() gridGraphics/inst/test-scripts/test-curve.R0000654000176200001440000000276713256770123020550 0ustar liggesusers library(gridGraphics) curve1 <- function() { plot(qnorm) # default range c(0, 1) is appropriate here, # but end values are -/+Inf and so are omitted. } curve2 <- function() { plot(qlogis, main = "The Inverse Logit : qlogis()") abline(h = 0, v = 0:2/2, lty = 3, col = "gray") } curve3 <- function() { curve(sin, -2*pi, 2*pi, xname = "t") } curve4 <- function() { curve(tan, xname = "t", add = NA, main = "curve(tan) --> same x-scale as previous plot") } curve5 <- function() { par(mfrow = c(2, 2)) curve(x^3 - 3*x, -2, 2) curve(x^2 - 2, add = TRUE, col = "violet") ## simple and advanced versions, quite similar: plot(cos, -pi, 3*pi) curve(cos, xlim = c(-pi, 3*pi), n = 1001, col = "blue", add = TRUE) } chippy <- function(x) sin(cos(x)*exp(-x/2)) curve6 <- function() { curve(chippy, -8, 7, n = 2001) } curve7 <- function() { plot (chippy, -8, -5) } curve8 <- function() { par(mfrow=c(2, 2)) for(ll in c("", "x", "y", "xy")) curve(log(1+x), 1, 100, log = ll, sub = paste0("log = '", ll, "'")) } plotdiff(expression(curve1()), "curve-1") ## Antialiasing of the "q" in qlogis() is unreliable plotdiff(expression(curve2()), "curve-2", antialias=FALSE) plotdiff(expression(curve3()), "curve-3") plotdiff(expression(curve4()), "curve-4") plotdiff(expression(curve5()), "curve-5") plotdiff(expression(curve6()), "curve-6") plotdiff(expression(curve7()), "curve-7") plotdiff(expression(curve8()), "curve-8") plotdiffResult() gridGraphics/inst/test-scripts/test-xspline.R0000654000176200001440000000375312425524553021103 0ustar liggesuserslibrary(gridGraphics) xsplineTest <- function(s, open = TRUE, x = c(1,1,3,3)/4, y = c(1,3,3,1)/4, ...) { plot(c(0,1), c(0,1), type = "n", axes = FALSE, xlab = "", ylab = "") points(x, y, pch = 19) xspline(x, y, s, open, ...) text(x+0.05*c(-1,-1,1,1), y+0.05*c(-1,1,1,-1), s) } xspline1 <- function() { par(mfrow = c(3,3), mar = rep(0,4), oma = c(0,0,2,0)) xsplineTest(c(0, -1, -1, 0)) xsplineTest(c(0, -1, 0, 0)) xsplineTest(c(0, -1, 1, 0)) xsplineTest(c(0, 0, -1, 0)) xsplineTest(c(0, 0, 0, 0)) xsplineTest(c(0, 0, 1, 0)) xsplineTest(c(0, 1, -1, 0)) xsplineTest(c(0, 1, 0, 0)) xsplineTest(c(0, 1, 1, 0)) title("Open X-splines", outer = TRUE) } xspline2 <- function() { par(mfrow = c(3,3), mar = rep(0,4), oma = c(0,0,2,0)) xsplineTest(c(0, -1, -1, 0), FALSE, col = "grey80") xsplineTest(c(0, -1, 0, 0), FALSE, col = "grey80") xsplineTest(c(0, -1, 1, 0), FALSE, col = "grey80") xsplineTest(c(0, 0, -1, 0), FALSE, col = "grey80") xsplineTest(c(0, 0, 0, 0), FALSE, col = "grey80") xsplineTest(c(0, 0, 1, 0), FALSE, col = "grey80") xsplineTest(c(0, 1, -1, 0), FALSE, col = "grey80") xsplineTest(c(0, 1, 0, 0), FALSE, col = "grey80") xsplineTest(c(0, 1, 1, 0), FALSE, col = "grey80") title("Closed X-splines", outer = TRUE) } xspline3 <- function() { set.seed(1) x <- sort(stats::rnorm(5)) y <- sort(stats::rnorm(5)) plot(x, y, pch = 19) res <- xspline(x, y, 1, draw = FALSE) lines(res) ## the end points may be very close together, ## so use last few for direction nr <- length(res$x) arrows(res$x[1], res$y[1], res$x[4], res$y[4], code = 1, length = 0.1) arrows(res$x[nr-3], res$y[nr-3], res$x[nr], res$y[nr], code = 2, length = 0.1) } plotdiff(expression(xspline1()), "xspline-1") plotdiff(expression(xspline2()), "xspline-2") plotdiff(expression(xspline3()), "xspline-3") plotdiffResult() gridGraphics/inst/test-scripts/test-persp.R0000654000176200001440000002004613256770123020543 0ustar liggesusers## testing function ## sin surface library(gridGraphics) testPersp = function(theta=120, phi = 20, expand = 0.5, col = 'White', box = TRUE, border = 'orange', ticktype = 'simple', nticks = 5, ...) { x = seq(-10,10,length = 30) y = seq(-10,10,length = 30) f <- function(x, y) { r <- sqrt(x^2+y^2); 10 * sin(r)/r } z <- outer(x, y, f) z[is.na(z)] <- 1 par(mar = c(2,2,2,2)) persp(x, y, z, theta = theta, phi = phi, expand = expand, col = col, box = box, border = border, ticktype = ticktype, nticks = nticks, ...) } ## testing function testPersp1 = function(theta=120, phi = 20, expand = 0.5, col = 'orange ', box = TRUE, border = 'NA', ticktype = 'simple', nticks = 5, ...) { x = seq(-pi,pi,length = 45) y = seq(-pi,pi,length = 45) f <- function(x, y) { 1 + 3 * cos((x^2 + y^2) * 2) * exp(-(x^2 + y^2))} z <- outer(x, y, f) nrz <- nrow(z) ncz <- ncol(z) # color jet.colors <- colorRampPalette( c("white",'yellow', "orange") ) nbcol <- 100 color <- jet.colors(nbcol) zfacet <- z[-1, -1] + z[-1, -ncz] + z[-nrz, -1] + z[-nrz, -ncz] facetcol <- cut(zfacet, nbcol) par(mar = c(2,2,2,2)) expand = 0.5 persp(x, y, z, theta = theta, phi = phi, expand = expand, col = color[facetcol], box = box, border = border, ticktype = ticktype, nticks = nticks, ...) } testPersp2 = function(theta=120, phi = 20, expand = 0.5, col = 'orange ', box = TRUE, border = 'NA', ticktype = 'simple', nticks = 5, ...) { x = seq(-1,1,length = 45) y = seq(-1,1,length = 45) f <- function(x, y) { (0.4^2-(0.6-(x^2+y^2)^0.5)^2)^0.5} z <- outer(x, y, f) nrz <- nrow(z) ncz <- ncol(z) # color jet.colors <- colorRampPalette( c("yellow",'gold', "orange") ) nbcol <- 100 color <- jet.colors(nbcol) zfacet <- z[-1, -1] + z[-1, -ncz] + z[-nrz, -1] + z[-nrz, -ncz] facetcol <- cut(zfacet, nbcol) par(mar = c(2,2,2,2)) expand = 0.5 persp(x, y, z, theta = theta, phi = phi, expand = expand, col = color[facetcol], box = box, border = border, ticktype = ticktype, nticks = nticks, ...) } testPersp3 = function(){ z <- 2 * volcano x <- 10 * (1:nrow(z)) y <- 10 * (1:ncol(z)) z0 <- min(z) - 20 z <- rbind(z0, cbind(z0, z, z0), z0) x <- c(min(x) - 1e-10, x, max(x) + 1e-10) y <- c(min(y) - 1e-10, y, max(y) + 1e-10) fill <- matrix("green3", nrow = nrow(z)-1, ncol = ncol(z)-1) fill[ , i2 <- c(1,ncol(fill))] <- "gray" fill[i1 <- c(1,nrow(fill)) , ] <- "gray" fcol <- fill zi <- volcano[ -1,-1] + volcano[ -1,-61] + volcano[-87,-1] + volcano[-87,-61] ## / 4 fcol[-i1,-i2] <- terrain.colors(20)[cut(zi, stats::quantile(zi, seq(0,1, length.out = 21)), include.lowest = TRUE)] persp(x, y, 2*z, theta = 110, phi = 40, col = fcol, scale = FALSE, ltheta = -120, shade = 0.4, border = NA, box = FALSE) } testPersp4 = function(theta=120, phi = 20, expand = 0.5, col = 'orange ', box = TRUE, border = 'NA', ticktype = 'simple', nticks = 5, ...) { x = seq(-15,15,length = 45) y = seq(-15,15,length = 45) f <- function(x, y) { (25 - (10 - sqrt(x^2 + y^2))^2)} z <- outer(x, y, f) nrz <- nrow(z) ncz <- ncol(z) # color jet.colors <- colorRampPalette( c("yellow",'gold', "orange") ) nbcol <- 100 color <- jet.colors(nbcol) zfacet <- z[-1, -1] + z[-1, -ncz] + z[-nrz, -1] + z[-nrz, -ncz] facetcol <- cut(zfacet, nbcol) par(mar = c(2,2,2,2)) persp(x, y, z, theta = theta, phi = phi, expand = expand, #col = color[facetcol], box = box, border = border, col = col, ticktype = ticktype, nticks = nticks, ...) } ## bugs ## calling shade when some z are NA # testPersp2(border = 'NA', shade = 0.2) # grid.echo() ## alpha of rgb less than 0 # testPersp(col = rgb(0.5, 0.2, 0.3, 0.8), shade = 0.5, border = NA) # grid.echo() #plotdiff(expression(testPersp3()), 'volcano', antialias = FALSE) ## test on theta plotdiff(expression(testPersp(30)), 'persp-01') ## test on phi plotdiff(expression(testPersp(phi = 5)), 'persp-02') ## test on expand plotdiff(expression(testPersp(expand = 0.01)), 'persp-03') ## test on lim plotdiff(expression(testPersp(xlim = c(-5,5))), 'persp-04') ## test on label plotdiff(expression( testPersp(xlab = 'just a label of x', ylab = 'just a label of y', zlab = 'just a label of z')), 'persp-05') ## test on r plotdiff(expression(testPersp(r = 10)), 'persp-06') ##test on d plotdiff(expression(testPersp(d = 0.2)), 'persp-07') ## test on scale plotdiff(expression(testPersp(scale = FALSE)), 'persp-08') ## test on multi-col plotdiff(expression(testPersp(col = 1:5)), 'persp-10') ## test on border plotdiff(expression(testPersp(border = 'brown')), 'persp-11') # only one color for border plotdiff(expression(testPersp(border = 5:6)), 'persp-12') ## test on axes plotdiff(expression(testPersp(axes = TRUE)), 'persp-13') plotdiff(expression(testPersp(axes = FALSE)), 'persp-14') ## if box = False then not drawing any axes even axes = TRUE plotdiff(expression(testPersp(box = FALSE, axes = TRUE)), 'persp-15') ## test on lty plotdiff(expression(testPersp(lty = 'dotted')), 'persp-18') ## test on lwd plotdiff(expression(testPersp(lwd = 3)), 'persp-21') plotdiff(expression(testPersp(col = 'orange', border = 'NA', shade =0.5, box = TRUE, scale = TRUE)), 'persp-22') plotdiff(expression(testPersp(col = 1:10, border = 'NA', shade =0.5, box = TRUE, scale = TRUE)), 'persp-23') plotdiff(expression(testPersp1(box = FALSE)), 'persp-sin2') plotdiff(expression(testPersp2(box = FALSE)), 'persp-Torus') ## new test unlikelyTest = function(i) { x = 1:3 y = 1:3 z = outer(x, y, "+") z[1,1] = NA cols = list( col1 = c('NA', 'red', 'blue', 'brown'), col2 = c('red', 'NA', 'blue', 'brown') ) persp(z, col = cols[[i]], shade = 0.5) } ## missing value on Z with: ##first color is missing when shading plotdiff(expression(unlikelyTest(1)), 'persp-unlike-1') ##include missing color when shadding plotdiff(expression(unlikelyTest(2)), 'persp-unlike-2') otherTest1 = function() { par(bg = "white") x <- seq(-1.95, 1.95, length = 30) y <- seq(-1.95, 1.95, length = 35) z <- outer(x, y, function(a, b) a*b^2) nrz <- nrow(z) ncz <- ncol(z) # Create a function interpolating colors in the range of specified colors jet.colors <- colorRampPalette( c("blue", "green") ) # Generate the desired number of colors from this palette nbcol <- 100 color <- jet.colors(nbcol) # Compute the z-value at the facet centres zfacet <- z[-1, -1] + z[-1, -ncz] + z[-nrz, -1] + z[-nrz, -ncz] # Recode facet z-values into color indices facetcol <- cut(zfacet, nbcol) persp(x, y, z, col = color[facetcol], phi = 30, theta = -30) } plotdiff(expression(otherTest1()), 'persp-other-1') otherTest2 = function() { z <- 2 * volcano x <- 10 * (1:nrow(z)) y <- 10 * (1:ncol(z)) z0 = min(z) - 20 z = rbind(z0, cbind(z0, z, z0), z0) x = c(min(x) - 1e-10, x, max(x) + 1e-10) y = c(min(y) - 1e-10, y, max(y) + 1e-10) fill = matrix("green3", nrow = nrow(z)-1, ncol = ncol(z)-1) fill[ , i2 <- c(1,ncol(fill))] <- "gray" fill[i1 <- c(1,nrow(fill)) , ] <- "gray" zi = volcano[ -1,-1] + volcano[ -1,-61] + volcano[-87,-1] + volcano[-87,-61] fcol <- fill fcol[-i1,-i2] = terrain.colors(20)[cut(zi, stats::quantile(zi, seq(0,1, length.out = 21)), include.lowest = TRUE)] persp(x, y, 2*z, theta = 110, phi = 40, col = fcol, scale = FALSE, ltheta = -120, shade = 0.4, border = NA, box = FALSE) } plotdiff(expression(otherTest2()), 'persp-other-2', antialias=FALSE) plotdiffResult() gridGraphics/inst/test-scripts/test-stripchart.R0000654000176200001440000000174012430022710021556 0ustar liggesusers library(gridGraphics) set.seed(1) x <- stats::rnorm(50) xr <- round(x, 1) stripchart1 <- function() { stripchart(x) ; m <- mean(par("usr")[1:2]) text(m, 1.04, "stripchart(x, \"overplot\")") stripchart(xr, method = "stack", add = TRUE, at = 1.2) text(m, 1.35, "stripchart(round(x,1), \"stack\")") stripchart(xr, method = "jitter", add = TRUE, at = 0.7) text(m, 0.85, "stripchart(round(x,1), \"jitter\")") } stripchart2 <- function() { stripchart(decrease ~ treatment, main = "stripchart(OrchardSprays)", vertical = TRUE, log = "y", data = OrchardSprays) } stripchart3 <- function() { stripchart(decrease ~ treatment, at = c(1:8)^2, main = "stripchart(OrchardSprays)", vertical = TRUE, log = "y", data = OrchardSprays) } plotdiff(expression(stripchart1()), "stripchart-1") plotdiff(expression(stripchart2()), "stripchart-2") plotdiff(expression(stripchart3()), "stripchart-3") plotdiffResult() gridGraphics/inst/test-scripts/test-sunflowerplot.R0000654000176200001440000000314412430022141022314 0ustar liggesusers library(gridGraphics) require(stats) require(grDevices) sunflowerplot1 <- function() { ## 'number' is computed automatically: sunflowerplot(iris[, 3:4]) } sunflowerplot2 <- function() { ## Imitating Chambers et al, p.109, closely: sunflowerplot(iris[, 3:4], cex = .2, cex.fact = 1, size = .035, seg.lwd = .8) } sunflowerplot3 <- function() { ## or sunflowerplot(Petal.Width ~ Petal.Length, data = iris, cex = .2, cex.fact = 1, size = .035, seg.lwd = .8) } sunflowerplot4 <- function() { set.seed(1) sunflowerplot(x = sort(2*round(rnorm(100))), y = round(rnorm(100), 0), main = "Sunflower Plot of Rounded N(0,1)") } ## Similarly using a "xyTable" argument: xyT <- xyTable(x = sort(2*round(rnorm(100))), y = round(rnorm(100), 0), digits = 3) utils::str(xyT, vec.len = 20) sunflowerplot5 <- function() { sunflowerplot(xyT, main = "2nd Sunflower Plot of Rounded N(0,1)") } sunflowerplot6 <- function() { ## A 'marked point process' {explicit 'number' argument}: set.seed(1) sunflowerplot(rnorm(100), rnorm(100), number = rpois(n = 100, lambda = 2), main = "Sunflower plot (marked point process)", rotate = TRUE, col = "blue4") } plotdiff(expression(sunflowerplot1()), "sunflowerplot-1") plotdiff(expression(sunflowerplot2()), "sunflowerplot-2") plotdiff(expression(sunflowerplot3()), "sunflowerplot-3") plotdiff(expression(sunflowerplot4()), "sunflowerplot-4") plotdiff(expression(sunflowerplot5()), "sunflowerplot-5") plotdiff(expression(sunflowerplot6()), "sunflowerplot-6") plotdiffResult() gridGraphics/inst/test-scripts/test-rect.R0000654000176200001440000000321612432212002020325 0ustar liggesusers require(grDevices) library(gridGraphics) rect1 <- function() { ## set up the plot region: par(bg = "thistle") plot(c(100, 250), c(300, 450), type = "n", xlab = "", ylab = "", main = "2 x 11 rectangles; 'rect(100+i,300+i, 150+i,380+i)'") i <- 4*(0:10) ## draw rectangles with bottom left (100, 300)+i ## and top right (150, 380)+i rect(100+i, 300+i, 150+i, 380+i, col = rainbow(11, start = 0.7, end = 0.1)) rect(240-i, 320+i, 250-i, 410+i, col = heat.colors(11), lwd = i/5) ## Background alternating ( transparent / "bg" ) : j <- 10*(0:5) rect(125+j, 360+j, 141+j, 405+j/2, col = c(NA, 0), border = "gold", lwd = 2) rect(125+j, 296+j/2, 141+j, 331+j/5, col = c(NA, "midnightblue")) mtext("+ 2 x 6 rect(*, col = c(NA,0)) and col = c(NA,\"m..blue\"))") } rect2 <- function() { ## an example showing colouring and shading plot(c(100, 200), c(300, 450), type= "n", xlab = "", ylab = "") rect(100, 300, 125, 350) # transparent rect(100, 400, 125, 450, col = "green", border = "blue") # coloured rect(115, 375, 150, 425, col = par("bg"), border = "transparent") rect(150, 300, 175, 350, density = 10, border = "red") rect(150, 400, 175, 450, density = 30, col = "blue", angle = -30, border = "transparent") legend(180, 450, legend = 1:4, fill = c(NA, "green", par("fg"), "blue"), density = c(NA, NA, 10, 30), angle = c(NA, NA, 30, -30)) } rect3 <- function() { plot(1:10, log="x") rect(2, 2, 6, 6) } plotdiff(expression(rect1()), "rect-1") plotdiff(expression(rect2()), "rect-2") plotdiff(expression(rect3()), "rect-3") plotdiffResult() gridGraphics/inst/test-scripts/test-arrows.R0000654000176200001440000000103312425524331020715 0ustar liggesusersrequire(grDevices); require(graphics) library(gridGraphics) exampleArrows <- function() { set.seed(1) x <- stats::runif(12); y <- stats::rnorm(12) i <- order(x, y); x <- x[i]; y <- y[i] plot(x,y, main = "arrows(.) and segments(.)") ## draw arrows from point to point : s <- seq(length(x)-1) # one shorter than data arrows(x[s], y[s], x[s+1], y[s+1], col = 1:3) s <- s[-length(s)] segments(x[s], y[s], x[s+2], y[s+2], col = "pink") } plotdiff(expression(exampleArrows()), "arrows") plotdiffResult() gridGraphics/inst/test-scripts/test-pairs.R0000654000176200001440000000465613256770123020541 0ustar liggesusers library(gridGraphics) pairs1 <- function() { pairs(iris[1:4], main = "Anderson's Iris Data -- 3 species", pch = 21, bg = c("red", "green3", "blue")[unclass(iris$Species)]) } pairs2 <- function() { ## formula method pairs(~ Fertility + Education + Catholic, data = swiss, subset = Education < 20, main = "Swiss data, Education < 20") } pairs3 <- function() { pairs(USJudgeRatings) } pairs4 <- function() { ## show only lower triangle (and suppress labeling for whatever reason): pairs(USJudgeRatings, text.panel = NULL, upper.panel = NULL) } pairs5 <- function() { ## put histograms on the diagonal panel.hist <- function(x, ...) { usr <- par("usr"); on.exit(par(usr)) par(usr = c(usr[1:2], 0, 1.5) ) h <- hist(x, plot = FALSE) breaks <- h$breaks; nB <- length(breaks) y <- h$counts; y <- y/max(y) rect(breaks[-nB], 0, breaks[-1], y, col = "cyan", ...) } pairs(USJudgeRatings[1:5], panel = panel.smooth, cex = 1.5, pch = 24, bg = "light blue", diag.panel = panel.hist, cex.labels = 2, font.labels = 2) } pairs6 <- function() { ## put (absolute) correlations on the upper panels, ## with size proportional to the correlations. panel.cor <- function(x, y, digits = 2, prefix = "", cex.cor, ...) { usr <- par("usr"); on.exit(par(usr)) par(usr = c(0, 1, 0, 1)) r <- abs(cor(x, y)) txt <- format(c(r, 0.123456789), digits = digits)[1] txt <- paste0(prefix, txt) if(missing(cex.cor)) cex.cor <- 0.8/strwidth(txt) text(0.5, 0.5, txt, cex = cex.cor * r) } pairs(USJudgeRatings, lower.panel = panel.smooth, upper.panel = panel.cor) } pairs7 <- function() { pairs(iris[-5], log = "xy") # plot all variables on log scale } pairs8 <- function() { pairs(iris, log = 1:4, # log the first four main = "Lengths and Widths in [log]", line.main=1.5, oma=c(2,2,3,2)) } plotdiff(expression(pairs1()), "pairs-1", width=10, height=10) plotdiff(expression(pairs2()), "pairs-2") plotdiff(expression(pairs3()), "pairs-3", width=15, height=15) plotdiff(expression(pairs4()), "pairs-4", width=15, height=15) plotdiff(expression(pairs5()), "pairs-5") plotdiff(expression(pairs6()), "pairs-6", width=15, height=15, antialias=FALSE) plotdiff(expression(pairs7()), "pairs-7", width=10, height=10) plotdiff(expression(pairs8()), "pairs-8", width=12, height=12) plotdiffResult() gridGraphics/inst/test-scripts/test-raster.R0000654000176200001440000000113012424044220020667 0ustar liggesusers require(grDevices) library(gridGraphics) raster1 <- function() { ## set up the plot region: par(bg = "thistle") plot(c(100, 250), c(300, 450), type = "n", xlab = "", ylab = "") image <- as.raster(matrix(0:1, ncol = 5, nrow = 3)) rasterImage(image, 100, 300, 150, 350, interpolate = FALSE) rasterImage(image, 100, 400, 150, 450) rasterImage(image, 200, 300, 200 + xinch(.5), 300 + yinch(.3), interpolate = FALSE) rasterImage(image, 200, 400, 250, 450, angle = 15, interpolate = FALSE) } plotdiff(expression(raster1()), "raster-1") plotdiffResult() gridGraphics/inst/test-scripts/test-panel.smooth.R0000654000176200001440000000064412427762141022023 0ustar liggesusers library(gridGraphics) panel.smooth1 <- function() { pairs(swiss, panel = panel.smooth, pch = ".") # emphasize the smooths } panel.smooth2 <- function() { pairs(swiss, panel = panel.smooth, lwd = 2, cex = 1.5, col = "blue") # hmm... } plotdiff(expression(panel.smooth1()), "panel.smooth-1", width=12, height=12) plotdiff(expression(panel.smooth2()), "panel.smooth-2", width=12, height=12) plotdiffResult() gridGraphics/inst/NEWS.Rd0000654000176200001440000001362013764276226014722 0ustar liggesusers\name{NEWS} \title{NEWS file for the gridGraphics package} \encoding{UTF-8} \section{Changes in version 0.5-1}{ \itemize{ \item Ensure use of Suggested packages is conditional (so \code{plotdiff()} only runs if the Suggested packages are available). } } \section{Changes in version 0.5-0}{ \itemize{ \item \code{grid.echo()} now supports \code{stats::plot.hclust()} \item Fix for \code{grid.echo.function()} when start with no devices open (it was opening an extra device on exit). \item Ensure old \code{pdf(useDingbats=TRUE)} behaviour for testing. } } \section{Changes in version 0.4-2}{ \itemize{ \item Protection against \code{NA} labels in text (so that they do not get echoed as "NA"). NOTE that his will NOT be fixed in \pkg{grid} because some existing packages relies on that \pkg{grid} behaviour. \item Protection against \code{NULL} labels in text (so that \pkg{grid} does not complain about them). Reported by Patrick Schratz. } } \section{Changes in version 0.4-1}{ \itemize{ \item Allow install on R below 3.6.0 (even if the echo results are not as good) } } \section{Changes in version 0.4-0}{ \itemize{ \item New function \code{echoGrob()}. \item Echoing \code{persp()} now respects \code{cex.axis} setting (for size of tick labels). \item Fixup for axis() when scale is reversed. \item Fixes for \code{C_axis()} (and \code{GMtext()}) to use \code{graphics::grconvertX()} (and \code{graphics::grconvertY}) to calculate length of tick marks and placement of tick labels. This is to respond correctly to \code{par()} changes AFTER \code{plot()}, but before \code{axis()} (either via explicit \code{par()} calls, or implicitly when functions like \code{dotchart()} reset \code{par()} internally). These changes make use of new \code{deviceLoc()} function and updated \code{grconvertX()} and \code{grconvertY()} functions in R 3.6.0. } } \section{Changes in version 0.3-1}{ \itemize{ \item Improved \code{currentPar()} function so that it behaves more like the graphics engine's \code{ProcessInlinePars()}. The main point is that setting a \code{par()} parameter in a high-level function is allowed to specify multiple values for the setting (whereas setting via \code{par()} itself only allows a single value per parameter setting). } } \section{Changes in version 0.3-0}{ \itemize{ \item Added \pkg{magick} and \pkg{pdftools} as (Suggests) dependencies, to provide better and more stable support for \code{plotdiff()}. \item Fixed clipping (of main contour region) bug for echoing \code{filled.contour()}. } } \section{Changes in version 0.2-2}{ \itemize{ \item Added \code{device} argument to \code{grid.echo()} so that user can specify a \dQuote{working device}. This is an in-memory PDF device by default, but that can have problems with fonts. Suggested by Claus Wilke. \item Added capture of font family when echoing persp() plots. Reported by Claus Wilke. \item Added names for grobs from echoing \code{persp()} and \code{filled.contour()}. \item Fix for echoing correct \code{font} settings in \code{axis()} and \code{persp()}. Reported by Claus Wilke. \item Attempt to survive errors during echoing (like "figure margins too large") more elegantly } } \section{Changes in version 0.2-1}{ \itemize{ \item Fixed bug when echoing scatter plot with ZERO points in it. Reported by github user zxzb \url{https://github.com/pmur002/gridgraphics/issues/9} \item Made plotdiff() more robust to unexpected output from ImageMagick's compare. Reported by Brian Ripley. \item Added Zhijian (Jason) Wen as package author (it was he who contributed the \code{persp()} and \code{filled.contour()} support). } } \section{Changes in version 0.2}{ \itemize{ \item \code{grid.echo()} now supports \code{persp()} and \code{filled.contour()} } } \section{Changes in version 0.1-5}{ \itemize{ \item Changed stop() to warning() when call grid.echo() with empty \dQuote{recordedplot} (suggested by Jonathon Godfrey). \item Fixed examples for \code{grid.echo()} (patch by Josh O'Brien). \item More robust Windows support for \code{plotdiff()} and \code{plotcompare()} (patch by Josh O'Brien). \item Added defence against \code{axis(line=)} specification of length greater than 1 (reported by Jimmy Oh). \item Added explicit handling of \code{C_layout()}, though handling does nothing (reported by Jimmy Oh). \item Fixed drawing of ticks for \code{axis(at=)} when \code{at} exceeds range of axis scale. The ticks outside the axis scale range are now correctly clipped (reported by Jimmy Oh). \item Future-proofed test script for \code{hist.POSIXt()} (so that the addition of new leap seconds does not generate errors about \code{breaks} not spanning the range of the data). } } \section{Changes in version 0.1-4}{ \itemize{ \item Added defence against \code{NA} text values in call to \code{title()}. } } \section{Changes in version 0.1-3}{ \itemize{ \item Added defence against code sending in NULL values in \code{par()} settings (e.g., \pkg{sp} does this with the \code{xpd} setting). These \code{par()} settings are ignored (to match internal \pkg{graphics} C code behaviour). } } \section{Changes in version 0.1-2}{ \itemize{ \item Fixed documentation of first argument in \code{grid.echo()} (it can be a function, not an expression). \item Added better checking in plotdiff() for existence of \code{convert} and \code{compare} tools and for recent-enough version of R (to be able to perform the strict check for differences). } } \section{Changes in version 0.1-1}{ \itemize{ \item First public release of \pkg{gridGraphics} package. } }