tests/reg-plot.R - R - Git at Google

 #### Regression tests for GRAPHICS & PLOTS

 pdf("reg-plot.pdf", paper="a4r", encoding ="ISOLatin1.enc", compress = FALSE)

 ## since we supply the font metrics, the results depend only on
 ## the encoding used: Windows is different from Unix by default.

 options(warn = 1) # print as they occur

 plot(0) # this should remain constant
 str(par(c("usr","xaxp","yaxp")))
 stopifnot(all.equal(
     par(c("usr","xaxp","yaxp"))
    ,
     list(usr = c(0.568, 1.432, -1.08, 1.08),
          xaxp = c(0.6, 1.4, 4), yaxp = c(-1, 1, 4))))


 ### Test for centring of chars.  All the chars which are plotted should
 ### be centred, and there should be no warnings about
 ### font metrics unknown for character `?'

 par(pty="s")
 plot(c(-1,16), c(-1,16), type="n", xlab="", ylab="", xaxs="i", yaxs="i")
 title("Centred chars in default char set (ISO Latin1)")
 grid(17, 17, lty=1)
 known <- c(32:126, 160:255)

 for(i in known) {
     x <- i %% 16
     y <- i %/% 16
     points(x, y, pch=-i)
 }

 par(pty="m")

 ## PR 816 (label sizes in dotchart)

 ### Prior to 1.2.2, the label sizes were unaffected by cex.

 dotchart(VADeaths, main = "Death Rates in Virginia - 1940", cex = 0.5)
 dotchart(VADeaths, main = "Death Rates in Virginia - 1940", cex = 1.5)

 ## killed by 0 prior to 1.4.0 and in 1.4.1:
 t1 <- ts(0:100)
 ## only warnings about values <= 0
 plot(t1, log = "y")
 plot(cbind(t1, 10*t1, t1 - 4), log="y", plot.type = "single")
 stopifnot(par("usr")[4] > 3) # log10: ylim[2] = 1000


 ## This one needs to be looked at.
 ## lty = "blank" killed the fill colour too.
 plot(1:10, type="n")
 polygon(c(1, 3, 3, 1), c(1, 1, 3, 3), col="yellow", border="red", lty="blank")
 rect(6, 6, 10, 10,  col="blue", border="red", lty="blank")
 ## in 1.5.0 all omit the fill colours.
 with(trees, symbols(Height, Volume, circles=Girth/24, inches=FALSE,
                     lty="blank", bg="blue"))
 ## in 1.5.0 ignored the lty.

 ## axis() and par(mgp < 0) {keep this example S+ compatible!}:
 lt <- if(is.R()) "31" else 2
 x <- seq(-2,3, len=1001)
 op <- par(tck= +0.02, mgp = -c(3,2,0))
 plot(x, x^2 - 1.2, xaxt = "n", xlab="", type ='l', col = 2,
      main = "mgp < 0: all ticks and labels inside `frame'")
 x <- -2:3
 lines(x, x^2 - 1.2, type ="h", col = 3, lwd=3)
 axis(1, pos = 0, at=-1:1, lty = lt, col=4)## col & lty work only from R 1.6
 par(op)
 axis(1, pos = 0, at=c(-2,2,3), lty = lt, col=4)
 mtext(side=1,"note the x-ticks on the other side of the bars")

 ## plot.table(): explicit xlab and ylab for non-1D
 plot(UCBAdmissions)# default x- and y-lab
 plot(UCBAdmissions, xlab = "x label", ylab = "YY")# wrong in 1.5.1
 ##   axis suppression
 plot(tt <- table(c(rep(0,7), rep(1,4), rep(5, 3))), axes = FALSE)
 plot(tt, xaxt = "n")
 ## wrong till (incl.) 1.6.x

 ## legend with call
 lo <- legend(2,2, substitute(hat(theta) == that, list(that= pi)))
 stopifnot(length(lo$text$x) == 1)
 ## length() was 3 till 1.7.x

 plot(ecdf(c(1:4,8,12)), ylab = "ECDF", main=NULL)
 ## ylab didn't work till 1.8.0

 plot(1:10, pch = NA) # gave error till 1.9.0
 points(1:3, pch=c("o",NA,"x"))# used "N"
 try(points(4, pch=c(NA,FALSE)))# still give an error

 ## 'lwd' should transfer to plot symbols
 legend(1,10, c("A","bcd"), lwd = 2:3, pch= 21:22, pt.bg="skyblue",
        col = 2:3, bg = "thistle")
 ## (gave an error for 2 days in "2.0.0 unstable")

 x <- 2^seq(1,1001, length=20)
 plot(x, x^0.9, type="l", log="xy")
 ## gave error 'Infinite axis extents [GEPretty(1.87013e-12,inf,5)]' for R 2.0.1

 plot(as.Date("2001/1/1") + 12*(1:9), 1:9)
 ## used bad 'xlab/ylab' in some versions of R 2.2.0(unstable)

 ## dotchart() restoring par()
 Opar <- par(no.readonly=TRUE) ; dotchart(1:4, cex= 0.7)
 Npar <- par(no.readonly=TRUE)
 ii <- c(37, 50:51, 58:59, 63)
 stopifnot(identical(names(Opar)[ii],
                     c("mai","pin","plt","usr","xaxp","yaxp")),
           identical(Opar[-ii], Npar[-ii]))
 ## did not correctly restore par("mar") up to (incl) R 2.4.0

 ## plot.function()     [n=11, ... : since we store and diff PS file !]
 plot(cos,       xlim=c(-5,5), n=11, axes=FALSE); abline(v=0)
 ## did *not* plot for negative x up to R 2.5.1
 plot(sin, -2,3, xlim=c(-5,5), n=11, axes=FALSE, xlab="")# plot from -2
 axis(1, at=c(-2,3), tcl=-1); axis(1, at=c(-5,5))
 ## (from,to) & xlim  should work simultaneously

 plot(cos, -7,7, n=11, axes=FALSE)
 ## gave wrong ylab in R 2.6.0
 plot(cos, -7,7, ylab = "Cosine  cos(x)", n=11, axes=FALSE)
 ## partial matching of 'ylab'; mapping  [0,1] (not [-7.7]):
 ## margins chosen to avoid rouding error showing to 2dp.
 op <- par(mar=c(5,4.123,4,2)+0.1)
 plot(gamma, yla = expression(Gamma(x)), n=11, yaxt="n")
 par(op)

 ## plot.ts(x, y) could get the labels wrong in R <= 2.6.0:
 x <- ts(1:5);x1 <- lag(x, 2); plot(x1, x, axes=FALSE)

 # adding a curve in log scale :
 curve(5*exp(-x), 0.1, 100, n = 3, log="x", ylab="", axes=FALSE)
 curve(5*exp(-x), add=TRUE, n = 3, col=2,lwd=3)
 ## should fully overplot; wrong default xlim in 2.6.1
 ## (and *slightly* wrong up to 2.6.0)

 ## Axis() calls via plot()  {[xy]axt to keep *.ps small}
 x <- as.Date("2008-04-22 09:45") + (i <- c(0,4))
 plot(x,    xaxt="n")# not ok in 2.6.2, nor 2.7.0
 plot(x, i, yaxt="n")# ok in 2.6.2  and 2.7.0
 plot(i, x, xaxt="n")# ok in 2.6.2 and not in 2.7.0

 ## table methods should be bypassed:
 dotchart(table(infert$education))
 ## failed in 2.12.[12]

 ## cex as "..."  in "high level" function
 hc <- hclust(dst <- dist(c(1:2, 5)), method="ave")
 plot(hc, cex = 2, axes=FALSE, ann=FALSE)
 ## cex was not used in 3.0.[01]

 ## axis.Date() and axis.POSIXct() with reversed 'xlim'
 toD <- as.Date("2016-08-19"); dates <- c(toD - 10, toD)
 plot(dates, 1:2, xlim = rev(dates),
      ann=FALSE, yaxt="n", frame.plot=FALSE)
 ## failed to label the dates in R <= 3.3.1


 ## axis() -- labels only written when there's room
 plot2 <- function(at, wait=FALSE) {
     plot1 <- function(x,y) plot(x,y, type="n", xlab="", ylab="", tck=0, frame.plot=FALSE)
     plot1( at, at); axis(3, at= at, tck=0)
     plot1(-at,-at); axis(3, at=-at, tck=0)
     if(wait) { mtext("Click here to advance!", line=-2, cex=1.5, col=2); locator(1) }
 }
 at <- c(7:15, 2*(8:15), 5*(7:15), 10*(8:15))
 op <- par(mfrow=2:1, mgp = c(1.5, 0.6, 0), mar = .1+c(2,2,2,1),
           lab = c(20,20,7), las = 1) # las=1: all horizontal => y-axis perpendicular
 interAct <- dev.interactive()

 if(interAct) { xMar <- c(1,3)/2  ; nP <- 10
 } else {       xMar <- c(1,3)*3/2; nP <-  3 }
 ## Now increasing margins ==> decreasing plot area ==> shrinking plot
 ## (*is* device dependent [here have "a4r"-pdf]) :
 for(n in 1:nP) {
     par(mar = par("mar") + xMar)
     plot2(at, n < nP && interAct)
 }
 par(op)


 ##----- pairs() using verInd & horInd ----------
 mpairs <- function(..., p=3, npp=2, main) { # p=4, npp=7 was Chris Andrews' example
     x <- matrix((1:(p*npp))/npp, ncol=p, dimnames=list(NULL, paste0("x", 1:p)))
     ## -> x \in [1/npp,.., p]  <==> ceiling(x) \in {1,2,...,p}
     ## the panel function
     mP <- function(x,y, ...) { ## really made for the 'x = ...' above
         j <- ceiling(mean(y)) # in 1:p
         points(x,y, col=ceiling(mean(x)), pch= 3*j, cex=((p-1.5)*j+1)/p, ...)
         g <- 1:(p-1); abline(h=g, v=g, lty=3, col="gray33")
     }
     if(missing(main))
         main <- if(...length()) sub("mpairs", '', deparse(sys.call()))
     lim <- range(x)
     k <- max(2, npp-2) ## bug in R(?): par(lab = c(1,1,7)) giving nonsense!
     op <- par(lab = c(k,k,7), oma=c(1,0,0,0)); on.exit(par(op))
     pairs(x, panel=mP, xlim=lim, ylim=lim, main=main, cex.main=1, ...)
 }

 mpairs() # 4x4 matrix of scatterplots
 if(interAct) dev.set(if(length(dev.list()) < 2) dev.new() else dev.prev())
 mpairs(horInd=1:2,verInd=  1:3 ) # 3x2 matrix: upper left [WRONG in R <= 3.5.0]
 mpairs(horInd=3:2)               # 2x4: middle rows swapped
 mpairs(           verInd=c(3,1)) # 4x2: cols 3,1
 ##
 ## now all with  'row1attop=FALSE'=======
 if(interAct) dev.set(dev.prev())
 mpairs(row1attop=FALSE) # 4x4 matrix of scatterplots -- perfect in R <= 3.5.0
 if(interAct) dev.set(dev.next())
 ## a version of those above, with 'row1attop = FALSE'
 mpairs(horInd=2:1,verInd=3:1   , row1attop=FALSE) # 3x2: *swapped* upper left
 mpairs(horInd=c(3,1)           , row1attop=FALSE) # 2x3: swapped outer rows
 mpairs(           verInd=c(3,2), row1attop=FALSE) # 3x2: cols 3,2


 ## axis() when in subnormal range (x is subnormal if 0 < x < .Machine$double.xmin):
 (.min.exp.subnormal <- with(.Machine, double.min.exp + double.ulp.digits)) # -1074
 (ry <- range(y74 <- 2^(.min.exp.subnormal + 0:50))) # all subnormal
 plotNchk <- function(y) {
     plot(y, log = "y", xlab="", ylab="", xaxt="n") # (as small pdf as possible)
     ry <- range(y)
     xp <- par("yaxp")
     ## and indeed yaxp do cover the range(y) :
     stopifnot(xp[1] <= ry[1], ry[2] <= xp[2], xp[3] == 1)
     invisible(xp)
 }
 if(interactive()) # not regularly, where pdf is stored
 plotNchk(y74) # gives 3 warnings; 1. from pretty(): "very small range"
 plotNchk(y74[1:8]) # 3 warnings *and* no error anymore
 plotNchk(y74[1:2]) #    (ditto)


 ## dotchart(*, pch=., groups=*) -- PR#16953
 x <- setNames(0:5, c('a','aa', 'aaa', 'b', 'bb', 'bbb'))
 y <- nchar(names(x)) # (minimal plot:)
 dotchart(x, color=y, pch=y, groups=y, xaxt="n", frame.plot=FALSE)
 ## now pch and colors match groups
	#### Regression tests for GRAPHICS & PLOTS

	pdf("reg-plot.pdf", paper="a4r", encoding ="ISOLatin1.enc", compress = FALSE)

	## since we supply the font metrics, the results depend only on
	## the encoding used: Windows is different from Unix by default.

	options(warn = 1) # print as they occur

	plot(0) # this should remain constant
	str(par(c("usr","xaxp","yaxp")))
	stopifnot(all.equal(
	par(c("usr","xaxp","yaxp"))
	,
	list(usr = c(0.568, 1.432, -1.08, 1.08),
	xaxp = c(0.6, 1.4, 4), yaxp = c(-1, 1, 4))))


	### Test for centring of chars. All the chars which are plotted should
	### be centred, and there should be no warnings about
	### font metrics unknown for character `?'

	par(pty="s")
	plot(c(-1,16), c(-1,16), type="n", xlab="", ylab="", xaxs="i", yaxs="i")
	title("Centred chars in default char set (ISO Latin1)")
	grid(17, 17, lty=1)
	known <- c(32:126, 160:255)

	for(i in known) {
	x <- i %% 16
	y <- i %/% 16
	points(x, y, pch=-i)
	}

	par(pty="m")

	## PR 816 (label sizes in dotchart)

	### Prior to 1.2.2, the label sizes were unaffected by cex.

	dotchart(VADeaths, main = "Death Rates in Virginia - 1940", cex = 0.5)
	dotchart(VADeaths, main = "Death Rates in Virginia - 1940", cex = 1.5)

	## killed by 0 prior to 1.4.0 and in 1.4.1:
	t1 <- ts(0:100)
	## only warnings about values <= 0
	plot(t1, log = "y")
	plot(cbind(t1, 10*t1, t1 - 4), log="y", plot.type = "single")
	stopifnot(par("usr")[4] > 3) # log10: ylim[2] = 1000


	## This one needs to be looked at.
	## lty = "blank" killed the fill colour too.
	plot(1:10, type="n")
	polygon(c(1, 3, 3, 1), c(1, 1, 3, 3), col="yellow", border="red", lty="blank")
	rect(6, 6, 10, 10, col="blue", border="red", lty="blank")
	## in 1.5.0 all omit the fill colours.
	with(trees, symbols(Height, Volume, circles=Girth/24, inches=FALSE,
	lty="blank", bg="blue"))
	## in 1.5.0 ignored the lty.

	## axis() and par(mgp < 0) {keep this example S+ compatible!}:
	lt <- if(is.R()) "31" else 2
	x <- seq(-2,3, len=1001)
	op <- par(tck= +0.02, mgp = -c(3,2,0))
	plot(x, x^2 - 1.2, xaxt = "n", xlab="", type ='l', col = 2,
	main = "mgp < 0: all ticks and labels inside `frame'")
	x <- -2:3
	lines(x, x^2 - 1.2, type ="h", col = 3, lwd=3)
	axis(1, pos = 0, at=-1:1, lty = lt, col=4)## col & lty work only from R 1.6
	par(op)
	axis(1, pos = 0, at=c(-2,2,3), lty = lt, col=4)
	mtext(side=1,"note the x-ticks on the other side of the bars")

	## plot.table(): explicit xlab and ylab for non-1D
	plot(UCBAdmissions)# default x- and y-lab
	plot(UCBAdmissions, xlab = "x label", ylab = "YY")# wrong in 1.5.1
	## axis suppression
	plot(tt <- table(c(rep(0,7), rep(1,4), rep(5, 3))), axes = FALSE)
	plot(tt, xaxt = "n")
	## wrong till (incl.) 1.6.x

	## legend with call
	lo <- legend(2,2, substitute(hat(theta) == that, list(that= pi)))
	stopifnot(length(lo$text$x) == 1)
	## length() was 3 till 1.7.x

	plot(ecdf(c(1:4,8,12)), ylab = "ECDF", main=NULL)
	## ylab didn't work till 1.8.0

	plot(1:10, pch = NA) # gave error till 1.9.0
	points(1:3, pch=c("o",NA,"x"))# used "N"
	try(points(4, pch=c(NA,FALSE)))# still give an error

	## 'lwd' should transfer to plot symbols
	legend(1,10, c("A","bcd"), lwd = 2:3, pch= 21:22, pt.bg="skyblue",
	col = 2:3, bg = "thistle")
	## (gave an error for 2 days in "2.0.0 unstable")

	x <- 2^seq(1,1001, length=20)
	plot(x, x^0.9, type="l", log="xy")
	## gave error 'Infinite axis extents [GEPretty(1.87013e-12,inf,5)]' for R 2.0.1

	plot(as.Date("2001/1/1") + 12*(1:9), 1:9)
	## used bad 'xlab/ylab' in some versions of R 2.2.0(unstable)

	## dotchart() restoring par()
	Opar <- par(no.readonly=TRUE) ; dotchart(1:4, cex= 0.7)
	Npar <- par(no.readonly=TRUE)
	ii <- c(37, 50:51, 58:59, 63)
	stopifnot(identical(names(Opar)[ii],
	c("mai","pin","plt","usr","xaxp","yaxp")),
	identical(Opar[-ii], Npar[-ii]))
	## did not correctly restore par("mar") up to (incl) R 2.4.0

	## plot.function() [n=11, ... : since we store and diff PS file !]
	plot(cos, xlim=c(-5,5), n=11, axes=FALSE); abline(v=0)
	## did not plot for negative x up to R 2.5.1
	plot(sin, -2,3, xlim=c(-5,5), n=11, axes=FALSE, xlab="")# plot from -2
	axis(1, at=c(-2,3), tcl=-1); axis(1, at=c(-5,5))
	## (from,to) & xlim should work simultaneously

	plot(cos, -7,7, n=11, axes=FALSE)
	## gave wrong ylab in R 2.6.0
	plot(cos, -7,7, ylab = "Cosine cos(x)", n=11, axes=FALSE)
	## partial matching of 'ylab'; mapping [0,1] (not [-7.7]):
	## margins chosen to avoid rouding error showing to 2dp.
	op <- par(mar=c(5,4.123,4,2)+0.1)
	plot(gamma, yla = expression(Gamma(x)), n=11, yaxt="n")
	par(op)

	## plot.ts(x, y) could get the labels wrong in R <= 2.6.0:
	x <- ts(1:5);x1 <- lag(x, 2); plot(x1, x, axes=FALSE)

	# adding a curve in log scale :
	curve(5*exp(-x), 0.1, 100, n = 3, log="x", ylab="", axes=FALSE)
	curve(5*exp(-x), add=TRUE, n = 3, col=2,lwd=3)
	## should fully overplot; wrong default xlim in 2.6.1
	## (and slightly wrong up to 2.6.0)

	## Axis() calls via plot() {[xy]axt to keep *.ps small}
	x <- as.Date("2008-04-22 09:45") + (i <- c(0,4))
	plot(x, xaxt="n")# not ok in 2.6.2, nor 2.7.0
	plot(x, i, yaxt="n")# ok in 2.6.2 and 2.7.0
	plot(i, x, xaxt="n")# ok in 2.6.2 and not in 2.7.0

	## table methods should be bypassed:
	dotchart(table(infert$education))
	## failed in 2.12.[12]

	## cex as "..." in "high level" function
	hc <- hclust(dst <- dist(c(1:2, 5)), method="ave")
	plot(hc, cex = 2, axes=FALSE, ann=FALSE)
	## cex was not used in 3.0.[01]

	## axis.Date() and axis.POSIXct() with reversed 'xlim'
	toD <- as.Date("2016-08-19"); dates <- c(toD - 10, toD)
	plot(dates, 1:2, xlim = rev(dates),
	ann=FALSE, yaxt="n", frame.plot=FALSE)
	## failed to label the dates in R <= 3.3.1


	## axis() -- labels only written when there's room
	plot2 <- function(at, wait=FALSE) {
	plot1 <- function(x,y) plot(x,y, type="n", xlab="", ylab="", tck=0, frame.plot=FALSE)
	plot1( at, at); axis(3, at= at, tck=0)
	plot1(-at,-at); axis(3, at=-at, tck=0)
	if(wait) { mtext("Click here to advance!", line=-2, cex=1.5, col=2); locator(1) }
	}
	at <- c(7:15, 2(8:15), 5(7:15), 10*(8:15))
	op <- par(mfrow=2:1, mgp = c(1.5, 0.6, 0), mar = .1+c(2,2,2,1),
	lab = c(20,20,7), las = 1) # las=1: all horizontal => y-axis perpendicular
	interAct <- dev.interactive()

	if(interAct) { xMar <- c(1,3)/2 ; nP <- 10
	} else { xMar <- c(1,3)*3/2; nP <- 3 }
	## Now increasing margins ==> decreasing plot area ==> shrinking plot
	## (is device dependent [here have "a4r"-pdf]) :
	for(n in 1:nP) {
	par(mar = par("mar") + xMar)
	plot2(at, n < nP && interAct)
	}
	par(op)


	##----- pairs() using verInd & horInd ----------
	mpairs <- function(..., p=3, npp=2, main) { # p=4, npp=7 was Chris Andrews' example
	x <- matrix((1:(p*npp))/npp, ncol=p, dimnames=list(NULL, paste0("x", 1:p)))
	## -> x \in [1/npp,.., p] <==> ceiling(x) \in {1,2,...,p}
	## the panel function
	mP <- function(x,y, ...) { ## really made for the 'x = ...' above
	j <- ceiling(mean(y)) # in 1:p
	points(x,y, col=ceiling(mean(x)), pch= 3j, cex=((p-1.5)j+1)/p, ...)
	g <- 1:(p-1); abline(h=g, v=g, lty=3, col="gray33")
	}
	if(missing(main))
	main <- if(...length()) sub("mpairs", '', deparse(sys.call()))
	lim <- range(x)
	k <- max(2, npp-2) ## bug in R(?): par(lab = c(1,1,7)) giving nonsense!
	op <- par(lab = c(k,k,7), oma=c(1,0,0,0)); on.exit(par(op))
	pairs(x, panel=mP, xlim=lim, ylim=lim, main=main, cex.main=1, ...)
	}

	mpairs() # 4x4 matrix of scatterplots
	if(interAct) dev.set(if(length(dev.list()) < 2) dev.new() else dev.prev())
	mpairs(horInd=1:2,verInd= 1:3 ) # 3x2 matrix: upper left [WRONG in R <= 3.5.0]
	mpairs(horInd=3:2) # 2x4: middle rows swapped
	mpairs( verInd=c(3,1)) # 4x2: cols 3,1
	##
	## now all with 'row1attop=FALSE'=======
	if(interAct) dev.set(dev.prev())
	mpairs(row1attop=FALSE) # 4x4 matrix of scatterplots -- perfect in R <= 3.5.0
	if(interAct) dev.set(dev.next())
	## a version of those above, with 'row1attop = FALSE'
	mpairs(horInd=2:1,verInd=3:1 , row1attop=FALSE) # 3x2: swapped upper left
	mpairs(horInd=c(3,1) , row1attop=FALSE) # 2x3: swapped outer rows
	mpairs( verInd=c(3,2), row1attop=FALSE) # 3x2: cols 3,2


	## axis() when in subnormal range (x is subnormal if 0 < x < .Machine$double.xmin):
	(.min.exp.subnormal <- with(.Machine, double.min.exp + double.ulp.digits)) # -1074
	(ry <- range(y74 <- 2^(.min.exp.subnormal + 0:50))) # all subnormal
	plotNchk <- function(y) {
	plot(y, log = "y", xlab="", ylab="", xaxt="n") # (as small pdf as possible)
	ry <- range(y)
	xp <- par("yaxp")
	## and indeed yaxp do cover the range(y) :
	stopifnot(xp[1] <= ry[1], ry[2] <= xp[2], xp[3] == 1)
	invisible(xp)
	}
	if(interactive()) # not regularly, where pdf is stored
	plotNchk(y74) # gives 3 warnings; 1. from pretty(): "very small range"
	plotNchk(y74[1:8]) # 3 warnings and no error anymore
	plotNchk(y74[1:2]) # (ditto)


	## dotchart(, pch=., groups=) -- PR#16953
	x <- setNames(0:5, c('a','aa', 'aaa', 'b', 'bb', 'bbb'))
	y <- nchar(names(x)) # (minimal plot:)
	dotchart(x, color=y, pch=y, groups=y, xaxt="n", frame.plot=FALSE)
	## now pch and colors match groups