tests/reg-tests-1b.R

## From PR#10000 on, for R < 3.0.0

pdf("reg-tests-1b.pdf", encoding = "ISOLatin1.enc")

## force standard handling for data frames
options(stringsAsFactors = TRUE)
## .Machine
(Meps <- .Machine$double.eps)# and use it in this file

assertWarning <- tools::assertWarning
assertError <- tools::assertError

## str() for list-alikes :
"[[.foo" <- function(x,i) x
x <- structure(list(2), class="foo")
str(x)
## gave infinite recursion < 2.6.0


curve(sin, -2*pi, 3*pi); pu1 <- par("usr")[1:2]
curve(cos, add = NA) # add = NA new in 2.14.0
stopifnot(all.equal(par("usr")[1:2], pu1))
## failed in R <= 2.6.0


## tests of side-effects with CHARSXP caching
x <- y <- "abc"
Encoding(x) <- "UTF-8"
stopifnot(Encoding(y) == "unknown") # was UTF-8 in 2.6.0
x <- unserialize(serialize(x, NULL))
stopifnot(Encoding(y) == "unknown") # was UTF-8 in 2.6.0
##  problems in earlier versions of cache


## regression test for adding functions to deriv()
deriv3(~  gamma(y), namevec="y")
deriv3(~  lgamma(y), namevec="y")
# failed in R < 2.7.0
D(quote(digamma(sin(x))),"x")
D(quote(trigamma(sin(x))),"x")
D(quote(psigamma(sin(x))),"x")
D(quote(psigamma(sin(x), 3)),"x")
n <- 2L; D(quote(psigamma(sin(x), n)),"x")
## rest are new


## .subset2 quirk
iris[1, c(TRUE, FALSE, FALSE, FALSE, FALSE)]
iris[1, c(FALSE, FALSE, FALSE, FALSE, TRUE)]
## failed in 2.6.0


## indexing by "": documented as 'no name' and no match
x <- structure(1:4, names=c(letters[1:3], ""))
stopifnot(is.na(x[""])) # always so
stopifnot(is.na(x[NA_character_]))
z <- tryCatch(x[[NA_character_]], error=function(...) {})
stopifnot(is.null(z))
z <- tryCatch(x[[""]], error=function(...) {})
stopifnot(is.null(z)) # x[[""]] == 4 < 2.7.0
x[[""]] <- 5  # no match, so should add an element, but replaced.
stopifnot(length(x) == 5)
x[""] <- 6    # also add
stopifnot(length(x) == 6)
xx <- list(a=1, 2)
stopifnot(is.null(xx[[""]])) # 2 < 2.7.0
##


## negative n gave choose(n, k) == 0
stopifnot(isTRUE(all.equal(choose(-1,3),-1)))
##


## by() on 1-column data frame (PR#10506)
X <- data.frame(a=1:10)
g <- gl(2,5)
by(X, g, colMeans)
## failed in 2.6.1


## range.default omitted na.rm on non-numeric objects
(z <- range(as.Date(c("2007-11-06", NA)), na.rm = TRUE))
stopifnot(!is.na(z))
## NAs in 2.6.1


## cut() on constant values used the min, not abs(min)
z <- cut(rep(-1,5), 2)
stopifnot(!is.na(z))
##


## extreme example of two-sample wilcox.test
## reported by Wolfgang Huber to R-devel, 2008-01-01
## normal approximation is way off here.
wilcox.test(1, 2:60, conf.int=TRUE, exact=FALSE)
## failed in R < 2.7.0


## more corner cases for cor()
z <- cor(c(1,2,3),c(3,4,6),use="pairwise.complete.obs",method="kendall")
stopifnot(!is.matrix(x)) # was 1x1 in R < 2.7.0
Z <- cbind(c(1,2,3),c(3,4,6))
# next gave 0x0 matrix < 2.7.0
z <- try(cor(Z[, FALSE], use="pairwise.complete.obs",method="kendall"))
stopifnot(inherits(z, "try-error"))
# next gave NA < 2.7.0
z <- try(cor(numeric(0), numeric(0), use="pairwise.complete.obs",
             method="kendall"))
stopifnot(inherits(z, "try-error"))
##


## infinite loop in format.AsIs reported on R-help by Bert Gunter
## https://stat.ethz.ch/pipermail/r-help/2008-January/149504.html
z <- rep(Sys.time(),5)
data.frame(I(z))
##


## drop with length-one result
x <- matrix(1:4, 4,1, dimnames=list(letters[1:4], NULL))
stopifnot(identical(names(drop(x)), letters[1:4])) # was OK
stopifnot(identical(names(drop(x[1,,drop=FALSE])), "a")) # was no names
stopifnot(identical(names(x[1,]), "a")) # ditto
# now consistency tests.
x <- matrix(1, 1, 1, dimnames=list("a", NULL))
stopifnot(identical(names(x[,]), "a"))
x <- matrix(1, 1, 1, dimnames=list(NULL, "a"))
stopifnot(identical(names(x[,]), "a"))
x <- matrix(1, 1, 1, dimnames=list("a", "b"))
stopifnot(is.null(names(x[,])))
## names were dropped in R < 2.7.0 in all cases except the first.


## fisher.test with extreme degeneracy PR#10558
a <- diag(1:3)
p <- fisher.test(a, simulate.p.value=TRUE)$p.value
# true value is 1/60, but should not be small
stopifnot(p > 0.001)
## was about 0.0005 in 2.6.1 patched


## tests of problems fixed by Marc Schwartz's patch for
## cut/hist for Dates and POSIXt
Dates <- seq(as.Date("2005/01/01"), as.Date("2009/01/01"), "day")
months <- format(Dates, format = "%m")
years <- format(Dates, format = "%Y")
mn <- unlist(lapply(unname(split(months, years)), table), use.names=FALSE)
ty <- as.vector(table(years))
# Test hist.Date() for months
stopifnot(identical(hist(Dates, "month", plot = FALSE)$counts, mn))
# Test cut.Date() for months
stopifnot(identical(as.vector(table(cut(Dates, "month"))), mn))
# Test cut.Date() for 3 months
stopifnot(identical(as.vector(table(cut(Dates, "3 months"))),
                    as.integer(colSums(matrix(c(mn, 0, 0), nrow = 3)))))
# Test hist.Date() for years
stopifnot(identical(hist(Dates, "year", plot = FALSE)$counts, ty))
# Test cut.Date() for years
stopifnot(identical(as.vector(table(cut(Dates, "years"))),ty))
# Test cut.Date() for 3 years
stopifnot(identical(as.vector(table(cut(Dates, "3 years"))),
                    as.integer(colSums(matrix(c(ty, 0), nrow = 3)))))

Dtimes <- as.POSIXlt(Dates)
# Test hist.POSIXt() for months
stopifnot(identical(hist(Dtimes, "month", plot = FALSE)$counts, mn))
# Test cut.POSIXt() for months
stopifnot(identical(as.vector(table(cut(Dtimes, "month"))), mn))
# Test cut.POSIXt() for 3 months
stopifnot(identical(as.vector(table(cut(Dtimes, "3 months"))),
                    as.integer(colSums(matrix(c(mn, 0, 0), nrow = 3)))))
# Test hist.POSIXt() for years
stopifnot(identical(hist(Dtimes, "year", plot = FALSE)$counts, ty))
# Test cut.POSIXt() for years
stopifnot(identical(as.vector(table(cut(Dtimes, "years"))), ty))
# Test cut.POSIXt() for 3 years
stopifnot(identical(as.vector(table(cut(Dtimes, "3 years"))),
                    as.integer(colSums(matrix(c(ty, 0), nrow = 3)))))
## changed in 2.6.2


## zero-length args in tapply (PR#10644)
tapply(character(0), factor(letters)[FALSE], length)
## failed < 2.6.2


## zero-length patterns in gregexpr
expect <- structure(1:3, match.length=rep(0L, 3),
                    index.type = "chars", useBytes = TRUE)
stopifnot(identical(expect, gregexpr("", "abc")[[1]]))
stopifnot(identical(expect, gregexpr("", "abc", fixed=TRUE)[[1]]))
stopifnot(identical(expect, gregexpr("", "abc", perl=TRUE)[[1]]))
## segfaulted < 2.6.2


## test of internal argument matching
stopifnot(all.equal(round(d=2, x=pi), 3.14))
## used positional matching in 2.6.x


## kappa.tri(x, exact=TRUE) wrongly ended using exact=FALSE:
data(longley)
fm1 <- lm(Employed ~ ., data = longley)
stopifnot(all.equal(23845862, kappa(fm1, exact=TRUE)))


## names from pairlists (PR#10807, esoteric)
m <- c("a", "b", "c")
mp <- pairlist("a", "b", "c")
x <- 1:3
names(x) <- mp
stopifnot(identical(names(x), m)) # OK before
x <- 1:3
attr(x, "names") <- mp
stopifnot(identical(names(x), m)) # rep("a", 3) in 2.6.x
##


## preserving attributes in [<-.data.frame (PR#10873)
df <- data.frame(a=1:3, b=letters[1:3])
attr(df,"foo") <- 10
df[, "b"] <- 10:12
stopifnot(identical(attr(df, "foo"), 10))
## dropped attributes < 2.7.0


## r<foo> NA warnings, and rnorm(*, mu = +- Inf) consistency
op <- options(warn=2)
m <- c(-Inf,Inf)
stopifnot(rnorm(2, mean = m) == m,
          rexp (2, Inf) == 0)
set.seed(11)
rt(1, Inf)
R <- list(try(rnorm(2, numeric())),
          try(rexp (2, numeric())),
          try(rnorm(2, c(1,NA))),
          try(rnorm(1, sd = Inf)) )
options(op)
stopifnot(sapply(R, function(ch) sub(".* : ", '', ch) ==
                 "(converted from warning) NAs produced\n"))
## was inconsistent in R < 2.7.0


## predict.loess with transformed variables
set.seed(11)
y <- 1:100 + rnorm(100)
od <- data.frame(x=1:100, z=1:100 + rnorm(100, 10))
nd <- data.frame(x=1:100, z=11:110)
fit <- loess(y ~ log(x) + log(z), od)
p1 <- predict(fit, nd) # failed in 2.6.x
fit.log <- loess(y ~ x + z, log(od))
p2 <- predict(fit.log, log(nd))
stopifnot(all.equal(p1, p2))


## wishlist PR#11192
plot(1:10)
segments(1, 1, 10, 10, col='green')
segments(numeric(0), numeric(0), numeric(0), numeric(0), col='green')
## last was error in R < 2.8.0


## merging with a zero-row data frame
merge(NULL, women)
merge(women, NULL)
merge(women[FALSE, ], women)
merge(women, women[FALSE, ])
## first two failed in 2.7.0


## influence.measures() for lm and glm, and its constituents
if(require(MASS)) {
    fit <- lm(formula = 1000/MPG.city ~ Weight + Cylinders + Type + EngineSize + DriveTrain, data = Cars93)
    gf <- glm(formula(fit), data=Cars93) # should be "identical"
    im1 <- influence.measures(fit)
    im2 <- influence.measures(gf)
    stopifnot(all.equal(im1[1:2], im2[1:2]),
	      all.equal(unname(im1$infmat[,1:15]), unname(dfbetas(fit))),
	      all.equal(im1$infmat[,"dffit"], dffits(fit)),
	      all.equal(im1$infmat[,"cov.r"], covratio(fit)),
	      all.equal(im1$infmat[,"cook.d"], cooks.distance(fit)),
	      all.equal(im2$infmat[,"cook.d"], cooks.distance(gf)),
	      all.equal(im1$infmat[,"hat"],  hatvalues(fit)))
}
## "cook.d" part of influence.measures(<glm>) differed in R <= 2.7.0


## short list value for dimnames
n <- matrix(c(1259, 845, 719,390,1360,1053,774,413), nrow = 2, byrow = TRUE)
dimnames(n)[[1]] <- c("a", "b")
## was (correctly) an error in R < 2.8.0


## glob2rx(pattern, .) with "(", "[" or "{" in pattern :
nm <- "my(ugly[file{name"
stopifnot(identical(regexpr(glob2rx("*[*"), nm),
		    structure(1L, match.length = 8L,
                              index.type = "chars", useBytes = TRUE)),
	  identical(regexpr(glob2rx("*{n*"), nm),
		    structure(1L, match.length = 14L,
                              index.type = "chars", useBytes = TRUE)),
	  identical(regexpr(glob2rx("*y(*{*"), nm),
		    structure(1L, match.length = 13L,
                              index.type = "chars", useBytes = TRUE))
	  )
## gave 'Invalid regular expression' in R <= 2.7.0


## showDefault() problem with "unregistered" S3 classes:
show(structure(1:3, class = "myClass"))
## failed in R <= 2.7.0


## formatC(.., format="fg", flag="#"):
x <- 0.599 * c(.1, .01, .001, 1e-4,1e-5,1e-6)
(fCx <- formatC(x, digits=2, format="fg", flag="#"))
stopifnot(sub(".*(..)$", "\\1", fCx) == "60")
## dropped the trailing "0" in the last 3 cases, in R <= 2.7.0


## c.noquote bug, posted to R-devel by Ray Brownrigg, 2008-06-16
z <- c(noquote('z'), 'y', 'x', 'w')
stopifnot(identical(unclass(z), c('z', 'y', 'x', 'w')))
## repeated third and later args in R < 2.7.1.

## PD found that f==f contains NA when f has NA levels (but no missing value)
f1 <- factor(c(1, 2, NA), levels = 1:2)
f2 <- factor(c(1, 2, NA), exclude = NULL)
stopifnot(identical(f1, factor(c(1,2,NA))),
          nlevels(f1) == 2, nlevels(f2) == 3,
          all(f2 == f2), !any(f2 != f2),
          identical(f1 == f1, c(TRUE,TRUE,NA)))

f. <- f <- factor(c(letters[c(1:3,3:1)],"NA", "d","d", NA), exclude=NULL)
is.na(f.)[2:3] <- TRUE
f.
stopifnot(all(f == f), identical(f == f., f. == f.),
          identical(2:3, which(is.na(f. == f.))))
## f == f was wrong in R 1.5.0 -- 2.7.1


## data.frame[, <char>] must match exactly
dd <- data.frame(ii = 1:10, xx = pi * -3:6)
t1 <- try(dd[,"x"])# partial match
t2 <- try(dd[,"C"])# no match
stopifnot(inherits(t1, "try-error"),
	  inherits(t2, "try-error"),
	  ## partial matching is "ok" for '$' {hence don't use for dataframes!}
	  identical(dd$x, dd[,"xx"]))
## From 2.5.0 to 2.7.1, the non-match indexing gave NULL instead of error


## data.frame[ (<NA>), ] when row.names had  "NA"
x <- data.frame(x=1:3, y=2:4, row.names=c("a","b","NA"))
y  <- x [c(2:3, NA),]
y.ok <- data.frame(x=c(2:3,NA), y=c(3:4,NA), row.names=c("b", "NA", "NA.1"))
stopifnot(identical(y, y.ok))
## From 2.5.0 to 2.7.1,  y had row name "NA" twice


stopifnot(shapiro.test(c(0,0,1))$p.value >= 0)
## was wrong up to 2.7.1, because of rounding errors (in single precision).


stopifnot(rcond(cbind(1, c(3,3))) == 0)
## gave an error (because Lapack's LU detects exact singularity)


## dispatch when primitives are called from lapply.
x <- data.frame(d=Sys.Date())
stopifnot(sapply(x, is.numeric) == FALSE)
# TRUE in 2.7.1, tried to dispatch on "FUN"
(ds <- seq(from=Sys.Date(), by=1, length=4))
lapply(list(d=ds), round)
# failed in 2.7.1 with 'dispatch error' since call had '...' arg
## related to calls being passed unevaluated by lapply.


## subsetting data frames with NA cols
## Dieter Menne: https://stat.ethz.ch/pipermail/r-help/2008-January/151266.html
df3 <- data.frame(a=0:10,b=10:20,c=20:30)
names(df3) <- c("A","B", NA)
df3[-2]
df3[, -2]
df3[1:4, -2]
df3[c(TRUE,FALSE,TRUE)]
df3[, c(TRUE,FALSE,TRUE)]
df3[1:4, c(TRUE,FALSE,TRUE)]
## all gave 'undefined columns selected', 2.6.1 to 2.7.x
## note that you can only select columns by number, not by name


## nls with weights in an unusual model
Data <- data.frame(x=c(1,1,1,1,1,2,2,3,3,3,3,3,3,4,4,4,5,5,5,5,6,6,6,6,6,6,
                   7,7,7,7,7,7,7,7,7,8,8,8, 8,8,8,8,8,8,8,9,9,9,9,9,11,12),
                   y=c(73,73,70,74,75,115,105,107,124,107,116,125,102,144,178,
                   149,177,124,157,128, 169,165,186,152,181,139,173,151,138,
                   181,152,188,173,196,180,171,188,174,198, 172, 176,162,188,
                   182,182,141,191,190,159,170,163,197),
                   weight=c(1, rep(0.1, 51)))
G.st <- c(k=0.005, g1=50, g2=550)
# model has length-1 (and 52) variables
Ta <- min(Data$x)
Tb <- max(Data$x)

#no weights
nls(y~((g1)*exp((log(g2/g1))*(1-exp(-k*(x-Ta)))
                /(1-exp(-k*(Tb-Ta))))), data=Data, start=G.st, trace=TRUE)

#with weights
nls(y ~ ((g1)*exp((log(g2/g1))*(1-exp(-k*(x-Ta)))/(1-exp(-k*(Tb-Ta))))),
    data = Data, start = G.st, trace = TRUE, weights = weight)
## failed for find weights in R <= 2.7.1


## barplot(log = "y") with NAs (PR#11585)
dat <- matrix(1:25, 5)
dat[2,3] <- NA
barplot(dat, beside = TRUE, log = "y")
## failed in 2.7.1


## related to PR#12551
unique("a", c("a", "b"))
unique(1, 1:2)
# could seqfault in 2.7.1 on some platforms
stopifnot(!duplicated(rep("a", 3), "a"))
## wrong answer in 2.7.1


## drop1.lm() bug
dd <- stackloss ; dd[1,3] <- NA
rr <- lm(stack.loss ~ ., data=dd, na.action=na.exclude)
drop1(rr)
## failed in 2.7.x


## explicit row.names=NULL in data.frame()
stopifnot(identical(row.names(data.frame(x=c(a=1,b=2), row.names=NULL)),
                    c("1", "2")))
stopifnot(identical(row.names(data.frame(x=c(a=1,b=2))), c("a", "b")))
## same as default in 2.5.0 <= R < 2.7.2

stopifnot(all.equal(chol2inv(2), matrix(0.25, 1), tolerance = 4*Meps),
	  all.equal(solve(chol2inv(chol(4))), matrix(4, 1), tolerance = 10*Meps))
## chol2inv() did not accept non-matrices up to 2.7.*


## seek should discard pushback. (PR#12640)
cat(c("1\t2\t3", "4\t5\t6"), file="foo.txt", sep="\n")
fd <- file("foo.txt",open="rt")
scan(file=fd,what=double(),n=2)
seek(con=fd,where=0,origin="start")
z <- scan(file=fd,what=double(),n=2)
close(fd)
unlink("foo.txt")
stopifnot(identical(z, c(1,2)))
## changed in 2.7.2 patched


## cov / cor / var etc with NAs :
stopifnot(inherits(try(var(NULL)), "try-error"))## gave NA in 1.2.2
v0 <- var(0[FALSE]) # gave "'x' is empty" in the past;  NA in 1.2.2
x <- c(1:2,NA)
v1 <- var(c(1,NA))
v2 <- var(c(NA,0/0, Inf-Inf))
sx <- sd(x)# sd() -> var()
## all three gave "missing observations in cov/cor"  for a long time in the past
is.NA <- function(x) is.na(x) & !is.nan(x)
stopifnot(is.NA(v1), is.NA(v2), is.NA(sx),
	  all.equal(0.5, var(x, na.rm=TRUE), tol=8*Meps)# should even be exact
	  )


## write.dcf() indenting for ".<foo>" (PR#12816)
zz <- textConnection("foo", "w")
write.dcf(list(Description = 'what a fat goat .haha'),
          file = zz, indent=1, width=10)
stopifnot(substring(foo[-1], 1,1) == " ", length(foo) == 4,
          foo[4] == "  .haha")
close(zz)
## was " .haha" (not according to DCF standard)


## pdf() with CIDfonts active -- they need MBCS to be supported
pdf(file = "testCID.pdf", family="Japan1") # << for CIDfonts, pd->fonts is NULL
try({
    plot(1,1,pch="", axes=FALSE)
    text(1,1,"F.1", family="Helvetica")
})
dev.off()
unlink("testCID.pdf")
## text() seg.faulted up to 2.7.2 (and early 2.8.0-alpha)


## PS mixing CIDfonts and Type1 - reverse case
postscript(file = "testCID.ps", family="Helvetica")
plot(1,1,pch="", axes=FALSE)
try(text(1,1,"A",family="Japan1"))
unlink("testCID.ps")
## error instead of seg.fault


## splinefun with derivatives evaluated to the left of first knot
x <- 1:10; y <- sin(x)
splfun <- splinefun(x,y, method='natural')
x1 <- splfun( seq(0,1, 0.1), deriv=1 )
x2 <- splfun( seq(0,1, 0.1), deriv=2 )
x3 <- splfun( seq(0,1, 0.1), deriv=3 )
stopifnot(x1 == x1[1], x2 == 0, x3 == 0)
##


## glm(y = FALSE), in part PR#1398
fit <- glm(1:10 ~ I(1:10) + I((1:10)^2), y = FALSE)
anova(fit)
## obscure errors < 2.8.0


## boundary case in cut.Date (PR#13159)
d <- as.Date("2008-07-07")
cut(d, "weeks")
d <- as.POSIXct("2008-07-07", tz="UTC")
cut(d, "weeks")
## failed < 2.8.0


### end of tests added for 2.8.x


## (Deliberate) overshot in seq(from, to, by) because of fuzz
stopifnot(seq(0, 1, 0.00025+5e-16) <= 1, seq.int(0, 1, 0.00025+5e-16) <= 1)
## overshot by about 2e-12 in 2.8.x
## no longer reaches 1 in 2.11.0 (needed a fuzz of 8e-9)


## str() with an "invalid object"
ob <- structure(1, class = "test") # this is fine
is.object(ob)# TRUE
ob <- 1 + ob # << this is "broken"
is.object(ob)# FALSE - hmm..
identical(ob, unclass(ob)) # TRUE !
stopifnot(grep("num 2", capture.output(str(ob))) == 1)
## str(ob) lead to infinite recursion in R <= 2.8.0


## row.names(data.frame(matrixWithDimnames)) (PR#13230)
rn0 <- c("","Row 2","Row 3")
A <- matrix(1:6, nrow=3, ncol=2, dimnames=list(rn0, paste("Col",1:2)))
rn <- row.names(data.frame(A))
stopifnot(identical(rn, rn0))
# was 1:3 in R 2.8.0, whereas
rn0 <- c("Row 1","","Row 3")
A <- matrix(1:6, nrow=3, ncol=2, dimnames=list(rn0, paste("Col",1:2)))
rn <- row.names(data.frame(A))
stopifnot(identical(rn, rn0))
## used the names.


## rounding error in windowing a time series (PR#13272)
x <- ts(1:290, start=c(1984,10), freq=12)
window(x, start=c(2008,9), end=c(2008,9), extend=FALSE)
window(x, start=c(2008,9), end=c(2008,9), extend=TRUE)
## second failed in 2.8.0


## deparse(nlines=) should shrink the result (PR#13299)
stopifnot(length(deparse(quote(foo(1,2,3)), width.cutoff = 20, nlines=7)) ==1)
## was 7.


## legend did not reset xpd correctly (PR#12756)
par(xpd = FALSE)
plot(1)
legend("top", legend="Tops", xpd=NA, inset=-0.1)
stopifnot(identical(par("xpd"), FALSE))
## left xpd as NA


## lines.formula with 'subset' and no 'data' needed a tweak
## (R-help, John Field, 20008-11-14)
x <- 1:5
y <- c(1,3,NA,2,5)
plot(y ~ x, type="n")
lines(y ~ x, subset = !is.na(y), col="red")
## error in 2.8.0


## prettyNum(*, drop0trailing) erronously dropped 0 in '1e10':
cn <- c("1.107", "2.3120", "3.14e+0", "4.2305400", "120.0",
        "5.31e-01", "6.3333e-20", "8.1e100", "9.9e+00", "10.1e-0")
d <- cn != (pcn <- prettyNum(cn, drop0trailing=TRUE))
stopifnot(identical(pcn[d],
		    c("2.312", "3.14", "4.23054","120","9.9","10.1")),
	  identical("-3", prettyNum("-3.0",drop0trailing=TRUE)) )
## first failed, e.g. for 8.1e100


## (R-help, 2008-12-01)
transform(mtcars, t1=3, t2=4)
## failed in 2.8.0 since extra columns were passed as a list.


## deparsing transform failed
parse(text = deparse(transform))
## failed in 2.8.0


## crashed on some systems (PR#13361)
matrix(1:4, nrow=2, dimnames=list())
##


## col(as.factor=TRUE) failed
col(matrix(0, 5, 5), as.factor=TRUE)
## failed in 2.8.0


## qt failure in R-devel in early Dec 2008
stopifnot(!is.nan(qt(0.1, 0.1)))
##


## formals<- gave wrong result for list body
f <- f0 <- function(x) list(pi)
formals(f) <- formals(f)
stopifnot(identical(body(f), body(f)))
## had body 'pi' < 2.8.1


## body<- failed on a function with no arguments.
f <- function() {pi}
body(f) <- 2
f
## Failed < 2.8.1


## body<- with value a list
f <- function(x) NULL
body(f) <- list(pi)
stopifnot(is.list(body(f))) # was 'pi'
body(f) <- b0 <- list(a=1, b=2)
stopifnot(identical(body(f), b0)) # 'a' became an argument
f <- function(x) NULL
body(f) <- list(1, 2, 3) # was error
## pre-2.9.0 behaviour was erratic.


## PR#13305
qr.solve(cbind(as.complex(1:11), as.complex(1)),
         as.complex(2*(20:30)))
## failed in 2.8.1


## PR#13433: is ....\nEOF an empty last line?
aa <- "field1\tfield2\n 1\ta\n 2\tb"
zz <- textConnection(aa)
res <- read.table(zz, blank.lines.skip = FALSE)
close(zz)
stopifnot(nrow(res) == 3)
## was 4 in 2.8.1


## segfault from cbind() reported by Hadley Wickham
## https://stat.ethz.ch/pipermail/r-devel/2009-January/051853.html
e <- environment()
a <- matrix(list(e), ncol = 1, nrow = 2)
b <- matrix(ncol = 0, nrow = 2) # zero-length
cbind(a, b)
cbind(a, b)
## crashed in 2.9.0


## besselI(x, -n) == besselI(x, +n)  when n is an integer
set.seed(7) ; x <- rlnorm(216) ; nu <- c(1,44,111)
## precision lost warnings {may be gone in the future}:
suppressWarnings(r <- outer(x, c(-nu, nu), besselI))
stopifnot(identical(r[,1:3], r[,4:6]))
## suffered from sin(n * pi) imprecision in R <= 2.8.1


## Large sanples in mood.test
## https://stat.ethz.ch/pipermail/r-help/2009-March/190479.html
set.seed(123)
x <- rnorm(50, 10, 5)
y <- rnorm(50, 2 ,5)
(z <- mood.test(x, y))
stopifnot(!is.na(z$p.value))
## gave warning and incorrect result in 2.8.x


## heatmap without dendrogram (PR#13512)
X <- matrix(rnorm(200),20,10)
XX <- crossprod(X)
heatmap(XX, Rowv =  NA, revC = TRUE)
heatmap(XX, Rowv = NA, symm = TRUE)
## both failed in 2.8.1


## sprintf with 0-length args
stopifnot(identical(sprintf("%d", integer(0L)), character(0L)))
stopifnot(identical(sprintf(character(0L), pi), character(0L)))
## new feature in 2.9.0


## C-level asLogical(x) or c(<raw>, <number>) did not work
r <- as.raw(1)
stopifnot(if(r) TRUE)
for (type in c("null", "logical", "integer", "double", "complex",
               "character", "list", "expression"))
    c(r, r, get(sprintf('as.%s', type))(1))
## failed  before 2.9.0


### Non-unique levels in factor should be forbidden from R 2.10.0 on
c1 <- c("a.b","a"); c2 <- c("c","b.c")
fi <- interaction(c1, c2)
stopifnot(length(lf <- levels(fi)) == 3, lf[1] == "a.b.c",
	  identical(as.integer(fi), rep.int(1L, 2)))
## interaction() failed to produce unique levels before 2.9.1

levs <- c("A","A")
## warnings since 2009; errors since R 3.4.0 (R-devel, June 2016):
local({
    assertError(gl(2,3, labels = levs))
    assertError(factor(levs, levels=levs))
    ## now valid: factor(1:2,  labels=levs)
    })
## failed in R < 2.10.0
L <- c("no", "yes")
x <- (5:1)/10; lx <- paste("0.", 1:5, sep="")
y <- pi + (-9:9)*2^-53
z <- c(1:2,2:1) ; names(z) <- nz <- letters[seq_along(z)]
of <- ordered(4:1)
stopifnot(identical(factor(c(2, 1:2), labels = L),
		    structure(c(2L, 1:2), .Label = L, class="factor")),
	  identical(factor(x),
		    structure(5:1, .Label = lx, class="factor")),
	  length(levels(factor(y))) == 1, length(unique(y)) == 5,
	  identical(factor(z),
		    structure(z, .Names = nz, .Label = c("1","2"),
			      class="factor")),
	  identical(of, factor(of)))
## partly failed in R <= 2.9.0, partly in R-devel(2.10.0)


## "misuses" of sprintf()
assertError(sprintf("%S%"))
assertError(sprintf("%n %g", 1))
## seg.faulted in R <= 2.9.0


## sprintf(., e)  where length(as.character(e)) < length(e):
e <- tryCatch(stop(), error=identity)
stopifnot(identical(sprintf("%s", e),
		    sprintf("%s", as.character(e))))
## seg.faulted in R <= 2.9.0
e <- tryCatch(sprintf("%q %d",1), error=function(e)e)
e2 <- tryCatch(sprintf("%s", quote(list())), error=function(e)e)
e3 <- tryCatch(sprintf("%s", quote(blabla)), error=function(e)e)
stopifnot(inherits(e, "error"), inherits(e2, "error"),inherits(e3, "error"),
	  grep("invalid", c(msg	 <- conditionMessage(e),
			    msg2 <- conditionMessage(e2),
			    msg3 <- conditionMessage(e3))) == 1:3,
	  1 == c(grep("%q", msg), grep("language", msg2), grep("symbol", msg3))
          )
## less helpful error messages previously


## bw.SJ on extreme example
ep <- 1e-3
stopifnot(all.equal(bw.SJ(c(1:99, 1e6), tol = ep), 0.725, tolerance = ep))
## bw.SJ(x) failed for R <= 2.9.0 (in two ways!), when x had extreme outlier


## anyDuplicated() with 'incomp' ...
oo <- options(warn=2) # no warnings allowed
stopifnot(identical(0L, anyDuplicated(c(1,NA,3,NA,5), incomp=NA)),
	  identical(5L, anyDuplicated(c(1,NA,3,NA,3), incomp=NA)),
	  identical(4L, anyDuplicated(c(1,NA,3,NA,3), incomp= 3)),
	  identical(0L, anyDuplicated(c(1,NA,3,NA,3), incomp=c(3,NA))))
options(oo)
## missing UNPROTECT and partly wrong in development versions of R


## test of 'stringsAsFactors' argument to expand.grid()
z <- expand.grid(letters[1:3], letters[1:4], stringsAsFactors = TRUE)
stopifnot(sapply(z, class) == "factor")
z <- expand.grid(letters[1:3], letters[1:4], stringsAsFactors = FALSE)
stopifnot(sapply(z, class) == "character")
## did not work in 2.9.0, fixed in 2.9.1 patched


## print.srcref should not fail; a bad encoding should fail; neither should
## leave an open connection
nopen <- nrow(showConnections())
tmp <- tempfile()
cat( c( "1", "a+b", "2"), file=tmp, sep="\n")
p <- parse(tmp)
print(p)
con <- try(file(tmp, open="r", encoding="unknown"))
unlink(tmp)
stopifnot(inherits(con, "try-error") && nopen == nrow(showConnections()))
##


## PR#13574
x <- 1:11; y <- c(6:1, 7, 11:8)
stopifnot(all.equal(cor.test(x, y, method="spearman", alternative="greater")$p.value,
                    cor.test(x, -y, method="spearman", alternative="less")$p.value))
## marginally different < 2.9.0 patched


## median should work on POSIXt objects (it did in 2.8.0)
median(rep(Sys.time(), 2))
## failed in 2.8.1, 2.9.0


## repeated NA in dim() (PR#13729)
L0 <- logical(0)
try(dim(L0) <- c(1,NA,NA))
stopifnot(is.null(dim(L0)))
L1 <- logical(1)
try(dim(L1) <- c(-1,-1))
stopifnot(is.null(dim(L)))
## dim was set in 2.9.0


## as.character(<numeric>)
nx <- 0.3 + 2e-16 * -2:2
stopifnot(identical("0.3", unique(as.character(nx))),
          identical("0.3+0.3i", unique(as.character(nx*(1+1i)))))
## the first gave ("0.300000000000000" "0.3") in R < 2.10.0


## aov evaluated a test in the wrong place ((PR#13733)
DF <- data.frame(y = c(rnorm(10), rnorm(10, mean=3), rnorm(10, mean=6)),
                 x = factor(rep(c("A", "B", "C"), c(10, 10, 10))),
                 sub = factor(rep(1:10, 3)))
## In 2.9.0, the following line raised an error because "x" cannot be found
junk <- summary(aov(y ~ x + Error(sub/x), data=DF, subset=(x!="C")))
## safety check added in 2.9.0 evaluated the call.


## for(var in seq) .. when seq is modified  "inside" :
x <- c(1,2); s <- 0; for (i in x) { x[i+1] <- i + 42.5; s <- s + i }
stopifnot(s == 3)
## s was  44.5  in R <= 2.9.0


## ":" at the boundary
M <- .Machine$integer.max
s <- (M-2):(M+.1)
stopifnot(is.integer(s), s-M == -2:0)
## was "double" in R <= 2.9.1


## too many columns model.matrix()
dd <- as.data.frame(sapply(1:40, function(i) gl(2, 100)))
(f <- as.formula(paste("~ - 1 + ", paste(names(dd), collapse = ":"), sep = "")))
e <- tryCatch(X <- model.matrix(f, data = dd), error=function(e)e)
stopifnot(inherits(e, "error"))
## seg.faulted in R <= 2.9.1


## seq_along( <obj> )
x <- structure(list(a = 1, value = 1:7), class = "FOO")
length.FOO <- function(x) length(x$value)
stopifnot(identical(seq_len(length(x)),
		    seq_along(x)))
## used C-internal non-dispatching length() in R <= 2.9.1


## factor(NULL)
stopifnot(identical(factor(), factor(NULL)))
## gave an error from R ~1.3.0 to 2.9.1


## methods() gave two wrong warnings in some cases:
op <- options(warn = 2)# no warning, please!
m1 <- methods(na.omit) ## should give (no warning):
##
setClass("bla")
setMethod("na.omit", "bla", function(object, ...) "na.omit(<bla>)")
(m2 <- methods(na.omit)) ## should give (no warning):
stopifnot(identical(m1, .S3methods("na.omit")))
options(op)
## gave two warnings, when an S3 generic had turned into an S4 one


## raw vector assignment with NA index
x <- charToRaw("abc")
y <- charToRaw("bbb")
x[c(1, NA, 3)] <- x[2]
stopifnot(identical(x, y))
## used to segfault


## Logic operations with complex
stopifnot(TRUE & -3i, FALSE | 0+1i,
	  TRUE && 1i, 0+0i || 1+0i)
## was error-caught explicitly in spite of contrary documentation


## Tests of save/load with different types of compression
x <- xx <- 1:1000
test1 <- function(ascii, compress)
{
    tf <- tempfile()
    save(x, ascii = ascii, compress = compress, file = tf)
    load(tf)
    stopifnot(identical(x, xx))
    unlink(tf)
}
for(compress in c(FALSE, TRUE))
    for(ascii in c(TRUE, FALSE)) test1(ascii, compress)
for(compress in c("bzip2", "xz"))
    for(ascii in c(TRUE, FALSE)) test1(ascii, compress)


## tests of read.table with different types of compressed input
mor <- system.file("data/morley.tab", package="datasets")
ll <- readLines(mor)
tf <- tempfile()
## gzip copression
writeLines(ll, con <- gzfile(tf)); close(con)
file.info(tf)$size
stopifnot(identical(read.table(tf), morley))
## bzip2 copression
writeLines(ll, con <- bzfile(tf)); close(con)
file.info(tf)$size
stopifnot(identical(read.table(tf), morley))
## xz copression
writeLines(ll, con <- xzfile(tf, compression = -9)); close(con)
file.info(tf)$size
stopifnot(identical(read.table(tf), morley))
unlink(tf)


## weighted.mean with NAs (PR#14032)
x <- c(101, 102, NA)
stopifnot(all.equal(mean(x, na.rm = TRUE), weighted.mean(x, na.rm = TRUE)))
## divided by 3 in 2.10.0 (only)
## but *should* give NaN for empty:
stopifnot(identical(NaN, weighted.mean(0[0])),
	  identical(NaN, weighted.mean(NA,		na.rm=TRUE)),
	  identical(NaN, weighted.mean(rep(NA_real_,2), na.rm=TRUE)))
## all three gave 0  in 2.10.x and 2.11.x (but not previously)


## unname() on 0-length vector
stopifnot(identical(1[FALSE], unname(c(a=1)[FALSE])))
## failed to drop names in 2.10.0


## complete.cases on 0-column data frame
complete.cases(data.frame(1:10)[-1])
## failed in 2.10.0


## PR#14035, converting (partially) unnamed lists to environments.
(qq <- with(list(2), ls()))
nchar(qq)
with(list(a=1, 2), ls())
## failed in R < 2.11.0


## chisq.test with over-long 'x' or 'y' arg
# https://stat.ethz.ch/pipermail/r-devel/2009-November/055700.html
x <- y <- rep(c(1000, 1001, 1002), each=5)
z <- eval(substitute(chisq.test(x,y), list(x=x)))
z
z$observed
## failed in 2.10.0


## unsplit(drop = TRUE) on a data frame failed (PR#14084)
dff <- data.frame(gr1 = factor(c(1,1,1,1,1,2,2,2,2,2,2), levels=1:4),
                  gr2 = factor(c(1,2,1,2,1,2,1,2,1,2,3), levels=1:4),
                  yy = rnorm(11), row.names = as.character(1:11))
dff2 <- split(dff, list(dff$gr1, dff$gr2), drop=TRUE)
dff3 <- unsplit(dff2, list(dff$gr1, dff$gr2), drop=TRUE)
stopifnot(identical(dff, dff3))
## failed in 2.10.0


## mean.difftime ignored its na.rm argument
z <- as.POSIXct(c("1980-01-01", "1980-02-01", NA, "1980-03-01", "1980-04-01"))
zz <- diff(z)
stopifnot(is.finite(mean(zz, na.rm=TRUE)))
## was NA in 2.10.0


## weighted means with zero weights and infinite values
x <- c(0, 1, 2, Inf)
w <- c(1, 1, 1, 0)
z <- weighted.mean(x, w)
stopifnot(is.finite(z))
## was NaN in 2.10.x


## Arithmetic operations involving "difftime"
z <- as.POSIXct(c("2009-12-01", "2009-12-02"), tz="UTC")
(zz <- z[2] - z[1])
(zzz <- z[1] + zz)
stopifnot(identical(zzz, z[2]),
          identical(zz + z[1], z[2]),
          identical(z[2] - zz, z[1]))
z <- as.Date(c("2009-12-01", "2009-12-02"))
(zz <- z[2] - z[1])
(zzz <- z[1] + zz)
stopifnot(identical(zzz, z[2]),
          identical(zz + z[1], z[2]),
          identical(z[2] - zz, z[1]))
## failed/gave wrong answers when Ops.difftime was introduced.


## quantiles, new possibilities in 2.11.0
x <- ordered(1:11, labels=letters[1:11])
quantile(x, type = 1)
quantile(x, type = 3)
st <- as.Date("1998-12-17")
en <- as.Date("2000-1-7")
ll <- seq(as.Date("2000-1-7"), as.Date("1997-12-17"), by="-1 month")
quantile(ll, type = 1)
quantile(ll, type = 3)
## failed prior to 2.11.0


## (asymptotic) point estimate in wilcox.test(*, conf.int=TRUE)
alt <- eval(formals(stats:::wilcox.test.default)$alternative)
Z <- c(-2, 0, 1, 1, 2, 2, 3, 5, 5, 5, 7)
E1 <- sapply(alt, function(a.)
	     wilcox.test(Z, conf.int = TRUE,
			 alternative = a., exact = FALSE)$estimate)
X <- c(6.5, 6.8, 7.1, 7.3, 10.2)
Y <- c(5.8, 5.8, 5.9, 6, 6, 6, 6.3, 6.3, 6.4, 6.5, 6.5)
E2 <- sapply(alt, function(a.)
	     wilcox.test(X,Y, conf.int = TRUE,
			 alternative = a., exact = FALSE)$estimate)
stopifnot(E1[-1] == E1[1],
	  E2[-1] == E2[1])
## was continiuity corrected, dependent on 'alternative', prior to 2.10.1


## read.table with embedded newlines in header (PR#14103)
writeLines(c('"B1', 'B2"', 'B3'), "test.dat")
z <- read.table("test.dat", header = TRUE)
unlink("test.dat")
stopifnot(identical(z, data.frame("B1.B2"="B3")))
## Left part of header to be read as data in R < 2.11.0


## switch() with  empty  '...'
stopifnot(is.null(switch("A")),
	  is.null(switch(1)), is.null(switch(3L)))
## the first one hung, 2nd gave error, in R <= 2.10.1


## factors with NA levels
V <- addNA(c(0,0,NA,0,1,1,0,NA,1,1))
stopifnot(identical(V, V[, drop = TRUE]))
stopifnot(identical(model.frame(~V), model.frame(~V, xlev = list(V=levels(V)))))
# dropped NA levels (in two places) in 2.10.1
V <- c(0,0,NA,0,1,1,0,NA,1,1)
stopifnot(identical(V, V[, drop = TRUE]))
stopifnot(identical(model.frame(~V), model.frame(~V, xlev = list(V=levels(V)))))
## check other cases have not been changed


## ks.test gave p=1 rather than p=0.9524 because abs(1/2-4/5)>3/10 was TRUE
stopifnot(all.equal(ks.test(1:5, c(2.5,4.5))$p.value, 20/21))


## NAs in utf8ToInt and v.v.
stopifnot(identical(utf8ToInt(NA_character_), NA_integer_),
          identical(intToUtf8(NA_integer_), NA_character_),
          identical(intToUtf8(NA_integer_, multiple = TRUE), NA_character_))
## no NA-handling prior to 2.11.0


## tcrossprod() for  matrix - vector combination
u <- 1:3 ; v <- 1:5
## would not work identically: names(u) <- LETTERS[seq_along(u)]
U <- as.matrix(u)
stopifnot(identical(tcrossprod(u,v), tcrossprod(U,v)),
	  identical(tcrossprod(u,v), u %*% t(v)),
	  identical(tcrossprod(v,u), tcrossprod(v,U)),
	  identical(tcrossprod(v,u), v %*% t(u)))
## tcrossprod(v,U) and (U,v) wrongly failed in R <= 2.10.1


## det() and determinant() in NA cases
m <- matrix(c(0, NA, 0, NA, NA, 0, 0, 0, 1), 3,3)
m0 <- rbind(0, cbind(0, m))
if(FALSE) { ## ideally, we'd want -- FIXME --
stopifnot(is.na(det(m)), 0 == det(m0))
} else print(c(det.m = det(m), det.m0 = det(m0)))
## the first wrongly gave 0  (still gives .. FIXME)


## c/rbind(deparse.level=2)
attach(mtcars)
(cn <- colnames(cbind(qsec, hp, disp)))
stopifnot(identical(cn, c("qsec", "hp", "disp")))
(cn <- colnames(cbind(qsec, hp, disp, deparse.level = 2)))
stopifnot(identical(cn, c("qsec", "hp", "disp")))
(cn <- colnames(cbind(qsec, log(hp), sqrt(disp))))
stopifnot(identical(cn, c("qsec", "", "")))
(cn <- colnames(cbind(qsec, log(hp), sqrt(disp), deparse.level = 2)))
stopifnot(identical(cn, c("qsec", "log(hp)", "sqrt(disp)")))
detach()
## 2.10.1 gave no column names for deparse.level=2


## Infinite-loops with match(incomparables=)
match(c("A", "B", "C"), "A", incomparables=NA)
match(c("A", "B", "C"), c("A", "B"), incomparables="A")
## infinite-looped in 2.10.1


## path.expand did not propagate NA
stopifnot(identical(c("foo", NA), path.expand(c("foo", NA))))
## 2.10.1 gave "NA"


## prettyNum(drop0trailing=TRUE) mangled complex values (PR#14201)
z <- c(1+2i, 1-3i)
str(z) # a user
stopifnot(identical(format(z, drop0trailing=TRUE), as.character(z)))
## 2.10.1 gave 'cplx [1:2] 1+2i 1+3i'


## "exact" fisher.test
dd <- data.frame(group=1, score=c(rep(0,14), rep(1,29), rep(2, 16)))[rep(1:59, 2),]
dd[,"group"] <- c(rep("DOG", 59), rep("kitty", 59))
Pv <- with(dd, fisher.test(score, group)$p.value)
stopifnot(0 <= Pv, Pv <= 1)
## gave P-value 1 + 1.17e-13  in R < 2.11.0


## Use of switch inside lapply (from BioC package ChromHeatMap)
lapply("forward", switch, forward = "posS", reverse = "negS")
## failed  when first converted to primitive.


## evaluation of arguments of log2
assertError(tryCatch(log2(quote(1:10))))
## 'worked' in 2.10.x by evaluting the arg twice.


## mean with NAs and trim (Bill Dunlap,
## https://stat.ethz.ch/pipermail/r-devel/2010-March/056982.html)
stopifnot(is.na(mean(c(1,10,100,NA), trim=0.1)),
          is.na(mean(c(1,10,100,NA), trim=0.26)))
## gave error, real value respectively in R <= 2.10.1


## all.equal(*, tol) for objects with numeric attributes
a <- structure(1:17, xtras = c(pi, exp(1)))
b <- a * (II <- (1 + 1e-7))
attr(b,"xtras") <- attr(a,"xtras") * II
stopifnot(all.equal(a,b, tolerance = 2e-7))
## gave  "Attributes: .... relative difference: 1e-07"  in R <= 2.10.x


## Misuse of gzcon() [PR# 14237]
(ac <- getAllConnections())
tc <- textConnection("x", "w")
try(f <- gzcon(tc)) # -> error.. but did *damage* tc
newConn <- function(){ A <- getAllConnections(); A[is.na(match(A,ac))] }
(newC <- newConn())
gg <- tryCatch(getConnection(newC), error=identity)
stopifnot(identical(gg, tc))
close(tc)
stopifnot(length(newConn()) == 0)
## getConn..(*) seg.faulted in R <= 2.10.x


## splinefun(., method = "monoH.FC")
x <- 1:7 ; xx <- seq(0.9, 7.1, length=2^12)
y <- c(-12, -10, 3.5, 4.45, 4.5, 140, 142)
Smon <- splinefun(x, y, method = "monoH.FC")
stopifnot(0 <= min(Smon(xx, deriv=1)))
## slopes in [4.4, 4.66] were slightly negative, because m[] adjustments
## could be sightly off in cases of adjacency, for  R <= 2.11.0


## prettyDate( <Date> )
x <- as.Date("2008-04-22 09:45") + 0:5
px <- pretty(x, n = 5)
stopifnot(px[1] == "2008-04-22", length(px) == 6)
## did depend on the local timezone  at first


## cut( d, breaks = n) - for d of class  'Date' or 'POSIXt'
x <- seq(as.POSIXct("2000-01-01"), by = "days", length = 20)
stopifnot(nlevels(c1 <- cut(x, breaks = 3)) == 3,
	  nlevels(c2 <- cut(as.POSIXlt(x), breaks = 3)) == 3,
	  nlevels(c3 <- cut(as.Date(x), breaks = 3)) == 3,
	  identical(c1, c2))
## failed in R <= 2.11.0


## memDecompress (https://stat.ethz.ch/pipermail/r-devel/2010-May/057419.html)
char <- paste(replicate(200, "1234567890"), collapse="")
char.comp <- memCompress(char, type="xz")
char.dec <- memDecompress(char.comp, type="xz", asChar=TRUE)
stopifnot(nchar(char.dec) == nchar(char))
## short in R <= 2.11.0


## rbeta() with mass very close to 1 -- bug PR#14291
set.seed(1)
if(any(ii <- is.na(rbeta(5000, 100, 0.001))))
    stop("rbeta() gave NAs at ", paste(which(ii), collapse=", "),
         "\n")
## did give several, but platform dependently, in R <= 2.11.0


## print.ls_str() should not eval() some objects
E <- environment((function(miss)function(){})())
E$i <- 2:4
E$o <- as.name("foobar")
E$cl <- expression(sin(x))[[1]]
ls.str(E)
## 'o' failed in R <= 2.11.0 (others in earlier versions of R)


## print() {& str()} should distinguish named empty lists
stopifnot(identical("named list()",
		    capture.output(list(.=2)[0])))
## was just "list()" up to R <= 2.11.x


## stripchart with empty first level (PR#14317)
stripchart(decrease ~ treatment, data = OrchardSprays,
           subset = treatment != "A")
## failed in 2.11.1


## versions of pre-2.12.0 using zlib 1.2.[45] failed
zz <- gzfile("ex.gz", "w")  # compressed file
cat("TITLE extra line", "2 3 5 7", "", "11 13 17", file = zz, sep ="\n")
close(zz)
blah <- file("ex.gz", "r")
stopifnot(seek(blah) == 0)
## gave random large multiple of 2^32 on Linux systems attempting to
## use LFS support.


## pre-2.12.0 wrongly accessed 0-length entries
o0 <- as.octmode(integer(0))
stopifnot(identical(o0, o0 & "400"))
## gave a seg.fault at some point


## as.logical on factors
x <- factor(c("FALSE", "TRUE"))
stopifnot(identical(as.logical(x), c(FALSE, TRUE)))
# Lost documented behaviour when taken primitive in R 2.6.0
stopifnot(identical(as.vector(x, "logical"), c(FALSE, TRUE)))
# continued to work
## Reverted in 2.12.0.


## missing backquoting of default arguments in in prompt()
f <- function (FUN = `*`) {}
pr <- prompt(f, NA)$usage
stopifnot(identical(pr[2], "f(FUN = `*`)"))
## see https://stat.ethz.ch/pipermail/r-devel/2010-August/058126.html


## cut.POSIXt very near boundaries (PR#14351)
x <- as.POSIXlt("2010-08-10 00:00:01")
stopifnot(!is.na(cut(x, "5 hours")))
## was NA in 2.11.x


## summary() on data frames with invalid names -- in UTF-8 locale
DF <- data.frame(a = 1:3, b = 4:6)
nm <- names(DF) <- c("\xca", "\xcb")
cn <- gsub(" ", "", colnames(summary(DF)), useBytes = TRUE)
stopifnot(identical(cn, nm))
m <- as.matrix(DF)
DF <- data.frame(a = 1:3, m=I(m))
cn <- gsub(" ", "", colnames(summary(DF)), useBytes = TRUE)
stopifnot(identical(cn, c("a", paste("m.", nm, sep="", collapse=""))))
##  Had NAs in < 2.12.0


## [[<- could create invalid objects,
## https://stat.ethz.ch/pipermail/r-devel/2010-August/058312.html
z0 <- z <- factor(c("Two","Two","Three"), levels=c("One","Two","Three"))
z[[2]] <- "One"
stopifnot(typeof(z) == "integer")
z[[2]] <- "Two"
stopifnot(identical(z, z0))
## failed < 2.12.0


## predict.loess with NAs
cars.lo <- loess(dist ~ speed, cars)
res <- predict(cars.lo, data.frame(speed = c(5, NA, 25)))
stopifnot(length(res) == 3L, is.na(res[2]))
res <- predict(cars.lo, data.frame(speed = c(5, NA, 25)), se = TRUE)
stopifnot(length(res$fit) == 3L, is.na(res$fit[2]),
          length(res$se.fit) == 3L, is.na(res$se.fit[2]))
cars.lo2 <- loess(dist ~ speed, cars, control = loess.control(surface = "direct"))
res <- predict(cars.lo2, data.frame(speed = c(5, NA, 25)))
stopifnot(length(res) == 3L, is.na(res[2]))
res <- predict(cars.lo2, data.frame(speed = c(5, NA, 25)), se = TRUE)
stopifnot(length(res$fit) == 3L, is.na(res$fit[2]),
          length(res$se.fit) == 3L, is.na(res$se.fit[2]))
## Used na.omit prior to 2.12.0


## student typo
try( ksmooth(cars$speed, cars$dists) )
## now error about y (== NULL);  segfaulted <= 2.11.1


## do.call()ing NextMethod and empty args:
try( do.call(function(x) NextMethod('foo'),list()) )
## segfaulted <= 2.11.1


## identical() returned FALSE on external ptr with
## identical addresses <= 2.11.1
## Example with getNativeSymbolInfo no longer relevant


## getNamespaceVersion() etc
stopifnot(getNamespaceVersion("stats") == getRversion())
## failed in R 2.11.x


## PR#14383
x <- rnorm(100)
z1 <- quantile(x, type = 6, probs = c(0, .5))
z2 <- quantile(x, type = 6, probs = c(.5, 0))
stopifnot(z1 == rev(z2))
## differed in 2.11.x


## backSpline() with decreasing knot locations
require(splines)
d1 <- c(616.1, 570.1, 523.7, 477.3, 431.3, 386.2, 342.4, 300.4, 260.4,
        222.7, 187.8, 155.7, 126.7, 100.8,  78.1,  58.6,  42.2,  28.7,
         18.1,  10.2)
r1 <- c(104.4, 110  , 115.5, 121,   126.6, 132.1, 137.7, 143.2, 148.8,
        154.3, 159.9, 165.4, 170.9, 176.5, 182,   187.6, 193.1, 198.7,
        204.2, 209.8)
sp1 <- interpSpline(r1,d1)# 'x' as function of 'y' (!)
psp1 <- predict(sp1)
bsp1 <- backSpline(sp1)
dy <- diff(predict(bsp1, .5 + 18:30)$y)
stopifnot(-.9 < dy, dy < -.35)
## failed in R <= 2.11.x: "bizarre jumps"
detach("package:splines")


## PR#14393
f <- factor(c(NA, 1, 2), levels = 1:3, labels = 1:3)
mf <- model.frame(~ f, na.action = na.pass, drop.unused.levels = TRUE)
stopifnot(identical(mf$f, f[,drop=TRUE]))
## failed to drop < 2.12.0


## problem with deparsing variable names of > 500 bytes in model.frame
## reported by Terry Therneau to R-devel, 2010-10-07
tname <- paste('var', 1:50, sep='')
tmat <- matrix(rnorm(500), ncol=50, dimnames=list(NULL, tname))
tdata <- data.frame(tmat)
temp1 <- paste( paste(tname, tname, sep='='), collapse=', ')
temp2 <- paste("~1 + cbind(", temp1, ")")
foo <- model.frame(as.formula(temp2), tdata)
## gave invalid variable name.


## subassignment to expressions sometimes coerced them to lists.
x1 <- x2 <- x3 <- expression(a = pi, b = pi^2)
x1["b"] <- expression(pi^3)
stopifnot(is.expression(x1)) # OK
x1["a"] <- NULL
stopifnot(is.expression(x1))
x2[["b"]] <- quote(pi^3)
stopifnot(is.expression(x2)) # OK
x2[["a"]] <- NULL
stopifnot(is.expression(x2))
x3$a <- NULL
stopifnot(is.expression(x3))
## coerced to lists


## predict on an lm object with type = "terms" and 'terms' specified
dat <- data.frame(y=log(1:10), x=1:10, fac=rep(LETTERS[11:13],c(3,3,4)))
fit <- lm(y~fac*x, data=dat)
pfit <- predict(fit, type="terms", interval="confidence", newdata=dat[7:5,])
pfit2 <- predict(fit, type="terms", terms=c("x","fac"),
                 interval="confidence", newdata=dat[7:5,])
pfit2Expected <- lapply(pfit,
                        function(x)if(is.matrix(x))
                        structure(x[, c("x","fac")], constant=attr(x, "constant"))
                        else x)
stopifnot(identical(pfit2, pfit2Expected))
## pfit2 failed, and without 'interval' gave se's for all terms.


## TRE called assert() on an invalid regexp (PR#14398)
try(regexpr("a{2-}", ""))
## terminated R <= 2.12.0


## ! on zero-length objects (PR#14244)
M <- matrix(FALSE, 0, 2)
stopifnot(identical(attributes(!M), attributes(M)))
# and for back compatibiility
!list() # logical(0)
## dropped all attributes in 2.12.0


## Preserve intercepts in drop.terms
tt <- terms(~ a + b - 1)
tt2 <- terms(~ b - 1)
stopifnot(identical(drop.terms(tt, 1), tt2))
stopifnot(identical(tt[2], tt2))
stopifnot(identical(tt[1:2], tt))
## reset intercept term < R 2.13.0


## Test new defn of cmdscale()
mds <- cmdscale(eurodist, eig = TRUE, k = 14)
stopifnot(ncol(mds$points) < 14L) # usually 11.
## Used negative eigenvalues in 2.12.0


## Sweave regression test moved to utils/tests.


## mapply() & sapply() should not simplify e.g. for "call":
f2 <- function(i,j) call(':',i,j)
stopifnot(identical(2:3,
		    dim(sapply(1:3, function(i) list(0, 1:i)))),
	  length(r <- mapply(1:2, c(3,7), FUN= f2)) == 2,
	  length(s <- sapply(1:3, f2, j=7)) == 3)
## length wrongly were 6 and 9, in R <= 2.12.0


## 'sep' in reshape() (PR#14335)
test <- data.frame(x = rnorm(100), y = rnorm(100), famid = rep(1:50, each=2),
                   time = rep(1:2, 50))

wide <- reshape(data = test, v.names = c("x", "y"), idvar = "famid",
                timevar = "time", sep = "", direction = "wide")
stopifnot(identical(names(wide), c("famid", "x1", "y1", "x2", "y2")))
## was c("famid", "x.1", "y.1", "x.2", "y.2") in R <= 2.12.0


## PR#14438
X <- matrix(0+1:10, ncol = 2)[, c(1,1,2,2)]
colnames(X) <- c("X1","Dup1", "X2", "Dup2")
X2 <- qr.X(qr(X))
X2
identical(colnames(X), colnames(X2))
## failed to pivot colnames in R <= 2.12.0


## improvements to aggregate.data.frame in 2.13.0
a <- data.frame(nm = c("a", "b", "a", "b"), time = rep(Sys.time(), 4))
b <- with(a, aggregate(time, list(nm=nm), max))
stopifnot(inherits(b$x, "POSIXt"))
##


## pretty(<only non-finite>)  PR#14468
stopifnot(length(pretty(-2:1 / 0)) == 0)
## gave an error in R <= 2.12.1


## revised behaviour of as.POSIXlt in R 2.13.0
x <- c("2001-02-03", "2001-02-03 04:05")
stopifnot(identical(as.POSIXlt(x), rev(as.POSIXlt(rev(x)))))
## used different formats earlier


## seq.Date could overshoot
x <- seq(as.Date("2011-01-07"), as.Date("2011-03-01"), by = "month")
stopifnot(length(x) == 2)
x <- seq(as.POSIXct("2011-01-07"), as.POSIXct("2011-03-01"), by = "month")
stopifnot(length(x) == 2)
## was 3 in R < 2.13.0


## mostattributes<- now sometimes works for data frames (PR#14469)
x <- women
mostattributes(x) <- attributes(women) # did not set names in R < 2.13.0
## but there are still problems with row.names (see the help)


## naresid.exclude when all cases have been omitted
## (reported by Simon Wood to R-help, 2011-01-14)
x <- NA_real_
na.act <- na.action(na.exclude(x))
z <- naresid(na.act, rep(0, 0))
stopifnot(identical(z, x))
## gave length-0 result


## weighted.residuals did not work correctly with mlm fits
## see https://stat.ethz.ch/pipermail/r-devel/2011-January/059642.html
d4 <- data.frame(y1=1:4, y2=2^(0:3), wt=log(1:4), fac=LETTERS[c(1,1,2,2)])
fit <- lm(data=d4, cbind(y1,y2)~fac, weights=wt)
wtr <- weighted.residuals(fit)
stopifnot(identical(dim(wtr), 3:2))
## dropped dims in 2.12.1


## ccf did not work with na.action=na.pass
## https://stat.ethz.ch/pipermail/r-help/2011-January/265992.html
z <- matrix(rnorm(50),,2); z[6,] <- NA; z <- ts(z)
acf(z, na.action=na.pass, plot = FALSE)
ccf(z[,1], z[,2], na.action=na.pass, plot=FALSE)
## failed in 2.12.1


## tests of append mode on compressed connections.
tf <- tempfile(); con <- gzfile(tf, "w")
writeLines(as.character(1:50), con)
close(con); con <- gzfile(tf, "a")
writeLines(as.character(51:70), con)
close(con)
stopifnot(length(readLines(tf)) == 70)
unlink(tf)

con <- bzfile(tf, "w")
writeLines(as.character(1:50), con)
close(con); con <- bzfile(tf, "a")
writeLines(as.character(51:70), con)
close(con)
stopifnot(length(readLines(tf)) == 70)
unlink(tf)

con <- xzfile(tf, "w")
writeLines(as.character(1:50), con)
close(con); con <- xzfile(tf, "a")
writeLines(as.character(51:70), con)
close(con)
stopifnot(length(readLines(tf)) == 70)
unlink(tf)
## bzfile warned and did not work R < 2.13.0


## NA_complex_ in prettyNum()
format(c(pi+0i, NA),   drop0 = TRUE)
prettyNum(NA_complex_, drop0 = TRUE)
## gave errors in R < 2.12.2


## Map() needed to call match.fun() itself (PR#14495)
local({a <- sum; Map("a", list(1:5))})
## failed R < 2.13.0


## correct format() / rounding, print()ing -- (PR#14491)
stopifnot(format.info(7.921,     digits=2) == c(3,1,0),
          format.info(5.9994001, digits=4) == c(5,3,0))
## gave (1, 0, 0) in all R versions < 2.13.0
stopifnot(identical(format(0.2204, digits=3), "0.22"))
## gave "0.220" previously


## regression test for PR#14517
try(unzip('non-existing_file.zip', list=TRUE, unzip="internal"))
## crashed on some platforms in pre-2.13.0


## plot.formula(*, data=<matrix>) etc
A <- data.matrix(anscombe)
plot  (y1 ~ x1, data = A, main = "Anscombe's first two sets")
points(y2 ~ x2, data = A, col=2, pch=2)
lines (y2 ~ x2, data = A, lwd=2, col="gray")
## using a matrix failed in R < 2.13.0  *when* there was an extra argument


## PR#14530
dfA <- data.frame(A=1:2, B=3:4, row.names=letters[1:2])
dfB <- dfA[2:1,]
res <- try(data.frame(dfA, dfA[2:1,], check.rows=TRUE))
stopifnot(inherits(res, "try-error"))
## 'worked' in 2.12.2.


## uniroot(f,..) when f(.) == -Inf :
## now play with different  g(.)'s ..
g <- function(x) exp( 5*sign(x)*abs(x)^2.1 )
if(FALSE) { ## if you want to see how it *did* go wrong:
    ff1 <- function(x) {r <- log(g(x)); print(c(x,r)); r}
    str(ur <- uniroot(ff1, c(-90,100)))
}
assertWarning(uniroot(function(x) log(g(x)), c(-90,100)))
str(ur <- uniroot(function(x) log(g(x)), c(-90,100)))# -> 2 warnings .. -Inf replaced ..
stopifnot(abs(ur$root) < 0.001)
## failed badly in R < 2.13.0, as -Inf was replaced by +1e308


## as.matrix.dist
x <- matrix(,0,0)
d <- dist(x)
as.matrix(d)
## Threw an error < 2.13.0


## smooth.spline with data with a very small range.  (PR#14552)
dt <- seq(as.POSIXct("2011-01-01"), as.POSIXct("2011-01-01 10:00:00"), by="min")
x <- as.double(dt)
y <- sin(seq_along(x) * 3 * pi/180)
s <- smooth.spline(x, y)
stopifnot(length(s$x) == length(x))
## Chose 5 distinct values of x in 2.13.0


## readBin on a raw connection
rawcon <- rawConnection(as.raw(101:110))
res <- readBin(rawcon, what="integer", size=1, n=4)
close(rawcon)
stopifnot(identical(res, 101:104))
## read the same value repeatedly in 2.13.0


## Types of closure bodies
fun <- eval(substitute(function() x, list(x = environment())))
body(fun)
# an external pointer
y <- file(""); z <- attr(y, "conn_id"); close(y)
fun <- eval(substitute(function() x, list(x = z)))
body(fun)
## not allowed in R < 2.14.0.


## Corner cases for signif() and round()
x <- pi^(-6:6)
stopifnot(identical(signif(x, -Inf), signif(x, 1L))) # zero in R < 2.14.0
stopifnot(identical(round(x, -Inf), rep(0, length(x)))) # NAs in R < 2.14.0
##


## (un)stack with character columns
DF <- data.frame(a = letters[1:3], b = letters[4:6], stringsAsFactors = FALSE)
DF2 <- stack(DF)
stopifnot(class(DF2$values) == "character") # was factor
DF3 <- unstack(DF2) # contained factors
stopifnot(all(sapply(DF3, class) == "character"))
DF4 <- stack(DF[1])
stopifnot(identical(unstack(DF4), DF[1])) # was a list
## issues in R < 2.14.0


## PR#14710 (an instance of PR#8528)
stopifnot(!is.na(qchisq(p=0.025, df=0.00991)))
## NaN in 2.13.2


## nobs() for zero-weight glm fits:
DF <- data.frame(x1=log(1:10), x2=c(1/(1:9), NA), y=1:10,
                 wt=c(0,2,0,4,0,6,7,8,9,10))
stopifnot(nobs(lm(y ~ x1 + x2, weights = wt, data=DF)) ==
          nobs(glm(y ~ x1 + x2, weights = wt, data = DF)))
## was 6 and 9 in R < 2.14.1.


## anyDuplicated(*, MARGIN=0)
m. <- m <- cbind(M = c(3,2,7,2),
                 F = c(6,2,7,2))
rownames(m.) <- LETTERS[1:4]; m.
stopifnot(identical(attributes(dm <- duplicated(m., MARGIN=0)),
		    attributes(m.)),
	  (dvm <- duplicated(as.vector(m.))) == dm, # all TRUE
	  identical(anyDuplicated(	    m.,	 MARGIN=0),
		    anyDuplicated(as.vector(m.), MARGIN=0)))
## gave error in R < 2.14.1


## PR#14739
stopifnot(!is.nan(pbinom(10, 1e6, 0.01, log.p=TRUE)))
## was NaN thanks to Maechler's misuse of toms708 in 2.11.0.


## PR14742
stopifnot(identical(duplicated(data.frame(c(1, 1)), fromLast = TRUE),
                    duplicated(c(1, 1), fromLast = TRUE)))
## first ignored fromLast in 2.14.0.

## str(*, list.len, strict.width=.):
dm <- as.data.frame(matrix( rnorm(10000), nrow=50, ncol=200))
calls <- list(quote( str(dm, list.len= 7)),
	      quote( str(dm, list.len= 7, digits=10, width=88, strict.width='no')),
	      quote( str(dm, list.len= 7, digits=10, width=88, strict.width='cut')))
ee <- lapply(calls, function(cl) capture.output(eval(cl)))
stopifnot(sapply(ee, length) == 1 + 7 + 1)
## with 'list.len' was not used with 'strict.width="cut"' in  R <= 2.14.1

## Tests of serialization (new internal code in 2.15.0)
input <- pi^(1:10)
stopifnot(identical(input, unserialize(serialize(input, NULL))))
stopifnot(identical(input, unserialize(serialize(input, NULL, xdr = FALSE))))
z <- pi+ 3*1i
input <- z^(1:10)
stopifnot(identical(input, unserialize(serialize(input, NULL))))
stopifnot(identical(input, unserialize(serialize(input, NULL, xdr = FALSE))))
input <- matrix(1:1000000, 1000, 1000)
stopifnot(identical(input, unserialize(serialize(input, NULL))))
stopifnot(identical(input, unserialize(serialize(input, NULL, xdr = FALSE))))
z <- paste(readLines(file.path(R.home("doc"), "COPYING")), collapse="\n")
input <- charToRaw(z)
stopifnot(identical(input, unserialize(serialize(input, NULL))))
serialize(input, con <- file("serial", "wb")); close(con)
res <- unserialize(con <- file("serial", "rb")); close(con)
stopifnot(identical(input, res))
unlink("serial")
## Just a test for possible regressions.


## mis-PROTECT()ion in printarray C code:
df <- data.frame(a=1:2080, b=1001:2040, c=letters, d=LETTERS, e=1:1040)
stopifnot(length(df.ch <- capture.output(df)) == 1+nrow(df))
## "cannot allocate memory block of size 17179869183.6 Gb" in R <= 2.14.1


## logic in one of the many combinations of predict.lm() computations
fit <- lm(mpg ~ disp+hp, data=mtcars)
r <- predict(fit, type="terms", terms = 2, se.fit=TRUE)
stopifnot(dim(r$se.fit) == c(nrow(mtcars), 1))
## failed in  R <= 2.14.1


## format.POSIXlt(x) for wrong x
d0 <- strptime(as.Date(logical(0)), format="%Y-%m-%d", tz = "GMT")
d0$mday <- 1
try(format(d0))
## crashed (Arithmetic exception) for  R <= 2.14.1


## options("max.print") :
tools::assertCondition(options(max.print = Inf), "warning") # and then error
assertError(options(max.print = -2))
tools::assertCondition(options(max.print = 1e100), "warning")
## gave only warnings (every print() time, ...)  in R <= 2.14.2


## attributes with units<-  (PR#14839)
tt <- structure(500, units = "secs", class = "difftime", names = "a")
tt
units(tt) <- "mins"
tt
stopifnot(identical(names(tt), "a"))
## R < 2.15.0 changed the name, but then it was not documented to be kept.


## predict( VAR(p >= 2) )
set.seed(42)
u <- matrix(rnorm(200), 100, 2)
y <- filter(u, filter=0.8, "recursive")
est <- ar(y, aic = FALSE, order.max = 2) ## Estimate VAR(2)
xpred <- predict(object = est, n.ahead = 100, se.fit = FALSE)
stopifnot(dim(xpred) == c(100, 2), abs(range(xpred)) < 1)
## values went to +- 1e23 in R <= 2.14.2


## regression tests for merge
d1 <- data.frame(a = 1:10, b = 1:10, b.x = 10:1)
d2 <- data.frame(a = 1:10, b = 101:110)
op <- options(warn = 2)
z <- try(merge(d1, d2, by = 'a'))
stopifnot(inherits(z, "try-error"))
merge(d1, d2, by = 'a', suffixes = c("", ".y"))
z <- try(merge(d1, d2, by = 'a', suffixes = c(".z", ".z")))
stopifnot(inherits(z, "try-error"))
options(op)
# First 'worked' in R < 2.15.0, second was disallowed in early 2012,
# third 'worked' in R < 2.15.1.
# example based on package SDMTools::compare.matrix
# where 'by' is ambiguous.
x <- expand.grid(x = 1:2, y = 1:2)
y <- data.frame(x = c(1,2,1,2), y = c(1,1,2,2), z = c(5040,128,1123,3709))
merge(x, y, all = TRUE)
names(y)[3] <- "x"
stopifnot(inherits(try(merge(x, y, all = TRUE)), "try-error"))
## 'worked' in R < 2.15.1.


## misuse of seq() by package 'plotrix'
stopifnot(inherits(try(seq(1:50, by = 5)), "try-error"))
## gave 1:50 in R < 2.15.1, with warnings from seq().


## regression test for PR#14850 (misuse of dim<-)
b <- a <- matrix(1:2, ncol = 2)
`dim<-`(b, c(2, 1))
stopifnot(ncol(a) == 2)
## did not duplicate.


## deparsing needs escape characters in names (PR#14846)
f <- function(x) switch(x,"\\dbc"=2,3)
parse(text=deparse(f))
## Gave error about unrecognized escape


## hclust()'s original algo was not ok for "median" (nor "centroid") -- PR#4195
n <- 12; p <- 3
set.seed(46)
d <- dist(matrix(round(rnorm(n*p), digits = 2), n,p), "manhattan")
d[] <- d[] * sample(1 + (-4:4)/100, length(d), replace=TRUE)
hc <- hclust(d, method = "median")
stopifnot(all.equal(hc$height[5:11],
		    c(1.70595, 1.657675, 1.8909, 1.619973438, 
                      1.548624609, 3.097474902, 6.097159351),
                    tolerance = 1e-9))
## Also ensure that hclust() remains fast:
set.seed(1); nn <- 2000
tm0 <- system.time(dst <- as.dist(matrix(runif(n = nn^2, min = 0, max = 1)^1.1, nn, nn)))
(tm <- system.time(hc <- hclust(dst, method="average")))
stopifnot(tm[1] <= tm0[1])
## was slow  from R 1.9.0 up to R 2.15.0


## 'infinity' partially matched 'inf'
stopifnot(as.numeric("infinity") == Inf)
## was NA in R < 2.15.1


## by() failed for a 0-row data frame
b <- data.frame(ppg.id=1, predvol=2)
a <- b[b$ppg.id == 2, ]
by(a, a["ppg.id"], function(x){
    vol.sum = numeric()
    id = integer();
    if(dim(x)[1] > 0) {id = x$ppg.id[1]; vol.sum = sum(x$predvol)}
    data.frame(ppg.id=id, predVolSum=vol.sum)
})
## failed in 2.15.0


## model.frame.lm could be fooled if factor levels were re-ordered
A <- warpbreaks
fm1 <- lm(breaks ~ wool*tension, data = A, model = TRUE)
fm2 <- lm(breaks ~ wool*tension, data = A, model = FALSE)
A$tension <- factor(warpbreaks$tension, levels = c("H", "M", "L"))
stopifnot(identical(model.frame(fm1), model.frame(fm2)))
stopifnot(identical(model.frame(fm1), model.frame(fm1, data = A)))
stopifnot(identical(model.matrix(fm1), model.matrix(fm2)))
## not true before 2.15.2


## model.frame.lm did not make use of predvars
library(splines)
fm <- lm(weight ~ ns(height, 3), data = women)
m1 <- model.frame(fm)[1:3, ]
m2 <- model.frame(fm, data = women[1:3, ])
# attributes will differ
stopifnot(identical(as.vector(m1[,2]), as.vector(m2[,2])))
## differed in R < 2.15.2


## JMC's version of class<- did not work as documented. (PR#14942)
x <- 1:10
class(x) <- character()
class(x) <- "foo"
class(x) <- character()
oldClass(x) <- "foo"
oldClass(x) <- character()
## class<- version failed: required NULL


## anova.lmlist could fail (PR#14960)
set.seed(1)
y <- rnorm(20)
x <- rnorm(20)
f <- factor(rep(letters[1:2], each = 10))
model1 <- lm(y ~ x)
model2 <- lm(y ~ x + f)
anova(model1, model2, test = "F")
##


## regression test for sunflowerplot's formula method
sunflowerplot( Sepal.Length ~ Sepal.Width, data = iris, xlab = "A")
## failed in 2.15.1


## misuse of alloca
for(n in c(200, 722, 1000)) x <- rWishart(1, n, diag(n))
## failed in various ways in R <= 2.15.1


## undocumented used of rep(NULL), from matplot()
stopifnot(identical(rep(NULL, length.out = 4), NULL))
## now gives a warning.


## PR14974
a.factor <- as.factor(rep(letters[1:2], 2))
b.factor <- as.factor(rep(c(1:2), each = 2))
y <- cbind(aa = as.character(a.factor), bb = b.factor)
data1 <- data.frame(a.factor, b.factor, y = NA)
data1$y <- y # inserts a matric
data1 <- subset(data1, !((a.factor == "b") & (b.factor == 2))) # Delete row
factorial.data <- data.frame(a.factor, b.factor, row = 1:length(b.factor))
ans <- merge(factorial.data, data1, by = c("a.factor", "b.factor"),
             all.x = TRUE)
stopifnot(is.na(ans[["y"]][4,]))
## only set the first column of ans[["y"]] to NA.


## PR14967
stopifnot(qgeom(1e-20, prob = 0.1) >= 0)
## was -1 in R 2.15.1


## Regression test for r60116:7
(p1 <- parse(text="exp(-0.5*u**2)", srcfile=NULL))
(p2 <- parse(text="exp(-0.5*u^2)",  srcfile=NULL))
stopifnot(identical(p1, p2))
## p1 was expression(exp((-0.5 * u)^2))


## backsolve with k < nrows(rhs)
r <- rbind(c(1,2,3),c(0,1,1),c(0,0,2))
b <- c(8,4,2,1)
x <- backsolve(r, cbind(b,b))
stopifnot(identical(x[,1], x[,2]))
## 2.15.1 used elements (4,1), (2,1), (2,2) for second column.


## Matrix oddly assumes that solve() drops NULL dimanmes
A <- diag(3)
dimnames(A) <- list(NULL, NULL)
sA <- solve(A)
stopifnot(is.null(dimnames(sA)))
# and expm inverts a logical matrix, even though this is not as documented.
Q <- matrix(c(FALSE, TRUE, TRUE, FALSE), 2, 2)
is.numeric(Q) # FALSE
solve(Q)
## failed in R-devel, which interpreted 'numeric' correctly.


## tests of rowsum() with names and for factor groups
set.seed(123)
x <- matrix(runif(100), ncol=5)
group <- sample(1:8, 20, TRUE)
(xsum <- rowsum(x, group))
colnames(x) <- letters[16:20]
(xsum <- rowsum(x, group))
rowsum(as.data.frame(x), group)
group <- factor(group)
(xsum <- rowsum(x, group))
stopifnot(sapply(dimnames(xsum), is.character))
rowsum(as.data.frame(x), group)
## one version had factor row names.


## Rather pointless usage in PR#15044
set.seed(42)
n <- 10
y <- rnorm(n)
x <- rnorm(n)
w <- rep(0, n)
lm.wfit(cbind(1, x), y, w)
## segfaulted in 2.15.1, only


## as.data.frame() methods should preferably not barf on an 'nm' arg
## reported by Bill Dunlap
## (https://stat.ethz.ch/pipermail/r-devel/2012-September/064848.html)
as.data.frame(1:10, nm = "OneToTen")
as.data.frame(LETTERS[1:10], nm = "FirstTenLetters")
as.data.frame(LETTERS[1:10])
## second failed in 2.15.1.


## Test of stack direction (related to PR#15011)
f <- function(depth) if(depth < 20) f(depth+1) else Cstack_info()
(z <- f(0))
z10 <- f(10)
if(is.na(z[2]) || is.na(z10[2])) {
    message("current stack size is not available")
} else stopifnot(z[2] > z10[2])
## Previous test ould be defeated by compiler optimization.


##
options(max.print = .Machine$integer.max)
1 ## segfaulted because of integer overflow
stopifnot(identical(.Machine$integer.max, getOption("max.print")))
##


## corner cases for arima.sim(), in part PR#15068
stopifnot(length(arima.sim(list(order = c(0,0,0)), n = 10)) == 10)
stopifnot(inherits(try(arima.sim(list(order = c(1,0,0), ar = 0.7), n = 0)),
                   "try-error"))
## one too long in R < 2.15.2


## maintainer()
maintainer('stats')
maintainer("impossible_package_name")
## gave an error in R < 2.15.2


## PR#15075 and more
stopifnot(is.finite(c(beta(0.01, 171), beta(171, 0.01), beta(1e-200, 1e-200))))
## each overflowed to +Inf during calculations in R <= 2.15.2


## PR#15077
default <- 1; z <- eval(bquote(function(y = .(default)) y))
zz <- function(y = 1) y
stopifnot(identical(args(z), args(zz))) # zz has attributes
## was not substituted in R <= 2.15.2


## PR#15098
x <- list()
x[1:2] <- list(1)
x[[1]][] <- 2  # change part of first component of x
x   # second component of x should not be affected
stopifnot(identical(x[[2]], 1))# was 2
##
## 2nd example from Comment #5
x <- list()
list(1) -> x[1] -> x[2]
x[[1]][] <- 2
stopifnot(x[[2]] == 1)## was 2, wrongly, as well ..
##
## 3rd example from Comment #5
y <- list(1)
x <- list()
x[1] <- y
x[[1]][] <- 2
stopifnot(y[[1]] == 1)## was 2
## "NAMED": all three were wrong in    2.4.0 <= R <= 2.15.2


## PR#15115
a <- as.name("abc")
f <- call("==", a, 1L)
for (i in 2:5)
   f <- call("+", f, call("==", a, i))
abc <- 2
stopifnot(eval(f) == 1)
## Was 0 in 2.15.2 because the i was not duplicated


## Complex subassignment  return value
## From: Justin Talbot to R-devel, 8 Jan 2013
a <- list( 1 ); b <- (a[[1]] <- a); stopifnot(identical(b, list( 1 )))
a <- list(x=1); b <- ( a$x  <-  a); stopifnot(identical(b, list(x=1)))
## both failed in 2.15.2


## TukeyHSD with na.omit = na.exclude, see
## https://stat.ethz.ch/pipermail/r-help/2012-October/327119.html
br <- warpbreaks
br[br$tension == "M", "breaks"] <- NA
fit1 <- aov(breaks ~ wool + tension, data = br)
TukeyHSD(fit1, "tension", ordered = TRUE)
fit2 <- aov(breaks ~ wool + tension, data = br, na.action = na.exclude)
(z <- TukeyHSD(fit2, "tension", ordered = TRUE))
stopifnot(!is.na(z$tension))
## results were NA in R <= 2.15.2


## recursive listing of directories
p <- file.path(R.home("share"),"texmf") # always exists, readable
lfri <- list.files(p, recursive=TRUE, include.dirs=TRUE)
subdirs <- c("bibtex", "tex")
lfnd <- setdiff(list.files(p, all.files=TRUE, no..=TRUE), c(".svn", ".DS_Store"))
stopifnot(!is.na(match(subdirs, lfri)), identical(subdirs, lfnd))
## the first failed for a few days, unnoticed, in the development version of R


## [sd]Quote on 0-length inputs.
x <- character(0)
stopifnot(identical(sQuote(x), x), identical(dQuote(x), x))
## was length one in 2.15.2

## aperm(a, <char>)  when a has named dimnames:
a <- matrix(1:6, 2, dimnames=list(A=NULL, B=NULL))
stopifnot(identical(unname(aperm(a, c("B","A"))),
		    matrix(1:6, 3, byrow=TRUE)))# worked
assertError(aperm(a, c("C","A")))# fine, but
## forgetting one had been detrimental:
assertError( aperm(a, "A"))
## seg.faulted in 2.15.2 and earlier

## enc2utf8 failed on NA in non-UTF-8 locales PR#15201
stopifnot(identical(NA_character_, enc2utf8(NA_character_)))
## gave "NA" instead of NA_character_

## End of regression tests for R < 3.0.0
## -------------------------------------

proc.time()