## 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-10 # typically see around 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 stopifnot(it[c(1,203)] == c(0, 100), all.equal(N * stepfun::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) < 10*.Machine$double.eps) stopifnot(Mod(1+exp(pi*1i)) < 10*.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 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 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 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)) unloadNamespace("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 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" ## method argument is no longer used in det #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 res <- try(data(ships, package = MASS)) if(!inherits(res, "try-error")) { ships.glm <- glm(incidents ~ type + year + period + offset(log(service)), family = poisson, data = ships, subset = (service != 0)) update(ships.glm, start = coef(ships.glm)) } ## 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) unloadNamespace("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 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 ## PR#2867 qr(LAPACK=TRUE) didn't always pivot in 1.7.0 set.seed(1) X <- matrix(rnorm(40),10,4) X[,1] <- X[,2] (qrx <- qr(X, LAPACK=TRUE)) stopifnot(any(qrx$pivot != 1:4)) # check for pivoting ## ## rownames<- did not work on an array with > 2 dims in 1.7.0 A <- array(1:12, dim=c(2, 3, 2)) rownames(A) <- letters[1:2] A <- array(1:12, dim=c(2, 3, 2)) colnames(A) <- 1:3 ## failed in 1.7.0 ## predict on constant model, PR#2958 res <- model.frame(~1, data.frame(x = 1:5)) stopifnot(nrow(res) == 5) res <- predict(lm(y ~ 1, data = data.frame(y = rep(0:3, c(5,9,7,1)))), newdata = data.frame(x = 1:5)) stopifnot(length(res) == 5) res <- predict(glm(y ~ 1, family = poisson, data = data.frame(y = rep(0:3, c(5,9,7,1)))), newdata = data.frame(x = 1:5), type = "r") stopifnot(length(res) == 5) ## all length one in 1.7.0 ## PR#3035 problems with sep > ASCII(127) f <- tempfile() cat("x¦a¦b¦c¦d", "1¦7¦13¦19¦25", "2¦8¦14¦20¦26", "3¦9¦15¦21¦27", "4¦10¦16¦22¦28", "5¦11¦17¦23¦29", "6¦12¦18¦24¦30", sep="\n", file=f) read.table(f, header = TRUE, sep ="¦") ## failed in 1.7.0 ## PR#2993 need to consider delta=NULL in power.t.test{ctest} power.t.test(n=10, delta=NULL, power=.9, alternative="two.sided") ## failed in 1.7.0 ## PR#3221 eigenvectors should be a matrix even in the 1x1 case A <- matrix(1) stopifnot(is.matrix(eigen(A)$vectors)) stopifnot(is.matrix(eigen(A, EISPACK = TRUE)$vectors)) stopifnot(is.matrix(La.eigen(A)$vectors)) ## gave vector in 1.7.0 ## [[<-.data.frame testdata <- data.frame(a=1:2, b = rep(NA, 2)) try(testdata[["a"]] <- strptime(c("31121991", "31121991"), "%d%m%Y")) stopifnot(inherits(.Last.value, "try-error")) ## succeeded in 1.7.0 ## pacf on n x 1 matrix: Paul Gilbert, R-devel, 2003-06-18 z <- as.ts(matrix(rnorm(100), , 1)) class(z) # not "mts" is.matrix(z) # TRUE in 1.7.1 pacf(z) pacf(matrix(rnorm(100), , 1)) ## both failed in 1.7.1. ## lsfit was not setting residuals in the rank=0 case fit <- lsfit(matrix(0, 10, 1), 1:10, intercept=FALSE) stopifnot(fit$residuals == 1:10) ## zero residuals in 1.7.1. ## interval calculations on predict.lm x <- 1:10 y <- rnorm(10) predict(lm(y ~ x), type="terms", interval="confidence") ## ## 0-level factors f <- factor(numeric(0)) sort(f) unique(f) ## both failed in 1.7.1 ## data failed with some multiple inputs data(cars, women) ## failed in 1.7.1 ## body() and formals() looked in different places bar <- function(x=NULL) { foo <- function(y=3) testit() print(formals("foo")) print(body("foo")) } bar() ## the call to body() failed in 1.7.0 ## string NAs shouldn't have any internal structure.(PR#3078) a <- c("NA", NA, "BANANA") na <- as.character(NA) a1 <- substr(a,1,1) stopifnot(is.na(a1)==is.na(a)) a2 <- substring(a,1,1) stopifnot(is.na(a2)==is.na(a)) a3 <- sub("NA","na",a) stopifnot(is.na(a3)==is.na(a)) a3 <- gsub("NA","na",a) stopifnot(is.na(a3)==is.na(a)) substr(a3, 1, 2) <- "na" stopifnot(is.na(a3)==is.na(a)) substr(a3, 1, 2) <- na stopifnot(all(is.na(a3))) stopifnot(agrep("NA", a) == c(1, 3)) stopifnot(grep("NA", a) == c(1, 3)) stopifnot(grep("NA", a, perl=TRUE) == c(1, 3)) stopifnot(all(is.na(agrep(na, a)))) stopifnot(all(is.na(grep(na, a)))) stopifnot(all(is.na(grep(na, a, perl=TRUE)))) a4 <- abbreviate(a) stopifnot(is.na(a4) == is.na(a)) a5 <- chartr("NA", "na", a) stopifnot(is.na(a5) == is.na(a)) a6 <- gsub(na, "na", a) stopifnot(all(is.na(a6))) a6a <- gsub("NANA", na, a) stopifnot(is.na(a6a)==c(FALSE, TRUE, TRUE)) a7 <- a; substr(a7, 1, 2) <- "na" stopifnot(is.na(a7) == is.na(a)) a8 <- a; substr(a8, 1, 2) <- na stopifnot(all(is.na(a8))) stopifnot(identical(a, toupper(tolower(a)))) a9<-strsplit(a, "NA") stopifnot(identical(a9, list("",na,c("BA","")))) a10<-strsplit(a, na) stopifnot(identical(a10, as.list(a))) ## but nchar doesn't fit this pattern stopifnot(all(!is.na(nchar(a)))) ## NA and "NA" were not distinguished in 1.7.x ## coercing 0-length generic vectors as.double(list()) as.integer(list()) as.logical(list()) as.complex(list()) as.character(list()) ## all but the last failed in 1.7.x ## help on reserved words ## if else repeat while function for in next break will fail if(.Platform$OS.type == "windows") options(pager="console") for(topic in c("TRUE", "FALSE", "NULL", "NA", "Inf", "NaN")) { eval(parse(text=paste("?", topic, sep=""))) eval(parse(text=paste("help(", topic, ")", sep=""))) } ## ?NULL and all the help calls fail in 1.7.x ## row names in data frames xx <- structure(1:3, names=letters[1:3]) data.frame(xx) data.frame(xx, yy=1:6) # failed with misleading message in 1.7.x data.frame(xx, yy=1:6, row.names=NULL) # no warning ## ## empty paste stopifnot(length(paste(character(0), character(0))) == 0) # was "" stopifnot(identical(paste(character(0), character(0), collapse="+"), "")) ## ## concatenation of make.names (Tom Minka, R-help, 2003-06-17) a1 <- make.names(c("a", "a", "a"), unique=TRUE) a2 <- make.names(c(make.names(c("a", "a"), unique=TRUE), "a"), unique=TRUE) stopifnot(identical(a1, a2)) df1 <- rbind(data.frame(x=1), data.frame(x=2), data.frame(x=3)) df2 <- rbind(rbind(data.frame(x=1), data.frame(x=2)), data.frame(x=3)) stopifnot(identical(df1, df2)) ## ## PR#3280 data.frame(check.name=FALSE) was not always respected DF <- data.frame(list("a*" = 3), check.names = FALSE) stopifnot(identical(names(DF), "a*")) ## gave "a." in 1.7.1 ## functions using get() were not always looking for functions or in the ## right place x <- factor(1:3) contrasts(x) <- "ctr" test <- function(x) { ctr <- contr.treatment contrasts(x) # failed in 1.7.1 } test(x) ## ## get/exists were ignoring mode in base stopifnot(exists(".Device")) stopifnot(!exists(".Device", mode="function")) # was true in 1.7.1 ## ## inadvertent recursive indexing bug (PR#3324) x <- list(a=1:3, b=2:4) try(x[[c("c", "d")]]) try(x[[c("c", "d")]] <- NA) ## both segfaulted in 1.7.1 ## empty indexing of data frames (PR#3532) x <- data.frame(x = "1.5") num <- numeric(0) x[num] <- list() x[, num] <- list() ## x[[num]] is rightly an error ## x[num] etc failed in 1.7.x. ## .Random.seed was searched for with inherits=TRUE rm(.Random.seed) attach(list(.Random.seed=c(0:4))) runif(1) detach(2) (new <- RNGkind()) stopifnot(identical(new, c("Mersenne-Twister", "Inversion"))) stopifnot(identical(find(".Random.seed"), ".GlobalEnv")) ## took from and assigned to list in 1.7.x. ## PR#3750 y <- c(1, NA, NA, 7) identical(y, qqnorm(y, plot.it=FALSE)$y) ## qqnorm() used to drop NA's in its result till 1.7.x ## PR#3763 d0 <- ISOdate(2001,1,1)[0] # length 0 POSIX (rd0 <- round(d0, "day")) stopifnot(identical(rd0, as.POSIXlt(d0))) ## 2nd line gave floating point exception (in format(*)!) ## New det() function stopifnot(det(m <- cbind(1, c(1, 1))) == 0, determinant(m )$mod == -Inf, determinant(m, log=FALSE)$mod == 0) ## gave error for singular matrices in earlier Aug.2003 ## 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")