## regression test for PR#376
aggregate(ts(1:20), nfreq=1/3)
## Comments: moved from aggregate.Rd


## aperm
# check the names
x <- array(1:24, c(4, 6))
nms <- list(happy=letters[1:4], sad=LETTERS[1:6])

dimnames(x) <- nms
tmp <- aperm(x, c(2, 1))
stopifnot(all.equal(dimnames(tmp), nms[c(2, 1)]))

dimnames(x) <- c(nms[1], list(NULL))
tmp <- aperm(x, c(2, 1))
stopifnot(all.equal(dimnames(tmp), c(list(NULL), nms[1])))

names(nms) <- c("happy", "sad")
dimnames(x) <- nms
tmp <- aperm(x, c(2, 1))
stopifnot(all.equal(names(dimnames(tmp)), names(nms[c(2, 1)])))

dimnames(x) <- c(nms[1], list(NULL))
tmp <- aperm(x, c(2, 1))
stopifnot(all.equal(names(dimnames(tmp)), c("", names(nms)[1])))

# check resize
stopifnot(dim(aperm(x, c(2, 1), FALSE)) == dim(x))
stopifnot(is.null(dimnames(aperm(x, c(2, 1), FALSE))))

# check the types
x <- array(1:24, c(4, 6))
stopifnot(all.equal(aperm(x, c(2, 1)), t(x)))
stopifnot(is.integer(aperm(x, c(2, 1))))

x <- x + 0.0
stopifnot(all.equal(aperm(x, c(2, 1)), t(x)))
stopifnot(is.double(aperm(x, c(2, 1))))

x <- x + 0.0i
stopifnot(all.equal(aperm(x, c(2, 1)), t(x)))

x[] <- LETTERS[1:24]
stopifnot(all.equal(aperm(x, c(2, 1)), t(x)))

x <- array(list("fred"), c(4, 6))
x[[3, 4]] <- 1:10
stopifnot(all.equal(aperm(x, c(2, 1)), t(x)))
## end of moved from aperm.Rd


## append
stopifnot(append(1:5, 0:1, after=3) == append(1:3, c(0:1, 4:5)))
## end of moved from append.Rd


## as.POSIXlt
z <- Sys.time()
stopifnot(range(z) == z,
	  min(z) == z,
	  max(z) == z,
	  mean(z) == z)
## end of moved from as.POSIXlt.Rd


## autoload
stopifnot(ls("Autoloads") == ls(envir = .AutoloadEnv))
## end of moved from autoload.Rd


## backsolve
r <- rbind(c(1,2,3),
	   c(0,1,1),
	   c(0,0,2))
( y <- backsolve(r, x <- c(8,4,2)) ) # -1 3 1
r %*% y # == x = (8,4,2)
( y2 <- backsolve(r, x, transpose = TRUE)) # 8 -12 -5
stopifnot(all.equal(drop(t(r) %*% y2), x))
stopifnot(all.equal(y, backsolve(t(r), x, upper = FALSE, transpose = TRUE)))
stopifnot(all.equal(y2, backsolve(t(r), x, upper = FALSE, transpose = FALSE)))
## end of moved from backsolve.Rd


## basename
dirname(character(0))
## end of moved from basename.Rd


## Bessel
## Check the Scaling :
nus <- c(0:5,10,20)
x <- seq(0,40,len=801)[-1]
for(nu in nus)
   stopifnot(abs(1- besselK(x,nu)*exp( x) / besselK(x,nu,expo=TRUE)) < 2e-15)
for(nu in nus)
   stopifnot(abs(1- besselI(x,nu)*exp(-x) / besselI(x,nu,expo=TRUE)) < 1e-15)
## end of moved from Bessel.Rd


## c
ll <- list(A = 1, c="C")
stopifnot(identical(c(ll, d=1:3), c(ll, as.list(c(d=1:3)))))
## moved from c.Rd


## Cauchy
stopifnot(all.equal(dcauchy(-1:4), 1 / (pi*(1 + (-1:4)^2))))
## end of moved from Cauchy.Rd


## chol
( m <- matrix(c(5,1,1,3),2,2) )
( cm <- chol(m) )
stopifnot(abs(m	 -  t(cm) %*% cm) < 100* .Machine$double.eps)
( Lcm <- La.chol(m) )
stopifnot(abs(m - crossprod(Lcm))  < 100* .Machine$double.eps)

## check with pivoting
( m <- matrix(c(5,1,1,3),2,2) )
( cm <- chol(m, TRUE) )
stopifnot(abs(m	 -  t(cm) %*% cm) < 100* .Machine$double.eps)

x <- matrix(c(1:5, (1:5)^2), 5, 2)
m <- crossprod(x)
Q <- chol(m)
stopifnot(all.equal(t(Q) %*% Q, m))

Q <- chol(m, pivot = TRUE)
pivot <- attr(Q, "pivot")
oo <- order(pivot)
stopifnot(all.equal(t(Q[, oo]) %*% Q[, oo], m))
stopifnot(all.equal(t(Q) %*% Q, m[pivot, pivot]))

# now for something positive semi-definite
x <- cbind(x, x[, 1]+3*x[, 2])
m <- crossprod(x)
qr(m)$rank # is 2, as it should be

(Q <- chol(m, pivot = TRUE)) # NB wrong rank here ... see Warning section.
pivot <- attr(Q, "pivot")
oo <- order(pivot)
stopifnot(all.equal(t(Q[, oo]) %*% Q[, oo], m))
stopifnot(all.equal(t(Q) %*% Q, m[pivot, pivot]))
## end of moved from chol.Rd


## chol2inv
cma <- chol(ma	<- cbind(1, 1:3, c(1,3,7)))
stopifnot(all.equal(diag(3), ma %*% chol2inv(cma)))
stopifnot(all.equal(diag(3), ma %*% La.chol2inv(cma)))
## end of moved from chol2inv.Rd


## col2rgb
pp <- palette(); names(pp) <- pp # add & use names :
stopifnot(col2rgb(1:8) == print(col2rgb(pp)))
stopifnot(col2rgb("#08a0ff") == c(8, 160, 255))
grC <- col2rgb(paste("gray",0:100,sep=""))
stopifnot(grC["red",] == grC["green",],
	  grC["red",] == grC["blue",],
	  grC["red", 1:4] == c(0,3,5,8))
## end of moved from col2rgb.Rd


## complex
z <- 0i ^ (-3:3)
stopifnot(Re(z) == 0 ^ (-3:3))
set.seed(123)
z <- complex(real = rnorm(100), imag = rnorm(100))
stopifnot(Mod ( 1 -  sin(z) / ( (exp(1i*z)-exp(-1i*z))/(2*1i) ))
	  < 20 * .Machine$double.eps)
## end of moved from complex.Rd


## Constants
stopifnot(
 nchar(letters) == 1,
 month.abb == substr(month.name, 1, 3)
)

eps <- .Machine$double.eps
stopifnot(all.equal(pi, 4*atan(1), tol= 2*eps))

# John Machin (1705) computed 100 decimals of pi :
stopifnot(all.equal(pi/4, 4*atan(1/5) - atan(1/239), 4*eps))
## end of moved from Constants.Rd


## cor
stopifnot(  is.na(var(1)),
	  !is.nan(var(1)))

zz <- c(-1.30167, -0.4957, -1.46749, 0.46927)
r <- cor(zz,zz); r - 1
stopifnot(r <= 1) # fails in R <= 1.3.x, for versions of Linux and Solaris
## end of moved from cor.Rd


## DateTimeClasses
(dls <- .leap.seconds[-1] - .leap.seconds[-22])
table(dls)
## end of moved from DateTimeClasses.Rd


## deriv
trig.exp <- expression(sin(cos(x + y^2)))
D.sc <- D(trig.exp, "x")
dxy <- deriv(trig.exp, c("x", "y"))
y <- 1
stopifnot(eval(D.sc) ==
	  attr(eval(dxy),"gradient")[,"x"])
ff <- y ~ sin(cos(x) * y)
stopifnot(all.equal(deriv(ff, c("x","y"), func = TRUE ),
		    deriv(ff, c("x","y"), func = function(x,y){ } )))
## end of moved from deriv.Rd


## diff
x <- cumsum(cumsum(1:10))
stopifnot(diff(x, lag = 2) == x[(1+2):10] - x[1:(10 - 2)],
	  diff(x, lag = 2) == (3:10)^2,
	  diff(diff(x))	   == diff(x, differences = 2))
## end of moved from diff.Rd


## duplicated
x <- c(9:20, 1:5, 3:7, 0:8)
## extract unique elements
(xu <- x[!duplicated(x)])
stopifnot(xu == unique(x), # but unique(x) is more efficient
	  0:20 == sort(x[!duplicated(x)]))

data(iris)
stopifnot(duplicated(iris)[143] == TRUE)
## end of moved from duplicated.Rd


## eigen
Meps <- .Machine$double.eps
set.seed(321, kind = "default")	 # force a particular seed
m <- matrix(round(rnorm(25),3), 5,5)
sm <- m + t(m) #- symmetric matrix
em <- eigen(sm); V <- em$vect
print(lam <- em$values) # ordered DEcreasingly

stopifnot(
 abs(sm %*% V - V %*% diag(lam))	  < 60*Meps,
 abs(sm	      - V %*% diag(lam) %*% t(V)) < 60*Meps)

##------- Symmetric = FALSE:  -- different to above : ---

em <- eigen(sm, symmetric = FALSE); V2 <- em$vect
print(lam2 <- em$values) # ordered decreasingly in ABSolute value !
print(i <- rev(order(lam2)))
stopifnot(abs(lam - lam2[i]) < 60 * Meps)

zapsmall(Diag <- t(V2) %*% V2)
stopifnot( abs(1- diag(Diag)) < 60*Meps)

stopifnot(abs(sm %*% V2 - V2 %*% diag(lam2))		< 60*Meps,
	  abs(sm	 - V2 %*% diag(lam2) %*% t(V2)) < 60*Meps)

## Re-ordered as with symmetric:
sV <- V2[,i]
slam <- lam2[i]
stopifnot(abs(sm %*% sV -  sV %*% diag(slam))		  < 60*Meps)
stopifnot(abs(sm	-  sV %*% diag(slam) %*% t(sV)) < 60*Meps)
## sV  *is* now equal to V  -- up to sign (+-) and rounding errors
stopifnot(abs(c(1 - abs(sV / V)))	<     1000*Meps)
## end of moved from eigen.Rd


## euro
data(euro)
stopifnot(euro == signif(euro,6), euro.cross == outer(1/euro, euro))
## end of moved from euro.Rd


## Exponential
r <- rexp(100)
stopifnot(abs(1 - dexp(1, r) / (r*exp(-r))) < 1e-14)
## end of moved from Exponential.Rd


## family
gf <- Gamma()
stopifnot(1:10 == gf$linkfun(gf$linkinv(1:10)))
## end of moved from family.Rd


## fft
set.seed(123)
eps <- 1e-11
for(N in 1:130) {
    x <- rnorm(N)
    if(N %% 5 == 0) {
	m5 <- matrix(x,ncol=5)
	stopifnot(apply(m5,2,fft) == mvfft(m5))
    }
    dd <- Mod(1 - (f2 <- fft(fft(x), inverse=TRUE)/(x*length(x))))
    stopifnot(dd < eps)
}
## end of moved from fft.Rd


## findint
N <- 100
X <- sort(round(rt(N, df=2), 2))
tt <- c(-100, seq(-2,2, len=201), +100)
it <- findInterval(tt, X)

## See that this is N * Fn(.) :
tt <- c(tt,X)
eps <- 100 * .Machine$double.eps
require(stepfun)
stopifnot(it[c(1,203)] == c(0, 100),
	  all.equal(N * ecdf(X)(tt),
		    findInterval(tt, X),  tol = eps),
	  findInterval(tt,X) ==	 apply( outer(tt, X, ">="), 1, sum)
	  )
## end of moved from findint.Rd


## format
(dd <- sapply(1:10, function(i)paste((9:0)[1:i],collapse="")))
np <- nchar(pd <- prettyNum(dd, big.mark="'"))
stopifnot(sapply(0:2, function(m)
	   all(grep("'", substr(pd, 1, np - 4*m)) == (4+3*m):10)))
## end of moved from format.Rd


## Geometric
pp <- sort(c((1:9)/10, 1 - .2^(2:8)))
print(qg <- qgeom(pp, prob = .2))
## test that qgeom is an inverse of pgeom
print(qg1 <- qgeom(pgeom(qg, prob=.2), prob =.2))
stopifnot(identical(qg, qg1))
## moved from Geometric.Rd


## glm
## these are the same -- example from Jim Lindsey
y <- rnorm(20)
y1 <- y[-1]; y2 <- y[-20]
summary(g1 <- glm(y1 - y2 ~ 1))
summary(g2 <- glm(y1 ~ offset(y2)))
Eq <- function(x,y) all.equal(x,y, tol = 1e-12)
stopifnot(Eq(coef(g1), coef(g2)),
	  Eq(deviance(g1), deviance(g2)),
	  Eq(resid(g1), resid(g2)))
## from logLik.glm.Rd
"anorexia" <-
structure(list(Treat = structure(c(2, 2, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
1, 1, 1, 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3
), .Label = c("CBT", "Cont", "FT"), class = "factor"), Prewt = c(80.7,
89.4, 91.8, 74, 78.1, 88.3, 87.3, 75.1, 80.6, 78.4, 77.6, 88.7,
81.3, 78.1, 70.5, 77.3, 85.2, 86, 84.1, 79.7, 85.5, 84.4, 79.6,
77.5, 72.3, 89, 80.5, 84.9, 81.5, 82.6, 79.9, 88.7, 94.9, 76.3,
81, 80.5, 85, 89.2, 81.3, 76.5, 70, 80.4, 83.3, 83, 87.7, 84.2,
86.4, 76.5, 80.2, 87.8, 83.3, 79.7, 84.5, 80.8, 87.4, 83.8, 83.3,
86, 82.5, 86.7, 79.6, 76.9, 94.2, 73.4, 80.5, 81.6, 82.1, 77.6,
83.5, 89.9, 86, 87.3), Postwt = c(80.2, 80.1, 86.4, 86.3, 76.1,
78.1, 75.1, 86.7, 73.5, 84.6, 77.4, 79.5, 89.6, 81.4, 81.8, 77.3,
84.2, 75.4, 79.5, 73, 88.3, 84.7, 81.4, 81.2, 88.2, 78.8, 82.2,
85.6, 81.4, 81.9, 76.4, 103.6, 98.4, 93.4, 73.4, 82.1, 96.7,
95.3, 82.4, 72.5, 90.9, 71.3, 85.4, 81.6, 89.1, 83.9, 82.7, 75.7,
82.6, 100.4, 85.2, 83.6, 84.6, 96.2, 86.7, 95.2, 94.3, 91.5,
91.9, 100.3, 76.7, 76.8, 101.6, 94.9, 75.2, 77.8, 95.5, 90.7,
92.5, 93.8, 91.7, 98)), .Names = c("Treat", "Prewt", "Postwt"
), class = "data.frame", row.names = c("1", "2", "3", "4", "5",
"6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16",
"17", "18", "19", "20", "21", "22", "23", "24", "25", "26", "27",
"28", "29", "30", "31", "32", "33", "34", "35", "36", "37", "38",
"39", "40", "41", "42", "43", "44", "45", "46", "47", "48", "49",
"50", "51", "52", "53", "54", "55", "56", "57", "58", "59", "60",
"61", "62", "63", "64", "65", "66", "67", "68", "69", "70", "71",
"72"))
anorex.1 <- glm(Postwt ~ Prewt + Treat + offset(Prewt),
	    family = gaussian, data = anorexia)
summary(anorex.1)
Eq <- function(x,y) all.equal(x,y, tol = 1e-12)
stopifnot(Eq(AIC(anorex.1), anorex.1$aic),
	  Eq(AIC(g1), g1$aic),
	  Eq(AIC(g2), g2$aic))
## next was wrong in 1.4.1
x <- 1:10
lmx <- logLik(lm(x ~ 1)); glmx <- logLik(glm(x ~ 1))
stopifnot(all.equal(as.vector(lmx), as.vector(glmx)),
	  all.equal(attr(lmx, 'df'), attr(glmx, 'df')))
## end of moved from glm.Rd and logLik.glm.Rd


## Hyperbolic
Ceps <- .Machine$double.eps # ``Computer epsilon''
x <- seq(-3, 3, len=200)
stopifnot(
 abs(cosh(x) - (exp(x) + exp(-x))/2) < 20*Ceps,
 abs(sinh(x) - (exp(x) - exp(-x))/2) < 20*Ceps,
 Mod(cosh(x) - cos(1i*x))	< 20*Ceps,
 Mod(sinh(x) - sin(1i*x)/1i)	< 20*Ceps,
 abs(tanh(x)*cosh(x) - sinh(x)) < 20*Ceps
)

stopifnot(abs(asinh(sinh(x)) - x) < 20*Ceps)
stopifnot(abs(acosh(cosh(x)) - abs(x)) < 1000*Ceps) #- imprecise for small x
stopifnot(abs(atanh(tanh(x)) - x) < 100*Ceps)

stopifnot(abs(asinh(x) - log(x + sqrt(x^2 + 1))) < 100*Ceps)
cx <- cosh(x)
stopifnot(abs(acosh(cx) - log(cx + sqrt(cx^2 - 1))) < 1000*Ceps)
## end of moved from Hyperbolic.Rd


## image
## Degenerate, should still work
image(as.matrix(1))
image(matrix(pi,2,4))
x <- seq(0,1,len=100)
image(x, 1, matrix(x), col=heat.colors(10))
image(x, 1, matrix(x), col=heat.colors(10), oldstyle = TRUE)
image(x, 1, matrix(x), col=heat.colors(10), breaks = seq(0.1,1.1,len=11))
## end of moved from image.Rd


## integrate
(ii <- integrate(dnorm, -1.96, 1.96))
(i1 <- integrate(dnorm, -Inf, Inf))
stopifnot(all.equal(0.9500042097, ii$val, tol = ii$abs.err, scale=1),
	  all.equal( 1,		  i1$val, tol = i1$abs.err, scale=1))

integrand <- function(x) {1/((x+1)*sqrt(x))}
(ii <- integrate(integrand, lower = 0, upper = Inf, rel.tol = 1e-10))
stopifnot(all.equal(pi, ii$val, tol = ii$abs.err, scale=1))
## end of moved from integrate.Rd


## is.finite
( weird.values <- c(-20.9/0, 1/0, 0/0, NA) )

Mmax <- .Machine$double.xmax
Mmin <- .Machine$double.xmin
( X.val <- c(Mmin*c(2^(-10:3),1e5,1e10),
	     Mmax*c(1e-10,1e-5,2^(-3:0),1.001)) )
( tst.val <- sort(c(X.val, weird.values), na.last = TRUE) )
( x2 <- c(-1:1/0,pi,1,NA) )
( z2 <- c(x2, 1+1i, Inf -Inf* 1i) )

is.inf <-
  function(x) (is.numeric(x) || is.complex(x)) && !is.na(x) && !is.finite(x)

for(x in list(tst.val, x2, z2))
  print(cbind(format(x), is.infinite=format(is.infinite(x))), quote=FALSE)

rbind(is.nan(tst.val),
      is.na (tst.val))
tst.val [ is.nan(tst.val) !=  is.na(tst.val) ]

stopifnot(
    is.na(0/0),
    !is.na(Inf),
    is.nan(0/0),

    !is.nan(NA)	 &&  !is.infinite(NA)  && !is.finite(NA),
     is.nan(NaN) &&  !is.infinite(NaN) && !is.finite(NaN),
    !is.nan(c(1,NA)),
    c(FALSE,TRUE,FALSE) == is.nan(c   (1,NaN,NA)),
    c(FALSE,TRUE,FALSE) == is.nan(list(1,NaN,NA))#-> FALSE in older versions
)

stopifnot(identical(lgamma(Inf), Inf))
stopifnot(identical(Inf + Inf, Inf))
stopifnot(identical(Inf - Inf, NaN))
stopifnot(identical((1/0) * (1/0), Inf))
stopifnot(identical((1/0) / (1/0), NaN))
stopifnot(identical(exp(-Inf), 0))
stopifnot(identical(log(0), -Inf))
stopifnot(identical((-1)/0, -Inf))
pm <- c(-1,1) # 'pm' = plus/minus
stopifnot(atan(Inf*pm) == pm*pi/2)
## end of moved from is.finite.Rd


## kronecker
( M <- matrix(1:6, ncol=2) )
stopifnot(kronecker(4, M)==4 * M)
# Block diagonal matrix:
stopifnot(kronecker(diag(1, 3), M) == diag(1, 3) %x% M)
## end of moved from kronecker.Rd


## log
stopifnot(all.equal(log(1:10), log(1:10, exp(1))))
stopifnot(all.equal(log10(30), log(30, 10)))
stopifnot(all.equal(log2(2^pi), 2^log2(pi)))
stopifnot(Mod(pi - log(exp(pi*1i)) / 1i) < .Machine$double.eps)
stopifnot(Mod(1+exp(pi*1i)) < .Machine$double.eps)
## end of moved from Log.Rd


## logistic
eps <- 100 * .Machine$double.eps
x <- c(0:4, rlogis(100))
stopifnot(all.equal(plogis(x),	1 / (1 + exp(-x)), tol = eps))
stopifnot(all.equal(plogis(x, lower=FALSE),  exp(-x)/ (1 + exp(-x)), tol = eps))
stopifnot(all.equal(plogis(x, lower=FALSE, log=TRUE), -log(1 + exp(x)),
		    tol = eps))
stopifnot(all.equal(dlogis(x), exp(x) * (1 + exp(x))^-2, tol = eps))
## end of moved from Logistic.Rd


## Lognormal
x <- rlnorm(1000)	# not yet always :
stopifnot(abs(x	 -  qlnorm(plnorm(x))) < 1e4 * .Machine$double.eps * x)
## end of moved from Lognormal.Rd


## lower.tri
ma <- matrix(1:20, 4, 5)
stopifnot(lower.tri(ma) == !upper.tri(ma, diag=TRUE))
## end of moved from lower.tri.Rd


## make.names
stopifnot(make.names(letters) == letters)
## end of make.names


## mean
x <- c(0:10, 50)
stopifnot(all.equal(mean(x, trim = 0.5), median(x)))
## moved from mean.Rd


## Multinom
N <- 20
pr <- c(1,3,6,10) # normalization not necessary for generation
set.seed(153)
rr <- rmultinom(5000, N, prob = pr)
stopifnot(colSums(rr) == N)
(m <- rowMeans(rr))
all.equal(m, N * pr/sum(pr)) # rel.error ~0.003
stopifnot(max(abs(m/(N*pr/sum(pr)) - 1)) < 0.01)

(Pr <- dmultinom(c(0,0,3), prob = c(1, 1, 14)))
stopifnot(all.equal(Pr, dbinom(3, 3, p = 14/16)))

X <- t(as.matrix(expand.grid(0:3, 0:3)))
X <- X[, colSums(X) <= 3]
X <- rbind(X, 3:3 - colSums(X))
for(p in list(c(1,2,5), 1:3, 3:1, 2:0, 0:2, c(1,2,1), c(0,0,1))) {
  px <- apply(X, 2, function(x) dmultinom(x, prob = p))
  stopifnot(identical(TRUE, all.equal(sum(px), 1)))
}
## end of moved from Multinom.Rd


## plot.lm
# which=4 failed in R 1.0.1
par(mfrow=c(1,1), oma= rep(0,4))
data(longley)
summary(lm.fm2 <- lm(Employed ~ . - Population - GNP.deflator, data = longley))
for(wh in 1:4) plot(lm.fm2, which = wh)
## end of moved from plot.lm.Rd


## Poisson
dpois(c(0, 1, 0.17, 0.77), 1)
## end of moved from Poisson.Rd


## qr
## tests of complex case
set.seed(1)
A <- matrix(rnorm(25), 5, 5, dimnames=list(1:5, letters[1:5]))
qr.solve(A, 1:5)
A[] <- as.complex(A)
qr.coef(qr(A), 1:5)
qr.solve(A, 1:5)

## check for rank-deficient cases
X <- cbind(1:3, 1:3, 1)
stopifnot(all.equal(qr.X(qr(X)), X))
## end of moved from qr.Rd


## qraux
data(LifeCycleSavings)
p <- ncol(x <- LifeCycleSavings[,-1]) # not the `sr'
qrstr <- qr(x)	 # dim(x) == c(n,p)
Q <- qr.Q(qrstr) # dim(Q) == dim(x)
R <- qr.R(qrstr) # dim(R) == ncol(x)
X <- qr.X(qrstr) # X == x
stopifnot(all.equal(X,	as.matrix(x)))

## X == Q %*% R :
stopifnot((1 - X /( Q %*% R))< 100*.Machine$double.eps)

dim(Qc <- qr.Q(qrstr, complete=TRUE)) # Square: dim(Qc) == rep(nrow(x),2)
stopifnot((crossprod(Qc) - diag(nrow(x))) < 10*.Machine $double.eps)

QD <- qr.Q(qrstr, D=1:p)      # QD == Q \%*\% diag(1:p)
stopifnot(QD - Q %*% diag(1:p)	< 8* .Machine$double.eps)

dim(Rc <- qr.R(qrstr, complete=TRUE)) # == dim(x)
dim(Xc <- qr.X(qrstr, complete=TRUE)) # square: nrow(x) ^ 2
dimnames(X) <- NULL
stopifnot(all.equal(Xc[,1:p], X))
## end of moved from qraux.Rd


## quantile
x <- rnorm(1001)
n <- length(x) ## the following is exact, because 1/(1001-1) is exact:
stopifnot(sort(x) == quantile(x, probs = ((1:n)-1)/(n-1), names=FALSE))

n <- 777
ox <- sort(x <- round(rnorm(n),1))# round() produces ties
ox <- c(ox, ox[n]) #- such that ox[n+1] := ox[n]
p <- c(0,1,runif(100))
i <- floor(r <- 1 + (n-1)*p)
f <- r - i
stopifnot(abs(quantile(x,p) - ((1-f)*ox[i] + f*ox[i+1])) < 20*.Machine$double.eps)
## end of moved from quantile.Rd


## rep
stopifnot(identical(rep(letters, 0), character(0)),
	  identical(rep.int(1:2, 0), integer(0)))
## end of moved from rep.Rd


## Round
x1 <- seq(-2, 4, by = .5)
non.int <- ceiling(x1) != floor(x1)
stopifnot(
 trunc(x1) == as.integer(x1),
 non.int == (ceiling(x1) != trunc(x1) | trunc(x1) != floor(x1)),
 (signif(x1, 1) != round(x1,1)) == (non.int & abs(x1) > 1)
)
## end of moved from Round.Rd


## seq
stopifnot(
 3 == seq(3,3,	by=pi),
 3 == seq(3,3.1,by=pi),
 seq(1,6,by=3) == c(1,4),
 seq(10,4.05,by=-3) == c(10,7)
)
## end of moved from seq.Rd


## sort
data(swiss)
x <- swiss$Education[1:25]
stopifnot(!is.unsorted(sort(x)),
	  !is.unsorted(LETTERS),
	   is.unsorted(c(NA,1:3,2), na.rm = TRUE))

for(n in 1:20) {
    z <- rnorm(n)
    for(x in list(z, round(z,1))) { ## 2nd one has ties
       qxi <- sort(x,  method = "quick",  index.return = TRUE)
       stopifnot(qxi$x == sort(x, method = "shell"),
		 any(duplicated(x)) || qxi$ix == order(x),
		 x[qxi$ix] == qxi$x)
   }
}
## end of moved from sort.Rd


## substr
ss <- substring("abcdef",1:6,1:6)
stopifnot(ss == strsplit ("abcdef",NULL)[[1]])
x <- c("asfef", "qwerty", "yuiop[", "b", "stuff.blah.yech")
stopifnot(substr(x, 2, 5) == substring(x, 2, 5))
## end of moved from substr.Rd


## svd
hilbert <- function(n) { i <- 1:n; 1 / outer(i - 1, i, "+") }
str(X <- hilbert(9)[,1:6])
str(s <- svd(X))
Eps <- 100 * .Machine$double.eps

D <- diag(s$d)
stopifnot(abs(X - s$u %*% D %*% t(s$v)) < Eps)#	 X = U D V'
stopifnot(abs(D - t(s$u) %*% X %*% s$v) < Eps)#	 D = U' X V

X <- cbind(1, 1:7)
str(s <- svd(X)); D <- diag(s$d)
stopifnot(abs(X - s$u %*% D %*% t(s$v)) < Eps)#	 X = U D V'
stopifnot(abs(D - t(s$u) %*% X %*% s$v) < Eps)#	 D = U' X V
## end of moved from svd.Rd


## trace
hasMethods <- .isMethodsDispatchOn() ## trace requires methods
f <- function(x, y) { c(x,y)}
xy <- 0

trace(f, quote(x <- c(1, x)), exit = quote(xy <<- x), print = FALSE)

fxy <- f(2,3)

stopifnot(identical(fxy, c(1,2,3)))
stopifnot(identical(xy, c(1,2)))

untrace(f)

## a generic and its methods

setGeneric("f")

setMethod("f", c("character", "character"), function(x,	 y) paste(x,y))

## trace the generic
trace("f", quote(x <- c("A", x)), exit = quote(xy <<- c(x, "Z")), print = FALSE)

## should work for any method

stopifnot(identical(f(4,5), c("A",4,5)))
stopifnot(identical(xy, c("A", 4, "Z")))

stopifnot(identical(f("B", "C"), paste(c("A","B"), "C")))
stopifnot(identical(xy, c("A", "B", "Z")))

## trace a method

trace("f", sig = c("character", "character"), quote(x <- c(x, "D")),
      exit = quote(xy <<- xyy <<- c(x, "W")), print = FALSE)

stopifnot(identical(f("B", "C"), paste(c("A","B","D"), "C")))
# These two got broken by Luke's lexical scoping fix
#stopifnot(identical(xy, c("A", "B", "D", "W")))
#stopifnot(identical(xy, xyy))

## but the default method is unchanged

stopifnot(identical(f(4,5), c("A",4,5)))
stopifnot(identical(xy, c("A", 4, "Z")))

removeGeneric("f")

if(!hasMethods) detach("package:methods")
## end of moved from trace.Rd


## Trig
## many of these tested for machine accuracy, which seems a bit extreme
set.seed(123)
stopifnot(cos(0) == 1)
stopifnot(sin(3*pi/2) == cos(pi))
x <- rnorm(99)
stopifnot(all.equal( sin(-x), - sin(x)))
stopifnot(all.equal( cos(-x), cos(x)))
x <- abs(x); y <- abs(rnorm(x))
stopifnot(abs(atan2(y, x) - atan(y/x)) < 10 * .Machine$double.eps)
stopifnot(abs(atan2(y, x) - atan(y/x)) < 10 * .Machine$double.eps)

x <- 1:99/100
stopifnot(Mod(1 - (cos(x) + 1i*sin(x)) / exp(1i*x)) < 10 * .Machine$double.eps)
## error is about 650* are x=0.01
stopifnot(abs(1 - x / acos(cos(x))) < 1000 * .Machine$double.eps)
stopifnot(abs(1 - x / asin(sin(x))) <= 10 * .Machine$double.eps)
stopifnot(abs(1 - x / atan(tan(x))) <= 10 *.Machine$double.eps)
## end of moved from Trig.Rd

## Uniform
u <- runif(20)
stopifnot(punif(u) == u, dunif(u) == 1,
	  runif(100, 2,2) == 2)#-> TRUE [bug in R version <= 0.63.1]
## end of moved from Uniform.Rd


## unique
my.unique <- function(x) x[!duplicated(x)]
for(i in 1:4)
 { x <- rpois(100, pi); stopifnot(unique(x) == my.unique(x)) }

data(iris)
unique(iris)
stopifnot(dim(unique(iris)) == c(149, 5))
## end of moved from unique.Rd


## which.min
stopifnot(length(which.min(numeric(0))) == 0)
stopifnot(length(which.max( c(NA,NA) )) == 0)
## end of moved from which.min.Rd


## Wilcoxon
x <- -1:(4*6 + 1)
fx <- dwilcox(x, 4, 6)
stopifnot(fx == dwilcox(x, 6, 4))
Fx <- pwilcox(x, 4, 6)
stopifnot(abs(Fx - cumsum(fx)) < 10 * .Machine$double.eps)
## end of moved from Wilcoxon.Rd


## .Machine
(Meps <- .Machine$double.eps)
## All the following relations must hold :
stopifnot(
 1 +	 Meps != 1,
 1 + .5* Meps == 1,
 log2(.Machine$double.xmax) == .Machine$double.max.exp,
 log2(.Machine$double.xmin) == .Machine$double.min.exp
)
# This test fails on HP-UX since pow(2,1024) returns DBL_MAX and sets
# errno = ERANGE.  Most other systems return Inf and set errno
if (Sys.info()["sysname"] != "HP-UX")
    stopifnot(is.infinite(.Machine$double.base ^ .Machine$double.max.exp))
## end of moved from zMachine.Rd


## PR 640 (diff.default computes an incorrect starting time)
## By: Laimonis Kavalieris <lkavalieris@maths.otago.ac.nz>
y <- ts(rnorm(24), freq=12)
x <- ts(rnorm(24), freq=12)
arima0(y, xreg = x, seasonal = list(order=c(0,1,0)))
## Comments:


## PR 644 (crash using fisher.test on Windows)
## By: Uwe Ligges <ligges@statistik.uni-dortmund.de>
x <- matrix(c(2, 2, 4, 8, 6, 0, 1, 1, 7, 8, 1, 3, 1, 3, 7, 4, 2, 2, 2,
	      1, 1, 0, 0, 0, 0, 0, 1, 1, 2, 0, 1, 1, 0, 2, 1, 0, 0, 0),
	    nc = 2)
fisher.test(x)
## Comments: (wasn't just on Windows)

## PR 653 (extrapolation in spline)
## By: Ian White <imsw@holyrood.ed.ac.uk>
x <- c(2,5,8,10)
y <- c(1.2266,-1.7606,-0.5051,1.0390)
fn <- splinefun(x, y, method="natural")
xx1 <- fn(0:12)
# should be the same if reflected
fn <- splinefun(rev(-x),rev(y),method="natural")
xx2 <- fn(0:-12)
stopifnot(all.equal(xx1, xx2))
# should be the same as interpSpline
library(splines)
xx3 <- predict(interpSpline(x, y), 0:12)
stopifnot(all.equal(xx1, xx3$y))
detach("package:splines")
## Comments: all three differed in 1.2.1.


## PR 698 (print problem with data frames)
## actually, a subsetting problem with data frames
fred <- data.frame(happy=c(TRUE, FALSE, TRUE), sad=7:9)
z <- try(tmp <- fred[c(FALSE, FALSE, TRUE, TRUE)])
stopifnot(class(z) == "try-error")
## Comments: No error before 1.2.1


## PR 753 (step can't find variables)
##
x <- data.frame(a=rnorm(10), b=rnorm(10), c=rnorm(10))
x0.lm <- lm(a ~ 1, data=x)
step(x0.lm, ~ b + c)
## Comments:


## PR 796 (aic in binomial models is often wrong)
##
data(esoph)
a1 <- glm(cbind(ncases, ncontrols) ~ agegp + tobgp * alcgp,
	  data = esoph, family = binomial())$aic
a1
a2 <- glm(ncases/(ncases+ncontrols) ~ agegp + tobgp * alcgp,
	  data = esoph, family = binomial(), weights=ncases+ncontrols)$aic
a2
stopifnot(a1 == a2)
## Comments:
# both should be 236.9645

## Follow up: example from Lindsey, purportedly of inaccuracy in aic
y <- matrix(c(2, 0, 7, 3, 0, 9), ncol=2)
x <- gl(3, 1)
a <- glm(y ~ x, family=binomial)$aic
stopifnot(is.finite(a))
## Comments: gave NaN prior to 1.2.1


## PR 802 (crash with scan(..., what=list(,,)))
##
m <- matrix(1:9, 3,3)
write(m, "test.dat", 3)
try(scan("test.dat", what=list(,,,)))
unlink("test.dat")
## Comments: segfaulted in 1.2.0


## Jonathan Rougier, 2001-01-30	 [bug in 1.2.1 and earlier]
tmp <- array(list(3), c(2, 3))
tmp[[2, 3]] <- "fred"
all.equal(t(tmp), aperm(tmp))


## PR 860 (Context problem with ... and rbind) Prof Brian D Ripley, 2001-03-03,
f <- function(x, ...)
{
   g <- function(x, ...) x
   rbind(numeric(), g(x, ...))
}
f(1:3)
## Error in 1.2.2
f <- function(x, ...) h(g(x, ...))
g <- function(x, ...) x
h <- function(...)substitute(list(...))
f(1)
## Error in 1.2.2
substitute(list(...))
## Error in 1.2.2


## Martin Maechler, 2001-03-07 [1.2.2 and in parts earlier]
tf <- tempfile()
cat(1:3,"\n", file = tf)
for(line in list(4:6, "", 7:9)) cat(line,"\n", file = tf, append = TRUE)

count.fields(tf) # 3 3 3 : ok {blank line skipped}
z <- scan(tf, what=rep(list(""),3), nmax = 3)
stopifnot(sapply(z, length) == 3)
## FALSE in 1.2.2
z <- as.data.frame(scan(tf, what=rep(list(""),3), n=9))
dim(z)
## should be 3 3.  Was 2 3 in 1.2.2.
read.table(tf)
## gave error in 1.2.2
unlink(tf)


## PR 870 (as.numeric and NAs)	Harald Fekjær, 2001-03-08,
is.na(as.numeric(" "))
is.na(as.integer(" "))
is.na(as.complex(" "))
## all false in 1.2.2


## PR 871 (deparsing of attribute names) Harald Fekjær, 2001-03-08,
midl <- 4
attr(midl,"Object created") <- date()
deparse(midl)
dump("midl", "midl.R")
source("midl.R") ## syntax error in 1.2.2
unlink("midl.R")


## PR 872 (surprising behavior of match.arg()) Woodrow Setzer, 2001-03-08,
fun1 <- function(x, A=c("power","constant")) {
  arg <- match.arg(A)
  formals()
}
topfun <- function(x, Fun=fun1) {
  a1 <- fun1(x)
  print(a1)
  a2 <- Fun(x,A="power")
  stopifnot(all.equal(a1, a2))
  print(a2)
}
topfun(2, fun1)
## a1 printed without defaults in 1.2.2


## PR 873 (long formulas in terms()) Jerome Asselin, 2001-03-08,
form <- cbind(log(inflowd1),log(inflowd2),log(inflowd3),
    log(inflowd4),log(inflowd5),log(inflowd6)) ~ precip*I(Tmax^2)
terms(form) # error in 1.2.2


## PR 881 Incorrect values in non-central chisq values on Linux, 2001-03-21
x <- dchisq(c(7.1, 7.2, 7.3), df=2, ncp=20)
stopifnot(diff(x) > 0)
## on 1.2.2 on RH6.2 i686 Linux x = 0.01140512 0.00804528 0.01210514


## PR 882 eigen segfaults on 0-diml matrices, 2001-03-23
m <- matrix(1, 0, 0)  # 1 to force numeric not logical
try(eigen(m))
## segfaults on 1.2.2


## 1.3.0 had poor compression on gzfile() with lots of small pieces.
if (capabilities("libz")) {
    zz <- gzfile("t1.gz", "w")
    write(1:1000, zz)
    close(zz)
    (sz <- file.info("t1.gz")$size)
    unlink("t1.gz")
    stopifnot(sz < 2000)
}


## PR 1010: plot.mts (type="p") was broken in 1.3.0 and this call failed.
plot(ts(matrix(runif(10), ncol = 2)), type = "p")


## in 1.3.0 readLines(ok=FALSE) failed.
cat(file="foo", 1:10, sep="\n")
x <- try(readLines("foo", 100, ok=FALSE))
unlink("foo")
stopifnot(length(class(x)) == 1 &&class(x) == "try-error")


## PR 1047 [<-data.frame failure, BDR 2001-08-10
test <- df <- data.frame(x=1:10, y=11:20, row.names=letters[1:10])
test[] <- lapply(df, factor)
test
## error in 1.3.0 in test[]


## PR 1048 bug in dummy.coef.lm, Adrian Baddeley, 2001-08-10
## modified to give a sensible test
old <- getOption("contrasts")
options(contrasts=c("contr.helmert", "contr.poly"))
DF <- data.frame(x=1:20,y=rnorm(20),z=factor(1:20 <= 10))
dummy.coef.lm(lm(y ~ z * I(x), data=DF))
dummy.coef.lm(lm(y ~ z * poly(x,1), data=DF))
## failed in 1.3.0.  Second one warns: deficiency of the method.
options(contrasts=old)


## PR 1050 error in ksmooth C code + patch, Hsiu-Khuern Tang, 2001-08-12
x <- 1:4
y <- 1:4
z <- ksmooth(x, y, x.points=x)
stopifnot(all.equal(z$y, y))
## did some smoothing prior to 1.3.1.


## The length of lines read by scan() was limited before 1.4.0
xx <- paste(rep(0:9, 2000), collapse="")
zz <- file("foo.txt", "w")
writeLines(xx, zz)
close(zz)
xxx <- scan("foo.txt", "", sep="\n")
stopifnot(identical(xx, xxx))
unlink("foo.txt")


## as.character was truncating formulae:  John Fox 2001-08-23
mod <- this ~ is + a + very + long + formula + with + a + very + large + number + of + characters
zz <- as.character(mod)
zz
nchar(zz)
stopifnot(nchar(zz)[3] == 83)
## truncated in 1.3.0


## substr<-, Tom Vogels, 2001-09-07
x <- "abcdef"
substr(x, 2, 3) <- "wx"
stopifnot(x == "awxdef")

x <- "abcdef"
substr(x, 2, 3) <- "wxy"
stopifnot(x == "awxdef")

x <- "abcdef"
substr(x, 2, 3) <- "w"
stopifnot(x == "awcdef")
## last was "aw" in 1.3.1


## reading bytes from a connection,  Friedrich Leisch 2001-09-07
cat("Hello World", file="world.txt")
con <- file("world.txt", "r")
zz <- readChar(con, 100)
close(con)
unlink("world.txt")
stopifnot(zz == "Hello World")
## was "" in 1.3.1.


## prediction was failing for intercept-only model
## as model frame has no columns.
d <- data.frame(x=runif(50), y=rnorm(50))
d.lm <- lm(y ~ 1, data=d)
predict(d.lm, data.frame(x=0.5))
## error in 1.3.1


## predict.arima0 needed a matrix newxreg: Roger Koenker, 2001-09-27
u <- rnorm(120)
s <- 1:120
y <- 0.3*s + 5*filter(u, c(.95,-.1), "recursive", init=rnorm(2))
fit0 <- arima0(y,order=c(2,0,0), xreg=s)
fit1 <- arima0(y,order=c(2,1,0), xreg=s, include.mean=TRUE)
fore0 <- predict(fit0 ,n.ahead=44, newxreg=121:164)
fore1 <- predict(fit1, n.ahead=44, newxreg=121:164)
par(mfrow=c(1,2))
ts.plot(y,fore0$pred, fore0$pred+2*fore0$se, fore0$pred-2*fore0$se,
		gpars=list(lty=c(1,2,3,3)))
abline(fit0$coef[3:4], lty=2)
ts.plot(y, fore1$pred, fore1$pred+2*fore1$se, fore1$pred-2*fore1$se,
		gpars=list(lty=c(1,2,3,3)))
abline(c(0, fit1$coef[3]), lty=2)


## merging when NA is a level
a <- data.frame(x = 1:4)
b <- data.frame(x = 1:3, y = factor(c("NA", "a", "b"), exclude=""))
(m <- merge(a, b, all.x = TRUE))
stopifnot(is.na(m[4, 2]))
## was level NA in 1.3.1
stopifnot(!is.na(m[1, 2]))


## merging with POSIXct columns:
x <- data.frame(a = as.POSIXct(Sys.time() + (1:3)*10000), b = LETTERS[1:3])
y <- data.frame(b = LETTERS[3:4], c = 1:2)
stopifnot(1 == nrow(merge(x, y)))
stopifnot(4 == nrow(merge(x, y, all = TRUE)))


## PR 1149.  promax was returning the wrong rotation matrix.
data(ability.cov)
ability.FA <- factanal(factors = 2, covmat = ability.cov, rotation = "none")
pm <- promax(ability.FA$loadings)
tmp1 <- as.vector(ability.FA$loadings %*% pm$rotmat)
tmp2 <- as.vector(pm$loadings)
stopifnot(all.equal(tmp1, tmp2))
rm(ability.cov)


## PR 1155. On some systems strptime was not setting the month or mday
## when yday was supplied.
bv1 <- data.frame(day=c(346,346,347,347,347), time=c(2340,2350,0,10,20))
attach(bv1)
tmp <- strptime(paste(day, time %/% 100, time %% 100), "%j %H %M")
detach()
stopifnot(tmp$mon == 11)
# day of month will be different in a leap year on systems that default
# to the current year, so test differences:
stopifnot(diff(tmp$mday) == c(0, 1, 0, 0))
## Comments: failed on glibc-based systems in 1.3.1, including Windows.


## PR 1004 (follow up).	 Exact Kolmogorov-Smirnov test gave incorrect
## results due to rounding errors (Charles Geyer, charlie@stat.umn.edu,
## 2001-10-25).
## Example 5.4 in Hollander and Wolfe (Nonparametric Statistical
## Methods, 2nd ed., Wiley, 1999, pp. 180-181).
x <- c(-0.15, 8.6, 5, 3.71, 4.29, 7.74, 2.48, 3.25, -1.15, 8.38)
y <- c(2.55, 12.07, 0.46, 0.35, 2.69, -0.94, 1.73, 0.73, -0.35, -0.37)
stopifnot(round(ks.test(x, y)$p.value, 4) == 0.0524)


## PR 1150.  Wilcoxon rank sum and signed rank tests did not return the
## Hodges-Lehmann estimators of the associated confidence interval
## (Charles Geyer, charlie@stat.umn.edu, 2001-10-25).
## One-sample test: Example 3.1 in Hollander & Wolfe (1973), 29f.
x <- c(1.83,  0.50,  1.62,  2.48, 1.68, 1.88, 1.55, 3.06, 1.30)
y <- c(0.878, 0.647, 0.598, 2.05, 1.06, 1.29, 1.06, 3.14, 1.29)
we <- wilcox.test(y, x, paired = TRUE, conf.int = TRUE)
## NOTE order: y then x.
## Results from Hollander & Wolfe (1999), 2nd edition, page 40 and 53
stopifnot(round(we$p.value,4) == 0.0391)
stopifnot(round(we$conf.int,3) == c(-0.786, -0.010))
stopifnot(round(we$estimate,3) == -0.46)
## Two-sample test: Example 4.1 in Hollander & Wolfe (1973), 69f.
x <- c(0.80, 0.83, 1.89, 1.04, 1.45, 1.38, 1.91, 1.64, 0.73, 1.46)
y <- c(1.15, 0.88, 0.90, 0.74, 1.21)
we <- wilcox.test(y, x, conf.int = TRUE)
## NOTE order: y then x.
## Results from Hollander & Wolfe (1999), 2nd edition, page 111 and 126
stopifnot(round(we$p.value,4) == 0.2544)
stopifnot(round(we$conf.int,3) == c(-0.76, 0.15))
stopifnot(round(we$estimate,3) == -0.305)


## range gave wrong length result for R < 1.4.0
stopifnot(length(range(numeric(0))) == 2)
##  Comments: was just NA


## mishandling of integer(0) in R < 1.4.0
x1 <- integer(0) / (1:3)
x2 <- integer(0) ^ (1:3)
stopifnot(length(x1) == 0 & length(x2) == 0)
##  Comments: were integer NAs in real answer in 1.3.1.


## PR#1138/9  rounding could give non-integer answer.
x <- round(100000/3, -2) - 33300
stopifnot(x == 0)
## failed in 1.3.x on Solaris and Windows but not Debian Linux.


## PR#1160 finding midpoints in image <janef@stat.berkeley.edu, 2001-11-06>
x2 <- c(0, 0.002242152, 0.004484305, 0.006726457, 0.00896861,
	0.01121076, 0.01345291, 0.01569507, 0.01793722, 0.02017937,
	0.02242152, 0.02466368, 0.02690583, 0.02914798, 0.03139013,
	0.03363229, 0.03587444, 0.03811659, 0.04035874, 0.04932735,
	0.05156951, 0.05381166)
z <- c(0, 0.067, NA, 0.167, 0.083, 0.05, 0.067, NA, 0, 0.1, 0, 0.05,
       0.067, 0.067, 0.016, 0.117, 0.017, -0.017, 0.2, 0.35, 0.134, 0.15)
image(x2, 1, as.matrix(z))
## Comments: failed under R 1.3.1.


##PR 1175 and 1123##
set.seed(123)
## We can't seem to get Pearson residuals right ##
x <- 1:4 # regressor variable
y <- c(2,6,7,8) # response binomial counts
n <- rep(10,4) # number of binomial trials
ym <- cbind(y,n-y) # response variable as a matrix
glm1 <- glm(ym~x,binomial) # fit a generalized linear model
f <- fitted(glm1)
rp1 <- (y-n*f)/sqrt(n*f*(1-f)) # direct calculation of pearson residuals
rp2 <- residuals(glm1,type="pearson") # should be pearson residuals
stopifnot(all.equal(rp1,rp2))
# sign should be same as response residuals
x <- 1:10
y <- rgamma(10,2)/x
glm2 <- glm(y~x,family=Gamma)
stopifnot(all.equal(sign(resid(glm2,"response")),sign(resid(glm2,"pearson"))))
# shouldn't depend on link for a saturated model
x<-rep(0:1,10)
y<-rep(c(0,1,1,0,1),4)
glm3<-glm(y~x,family=binomial(),control=glm.control(eps=1e-8))
glm4<-glm(y~x,family=binomial("log"),control=glm.control(eps=1e-8))
stopifnot(all.equal(resid(glm3,"pearson"),resid(glm4,"pearson")))


## Torsten Hothorn, 2001-12-04
stopifnot(pt(-Inf, 3, ncp=0) == 0, pt(Inf, 3, ncp=0) == 1)
##  Comments: were 0.5 in 1.3.1


## Paul Gilbert, 2001-12-07
cancor(matrix(rnorm(100),100,1), matrix(rnorm(300),100,3))
##  Comments: failed in R-devel.


## PR#1201: incorrect values in qbeta
x <- seq(0, 0.8, len=1000)
xx <- pbeta(qbeta(x, 0.143891, 0.05), 0.143891, 0.05)
stopifnot(max(abs(x - xx)) < 1e-6)
##  Comments:  Get a range of zeroes in 1.3.1


## PR#1216: binomial null model
y <- rbinom(20, 1, 0.5)
glm(y ~ 0, family = binomial)
##  Comments:  1.3.1 gave  Error in any(n > 1) : Object "n" not found


## Integer overflow in type.convert
res <- type.convert("12345689")
stopifnot(typeof(res) == "integer")
res <- type.convert("12345689012")
stopifnot(typeof(res) == "double")
##  Comments: was integer in 1.4.0


## La.eigen() segfault
e1 <- La.eigen(m <- matrix(1:9,3))
stopifnot(e1$values == La.eigen(m, only.values = TRUE)$values)


## Patrick Connelly 2001-01-22, prediction with offsets failed
## a simpler example
counts <- c(18, 17, 15, 20, 10, 20, 25, 13, 12)
outcome <- gl(3, 1, 9)
treatment <- gl(3, 3)
DF <- data.frame(counts = c(18, 17, 15, 20, 10, 20, 25, 13, 12),
		 outcome = gl(3, 1, 9), treatment = gl(3, 3),
		 exposure = c(1.17, 1.78, 1.00, 2.36, 2.58, 0.80, 2.51,
		 1.16, 1.77))
fit <- glm(counts ~ outcome + treatment + offset(log(exposure)),
	   family = poisson, data = DF)
p1 <- predict(fit)
p2 <- predict(fit, se = TRUE)  ## failed < 1.4.1
p3 <- predict(fit, newdata = DF)
p4 <- predict(fit, newdata = DF, se = TRUE)
stopifnot(all.equal(p1, p2$fit), all.equal(p1, p3), all.equal(p2, p4))
fit <- glm(counts ~ outcome + treatment, offset = log(exposure),
	   family = poisson, data = DF)
p1 <- predict(fit)
p2 <- predict(fit, se = TRUE)  ## failed < 1.4.1
p3 <- predict(fit, newdata = DF)
p4 <- predict(fit, newdata = DF, se = TRUE)
stopifnot(all.equal(p1, p2$fit), all.equal(p1, p3), all.equal(p2, p4))


## PR#1267 hashing NaN
load(file.path(Sys.getenv("SRCDIR"), "nanbug.rda"))
bb <- b; bb[5] <- NaN
identical(b, bb)	    # TRUE
unique(c(NaN, bb))	    #[1] NaN 0 1 2 3 NA
stopifnot(identical(unique(c(NaN, b)), unique(c(NaN, bb))))
## 1.4.0 gives [1] NaN 0 1 2 NaN 3 NA	on most platforms


## PR 1271  detach("package:base") crashes R.
try(detach("package:base"))


## reported by PD 2002-01-24
Y <- matrix(rnorm(20), , 2)
fit <- manova(Y ~ 1)
fit # failed
print(fit, intercept = TRUE)
summary(fit) # failed
summary(fit, intercept = TRUE)


## Several  qr.*() functions lose (dim)names.
## reported by MM 2002-01-26

## the following should work both in R and S+ :
q4 <- qr(X4 <- cbind(a = 1:9, b = c(1:6,3:1), c = 2:10, d = rep(1,9)))
##q2 <- qr(X4[,1:2])
y04 <- y4 <- cbind(A=1:9,B=2:10,C=3:11,D=4:12)
dimnames(y4)[[1]] <- paste("c",1:9,sep=".")
y1 <- y4[,2]
y40 <- y4 ; dimnames(y40) <- list(dimnames(y4)[[1]], NULL)

c1 <- qr.coef( q4, y4) # row- AND col-names
c2 <- qr.coef( q4, y04)# ditto
c3 <- qr.coef( q4, y40)# row--names
dn3 <- dimnames(c3)
stopifnot(identical(dimnames(c1), dimnames(c2)),
	  identical(dimnames(c1), list(letters[1:4], LETTERS[1:4])),
	  identical(dn3[[1]], letters[1:4]),  length(dn3[[2]]) == 0,
	  identical(names(qr.coef(q4,y1)),   letters[1:4]),
	  identical(dimnames(qr.R(q4))[[2]], letters[1:4]),

	  identical(dimnames(qr.qty(q4,y4)), dimnames(y4)),
	  identical(dimnames(qr.qty(q4,y40)), dimnames(y40)),
	  identical(dimnames(qr.qy (q4,y04)), dimnames(y04)),

	  all.equal(y1,	 qr.fitted(q4, y1 ), tol = 1e-12),
	  all.equal(y4,	 qr.fitted(q4, y4 ), tol = 1e-12),
	  all.equal(y40, qr.fitted(q4, y40), tol = 1e-12),
	  all.equal(y04, qr.fitted(q4, y04), tol = 1e-12),

	  all.equal(X4, qr.X(q4), tol = 1e-12)
)


## PR 1297  read.fwf() was interpreting `#' in 1.4.0/1
cat(file="test.fwf", "123ABC123", "123#3 123", "123XYZ123", sep="\n")
(res <- read.fwf("test.fwf", widths=c(3,3,3), comment.char=""))
unlink("test.fwf")
stopifnot(res[2, 2] == "#3 ")


## abs was failing to dispatch as part of the Math group generic
tmp <- data.frame(x = -5:5)
abs(tmp)
## failed in 1.4.1.


## PR 1363 La.svd was not working for integer args
m <- matrix(1:4, 2)
(s1 <- svd(m))
(s2 <- La.svd(m))
stopifnot(all.equal(s1$d, s2$d), all.equal(s1$u, s2$u),
	  all.equal(s1$v, t(s2$vt)))
(e1 <- eigen(m))
(e2 <- La.eigen(m))
stopifnot(all.equal(e1$d, e1$d))


## order/sort.list on NA_STRING
x <- c("A", NA, "Z")
stopifnot(identical(sort(x, na.last = TRUE), x[sort.list(x, na.last = TRUE)]))
stopifnot(identical(sort(x, na.last = FALSE), x[sort.list(x, na.last = FALSE)]))
## 1.4.1 sorted NA correctly with sort but not sort.list.


## Don MacQueen 2002-03-26
stopifnot(length(seq(1024902010, 1024902025, by=1)) == 16)
t0 <- ISOdatetime(2002,6,24,0,0,10)
x <- seq.POSIXt(from=t0,to=t0+15,by='1 sec')
stopifnot(length(x) == 16)


## whilst reading the code BDR 2002-03-31
z <- try(max(complex(0)))
stopifnot(inherits(z, "try-error"))
z <- try(min(complex(0)))
stopifnot(inherits(z, "try-error"))
## 1.4.1 gave +-Inf + random imaginary part


## PR#1238  min/max(NULL) or (integer(0))
z <- min(NULL)
stopifnot(!is.na(z), mode(z) == "numeric", z == Inf)
z <- min(integer(0))
stopifnot(!is.na(z), mode(z) == "numeric", z == Inf)
z <- max(NULL)
stopifnot(!is.na(z), mode(z) == "numeric", z == -Inf)
z <- max(integer(0))
stopifnot(!is.na(z), mode(z) == "numeric", z == -Inf)


## more reading the code BDR 2002-03-31
stopifnot(identical(range(), range(numeric(0))))
## in 1.4.1 range() was c(1,1)
stopifnot(is.null(c()))
## in 1.4.1 this was structure(TRUE, names="recursive")

## range(numeric(0)) was not as documented
x <- numeric(0)
(rx <- range(x))
stopifnot(identical(rx, c(min(x), max(x))))
## 1.4.1 had c(NA, NA)


## PR 1431 persp() crashes with numeric values for [x,y,z]lab
persp(1:2, 1:2, matrix(1:4, 2), xlab=1)
## segfaulted in 1.4.1


## PR#1244 bug in det using method="qr"
m2 <- structure(c(9822616000, 3841723000, 79790.09, 3841723000, 1502536000,
		  31251.82, 79790.09, 31251.82, 64156419.36), .Dim = c(3, 3))
(d1 <- det(m2, method="eigenvalues"))
(d2 <- det(m2, method="qr"))
stopifnot(d2 == 0) ## 1.4.1 gave 9.331893e+19
(d3 <- det(m2, method="qr", tol = 1e-10))
stopifnot(all.equal(d1, d3, tol=1e-3))


## PR#1422 glm start/offset bugs
if(require(MASS)) {
data(ships, package = MASS)
ships.glm <- glm(incidents ~ type + year + period + offset(log(service)),
		 family = poisson, data = ships, subset = (service != 0))
update(ships.glm, start = coef(ships.glm))
detach("package:MASS")
}
## failed in 1.4.1.


## PR#1439 file.info()$isdir was only partially logical
(info <- file.info("."))
info$isdir
stopifnot(info$isdir == TRUE)
## 1.4.1 had a TRUE value that was not internally integer 1.

## PR#1473 predict.*bSpline() bugs extrapolating for deriv >= 1
library(splines)
x <- c(1:3,5:6)
y <- c(3:1,5:6)
(isP <- interpSpline(x,y))# poly-spline representation
(isB <- interpSpline(x,y, bSpl = TRUE))# B-spline repr.
xo <- c(0, x, 10)# x + outside points
op <- options(digits = 4)
for(der in 0:3) # deriv=3 fails!
    print(formatC(try(predict(isP, xo, deriv = der)$y), wid=7,format="f"),
	  quote = FALSE)
## and for B-spline (instead of polynomial):
for(der in 0:3)	 # deriv=3 failed
    print(formatC(try(predict(isB, xo, deriv = der)$y), wid=7,format="f"),
	  quote = FALSE)
options(op)
detach("package:splines")


## PR 902 segfaults when warning string is too long, Ben Bolker 2001-04-09
provoke.bug <- function(n=9000) {
   warnmsg <- paste(LETTERS[sample(1:26,n,replace=TRUE)],collapse="")
   warning(warnmsg)
}
provoke.bug()
## segfaulted in 1.2.2, will also on machines without vsnprintf (none now)


## PR#1510 merge with multiple match rows and different names.
df1 <- data.frame(z = 1:10, m = letters[1:10], w = rnorm(10))
df2 <- data.frame(x = 1:10, y = rnorm(10), n = letters[1:10])
merge(df2, df1, by.x = c("x", "n"), by.y = c("z", "m"))
## failed in 1.5.0


## PR 1524  Problems with paste/unlist
l <- names(unlist(list(aa = list(bb = 1))))
l
# this is exactly "aa.bb"
stopifnot(identical(l, "aa.bb"))
l2 <- paste(l, "this should be added")
stopifnot(identical(l2, "aa.bb this should be added"))
## 1.5.0 gave l2 printing as l.


## PR 1530 drop inconsistency for data frames
DF <- data.frame(x = 1:3, y = c("A","D","E"), z = c(6,9,10))
a1 <- DF[1,1:3]
xx <- DF[1,]
a2 <- xx[, 1:3]
a3 <- DF[1,1:3, drop = TRUE]
a4 <- xx[, 1:3, drop = TRUE]
stopifnot(identical(a1, a2), identical(a3, a4))
## <= 1.5.0 had a2 == a3.


## PR 1536 rbind.data.frame converts logical to factor
df <- data.frame(a = 1:10)
df$b <- df$a < 5
ddf <- rbind(df, df)
stopifnot(!is.factor(ddf$b))
## 1.5.0 had b as a factor.


## PR 1548 : prettyNum inserted leading commas
stopifnot(prettyNum(123456, big.mark=",") == "123,456")


## PR 1552: cut.dendrogram
data(USArrests)
hc <- hclust(dist(USArrests), "ave")
cc <- cut(as.dendrogram(hc), h = 20)## error in 1.5.0

## predict.smooth.spline(*, deriv > 0) :
x <- (1:200)/32
ss <- smooth.spline(x, 10*sin(x))
stopifnot(length(x) == length(predict(ss,deriv=1)$x))# not yet in 1.5.0

## pweibull(large, log=T):
stopifnot(pweibull(seq(1,50,len=1001), 2,3, log = TRUE) < 0)

## selfStart.default() w/ no parameters:
## --> make this into example(selfStart) {with data and nls()!}
logist <- deriv( ~Asym/(1+exp(-(x-xmid)/scal)), c("Asym", "xmid", "scal"),
		function(x, Asym, xmid, scal){} )
logistInit <- function(mCall, LHS, data) {
    xy <- sortedXyData(mCall[["x"]], LHS, data)
    if(nrow(xy) < 3) stop("Too few distinct input values to fit a logistic")
    Asym <- max(abs(xy[,"y"]))
    if (Asym != max(xy[,"y"])) Asym <- -Asym  # negative asymptote
    xmid <- NLSstClosestX(xy, 0.5 * Asym)
    scal <- NLSstClosestX(xy, 0.75 * Asym) - xmid
    value <- c(Asym, xmid, scal)
    names(value) <- mCall[c("Asym", "xmid", "scal")]
    value
}
logist <- selfStart( logist, initial = logistInit ) ##-> Error in R 1.5.0
str(logist)


## part of PR 1662: fisher.test with total one
fisher.test(cbind(0, c(0,0,0,1)))
## crashed in R <= 1.5.0

stopifnot(Mod(vector("complex", 7)) == 0) # contained garbage in 1.5.0

## hist.POSIXt with numeric `breaks'
hist(.leap.seconds, breaks = 5)
## error in 1.5.1


##Jonathan Rougier 2002-06-18
x <- matrix(runif(30), 10, 3)
poly(x, degree=2)
## failed in 1.5.1


## PR#1694 cut with infinite values -> NA (Markus Jäntti)
cut.off <- c(-Inf, 0, Inf)
x <- c(-Inf, -10, 0, 10, Inf)
(res <- cut(x, cut.off, include.lowest=TRUE))
stopifnot(!is.na(res))
(res <- cut(x, cut.off, include.lowest=TRUE, right=FALSE))
stopifnot(!is.na(res))
## outer values were NA in 1.5.1


## ls.str() for function environments:
library(stepfun)
Fn <- ecdf(rnorm(50))
ls.str(envir = environment(Fn))
detach("package:stepfun")
## failed in 1.5.1


## PR 1767 all.equal.character for non-matching NAs
all.equal(c("A", "B"), c("A", NA))
## failed in 1.5.1


## failed since at least version 0.90:
stopifnot(is.character(a12 <- all.equal(1,1:2)),
	  length(a12) == 1,# was 2 till 1.6.2
	  a12 == "Numeric: lengths (1, 2) differ")
## a12 was *list* of length 3


## related to PR 1577/1608, conversions to character
DF <- data.frame(b = LETTERS[1:3])
sapply(DF, class)
DF[[1]] <- LETTERS[1:3]
stopifnot(is.character(DF$b)) ## was factor < 1.6.0
DF <- data.frame(b = LETTERS[1:3])
DF$b <- LETTERS[1:3]
stopifnot(is.character(DF$b)) ## always was character.

x <- data.frame(var = LETTERS[1:3]); x$var <- as.character(x$var)
x[[1]][2] <- "3"
x
stopifnot(is.character(x$var))
is.na(x[[1]]) <- 2
stopifnot(is.character(x$var))

x <- data.frame(var = I(LETTERS[1:3]))
x[[1]][2] <- "3"
x
stopifnot(is.character(x$var))
is.na(x[[1]]) <- 2
stopifnot(is.character(x$var))

x <- data.frame(var = LETTERS[1:3])
x[[1]][2] <- "3"
x
stopifnot(is.factor(x$var))
is.na(x[[1]]) <- 2
stopifnot(is.factor(x$var))

x <- data.frame(a = 1:4)
y <- data.frame(b = LETTERS[1:3])
y$b <- as.character(y$b)
z <- merge(x, y, by = 0, all.x = TRUE)
sapply(z, data.class)
stopifnot(is.character(z$b))
## end of `related to PR 1577/1608'


## logicals became factors < 1.6.0
stopifnot(sapply(as.data.frame(matrix((1:12)%% 4 == 1, 3,4)),
		 is.logical))


## recycling of factors in data.frame (wish from PR#1713)
data.frame(x=c("A","B"), y="C")	     # failed to recycle in 1.5.1
X <- data.frame(x=c("A","B"), y=I("C")) # also failed
XX <- data.frame(x=c("A","B"), y=I(rep("C", 2))) # fine
stopifnot(identical(X, XX))
## Last is false in some S variants.


## test of rank-deficient prediction, as various claims this did not work
## on R-help in June 2002
x1 <- rnorm(100)
x3 <- rnorm(100)
y <- rnorm(100)
train <- data.frame(y=y, x1=x1, x2=x1, x3=x3)
fit <- lm(y ~ ., train)
stopifnot(all.equal(predict(fit), predict(fit, train)))
## warning added for 1.6.0


## terms(y ~ .) on data frames with duplicate names
DF <- data.frame(y = rnorm(10), x1 = rnorm(10), x2 = rnorm(10), x3 = rnorm(10))
names(DF)[3] <- "x1"
fit <- try(lm(y ~ ., DF))
stopifnot(class(fit) == "try-error")
## had formula y ~ x1 + x1 + x3 in 1.5.1.


## PR#1759 as.character.octmode() (Henrik Bengtsson)
x <- 0; class(x) <- "octmode"
stopifnot(as.character(x) == "0")
## gave "" in 1.5.1


## PR#1843 unsplit() with f a list
g <- factor(round(10 * runif(1000)))
x <- rnorm(1000) + sqrt(as.numeric(g))
xg <- split(x, list(g1=g,g2=g))
res <- unsplit(xg, list(g1=g, g2=g))
stopifnot(x == res) # can't have rounding error here
## gave incorrect result with warning in 1.5.1.


## matching NAs on Solaris (MM 2002-08-02)
x <- as.double(NA)
identical(x + 0, x)
stopifnot(match(x + 0, x, 0) == 1)
## match failed on Solaris with some compiler settings


## identical on specials  (BDR 2002-08-02)
stopifnot(identical(as.double(NA), NaN) == FALSE)
## was identical on 1.5.1


## safe prediction (PR#1840)
data(cars)
cars.1 <- lm(dist ~ poly(speed, degree = 1), data = cars)
cars1  <- lm(dist ~	 speed,		     data = cars)
DF <- data.frame(speed=4)
stopifnot(all.equal(predict(cars.1, DF), predict(cars1, DF)))
## error in 1.5.1


## Ops.data.frame (PR#1889)
d <- data.frame(1:10)
d > list(5)
## failed in 1.5.1


## order(na.last = NA) (PR#1913 / 1906 / 1981)
x <- 1
order(x, na.last=NA)
order(x, x, x, na.last=NA)
## failed in 1.5.1, since sapply simplified to a scalar.
stopifnot(3:1 == order(c(1,2,3,NA), na.last=NA, decreasing=TRUE))
## ignored `decreasing' in 1.5.1
order(c(NA, NA), na.last = NA)
## error in 1.5.1, now integer(0)

## as.list() coerced logical to integer (PR#1926)
x <- c(TRUE,FALSE,NA)
stopifnot(identical(x, unlist(as.list(x))))
## the 2nd was (1,0,NA) before 1.6


## test of long Error expression in aov(): PR#1315 and later,
## and also a cross-check of deparse(, cutoff = 500)
AA <- structure(list(Y2 = c(10, 9, 0, 0, 5, 6, 0, 0, 8, 9, 0, 0, 4,
4, 0, 0, 12, 11, 2, 0, 6, 7, 0, 0), P2 = structure(c(1, 1, 1,
1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3
), .Label = c("1", "2", "3"), class = "factor"), AAAAAAAA = structure(c(1,
1, 1, 1, 2, 2, 2, 2, 1, 1, 1, 1, 2, 2, 2, 2, 1, 1, 1, 1, 2, 2,
2, 2), .Label = c("E1", "E2"), class = "factor"), B2 = structure(c(1,
1, 2, 2, 1, 1, 2, 2, 1, 1, 2, 2, 1, 1, 2, 2, 1, 1, 2, 2, 1, 1,
2, 2), .Label = c("Red", "Unred"), class = "factor"), C2 = structure(c(1,
2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2,
1, 2), .Label = c("Agent", "Patient"), class = "factor")), .Names = c("Y2",
"P2", "AAAAAAAA", "B2", "C2"), class = "data.frame", row.names = c("1",
"2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13",
"14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24"
))
AK2anova.out <-
    aov(Y2 ~ AAAAAAAA * B2 * C2 +
	Error(P2 + P2:AAAAAAAA + P2:B2 + P2:C2 + P2:AAAAAAAA:B2 +
	      P2:AAAAAAAA:C2 + P2:B2:C2 + P2:AAAAAAAA:B2:C2),
	data=AA)
## failed in 1.5.1

## as.character was silently truncating expressions to 60 chars
q2 <- expression(c(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19))
(q3 <- as.character(q2))
stopifnot(nchar(q3) == 68)
## was 61 in 1.5.1


## Ops wasn't using NextMethod correctly

## Ops.ordered:
or <- ordered(c("a","b","c"))
stopifnot( (or == "a") == c(TRUE,FALSE,FALSE))
stopifnot(or == or)
stopifnot(or != "d")
##  last was NA NA NA in 1.5.1


Ops.foo <- function(e1, e2) {
    NextMethod()
}
Ops.baz <- function(e1, e2) {
   NextMethod()
}
a <- b <- 1
class(a) <- c("foo","bar","baz")
class(b) <- c("foo","baz")
stopifnot(a == 1,
	  b == a)
##(already worked in 1.5.1)


## t() wrongly kept "ts" class and "tsp"
t(ts(c(a=1, d=2)))
## gave error while printing in 1.5.1
at <- attributes(t(ts(cbind(1, 1:20))))
stopifnot(length(at) == 2,
	  at$dim == c(2, 20),
	  at$dimnames[[1]] == paste("Series", 1:2))
## failed in 1.5.1


## Nextmethod from anonymous function (PR#1211)
try( get("print.ts")(1) )# -> Error
## seg.faulted till 1.5.1


## cbind/rbind should work with NULL only args
stopifnot(is.null(cbind(NULL)), is.null(cbind(NULL,NULL)),
	  is.null(rbind(NULL)), is.null(rbind(NULL,NULL)))
## gave error from 0.63 till 1.5.1


## seq.POSIXt() had rounding problem:
stopifnot(4 == length(seq(from=ISOdate(2000,1,1), to=ISOdate(2000,1,4),
			  length.out=4)))
## length was 5 till 1.6.0


## loess has a limit of 4 predictors (John Deke on R-help, 2002-09-16)
data1 <- array(runif(500*5),c(500,5))
colnames(data1) <- c("x1","x2","x3","x4","x5")
y <- 3+2*data1[,"x1"]+15*data1[,"x2"]+13*data1[,"x3"]-8*data1[,"x4"]+14*data1[,"x5"]+rnorm(500)
data2 <- as.data.frame(cbind(y,data1))
result4 <- loess(y~x1+x2+x3+x4,data2)
try(result5 <- loess(y~x1+x2+x3+x4+x5,data2))
## segfaulted in 1.5.1


## format.AsIs was not handling matrices
jk <- data.frame(x1=2, x2=I(matrix(0,1,2)))
jk
## printing failed in 1.5.1


## eigenvectors got irrelevant names (PR#2116)
set.seed(1)
A <- matrix(rnorm(20), 5, 5)
dimnames(A) <- list(LETTERS[1:5], letters[1:5])
(ev <- eigen(A)$vectors)
stopifnot(is.null(colnames(ev)))
## had colnames in 1.6.0


## pretty was not pretty {because seq() isn't} (PR#1032 and D.Brahm)
stopifnot(pretty(c(-.1, 1))[2] == 0, ## [2] was -2.775558e-17
	  pretty(c(-.4,.8))[3] == 0, ## [3] was 5.551115e-17
	  pretty(100+ c(0, pi*1e-10))[4] > 100,# < not too much rounding!
	  pretty(c(2.8,3))[1] == 2.8)
## last differed by 4.44e-16 in R 1.1.1


## add1 was giving misleading message when scope was nonsensical.
counts <- c(18,17,15,20,10,20,25,13,12)
fit <- glm(counts ~ 1, family=poisson)
res <- try(add1(fit, ~ .))
## error in 1.6.0 was
## `Error in if (ncol(add) > 1) { : missing value where logical needed'
stopifnot(length(grep("missing value", res)) == 0)


## stripchart with NAs (PR#2018)
data(iris)
Sepal <- iris$Sepal.Length
Sepal[27] <- NA
stripchart(Sepal ~ iris$Species, method="stack")
## failed in 1.6.1


## losing is.object bit internally (PR#2315)
stopifnot(is.ts(log(as.ts(1:10))))
## failed for integer original as here in 1.6.1.


## formatC ignored rounding up (PR#2299)
stopifnot(formatC(99.9, 1, format="fg") == "100")
stopifnot(formatC(99.9, 2, format="fg") == "100")
stopifnot(formatC(99.9, 3, format="fg") == "99.9")
## gave exponential format on 1.6.1


## full/partial matching in attr.
tmp <- list(id=1)
attr(tmp,"n.ch") <- 2
attr(tmp,"n") <- 1
attributes(tmp)
(res <- attr(tmp, "n"))
stopifnot(length(res) == 1 && res == 1)
## gave NULL in 1.6.1


## Undocumented line limit in system(intern=TRUE)
## Naoki Takebayashi <ntakebay@bio.indiana.edu> 2002-12-07
tmp <- tempfile()
long <- paste(rep("0123456789", 20), collapse="")
cat(long, "\n", sep="", file=tmp)
junk <- system(paste("cat", tmp), intern = TRUE)
stopifnot(length(junk) == 1, nchar(junk[1]) == 200)
## and split truncated on 1.6.1


## missing group generics for `difftime' (related to PR#2345)
x <- as.difftime(c("0:3:20", "11:23:15"))
y <- ISOdate(2001, 4, 26) - ISOdate(2001, 2, 26)
x + x
2*x
x < y
x < 100
## all but last failed in R < 1.7.0


## PR 2358 (part)
mm <- 1:2
names(mm)[2] <- 'y'
(mm <- c(mm, 3))
stopifnot(is.na(names(mm)[1]))
## 1.6.1 had "NA"


## PR 2357
a <- matrix(c(1,2,3,-1,-2,3),2,3,dimnames=list(c("A","B"),NULL))
(z <- pmax(a, 0))
stopifnot(identical(dimnames(z), dimnames(a)))
# further checks
a <- matrix(c(1,2,3,-1,-2,3),2,3,dimnames=list(c("A","B"),1:3))
(z <- pmax(a, 0))
stopifnot(identical(dimnames(z), dimnames(a)))
a <- matrix(c(1,2,3,-1,-2,3),2,3,dimnames=list(NULL, letters[1:3]))
(z <- pmax(a, 0))
stopifnot(identical(dimnames(z), dimnames(a)))
## 1.6.1 only transferred dimnames if both components were non-null


## internal conversion to factor in type.convert was not right
## if a character string NA was involved.
x <- c(NA, "NA", "foo")
(z <- type.convert(x))
stopifnot(identical(levels(z), "foo"))
(z <- type.convert(x, na.strings=character(0)))
stopifnot(identical(levels(z), sort(c("foo", "NA"))))
(z <- type.convert(x, na.strings="foo"))
stopifnot(identical(levels(z), "NA"))
## extra level in 1.6.1


## related example
tmp <- tempfile()
cat(c("1", "foo", "\n", "2", "NA", "\n"), file = tmp)
(z <- read.table(tmp, na.strings="foo"))
unlink(tmp)
stopifnot(identical(levels(z$V2), "NA"),
	  identical(is.na(z$V2), c(TRUE, FALSE)))
## 1.6.1 had V2 as NA NA.


## PR#2396, parsing and pushbacks.
tmp <- tempfile()
cat( c( "1", "a+b", "2"), file=tmp, sep="\n")
open(tcon <- file(tmp))
readLines(tcon, n=1)
pushBack("a1+b1", tcon)
parse(file=tcon, n=1)
close(tcon)
unlink(tmp)
## failed with syntax error in 1.6.1


## NAs in max.col
a <- matrix(1, 3, 3)
a[1,2] <- NA
(z <- max.col(a))
stopifnot(is.na(z[1]))
## gave (randomly) 1 or 3 in 1.6.1


## PR#2469: read.table on MacOS CR-terminated files.
tmp <- tempfile()
x <- c("aaa", "bbb", "ccc")
cat(x, sep="\r", file=tmp)
con <- file(tmp)
open(con)
line <- readLines(con, 1)
pushBack(line, con)
(y <- readLines(con))
unlink(tmp)
stopifnot(identical(x, y))
## pushback problems in 1.6.2 only


## dimnames in solve(): not a bug just an improvement in 1.7.0
A <- diag(3)
dimnames(A) <- list(LETTERS[1:3], letters[1:3])
(B <- solve(A))
stopifnot(identical(colnames(B), rownames(A)))
## R < 1.7.0 had no colnames for B, and S has the colnames of A.
stopifnot(all.equal(t(B), solve(t(A))))
## test here is of dimnames


## PR#2507: extracting 0-length dimensions for arrays
dn <- list(LETTERS[1:2], letters[1:3], paste("t",1:4,sep=""))
A. <- array(1:24, dim = 2:4, dimnames = dn)
str(A.[1, 0, 2 ])
str(A.[1, 0, 2, drop = FALSE])
## both gave errors in 1.6.2

library(stepfun)
plot(sf <- stepfun(2, 3:4))
detach("package:stepfun")
## failed in 1.6.2


## PR#2541, cbind (and rbind) with zero-length components
y <- matrix(0,1,0)
cbind(y, integer(0))
y <- matrix(0,0,1)
rbind(y, integer(0))
## gave fatal error in 1.6.2, since miscalculated no of rows/cols.


## PR#2518 multiple objects in AIC.default.
lm1 <- lm(y ~ x, list(x=1:10, y=jitter(1:10)))
lm2 <- lm(y ~ x, list(x=1:10, y=jitter(1:10)))
AIC(lm1, lm2)
AIC(lm1, lm2,  k=2)
## second failed in 1.6.2


## PR#2591 unique on ordered factor
f <- ordered(month.name, levels=month.name)
(uf <- unique(f))
stopifnot(is.ordered(uf))
## gave factor in 1.6.2


## PR#2587 coercion of length-0 vectors
x <- numeric(0)
x[1] <- NA
stopifnot(identical(mode(x), "numeric"))
##


## PR#2586 labelling in alias()
Y <- c(0,1,2)
X1 <- c(0,1,0)
X2 <- c(0,1,0)
X3 <- c(0,0,1)
(res <- alias(lm(Y ~ X1 + X2 + X3)))
stopifnot(identical(rownames(res[[2]]),	 "X2"))
## the error was in lm.(w)fit


## coercion lost the object bit in [<-
x <- I(TRUE)
is.object(x)
x[2] <- "N"
stopifnot(is.object(x))
## failed in 1.6.2


## check inherits now works for basic classes:
x <- 1:3
is.object(x) # FALSE
stopifnot(inherits(x, "integer"))
## 2003-Mar-12 it did not


## rank() is numeric also for NA char vectors
stopifnot(is.numeric(rk <- rank(c("ch","c", NA))),
          all(rk == c(2,1,3)))
## did not from R 1.2 -- 1.6


## table() should by default keep NA levels of factors
i <- c(1:2,NA);	 fi <- factor(i, exclude = NULL)
stopifnot(identical(as.character(i), dimnames(table(fi))[[1]]))
## not in 2003-Mar-10 unstable


## [lm.]influence() for multivariate lm :
n <- 32
Y <- matrix(rnorm(3 * n), n, 3)
X <- matrix(rnorm(5 * n), n, 5)
infm <- lm.influence(mod <- lm(Y ~ X))
## failed up to 2003-03-29 (pre 1.7.0)


## rbind.data.frame with character and ordered columns
A <- data.frame(a=1)
A$b <- "A"
B <- data.frame(a=2)
B$b <- "B"
AB <- rbind(A,B)
(cl <- sapply(AB, class))
stopifnot(cl[2] == "character") # was factor in 1.6.2

A <- data.frame(a=1:3, b=ordered(letters[1:3]))
B <- data.frame(a=7:9, b=ordered(letters[7:9]))
AB <- rbind(A,B)
(cl <- sapply(AB, class))
stopifnot(cl$b[1] == "ordered") # was factor in 1.6.2
C <- data.frame(a=4:6, b=letters[4:6])
ABC <- rbind(AB, C)
(cl <- sapply(ABC, class))
stopifnot(cl[2] == "factor")

A <- data.frame(a=1)
A$b <- "A"
B <- data.frame(a=2, b="B")
(AB <- rbind(A,B))
(cl <- sapply(AB, class))
stopifnot(cl[2] == "character")

A <- data.frame(a=1, b="A")
B <- data.frame(a=2)
B$b <- "B"
(AB <- rbind(A,B))
(cl <- sapply(AB, class))
stopifnot(cl[2] == "factor")
A <- data.frame(a=c("A", NA, "C"))
B <- data.frame(a=c("B", NA, "C"))
(AB <- rbind(A,B))
stopifnot(levels(AB$a) == c("A", "C", "B"))
A <- data.frame(a=I(c("A", NA, "C")))
B <- data.frame(a=I(c("B", NA, "C")))
(AB <- rbind(A,B))
(cl <- sapply(AB, class))
stopifnot(cl[1] == "AsIs")

A <- data.frame(a=1)
A$b <- "A"
B <- data.frame(a=2, b=I("B"))
(AB <- rbind(A,B))
(cl <- sapply(AB, class))
stopifnot(cl[2] == "character")

A <- data.frame(a=1, b="A")
B <- data.frame(a=2, b=I("B"))
(AB <- rbind(A,B))
(cl <- sapply(AB, class))
stopifnot(cl[2] == "factor")
##

## hclust(), as.hclust.twins(), agnes()  consistency
x <- matrix(rnorm(30), ncol=3)  # no observation names
xn <- x; rownames(xn) <- letters[10:1]# has obs. names
hc  <- hclust(dist(x),  method="complete")
hcn <- hclust(dist(xn), method="complete")
iC1 <- !names(hc) %in% c("labels", "call")
stopifnot(identical(hc, hhc <- as.hclust(hc)),
          identical(hhc, as.hclust(hhc)),
          identical(hc[iC1], hcn[iC1]),
          identical(hcn$labels, rownames(xn))
          )
if(require(cluster)) {# is a required package
  ag <- agnes(x, method="complete")
  hcag <- as.hclust(ag)
  agn <- agnes(xn, method="complete")
  hcagn <- as.hclust(agn)
  iC2 <- !names(hcag) %in% c("labels", "call")
  stopifnot(identical(hcagn[iC2], hcag[iC2]),
            identical(hcagn$labels, hcn$labels),
            all.equal(hc$height, hcag$height, tol = 1e-12),
            all(hc$merge == hcag$merge | hc$merge == hcag$merge[ ,2:1])
            )
}
## as.hclust.twins() lost labels and more till (incl) 1.6.2


## keep at end, as package `methods' has had persistent side effects
library(methods)
stopifnot(all.equal(3:3, 3.), all.equal(1., 1:1))
detach("package:methods")
