diff --git a/.gitignore b/.gitignore
index 323c0ee06b133934f0ed992ad24943247af86886..ff804d8c8061133902e92a4888cde4df41cf8fe2 100644
--- a/.gitignore
+++ b/.gitignore
@@ -26,6 +26,7 @@
/com.oracle.truffle.r.native/gnur/platform.mk.temp*
/com.oracle.truffle.r.native/gnur/R-*
/com.oracle.truffle.r.native/gnur/rcopylib.done
+/com.oracle.truffle.r.native/gnur/tests/log
/com.oracle.truffle.r.native/run/Makeconf.etc
/com.oracle.truffle.r.native/include/*.h
/com.oracle.truffle.r.native/include/R_ext/*.h
diff --git a/ci.hocon b/ci.hocon
index 1d86b07e66f0229f26082509df764a6adfa6ed04..208083f56e5fad2133293a7a19b21ac6b3740bcf 100644
--- a/ci.hocon
+++ b/ci.hocon
@@ -34,6 +34,7 @@ logfiles : [
"com.oracle.truffle.r.native/gnur/R-*/gnur_configure.log"
"com.oracle.truffle.r.native/gnur/R-*/gnur_make.log"
"com.oracle.truffle.r.native/gnur/R-*/Makeconf"
+ "com.oracle.truffle.r.native/gnur/tests/log/all.diff"
"com.oracle.truffle.r.native/gnur/libiconv-*/iconv_configure.log"
"com.oracle.truffle.r.native/gnur/libiconv-*/iconv_make.log"
"*-tests/*.Rout"
@@ -181,6 +182,13 @@ internalPkgtest: ${common} {
logs: ${common.logs}
}
+gnurTests: ${common} {
+ run : [
+ ["mx", "build"]
+ ["mx", "gnu-rtests"]
+ ]
+}
+
# The standard set of gate builds. N.B. the style/builtin checks are only run on Linux as they are not OS-dependent.
builds = [
@@ -192,4 +200,5 @@ builds = [
${internalPkgtest} {capabilities : [linux, amd64], targets : [gate], name: "gate-internal-pkgtest-linux-amd64"}
# ${gateTestManagedLinux} {capabilities : [linux, amd64, fast], targets : [gate], name: "gate-test-managed-linux-amd64"}
${gateTestJava9Linux} {capabilities : [linux, amd64, fast], targets : [gate], name: "gate-test-java9-linux-amd64"}
+ ${gnurTests} {capabilities : [linux, amd64, fast], targets : [gate], name: "gate-gnur-tests"}
]
diff --git a/com.oracle.truffle.r.native/gnur/Makefile b/com.oracle.truffle.r.native/gnur/Makefile
index af3055b9cecac05251d8e6e5f93a787b610def5b..c04bcdb6f701fedf1fdee43bb19304a7b740ed9f 100644
--- a/com.oracle.truffle.r.native/gnur/Makefile
+++ b/com.oracle.truffle.r.native/gnur/Makefile
@@ -1,5 +1,5 @@
#
-# Copyright (c) 2014, 2015, Oracle and/or its affiliates. All rights reserved.
+# Copyright (c) 2014, 2017, Oracle and/or its affiliates. All rights reserved.
# DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
#
# This code is free software; you can redistribute it and/or modify it
@@ -33,6 +33,7 @@ makegnur:
clean: cleangnur
$(MAKE) -f Makefile.libs clean
$(MAKE) -f Makefile.platform clean
+ rm -rf tests/log
ifdef GNUR_NOCLEAN
cleangnur:
diff --git a/com.oracle.truffle.r.native/gnur/tests/README b/com.oracle.truffle.r.native/gnur/tests/README
new file mode 100644
index 0000000000000000000000000000000000000000..c047b86accb916b89a5cef67c90a91b6fd535066
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/README
@@ -0,0 +1,10 @@
+Tests extracted from 'tests' subdirectory of GunR's installation.
+Examples subdirectory contains joined code snippets from Examples section of various builtins.
+
+Some test snippets are currently omitted:
+- Snippet from base-Ex.R requesting load of MASS package.
+- Snippets requiring graphics package.
+
+Tests can be executed by
+ mx gnu-rtests
+
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/CRANtools.R b/com.oracle.truffle.r.native/gnur/tests/src/CRANtools.R
new file mode 100644
index 0000000000000000000000000000000000000000..9fc2ef3dd416aa7084c7f61e2dad8ad9fcb39388
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/CRANtools.R
@@ -0,0 +1,21 @@
+### This needs a full local CRAN mirror or Internet access
+
+.ptime <- proc.time()
+
+## look up CRAN mirror in the same way the functions do.
+mirror <- tools:::CRAN_baseurl_for_web_area()
+message("Using CRAN mirror ", sQuote(mirror))
+
+## Sanity check
+options(warn = 1)
+foo <- tryCatch(readLines(paste0(mirror, "/web/packages")),
+ error = function(e) {
+ message(conditionMessage(e))
+ cat("Time elapsed: ", proc.time() - .ptime,"\n")
+ ## q("no")
+ })
+
+library(tools)
+example("CRAN_package_db", run.donttest = TRUE)
+
+cat("Time elapsed: ", proc.time() - .ptime,"\n")
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/Examples/Sweave-test-1.R b/com.oracle.truffle.r.native/gnur/tests/src/Examples/Sweave-test-1.R
new file mode 100644
index 0000000000000000000000000000000000000000..2d69b7229b7645311532972155c76ddb5bd5e951
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/Examples/Sweave-test-1.R
@@ -0,0 +1,51 @@
+### R code from vignette source '/s/a/k/fastr/library/utils/Sweave/Sweave-test-1.Rnw'
+
+###################################################
+### code chunk number 1: Sweave-test-1.Rnw:15-16
+###################################################
+1:10
+
+
+###################################################
+### code chunk number 2: Sweave-test-1.Rnw:17-18
+###################################################
+print(1:20)
+
+
+###################################################
+### code chunk number 3: Sweave-test-1.Rnw:22-25
+###################################################
+1 + 1
+1 + pi
+sin(pi/2)
+
+
+###################################################
+### code chunk number 4: Sweave-test-1.Rnw:30-34
+###################################################
+library(stats)
+x <- rnorm(20)
+print(x)
+print(t1 <- t.test(x))
+
+
+###################################################
+### code chunk number 5: Sweave-test-1.Rnw:45-47
+###################################################
+data(iris)
+summary(iris)
+
+
+###################################################
+### code chunk number 6: Sweave-test-1.Rnw:53-55
+###################################################
+library(graphics)
+pairs(iris)
+
+
+###################################################
+### code chunk number 7: Sweave-test-1.Rnw:63-64
+###################################################
+boxplot(Sepal.Length~Species, data=iris)
+
+
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/Examples/base-Ex.R b/com.oracle.truffle.r.native/gnur/tests/src/Examples/base-Ex.R
new file mode 100644
index 0000000000000000000000000000000000000000..9617422e0ba6f57b3d40a64ac4f857ca648ceceb
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/Examples/base-Ex.R
@@ -0,0 +1,11040 @@
+pkgname <- "base"
+source(file.path(R.home("share"), "R", "examples-header.R"))
+options(warn = 1)
+base::assign(".oldSearch", base::search(), pos = 'CheckExEnv')
+cleanEx()
+nameEx("Arithmetic")
+### * Arithmetic
+
+flush(stderr()); flush(stdout())
+
+### Name: Arithmetic
+### Title: Arithmetic Operators
+### Aliases: + - * ** / ^ %% %/% Arithmetic
+### Keywords: arith
+
+### ** Examples
+
+x <- -1:12
+x + 1
+2 * x + 3
+x %% 2 #-- is periodic
+x %/% 5
+
+
+
+cleanEx()
+nameEx("Bessel")
+### * Bessel
+
+flush(stderr()); flush(stdout())
+
+### Name: Bessel
+### Title: Bessel Functions
+### Aliases: bessel Bessel besselI besselJ besselK besselY
+### Keywords: math
+
+### ** Examples
+
+require(graphics)
+
+nus <- c(0:5, 10, 20)
+
+x <- seq(0, 4, length.out = 501)
+plot(x, x, ylim = c(0, 6), ylab = "", type = "n",
+ main = "Bessel Functions I_nu(x)")
+for(nu in nus) lines(x, besselI(x, nu = nu), col = nu + 2)
+legend(0, 6, legend = paste("nu=", nus), col = nus + 2, lwd = 1)
+
+x <- seq(0, 40, length.out = 801); yl <- c(-.8, .8)
+plot(x, x, ylim = yl, ylab = "", type = "n",
+ main = "Bessel Functions J_nu(x)")
+for(nu in nus) lines(x, besselJ(x, nu = nu), col = nu + 2)
+legend(32, -.18, legend = paste("nu=", nus), col = nus + 2, lwd = 1)
+
+## Negative nu's :
+xx <- 2:7
+nu <- seq(-10, 9, length.out = 2001)
+op <- par(lab = c(16, 5, 7))
+matplot(nu, t(outer(xx, nu, besselI)), type = "l", ylim = c(-50, 200),
+ main = expression(paste("Bessel ", I[nu](x), " for fixed ", x,
+ ", as ", f(nu))),
+ xlab = expression(nu))
+abline(v = 0, col = "light gray", lty = 3)
+legend(5, 200, legend = paste("x=", xx), col=seq(xx), lty=seq(xx))
+par(op)
+
+x0 <- 2^(-20:10)
+plot(x0, x0^-8, log = "xy", ylab = "", type = "n",
+ main = "Bessel Functions J_nu(x) near 0\n log - log scale")
+for(nu in sort(c(nus, nus+0.5)))
+ lines(x0, besselJ(x0, nu = nu), col = nu + 2)
+legend(3, 1e50, legend = paste("nu=", paste(nus, nus+0.5, sep=",")),
+ col = nus + 2, lwd = 1)
+
+plot(x0, x0^-8, log = "xy", ylab = "", type = "n",
+ main = "Bessel Functions K_nu(x) near 0\n log - log scale")
+for(nu in sort(c(nus, nus+0.5)))
+ lines(x0, besselK(x0, nu = nu), col = nu + 2)
+legend(3, 1e50, legend = paste("nu=", paste(nus, nus + 0.5, sep = ",")),
+ col = nus + 2, lwd = 1)
+
+x <- x[x > 0]
+plot(x, x, ylim = c(1e-18, 1e11), log = "y", ylab = "", type = "n",
+ main = "Bessel Functions K_nu(x)")
+for(nu in nus) lines(x, besselK(x, nu = nu), col = nu + 2)
+legend(0, 1e-5, legend=paste("nu=", nus), col = nus + 2, lwd = 1)
+
+yl <- c(-1.6, .6)
+plot(x, x, ylim = yl, ylab = "", type = "n",
+ main = "Bessel Functions Y_nu(x)")
+for(nu in nus){
+ xx <- x[x > .6*nu]
+ lines(xx, besselY(xx, nu=nu), col = nu+2)
+}
+legend(25, -.5, legend = paste("nu=", nus), col = nus+2, lwd = 1)
+
+## negative nu in bessel_Y -- was bogus for a long time
+curve(besselY(x, -0.1), 0, 10, ylim = c(-3,1), ylab = "")
+for(nu in c(seq(-0.2, -2, by = -0.1)))
+ curve(besselY(x, nu), add = TRUE)
+title(expression(besselY(x, nu) * " " *
+ {nu == list(-0.1, -0.2, ..., -2)}))
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("Colon")
+### * Colon
+
+flush(stderr()); flush(stdout())
+
+### Name: Colon
+### Title: Colon Operator
+### Aliases: : colon
+### Keywords: manip
+
+### ** Examples
+
+1:4
+pi:6 # real
+6:pi # integer
+
+f1 <- gl(2, 3); f1
+f2 <- gl(3, 2); f2
+f1:f2 # a factor, the "cross" f1 x f2
+
+
+
+cleanEx()
+nameEx("Comparison")
+### * Comparison
+
+flush(stderr()); flush(stdout())
+
+### Name: Comparison
+### Title: Relational Operators
+### Aliases: < <= == != >= > Comparison collation
+### Keywords: logic
+
+### ** Examples
+
+x <- stats::rnorm(20)
+x < 1
+x[x > 0]
+
+x1 <- 0.5 - 0.3
+x2 <- 0.3 - 0.1
+x1 == x2 # FALSE on most machines
+identical(all.equal(x1, x2), TRUE) # TRUE everywhere
+
+
+
+cleanEx()
+nameEx("Constants")
+### * Constants
+
+flush(stderr()); flush(stdout())
+
+### Name: Constants
+### Title: Built-in Constants
+### Aliases: Constants LETTERS letters month.abb month.name pi
+### Keywords: sysdata
+
+### ** Examples
+
+## John Machin (ca 1706) computed pi to over 100 decimal places
+## using the Taylor series expansion of the second term of
+pi - 4*(4*atan(1/5) - atan(1/239))
+
+## months in English
+month.name
+## months in your current locale
+format(ISOdate(2000, 1:12, 1), "%B")
+format(ISOdate(2000, 1:12, 1), "%b")
+
+
+
+cleanEx()
+nameEx("Control")
+### * Control
+
+flush(stderr()); flush(stdout())
+
+### Name: Control
+### Title: Control Flow
+### Aliases: Control if else for in while repeat break next
+### Keywords: programming iteration logic
+
+### ** Examples
+
+for(i in 1:5) print(1:i)
+for(n in c(2,5,10,20,50)) {
+ x <- stats::rnorm(n)
+ cat(n, ": ", sum(x^2), "\n", sep = "")
+}
+f <- factor(sample(letters[1:5], 10, replace = TRUE))
+for(i in unique(f)) print(i)
+
+
+
+cleanEx()
+nameEx("Cstack_info")
+### * Cstack_info
+
+flush(stderr()); flush(stdout())
+
+### Name: Cstack_info
+### Title: Report Information on C Stack Size and Usage
+### Aliases: Cstack_info
+### Keywords: utilities
+
+### ** Examples
+
+
+cleanEx()
+nameEx("DateTimeClasses")
+### * DateTimeClasses
+
+flush(stderr()); flush(stdout())
+
+### Name: DateTimeClasses
+### Title: Date-Time Classes
+### Aliases: DateTimeClasses POSIXct POSIXlt POSIXt print.POSIXct
+### print.POSIXlt summary.POSIXct summary.POSIXlt +.POSIXt -.POSIXt
+### Ops.POSIXt Math.POSIXt Summary.POSIXct Math.POSIXlt Summary.POSIXlt
+### [.POSIXct [<-.POSIXct [[.POSIXct [.POSIXlt [<-.POSIXlt
+### as.data.frame.POSIXct as.data.frame.POSIXlt as.list.POSIXct
+### .leap.seconds anyNA.POSIXlt is.na.POSIXlt c.POSIXct c.POSIXlt
+### as.matrix.POSIXlt length.POSIXlt mean.POSIXct mean.POSIXlt str.POSIXt
+### check_tzones duplicated.POSIXlt unique.POSIXlt split.POSIXct
+### names.POSIXlt names<-.POSIXlt date-time
+### Keywords: utilities chron
+
+### ** Examples
+
+
+cleanEx()
+nameEx("Dates")
+### * Dates
+
+flush(stderr()); flush(stdout())
+
+### Name: Dates
+### Title: Date Class
+### Aliases: Date Dates print.Date summary.Date Math.Date Summary.Date
+### [.Date [<-.Date [[.Date as.data.frame.Date as.list.Date c.Date
+### mean.Date split.Date
+### Keywords: utilities chron
+
+### ** Examples
+
+
+cleanEx()
+nameEx("Encoding")
+### * Encoding
+
+flush(stderr()); flush(stdout())
+
+### Name: Encoding
+### Title: Read or Set the Declared Encodings for a Character Vector
+### Aliases: Encoding Encoding<- enc2native enc2utf8
+### Keywords: utilities character
+
+### ** Examples
+
+## x is intended to be in latin1
+x <- "fa\xE7ile"
+Encoding(x)
+Encoding(x) <- "latin1"
+x
+xx <- iconv(x, "latin1", "UTF-8")
+Encoding(c(x, xx))
+c(x, xx)
+Encoding(xx) <- "bytes"
+xx # will be encoded in hex
+cat("xx = ", xx, "\n", sep = "")
+
+
+
+cleanEx()
+nameEx("Extract")
+### * Extract
+
+flush(stderr()); flush(stdout())
+
+### Name: Extract
+### Title: Extract or Replace Parts of an Object
+### Aliases: Extract Subscript [ [.listof [.simple.list [.Dlist [[ $
+### getElement [<- [[<- $<-
+### Keywords: array list
+
+### ** Examples
+
+x <- 1:12
+m <- matrix(1:6, nrow = 2, dimnames = list(c("a", "b"), LETTERS[1:3]))
+li <- list(pi = pi, e = exp(1))
+x[10] # the tenth element of x
+x <- x[-1] # delete the 1st element of x
+m[1,] # the first row of matrix m
+m[1, , drop = FALSE] # is a 1-row matrix
+m[,c(TRUE,FALSE,TRUE)]# logical indexing
+m[cbind(c(1,2,1),3:1)]# matrix numeric index
+ci <- cbind(c("a", "b", "a"), c("A", "C", "B"))
+m[ci] # matrix character index
+m <- m[,-1] # delete the first column of m
+li[[1]] # the first element of list li
+y <- list(1, 2, a = 4, 5)
+y[c(3, 4)] # a list containing elements 3 and 4 of y
+y$a # the element of y named a
+
+## non-integer indices are truncated:
+(i <- 3.999999999) # "4" is printed
+(1:5)[i] # 3
+
+## named atomic vectors, compare "[" and "[[" :
+nx <- c(Abc = 123, pi = pi)
+nx[1] ; nx["pi"] # keeps names, whereas "[[" does not:
+nx[[1]] ; nx[["pi"]]
+## Don't show:
+stopifnot(identical(names(nx[1]), "Abc"),
+ identical(names(nx["pi"]), "pi"),
+ is.null(names(nx[["Abc"]])), is.null(names(nx[[2]])))
+## End(Don't show)
+## recursive indexing into lists
+z <- list(a = list(b = 9, c = "hello"), d = 1:5)
+unlist(z)
+z[[c(1, 2)]]
+z[[c(1, 2, 1)]] # both "hello"
+z[[c("a", "b")]] <- "new"
+unlist(z)
+
+## check $ and [[ for environments
+e1 <- new.env()
+e1$a <- 10
+e1[["a"]]
+e1[["b"]] <- 20
+e1$b
+ls(e1)
+
+## partial matching - possibly with warning :
+stopifnot(identical(li$p, pi))
+op <- options(warnPartialMatchDollar = TRUE)
+stopifnot( identical(li$p, pi), #-- a warning
+ inherits(tryCatch (li$p, warning = identity), "warning"))
+## revert the warning option:
+if(is.null(op[[1]])) op[[1]] <- FALSE; options(op)
+
+
+
+cleanEx()
+nameEx("Extract.data.frame")
+### * Extract.data.frame
+
+flush(stderr()); flush(stdout())
+
+### Name: Extract.data.frame
+### Title: Extract or Replace Parts of a Data Frame
+### Aliases: [.data.frame [[.data.frame [<-.data.frame [[<-.data.frame
+### $.data.frame $<-.data.frame
+### Keywords: array
+
+### ** Examples
+
+sw <- swiss[1:5, 1:4] # select a manageable subset
+
+sw[1:3] # select columns
+sw[, 1:3] # same
+sw[4:5, 1:3] # select rows and columns
+sw[1] # a one-column data frame
+sw[, 1, drop = FALSE] # the same
+sw[, 1] # a (unnamed) vector
+sw[[1]] # the same
+
+sw[1,] # a one-row data frame
+sw[1,, drop = TRUE] # a list
+
+sw["C", ] # partially matches
+sw[match("C", row.names(sw)), ] # no exact match
+try(sw[, "Ferti"]) # column names must match exactly
+
+## Don't show:
+stopifnot(identical(sw[, 1], sw[[1]]),
+ identical(sw[, 1][1], 80.2),
+ identical(sw[, 1, drop = FALSE], sw[1]),
+ is.data.frame(sw[1 ]), dim(sw[1 ]) == c(5, 1),
+ is.data.frame(sw[1,]), dim(sw[1,]) == c(1, 4),
+ is.list(s1 <- sw[1, , drop = TRUE]), identical(s1$Fertility, 80.2))
+tools::assertError(sw[, "Ferti"])
+## End(Don't show)
+swiss[ c(1, 1:2), ] # duplicate row, unique row names are created
+
+sw[sw <= 6] <- 6 # logical matrix indexing
+sw
+
+## adding a column
+sw["new1"] <- LETTERS[1:5] # adds a character column
+sw[["new2"]] <- letters[1:5] # ditto
+sw[, "new3"] <- LETTERS[1:5] # ditto
+sw$new4 <- 1:5
+sapply(sw, class)
+sw$new4 <- NULL # delete the column
+sw
+sw[6:8] <- list(letters[10:14], NULL, aa = 1:5)
+# update col. 6, delete 7, append
+sw
+
+## matrices in a data frame
+A <- data.frame(x = 1:3, y = I(matrix(4:9, 3, 2)),
+ z = I(matrix(letters[1:9], 3, 3)))
+A[1:3, "y"] # a matrix
+A[1:3, "z"] # a matrix
+A[, "y"] # a matrix
+stopifnot(identical(colnames(A), c("x", "y", "z")), ncol(A) == 3L,
+ identical(A[,"y"], A[1:3, "y"]),
+ inherits (A[,"y"], "AsIs"))
+
+## keeping special attributes: use a class with a
+## "as.data.frame" and "[" method;
+## "avector" := vector that keeps attributes. Could provide a constructor
+## avector <- function(x) { class(x) <- c("avector", class(x)); x }
+as.data.frame.avector <- as.data.frame.vector
+
+`[.avector` <- function(x,i,...) {
+ r <- NextMethod("[")
+ mostattributes(r) <- attributes(x)
+ r
+}
+
+d <- data.frame(i = 0:7, f = gl(2,4),
+ u = structure(11:18, unit = "kg", class = "avector"))
+str(d[2:4, -1]) # 'u' keeps its "unit"
+## Don't show:
+stopifnot(identical(d[2:4,-1][,"u"],
+ structure(12:14, unit = "kg", class = "avector")))
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("Extract.factor")
+### * Extract.factor
+
+flush(stderr()); flush(stdout())
+
+### Name: Extract.factor
+### Title: Extract or Replace Parts of a Factor
+### Aliases: [.factor [<-.factor [[.factor [[<-.factor
+### Keywords: category
+
+### ** Examples
+
+## following example(factor)
+(ff <- factor(substring("statistics", 1:10, 1:10), levels = letters))
+ff[, drop = TRUE]
+factor(letters[7:10])[2:3, drop = TRUE]
+
+
+
+cleanEx()
+nameEx("Extremes")
+### * Extremes
+
+flush(stderr()); flush(stdout())
+
+### Name: Extremes
+### Title: Maxima and Minima
+### Aliases: max min pmax pmin pmax.int pmin.int
+### Keywords: univar arith
+
+### ** Examples
+
+require(stats); require(graphics)
+ min(5:1, pi) #-> one number
+pmin(5:1, pi) #-> 5 numbers
+
+x <- sort(rnorm(100)); cH <- 1.35
+pmin(cH, quantile(x)) # no names
+pmin(quantile(x), cH) # has names
+plot(x, pmin(cH, pmax(-cH, x)), type = "b", main = "Huber's function")
+
+cut01 <- function(x) pmax(pmin(x, 1), 0)
+curve( x^2 - 1/4, -1.4, 1.5, col = 2)
+curve(cut01(x^2 - 1/4), col = "blue", add = TRUE, n = 500)
+## pmax(), pmin() preserve attributes of *first* argument
+D <- diag(x = (3:1)/4) ; n0 <- numeric()
+stopifnot(identical(D, cut01(D) ),
+ identical(n0, cut01(n0)),
+ identical(n0, cut01(NULL)),
+ identical(n0, pmax(3:1, n0, 2)),
+ identical(n0, pmax(n0, 4)))
+
+
+
+cleanEx()
+nameEx("La_library")
+### * La_library
+
+flush(stderr()); flush(stdout())
+
+### Name: La_library
+### Title: LAPACK Library
+### Aliases: La_library
+### Keywords: utilities
+
+### ** Examples
+
+La_library()
+
+
+
+cleanEx()
+nameEx("La_version")
+### * La_version
+
+flush(stderr()); flush(stdout())
+
+### Name: La_version
+### Title: LAPACK Version
+### Aliases: La_version
+### Keywords: utilities
+
+### ** Examples
+
+La_version()
+
+
+
+cleanEx()
+nameEx("Last.value")
+### * Last.value
+
+flush(stderr()); flush(stdout())
+
+### Name: Last.value
+### Title: Value of Last Evaluated Expression
+### Aliases: .Last.value
+### Keywords: programming
+
+### ** Examples
+
+## These will not work correctly from example(),
+## but they will in make check or if pasted in,
+## as example() does not run them at the top level
+gamma(1:15) # think of some intensive calculation...
+fac14 <- .Last.value # keep them
+
+library("splines") # returns invisibly
+.Last.value # shows what library(.) above returned
+## Don't show:
+detach("package:splines")
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("Log")
+### * Log
+
+flush(stderr()); flush(stdout())
+
+### Name: log
+### Title: Logarithms and Exponentials
+### Aliases: log logb log10 log2 log1p exp expm1
+### Keywords: math
+
+### ** Examples
+
+log(exp(3))
+log10(1e7) # = 7
+
+x <- 10^-(1+2*1:9)
+cbind(x, log(1+x), log1p(x), exp(x)-1, expm1(x))
+
+
+
+cleanEx()
+nameEx("Logic")
+### * Logic
+
+flush(stderr()); flush(stdout())
+
+### Name: Logic
+### Title: Logical Operators
+### Aliases: ! & && | || xor Logic isTRUE
+### Keywords: logic
+
+### ** Examples
+
+y <- 1 + (x <- stats::rpois(50, lambda = 1.5) / 4 - 1)
+x[(x > 0) & (x < 1)] # all x values between 0 and 1
+if (any(x == 0) || any(y == 0)) "zero encountered"
+
+## construct truth tables :
+
+x <- c(NA, FALSE, TRUE)
+names(x) <- as.character(x)
+outer(x, x, "&") ## AND table
+outer(x, x, "|") ## OR table
+
+
+
+cleanEx()
+nameEx("MathFun")
+### * MathFun
+
+flush(stderr()); flush(stdout())
+
+### Name: MathFun
+### Title: Miscellaneous Mathematical Functions
+### Aliases: abs sqrt
+### Keywords: math
+
+### ** Examples
+
+require(stats) # for spline
+require(graphics)
+xx <- -9:9
+plot(xx, sqrt(abs(xx)), col = "red")
+lines(spline(xx, sqrt(abs(xx)), n=101), col = "pink")
+
+
+
+cleanEx()
+nameEx("NA")
+### * NA
+
+flush(stderr()); flush(stdout())
+
+### Name: NA
+### Title: 'Not Available' / Missing Values
+### Aliases: NA NA_integer_ NA_real_ NA_complex_ NA_character_ is.na
+### is.na.data.frame is.na<- is.na<-.default anyNA anyMissing
+### Keywords: NA logic manip
+
+### ** Examples
+
+is.na(c(1, NA)) #> FALSE TRUE
+is.na(paste(c(1, NA))) #> FALSE FALSE
+
+(xx <- c(0:4))
+is.na(xx) <- c(2, 4)
+xx #> 0 NA 2 NA 4
+anyNA(xx) # TRUE
+
+# Some logical operations do not return NA
+c(TRUE, FALSE) & NA
+c(TRUE, FALSE) | NA
+
+
+## anyNA() can work recursively with list()s:
+LL <- list(1:5, c(NA, 5:8), c("A","NA"), c("a", NA_character_))
+L2 <- LL[c(1,3)]
+sapply(LL, anyNA); c(anyNA(LL), anyNA(LL, TRUE))
+sapply(L2, anyNA); c(anyNA(L2), anyNA(L2, TRUE))
+
+## ... lists, and hence data frames, too:
+dN <- dd <- USJudgeRatings; dN[3,6] <- NA
+anyNA(dd) # FALSE
+anyNA(dN) # TRUE
+
+
+
+cleanEx()
+nameEx("NULL")
+### * NULL
+
+flush(stderr()); flush(stdout())
+
+### Name: NULL
+### Title: The Null Object
+### Aliases: NULL as.null as.null.default is.null
+### Keywords: attribute manip list sysdata
+
+### ** Examples
+
+is.null(list()) # FALSE (on purpose!)
+is.null(pairlist()) # TRUE
+is.null(integer(0)) # FALSE
+is.null(logical(0)) # FALSE
+as.null(list(a = 1, b = "c"))
+
+
+
+cleanEx()
+nameEx("NumericConstants")
+### * NumericConstants
+
+flush(stderr()); flush(stdout())
+
+### Name: NumericConstants
+### Title: Numeric Constants
+### Aliases: NumericConstants 1L 0x1 1i
+### Keywords: documentation
+
+### ** Examples
+
+## You can create numbers using fixed or scientific formatting.
+2.1
+2.1e10
+-2.1E-10
+
+## The resulting objects have class numeric and type double.
+class(2.1)
+typeof(2.1)
+
+## This holds even if what you typed looked like an integer.
+class(2)
+typeof(2)
+
+## If you actually wanted integers, use an "L" suffix.
+class(2L)
+typeof(2L)
+
+## These are equal but not identical
+2 == 2L
+identical(2, 2L)
+
+## You can write numbers between 0 and 1 without a leading "0"
+## (but typically this makes code harder to read)
+.1234
+
+sqrt(1i) # remember elementary math?
+utils::str(0xA0)
+identical(1L, as.integer(1))
+
+## You can combine the "0x" prefix with the "L" suffix :
+identical(0xFL, as.integer(15))
+
+
+
+cleanEx()
+nameEx("Ops.Date")
+### * Ops.Date
+
+flush(stderr()); flush(stdout())
+
+### Name: Ops.Date
+### Title: Operators on the Date Class
+### Aliases: +.Date -.Date Ops.Date
+### Keywords: utilities chron
+
+### ** Examples
+
+
+cleanEx()
+nameEx("Paren")
+### * Paren
+
+flush(stderr()); flush(stdout())
+
+### Name: Paren
+### Title: Parentheses and Braces
+### Aliases: Paren ( {
+### Keywords: programming
+
+### ** Examples
+
+f <- get("(")
+e <- expression(3 + 2 * 4)
+identical(f(e), e)
+
+do <- get("{")
+do(x <- 3, y <- 2*x-3, 6-x-y); x; y
+
+## note the differences
+(2+3)
+{2+3; 4+5}
+(invisible(2+3))
+{invisible(2+3)}
+
+
+
+cleanEx()
+nameEx("Platform")
+### * Platform
+
+flush(stderr()); flush(stdout())
+
+### Name: .Platform
+### Title: Platform Specific Variables
+### Aliases: .Platform
+### Keywords: file utilities
+
+### ** Examples
+
+## Note: this can be done in a system-independent way by dir.exists()
+if(.Platform$OS.type == "unix") {
+ system.test <- function(...) system(paste("test", ...)) == 0L
+ dir.exists2 <- function(dir)
+ sapply(dir, function(d) system.test("-d", d))
+ dir.exists2(c(R.home(), "/tmp", "~", "/NO")) # > T T T F
+}
+
+
+
+cleanEx()
+nameEx("Primitive")
+### * Primitive
+
+flush(stderr()); flush(stdout())
+
+### Name: Primitive
+### Title: Look Up a Primitive Function
+### Aliases: .Primitive primitive
+### Keywords: interface
+
+### ** Examples
+
+mysqrt <- .Primitive("sqrt")
+c
+.Internal # this one *must* be primitive!
+`if` # need backticks
+
+
+
+cleanEx()
+nameEx("Quotes")
+### * Quotes
+
+flush(stderr()); flush(stdout())
+
+### Name: Quotes
+### Title: Quotes
+### Aliases: Quotes backtick backquote ' " `
+### Keywords: documentation
+
+### ** Examples
+
+'single quotes can be used more-or-less interchangeably'
+"with double quotes to create character vectors"
+
+## Single quotes inside single-quoted strings need backslash-escaping.
+## Ditto double quotes inside double-quoted strings.
+##
+identical('"It\'s alive!", he screamed.',
+ "\"It's alive!\", he screamed.") # same
+
+## Backslashes need doubling, or they have a special meaning.
+x <- "In ALGOL, you could do logical AND with /\\."
+print(x) # shows it as above ("input-like")
+writeLines(x) # shows it as you like it ;-)
+
+## Single backslashes followed by a letter are used to denote
+## special characters like tab(ulator)s and newlines:
+x <- "long\tlines can be\nbroken with newlines"
+writeLines(x) # see also ?strwrap
+
+## Backticks are used for non-standard variable names.
+## (See make.names and ?Reserved for what counts as
+## non-standard.)
+`x y` <- 1:5
+`x y`
+d <- data.frame(`1st column` = rchisq(5, 2), check.names = FALSE)
+d$`1st column`
+
+## Backslashes followed by up to three numbers are interpreted as
+## octal notation for ASCII characters.
+"\110\145\154\154\157\40\127\157\162\154\144\41"
+
+## \x followed by up to two numbers is interpreted as
+## hexadecimal notation for ASCII characters.
+(hw1 <- "\x48\x65\x6c\x6c\x6f\x20\x57\x6f\x72\x6c\x64\x21")
+
+## Mixing octal and hexadecimal in the same string is OK
+(hw2 <- "\110\x65\154\x6c\157\x20\127\x6f\162\x6c\144\x21")
+
+## \u is also hexadecimal, but supported up to 4 numbers,
+## using Unicode specification. In the previous example,
+## you can simply replace \x with \u.
+(hw3 <- "\u48\u65\u6c\u6c\u6f\u20\u57\u6f\u72\u6c\u64\u21")
+
+## The last three are all identical to
+hw <- "Hello World!"
+stopifnot(identical(hw, hw1), identical(hw1, hw2), identical(hw2, hw3))
+
+## Using Unicode makes more sense for non-latin characters.
+(nn <- "\u0126\u0119\u1114\u022d\u2001\u03e2\u0954\u0f3f\u13d3\u147b\u203c")
+
+## Mixing \x and \u throws a _parse_ error (which is not catchable!)
+## Not run:
+##D "\x48\u65\x6c\u6c\x6f\u20\x57\u6f\x72\u6c\x64\u21"
+## End(Not run)
+## --> Error: mixing Unicode and octal/hex escapes .....
+
+## \U works like \u, but supports up to eight numbers.
+## So we can replace \u with \U in the previous example.
+n2 <- "\U0126\U0119\U1114\U022d\U2001\U03e2\U0954\U0f3f\U13d3\U147b\U203c"
+stopifnot(identical(nn, n2))
+
+## Under systems supporting multi-byte locales (and not Windows),
+## \U also supports the rarer characters outside the usual 16^4 range.
+## See the R language manual,
+## https://cran.r-project.org/doc/manuals/r-release/R-lang.html#Literal-constants
+## and bug 16098 https://bugs.r-project.org/bugzilla3/show_bug.cgi?id=16098
+"\U1d4d7" # On Windows this gives the incorrect value of "\Ud4d7"
+
+## nul characters (for terminating strings in C) are not allowed (parse errors)
+## Not run: ##D
+##D "foo\0bar" # Error: nul character not allowed (line 1)
+##D "foo\u0000bar" # same error
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("Random-user")
+### * Random-user
+
+flush(stderr()); flush(stdout())
+
+### Name: Random.user
+### Title: User-supplied Random Number Generation
+### Aliases: Random.user
+### Keywords: distribution sysdata
+
+### ** Examples
+## Not run:
+##D ## Marsaglia's congruential PRNG
+##D #include <R_ext/Random.h>
+##D
+##D static Int32 seed;
+##D static double res;
+##D static int nseed = 1;
+##D
+##D double * user_unif_rand()
+##D {
+##D seed = 69069 * seed + 1;
+##D res = seed * 2.32830643653869e-10;
+##D return &res;
+##D }
+##D
+##D void user_unif_init(Int32 seed_in) { seed = seed_in; }
+##D int * user_unif_nseed() { return &nseed; }
+##D int * user_unif_seedloc() { return (int *) &seed; }
+##D
+##D /* ratio-of-uniforms for normal */
+##D #include <math.h>
+##D static double x;
+##D
+##D double * user_norm_rand()
+##D {
+##D double u, v, z;
+##D do {
+##D u = unif_rand();
+##D v = 0.857764 * (2. * unif_rand() - 1);
+##D x = v/u; z = 0.25 * x * x;
+##D if (z < 1. - u) break;
+##D if (z > 0.259/u + 0.35) continue;
+##D } while (z > -log(u));
+##D return &x;
+##D }
+##D
+##D ## Use under Unix:
+##D R CMD SHLIB urand.c
+##D R
+##D > dyn.load("urand.so")
+##D > RNGkind("user")
+##D > runif(10)
+##D > .Random.seed
+##D > RNGkind(, "user")
+##D > rnorm(10)
+##D > RNGkind()
+##D [1] "user-supplied" "user-supplied"
+## End(Not run)
+
+
+cleanEx()
+nameEx("Random")
+### * Random
+
+flush(stderr()); flush(stdout())
+
+### Name: Random
+### Title: Random Number Generation
+### Aliases: Random RNG RNGkind RNGversion set.seed .Random.seed
+### Keywords: distribution sysdata
+
+### ** Examples
+
+
+cleanEx()
+nameEx("Recall")
+### * Recall
+
+flush(stderr()); flush(stdout())
+
+### Name: Recall
+### Title: Recursive Calling
+### Aliases: Recall
+### Keywords: programming
+
+### ** Examples
+
+## A trivial (but inefficient!) example:
+fib <- function(n)
+ if(n<=2) { if(n>=0) 1 else 0 } else Recall(n-1) + Recall(n-2)
+fibonacci <- fib; rm(fib)
+## renaming wouldn't work without Recall
+fibonacci(10) # 55
+
+
+
+cleanEx()
+nameEx("Round")
+### * Round
+
+flush(stderr()); flush(stdout())
+
+### Name: Round
+### Title: Rounding of Numbers
+### Aliases: ceiling floor round signif trunc
+### Keywords: arith
+
+### ** Examples
+
+round(.5 + -2:4) # IEEE rounding: -2 0 0 2 2 4 4
+( x1 <- seq(-2, 4, by = .5) )
+round(x1) #-- IEEE rounding !
+x1[trunc(x1) != floor(x1)]
+x1[round(x1) != floor(x1 + .5)]
+(non.int <- ceiling(x1) != floor(x1))
+
+x2 <- pi * 100^(-1:3)
+round(x2, 3)
+signif(x2, 3)
+
+
+
+cleanEx()
+nameEx("Special")
+### * Special
+
+flush(stderr()); flush(stdout())
+
+### Name: Special
+### Title: Special Functions of Mathematics
+### Aliases: Special beta lbeta gamma lgamma psigamma digamma trigamma
+### choose lchoose factorial lfactorial
+### Keywords: math
+
+### ** Examples
+
+require(graphics)
+
+choose(5, 2)
+for (n in 0:10) print(choose(n, k = 0:n))
+
+factorial(100)
+lfactorial(10000)
+
+## gamma has 1st order poles at 0, -1, -2, ...
+## this will generate loss of precision warnings, so turn off
+op <- options("warn")
+options(warn = -1)
+x <- sort(c(seq(-3, 4, length.out = 201), outer(0:-3, (-1:1)*1e-6, "+")))
+plot(x, gamma(x), ylim = c(-20,20), col = "red", type = "l", lwd = 2,
+ main = expression(Gamma(x)))
+abline(h = 0, v = -3:0, lty = 3, col = "midnightblue")
+options(op)
+
+x <- seq(0.1, 4, length.out = 201); dx <- diff(x)[1]
+par(mfrow = c(2, 3))
+for (ch in c("", "l","di","tri","tetra","penta")) {
+ is.deriv <- nchar(ch) >= 2
+ nm <- paste0(ch, "gamma")
+ if (is.deriv) {
+ dy <- diff(y) / dx # finite difference
+ der <- which(ch == c("di","tri","tetra","penta")) - 1
+ nm2 <- paste0("psigamma(*, deriv = ", der,")")
+ nm <- if(der >= 2) nm2 else paste(nm, nm2, sep = " ==\n")
+ y <- psigamma(x, deriv = der)
+ } else {
+ y <- get(nm)(x)
+ }
+ plot(x, y, type = "l", main = nm, col = "red")
+ abline(h = 0, col = "lightgray")
+ if (is.deriv) lines(x[-1], dy, col = "blue", lty = 2)
+}
+par(mfrow = c(1, 1))
+
+## "Extended" Pascal triangle:
+fN <- function(n) formatC(n, width=2)
+for (n in -4:10) {
+ cat(fN(n),":", fN(choose(n, k = -2:max(3, n+2))))
+ cat("\n")
+}
+
+## R code version of choose() [simplistic; warning for k < 0]:
+mychoose <- function(r, k)
+ ifelse(k <= 0, (k == 0),
+ sapply(k, function(k) prod(r:(r-k+1))) / factorial(k))
+k <- -1:6
+cbind(k = k, choose(1/2, k), mychoose(1/2, k))
+
+## Binomial theorem for n = 1/2 ;
+## sqrt(1+x) = (1+x)^(1/2) = sum_{k=0}^Inf choose(1/2, k) * x^k :
+k <- 0:10 # 10 is sufficient for ~ 9 digit precision:
+sqrt(1.25)
+sum(choose(1/2, k)* .25^k)
+
+## Don't show:
+k. <- 1:9
+stopifnot(all.equal( (choose(1/2, k.) -> ck.),
+ mychoose(1/2, k.)),
+ all.equal(lchoose(1/2, k.), log(abs(ck.))),
+ all.equal(sqrt(1.25),
+ sum(choose(1/2, k)* .25^k)))
+## End(Don't show)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("Startup")
+### * Startup
+
+flush(stderr()); flush(stdout())
+
+### Name: Startup
+### Title: Initialization at Start of an R Session
+### Aliases: Startup Rprofile .Rprofile Rprofile.site Renviron
+### Renviron.site .Renviron .First .First.sys .OptRequireMethods
+### R_DEFAULT_PACKAGES R_ENVIRON R_ENVIRON_USER R_PROFILE R_PROFILE_USER
+### Keywords: environment
+
+### ** Examples
+
+## Not run:
+##D ## Example ~/.Renviron on Unix
+##D R_LIBS=~/R/library
+##D PAGER=/usr/local/bin/less
+##D
+##D ## Example .Renviron on Windows
+##D R_LIBS=C:/R/library
+##D MY_TCLTK="c:/Program Files/Tcl/bin"
+##D
+##D ## Example of setting R_DEFAULT_PACKAGES (from R CMD check)
+##D R_DEFAULT_PACKAGES='utils,grDevices,graphics,stats'
+##D # this loads the packages in the order given, so they appear on
+##D # the search path in reverse order.
+##D
+##D ## Example of .Rprofile
+##D options(width=65, digits=5)
+##D options(show.signif.stars=FALSE)
+##D setHook(packageEvent("grDevices", "onLoad"),
+##D function(...) grDevices::ps.options(horizontal=FALSE))
+##D set.seed(1234)
+##D .First <- function() cat("\n Welcome to R!\n\n")
+##D .Last <- function() cat("\n Goodbye!\n\n")
+##D
+##D ## Example of Rprofile.site
+##D local({
+##D # add MASS to the default packages, set a CRAN mirror
+##D old <- getOption("defaultPackages"); r <- getOption("repos")
+##D r["CRAN"] <- "http://my.local.cran"
+##D options(defaultPackages = c(old, "MASS"), repos = r)
+##D ## (for Unix terminal users) set the width from COLUMNS if set
+##D cols <- Sys.getenv("COLUMNS")
+##D if(nzchar(cols)) options(width = as.integer(cols))
+##D # interactive sessions get a fortune cookie (needs fortunes package)
+##D if (interactive())
+##D fortunes::fortune()
+##D })
+##D
+##D ## if .Renviron contains
+##D FOOBAR="coo\bar"doh\ex"abc\"def'"
+##D
+##D ## then we get
+##D # > cat(Sys.getenv("FOOBAR"), "\n")
+##D # coo\bardoh\exabc"def'
+## End(Not run)
+
+
+cleanEx()
+nameEx("Syntax")
+### * Syntax
+
+flush(stderr()); flush(stdout())
+
+### Name: Syntax
+### Title: Operator Syntax and Precedence
+### Aliases: Syntax
+### Keywords: documentation programming
+
+### ** Examples
+
+## Logical AND ("&&") has higher precedence than OR ("||"):
+TRUE || TRUE && FALSE # is the same as
+TRUE || (TRUE && FALSE) # and different from
+(TRUE || TRUE) && FALSE
+
+## Special operators have higher precedence than "!" (logical NOT).
+## You can use this for %in% :
+! 1:10 %in% c(2, 3, 5, 7) # same as !(1:10 %in% c(2, 3, 5, 7))
+## but we strongly advise to use the "!( ... )" form in this case!
+
+
+## '=' has lower precedence than '<-' ... so you should not mix them
+## (and '<-' is considered better style anyway):
+
+
+
+cleanEx()
+nameEx("Sys.getenv")
+### * Sys.getenv
+
+flush(stderr()); flush(stdout())
+
+### Name: Sys.getenv
+### Title: Get Environment Variables
+### Aliases: Sys.getenv
+### Keywords: environment utilities
+
+### ** Examples
+
+## whether HOST is set will be shell-dependent e.g. Solaris' csh does not.
+Sys.getenv(c("R_HOME", "R_PAPERSIZE", "R_PRINTCMD", "HOST"))
+
+names(s <- Sys.getenv()) # all settings (the values could be very long)
+head(s, 12)# using the Dlist print() method
+
+## Language and Locale settings -- but rather use Sys.getlocale()
+s[grep("^L(C|ANG)", names(s))]
+
+
+
+cleanEx()
+nameEx("Sys.getpid")
+### * Sys.getpid
+
+flush(stderr()); flush(stdout())
+
+### Name: Sys.getpid
+### Title: Get the Process ID of the R Session
+### Aliases: Sys.getpid
+### Keywords: utilities
+
+### ** Examples
+
+
+cleanEx()
+nameEx("Sys.glob")
+### * Sys.glob
+
+flush(stderr()); flush(stdout())
+
+### Name: Sys.glob
+### Title: Wildcard Expansion on File Paths
+### Aliases: Sys.glob
+### Keywords: utilities file
+
+### ** Examples
+
+
+
+cleanEx()
+nameEx("Sys.info")
+### * Sys.info
+
+flush(stderr()); flush(stdout())
+
+### Name: Sys.info
+### Title: Extract System and User Information
+### Aliases: Sys.info
+### Keywords: utilities
+
+### ** Examples
+
+Sys.info()
+## An alternative (and probably better) way to get the login name on Unix
+Sys.getenv("LOGNAME")
+
+
+
+cleanEx()
+nameEx("Sys.localeconv")
+### * Sys.localeconv
+
+flush(stderr()); flush(stdout())
+
+### Name: Sys.localeconv
+### Title: Find Details of the Numerical and Monetary Representations in
+### the Current Locale
+### Aliases: localeconv Sys.localeconv
+### Keywords: utilities
+
+### ** Examples
+
+Sys.localeconv()
+## The results in the C locale are
+## decimal_point thousands_sep grouping int_curr_symbol
+## "." "" "" ""
+## currency_symbol mon_decimal_point mon_thousands_sep mon_grouping
+## "" "" "" ""
+## positive_sign negative_sign int_frac_digits frac_digits
+## "" "" "127" "127"
+## p_cs_precedes p_sep_by_space n_cs_precedes n_sep_by_space
+## "127" "127" "127" "127"
+## p_sign_posn n_sign_posn
+## "127" "127"
+
+## Now try your default locale (which might be "C").
+
+## Not run: read.table("foo", dec=Sys.localeconv()["decimal_point"])
+
+
+
+cleanEx()
+nameEx("Sys.setenv")
+### * Sys.setenv
+
+flush(stderr()); flush(stdout())
+
+### Name: Sys.setenv
+### Title: Set or Unset Environment Variables
+### Aliases: Sys.setenv Sys.unsetenv
+### Keywords: environment utilities
+
+### ** Examples
+
+print(Sys.setenv(R_TEST = "testit", "A+C" = 123)) # `A+C` could also be used
+Sys.getenv("R_TEST")
+Sys.unsetenv("R_TEST") # may warn and not succeed
+Sys.getenv("R_TEST", unset = NA)
+
+
+
+cleanEx()
+nameEx("Sys.sleep")
+### * Sys.sleep
+
+flush(stderr()); flush(stdout())
+
+### Name: Sys.sleep
+### Title: Suspend Execution for a Time Interval
+### Aliases: Sys.sleep
+### Keywords: utilities
+
+### ** Examples
+
+
+cleanEx()
+nameEx("Sys.time")
+### * Sys.time
+
+flush(stderr()); flush(stdout())
+
+### Name: Sys.time
+### Title: Get Current Date and Time
+### Aliases: Sys.time Sys.Date
+### Keywords: utilities chron
+
+### ** Examples
+
+
+cleanEx()
+nameEx("Sys.which")
+### * Sys.which
+
+flush(stderr()); flush(stdout())
+
+### Name: Sys.which
+### Title: Find Full Paths to Executables
+### Aliases: Sys.which
+### Keywords: utilities
+
+### ** Examples
+
+## the first two are likely to exist everywhere
+## texi2dvi exists on most Unix-alikes and under MiKTeX
+Sys.which(c("ftp", "ping", "texi2dvi", "this-does-not-exist"))
+
+
+
+cleanEx()
+nameEx("Trig")
+### * Trig
+
+flush(stderr()); flush(stdout())
+
+### Name: Trig
+### Title: Trigonometric Functions
+### Aliases: Trig cos sin tan acos arccos asin arcsin atan arctan atan2
+### cospi sinpi tanpi
+### Keywords: math
+
+### ** Examples
+
+x <- seq(-3, 7, by = 1/8)
+tx <- cbind(x, cos(pi*x), cospi(x), sin(pi*x), sinpi(x),
+ tan(pi*x), tanpi(x), deparse.level=2)
+op <- options(digits = 4, width = 90) # for nice formatting
+head(tx)
+tx[ (x %% 1) %in% c(0, 0.5) ,]
+options(op)
+
+
+
+cleanEx()
+nameEx("Vectorize")
+### * Vectorize
+
+flush(stderr()); flush(stdout())
+
+### Name: Vectorize
+### Title: Vectorize a Scalar Function
+### Aliases: Vectorize
+### Keywords: manip utilities
+
+### ** Examples
+
+# We use rep.int as rep is primitive
+vrep <- Vectorize(rep.int)
+vrep(1:4, 4:1)
+vrep(times = 1:4, x = 4:1)
+
+vrep <- Vectorize(rep.int, "times")
+vrep(times = 1:4, x = 42)
+
+f <- function(x = 1:3, y) c(x, y)
+vf <- Vectorize(f, SIMPLIFY = FALSE)
+f(1:3, 1:3)
+vf(1:3, 1:3)
+vf(y = 1:3) # Only vectorizes y, not x
+
+# Nonlinear regression contour plot, based on nls() example
+require(graphics)
+SS <- function(Vm, K, resp, conc) {
+ pred <- (Vm * conc)/(K + conc)
+ sum((resp - pred)^2 / pred)
+}
+vSS <- Vectorize(SS, c("Vm", "K"))
+Treated <- subset(Puromycin, state == "treated")
+
+Vm <- seq(140, 310, length.out = 50)
+K <- seq(0, 0.15, length.out = 40)
+SSvals <- outer(Vm, K, vSS, Treated$rate, Treated$conc)
+contour(Vm, K, SSvals, levels = (1:10)^2, xlab = "Vm", ylab = "K")
+
+# combn() has an argument named FUN
+combnV <- Vectorize(function(x, m, FUNV = NULL) combn(x, m, FUN = FUNV),
+ vectorize.args = c("x", "m"))
+combnV(4, 1:4)
+combnV(4, 1:4, sum)
+
+
+
+cleanEx()
+nameEx("Version")
+### * Version
+
+flush(stderr()); flush(stdout())
+
+### Name: R.Version
+### Title: Version Information
+### Aliases: R.Version R.version version R.version.string
+### Keywords: environment sysdata programming
+
+### ** Examples
+
+require(graphics)
+
+R.version$os # to check how lucky you are ...
+plot(0) # any plot
+mtext(R.version.string, side = 1, line = 4, adj = 1) # a useful bottom-right note
+
+## a good way to detect macOS:
+if(grepl("^darwin", R.version$os)) message("running on macOS")
+
+
+
+cleanEx()
+nameEx("abbreviate")
+### * abbreviate
+
+flush(stderr()); flush(stdout())
+
+### Name: abbreviate
+### Title: Abbreviate Strings
+### Aliases: abbreviate
+### Keywords: character
+
+### ** Examples
+
+x <- c("abcd", "efgh", "abce")
+abbreviate(x, 2)
+abbreviate(x, 2, strict = TRUE) # >> 1st and 3rd are == "ab"
+
+(st.abb <- abbreviate(state.name, 2))
+stopifnot(identical(unname(st.abb),
+ abbreviate(state.name, 2, named=FALSE)))
+table(nchar(st.abb)) # out of 50, 3 need 4 letters :
+as <- abbreviate(state.name, 3, strict = TRUE)
+as[which(as == "Mss")]
+## Don't show:
+stopifnot(which(as == "Mss") == c(21,24,25))
+## End(Don't show)
+## and without distinguishing vowels:
+st.abb2 <- abbreviate(state.name, 2, FALSE)
+cbind(st.abb, st.abb2)[st.abb2 != st.abb, ]
+
+## method = "both.sides" helps: no 4-letters, and only 4 3-letters:
+st.ab2 <- abbreviate(state.name, 2, method = "both")
+table(nchar(st.ab2))
+## Compare the two methods:
+cbind(st.abb, st.ab2)
+
+
+
+cleanEx()
+nameEx("agrep")
+### * agrep
+
+flush(stderr()); flush(stdout())
+
+### Name: agrep
+### Title: Approximate String Matching (Fuzzy Matching)
+### Aliases: agrep agrepl 'fuzzy matching' .amatch_bounds .amatch_costs
+### Keywords: character
+
+### ** Examples
+
+agrep("lasy", "1 lazy 2")
+agrep("lasy", c(" 1 lazy 2", "1 lasy 2"), max = list(sub = 0))
+agrep("laysy", c("1 lazy", "1", "1 LAZY"), max = 2)
+agrep("laysy", c("1 lazy", "1", "1 LAZY"), max = 2, value = TRUE)
+agrep("laysy", c("1 lazy", "1", "1 LAZY"), max = 2, ignore.case = TRUE)
+
+
+
+cleanEx()
+nameEx("all")
+### * all
+
+flush(stderr()); flush(stdout())
+
+### Name: all
+### Title: Are All Values True?
+### Aliases: all
+### Keywords: logic
+
+### ** Examples
+
+range(x <- sort(round(stats::rnorm(10) - 1.2, 1)))
+if(all(x < 0)) cat("all x values are negative\n")
+
+all(logical(0)) # true, as all zero of the elements are true.
+
+
+
+cleanEx()
+nameEx("all.equal")
+### * all.equal
+
+flush(stderr()); flush(stdout())
+
+### Name: all.equal
+### Title: Test if Two Objects are (Nearly) Equal
+### Aliases: all.equal all.equal.default all.equal.numeric
+### all.equal.character all.equal.environment all.equal.envRefClass
+### all.equal.factor all.equal.formula all.equal.list all.equal.language
+### all.equal.POSIXt all.equal.raw attr.all.equal
+### Keywords: programming utilities logic arith
+
+### ** Examples
+
+all.equal(pi, 355/113)
+# not precise enough (default tol) > relative error
+
+d45 <- pi*(1/4 + 1:10)
+stopifnot(
+all.equal(tan(d45), rep(1, 10))) # TRUE, but
+all (tan(d45) == rep(1, 10)) # FALSE, since not exactly
+all.equal(tan(d45), rep(1, 10), tolerance = 0) # to see difference
+
+## advanced: equality of environments
+ae <- all.equal(as.environment("package:stats"),
+ asNamespace("stats"))
+stopifnot(is.character(ae), length(ae) > 10,
+ ## were incorrectly "considered equal" in R <= 3.1.1
+ all.equal(asNamespace("stats"), asNamespace("stats")))
+
+
+
+cleanEx()
+nameEx("allnames")
+### * allnames
+
+flush(stderr()); flush(stdout())
+
+### Name: all.names
+### Title: Find All Names in an Expression
+### Aliases: all.names all.vars
+### Keywords: programming
+
+### ** Examples
+
+all.names(expression(sin(x+y)))
+all.names(quote(sin(x+y))) # or a call
+all.vars(expression(sin(x+y)))
+
+
+
+cleanEx()
+nameEx("any")
+### * any
+
+flush(stderr()); flush(stdout())
+
+### Name: any
+### Title: Are Some Values True?
+### Aliases: any
+### Keywords: logic
+
+### ** Examples
+
+range(x <- sort(round(stats::rnorm(10) - 1.2, 1)))
+if(any(x < 0)) cat("x contains negative values\n")
+
+
+
+cleanEx()
+nameEx("aperm")
+### * aperm
+
+flush(stderr()); flush(stdout())
+
+### Name: aperm
+### Title: Array Transposition
+### Aliases: aperm aperm.default aperm.table
+### Keywords: array
+
+### ** Examples
+
+# interchange the first two subscripts on a 3-way array x
+x <- array(1:24, 2:4)
+xt <- aperm(x, c(2,1,3))
+stopifnot(t(xt[,,2]) == x[,,2],
+ t(xt[,,3]) == x[,,3],
+ t(xt[,,4]) == x[,,4])
+
+UCB <- aperm(UCBAdmissions, c(2,1,3))
+UCB[1,,]
+summary(UCB) # UCB is still a continency table
+## Don't show:
+stopifnot(is.table(UCB))
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("append")
+### * append
+
+flush(stderr()); flush(stdout())
+
+### Name: append
+### Title: Vector Merging
+### Aliases: append
+### Keywords: manip
+
+### ** Examples
+
+append(1:5, 0:1, after = 3)
+
+
+
+cleanEx()
+nameEx("apply")
+### * apply
+
+flush(stderr()); flush(stdout())
+
+### Name: apply
+### Title: Apply Functions Over Array Margins
+### Aliases: apply
+### Keywords: iteration array
+
+### ** Examples
+
+## Compute row and column sums for a matrix:
+x <- cbind(x1 = 3, x2 = c(4:1, 2:5))
+dimnames(x)[[1]] <- letters[1:8]
+apply(x, 2, mean, trim = .2)
+col.sums <- apply(x, 2, sum)
+row.sums <- apply(x, 1, sum)
+rbind(cbind(x, Rtot = row.sums), Ctot = c(col.sums, sum(col.sums)))
+
+stopifnot( apply(x, 2, is.vector))
+
+## Sort the columns of a matrix
+apply(x, 2, sort)
+
+## keeping named dimnames
+names(dimnames(x)) <- c("row", "col")
+x3 <- array(x, dim = c(dim(x),3),
+ dimnames = c(dimnames(x), list(C = paste0("cop.",1:3))))
+identical(x, apply( x, 2, identity))
+identical(x3, apply(x3, 2:3, identity))
+## Don't show:
+xN <- x; dimnames(xN) <- list(row=NULL, col=NULL)
+x2 <- x; names(dimnames(x2)) <- NULL
+fXY <- function(u) c(X=u[1], Y=u[2])
+ax1 <- apply(x, 1, fXY)
+ax2 <- apply(x2,1, fXY)
+stopifnot(identical(dimnames(ax1), list(col=c("X.x1", "Y.x2"), row=letters[1:8])),
+ identical(dimnames(ax2), unname(dimnames(ax1))),
+ identical( x, apply( x, 2, identity)),
+ identical(xN, apply(xN, 2, identity)),
+ identical(dimnames(x),
+ dimnames(apply(x, 2, format))),
+ identical(x3, apply(x3, 2:3, identity)),
+ identical(dimnames(apply(x3, 2:1, identity)),
+ dimnames(x3)[3:1]))
+rm(xN, x2, fXY, ax1, ax2)
+## End(Don't show)
+##- function with extra args:
+cave <- function(x, c1, c2) c(mean(x[c1]), mean(x[c2]))
+apply(x, 1, cave, c1 = "x1", c2 = c("x1","x2"))
+
+ma <- matrix(c(1:4, 1, 6:8), nrow = 2)
+ma
+apply(ma, 1, table) #--> a list of length 2
+apply(ma, 1, stats::quantile) # 5 x n matrix with rownames
+
+stopifnot(dim(ma) == dim(apply(ma, 1:2, sum)))
+
+## Example with different lengths for each call
+z <- array(1:24, dim = 2:4)
+zseq <- apply(z, 1:2, function(x) seq_len(max(x)))
+zseq ## a 2 x 3 matrix
+typeof(zseq) ## list
+dim(zseq) ## 2 3
+zseq[1,]
+apply(z, 3, function(x) seq_len(max(x)))
+# a list without a dim attribute
+
+
+
+cleanEx()
+nameEx("args")
+### * args
+
+flush(stderr()); flush(stdout())
+
+### Name: args
+### Title: Argument List of a Function
+### Aliases: args
+### Keywords: documentation
+
+### ** Examples
+
+## "regular" (non-primitive) functions "print their arguments"
+## (by returning another function with NULL body which you also see):
+args(ls)
+args(graphics::plot.default)
+utils::str(ls) # (just "prints": does not show a NULL)
+
+## You can also pass a string naming a function.
+args("scan")
+## ...but :: package specification doesn't work in this case.
+tryCatch(args("graphics::plot.default"), error = print)
+
+## As explained above, args() gives a function with empty body:
+list(is.f = is.function(args(scan)), body = body(args(scan)))
+
+## Primitive functions mostly behave like non-primitive functions.
+args(c)
+args(`+`)
+## primitive functions without well-defined argument list return NULL:
+args(`if`)
+
+
+
+cleanEx()
+nameEx("array")
+### * array
+
+flush(stderr()); flush(stdout())
+
+### Name: array
+### Title: Multi-way Arrays
+### Aliases: array as.array as.array.default is.array
+### Keywords: array
+
+### ** Examples
+
+dim(as.array(letters))
+array(1:3, c(2,4)) # recycle 1:3 "2 2/3 times"
+# [,1] [,2] [,3] [,4]
+#[1,] 1 3 2 1
+#[2,] 2 1 3 2
+
+
+
+cleanEx()
+nameEx("as.Date")
+### * as.Date
+
+flush(stderr()); flush(stdout())
+
+### Name: as.Date
+### Title: Date Conversion Functions to and from Character
+### Aliases: format.Date as.character.Date as.Date as.Date.character
+### as.Date.default as.Date.factor as.Date.POSIXct as.Date.POSIXlt
+### as.Date.date as.Date.dates as.Date.numeric
+### Keywords: utilities chron
+
+### ** Examples
+
+## read in date info in format 'ddmmmyyyy'
+## This will give NA(s) in some locales; setting the C locale
+## as in the commented lines will overcome this on most systems.
+## lct <- Sys.getlocale("LC_TIME"); Sys.setlocale("LC_TIME", "C")
+x <- c("1jan1960", "2jan1960", "31mar1960", "30jul1960")
+z <- as.Date(x, "%d%b%Y")
+## Sys.setlocale("LC_TIME", lct)
+z
+
+## read in date/time info in format 'm/d/y'
+dates <- c("02/27/92", "02/27/92", "01/14/92", "02/28/92", "02/01/92")
+as.Date(dates, "%m/%d/%y")
+
+## date given as number of days since 1900-01-01 (a date in 1989)
+as.Date(32768, origin = "1900-01-01")
+## Excel is said to use 1900-01-01 as day 1 (Windows default) or
+## 1904-01-01 as day 0 (Mac default), but this is complicated by Excel
+## incorrectly treating 1900 as a leap year.
+## So for dates (post-1901) from Windows Excel
+as.Date(35981, origin = "1899-12-30") # 1998-07-05
+## and Mac Excel
+as.Date(34519, origin = "1904-01-01") # 1998-07-05
+## (these values come from http://support.microsoft.com/kb/214330)
+
+## Experiment shows that Matlab's origin is 719529 days before ours,
+## (it takes the non-existent 0000-01-01 as day 1)
+## so Matlab day 734373 can be imported as
+as.Date(734373, origin = "1970-01-01") - 719529 # 2010-08-23
+## (value from
+## http://www.mathworks.de/de/help/matlab/matlab_prog/represent-date-and-times-in-MATLAB.html)
+
+## Time zone effect
+z <- ISOdate(2010, 04, 13, c(0,12)) # midnight and midday UTC
+as.Date(z) # in UTC
+
+
+
+cleanEx()
+nameEx("as.POSIXlt")
+### * as.POSIXlt
+
+flush(stderr()); flush(stdout())
+
+### Name: as.POSIX*
+### Title: Date-time Conversion Functions
+### Aliases: as.POSIXct as.POSIXct.default as.POSIXct.POSIXlt
+### as.POSIXct.date as.POSIXct.dates as.POSIXct.Date as.POSIXct.numeric
+### as.POSIXlt as.POSIXlt.Date as.POSIXlt.date as.POSIXlt.dates
+### as.POSIXlt.POSIXct as.POSIXlt.factor as.POSIXlt.character
+### as.POSIXlt.default as.POSIXlt.numeric as.double.POSIXlt
+### Keywords: utilities chron
+
+### ** Examples
+
+
+cleanEx()
+nameEx("as.environment")
+### * as.environment
+
+flush(stderr()); flush(stdout())
+
+### Name: as.environment
+### Title: Coerce to an Environment Object
+### Aliases: as.environment
+### Keywords: data environment
+
+### ** Examples
+
+as.environment(1) ## the global environment
+identical(globalenv(), as.environment(1)) ## is TRUE
+try( ## <<- stats need not be attached
+ as.environment("package:stats"))
+ee <- as.environment(list(a = "A", b = pi, ch = letters[1:8]))
+ls(ee) # names of objects in ee
+utils::ls.str(ee)
+
+
+
+cleanEx()
+nameEx("as.function")
+### * as.function
+
+flush(stderr()); flush(stdout())
+
+### Name: as.function
+### Title: Convert Object to Function
+### Aliases: as.function as.function.default
+### Keywords: programming
+
+### ** Examples
+
+as.function(alist(a = , b = 2, a+b))
+as.function(alist(a = , b = 2, a+b))(3)
+
+
+
+cleanEx()
+nameEx("assign")
+### * assign
+
+flush(stderr()); flush(stdout())
+
+### Name: assign
+### Title: Assign a Value to a Name
+### Aliases: assign
+### Keywords: data
+
+### ** Examples
+
+for(i in 1:6) { #-- Create objects 'r.1', 'r.2', ... 'r.6' --
+ nam <- paste("r", i, sep = ".")
+ assign(nam, 1:i)
+}
+ls(pattern = "^r..$")
+
+##-- Global assignment within a function:
+myf <- function(x) {
+ innerf <- function(x) assign("Global.res", x^2, envir = .GlobalEnv)
+ innerf(x+1)
+}
+myf(3)
+Global.res # 16
+
+a <- 1:4
+assign("a[1]", 2)
+a[1] == 2 # FALSE
+get("a[1]") == 2 # TRUE
+
+
+
+
+cleanEx()
+nameEx("attach")
+### * attach
+
+flush(stderr()); flush(stdout())
+
+### Name: attach
+### Title: Attach Set of R Objects to Search Path
+### Aliases: attach .conflicts.OK
+### Keywords: data
+
+### ** Examples
+
+require(utils)
+
+summary(women$height) # refers to variable 'height' in the data frame
+attach(women)
+summary(height) # The same variable now available by name
+height <- height*2.54 # Don't do this. It creates a new variable
+ # in the user's workspace
+find("height")
+summary(height) # The new variable in the workspace
+rm(height)
+summary(height) # The original variable.
+height <<- height*25.4 # Change the copy in the attached environment
+find("height")
+summary(height) # The changed copy
+detach("women")
+summary(women$height) # unchanged
+
+## Not run:
+##D ## create an environment on the search path and populate it
+##D sys.source("myfuns.R", envir = attach(NULL, name = "myfuns"))
+## End(Not run)
+
+
+cleanEx()
+nameEx("attr")
+### * attr
+
+flush(stderr()); flush(stdout())
+
+### Name: attr
+### Title: Object Attributes
+### Aliases: attr attr<-
+### Keywords: attribute
+
+### ** Examples
+
+# create a 2 by 5 matrix
+x <- 1:10
+attr(x,"dim") <- c(2, 5)
+
+
+
+cleanEx()
+nameEx("attributes")
+### * attributes
+
+flush(stderr()); flush(stdout())
+
+### Name: attributes
+### Title: Object Attribute Lists
+### Aliases: attributes attributes<- mostattributes<-
+### Keywords: attribute
+
+### ** Examples
+
+x <- cbind(a = 1:3, pi = pi) # simple matrix with dimnames
+attributes(x)
+
+## strip an object's attributes:
+attributes(x) <- NULL
+x # now just a vector of length 6
+
+mostattributes(x) <- list(mycomment = "really special", dim = 3:2,
+ dimnames = list(LETTERS[1:3], letters[1:5]), names = paste(1:6))
+x # dim(), but not {dim}names
+
+
+
+cleanEx()
+nameEx("autoload")
+### * autoload
+
+flush(stderr()); flush(stdout())
+
+### Name: autoload
+### Title: On-demand Loading of Packages
+### Aliases: autoload autoloader .AutoloadEnv .Autoloaded Autoloads
+### Keywords: data programming
+
+### ** Examples
+
+require(stats)
+autoload("interpSpline", "splines")
+search()
+ls("Autoloads")
+.Autoloaded
+
+x <- sort(stats::rnorm(12))
+y <- x^2
+is <- interpSpline(x, y)
+search() ## now has splines
+detach("package:splines")
+search()
+is2 <- interpSpline(x, y+x)
+search() ## and again
+detach("package:splines")
+
+
+
+cleanEx()
+nameEx("backsolve")
+### * backsolve
+
+flush(stderr()); flush(stdout())
+
+### Name: backsolve
+### Title: Solve an Upper or Lower Triangular System
+### Aliases: backsolve forwardsolve
+### Keywords: algebra array
+
+### ** Examples
+
+## upper triangular matrix 'r':
+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)
+backsolve(r, x, transpose = TRUE) # 8 -12 -5
+
+
+
+cleanEx()
+nameEx("basename")
+### * basename
+
+flush(stderr()); flush(stdout())
+
+### Name: basename
+### Title: Manipulate File Paths
+### Aliases: basename dirname
+### Keywords: file
+
+### ** Examples
+
+basename(file.path("","p1","p2","p3", c("file1", "file2")))
+dirname(file.path("","p1","p2","p3","filename"))
+
+
+
+cleanEx()
+nameEx("bincode")
+### * bincode
+
+flush(stderr()); flush(stdout())
+
+### Name: .bincode
+### Title: Bin a Numeric Vector
+### Aliases: .bincode
+### Keywords: category
+
+### ** Examples
+
+## An example with non-unique breaks:
+x <- c(0, 0.01, 0.5, 0.99, 1)
+b <- c(0, 0, 1, 1)
+.bincode(x, b, TRUE)
+.bincode(x, b, FALSE)
+.bincode(x, b, TRUE, TRUE)
+.bincode(x, b, FALSE, TRUE)
+
+
+
+cleanEx()
+nameEx("bindenv")
+### * bindenv
+
+flush(stderr()); flush(stdout())
+
+### Name: bindenv
+### Title: Binding and Environment Locking, Active Bindings
+### Aliases: bindenv lockEnvironment environmentIsLocked lockBinding
+### unlockBinding makeActiveBinding bindingIsLocked bindingIsActive
+### Keywords: utilities
+
+### ** Examples
+
+# locking environments
+e <- new.env()
+assign("x", 1, envir = e)
+get("x", envir = e)
+lockEnvironment(e)
+get("x", envir = e)
+assign("x", 2, envir = e)
+try(assign("y", 2, envir = e)) # error
+
+# locking bindings
+e <- new.env()
+assign("x", 1, envir = e)
+get("x", envir = e)
+lockBinding("x", e)
+try(assign("x", 2, envir = e)) # error
+unlockBinding("x", e)
+assign("x", 2, envir = e)
+get("x", envir = e)
+
+# active bindings
+f <- local( {
+ x <- 1
+ function(v) {
+ if (missing(v))
+ cat("get\n")
+ else {
+ cat("set\n")
+ x <<- v
+ }
+ x
+ }
+})
+makeActiveBinding("fred", f, .GlobalEnv)
+bindingIsActive("fred", .GlobalEnv)
+fred
+fred <- 2
+fred
+
+
+
+cleanEx()
+nameEx("bitwise")
+### * bitwise
+
+flush(stderr()); flush(stdout())
+
+### Name: bitwise
+### Title: Bitwise Logical Operations
+### Aliases: bitwNot bitwAnd bitwOr bitwXor bitwShiftL bitwShiftR
+### Keywords: logic
+
+### ** Examples
+
+bitwNot(0:12) # -1 -2 ... -13
+bitwAnd(15L, 7L) # 7
+bitwOr (15L, 7L) # 15
+bitwXor(15L, 7L) # 8
+bitwXor(-1L, 1L) # -2
+
+## The "same" for 'raw' instead of integer :
+rr12 <- as.raw(0:12) ; rbind(rr12, !rr12)
+c(r15 <- as.raw(15), r7 <- as.raw(7)) # 0f 07
+r15 & r7 # 07
+r15 | r7 # 0f
+xor(r15, r7)# 08
+
+bitwShiftR(-1, 1:31) # shifts of 2^32-1 = 4294967295
+
+
+
+cleanEx()
+nameEx("body")
+### * body
+
+flush(stderr()); flush(stdout())
+
+### Name: body
+### Title: Access to and Manipulation of the Body of a Function
+### Aliases: body body<-
+### Keywords: programming
+
+### ** Examples
+
+body(body)
+f <- function(x) x^5
+body(f) <- quote(5^x)
+## or equivalently body(f) <- expression(5^x)
+f(3) # = 125
+body(f)
+
+## creating a multi-expression body
+e <- expression(y <- x^2, return(y)) # or a list
+body(f) <- as.call(c(as.name("{"), e))
+f
+f(8)
+## Using substitute() may be simpler than 'as.call(c(as.name("{",..)))':
+stopifnot(identical(body(f), substitute({ y <- x^2; return(y) })))
+
+
+
+cleanEx()
+nameEx("bquote")
+### * bquote
+
+flush(stderr()); flush(stdout())
+
+### Name: bquote
+### Title: Partial substitution in expressions
+### Aliases: bquote
+### Keywords: programming data
+
+### ** Examples
+
+require(graphics)
+
+a <- 2
+
+bquote(a == a)
+quote(a == a)
+
+bquote(a == .(a))
+substitute(a == A, list(A = a))
+
+plot(1:10, a*(1:10), main = bquote(a == .(a)))
+
+## to set a function default arg
+default <- 1
+bquote( function(x, y = .(default)) x+y )
+
+
+
+cleanEx()
+nameEx("by")
+### * by
+
+flush(stderr()); flush(stdout())
+
+### Name: by
+### Title: Apply a Function to a Data Frame Split by Factors
+### Aliases: by by.default by.data.frame print.by
+### Keywords: iteration category
+
+### ** Examples
+
+require(stats)
+by(warpbreaks[, 1:2], warpbreaks[,"tension"], summary)
+by(warpbreaks[, 1], warpbreaks[, -1], summary)
+by(warpbreaks, warpbreaks[,"tension"],
+ function(x) lm(breaks ~ wool, data = x))
+
+## now suppose we want to extract the coefficients by group
+tmp <- with(warpbreaks,
+ by(warpbreaks, tension,
+ function(x) lm(breaks ~ wool, data = x)))
+sapply(tmp, coef)
+
+
+
+cleanEx()
+nameEx("c")
+### * c
+
+flush(stderr()); flush(stdout())
+
+### Name: c
+### Title: Combine Values into a Vector or List
+### Aliases: c c.default
+### Keywords: manip
+
+### ** Examples
+
+c(1,7:9)
+c(1:5, 10.5, "next")
+
+## uses with a single argument to drop attributes
+x <- 1:4
+names(x) <- letters[1:4]
+x
+c(x) # has names
+as.vector(x) # no names
+dim(x) <- c(2,2)
+x
+c(x)
+as.vector(x)
+
+## append to a list:
+ll <- list(A = 1, c = "C")
+## do *not* use
+c(ll, d = 1:3) # which is == c(ll, as.list(c(d = 1:3))
+## but rather
+c(ll, d = list(1:3)) # c() combining two lists
+
+c(list(A = c(B = 1)), recursive = TRUE)
+
+c(options(), recursive = TRUE)
+c(list(A = c(B = 1, C = 2), B = c(E = 7)), recursive = TRUE)
+
+
+
+cleanEx()
+nameEx("call")
+### * call
+
+flush(stderr()); flush(stdout())
+
+### Name: call
+### Title: Function Calls
+### Aliases: call is.call as.call
+### Keywords: programming attribute
+
+### ** Examples
+
+is.call(call) #-> FALSE: Functions are NOT calls
+
+## set up a function call to round with argument 10.5
+cl <- call("round", 10.5)
+is.call(cl) # TRUE
+cl
+## such a call can also be evaluated.
+eval(cl) # [1] 10
+
+A <- 10.5
+call("round", A) # round(10.5)
+call("round", quote(A)) # round(A)
+f <- "round"
+call(f, quote(A)) # round(A)
+## if we want to supply a function we need to use as.call or similar
+f <- round
+## Not run: call(f, quote(A)) # error: first arg must be character
+(g <- as.call(list(f, quote(A))))
+eval(g)
+## alternatively but less transparently
+g <- list(f, quote(A))
+mode(g) <- "call"
+g
+eval(g)
+## see also the examples in the help for do.call
+
+
+
+cleanEx()
+nameEx("callCC")
+### * callCC
+
+flush(stderr()); flush(stdout())
+
+### Name: callCC
+### Title: Call With Current Continuation
+### Aliases: callCC
+### Keywords: programming
+
+### ** Examples
+
+# The following all return the value 1
+callCC(function(k) 1)
+callCC(function(k) k(1))
+callCC(function(k) {k(1); 2})
+callCC(function(k) repeat k(1))
+
+
+
+cleanEx()
+nameEx("capabilities")
+### * capabilities
+
+flush(stderr()); flush(stdout())
+
+### Name: capabilities
+### Title: Report Capabilities of this Build of R
+### Aliases: capabilities
+### Keywords: utilities
+
+### ** Examples
+
+capabilities()
+
+if(!capabilities("ICU"))
+ warning("ICU is not available")
+
+## See also the examples for 'connections'.
+
+
+
+cleanEx()
+nameEx("cat")
+### * cat
+
+flush(stderr()); flush(stdout())
+
+### Name: cat
+### Title: Concatenate and Print
+### Aliases: cat
+### Keywords: print file connection
+
+### ** Examples
+
+iter <- stats::rpois(1, lambda = 10)
+## print an informative message
+cat("iteration = ", iter <- iter + 1, "\n")
+
+## 'fill' and label lines:
+cat(paste(letters, 100* 1:26), fill = TRUE, labels = paste0("{", 1:10, "}:"))
+
+
+
+cleanEx()
+nameEx("cbind")
+### * cbind
+
+flush(stderr()); flush(stdout())
+
+### Name: cbind
+### Title: Combine R Objects by Rows or Columns
+### Aliases: cbind rbind cbind.data.frame rbind.data.frame .__H__.cbind
+### .__H__.rbind
+### Keywords: array manip
+
+### ** Examples
+
+m <- cbind(1, 1:7) # the '1' (= shorter vector) is recycled
+m
+m <- cbind(m, 8:14)[, c(1, 3, 2)] # insert a column
+m
+cbind(1:7, diag(3)) # vector is subset -> warning
+
+cbind(0, rbind(1, 1:3))
+cbind(I = 0, X = rbind(a = 1, b = 1:3)) # use some names
+xx <- data.frame(I = rep(0,2))
+cbind(xx, X = rbind(a = 1, b = 1:3)) # named differently
+
+cbind(0, matrix(1, nrow = 0, ncol = 4)) #> Warning (making sense)
+dim(cbind(0, matrix(1, nrow = 2, ncol = 0))) #-> 2 x 1
+
+## deparse.level
+dd <- 10
+rbind(1:4, c = 2, "a++" = 10, dd, deparse.level = 0) # middle 2 rownames
+rbind(1:4, c = 2, "a++" = 10, dd, deparse.level = 1) # 3 rownames (default)
+rbind(1:4, c = 2, "a++" = 10, dd, deparse.level = 2) # 4 rownames
+
+## cheap row names:
+b0 <- gl(3,4, labels=letters[1:3])
+bf <- setNames(b0, paste0("o", seq_along(b0)))
+df <- data.frame(a = 1, B = b0, f = gl(4,3))
+df. <- data.frame(a = 1, B = bf, f = gl(4,3))
+new <- data.frame(a = 8, B ="B", f = "1")
+(df1 <- rbind(df , new))
+(df.1 <- rbind(df., new))
+stopifnot(identical(df1, rbind(df, new, make.row.names=FALSE)),
+ identical(df1, rbind(df., new, make.row.names=FALSE)))
+## Don't show:
+## Testing a semi-official use:
+d2 <- rbind.data.frame(as.list(df), as.list(new))
+d3 <- rbind.data.frame(as.list(df), as.list(new), make.row.names=FALSE)
+stopifnot(identical(.row_names_info(d3), -13L))
+## no longer: attr(d2, "row.names")[c(1,13)] == c("13", "131"))
+row.names(d2) <- attr(d3, "row.names")# = 1:13
+stopifnot(identical(d2, d3))
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("char.expand")
+### * char.expand
+
+flush(stderr()); flush(stdout())
+
+### Name: char.expand
+### Title: Expand a String with Respect to a Target Table
+### Aliases: char.expand
+### Keywords: character
+
+### ** Examples
+
+locPars <- c("mean", "median", "mode")
+char.expand("me", locPars, warning("Could not expand!"))
+char.expand("mo", locPars)
+
+
+
+cleanEx()
+nameEx("character")
+### * character
+
+flush(stderr()); flush(stdout())
+
+### Name: character
+### Title: Character Vectors
+### Aliases: character as.character as.character.default
+### as.character.factor is.character
+### Keywords: character classes
+
+### ** Examples
+
+form <- y ~ a + b + c
+as.character(form) ## length 3
+deparse(form) ## like the input
+
+a0 <- 11/999 # has a repeating decimal representation
+(a1 <- as.character(a0))
+format(a0, digits = 16) # shows one more digit
+a2 <- as.numeric(a1)
+a2 - a0 # normally around -1e-17
+as.character(a2) # normally different from a1
+print(c(a0, a2), digits = 16)
+
+
+
+cleanEx()
+nameEx("charmatch")
+### * charmatch
+
+flush(stderr()); flush(stdout())
+
+### Name: charmatch
+### Title: Partial String Matching
+### Aliases: charmatch
+### Keywords: character
+
+### ** Examples
+
+charmatch("", "") # returns 1
+charmatch("m", c("mean", "median", "mode")) # returns 0
+charmatch("med", c("mean", "median", "mode")) # returns 2
+
+
+
+cleanEx()
+nameEx("chartr")
+### * chartr
+
+flush(stderr()); flush(stdout())
+
+### Name: chartr
+### Title: Character Translation and Casefolding
+### Aliases: chartr tolower toupper casefold
+### Keywords: character
+
+### ** Examples
+
+x <- "MiXeD cAsE 123"
+chartr("iXs", "why", x)
+chartr("a-cX", "D-Fw", x)
+tolower(x)
+toupper(x)
+
+## "Mixed Case" Capitalizing - toupper( every first letter of a word ) :
+
+.simpleCap <- function(x) {
+ s <- strsplit(x, " ")[[1]]
+ paste(toupper(substring(s, 1, 1)), substring(s, 2),
+ sep = "", collapse = " ")
+}
+.simpleCap("the quick red fox jumps over the lazy brown dog")
+## -> [1] "The Quick Red Fox Jumps Over The Lazy Brown Dog"
+
+## and the better, more sophisticated version:
+capwords <- function(s, strict = FALSE) {
+ cap <- function(s) paste(toupper(substring(s, 1, 1)),
+ {s <- substring(s, 2); if(strict) tolower(s) else s},
+ sep = "", collapse = " " )
+ sapply(strsplit(s, split = " "), cap, USE.NAMES = !is.null(names(s)))
+}
+capwords(c("using AIC for model selection"))
+## -> [1] "Using AIC For Model Selection"
+capwords(c("using AIC", "for MODEL selection"), strict = TRUE)
+## -> [1] "Using Aic" "For Model Selection"
+## ^^^ ^^^^^
+## 'bad' 'good'
+
+## -- Very simple insecure crypto --
+rot <- function(ch, k = 13) {
+ p0 <- function(...) paste(c(...), collapse = "")
+ A <- c(letters, LETTERS, " '")
+ I <- seq_len(k); chartr(p0(A), p0(c(A[-I], A[I])), ch)
+}
+
+pw <- "my secret pass phrase"
+(crypw <- rot(pw, 13)) #-> you can send this off
+
+## now ``decrypt'' :
+rot(crypw, 54 - 13) # -> the original:
+stopifnot(identical(pw, rot(crypw, 54 - 13)))
+
+
+
+cleanEx()
+nameEx("chkDots")
+### * chkDots
+
+flush(stderr()); flush(stdout())
+
+### Name: chkDots
+### Title: Warn About Extraneous Arguments in the "..." of Its Caller
+### Aliases: chkDots
+### Keywords: utilities
+
+### ** Examples
+
+seq.default ## <- you will see ' chkDots(...) '
+
+seq(1,5, foo = "bar") # gives warning via chkDots()
+
+## warning with more than one ...-entry:
+density.f <- function(x, ...) NextMethod("density")
+x <- density(structure(rnorm(10), class="f"), bar=TRUE, baz=TRUE)
+
+
+
+cleanEx()
+nameEx("chol")
+### * chol
+
+flush(stderr()); flush(stdout())
+
+### Name: chol
+### Title: The Choleski Decomposition
+### Aliases: chol chol.default
+### Keywords: algebra array
+
+### ** Examples
+
+( m <- matrix(c(5,1,1,3),2,2) )
+( cm <- chol(m) )
+t(cm) %*% cm #-- = 'm'
+crossprod(cm) #-- = 'm'
+
+# now for something positive semi-definite
+x <- matrix(c(1:5, (1:5)^2), 5, 2)
+x <- cbind(x, x[, 1] + 3*x[, 2])
+colnames(x) <- letters[20:22]
+m <- crossprod(x)
+qr(m)$rank # is 2, as it should be
+
+# chol() may fail, depending on numerical rounding:
+# chol() unlike qr() does not use a tolerance.
+try(chol(m))
+
+(Q <- chol(m, pivot = TRUE))
+## we can use this by
+pivot <- attr(Q, "pivot")
+crossprod(Q[, order(pivot)]) # recover m
+
+## now for a non-positive-definite matrix
+( m <- matrix(c(5,-5,-5,3), 2, 2) )
+try(chol(m)) # fails
+(Q <- chol(m, pivot = TRUE)) # warning
+crossprod(Q) # not equal to m
+
+
+
+cleanEx()
+nameEx("chol2inv")
+### * chol2inv
+
+flush(stderr()); flush(stdout())
+
+### Name: chol2inv
+### Title: Inverse from Choleski (or QR) Decomposition
+### Aliases: chol2inv
+### Keywords: algebra array
+
+### ** Examples
+
+cma <- chol(ma <- cbind(1, 1:3, c(1,3,7)))
+ma %*% chol2inv(cma)
+
+
+
+cleanEx()
+nameEx("class")
+### * class
+
+flush(stderr()); flush(stdout())
+
+### Name: class
+### Title: Object Classes
+### Aliases: class class<- oldClass oldClass<- unclass inherits
+### Keywords: methods classes
+
+### ** Examples
+
+x <- 10
+class(x) # "numeric"
+oldClass(x) # NULL
+inherits(x, "a") #FALSE
+class(x) <- c("a", "b")
+inherits(x,"a") #TRUE
+inherits(x, "a", TRUE) # 1
+inherits(x, c("a", "b", "c"), TRUE) # 1 2 0
+
+
+
+cleanEx()
+nameEx("col")
+### * col
+
+flush(stderr()); flush(stdout())
+
+### Name: col
+### Title: Column Indexes
+### Aliases: col
+### Keywords: array
+
+### ** Examples
+
+# extract an off-diagonal of a matrix
+ma <- matrix(1:12, 3, 4)
+ma[row(ma) == col(ma) + 1]
+
+# create an identity 5-by-5 matrix
+x <- matrix(0, nrow = 5, ncol = 5)
+x[row(x) == col(x)] <- 1
+
+
+
+cleanEx()
+nameEx("colSums")
+### * colSums
+
+flush(stderr()); flush(stdout())
+
+### Name: colSums
+### Title: Form Row and Column Sums and Means
+### Aliases: colSums rowSums colMeans rowMeans .colSums .rowSums .colMeans
+### .rowMeans
+### Keywords: array algebra arith
+
+### ** Examples
+
+## Compute row and column sums for a matrix:
+x <- cbind(x1 = 3, x2 = c(4:1, 2:5))
+rowSums(x); colSums(x)
+dimnames(x)[[1]] <- letters[1:8]
+rowSums(x); colSums(x); rowMeans(x); colMeans(x)
+x[] <- as.integer(x)
+rowSums(x); colSums(x)
+x[] <- x < 3
+rowSums(x); colSums(x)
+x <- cbind(x1 = 3, x2 = c(4:1, 2:5))
+x[3, ] <- NA; x[4, 2] <- NA
+rowSums(x); colSums(x); rowMeans(x); colMeans(x)
+rowSums(x, na.rm = TRUE); colSums(x, na.rm = TRUE)
+rowMeans(x, na.rm = TRUE); colMeans(x, na.rm = TRUE)
+
+## an array
+dim(UCBAdmissions)
+rowSums(UCBAdmissions); rowSums(UCBAdmissions, dims = 2)
+colSums(UCBAdmissions); colSums(UCBAdmissions, dims = 2)
+
+## complex case
+x <- cbind(x1 = 3 + 2i, x2 = c(4:1, 2:5) - 5i)
+x[3, ] <- NA; x[4, 2] <- NA
+rowSums(x); colSums(x); rowMeans(x); colMeans(x)
+rowSums(x, na.rm = TRUE); colSums(x, na.rm = TRUE)
+rowMeans(x, na.rm = TRUE); colMeans(x, na.rm = TRUE)
+
+
+
+cleanEx()
+nameEx("colnames")
+### * colnames
+
+flush(stderr()); flush(stdout())
+
+### Name: row+colnames
+### Title: Row and Column Names
+### Aliases: rownames rownames<- colnames colnames<-
+### Keywords: array manip
+
+### ** Examples
+
+m0 <- matrix(NA, 4, 0)
+rownames(m0)
+
+m2 <- cbind(1, 1:4)
+colnames(m2, do.NULL = FALSE)
+colnames(m2) <- c("x","Y")
+rownames(m2) <- rownames(m2, do.NULL = FALSE, prefix = "Obs.")
+m2
+
+
+
+cleanEx()
+nameEx("commandArgs")
+### * commandArgs
+
+flush(stderr()); flush(stdout())
+
+### Name: commandArgs
+### Title: Extract Command Line Arguments
+### Aliases: commandArgs
+### Keywords: environment sysdata programming
+
+### ** Examples
+
+commandArgs()
+## Spawn a copy of this application as it was invoked,
+## subject to shell quoting issues
+## system(paste(commandArgs(), collapse = " "))
+
+
+
+cleanEx()
+nameEx("comment")
+### * comment
+
+flush(stderr()); flush(stdout())
+
+### Name: comment
+### Title: Query or Set a '"comment"' Attribute
+### Aliases: comment comment<-
+### Keywords: attribute
+
+### ** Examples
+
+x <- matrix(1:12, 3, 4)
+comment(x) <- c("This is my very important data from experiment #0234",
+ "Jun 5, 1998")
+x
+comment(x)
+
+
+
+cleanEx()
+nameEx("complex")
+### * complex
+
+flush(stderr()); flush(stdout())
+
+### Name: complex
+### Title: Complex Numbers and Basic Functionality
+### Aliases: complex as.complex is.complex Re Im Mod Arg Conj
+### Keywords: complex
+
+### ** Examples
+
+require(graphics)
+
+0i ^ (-3:3)
+
+matrix(1i^ (-6:5), nrow = 4) #- all columns are the same
+0 ^ 1i # a complex NaN
+
+## create a complex normal vector
+z <- complex(real = stats::rnorm(100), imaginary = stats::rnorm(100))
+## or also (less efficiently):
+z2 <- 1:2 + 1i*(8:9)
+
+## The Arg(.) is an angle:
+zz <- (rep(1:4, len = 9) + 1i*(9:1))/10
+zz.shift <- complex(modulus = Mod(zz), argument = Arg(zz) + pi)
+plot(zz, xlim = c(-1,1), ylim = c(-1,1), col = "red", asp = 1,
+ main = expression(paste("Rotation by "," ", pi == 180^o)))
+abline(h = 0, v = 0, col = "blue", lty = 3)
+points(zz.shift, col = "orange")
+
+showC <- function(z) noquote(sprintf("(R = %g, I = %g)", Re(z), Im(z)))
+
+## The exact result of this *depends* on the platform, compiler, math-library:
+(NpNA <- NaN + NA_complex_) ; str(NpNA) # *behaves* as 'cplx NA' ..
+stopifnot(is.na(NpNA), is.na(NA_complex_), is.na(Re(NA_complex_)), is.na(Im(NA_complex_)))
+showC(NpNA)# but not always is {shows '(R = NaN, I = NA)' on some platforms}
+## and this is not TRUE everywhere:
+identical(NpNA, NA_complex_)
+showC(NA_complex_) # always == (R = NA, I = NA)
+
+
+
+cleanEx()
+nameEx("conditions")
+### * conditions
+
+flush(stderr()); flush(stdout())
+
+### Name: conditions
+### Title: Condition Handling and Recovery
+### Aliases: conditions condition computeRestarts conditionCall
+### conditionMessage findRestart invokeRestart invokeRestartInteractively
+### isRestart restartDescription restartFormals signalCondition
+### simpleCondition simpleError simpleWarning simpleMessage tryCatch
+### withCallingHandlers withRestarts .signalSimpleWarning
+### .handleSimpleError .tryResumeInterrupt as.character.condition
+### as.character.error conditionCall.condition conditionMessage.condition
+### print.condition print.restart
+### Keywords: programming error
+
+### ** Examples
+
+tryCatch(1, finally = print("Hello"))
+e <- simpleError("test error")
+## Not run:
+##D stop(e)
+##D tryCatch(stop(e), finally = print("Hello"))
+##D tryCatch(stop("fred"), finally = print("Hello"))
+## End(Not run)
+tryCatch(stop(e), error = function(e) e, finally = print("Hello"))
+tryCatch(stop("fred"), error = function(e) e, finally = print("Hello"))
+withCallingHandlers({ warning("A"); 1+2 }, warning = function(w) {})
+## Not run:
+##D { withRestarts(stop("A"), abort = function() {}); 1 }
+## End(Not run)
+withRestarts(invokeRestart("foo", 1, 2), foo = function(x, y) {x + y})
+
+##--> More examples are part of
+##--> demo(error.catching)
+
+
+
+cleanEx()
+nameEx("conflicts")
+### * conflicts
+
+flush(stderr()); flush(stdout())
+
+### Name: conflicts
+### Title: Search for Masked Objects on the Search Path
+### Aliases: conflicts
+### Keywords: utilities
+
+### ** Examples
+
+lm <- 1:3
+conflicts(, TRUE)
+## gives something like
+# $.GlobalEnv
+# [1] "lm"
+#
+# $package:base
+# [1] "lm"
+
+## Remove things from your "workspace" that mask others:
+remove(list = conflicts(detail = TRUE)$.GlobalEnv)
+
+
+
+cleanEx()
+nameEx("connections")
+### * connections
+
+flush(stderr()); flush(stdout())
+
+### Name: connections
+### Title: Functions to Manipulate Connections (Files, URLs, ...)
+### Aliases: connections connection file clipboard pipe fifo gzfile unz
+### bzfile xzfile url socketConnection open open.connection isOpen
+### isIncomplete close close.connection flush flush.connection
+### print.connection summary.connection
+### Keywords: file connection
+
+### ** Examples
+
+zz <- file("ex.data", "w") # open an output file connection
+cat("TITLE extra line", "2 3 5 7", "", "11 13 17", file = zz, sep = "\n")
+cat("One more line\n", file = zz)
+close(zz)
+readLines("ex.data")
+unlink("ex.data")
+
+zz <- gzfile("ex.gz", "w") # compressed file
+cat("TITLE extra line", "2 3 5 7", "", "11 13 17", file = zz, sep = "\n")
+close(zz)
+readLines(zz <- gzfile("ex.gz"))
+close(zz)
+unlink("ex.gz")
+zz # an invalid connection
+
+zz <- bzfile("ex.bz2", "w") # bzip2-ed file
+cat("TITLE extra line", "2 3 5 7", "", "11 13 17", file = zz, sep = "\n")
+close(zz)
+zz # print() method: invalid connection
+print(readLines(zz <- bzfile("ex.bz2")))
+close(zz)
+unlink("ex.bz2")
+
+## An example of a file open for reading and writing
+Tfile <- file("test1", "w+")
+c(isOpen(Tfile, "r"), isOpen(Tfile, "w")) # both TRUE
+cat("abc\ndef\n", file = Tfile)
+readLines(Tfile)
+seek(Tfile, 0, rw = "r") # reset to beginning
+readLines(Tfile)
+cat("ghi\n", file = Tfile)
+readLines(Tfile)
+Tfile # -> print() : "valid" connection
+close(Tfile)
+Tfile # -> print() : "invalid" connection
+unlink("test1")
+
+## We can do the same thing with an anonymous file.
+Tfile <- file()
+cat("abc\ndef\n", file = Tfile)
+readLines(Tfile)
+close(Tfile)
+
+## Not run:
+##D ## fifo example -- may hang even with OS support for fifos
+##D if(capabilities("fifo")) {
+##D zz <- fifo("foo-fifo", "w+")
+##D writeLines("abc", zz)
+##D print(readLines(zz))
+##D close(zz)
+##D unlink("foo-fifo")
+##D }
+## End(Not run)
+## Not run:
+##D ## example for a machine running a finger daemon
+##D
+##D con <- socketConnection(port = 79, blocking = TRUE)
+##D writeLines(paste0(system("whoami", intern = TRUE), "\r"), con)
+##D gsub(" *$", "", readLines(con))
+##D close(con)
+## End(Not run)
+
+## Not run:
+##D ## Two R processes communicating via non-blocking sockets
+##D # R process 1
+##D con1 <- socketConnection(port = 6011, server = TRUE)
+##D writeLines(LETTERS, con1)
+##D close(con1)
+##D
+##D # R process 2
+##D con2 <- socketConnection(Sys.info()["nodename"], port = 6011)
+##D # as non-blocking, may need to loop for input
+##D readLines(con2)
+##D while(isIncomplete(con2)) {
+##D Sys.sleep(1)
+##D z <- readLines(con2)
+##D if(length(z)) print(z)
+##D }
+##D close(con2)
+##D
+##D ## examples of use of encodings
+##D # write a file in UTF-8
+##D cat(x, file = (con <- file("foo", "w", encoding = "UTF-8"))); close(con)
+##D # read a 'Windows Unicode' file
+##D A <- read.table(con <- file("students", encoding = "UCS-2LE")); close(con)
+## End(Not run)
+
+
+cleanEx()
+nameEx("crossprod")
+### * crossprod
+
+flush(stderr()); flush(stdout())
+
+### Name: crossprod
+### Title: Matrix Crossproduct
+### Aliases: crossprod tcrossprod
+### Keywords: algebra array
+
+### ** Examples
+
+(z <- crossprod(1:4)) # = sum(1 + 2^2 + 3^2 + 4^2)
+drop(z) # scalar
+x <- 1:4; names(x) <- letters[1:4]; x
+tcrossprod(as.matrix(x)) # is
+identical(tcrossprod(as.matrix(x)),
+ crossprod(t(x)))
+tcrossprod(x) # no dimnames
+
+m <- matrix(1:6, 2,3) ; v <- 1:3; v2 <- 2:1
+stopifnot(identical(tcrossprod(v, m), v %*% t(m)),
+ identical(tcrossprod(v, m), crossprod(v, t(m))),
+ identical(crossprod(m, v2), t(m) %*% v2))
+
+
+
+cleanEx()
+nameEx("cumsum")
+### * cumsum
+
+flush(stderr()); flush(stdout())
+
+### Name: cumsum
+### Title: Cumulative Sums, Products, and Extremes
+### Aliases: cumsum cumprod cummin cummax
+### Keywords: arith
+
+### ** Examples
+
+cumsum(1:10)
+cumprod(1:10)
+cummin(c(3:1, 2:0, 4:2))
+cummax(c(3:1, 2:0, 4:2))
+
+
+
+cleanEx()
+nameEx("curlGetHeaders")
+### * curlGetHeaders
+
+flush(stderr()); flush(stdout())
+
+### Name: curlGetHeaders
+### Title: Retrieve Headers from URLs
+### Aliases: curlGetHeaders
+
+### ** Examples
+## Not run:
+##D ## a not-always-available site:
+##D curlGetHeaders("ftps://test.rebex.net/readme.txt")
+## End(Not run)
+
+
+cleanEx()
+nameEx("cut.POSIXt")
+### * cut.POSIXt
+
+flush(stderr()); flush(stdout())
+
+### Name: cut.POSIXt
+### Title: Convert a Date or Date-Time Object to a Factor
+### Aliases: cut.POSIXt cut.Date
+### Keywords: manip chron
+
+### ** Examples
+
+## random dates in a 10-week period
+cut(ISOdate(2001, 1, 1) + 70*86400*stats::runif(100), "weeks")
+cut(as.Date("2001/1/1") + 70*stats::runif(100), "weeks")
+
+# The standards all have midnight as the start of the day, but some
+# people incorrectly interpret it at the end of the previous day ...
+tm <- seq(as.POSIXct("2012-06-01 06:00"), by = "6 hours", length.out = 24)
+aggregate(1:24, list(day = cut(tm, "days")), mean)
+# and a version with midnight included in the previous day:
+aggregate(1:24, list(day = cut(tm, "days", right = TRUE)), mean)
+
+
+
+cleanEx()
+nameEx("cut")
+### * cut
+
+flush(stderr()); flush(stdout())
+
+### Name: cut
+### Title: Convert Numeric to Factor
+### Aliases: cut cut.default
+### Keywords: category
+
+### ** Examples
+
+Z <- stats::rnorm(10000)
+table(cut(Z, breaks = -6:6))
+sum(table(cut(Z, breaks = -6:6, labels = FALSE)))
+sum(graphics::hist(Z, breaks = -6:6, plot = FALSE)$counts)
+
+cut(rep(1,5), 4) #-- dummy
+tx0 <- c(9, 4, 6, 5, 3, 10, 5, 3, 5)
+x <- rep(0:8, tx0)
+stopifnot(table(x) == tx0)
+
+table( cut(x, b = 8))
+table( cut(x, breaks = 3*(-2:5)))
+table( cut(x, breaks = 3*(-2:5), right = FALSE))
+
+##--- some values OUTSIDE the breaks :
+table(cx <- cut(x, breaks = 2*(0:4)))
+table(cxl <- cut(x, breaks = 2*(0:4), right = FALSE))
+which(is.na(cx)); x[is.na(cx)] #-- the first 9 values 0
+which(is.na(cxl)); x[is.na(cxl)] #-- the last 5 values 8
+
+
+## Label construction:
+y <- stats::rnorm(100)
+table(cut(y, breaks = pi/3*(-3:3)))
+table(cut(y, breaks = pi/3*(-3:3), dig.lab = 4))
+
+table(cut(y, breaks = 1*(-3:3), dig.lab = 4))
+# extra digits don't "harm" here
+table(cut(y, breaks = 1*(-3:3), right = FALSE))
+#- the same, since no exact INT!
+
+## sometimes the default dig.lab is not enough to be avoid confusion:
+aaa <- c(1,2,3,4,5,2,3,4,5,6,7)
+cut(aaa, 3)
+cut(aaa, 3, dig.lab = 4, ordered = TRUE)
+
+## one way to extract the breakpoints
+labs <- levels(cut(aaa, 3))
+cbind(lower = as.numeric( sub("\\((.+),.*", "\\1", labs) ),
+ upper = as.numeric( sub("[^,]*,([^]]*)\\]", "\\1", labs) ))
+
+
+
+cleanEx()
+nameEx("data.class")
+### * data.class
+
+flush(stderr()); flush(stdout())
+
+### Name: data.class
+### Title: Object Classes
+### Aliases: data.class
+### Keywords: classes methods
+
+### ** Examples
+
+x <- LETTERS
+data.class(factor(x)) # has a class attribute
+data.class(matrix(x, ncol = 13)) # has a dim attribute
+data.class(list(x)) # the same as mode(x)
+data.class(x) # the same as mode(x)
+
+stopifnot(data.class(1:2) == "numeric") # compatibility "rule"
+
+
+
+cleanEx()
+nameEx("data.frame")
+### * data.frame
+
+flush(stderr()); flush(stdout())
+
+### Name: data.frame
+### Title: Data Frames
+### Aliases: data.frame default.stringsAsFactors
+### Keywords: classes methods
+
+### ** Examples
+
+L3 <- LETTERS[1:3]
+fac <- sample(L3, 10, replace = TRUE)
+(d <- data.frame(x = 1, y = 1:10, fac = fac))
+## The "same" with automatic column names:
+data.frame(1, 1:10, sample(L3, 10, replace = TRUE))
+
+is.data.frame(d)
+
+## do not convert to factor, using I() :
+(dd <- cbind(d, char = I(letters[1:10])))
+rbind(class = sapply(dd, class), mode = sapply(dd, mode))
+
+stopifnot(1:10 == row.names(d)) # {coercion}
+
+(d0 <- d[, FALSE]) # data frame with 0 columns and 10 rows
+(d.0 <- d[FALSE, ]) # <0 rows> data frame (3 named cols)
+(d00 <- d0[FALSE, ]) # data frame with 0 columns and 0 rows
+
+
+
+cleanEx()
+nameEx("data.matrix")
+### * data.matrix
+
+flush(stderr()); flush(stdout())
+
+### Name: data.matrix
+### Title: Convert a Data Frame to a Numeric Matrix
+### Aliases: data.matrix
+### Keywords: array
+
+### ** Examples
+
+DF <- data.frame(a = 1:3, b = letters[10:12],
+ c = seq(as.Date("2004-01-01"), by = "week", len = 3),
+ stringsAsFactors = TRUE)
+data.matrix(DF[1:2])
+data.matrix(DF)
+
+
+
+cleanEx()
+nameEx("date")
+### * date
+
+flush(stderr()); flush(stdout())
+
+### Name: date
+### Title: System Date and Time
+### Aliases: date
+### Keywords: utilities
+
+### ** Examples
+
+
+cleanEx()
+nameEx("dcf")
+### * dcf
+
+flush(stderr()); flush(stdout())
+
+### Name: dcf
+### Title: Read and Write Data in DCF Format
+### Aliases: read.dcf write.dcf
+### Keywords: print file
+
+### ** Examples
+
+
+cleanEx()
+nameEx("debug")
+### * debug
+
+flush(stderr()); flush(stdout())
+
+### Name: debug
+### Title: Debug a Function
+### Aliases: debug debugonce undebug isdebugged debuggingState
+### Keywords: programming environment
+
+### ** Examples
+
+## Not run:
+##D debug(library)
+##D library(methods)
+## End(Not run)
+## Not run:
+##D debugonce(sample)
+##D ## only the first call will be debugged
+##D sampe(10, 1)
+##D sample(10, 1)
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("delayedAssign")
+### * delayedAssign
+
+flush(stderr()); flush(stdout())
+
+### Name: delayedAssign
+### Title: Delay Evaluation
+### Aliases: delayedAssign promise promises
+### Keywords: programming data
+
+### ** Examples
+
+msg <- "old"
+delayedAssign("x", msg)
+substitute(x) # shows only 'x', as it is in the global env.
+msg <- "new!"
+x # new!
+
+delayedAssign("x", {
+ for(i in 1:3)
+ cat("yippee!\n")
+ 10
+})
+
+x^2 #- yippee
+x^2 #- simple number
+
+ne <- new.env()
+delayedAssign("x", pi + 2, assign.env = ne)
+## See the promise {without "forcing" (i.e. evaluating) it}:
+substitute(x, ne) # 'pi + 2'
+## Don't show:
+stopifnot(identical(substitute(x,ne), quote(pi + 2)))
+## End(Don't show)
+
+### Promises in an environment [for advanced users]: ---------------------
+
+e <- (function(x, y = 1, z) environment())(cos, "y", {cat(" HO!\n"); pi+2})
+## How can we look at all promises in an env (w/o forcing them)?
+gete <- function(e_)
+ lapply(lapply(ls(e_), as.name),
+ function(n) eval(substitute(substitute(X, e_), list(X=n))))
+
+(exps <- gete(e))
+sapply(exps, typeof)
+
+(le <- as.list(e)) # evaluates ("force"s) the promises
+stopifnot(identical(unname(le), lapply(exps, eval))) # and another "Ho!"
+
+
+
+cleanEx()
+nameEx("deparse")
+### * deparse
+
+flush(stderr()); flush(stdout())
+
+### Name: deparse
+### Title: Expression Deparsing
+### Aliases: deparse
+### Keywords: programming manip data
+
+### ** Examples
+
+require(stats); require(graphics)
+
+deparse(args(lm))
+deparse(args(lm), width = 500)
+myplot <-
+function(x, y) {
+ plot(x, y, xlab = deparse(substitute(x)),
+ ylab = deparse(substitute(y)))
+}
+e <- quote(`foo bar`)
+deparse(e)
+deparse(e, backtick = TRUE)
+e <- quote(`foo bar`+1)
+deparse(e)
+deparse(e, control = "all")
+
+
+
+cleanEx()
+nameEx("det")
+### * det
+
+flush(stderr()); flush(stdout())
+
+### Name: det
+### Title: Calculate the Determinant of a Matrix
+### Aliases: det determinant determinant.matrix
+### Keywords: array
+
+### ** Examples
+
+(x <- matrix(1:4, ncol = 2))
+unlist(determinant(x))
+det(x)
+
+det(print(cbind(1, 1:3, c(2,0,1))))
+
+
+
+cleanEx()
+nameEx("detach")
+### * detach
+
+flush(stderr()); flush(stdout())
+
+### Name: detach
+### Title: Detach Objects from the Search Path
+### Aliases: detach
+### Keywords: data
+
+### ** Examples
+
+require(splines) # package
+detach(package:splines)
+## or also
+library(splines)
+pkg <- "package:splines"
+## Don't show:
+stopifnot(inherits(tryCatch(detach(pkg), error = function(.).), "error"))
+## End(Don't show)
+detach(pkg, character.only = TRUE)
+
+## careful: do not do this unless 'splines' is not already attached.
+library(splines)
+detach(2) # 'pos' used for 'name'
+
+## an example of the name argument to attach
+## and of detaching a database named by a character vector
+attach_and_detach <- function(db, pos = 2)
+{
+ name <- deparse(substitute(db))
+ attach(db, pos = pos, name = name)
+ print(search()[pos])
+ detach(name, character.only = TRUE)
+}
+attach_and_detach(women, pos = 3)
+
+
+
+cleanEx()
+nameEx("diag")
+### * diag
+
+flush(stderr()); flush(stdout())
+
+### Name: diag
+### Title: Matrix Diagonals
+### Aliases: diag diag<-
+### Keywords: array
+
+### ** Examples
+
+dim(diag(3))
+diag(10, 3, 4) # guess what?
+all(diag(1:3) == {m <- matrix(0,3,3); diag(m) <- 1:3; m})
+
+## other "numeric"-like diagonal matrices :
+diag(c(1i,2i)) # complex
+diag(TRUE, 3) # logical
+diag(as.raw(1:3)) # raw
+(D2 <- diag(2:1, 4)); typeof(D2) # "integer"
+
+require(stats)
+## diag(<var-cov-matrix>) = variances
+diag(var(M <- cbind(X = 1:5, Y = rnorm(5))))
+#-> vector with names "X" and "Y"
+rownames(M) <- c(colnames(M), rep("", 3));
+M; diag(M) # named as well
+
+
+
+cleanEx()
+nameEx("diff")
+### * diff
+
+flush(stderr()); flush(stdout())
+
+### Name: diff
+### Title: Lagged Differences
+### Aliases: diff diff.default diff.POSIXt diff.Date
+### Keywords: arith
+
+### ** Examples
+
+diff(1:10, 2)
+diff(1:10, 2, 2)
+x <- cumsum(cumsum(1:10))
+diff(x, lag = 2)
+diff(x, differences = 2)
+
+diff(.leap.seconds)
+
+
+
+cleanEx()
+nameEx("difftime")
+### * difftime
+
+flush(stderr()); flush(stdout())
+
+### Name: difftime
+### Title: Time Intervals / Differences
+### Aliases: difftime as.difftime as.double.difftime is.numeric.difftime
+### print.difftime format.difftime units.difftime units<-.difftime
+### Ops.difftime *.difftime /.difftime Math.difftime Summary.difftime
+### [.difftime mean.difftime diff.difftime c.difftime units units<- 'time
+### interval'
+### Keywords: utilities chron
+
+### ** Examples
+
+
+cleanEx()
+nameEx("dim")
+### * dim
+
+flush(stderr()); flush(stdout())
+
+### Name: dim
+### Title: Dimensions of an Object
+### Aliases: dim dim.data.frame dim<-
+### Keywords: array
+
+### ** Examples
+
+x <- 1:12 ; dim(x) <- c(3,4)
+x
+
+# simple versions of nrow and ncol could be defined as follows
+nrow0 <- function(x) dim(x)[1]
+ncol0 <- function(x) dim(x)[2]
+
+
+
+cleanEx()
+nameEx("dimnames")
+### * dimnames
+
+flush(stderr()); flush(stdout())
+
+### Name: dimnames
+### Title: Dimnames of an Object
+### Aliases: dimnames dimnames<- dimnames.data.frame dimnames<-.data.frame
+### provideDimnames
+### Keywords: array manip
+
+### ** Examples
+
+## simple versions of rownames and colnames
+## could be defined as follows
+rownames0 <- function(x) dimnames(x)[[1]]
+colnames0 <- function(x) dimnames(x)[[2]]
+
+(dn <- dimnames(A <- provideDimnames(N <- array(1:24, dim = 2:4))))
+A0 <- A; dimnames(A)[2:3] <- list(NULL)
+stopifnot(identical(A0, provideDimnames(A)))
+strd <- function(x) utils::str(dimnames(x))
+strd(provideDimnames(A, base= list(letters[-(1:9)], tail(LETTERS))))
+strd(provideDimnames(N, base= list(letters[-(1:9)], tail(LETTERS)))) # recycling
+strd(provideDimnames(A, base= list(c("AA","BB")))) # recycling on both levels
+## set "empty dimnames":
+provideDimnames(rbind(1, 2:3), base = list(""), unique=FALSE)
+
+
+
+cleanEx()
+nameEx("do.call")
+### * do.call
+
+flush(stderr()); flush(stdout())
+
+### Name: do.call
+### Title: Execute a Function Call
+### Aliases: do.call
+### Keywords: programming
+
+### ** Examples
+
+do.call("complex", list(imag = 1:3))
+
+## if we already have a list (e.g., a data frame)
+## we need c() to add further arguments
+tmp <- expand.grid(letters[1:2], 1:3, c("+", "-"))
+do.call("paste", c(tmp, sep = ""))
+
+do.call(paste, list(as.name("A"), as.name("B")), quote = TRUE)
+
+## examples of where objects will be found.
+A <- 2
+f <- function(x) print(x^2)
+env <- new.env()
+assign("A", 10, envir = env)
+assign("f", f, envir = env)
+f <- function(x) print(x)
+f(A) # 2
+do.call("f", list(A)) # 2
+do.call("f", list(A), envir = env) # 4
+do.call(f, list(A), envir = env) # 2
+do.call("f", list(quote(A)), envir = env) # 100
+do.call(f, list(quote(A)), envir = env) # 10
+do.call("f", list(as.name("A")), envir = env) # 100
+
+eval(call("f", A)) # 2
+eval(call("f", quote(A))) # 2
+eval(call("f", A), envir = env) # 4
+eval(call("f", quote(A)), envir = env) # 100
+
+
+
+cleanEx()
+nameEx("double")
+### * double
+
+flush(stderr()); flush(stdout())
+
+### Name: double
+### Title: Double-Precision Vectors
+### Aliases: double as.double is.double single as.single as.single.default
+### Keywords: classes
+
+### ** Examples
+
+is.double(1)
+all(double(3) == 0)
+
+
+
+cleanEx()
+nameEx("dput")
+### * dput
+
+flush(stderr()); flush(stdout())
+
+### Name: dput
+### Title: Write an Object to a File or Recreate it
+### Aliases: dput dget
+### Keywords: file programming connection
+
+### ** Examples
+
+## Write an ASCII version of function mean to the file "foo"
+dput(mean, "foo")
+## And read it back into 'bar'
+bar <- dget("foo")
+## Create a function with comments
+baz <- function(x) {
+ # Subtract from one
+ 1-x
+}
+## and display it
+dput(baz)
+## and now display the saved source
+dput(baz, control = "useSource")
+
+## Numeric values:
+xx <- pi^(1:3)
+dput(xx)
+dput(xx, control = "digits17")
+dput(xx, control = "hexNumeric")
+dput(xx, "foo"); dget("foo") - xx # slight rounding on all platforms
+dput(xx, "foo", control = "digits17")
+dget("foo") - xx # slight rounding on some platforms
+dput(xx, "foo", control = "hexNumeric"); dget("foo") - xx
+unlink("foo")
+
+
+
+cleanEx()
+nameEx("drop")
+### * drop
+
+flush(stderr()); flush(stdout())
+
+### Name: drop
+### Title: Drop Redundant Extent Information
+### Aliases: drop
+### Keywords: array
+
+### ** Examples
+
+dim(drop(array(1:12, dim = c(1,3,1,1,2,1,2)))) # = 3 2 2
+drop(1:3 %*% 2:4) # scalar product
+
+
+
+cleanEx()
+nameEx("droplevels")
+### * droplevels
+
+flush(stderr()); flush(stdout())
+
+### Name: droplevels
+### Title: Drop Unused Levels from Factors
+### Aliases: droplevels droplevels.factor droplevels.data.frame
+### Keywords: category NA
+
+### ** Examples
+
+aq <- transform(airquality, Month = factor(Month, labels = month.abb[5:9]))
+aq <- subset(aq, Month != "Jul")
+table( aq $Month)
+table(droplevels(aq)$Month)
+
+
+
+cleanEx()
+nameEx("dump")
+### * dump
+
+flush(stderr()); flush(stdout())
+
+### Name: dump
+### Title: Text Representations of R Objects
+### Aliases: dump
+### Keywords: file connection
+
+### ** Examples
+
+x <- 1; y <- 1:10
+dump(ls(pattern = '^[xyz]'), "xyz.Rdmped")
+print(.Last.value)
+unlink("xyz.Rdmped")
+
+
+
+cleanEx()
+nameEx("duplicated")
+### * duplicated
+
+flush(stderr()); flush(stdout())
+
+### Name: duplicated
+### Title: Determine Duplicate Elements
+### Aliases: duplicated duplicated.default duplicated.data.frame
+### duplicated.matrix duplicated.array anyDuplicated
+### anyDuplicated.default anyDuplicated.array anyDuplicated.matrix
+### anyDuplicated.data.frame
+### Keywords: logic manip
+
+### ** Examples
+
+x <- c(9:20, 1:5, 3:7, 0:8)
+## extract unique elements
+(xu <- x[!duplicated(x)])
+## similar, same elements but different order:
+(xu2 <- x[!duplicated(x, fromLast = TRUE)])
+
+## xu == unique(x) but unique(x) is more efficient
+stopifnot(identical(xu, unique(x)),
+ identical(xu2, unique(x, fromLast = TRUE)))
+
+duplicated(iris)[140:143]
+
+duplicated(iris3, MARGIN = c(1, 3))
+anyDuplicated(iris) ## 143
+## Don't show:
+stopifnot(identical(anyDuplicated(iris), 143L),
+ identical(anyDuplicated(iris3, MARGIN = c(1, 3)), 143L))
+## End(Don't show)
+anyDuplicated(x)
+anyDuplicated(x, fromLast = TRUE)
+
+
+
+cleanEx()
+nameEx("dynload")
+### * dynload
+
+flush(stderr()); flush(stdout())
+
+### Name: dyn.load
+### Title: Foreign Function Interface
+### Aliases: dyn.load dyn.unload is.loaded
+### Keywords: interface
+
+### ** Examples
+
+## expect all of these to be false in R >= 3.0.0.
+is.loaded("supsmu") # Fortran entry point in stats
+is.loaded("supsmu", "stats", "Fortran")
+is.loaded("PDF", type = "External") # pdf() device in grDevices
+
+
+
+cleanEx()
+nameEx("eapply")
+### * eapply
+
+flush(stderr()); flush(stdout())
+
+### Name: eapply
+### Title: Apply a Function Over Values in an Environment
+### Aliases: eapply
+### Keywords: iteration environment list
+
+### ** Examples
+
+require(stats)
+
+env <- new.env(hash = FALSE) # so the order is fixed
+env$a <- 1:10
+env$beta <- exp(-3:3)
+env$logic <- c(TRUE, FALSE, FALSE, TRUE)
+# what have we there?
+utils::ls.str(env)
+
+# compute the mean for each list element
+ eapply(env, mean)
+unlist(eapply(env, mean, USE.NAMES = FALSE))
+
+# median and quartiles for each element (making use of "..." passing):
+eapply(env, quantile, probs = 1:3/4)
+eapply(env, quantile)
+
+
+
+cleanEx()
+nameEx("eigen")
+### * eigen
+
+flush(stderr()); flush(stdout())
+
+### Name: eigen
+### Title: Spectral Decomposition of a Matrix
+### Aliases: eigen print.eigen
+### Keywords: algebra array
+
+### ** Examples
+
+eigen(cbind(c(1,-1), c(-1,1)))
+eigen(cbind(c(1,-1), c(-1,1)), symmetric = FALSE)
+# same (different algorithm).
+
+eigen(cbind(1, c(1,-1)), only.values = TRUE)
+eigen(cbind(-1, 2:1)) # complex values
+eigen(print(cbind(c(0, 1i), c(-1i, 0)))) # Hermite ==> real Eigenvalues
+## 3 x 3:
+eigen(cbind( 1, 3:1, 1:3))
+eigen(cbind(-1, c(1:2,0), 0:2)) # complex values
+
+
+
+
+cleanEx()
+nameEx("encodeString")
+### * encodeString
+
+flush(stderr()); flush(stdout())
+
+### Name: encodeString
+### Title: Encode Character Vector as for Printing
+### Aliases: encodeString
+### Keywords: utilities
+
+### ** Examples
+
+x <- "ab\bc\ndef"
+print(x)
+cat(x) # interprets escapes
+cat(encodeString(x), "\n", sep = "") # similar to print()
+
+factor(x) # makes use of this to print the levels
+
+x <- c("a", "ab", "abcde")
+encodeString(x) # width = 0: use as little as possible
+encodeString(x, 2) # use two or more (left justified)
+encodeString(x, width = NA) # left justification
+encodeString(x, width = NA, justify = "c")
+encodeString(x, width = NA, justify = "r")
+encodeString(x, width = NA, quote = "'", justify = "r")
+
+
+
+cleanEx()
+nameEx("environment")
+### * environment
+
+flush(stderr()); flush(stdout())
+
+### Name: environment
+### Title: Environment Access
+### Aliases: environment environment<- .GlobalEnv globalenv emptyenv
+### baseenv is.environment new.env parent.env parent.env<-
+### .BaseNamespaceEnv environmentName env.profile enclosure
+### Keywords: data programming
+
+### ** Examples
+
+f <- function() "top level function"
+
+##-- all three give the same:
+environment()
+environment(f)
+.GlobalEnv
+
+ls(envir = environment(stats::approxfun(1:2, 1:2, method = "const")))
+
+is.environment(.GlobalEnv) # TRUE
+
+e1 <- new.env(parent = baseenv()) # this one has enclosure package:base.
+e2 <- new.env(parent = e1)
+assign("a", 3, envir = e1)
+ls(e1)
+ls(e2)
+exists("a", envir = e2) # this succeeds by inheritance
+exists("a", envir = e2, inherits = FALSE)
+exists("+", envir = e2) # this succeeds by inheritance
+
+eh <- new.env(hash = TRUE, size = NA)
+with(env.profile(eh), stopifnot(size == length(counts)))
+
+
+
+cleanEx()
+nameEx("eval")
+### * eval
+
+flush(stderr()); flush(stdout())
+
+### Name: eval
+### Title: Evaluate an (Unevaluated) Expression
+### Aliases: eval evalq eval.parent local
+### Keywords: data programming
+
+### ** Examples
+
+eval(2 ^ 2 ^ 3)
+mEx <- expression(2^2^3); mEx; 1 + eval(mEx)
+eval({ xx <- pi; xx^2}) ; xx
+
+a <- 3 ; aa <- 4 ; evalq(evalq(a+b+aa, list(a = 1)), list(b = 5)) # == 10
+a <- 3 ; aa <- 4 ; evalq(evalq(a+b+aa, -1), list(b = 5)) # == 12
+
+ev <- function() {
+ e1 <- parent.frame()
+ ## Evaluate a in e1
+ aa <- eval(expression(a), e1)
+ ## evaluate the expression bound to a in e1
+ a <- expression(x+y)
+ list(aa = aa, eval = eval(a, e1))
+}
+tst.ev <- function(a = 7) { x <- pi; y <- 1; ev() }
+tst.ev() #-> aa : 7, eval : 4.14
+
+a <- list(a = 3, b = 4)
+with(a, a <- 5) # alters the copy of a from the list, discarded.
+
+##
+## Example of evalq()
+##
+
+N <- 3
+env <- new.env()
+assign("N", 27, envir = env)
+## this version changes the visible copy of N only, since the argument
+## passed to eval is '4'.
+eval(N <- 4, env)
+N
+get("N", envir = env)
+## this version does the assignment in env, and changes N only there.
+evalq(N <- 5, env)
+N
+get("N", envir = env)
+
+
+##
+## Uses of local()
+##
+
+# Mutually recursive.
+# gg gets value of last assignment, an anonymous version of f.
+
+gg <- local({
+ k <- function(y)f(y)
+ f <- function(x) if(x) x*k(x-1) else 1
+})
+gg(10)
+sapply(1:5, gg)
+
+# Nesting locals: a is private storage accessible to k
+gg <- local({
+ k <- local({
+ a <- 1
+ function(y){print(a <<- a+1);f(y)}
+ })
+ f <- function(x) if(x) x*k(x-1) else 1
+})
+sapply(1:5, gg)
+
+ls(envir = environment(gg))
+ls(envir = environment(get("k", envir = environment(gg))))
+
+
+
+cleanEx()
+nameEx("exists")
+### * exists
+
+flush(stderr()); flush(stdout())
+
+### Name: exists
+### Title: Is an Object Defined?
+### Aliases: exists get0
+### Keywords: data
+
+### ** Examples
+
+## Define a substitute function if necessary:
+if(!exists("some.fun", mode = "function"))
+ some.fun <- function(x) { cat("some.fun(x)\n"); x }
+search()
+exists("ls", 2) # true even though ls is in pos = 3
+exists("ls", 2, inherits = FALSE) # false
+
+## These are true (in most circumstances):
+identical(ls, get0("ls"))
+identical(NULL, get0(".foo.bar.")) # default ifnotfound = NULL (!)
+## Don't show:
+stopifnot(identical(ls, get0("ls")),
+ is.null(get0(".foo.bar.")))
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("expand.grid")
+### * expand.grid
+
+flush(stderr()); flush(stdout())
+
+### Name: expand.grid
+### Title: Create a Data Frame from All Combinations of Factor Variables
+### Aliases: expand.grid
+### Keywords: models array
+
+### ** Examples
+
+require(utils)
+
+expand.grid(height = seq(60, 80, 5), weight = seq(100, 300, 50),
+ sex = c("Male","Female"))
+
+x <- seq(0, 10, length.out = 100)
+y <- seq(-1, 1, length.out = 20)
+d1 <- expand.grid(x = x, y = y)
+d2 <- expand.grid(x = x, y = y, KEEP.OUT.ATTRS = FALSE)
+object.size(d1) - object.size(d2)
+##-> 5992 or 8832 (on 32- / 64-bit platform)
+## Don't show:
+stopifnot(object.size(d1) > object.size(d2))
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("expression")
+### * expression
+
+flush(stderr()); flush(stdout())
+
+### Name: expression
+### Title: Unevaluated Expressions
+### Aliases: expression is.expression as.expression as.expression.default
+### Keywords: programming dplot
+
+### ** Examples
+
+length(ex1 <- expression(1 + 0:9)) # 1
+ex1
+eval(ex1) # 1:10
+
+length(ex3 <- expression(u, v, 1+ 0:9)) # 3
+mode(ex3 [3]) # expression
+mode(ex3[[3]]) # call
+rm(ex3)
+
+
+
+cleanEx()
+nameEx("extSoftVersion")
+### * extSoftVersion
+
+flush(stderr()); flush(stdout())
+
+### Name: extSoftVersion
+### Title: Report Versions of Third-Party Software
+### Aliases: extSoftVersion
+
+### ** Examples
+
+extSoftVersion()
+## the PCRE version
+sub(" .*", "", extSoftVersion()["PCRE"])
+
+
+
+cleanEx()
+nameEx("factor")
+### * factor
+
+flush(stderr()); flush(stdout())
+
+### Name: factor
+### Title: Factors
+### Aliases: factor ordered is.factor is.ordered as.factor as.ordered
+### is.na<-.factor Math.factor Ops.factor Summary.factor Ops.ordered
+### Summary.ordered addNA .valid.factor
+### Keywords: category NA
+
+### ** Examples
+
+(ff <- factor(substring("statistics", 1:10, 1:10), levels = letters))
+as.integer(ff) # the internal codes
+(f. <- factor(ff)) # drops the levels that do not occur
+ff[, drop = TRUE] # the same, more transparently
+
+factor(letters[1:20], labels = "letter")
+
+class(ordered(4:1)) # "ordered", inheriting from "factor"
+z <- factor(LETTERS[3:1], ordered = TRUE)
+## and "relational" methods work:
+stopifnot(sort(z)[c(1,3)] == range(z), min(z) < max(z))
+## Don't show:
+of <- ordered(ff)
+stopifnot(identical(range(of, rev(of)), of[3:2]),
+ identical(max(of), of[2]))
+## End(Don't show)
+
+## suppose you want "NA" as a level, and to allow missing values.
+(x <- factor(c(1, 2, NA), exclude = NULL))
+is.na(x)[2] <- TRUE
+x # [1] 1 <NA> <NA>
+is.na(x)
+# [1] FALSE TRUE FALSE
+
+## More rational, since R 3.4.0 :
+factor(c(1:2, NA), exclude = "" ) # keeps <NA> , as
+factor(c(1:2, NA), exclude = NULL) # always did
+## exclude = <character>
+z # ordered levels 'A < B < C'
+factor(z, exclude = "C") # does exclude
+factor(z, exclude = "B") # ditto
+
+## Using addNA()
+Month <- airquality$Month
+table(addNA(Month))
+table(addNA(Month, ifany = TRUE))
+
+
+
+cleanEx()
+nameEx("file.access")
+### * file.access
+
+flush(stderr()); flush(stdout())
+
+### Name: file.access
+### Title: Ascertain File Accessibility
+### Aliases: file.access
+### Keywords: file
+
+### ** Examples
+
+fa <- file.access(dir("."))
+table(fa) # count successes & failures
+
+
+cleanEx()
+nameEx("file.info")
+### * file.info
+
+flush(stderr()); flush(stdout())
+
+### Name: file.info
+### Title: Extract File Information
+### Aliases: file.info file.mode file.mtime file.size
+### Keywords: file
+
+### ** Examples
+
+ncol(finf <- file.info(dir())) # at least six
+## Those that are more than 100 days old :
+finf <- file.info(dir(), extra_cols = FALSE)
+finf[difftime(Sys.time(), finf[,"mtime"], units = "days") > 100 , 1:4]
+
+file.info("no-such-file-exists")
+
+
+
+cleanEx()
+nameEx("file.show")
+### * file.show
+
+flush(stderr()); flush(stdout())
+
+### Name: file.show
+### Title: Display One or More Text Files
+### Aliases: file.show
+### Keywords: file
+
+### ** Examples
+
+file.show(file.path(R.home("doc"), "COPYRIGHTS"))
+
+
+
+cleanEx()
+nameEx("files")
+### * files
+
+flush(stderr()); flush(stdout())
+
+### Name: files
+### Title: File Manipulation
+### Aliases: files file.append file.copy file.create file.exists
+### file.remove file.rename file.symlink file.link
+### Keywords: file
+
+### ** Examples
+
+cat("file A\n", file = "A")
+cat("file B\n", file = "B")
+file.append("A", "B")
+file.create("A")
+file.append("A", rep("B", 10))
+if(interactive()) file.show("A")
+file.copy("A", "C")
+dir.create("tmp")
+file.copy(c("A", "B"), "tmp")
+list.files("tmp")
+setwd("tmp")
+file.remove("B")
+file.symlink(file.path("..", c("A", "B")), ".")
+setwd("..")
+unlink("tmp", recursive = TRUE)
+file.remove("A", "B", "C")
+
+
+
+cleanEx()
+nameEx("files2")
+### * files2
+
+flush(stderr()); flush(stdout())
+
+### Name: files2
+### Title: Manipulaton of Directories and File Permissions
+### Aliases: dir.create dir.exists Sys.chmod Sys.umask umask
+### Keywords: file
+
+### ** Examples
+## Not run:
+##D ## Fix up maximal allowed permissions in a file tree
+##D Sys.chmod(list.dirs("."), "777")
+##D f <- list.files(".", all.files = TRUE, full.names = TRUE, recursive TRUE)
+##D Sys.chmod(f, (file.info(f)$mode | "664"))
+## End(Not run)
+
+
+cleanEx()
+nameEx("findInterval")
+### * findInterval
+
+flush(stderr()); flush(stdout())
+
+### Name: findInterval
+### Title: Find Interval Numbers or Indices
+### Aliases: findInterval
+### Keywords: arith utilities
+
+### ** Examples
+
+x <- 2:18
+v <- c(5, 10, 15) # create two bins [5,10) and [10,15)
+cbind(x, findInterval(x, v))
+
+N <- 100
+X <- sort(round(stats::rt(N, df = 2), 2))
+tt <- c(-100, seq(-2, 2, len = 201), +100)
+it <- findInterval(tt, X)
+tt[it < 1 | it >= N] # only first and last are outside range(X)
+
+## 'left.open = TRUE' means "mirroring" :
+N <- length(v)
+stopifnot(identical(
+ findInterval( x, v, left.open=TRUE) ,
+ N - findInterval(-x, -v[N:1])))
+
+
+
+cleanEx()
+nameEx("force")
+### * force
+
+flush(stderr()); flush(stdout())
+
+### Name: force
+### Title: Force Evaluation of an Argument
+### Aliases: force
+### Keywords: data programming
+
+### ** Examples
+
+f <- function(y) function() y
+lf <- vector("list", 5)
+for (i in seq_along(lf)) lf[[i]] <- f(i)
+lf[[1]]() # returns 5
+
+g <- function(y) { force(y); function() y }
+lg <- vector("list", 5)
+for (i in seq_along(lg)) lg[[i]] <- g(i)
+lg[[1]]() # returns 1
+
+## This is identical to
+g <- function(y) { y; function() y }
+
+
+
+cleanEx()
+nameEx("formals")
+### * formals
+
+flush(stderr()); flush(stdout())
+
+### Name: formals
+### Title: Access to and Manipulation of the Formal Arguments
+### Aliases: formals formals<-
+### Keywords: programming
+
+### ** Examples
+
+require(stats)
+formals(lm)
+
+## If you just want the names of the arguments, use formalArgs instead.
+names(formals(lm))
+methods:: formalArgs(lm) # same
+
+## formals returns a pairlist. Arguments with no default have type symbol (aka name).
+str(formals(lm))
+
+## formals returns NULL for primitive functions. Use it in combination with
+## args for this case.
+is.primitive(`+`)
+formals(`+`)
+formals(args(`+`))
+
+## You can overwrite the formal arguments of a function (though this is
+## advanced, dangerous coding).
+f <- function(x) a + b
+formals(f) <- alist(a = , b = 3)
+f # function(a, b = 3) a + b
+f(2) # result = 5
+
+
+
+cleanEx()
+nameEx("format")
+### * format
+
+flush(stderr()); flush(stdout())
+
+### Name: format
+### Title: Encode in a Common Format
+### Aliases: format format.AsIs format.data.frame format.default
+### format.factor
+### Keywords: character print
+
+### ** Examples
+
+format(1:10)
+format(1:10, trim = TRUE)
+
+zz <- data.frame("(row names)"= c("aaaaa", "b"), check.names = FALSE)
+format(zz)
+format(zz, justify = "left")
+
+## use of nsmall
+format(13.7)
+format(13.7, nsmall = 3)
+format(c(6.0, 13.1), digits = 2)
+format(c(6.0, 13.1), digits = 2, nsmall = 1)
+
+## use of scientific
+format(2^31-1)
+format(2^31-1, scientific = TRUE)
+
+## a list
+z <- list(a = letters[1:3], b = (-pi+0i)^((-2:2)/2), c = c(1,10,100,1000),
+ d = c("a", "longer", "character", "string"),
+ q = quote( a + b ), e = expression(1+x))
+## can you find the "2" small differences?
+(f1 <- format(z, digits = 2))
+(f2 <- format(z, digits = 2, justify = "left", trim = FALSE))
+f1 == f2 ## 2 FALSE, 4 TRUE
+
+
+
+cleanEx()
+nameEx("format.info")
+### * format.info
+
+flush(stderr()); flush(stdout())
+
+### Name: format.info
+### Title: format(.) Information
+### Aliases: format.info
+### Keywords: character print programming
+
+### ** Examples
+
+dd <- options("digits") ; options(digits = 7) #-- for the following
+format.info(123) # 3 0 0
+format.info(pi) # 8 6 0
+format.info(1e8) # 5 0 1 - exponential "1e+08"
+format.info(1e222) # 6 0 2 - exponential "1e+222"
+
+x <- pi*10^c(-10,-2,0:2,8,20)
+names(x) <- formatC(x, width = 1, digits = 3, format = "g")
+cbind(sapply(x, format))
+t(sapply(x, format.info))
+
+## using at least 8 digits right of "."
+t(sapply(x, format.info, nsmall = 8))
+
+# Reset old options:
+options(dd)
+
+
+
+cleanEx()
+nameEx("format.pval")
+### * format.pval
+
+flush(stderr()); flush(stdout())
+
+### Name: format.pval
+### Title: Format P Values
+### Aliases: format.pval
+### Keywords: print
+
+### ** Examples
+
+format.pval(c(stats::runif(5), pi^-100, NA))
+format.pval(c(0.1, 0.0001, 1e-27))
+
+
+
+cleanEx()
+nameEx("formatDL")
+### * formatDL
+
+flush(stderr()); flush(stdout())
+
+### Name: formatDL
+### Title: Format Description Lists
+### Aliases: formatDL
+### Keywords: print
+
+### ** Examples
+
+## Provide a nice summary of the numerical characteristics of the
+## machine R is running on:
+writeLines(formatDL(unlist(.Machine)))
+## Inspect Sys.getenv() results in "list" style (by default, these are
+## printed in "table" style):
+writeLines(formatDL(Sys.getenv(), style = "list"))
+
+
+
+cleanEx()
+nameEx("formatc")
+### * formatc
+
+flush(stderr()); flush(stdout())
+
+### Name: formatC
+### Title: Formatting Using C-style Formats
+### Aliases: formatC prettyNum .format.zeros
+### Keywords: character print
+
+### ** Examples
+
+xx <- pi * 10^(-5:4)
+cbind(format(xx, digits = 4), formatC(xx))
+cbind(formatC(xx, width = 9, flag = "-"))
+cbind(formatC(xx, digits = 5, width = 8, format = "f", flag = "0"))
+cbind(format(xx, digits = 4), formatC(xx, digits = 4, format = "fg"))
+
+formatC( c("a", "Abc", "no way"), width = -7) # <=> flag = "-"
+formatC(c((-1:1)/0,c(1,100)*pi), width = 8, digits = 1)
+
+## note that some of the results here depend on the implementation
+## of long-double arithmetic, which is platform-specific.
+xx <- c(1e-12,-3.98765e-10,1.45645e-69,1e-70,pi*1e37,3.44e4)
+## 1 2 3 4 5 6
+formatC(xx)
+formatC(xx, format = "fg") # special "fixed" format.
+formatC(xx[1:4], format = "f", digits = 75) #>> even longer strings
+
+formatC(c(3.24, 2.3e-6), format = "f", digits = 11, drop0trailing = TRUE)
+
+r <- c("76491283764.97430", "29.12345678901", "-7.1234", "-100.1","1123")
+## American:
+prettyNum(r, big.mark = ",")
+## Some Europeans:
+prettyNum(r, big.mark = "'", decimal.mark = ",")
+
+(dd <- sapply(1:10, function(i) paste((9:0)[1:i], collapse = "")))
+prettyNum(dd, big.mark = "'")
+
+## examples of 'small.mark'
+pN <- stats::pnorm(1:7, lower.tail = FALSE)
+cbind(format (pN, small.mark = " ", digits = 15))
+cbind(formatC(pN, small.mark = " ", digits = 17, format = "f"))
+
+cbind(ff <- format(1.2345 + 10^(0:5), width = 11, big.mark = "'"))
+## all with same width (one more than the specified minimum)
+
+## individual formatting to common width:
+fc <- formatC(1.234 + 10^(0:8), format = "fg", width = 11, big.mark = "'")
+cbind(fc)
+## Powers of two, stored exactly, formatted individually:
+pow.2 <- formatC(2^-(1:32), digits = 24, width = 1, format = "fg")
+## nicely printed (the last line showing 5^32 exactly):
+noquote(cbind(pow.2))
+
+## complex numbers:
+r <- 10.0000001; rv <- (r/10)^(1:10)
+(zv <- (rv + 1i*rv))
+op <- options(digits = 7) ## (system default)
+(pnv <- prettyNum(zv))
+stopifnot(pnv == "1+1i", pnv == format(zv),
+ pnv == prettyNum(zv, drop0trailing = TRUE))
+## more digits change the picture:
+options(digits = 8)
+head(fv <- format(zv), 3)
+prettyNum(fv)
+prettyNum(fv, drop0trailing = TRUE) # a bit nicer
+options(op)
+
+## The ' flag :
+doLC <- FALSE # R warns, so change to TRUE manually if you want see the effect
+if(doLC)
+ oldLC <- Sys.setlocale("LC_NUMERIC", "de_CH.UTF-8")
+formatC(1.234 + 10^(0:4), format = "fg", width = 11, flag = "'")
+## --> ..... " 1'001" " 10'001" on supported platforms
+if(doLC) ## revert, typically to "C" :
+ Sys.setlocale("LC_NUMERIC", oldLC)
+
+
+
+cleanEx()
+nameEx("function")
+### * function
+
+flush(stderr()); flush(stdout())
+
+### Name: function
+### Title: Function Definition
+### Aliases: function return closure
+### Keywords: programming
+
+### ** Examples
+
+norm <- function(x) sqrt(x%*%x)
+norm(1:4)
+
+## An anonymous function:
+(function(x, y){ z <- x^2 + y^2; x+y+z })(0:7, 1)
+
+
+
+cleanEx()
+nameEx("funprog")
+### * funprog
+
+flush(stderr()); flush(stdout())
+
+### Name: funprog
+### Title: Common Higher-Order Functions in Functional Programming
+### Languages
+### Aliases: Filter Find Map Negate Reduce Position
+### Keywords: programming
+
+### ** Examples
+
+## A general-purpose adder:
+add <- function(x) Reduce("+", x)
+add(list(1, 2, 3))
+## Like sum(), but can also used for adding matrices etc., as it will
+## use the appropriate '+' method in each reduction step.
+## More generally, many generics meant to work on arbitrarily many
+## arguments can be defined via reduction:
+FOO <- function(...) Reduce(FOO2, list(...))
+FOO2 <- function(x, y) UseMethod("FOO2")
+## FOO() methods can then be provided via FOO2() methods.
+
+## A general-purpose cumulative adder:
+cadd <- function(x) Reduce("+", x, accumulate = TRUE)
+cadd(seq_len(7))
+
+## A simple function to compute continued fractions:
+cfrac <- function(x) Reduce(function(u, v) u + 1 / v, x, right = TRUE)
+## Continued fraction approximation for pi:
+cfrac(c(3, 7, 15, 1, 292))
+## Continued fraction approximation for Euler's number (e):
+cfrac(c(2, 1, 2, 1, 1, 4, 1, 1, 6, 1, 1, 8))
+
+## Iterative function application:
+Funcall <- function(f, ...) f(...)
+## Compute log(exp(acos(cos(0))
+Reduce(Funcall, list(log, exp, acos, cos), 0, right = TRUE)
+## n-fold iterate of a function, functional style:
+Iterate <- function(f, n = 1)
+ function(x) Reduce(Funcall, rep.int(list(f), n), x, right = TRUE)
+## Continued fraction approximation to the golden ratio:
+Iterate(function(x) 1 + 1 / x, 30)(1)
+## which is the same as
+cfrac(rep.int(1, 31))
+## Computing square root approximations for x as fixed points of the
+## function t |-> (t + x / t) / 2, as a function of the initial value:
+asqrt <- function(x, n) Iterate(function(t) (t + x / t) / 2, n)
+asqrt(2, 30)(10) # Starting from a positive value => +sqrt(2)
+asqrt(2, 30)(-1) # Starting from a negative value => -sqrt(2)
+
+## A list of all functions in the base environment:
+funs <- Filter(is.function, sapply(ls(baseenv()), get, baseenv()))
+## Functions in base with more than 10 arguments:
+names(Filter(function(f) length(formals(f)) > 10, funs))
+## Number of functions in base with a '...' argument:
+length(Filter(function(f)
+ any(names(formals(f)) %in% "..."),
+ funs))
+
+
+cleanEx()
+nameEx("gc")
+### * gc
+
+flush(stderr()); flush(stdout())
+
+### Name: gc
+### Title: Garbage Collection
+### Aliases: gc gcinfo
+### Keywords: environment
+
+### ** Examples
+
+
+cleanEx()
+nameEx("gc.time")
+### * gc.time
+
+flush(stderr()); flush(stdout())
+
+### Name: gc.time
+### Title: Report Time Spent in Garbage Collection
+### Aliases: gc.time
+### Keywords: utilities
+
+### ** Examples
+
+gc.time()
+
+
+
+cleanEx()
+nameEx("get")
+### * get
+
+flush(stderr()); flush(stdout())
+
+### Name: get
+### Title: Return the Value of a Named Object
+### Aliases: get mget dynGet
+### Keywords: data
+
+### ** Examples
+
+get("%o%")
+
+## test mget
+e1 <- new.env()
+mget(letters, e1, ifnotfound = as.list(LETTERS))
+
+
+
+cleanEx()
+nameEx("getCallingDLL")
+### * getCallingDLL
+
+flush(stderr()); flush(stdout())
+
+### Name: getCallingDLL
+### Title: Compute DLL for Native Interface Call
+### Aliases: getCallingDLL getCallingDLLe
+### Keywords: internal
+
+### ** Examples
+
+if(exists("ansari.test"))
+ getCallingDLL(ansari.test)
+
+
+
+cleanEx()
+nameEx("getDLLRegisteredRoutines")
+### * getDLLRegisteredRoutines
+
+flush(stderr()); flush(stdout())
+
+### Name: getDLLRegisteredRoutines
+### Title: Reflectance Information for C/Fortran routines in a DLL
+### Aliases: getDLLRegisteredRoutines getDLLRegisteredRoutines.character
+### getDLLRegisteredRoutines.DLLInfo print.NativeRoutineList
+### print.DLLRegisteredRoutines
+### Keywords: interface
+
+### ** Examples
+
+dlls <- getLoadedDLLs()
+getDLLRegisteredRoutines(dlls[["base"]])
+
+getDLLRegisteredRoutines("stats")
+
+
+
+cleanEx()
+nameEx("getLoadedDLLs")
+### * getLoadedDLLs
+
+flush(stderr()); flush(stdout())
+
+### Name: getLoadedDLLs
+### Title: Get DLLs Loaded in Current Session
+### Aliases: getLoadedDLLs print.DLLInfo print.DLLInfoList $.DLLInfo
+### DLLInfo DLLInfoList
+### Keywords: interface
+
+### ** Examples
+
+getLoadedDLLs()
+
+
+
+cleanEx()
+nameEx("gettext")
+### * gettext
+
+flush(stderr()); flush(stdout())
+
+### Name: gettext
+### Title: Translate Text Messages
+### Aliases: gettext ngettext bindtextdomain
+### Keywords: utilities character
+
+### ** Examples
+
+bindtextdomain("R") # non-null if and only if NLS is enabled
+
+for(n in 0:3)
+ print(sprintf(ngettext(n, "%d variable has missing values",
+ "%d variables have missing values"),
+ n))
+
+## Not run:
+##D ## for translation, those strings should appear in R-pkg.pot as
+##D msgid "%d variable has missing values"
+##D msgid_plural "%d variables have missing values"
+##D msgstr[0] ""
+##D msgstr[1] ""
+## End(Not run)
+
+miss <- c("one", "or", "another")
+cat(ngettext(length(miss), "variable", "variables"),
+ paste(sQuote(miss), collapse = ", "),
+ ngettext(length(miss), "contains", "contain"), "missing values\n")
+
+## better for translators would be to use
+cat(sprintf(ngettext(length(miss),
+ "variable %s contains missing values\n",
+ "variables %s contain missing values\n"),
+ paste(sQuote(miss), collapse = ", ")))
+
+
+
+cleanEx()
+nameEx("getwd")
+### * getwd
+
+flush(stderr()); flush(stdout())
+
+### Name: getwd
+### Title: Get or Set Working Directory
+### Aliases: getwd setwd
+### Keywords: utilities
+
+### ** Examples
+
+(WD <- getwd())
+if (!is.null(WD)) setwd(WD)
+
+
+
+cleanEx()
+nameEx("gl")
+### * gl
+
+flush(stderr()); flush(stdout())
+
+### Name: gl
+### Title: Generate Factor Levels
+### Aliases: gl
+### Keywords: category arith
+
+### ** Examples
+
+## First control, then treatment:
+gl(2, 8, labels = c("Control", "Treat"))
+## 20 alternating 1s and 2s
+gl(2, 1, 20)
+## alternating pairs of 1s and 2s
+gl(2, 2, 20)
+
+
+
+cleanEx()
+nameEx("grep")
+### * grep
+
+flush(stderr()); flush(stdout())
+
+### Name: grep
+### Title: Pattern Matching and Replacement
+### Aliases: grep grepl sub gsub regexpr gregexpr regexec
+### Keywords: character utilities
+
+### ** Examples
+
+grep("[a-z]", letters)
+
+txt <- c("arm","foot","lefroo", "bafoobar")
+if(length(i <- grep("foo", txt)))
+ cat("'foo' appears at least once in\n\t", txt, "\n")
+i # 2 and 4
+txt[i]
+
+## Double all 'a' or 'b's; "\" must be escaped, i.e., 'doubled'
+gsub("([ab])", "\\1_\\1_", "abc and ABC")
+
+txt <- c("The", "licenses", "for", "most", "software", "are",
+ "designed", "to", "take", "away", "your", "freedom",
+ "to", "share", "and", "change", "it.",
+ "", "By", "contrast,", "the", "GNU", "General", "Public", "License",
+ "is", "intended", "to", "guarantee", "your", "freedom", "to",
+ "share", "and", "change", "free", "software", "--",
+ "to", "make", "sure", "the", "software", "is",
+ "free", "for", "all", "its", "users")
+( i <- grep("[gu]", txt) ) # indices
+stopifnot( txt[i] == grep("[gu]", txt, value = TRUE) )
+
+## Note that in locales such as en_US this includes B as the
+## collation order is aAbBcCdEe ...
+(ot <- sub("[b-e]",".", txt))
+txt[ot != gsub("[b-e]",".", txt)]#- gsub does "global" substitution
+
+txt[gsub("g","#", txt) !=
+ gsub("g","#", txt, ignore.case = TRUE)] # the "G" words
+
+regexpr("en", txt)
+
+gregexpr("e", txt)
+
+## Using grepl() for filtering
+## Find functions with argument names matching "warn":
+findArgs <- function(env, pattern) {
+ nms <- ls(envir = as.environment(env))
+ nms <- nms[is.na(match(nms, c("F","T")))] # <-- work around "checking hack"
+ aa <- sapply(nms, function(.) { o <- get(.)
+ if(is.function(o)) names(formals(o)) })
+ iw <- sapply(aa, function(a) any(grepl(pattern, a, ignore.case=TRUE)))
+ aa[iw]
+}
+findArgs("package:base", "warn")
+
+## trim trailing white space
+str <- "Now is the time "
+sub(" +$", "", str) ## spaces only
+## what is considered 'white space' depends on the locale.
+sub("[[:space:]]+$", "", str) ## white space, POSIX-style
+## what PCRE considered white space changed in version 8.34: see ?regex
+sub("\\s+$", "", str, perl = TRUE) ## PCRE-style white space
+
+## capitalizing
+txt <- "a test of capitalizing"
+gsub("(\\w)(\\w*)", "\\U\\1\\L\\2", txt, perl=TRUE)
+gsub("\\b(\\w)", "\\U\\1", txt, perl=TRUE)
+
+txt2 <- "useRs may fly into JFK or laGuardia"
+gsub("(\\w)(\\w*)(\\w)", "\\U\\1\\E\\2\\U\\3", txt2, perl=TRUE)
+ sub("(\\w)(\\w*)(\\w)", "\\U\\1\\E\\2\\U\\3", txt2, perl=TRUE)
+
+## named capture
+notables <- c(" Ben Franklin and Jefferson Davis",
+ "\tMillard Fillmore")
+# name groups 'first' and 'last'
+name.rex <- "(?<first>[[:upper:]][[:lower:]]+) (?<last>[[:upper:]][[:lower:]]+)"
+(parsed <- regexpr(name.rex, notables, perl = TRUE))
+gregexpr(name.rex, notables, perl = TRUE)[[2]]
+parse.one <- function(res, result) {
+ m <- do.call(rbind, lapply(seq_along(res), function(i) {
+ if(result[i] == -1) return("")
+ st <- attr(result, "capture.start")[i, ]
+ substring(res[i], st, st + attr(result, "capture.length")[i, ] - 1)
+ }))
+ colnames(m) <- attr(result, "capture.names")
+ m
+}
+parse.one(notables, parsed)
+
+## Decompose a URL into its components.
+## Example by LT (http://www.cs.uiowa.edu/~luke/R/regexp.html).
+x <- "http://stat.umn.edu:80/xyz"
+m <- regexec("^(([^:]+)://)?([^:/]+)(:([0-9]+))?(/.*)", x)
+m
+regmatches(x, m)
+## Element 3 is the protocol, 4 is the host, 6 is the port, and 7
+## is the path. We can use this to make a function for extracting the
+## parts of a URL:
+URL_parts <- function(x) {
+ m <- regexec("^(([^:]+)://)?([^:/]+)(:([0-9]+))?(/.*)", x)
+ parts <- do.call(rbind,
+ lapply(regmatches(x, m), `[`, c(3L, 4L, 6L, 7L)))
+ colnames(parts) <- c("protocol","host","port","path")
+ parts
+}
+URL_parts(x)
+
+## There is no gregexec() yet, but one can emulate it by running
+## regexec() on the regmatches obtained via gregexpr(). E.g.:
+pattern <- "([[:alpha:]]+)([[:digit:]]+)"
+s <- "Test: A1 BC23 DEF456"
+lapply(regmatches(s, gregexpr(pattern, s)),
+ function(e) regmatches(e, regexec(pattern, e)))
+
+
+
+cleanEx()
+nameEx("grepRaw")
+### * grepRaw
+
+flush(stderr()); flush(stdout())
+
+### Name: grepRaw
+### Title: Pattern Matching for Raw Vectors
+### Aliases: grepRaw
+### Keywords: utilities
+
+### ** Examples
+
+grepRaw("no match", "textText") # integer(0): no match
+grepRaw("adf", "adadfadfdfadadf") # 3 - the first match
+grepRaw("adf", "adadfadfdfadadf", all=TRUE, fixed=TRUE)
+## [1] 3 6 13 -- three matches
+
+
+
+cleanEx()
+nameEx("groupGeneric")
+### * groupGeneric
+
+flush(stderr()); flush(stdout())
+
+### Name: groupGeneric
+### Title: S3 Group Generic Functions
+### Aliases: S3groupGeneric groupGeneric .Group Math Math.data.frame Ops
+### Ops.data.frame Summary Summary.data.frame Complex 'group generic'
+### Keywords: methods
+
+### ** Examples
+
+require(utils)
+
+d.fr <- data.frame(x = 1:9, y = stats::rnorm(9))
+class(1 + d.fr) == "data.frame" ##-- add to d.f. ...
+
+methods("Math")
+methods("Ops")
+methods("Summary")
+methods("Complex") # none in base R
+
+
+
+cleanEx()
+nameEx("grouping")
+### * grouping
+
+flush(stderr()); flush(stdout())
+
+### Name: grouping
+### Title: Grouping Permutation
+### Aliases: grouping
+### Keywords: manip
+
+### ** Examples
+
+(ii <- grouping(x <- c(1, 1, 3:1, 1:4, 3), y <- c(9, 9:1), z <- c(2, 1:9)))
+## 6 5 2 1 7 4 10 8 3 9
+rbind(x, y, z)[, ii]
+
+
+
+cleanEx()
+nameEx("gzcon")
+### * gzcon
+
+flush(stderr()); flush(stdout())
+
+### Name: gzcon
+### Title: (De)compress I/O Through Connections
+### Aliases: gzcon
+### Keywords: file connection
+
+### ** Examples
+
+
+## gzfile and gzcon can inter-work.
+## Of course here one would use gzfile, but file() can be replaced by
+## any other connection generator.
+zz <- gzfile("ex.gz", "w")
+cat("TITLE extra line", "2 3 5 7", "", "11 13 17", file = zz, sep = "\n")
+close(zz)
+readLines(zz <- gzcon(file("ex.gz", "rb")))
+close(zz)
+unlink("ex.gz")
+zz <- gzcon(file("ex2.gz", "wb"))
+cat("TITLE extra line", "2 3 5 7", "", "11 13 17", file = zz, sep = "\n")
+close(zz)
+readLines(zz <- gzfile("ex2.gz"))
+close(zz)
+unlink("ex2.gz")
+
+
+
+cleanEx()
+nameEx("hexmode")
+### * hexmode
+
+flush(stderr()); flush(stdout())
+
+### Name: hexmode
+### Title: Display Numbers in Hexadecimal
+### Aliases: as.hexmode format.hexmode print.hexmode as.character.hexmode
+### [.hexmode !.hexmode |.hexmode &.hexmode xor.hexmode hexmode
+### Keywords: utilities print
+
+### ** Examples
+
+i <- as.hexmode("7fffffff")
+i; class(i)
+identical(as.integer(i), .Machine$integer.max)
+
+hm <- as.hexmode(c(NA, 1)); hm
+as.integer(hm)
+
+
+
+cleanEx()
+nameEx("iconv")
+### * iconv
+
+flush(stderr()); flush(stdout())
+
+### Name: iconv
+### Title: Convert Character Vector between Encodings
+### Aliases: iconv iconvlist
+### Keywords: character utilities
+
+### ** Examples
+
+## In principle, as not all systems have iconvlist
+try(utils::head(iconvlist(), n = 50))
+
+## Not run:
+##D ## convert from Latin-2 to UTF-8: two of the glibc iconv variants.
+##D iconv(x, "ISO_8859-2", "UTF-8")
+##D iconv(x, "LATIN2", "UTF-8")
+## End(Not run)
+
+## Both x below are in latin1 and will only display correctly in a
+## locale that can represent and display latin1.
+x <- "fa\xE7ile"
+Encoding(x) <- "latin1"
+x
+charToRaw(xx <- iconv(x, "latin1", "UTF-8"))
+xx
+
+iconv(x, "latin1", "ASCII") # NA
+iconv(x, "latin1", "ASCII", "?") # "fa?ile"
+iconv(x, "latin1", "ASCII", "") # "faile"
+iconv(x, "latin1", "ASCII", "byte") # "fa<e7>ile"
+
+## Extracts from old R help files (they are nowadays in UTF-8)
+x <- c("Ekstr\xf8m", "J\xf6reskog", "bi\xdfchen Z\xfcrcher")
+Encoding(x) <- "latin1"
+x
+try(iconv(x, "latin1", "ASCII//TRANSLIT")) # platform-dependent
+iconv(x, "latin1", "ASCII", sub = "byte")
+## and for Windows' 'Unicode'
+str(xx <- iconv(x, "latin1", "UTF-16LE", toRaw = TRUE))
+iconv(xx, "UTF-16LE", "UTF-8")
+
+
+
+cleanEx()
+nameEx("icuSetCollate")
+### * icuSetCollate
+
+flush(stderr()); flush(stdout())
+
+### Name: icuSetCollate
+### Title: Setup Collation by ICU
+### Aliases: icuSetCollate icuGetCollate R_ICU_LOCALE
+### Keywords: utilities
+
+### ** Examples
+
+
+cleanEx()
+nameEx("identical")
+### * identical
+
+flush(stderr()); flush(stdout())
+
+### Name: identical
+### Title: Test Objects for Exact Equality
+### Aliases: identical
+### Keywords: programming logic iteration
+
+### ** Examples
+
+identical(1, NULL) ## FALSE -- don't try this with ==
+identical(1, 1.) ## TRUE in R (both are stored as doubles)
+identical(1, as.integer(1)) ## FALSE, stored as different types
+
+x <- 1.0; y <- 0.99999999999
+## how to test for object equality allowing for numeric fuzz :
+(E <- all.equal(x, y))
+isTRUE(E) # which is simply defined to just use
+identical(TRUE, E)
+## If all.equal thinks the objects are different, it returns a
+## character string, and the above expression evaluates to FALSE
+
+## even for unusual R objects :
+identical(.GlobalEnv, environment())
+
+### ------- Pickyness Flags : -----------------------------
+
+## the infamous example:
+identical(0., -0.) # TRUE, i.e. not differentiated
+identical(0., -0., num.eq = FALSE)
+## similar:
+identical(NaN, -NaN) # TRUE
+identical(NaN, -NaN, single.NA = FALSE) # differ on bit-level
+
+### For functions ("closure"s): ----------------------------------------------
+### ~~~~~~~~~
+f <- function(x) x
+f
+g <- compiler::cmpfun(f)
+g
+identical(f, g) # TRUE, as bytecode is ignored by default
+identical(f, g, ignore.bytecode=FALSE) # FALSE: bytecode differs
+
+## GLM families contain several functions, some of which share an environment:
+p1 <- poisson() ; p2 <- poisson()
+identical(p1, p2) # FALSE
+identical(p1, p2, ignore.environment=TRUE) # TRUE
+
+## in interactive use, the 'keep.source' option is typically true:
+op <- options(keep.source = TRUE) # and so, these have differing "srcref" :
+f1 <- function() {}
+f2 <- function() {}
+identical(f1,f2)# ignore.srcref= TRUE : TRUE
+identical(f1,f2, ignore.srcref=FALSE)# FALSE
+options(op) # revert to previous state
+
+## Don't show:
+m0 <- m <- structure(cbind(I = 1, a = 1:3), foo = "bar", class = "matrix")
+attributes(m0) <- rev(attributes(m))
+names(attributes(m0)) # 'dim' remains first, interestingly...
+
+stopifnot(identical(0, -0), !identical(0, -0, num.eq = FALSE),
+ identical(NaN, -NaN), !identical(NaN, -NaN, single.NA = FALSE),
+ identical(m, m0), !identical(m, m0, attrib.as.set = FALSE) )
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("ifelse")
+### * ifelse
+
+flush(stderr()); flush(stdout())
+
+### Name: ifelse
+### Title: Conditional Element Selection
+### Aliases: ifelse
+### Keywords: logic programming
+
+### ** Examples
+
+x <- c(6:-4)
+sqrt(x) #- gives warning
+sqrt(ifelse(x >= 0, x, NA)) # no warning
+
+## Note: the following also gives the warning !
+ifelse(x >= 0, sqrt(x), NA)
+
+
+## ifelse() strips attributes
+## This is important when working with Dates and factors
+x <- seq(as.Date("2000-02-29"), as.Date("2004-10-04"), by = "1 month")
+## has many "yyyy-mm-29", but a few "yyyy-03-01" in the non-leap years
+y <- ifelse(as.POSIXlt(x)$mday == 29, x, NA)
+head(y) # not what you expected ... ==> need restore the class attribute:
+class(y) <- class(x)
+y
+## ==> Again a case where it is better *not* to use ifelse(), but
+## both more efficient and clear:
+y2 <- x
+y2[as.POSIXlt(x)$mday != 29] <- NA
+stopifnot(identical(y2, y))
+
+
+## example of different return modes:
+yes <- 1:3
+no <- pi^(0:3)
+typeof(ifelse(NA, yes, no)) # logical
+typeof(ifelse(TRUE, yes, no)) # integer
+typeof(ifelse(FALSE, yes, no)) # double
+
+
+
+cleanEx()
+nameEx("integer")
+### * integer
+
+flush(stderr()); flush(stdout())
+
+### Name: integer
+### Title: Integer Vectors
+### Aliases: integer as.integer is.integer
+### Keywords: classes
+
+### ** Examples
+
+## as.integer() truncates:
+x <- pi * c(-1:1, 10)
+as.integer(x)
+
+is.integer(1) # is FALSE !
+
+is.wholenumber <-
+ function(x, tol = .Machine$double.eps^0.5) abs(x - round(x)) < tol
+is.wholenumber(1) # is TRUE
+(x <- seq(1, 5, by = 0.5) )
+is.wholenumber( x ) #--> TRUE FALSE TRUE ...
+
+
+
+cleanEx()
+nameEx("interaction")
+### * interaction
+
+flush(stderr()); flush(stdout())
+
+### Name: interaction
+### Title: Compute Factor Interactions
+### Aliases: interaction
+### Keywords: category
+
+### ** Examples
+
+a <- gl(2, 4, 8)
+b <- gl(2, 2, 8, labels = c("ctrl", "treat"))
+s <- gl(2, 1, 8, labels = c("M", "F"))
+interaction(a, b)
+interaction(a, b, s, sep = ":")
+stopifnot(identical(a:s,
+ interaction(a, s, sep = ":", lex.order = TRUE)),
+ identical(a:s:b,
+ interaction(a, s, b, sep = ":", lex.order = TRUE)))
+
+
+
+cleanEx()
+nameEx("interactive")
+### * interactive
+
+flush(stderr()); flush(stdout())
+
+### Name: interactive
+### Title: Is R Running Interactively?
+### Aliases: interactive
+### Keywords: environment programming
+
+### ** Examples
+
+ .First <- function() if(interactive()) x11()
+
+
+
+cleanEx()
+nameEx("invisible")
+### * invisible
+
+flush(stderr()); flush(stdout())
+
+### Name: invisible
+### Title: Change the Print Mode to Invisible
+### Aliases: invisible
+### Keywords: programming
+
+### ** Examples
+
+# These functions both return their argument
+f1 <- function(x) x
+f2 <- function(x) invisible(x)
+f1(1) # prints
+f2(1) # does not
+
+
+
+cleanEx()
+nameEx("is.finite")
+### * is.finite
+
+flush(stderr()); flush(stdout())
+
+### Name: is.finite
+### Title: Finite, Infinite and NaN Numbers
+### Aliases: is.finite is.infinite Inf NaN is.nan finite infinite
+### Keywords: programming math
+
+### ** Examples
+
+pi / 0 ## = Inf a non-zero number divided by zero creates infinity
+0 / 0 ## = NaN
+
+1/0 + 1/0 # Inf
+1/0 - 1/0 # NaN
+
+stopifnot(
+ 1/0 == Inf,
+ 1/Inf == 0
+)
+sin(Inf)
+cos(Inf)
+tan(Inf)
+
+
+
+cleanEx()
+nameEx("is.function")
+### * is.function
+
+flush(stderr()); flush(stdout())
+
+### Name: is.function
+### Title: Is an Object of Type (Primitive) Function?
+### Aliases: is.function is.primitive
+### Keywords: programming
+
+### ** Examples
+
+is.function(1) # FALSE
+is.function(is.primitive) # TRUE: it is a function, but ..
+is.primitive(is.primitive) # FALSE:it's not a primitive one, whereas
+is.primitive(is.function) # TRUE: that one *is*
+
+
+
+cleanEx()
+nameEx("is.language")
+### * is.language
+
+flush(stderr()); flush(stdout())
+
+### Name: is.language
+### Title: Is an Object a Language Object?
+### Aliases: is.language 'language object' 'language objects'
+### Keywords: programming
+
+### ** Examples
+
+ll <- list(a = expression(x^2 - 2*x + 1), b = as.name("Jim"),
+ c = as.expression(exp(1)), d = call("sin", pi))
+sapply(ll, typeof)
+sapply(ll, mode)
+stopifnot(sapply(ll, is.language))
+
+
+
+cleanEx()
+nameEx("is.object")
+### * is.object
+
+flush(stderr()); flush(stdout())
+
+### Name: is.object
+### Title: Is an Object 'internally classed'?
+### Aliases: is.object
+### Keywords: methods classes
+
+### ** Examples
+
+is.object(1) # FALSE
+is.object(as.factor(1:3)) # TRUE
+
+
+
+cleanEx()
+nameEx("is.recursive")
+### * is.recursive
+
+flush(stderr()); flush(stdout())
+
+### Name: is.recursive
+### Title: Is an Object Atomic or Recursive?
+### Aliases: is.atomic is.recursive
+### Keywords: programming classes
+
+### ** Examples
+
+require(stats)
+
+is.a.r <- function(x) c(is.atomic(x), is.recursive(x))
+
+is.a.r(c(a = 1, b = 3)) # TRUE FALSE
+is.a.r(list()) # FALSE TRUE - a list is a list
+is.a.r(list(2)) # FALSE TRUE
+is.a.r(lm) # FALSE TRUE
+is.a.r(y ~ x) # FALSE TRUE
+is.a.r(expression(x+1)) # FALSE TRUE
+is.a.r(quote(exp)) # FALSE FALSE
+
+
+
+cleanEx()
+nameEx("isR")
+### * isR
+
+flush(stderr()); flush(stdout())
+
+### Name: is.R
+### Title: Are we using R, rather than S?
+### Aliases: is.R
+### Keywords: environment utilities
+
+### ** Examples
+
+x <- stats::runif(20); small <- x < 0.4
+## In the early years of R, 'which()' only existed in R:
+if(is.R()) which(small) else seq(along = small)[small]
+
+
+
+cleanEx()
+nameEx("isS4")
+### * isS4
+
+flush(stderr()); flush(stdout())
+
+### Name: isS4
+### Title: Test for an S4 object
+### Aliases: isS4 asS4 S4 asS3
+### Keywords: programming
+
+### ** Examples
+
+## Don't show:
+require(methods)
+## End(Don't show)
+isS4(pi) # FALSE
+isS4(getClass("MethodDefinition")) # TRUE
+## Don't show:
+stopifnot(isS4(asS4(Sys.time())))
+## Following is a correction of previous behavior. See note in the
+## value section above
+stopifnot(isS4(asS4(getClass("MethodDefinition"), FALSE, 2)))
+stopifnot(!isS4(asS4(getClass("MethodDefinition"), FALSE, 0)))
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("isSymmetric")
+### * isSymmetric
+
+flush(stderr()); flush(stdout())
+
+### Name: isSymmetric
+### Title: Test if a Matrix or other Object is Symmetric (Hermitian)
+### Aliases: isSymmetric isSymmetric.matrix
+### Keywords: array utilities
+
+### ** Examples
+
+isSymmetric(D3 <- diag(3)) # -> TRUE
+
+D3[2, 1] <- 1e-100
+D3
+isSymmetric(D3) # TRUE
+isSymmetric(D3, tol = 0) # FALSE for zero-tolerance
+
+## Complex Matrices - Hermitian or not
+Z <- sqrt(matrix(-1:2 + 0i, 2)); Z <- t(Conj(Z)) %*% Z
+Z
+isSymmetric(Z) # TRUE
+isSymmetric(Z + 1) # TRUE
+isSymmetric(Z + 1i) # FALSE -- a Hermitian matrix has a *real* diagonal
+
+
+
+cleanEx()
+nameEx("jitter")
+### * jitter
+
+flush(stderr()); flush(stdout())
+
+### Name: jitter
+### Title: 'Jitter' (Add Noise) to Numbers
+### Aliases: jitter
+### Keywords: dplot utilities
+
+### ** Examples
+
+round(jitter(c(rep(1, 3), rep(1.2, 4), rep(3, 3))), 3)
+## These two 'fail' with S-plus 3.x:
+jitter(rep(0, 7))
+jitter(rep(10000, 5))
+
+
+
+cleanEx()
+nameEx("kappa")
+### * kappa
+
+flush(stderr()); flush(stdout())
+
+### Name: kappa
+### Title: Compute or Estimate the Condition Number of a Matrix
+### Aliases: rcond kappa kappa.default kappa.lm kappa.qr .kappa_tri
+### Keywords: math
+
+### ** Examples
+
+kappa(x1 <- cbind(1, 1:10)) # 15.71
+kappa(x1, exact = TRUE) # 13.68
+kappa(x2 <- cbind(x1, 2:11)) # high! [x2 is singular!]
+
+hilbert <- function(n) { i <- 1:n; 1 / outer(i - 1, i, "+") }
+sv9 <- svd(h9 <- hilbert(9))$ d
+kappa(h9) # pretty high!
+kappa(h9, exact = TRUE) == max(sv9) / min(sv9)
+kappa(h9, exact = TRUE) / kappa(h9) # 0.677 (i.e., rel.error = 32%)
+
+
+
+cleanEx()
+nameEx("kronecker")
+### * kronecker
+
+flush(stderr()); flush(stdout())
+
+### Name: kronecker
+### Title: Kronecker Products on Arrays
+### Aliases: kronecker .kronecker %x%
+### Keywords: array
+
+### ** Examples
+
+# simple scalar multiplication
+( M <- matrix(1:6, ncol = 2) )
+kronecker(4, M)
+# Block diagonal matrix:
+kronecker(diag(1, 3), M)
+
+# ask for dimnames
+
+fred <- matrix(1:12, 3, 4, dimnames = list(LETTERS[1:3], LETTERS[4:7]))
+bill <- c("happy" = 100, "sad" = 1000)
+kronecker(fred, bill, make.dimnames = TRUE)
+
+bill <- outer(bill, c("cat" = 3, "dog" = 4))
+kronecker(fred, bill, make.dimnames = TRUE)
+
+
+
+cleanEx()
+nameEx("l10n_info")
+### * l10n_info
+
+flush(stderr()); flush(stdout())
+
+### Name: l10n_info
+### Title: Localization Information
+### Aliases: l10n_info
+### Keywords: utilities
+
+### ** Examples
+
+l10n_info()
+
+
+
+cleanEx()
+nameEx("lapply")
+### * lapply
+
+flush(stderr()); flush(stdout())
+
+### Name: lapply
+### Title: Apply a Function over a List or Vector
+### Aliases: lapply sapply vapply replicate simplify2array
+### Keywords: iteration list
+
+### ** Examples
+
+require(stats); require(graphics)
+
+x <- list(a = 1:10, beta = exp(-3:3), logic = c(TRUE,FALSE,FALSE,TRUE))
+# compute the list mean for each list element
+lapply(x, mean)
+# median and quartiles for each list element
+lapply(x, quantile, probs = 1:3/4)
+sapply(x, quantile)
+i39 <- sapply(3:9, seq) # list of vectors
+sapply(i39, fivenum)
+vapply(i39, fivenum,
+ c(Min. = 0, "1st Qu." = 0, Median = 0, "3rd Qu." = 0, Max. = 0))
+
+## sapply(*, "array") -- artificial example
+(v <- structure(10*(5:8), names = LETTERS[1:4]))
+f2 <- function(x, y) outer(rep(x, length.out = 3), y)
+(a2 <- sapply(v, f2, y = 2*(1:5), simplify = "array"))
+a.2 <- vapply(v, f2, outer(1:3, 1:5), y = 2*(1:5))
+stopifnot(dim(a2) == c(3,5,4), all.equal(a2, a.2),
+ identical(dimnames(a2), list(NULL,NULL,LETTERS[1:4])))
+
+hist(replicate(100, mean(rexp(10))))
+
+## use of replicate() with parameters:
+foo <- function(x = 1, y = 2) c(x, y)
+# does not work: bar <- function(n, ...) replicate(n, foo(...))
+bar <- function(n, x) replicate(n, foo(x = x))
+bar(5, x = 3)
+
+
+
+cleanEx()
+nameEx("length")
+### * length
+
+flush(stderr()); flush(stdout())
+
+### Name: length
+### Title: Length of an Object
+### Aliases: length length<- length<-.factor
+### Keywords: attribute
+
+### ** Examples
+
+length(diag(4)) # = 16 (4 x 4)
+length(options()) # 12 or more
+length(y ~ x1 + x2 + x3) # 3
+length(expression(x, {y <- x^2; y+2}, x^y)) # 3
+
+## from example(warpbreaks)
+require(stats)
+
+fm1 <- lm(breaks ~ wool * tension, data = warpbreaks)
+length(fm1$call) # 3, lm() and two arguments.
+length(formula(fm1)) # 3, ~ lhs rhs
+
+
+
+cleanEx()
+nameEx("lengths")
+### * lengths
+
+flush(stderr()); flush(stdout())
+
+### Name: lengths
+### Title: Lengths of List or Vector Elements
+### Aliases: lengths
+### Keywords: attribute
+
+### ** Examples
+
+require(stats)
+## summarize by month
+l <- split(airquality$Ozone, airquality$Month)
+avgOz <- lapply(l, mean, na.rm=TRUE)
+## merge result
+airquality$avgOz <- rep(unlist(avgOz, use.names=FALSE), lengths(l))
+## but this is safer and cleaner, but can be slower
+airquality$avgOz <- unsplit(avgOz, airquality$Month)
+
+## should always be true, except when a length does not fit in 32 bits
+stopifnot(identical(lengths(l), vapply(l, length, integer(1L))))
+
+## empty lists are not a problem
+x <- list()
+stopifnot(identical(lengths(x), integer()))
+
+## nor are "list-like" expressions:
+lengths(expression(u, v, 1+ 0:9))
+
+## and we should dispatch to length methods
+f <- c(rep(1, 3), rep(2, 6), 3)
+dates <- split(as.POSIXlt(Sys.time() + 1:10), f)
+stopifnot(identical(lengths(dates), vapply(dates, length, integer(1L))))
+
+
+
+cleanEx()
+nameEx("levels")
+### * levels
+
+flush(stderr()); flush(stdout())
+
+### Name: levels
+### Title: Levels Attributes
+### Aliases: levels levels.default levels<- levels<-.factor
+### Keywords: category
+
+### ** Examples
+
+## assign individual levels
+x <- gl(2, 4, 8)
+levels(x)[1] <- "low"
+levels(x)[2] <- "high"
+x
+
+## or as a group
+y <- gl(2, 4, 8)
+levels(y) <- c("low", "high")
+y
+
+## combine some levels
+z <- gl(3, 2, 12, labels = c("apple", "salad", "orange"))
+z
+levels(z) <- c("fruit", "veg", "fruit")
+z
+
+## same, using a named list
+z <- gl(3, 2, 12, labels = c("apple", "salad", "orange"))
+z
+levels(z) <- list("fruit" = c("apple","orange"),
+ "veg" = "salad")
+z
+
+## we can add levels this way:
+f <- factor(c("a","b"))
+levels(f) <- c("c", "a", "b")
+f
+
+f <- factor(c("a","b"))
+levels(f) <- list(C = "C", A = "a", B = "b")
+f
+
+
+
+cleanEx()
+nameEx("libPaths")
+### * libPaths
+
+flush(stderr()); flush(stdout())
+
+### Name: libPaths
+### Title: Search Paths for Packages
+### Aliases: .Library .Library.site .libPaths R_LIBS R_LIBS_SITE
+### R_LIBS_USER .expand_R_libs_env_var
+### Keywords: data
+
+### ** Examples
+
+.libPaths() # all library trees R knows about
+
+
+
+cleanEx()
+nameEx("libcurlVersion")
+### * libcurlVersion
+
+flush(stderr()); flush(stdout())
+
+### Name: libcurlVersion
+### Title: Report Version of libcurl
+### Aliases: libcurlVersion
+
+### ** Examples
+
+libcurlVersion()
+
+
+
+cleanEx()
+nameEx("library")
+### * library
+
+flush(stderr()); flush(stdout())
+
+### Name: library
+### Title: Loading/Attaching and Listing of Packages
+### Aliases: library require .noGenerics format.libraryIQR print.libraryIQR
+### format.packageInfo print.packageInfo
+### Keywords: data
+
+### ** Examples
+
+library() # list all available packages
+library(lib.loc = .Library) # list all packages in the default library
+library(splines) # attach package 'splines'
+require(splines) # the same
+search() # "splines", too
+detach("package:splines")
+
+# if the package name is in a character vector, use
+pkg <- "splines"
+library(pkg, character.only = TRUE)
+detach(pos = match(paste("package", pkg, sep = ":"), search()))
+
+require(pkg, character.only = TRUE)
+detach(pos = match(paste("package", pkg, sep = ":"), search()))
+
+require(nonexistent) # FALSE
+## Not run:
+##D ## if you want to mask as little as possible, use
+##D library(mypkg, pos = "package:base")
+## End(Not run)
+
+
+cleanEx()
+nameEx("library.dynam")
+### * library.dynam
+
+flush(stderr()); flush(stdout())
+
+### Name: library.dynam
+### Title: Loading DLLs from Packages
+### Aliases: library.dynam library.dynam.unload .dynLibs
+### Keywords: data
+
+### ** Examples
+
+## Which DLLs were dynamically loaded by packages?
+library.dynam()
+
+
+
+cleanEx()
+nameEx("list")
+### * list
+
+flush(stderr()); flush(stdout())
+
+### Name: list
+### Title: Lists - Generic and Dotted Pairs
+### Aliases: list pairlist alist as.list as.list.default as.list.data.frame
+### as.list.environment as.list.factor as.list.function as.pairlist
+### is.list is.pairlist
+### Keywords: list manip
+
+### ** Examples
+
+require(graphics)
+
+# create a plotting structure
+pts <- list(x = cars[,1], y = cars[,2])
+plot(pts)
+
+is.pairlist(.Options) # a user-level pairlist
+
+## "pre-allocate" an empty list of length 5
+vector("list", 5)
+
+# Argument lists
+f <- function() x
+# Note the specification of a "..." argument:
+formals(f) <- al <- alist(x = , y = 2+3, ... = )
+f
+al
+
+## environment->list coercion
+
+e1 <- new.env()
+e1$a <- 10
+e1$b <- 20
+as.list(e1)
+
+
+
+cleanEx()
+nameEx("list.files")
+### * list.files
+
+flush(stderr()); flush(stdout())
+
+### Name: list.files
+### Title: List the Files in a Directory/Folder
+### Aliases: list.files dir list.dirs
+### Keywords: file
+
+### ** Examples
+
+list.files(R.home())
+## Only files starting with a-l or r
+## Note that a-l is locale-dependent, but using case-insensitive
+## matching makes it unambiguous in English locales
+dir("../..", pattern = "^[a-lr]", full.names = TRUE, ignore.case = TRUE)
+
+list.dirs(R.home("doc"))
+list.dirs(R.home("doc"), full.names = FALSE)
+
+
+
+cleanEx()
+nameEx("list2env")
+### * list2env
+
+flush(stderr()); flush(stdout())
+
+### Name: list2env
+### Title: From A List, Build or Add To an Environment
+### Aliases: list2env
+### Keywords: data
+
+### ** Examples
+
+L <- list(a = 1, b = 2:4, p = pi, ff = gl(3, 4, labels = LETTERS[1:3]))
+e <- list2env(L)
+ls(e)
+stopifnot(ls(e) == sort(names(L)),
+ identical(L$b, e$b)) # "$" working for environments as for lists
+
+## consistency, when we do the inverse:
+ll <- as.list(e) # -> dispatching to the as.list.environment() method
+rbind(names(L), names(ll)) # not in the same order, typically,
+ # but the same content:
+stopifnot(identical(L [sort.list(names(L ))],
+ ll[sort.list(names(ll))]))
+
+## now add to e -- can be seen as a fast "multi-assign":
+list2env(list(abc = LETTERS, note = "just an example",
+ df = data.frame(x = rnorm(20), y = rbinom(20, 1, pr = 0.2))),
+ envir = e)
+utils::ls.str(e)
+
+
+
+cleanEx()
+nameEx("load")
+### * load
+
+flush(stderr()); flush(stdout())
+
+### Name: load
+### Title: Reload Saved Datasets
+### Aliases: load
+### Keywords: file
+
+### ** Examples
+
+## save all data
+xx <- pi # to ensure there is some data
+save(list = ls(all = TRUE), file= "all.RData")
+rm(xx)
+
+## restore the saved values to the current environment
+local({
+ load("all.RData")
+ ls()
+})
+
+xx <- exp(1:3)
+## restore the saved values to the user's workspace
+load("all.RData") ## which is here *equivalent* to
+## load("all.RData", .GlobalEnv)
+## This however annihilates all objects in .GlobalEnv with the same names !
+xx # no longer exp(1:3)
+rm(xx)
+attach("all.RData") # safer and will warn about masked objects w/ same name in .GlobalEnv
+ls(pos = 2)
+## also typically need to cleanup the search path:
+detach("file:all.RData")
+
+## clean up (the example):
+unlink("all.RData")
+
+## Not run:
+##D con <- url("http://some.where.net/R/data/example.rda")
+##D ## print the value to see what objects were created.
+##D print(load(con))
+##D close(con) # url() always opens the connection
+## End(Not run)
+
+
+cleanEx()
+nameEx("locales")
+### * locales
+
+flush(stderr()); flush(stdout())
+
+### Name: locales
+### Title: Query or Set Aspects of the Locale
+### Aliases: locales Sys.getlocale Sys.setlocale LC_ALL LC_COLLATE LC_CTYPE
+### LC_MONETARY LC_NUMERIC LC_TIME LC_MESSAGES LC_PAPER LC_MEASUREMENT
+### Keywords: utilities
+
+### ** Examples
+
+Sys.getlocale()
+Sys.getlocale("LC_TIME")
+## Not run:
+##D Sys.setlocale("LC_TIME", "de") # Solaris: details are OS-dependent
+##D Sys.setlocale("LC_TIME", "de_DE.utf8") # Modern Linux etc.
+##D Sys.setlocale("LC_TIME", "de_DE.UTF-8") # ditto
+##D Sys.setlocale("LC_TIME", "de_DE") # macOS, in UTF-8
+##D Sys.setlocale("LC_TIME", "German") # Windows
+## End(Not run)
+Sys.getlocale("LC_PAPER") # may or may not be set
+
+## Not run:
+##D Sys.setlocale("LC_COLLATE", "C") # turn off locale-specific sorting,
+##D # usually, but not on all platforms
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("lower.tri")
+### * lower.tri
+
+flush(stderr()); flush(stdout())
+
+### Name: lower.tri
+### Title: Lower and Upper Triangular Part of a Matrix
+### Aliases: lower.tri upper.tri
+### Keywords: array
+
+### ** Examples
+
+(m2 <- matrix(1:20, 4, 5))
+lower.tri(m2)
+m2[lower.tri(m2)] <- NA
+m2
+
+
+
+cleanEx()
+nameEx("ls")
+### * ls
+
+flush(stderr()); flush(stdout())
+
+### Name: ls
+### Title: List Objects
+### Aliases: ls objects
+### Keywords: environment
+
+### ** Examples
+
+.Ob <- 1
+ls(pattern = "O")
+ls(pattern= "O", all.names = TRUE) # also shows ".[foo]"
+
+# shows an empty list because inside myfunc no variables are defined
+myfunc <- function() {ls()}
+myfunc()
+
+# define a local variable inside myfunc
+myfunc <- function() {y <- 1; ls()}
+myfunc() # shows "y"
+
+
+
+cleanEx()
+nameEx("make.names")
+### * make.names
+
+flush(stderr()); flush(stdout())
+
+### Name: make.names
+### Title: Make Syntactically Valid Names
+### Aliases: make.names
+### Keywords: character
+
+### ** Examples
+
+make.names(c("a and b", "a-and-b"), unique = TRUE)
+# "a.and.b" "a.and.b.1"
+make.names(c("a and b", "a_and_b"), unique = TRUE)
+# "a.and.b" "a_and_b"
+make.names(c("a and b", "a_and_b"), unique = TRUE, allow_ = FALSE)
+# "a.and.b" "a.and.b.1"
+make.names(c("", "X"), unique = TRUE)
+# "X.1" "X" currently; R up to 3.0.2 gave "X" "X.1"
+
+state.name[make.names(state.name) != state.name] # those 10 with a space
+
+
+
+cleanEx()
+nameEx("make.unique")
+### * make.unique
+
+flush(stderr()); flush(stdout())
+
+### Name: make.unique
+### Title: Make Character Strings Unique
+### Aliases: make.unique
+### Keywords: character
+
+### ** Examples
+
+make.unique(c("a", "a", "a"))
+make.unique(c(make.unique(c("a", "a")), "a"))
+
+make.unique(c("a", "a", "a.2", "a"))
+make.unique(c(make.unique(c("a", "a")), "a.2", "a"))
+
+rbind(data.frame(x = 1), data.frame(x = 2), data.frame(x = 3))
+rbind(rbind(data.frame(x = 1), data.frame(x = 2)), data.frame(x = 3))
+
+
+
+cleanEx()
+nameEx("mapply")
+### * mapply
+
+flush(stderr()); flush(stdout())
+
+### Name: mapply
+### Title: Apply a Function to Multiple List or Vector Arguments
+### Aliases: mapply
+### Keywords: manip utilities
+
+### ** Examples
+
+mapply(rep, 1:4, 4:1)
+
+mapply(rep, times = 1:4, x = 4:1)
+
+mapply(rep, times = 1:4, MoreArgs = list(x = 42))
+
+mapply(function(x, y) seq_len(x) + y,
+ c(a = 1, b = 2, c = 3), # names from first
+ c(A = 10, B = 0, C = -10))
+
+word <- function(C, k) paste(rep.int(C, k), collapse = "")
+utils::str(mapply(word, LETTERS[1:6], 6:1, SIMPLIFY = FALSE))
+
+
+
+cleanEx()
+nameEx("margin.table")
+### * margin.table
+
+flush(stderr()); flush(stdout())
+
+### Name: margin.table
+### Title: Compute table margin
+### Aliases: margin.table
+### Keywords: array
+
+### ** Examples
+
+m <- matrix(1:4, 2)
+margin.table(m, 1)
+margin.table(m, 2)
+
+
+
+cleanEx()
+nameEx("mat.or.vec")
+### * mat.or.vec
+
+flush(stderr()); flush(stdout())
+
+### Name: mat.or.vec
+### Title: Create a Matrix or a Vector
+### Aliases: mat.or.vec
+### Keywords: array
+
+### ** Examples
+
+mat.or.vec(3, 1)
+mat.or.vec(3, 2)
+
+
+
+cleanEx()
+nameEx("match")
+### * match
+
+flush(stderr()); flush(stdout())
+
+### Name: match
+### Title: Value Matching
+### Aliases: match %in%
+### Keywords: manip logic
+
+### ** Examples
+
+## The intersection of two sets can be defined via match():
+## Simple version:
+## intersect <- function(x, y) y[match(x, y, nomatch = 0)]
+intersect # the R function in base is slightly more careful
+intersect(1:10, 7:20)
+
+1:10 %in% c(1,3,5,9)
+sstr <- c("c","ab","B","bba","c",NA,"@","bla","a","Ba","%")
+sstr[sstr %in% c(letters, LETTERS)]
+
+"%w/o%" <- function(x, y) x[!x %in% y] #-- x without y
+(1:10) %w/o% c(3,7,12)
+## Note that setdiff() is very similar and typically makes more sense:
+ c(1:6,7:2) %w/o% c(3,7,12) # -> keeps duplicates
+setdiff(c(1:6,7:2), c(3,7,12)) # -> unique values
+
+## Illuminating example about NA matching
+r <- c(1, NA, NaN)
+zN <- c(complex(real = NA , imaginary = r ), complex(real = r , imaginary = NA ),
+ complex(real = r , imaginary = NaN), complex(real = NaN, imaginary = r ))
+zM <- cbind(Re=Re(zN), Im=Im(zN), match = match(zN, zN))
+rownames(zM) <- format(zN)
+zM ##--> many "NA's" (= 1) and the four non-NA's (3 different ones, at 7,9,10)
+
+length(zN) # 12
+unique(zN) # the "NA" and the 3 different non-NA NaN's
+stopifnot(identical(unique(zN), zN[c(1, 7,9,10)]))
+
+## very strict equality would have 4 duplicates (of 12):
+symnum(outer(zN, zN, Vectorize(identical,c("x","y")),
+ FALSE,FALSE,FALSE,FALSE))
+## removing "(very strictly) duplicates",
+i <- c(5,8,11,12) # we get 8 pairwise non-identicals :
+Ixy <- outer(zN[-i], zN[-i], Vectorize(identical,c("x","y")),
+ FALSE,FALSE,FALSE,FALSE)
+stopifnot(identical(Ixy, diag(8) == 1))
+
+
+
+cleanEx()
+nameEx("match.arg")
+### * match.arg
+
+flush(stderr()); flush(stdout())
+
+### Name: match.arg
+### Title: Argument Verification Using Partial Matching
+### Aliases: match.arg
+### Keywords: programming
+
+### ** Examples
+
+require(stats)
+## Extends the example for 'switch'
+center <- function(x, type = c("mean", "median", "trimmed")) {
+ type <- match.arg(type)
+ switch(type,
+ mean = mean(x),
+ median = median(x),
+ trimmed = mean(x, trim = .1))
+}
+x <- rcauchy(10)
+center(x, "t") # Works
+center(x, "med") # Works
+try(center(x, "m")) # Error
+stopifnot(identical(center(x), center(x, "mean")),
+ identical(center(x, NULL), center(x, "mean")) )
+
+## Allowing more than one match:
+match.arg(c("gauss", "rect", "ep"),
+ c("gaussian", "epanechnikov", "rectangular", "triangular"),
+ several.ok = TRUE)
+
+
+
+cleanEx()
+nameEx("match.call")
+### * match.call
+
+flush(stderr()); flush(stdout())
+
+### Name: match.call
+### Title: Argument Matching
+### Aliases: match.call
+### Keywords: programming
+
+### ** Examples
+
+match.call(get, call("get", "abc", i = FALSE, p = 3))
+## -> get(x = "abc", pos = 3, inherits = FALSE)
+fun <- function(x, lower = 0, upper = 1) {
+ structure((x - lower) / (upper - lower), CALL = match.call())
+}
+fun(4 * atan(1), u = pi)
+
+
+
+cleanEx()
+nameEx("match.fun")
+### * match.fun
+
+flush(stderr()); flush(stdout())
+
+### Name: match.fun
+### Title: Extract a Function Specified by Name
+### Aliases: match.fun
+### Keywords: programming
+
+### ** Examples
+
+# Same as get("*"):
+match.fun("*")
+# Overwrite outer with a vector
+outer <- 1:5
+try(match.fun(outer, descend = FALSE)) #-> Error: not a function
+match.fun(outer) # finds it anyway
+is.function(match.fun("outer")) # as well
+
+
+
+cleanEx()
+nameEx("matmult")
+### * matmult
+
+flush(stderr()); flush(stdout())
+
+### Name: matmult
+### Title: Matrix Multiplication
+### Aliases: %*% matmult
+### Keywords: array arith
+
+### ** Examples
+
+x <- 1:4
+(z <- x %*% x) # scalar ("inner") product (1 x 1 matrix)
+drop(z) # as scalar
+
+y <- diag(x)
+z <- matrix(1:12, ncol = 3, nrow = 4)
+y %*% z
+y %*% x
+x %*% z
+
+
+
+cleanEx()
+nameEx("matrix")
+### * matrix
+
+flush(stderr()); flush(stdout())
+
+### Name: matrix
+### Title: Matrices
+### Aliases: matrix as.matrix as.matrix.default as.matrix.data.frame
+### is.matrix
+### Keywords: array algebra
+
+### ** Examples
+
+is.matrix(as.matrix(1:10))
+!is.matrix(warpbreaks) # data.frame, NOT matrix!
+warpbreaks[1:10,]
+as.matrix(warpbreaks[1:10,]) # using as.matrix.data.frame(.) method
+
+## Example of setting row and column names
+mdat <- matrix(c(1,2,3, 11,12,13), nrow = 2, ncol = 3, byrow = TRUE,
+ dimnames = list(c("row1", "row2"),
+ c("C.1", "C.2", "C.3")))
+mdat
+
+
+
+cleanEx()
+nameEx("maxCol")
+### * maxCol
+
+flush(stderr()); flush(stdout())
+
+### Name: maxCol
+### Title: Find Maximum Position in Matrix
+### Aliases: max.col
+### Keywords: utilities array
+
+### ** Examples
+
+table(mc <- max.col(swiss)) # mostly "1" and "5", 5 x "2" and once "4"
+swiss[unique(print(mr <- max.col(t(swiss)))) , ] # 3 33 45 45 33 6
+
+set.seed(1) # reproducible example:
+(mm <- rbind(x = round(2*stats::runif(12)),
+ y = round(5*stats::runif(12)),
+ z = round(8*stats::runif(12))))
+## Not run:
+##D [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12]
+##D x 1 1 1 2 0 2 2 1 1 0 0 0
+##D y 3 2 4 2 4 5 2 4 5 1 3 1
+##D z 2 3 0 3 7 3 4 5 4 1 7 5
+## End(Not run)
+## column indices of all row maxima :
+utils::str(lapply(1:3, function(i) which(mm[i,] == max(mm[i,]))))
+max.col(mm) ; max.col(mm) # "random"
+max.col(mm, "first") # -> 4 6 5
+max.col(mm, "last") # -> 7 9 11
+## Don't show:
+stopifnot(max.col(mm, "first") == c(4, 6, 5),
+ max.col(mm, "last") == c(7, 9, 11))
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("mean")
+### * mean
+
+flush(stderr()); flush(stdout())
+
+### Name: mean
+### Title: Arithmetic Mean
+### Aliases: mean mean.default
+### Keywords: univar
+
+### ** Examples
+
+x <- c(0:10, 50)
+xm <- mean(x)
+c(xm, mean(x, trim = 0.10))
+
+
+
+cleanEx()
+nameEx("memCompress")
+### * memCompress
+
+flush(stderr()); flush(stdout())
+
+### Name: memCompress
+### Title: In-memory Compression and Decompression
+### Aliases: memCompress memDecompress
+### Keywords: file connection
+
+### ** Examples
+
+txt <- readLines(file.path(R.home("doc"), "COPYING"))
+sum(nchar(txt))
+txt.gz <- memCompress(txt, "g")
+length(txt.gz)
+txt2 <- strsplit(memDecompress(txt.gz, "g", asChar = TRUE), "\n")[[1]]
+stopifnot(identical(txt, txt2))
+txt.bz2 <- memCompress(txt, "b")
+length(txt.bz2)
+## can auto-detect bzip2:
+txt3 <- strsplit(memDecompress(txt.bz2, asChar = TRUE), "\n")[[1]]
+stopifnot(identical(txt, txt3))
+
+## xz compression is only worthwhile for large objects
+txt.xz <- memCompress(txt, "x")
+length(txt.xz)
+txt3 <- strsplit(memDecompress(txt.xz, asChar = TRUE), "\n")[[1]]
+stopifnot(identical(txt, txt3))
+
+
+
+cleanEx()
+nameEx("memory.profile")
+### * memory.profile
+
+flush(stderr()); flush(stdout())
+
+### Name: memory.profile
+### Title: Profile the Usage of Cons Cells
+### Aliases: memory.profile
+### Keywords: utilities
+
+### ** Examples
+
+
+cleanEx()
+nameEx("merge")
+### * merge
+
+flush(stderr()); flush(stdout())
+
+### Name: merge
+### Title: Merge Two Data Frames
+### Aliases: merge merge.default merge.data.frame
+### Keywords: array manip
+
+### ** Examples
+
+## use character columns of names to get sensible sort order
+authors <- data.frame(
+ surname = I(c("Tukey", "Venables", "Tierney", "Ripley", "McNeil")),
+ nationality = c("US", "Australia", "US", "UK", "Australia"),
+ deceased = c("yes", rep("no", 4)))
+books <- data.frame(
+ name = I(c("Tukey", "Venables", "Tierney",
+ "Ripley", "Ripley", "McNeil", "R Core")),
+ title = c("Exploratory Data Analysis",
+ "Modern Applied Statistics ...",
+ "LISP-STAT",
+ "Spatial Statistics", "Stochastic Simulation",
+ "Interactive Data Analysis",
+ "An Introduction to R"),
+ other.author = c(NA, "Ripley", NA, NA, NA, NA,
+ "Venables & Smith"))
+
+(m1 <- merge(authors, books, by.x = "surname", by.y = "name"))
+(m2 <- merge(books, authors, by.x = "name", by.y = "surname"))
+stopifnot(as.character(m1[, 1]) == as.character(m2[, 1]),
+ all.equal(m1[, -1], m2[, -1][ names(m1)[-1] ]),
+ dim(merge(m1, m2, by = integer(0))) == c(36, 10))
+
+## "R core" is missing from authors and appears only here :
+merge(authors, books, by.x = "surname", by.y = "name", all = TRUE)
+
+## example of using 'incomparables'
+x <- data.frame(k1 = c(NA,NA,3,4,5), k2 = c(1,NA,NA,4,5), data = 1:5)
+y <- data.frame(k1 = c(NA,2,NA,4,5), k2 = c(NA,NA,3,4,5), data = 1:5)
+merge(x, y, by = c("k1","k2")) # NA's match
+merge(x, y, by = "k1") # NA's match, so 6 rows
+merge(x, y, by = "k2", incomparables = NA) # 2 rows
+
+
+
+cleanEx()
+nameEx("message")
+### * message
+
+flush(stderr()); flush(stdout())
+
+### Name: message
+### Title: Diagnostic Messages
+### Aliases: message suppressMessages packageStartupMessage
+### .packageStartupMessage suppressPackageStartupMessages .makeMessage
+### Keywords: programming
+
+### ** Examples
+
+message("ABC", "DEF")
+suppressMessages(message("ABC"))
+
+testit <- function() {
+ message("testing package startup messages")
+ packageStartupMessage("initializing ...", appendLF = FALSE)
+ Sys.sleep(1)
+ packageStartupMessage(" done")
+}
+
+testit()
+suppressPackageStartupMessages(testit())
+suppressMessages(testit())
+
+
+
+cleanEx()
+nameEx("missing")
+### * missing
+
+flush(stderr()); flush(stdout())
+
+### Name: missing
+### Title: Does a Formal Argument have a Value?
+### Aliases: missing
+### Keywords: programming
+
+### ** Examples
+
+myplot <- function(x, y) {
+ if(missing(y)) {
+ y <- x
+ x <- 1:length(y)
+ }
+ plot(x, y)
+ }
+
+
+
+cleanEx()
+nameEx("mode")
+### * mode
+
+flush(stderr()); flush(stdout())
+
+### Name: mode
+### Title: The (Storage) Mode of an Object
+### Aliases: mode mode<- storage.mode storage.mode<-
+### Keywords: attribute
+
+### ** Examples
+
+require(stats)
+
+sapply(options(), mode)
+
+cex3 <- c("NULL", "1", "1:1", "1i", "list(1)", "data.frame(x = 1)",
+ "pairlist(pi)", "c", "lm", "formals(lm)[[1]]", "formals(lm)[[2]]",
+ "y ~ x","expression((1))[[1]]", "(y ~ x)[[1]]",
+ "expression(x <- pi)[[1]][[1]]")
+lex3 <- sapply(cex3, function(x) eval(parse(text = x)))
+mex3 <- t(sapply(lex3,
+ function(x) c(typeof(x), storage.mode(x), mode(x))))
+dimnames(mex3) <- list(cex3, c("typeof(.)","storage.mode(.)","mode(.)"))
+mex3
+
+## This also makes a local copy of 'pi':
+storage.mode(pi) <- "complex"
+storage.mode(pi)
+rm(pi)
+
+
+
+cleanEx()
+nameEx("name")
+### * name
+
+flush(stderr()); flush(stdout())
+
+### Name: name
+### Title: Names and Symbols
+### Aliases: name is.symbol as.symbol as.name is.name
+### Keywords: programming attribute
+
+### ** Examples
+
+an <- as.name("arrg")
+is.name(an) # TRUE
+mode(an) # name
+typeof(an) # symbol
+
+
+
+cleanEx()
+nameEx("names")
+### * names
+
+flush(stderr()); flush(stdout())
+
+### Name: names
+### Title: The Names of an Object
+### Aliases: names names.default names<- names<-.default
+### Keywords: attribute
+
+### ** Examples
+
+# print the names attribute of the islands data set
+names(islands)
+
+# remove the names attribute
+names(islands) <- NULL
+islands
+rm(islands) # remove the copy made
+
+z <- list(a = 1, b = "c", c = 1:3)
+names(z)
+# change just the name of the third element.
+names(z)[3] <- "c2"
+z
+
+z <- 1:3
+names(z)
+## assign just one name
+names(z)[2] <- "b"
+z
+
+## Don't show:
+## "show" the equivalence claimed above:
+ for(e in c(baseenv(), globalenv()))
+ stopifnot(identical(names(e), ls(e, all.names=TRUE, sorted=FALSE)),
+ identical(names(e), names(as.list(e, all.names=TRUE))))
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("nargs")
+### * nargs
+
+flush(stderr()); flush(stdout())
+
+### Name: nargs
+### Title: The Number of Arguments to a Function
+### Aliases: nargs
+### Keywords: programming
+
+### ** Examples
+
+tst <- function(a, b = 3, ...) {nargs()}
+tst() # 0
+tst(clicketyclack) # 1 (even non-existing)
+tst(c1, a2, rr3) # 3
+
+foo <- function(x, y, z, w) {
+ cat("call was ", deparse(match.call()), "\n", sep = "")
+ nargs()
+}
+foo() # 0
+foo(, , 3) # 3
+foo(z = 3) # 1, even though this is the same call
+
+nargs() # not really meaningful
+
+
+
+cleanEx()
+nameEx("nchar")
+### * nchar
+
+flush(stderr()); flush(stdout())
+
+### Name: nchar
+### Title: Count the Number of Characters (or Bytes or Width)
+### Aliases: nchar nzchar
+### Keywords: character
+
+### ** Examples
+
+x <- c("asfef", "qwerty", "yuiop[", "b", "stuff.blah.yech")
+nchar(x)
+# 5 6 6 1 15
+
+nchar(deparse(mean))
+# 18 17 <-- unless mean differs from base::mean
+
+x[3] <- NA; x
+nchar(x, keepNA= TRUE) # 5 6 NA 1 15
+nchar(x, keepNA=FALSE) # 5 6 2 1 15
+stopifnot(identical(nchar(x ), nchar(x, keepNA= TRUE)),
+ identical(nchar(x, "w"), nchar(x, keepNA=FALSE)),
+ identical(is.na(x), is.na(nchar(x))))
+
+##' nchar() for all three types :
+nchars <- function(x, ...)
+ vapply(c("chars", "bytes", "width"),
+ function(tp) nchar(x, tp, ...), integer(length(x)))
+
+nchars("\u200b") # in R versions (>= 2015-09-xx):
+## chars bytes width
+## 1 3 0
+
+data.frame(x, nchars(x)) ## all three types : same unless for NA
+## force the same by forcing 'keepNA':
+(ncT <- nchars(x, keepNA = TRUE)) ## .... NA NA NA ....
+(ncF <- nchars(x, keepNA = FALSE))## .... 2 2 2 ....
+stopifnot(apply(ncT, 1, function(.) length(unique(.))) == 1,
+ apply(ncF, 1, function(.) length(unique(.))) == 1)
+
+
+
+cleanEx()
+nameEx("nlevels")
+### * nlevels
+
+flush(stderr()); flush(stdout())
+
+### Name: nlevels
+### Title: The Number of Levels of a Factor
+### Aliases: nlevels
+### Keywords: category
+
+### ** Examples
+
+nlevels(gl(3, 7)) # = 3
+
+
+
+cleanEx()
+nameEx("noquote")
+### * noquote
+
+flush(stderr()); flush(stdout())
+
+### Name: noquote
+### Title: Class for 'no quote' Printing of Character Strings
+### Aliases: noquote print.noquote as.matrix.noquote c.noquote [.noquote
+### Keywords: print methods utilities
+
+### ** Examples
+
+letters
+nql <- noquote(letters)
+nql
+nql[1:4] <- "oh"
+nql[1:12]
+
+cmp.logical <- function(log.v)
+{
+ ## Purpose: compact printing of logicals
+ log.v <- as.logical(log.v)
+ noquote(if(length(log.v) == 0)"()" else c(".","|")[1 + log.v])
+}
+cmp.logical(stats::runif(20) > 0.8)
+
+
+
+cleanEx()
+nameEx("norm")
+### * norm
+
+flush(stderr()); flush(stdout())
+
+### Name: norm
+### Title: Compute the Norm of a Matrix
+### Aliases: norm
+### Keywords: math
+
+### ** Examples
+
+(x1 <- cbind(1, 1:10))
+norm(x1)
+norm(x1, "I")
+norm(x1, "M")
+stopifnot(all.equal(norm(x1, "F"),
+ sqrt(sum(x1^2))))
+
+hilbert <- function(n) { i <- 1:n; 1 / outer(i - 1, i, "+") }
+h9 <- hilbert(9)
+## all 5 types of norm:
+(nTyp <- eval(formals(base::norm)$type))
+sapply(nTyp, norm, x = h9)
+
+
+
+cleanEx()
+nameEx("normalizePath")
+### * normalizePath
+
+flush(stderr()); flush(stdout())
+
+### Name: normalizePath
+### Title: Express File Paths in Canonical Form
+### Aliases: normalizePath
+### Keywords: utilities
+
+### ** Examples
+
+
+cleanEx()
+nameEx("notyet")
+### * notyet
+
+flush(stderr()); flush(stdout())
+
+### Name: NotYet
+### Title: Not Yet Implemented Functions and Unused Arguments
+### Aliases: NotYetImplemented .NotYetImplemented NotYetUsed .NotYetUsed
+### Keywords: documentation utilities
+
+### ** Examples
+
+require(graphics)
+barplot(1:5, inside = TRUE) # 'inside' is not yet used
+
+
+
+cleanEx()
+nameEx("nrow")
+### * nrow
+
+flush(stderr()); flush(stdout())
+
+### Name: nrow
+### Title: The Number of Rows/Columns of an Array
+### Aliases: nrow NROW ncol NCOL
+### Keywords: array
+
+### ** Examples
+
+ma <- matrix(1:12, 3, 4)
+nrow(ma) # 3
+ncol(ma) # 4
+
+ncol(array(1:24, dim = 2:4)) # 3, the second dimension
+NCOL(1:12) # 1
+NROW(1:12) # 12
+
+
+
+cleanEx()
+nameEx("ns-dblcolon")
+### * ns-dblcolon
+
+flush(stderr()); flush(stdout())
+
+### Name: ns-dblcolon
+### Title: Double Colon and Triple Colon Operators
+### Aliases: :: :::
+### Keywords: programming
+
+### ** Examples
+
+base::log
+base::"+"
+
+## Beware -- use ':::' at your own risk! (see "Details")
+stats:::coef.default
+
+
+
+cleanEx()
+nameEx("ns-internal")
+### * ns-internal
+
+flush(stderr()); flush(stdout())
+
+### Name: ns-internals
+### Title: Namespace Internals
+### Aliases: asNamespace getNamespaceInfo .getNamespaceInfo importIntoEnv
+### isBaseNamespace isNamespace namespaceExport namespaceImport
+### namespaceImportClasses namespaceImportFrom namespaceImportMethods
+### packageHasNamespace parseNamespaceFile registerS3method
+### registerS3methods setNamespaceInfo .__S3MethodsTable__.
+### .mergeExportMethods .mergeImportMethods .knownS3Generics
+### loadingNamespaceInfo .getNamespace .getNamespaceInfo ..getNamespace
+### Keywords: internal
+
+### ** Examples
+
+nsName <- "stats"
+(ns <- asNamespace(nsName)) # <environment: namespace:stats>
+
+## Inverse function of asNamespace() :
+environmentName(asNamespace("stats")) # "stats"
+environmentName(asNamespace("base")) # "base"
+getNamespaceInfo(ns, "spec")[["name"]] ## -> "stats"
+## Don't show:
+stopifnot(identical(nsName,
+ getNamespaceInfo(ns, "spec")[["name"]]))
+## End(Don't show)
+
+## Only for for the daring ones, trying to get into the bowels :
+
+lsNamespaceInfo <- function(ns, ...) {
+ ns <- asNamespace(ns, base.OK = FALSE)
+ ls(..., envir = get(".__NAMESPACE__.", envir = ns, inherits = FALSE))
+}
+allinfoNS <- function(ns) sapply(lsNamespaceInfo(ns), getNamespaceInfo, ns=ns)
+
+utils::str(allinfoNS("stats"))
+utils::str(allinfoNS("stats4"))
+
+
+
+cleanEx()
+nameEx("ns-load")
+### * ns-load
+
+flush(stderr()); flush(stdout())
+
+### Name: ns-load
+### Title: Loading and Unloading Name Spaces
+### Aliases: attachNamespace loadNamespace requireNamespace
+### loadedNamespaces unloadNamespace isNamespaceLoaded
+### Keywords: data utilities
+
+### ** Examples
+
+ (lns <- loadedNamespaces())
+ statL <- isNamespaceLoaded("stats")
+ stopifnot( identical(statL, "stats" %in% lns) )
+
+ ## The string "foo" and the symbol 'foo' can be used interchangably here:
+ stopifnot( identical(isNamespaceLoaded( "foo" ), FALSE),
+ identical(isNamespaceLoaded(quote(foo)), FALSE),
+ identical(isNamespaceLoaded(quote(stats)), statL))
+
+hasS <- isNamespaceLoaded("splines") # (to restore if needed)
+Sns <- asNamespace("splines") # loads it if not already
+stopifnot( isNamespaceLoaded("splines"))
+unloadNamespace(Sns) # unloading the NS 'object'
+stopifnot( ! isNamespaceLoaded("splines"))
+if (hasS) loadNamespace("splines") # (restoring previous state)
+
+
+
+cleanEx()
+nameEx("ns-topenv")
+### * ns-topenv
+
+flush(stderr()); flush(stdout())
+
+### Name: ns-topenv
+### Title: Top Level Environment
+### Aliases: topenv
+### Keywords: programming
+
+### ** Examples
+
+topenv(.GlobalEnv)
+topenv(new.env()) # also global env
+topenv(environment(ls))# namespace:base
+topenv(environment(lm))# namespace:stats
+## Don't show:
+stopifnot(identical(.GlobalEnv, topenv(new.env())),
+ identical(.GlobalEnv, topenv(.GlobalEnv)),
+ identical(baseenv(), topenv(baseenv())),
+ identical(.BaseNamespaceEnv, topenv(.BaseNamespaceEnv)),
+ identical(topenv(environment(ls)), asNamespace("base")),
+ identical(topenv(environment(lm)), asNamespace("stats")))
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("numeric")
+### * numeric
+
+flush(stderr()); flush(stdout())
+
+### Name: numeric
+### Title: Numeric Vectors
+### Aliases: numeric as.numeric is.numeric is.numeric.Date
+### is.numeric.POSIXt
+### Keywords: classes attribute
+
+### ** Examples
+
+as.numeric(c("-.1"," 2.7 ","B")) # (-0.1, 2.7, NA) + warning
+
+as.numeric(factor(5:10)) # not what you'd expect
+f <- factor(1:5)
+## what you typically meant and want:
+as.numeric(as.character(f))
+## the same, considerably (for long factors) more efficient:
+as.numeric(levels(f))[f]
+
+
+
+cleanEx()
+nameEx("numeric_version")
+### * numeric_version
+
+flush(stderr()); flush(stdout())
+
+### Name: numeric_version
+### Title: Numeric Versions
+### Aliases: numeric_version as.numeric_version is.numeric_version
+### package_version is.package_version as.package_version
+### R_system_version getRversion [.numeric_version [<-.numeric_version
+### [[.numeric_version [[<-.numeric_version Ops.numeric_version
+### Summary.numeric_version anyNA.numeric_version
+### as.character.numeric_version as.data.frame.numeric_version
+### as.list.numeric_version c.numeric_version duplicated.numeric_version
+### format.numeric_version is.na.numeric_version is.na<-.numeric_version
+### print.numeric_version rep.numeric_version unique.numeric_version
+### xtfrm.numeric_version $.package_version .encode_numeric_version
+### .decode_numeric_version .make_numeric_version
+### Keywords: utilities
+
+### ** Examples
+
+x <- package_version(c("1.2-4", "1.2-3", "2.1"))
+x < "1.4-2.3"
+c(min(x), max(x))
+x[2, 2]
+x$major
+x$minor
+
+if(getRversion() <= "2.5.0") { ## work around missing feature
+ cat("Your version of R, ", as.character(getRversion()),
+ ", is outdated.\n",
+ "Now trying to work around that ...\n", sep = "")
+}
+
+x[[c(1, 3)]] # '4' as a numeric vector, same as x[1, 3]
+x[1, 3] # 4 as an integer
+x[[2, 3]] <- 0 # zero the patchlevel
+x[[c(2, 3)]] <- 0 # same
+x
+x[[3]] <- "2.2.3"; x
+x <- c(x, package_version("0.0"))
+is.na(x)[4] <- TRUE
+stopifnot(identical(is.na(x), c(rep(FALSE,3), TRUE)),
+ anyNA(x))
+
+
+
+cleanEx()
+nameEx("octmode")
+### * octmode
+
+flush(stderr()); flush(stdout())
+
+### Name: octmode
+### Title: Display Numbers in Octal
+### Aliases: as.octmode format.octmode print.octmode as.character.octmode
+### [.octmode !.octmode |.octmode &.octmode xor.octmode octmode
+### Keywords: utilities print
+
+### ** Examples
+
+(on <- as.octmode(c(16, 32, 127:129))) # "020" "040" "177" "200" "201"
+unclass(on[3:4]) # subsetting
+
+## manipulate file modes
+fmode <- as.octmode("170")
+(fmode | "644") & "755"
+
+
+cleanEx()
+nameEx("on.exit")
+### * on.exit
+
+flush(stderr()); flush(stdout())
+
+### Name: on.exit
+### Title: Function Exit Code
+### Aliases: on.exit
+### Keywords: programming
+
+### ** Examples
+
+require(graphics)
+
+opar <- par(mai = c(1,1,1,1))
+on.exit(par(opar))
+## Don't show:
+par(opar)
+## End(Don't show)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("options")
+### * options
+
+flush(stderr()); flush(stdout())
+
+### Name: options
+### Title: Options Settings
+### Aliases: options .Options getOption option MC_CORES R_C_BOUNDS_CHECK
+### R_DEFAULT_DEVICE R_KEEP_PKG_SOURCE R_INTERACTIVE_DEVICE
+### Keywords: environment error print
+
+### ** Examples
+
+op <- options(); utils::str(op) # op is a named list
+
+getOption("width") == options()$width # the latter needs more memory
+options(digits = 15)
+pi
+
+# set the editor, and save previous value
+old.o <- options(editor = "nedit")
+old.o
+
+options(check.bounds = TRUE, warn = 1)
+x <- NULL; x[4] <- "yes" # gives a warning
+
+options(digits = 5)
+print(1e5)
+options(scipen = 3); print(1e5)
+
+options(op) # reset (all) initial options
+options("digits")
+
+## Not run:
+##D ## set contrast handling to be like S
+##D options(contrasts = c("contr.helmert", "contr.poly"))
+## End(Not run)
+
+## Not run:
+##D ## on error, terminate the R session with error status 66
+##D options(error = quote(q("no", status = 66, runLast = FALSE)))
+##D stop("test it")
+## End(Not run)
+
+## Not run:
+##D ## Set error actions for debugging:
+##D ## enter browser on error, see ?recover:
+##D options(error = recover)
+##D ## allows to call debugger() afterwards, see ?debugger:
+##D options(error = dump.frames)
+##D ## A possible setting for non-interactive sessions
+##D options(error = quote({dump.frames(to.file = TRUE); q()}))
+## End(Not run)
+
+ # Compare the two ways to get an option and use it
+ # acconting for the possibility it might not be set.
+if(as.logical(getOption("performCleanp", TRUE)))
+ cat("do cleanup\n")
+
+## Not run:
+##D # a clumsier way of expressing the above w/o the default.
+##D tmp <- getOption("performCleanup")
+##D if(is.null(tmp))
+##D tmp <- TRUE
+##D if(tmp)
+##D cat("do cleanup\n")
+## End(Not run)
+
+
+
+
+cleanEx()
+nameEx("order")
+### * order
+
+flush(stderr()); flush(stdout())
+
+### Name: order
+### Title: Ordering Permutation
+### Aliases: order sort.list
+### Keywords: univar manip
+
+### ** Examples
+
+require(stats)
+
+(ii <- order(x <- c(1,1,3:1,1:4,3), y <- c(9,9:1), z <- c(2,1:9)))
+## 6 5 2 1 7 4 10 8 3 9
+rbind(x, y, z)[,ii] # shows the reordering (ties via 2nd & 3rd arg)
+
+## Suppose we wanted descending order on y.
+## A simple solution for numeric 'y' is
+rbind(x, y, z)[, order(x, -y, z)]
+## More generally we can make use of xtfrm
+cy <- as.character(y)
+rbind(x, y, z)[, order(x, -xtfrm(cy), z)]
+## The radix sort supports multiple 'decreasing' values:
+rbind(x, y, z)[, order(x, cy, z, decreasing = c(FALSE, TRUE, FALSE),
+ method="radix")]
+
+## Sorting data frames:
+dd <- transform(data.frame(x, y, z),
+ z = factor(z, labels = LETTERS[9:1]))
+## Either as above {for factor 'z' : using internal coding}:
+dd[ order(x, -y, z), ]
+## or along 1st column, ties along 2nd, ... *arbitrary* no.{columns}:
+dd[ do.call(order, dd), ]
+
+set.seed(1) # reproducible example:
+d4 <- data.frame(x = round( rnorm(100)), y = round(10*runif(100)),
+ z = round( 8*rnorm(100)), u = round(50*runif(100)))
+(d4s <- d4[ do.call(order, d4), ])
+(i <- which(diff(d4s[, 3]) == 0))
+# in 2 places, needed 3 cols to break ties:
+d4s[ rbind(i, i+1), ]
+
+## rearrange matched vectors so that the first is in ascending order
+x <- c(5:1, 6:8, 12:9)
+y <- (x - 5)^2
+o <- order(x)
+rbind(x[o], y[o])
+
+## tests of na.last
+a <- c(4, 3, 2, NA, 1)
+b <- c(4, NA, 2, 7, 1)
+z <- cbind(a, b)
+(o <- order(a, b)); z[o, ]
+(o <- order(a, b, na.last = FALSE)); z[o, ]
+(o <- order(a, b, na.last = NA)); z[o, ]
+
+
+
+cleanEx()
+nameEx("outer")
+### * outer
+
+flush(stderr()); flush(stdout())
+
+### Name: outer
+### Title: Outer Product of Arrays
+### Aliases: outer %o%
+### Keywords: array
+
+### ** Examples
+
+x <- 1:9; names(x) <- x
+# Multiplication & Power Tables
+x %o% x
+y <- 2:8; names(y) <- paste(y,":", sep = "")
+outer(y, x, "^")
+
+outer(month.abb, 1999:2003, FUN = "paste")
+
+## three way multiplication table:
+x %o% x %o% y[1:3]
+
+
+
+cleanEx()
+nameEx("parse")
+### * parse
+
+flush(stderr()); flush(stdout())
+
+### Name: parse
+### Title: Parse Expressions
+### Aliases: parse
+### Keywords: file programming connection
+
+### ** Examples
+
+cat("x <- c(1, 4)\n x ^ 3 -10 ; outer(1:7, 5:9)\n", file = "xyz.Rdmped")
+# parse 3 statements from the file "xyz.Rdmped"
+parse(file = "xyz.Rdmped", n = 3)
+unlink("xyz.Rdmped")
+
+# A partial parse with a syntax error
+txt <- "
+x <- 1
+an error
+"
+sf <- srcfile("txt")
+try(parse(text = txt, srcfile = sf))
+getParseData(sf)
+
+
+
+cleanEx()
+nameEx("paste")
+### * paste
+
+flush(stderr()); flush(stdout())
+
+### Name: paste
+### Title: Concatenate Strings
+### Aliases: paste paste0
+### Keywords: character
+
+### ** Examples
+
+## When passing a single vector, paste0 and paste work like as.character.
+paste0(1:12)
+paste(1:12) # same
+as.character(1:12) # same
+
+## If you pass several vectors to paste0, they are concatenated in a
+## vectorized way.
+(nth <- paste0(1:12, c("st", "nd", "rd", rep("th", 9))))
+
+## paste works the same, but separates each input with a space.
+## Notice that the recycling rules make every input as long as the longest input.
+paste(month.abb, "is the", nth, "month of the year.")
+paste(month.abb, letters)
+
+## You can change the separator by passing a sep argument
+## which can be multiple characters.
+paste(month.abb, "is the", nth, "month of the year.", sep = "_*_")
+
+## To collapse the output into a single string, pass a collapse argument.
+paste0(nth, collapse = ", ")
+
+## For inputs of length 1, use the sep argument rather than collapse
+paste("1st", "2nd", "3rd", collapse = ", ") # probably not what you wanted
+paste("1st", "2nd", "3rd", sep = ", ")
+
+## You can combine the sep and collapse arguments together.
+paste(month.abb, nth, sep = ": ", collapse = "; ")
+
+## Using paste() in combination with strwrap() can be useful
+## for dealing with long strings.
+(title <- paste(strwrap(
+ "Stopping distance of cars (ft) vs. speed (mph) from Ezekiel (1930)",
+ width = 30), collapse = "\n"))
+plot(dist ~ speed, cars, main = title)
+
+
+
+cleanEx()
+nameEx("path.expand")
+### * path.expand
+
+flush(stderr()); flush(stdout())
+
+### Name: path.expand
+### Title: Expand File Paths
+### Aliases: path.expand 'tilde expansion'
+### Keywords: file
+
+### ** Examples
+
+path.expand("~/foo")
+
+
+
+cleanEx()
+nameEx("pcre_config")
+### * pcre_config
+
+flush(stderr()); flush(stdout())
+
+### Name: pcre_config
+### Title: Report Configuration Options for PCRE
+### Aliases: pcre_config
+
+### ** Examples
+
+pcre_config()
+
+
+
+cleanEx()
+nameEx("pmatch")
+### * pmatch
+
+flush(stderr()); flush(stdout())
+
+### Name: pmatch
+### Title: Partial String Matching
+### Aliases: pmatch
+### Keywords: character
+
+### ** Examples
+
+pmatch("", "") # returns NA
+pmatch("m", c("mean", "median", "mode")) # returns NA
+pmatch("med", c("mean", "median", "mode")) # returns 2
+
+pmatch(c("", "ab", "ab"), c("abc", "ab"), dup = FALSE)
+pmatch(c("", "ab", "ab"), c("abc", "ab"), dup = TRUE)
+## compare
+charmatch(c("", "ab", "ab"), c("abc", "ab"))
+
+
+
+cleanEx()
+nameEx("polyroot")
+### * polyroot
+
+flush(stderr()); flush(stdout())
+
+### Name: polyroot
+### Title: Find Zeros of a Real or Complex Polynomial
+### Aliases: polyroot
+### Keywords: math
+
+### ** Examples
+
+polyroot(c(1, 2, 1))
+round(polyroot(choose(8, 0:8)), 11) # guess what!
+for (n1 in 1:4) print(polyroot(1:n1), digits = 4)
+polyroot(c(1, 2, 1, 0, 0)) # same as the first
+
+
+
+cleanEx()
+nameEx("pos.to.env")
+### * pos.to.env
+
+flush(stderr()); flush(stdout())
+
+### Name: pos.to.env
+### Title: Convert Positions in the Search Path to Environments
+### Aliases: pos.to.env
+### Keywords: utilities
+
+### ** Examples
+
+pos.to.env(1) # R_GlobalEnv
+# the next returns the base environment
+pos.to.env(length(search()))
+
+
+
+cleanEx()
+nameEx("pretty")
+### * pretty
+
+flush(stderr()); flush(stdout())
+
+### Name: pretty
+### Title: Pretty Breakpoints
+### Aliases: pretty pretty.default
+### Keywords: dplot
+
+### ** Examples
+
+pretty(1:15) # 0 2 4 6 8 10 12 14 16
+pretty(1:15, h = 2) # 0 5 10 15
+pretty(1:15, n = 4) # 0 5 10 15
+pretty(1:15 * 2) # 0 5 10 15 20 25 30
+pretty(1:20) # 0 5 10 15 20
+pretty(1:20, n = 2) # 0 10 20
+pretty(1:20, n = 10) # 0 2 4 ... 20
+
+for(k in 5:11) {
+ cat("k=", k, ": "); print(diff(range(pretty(100 + c(0, pi*10^-k)))))}
+
+##-- more bizarre, when min(x) == max(x):
+pretty(pi)
+
+add.names <- function(v) { names(v) <- paste(v); v}
+utils::str(lapply(add.names(-10:20), pretty))
+utils::str(lapply(add.names(0:20), pretty, min.n = 0))
+sapply( add.names(0:20), pretty, min.n = 4)
+
+pretty(1.234e100)
+pretty(1001.1001)
+pretty(1001.1001, shrink = 0.2)
+for(k in -7:3)
+ cat("shrink=", formatC(2^k, width = 9),":",
+ formatC(pretty(1001.1001, shrink.sml = 2^k), width = 6),"\n")
+
+
+
+cleanEx()
+nameEx("print")
+### * print
+
+flush(stderr()); flush(stdout())
+
+### Name: print
+### Title: Print Values
+### Aliases: print print.factor print.function print.listof
+### print.simple.list print.Dlist print.table
+### Keywords: print
+
+### ** Examples
+
+require(stats)
+
+ts(1:20) #-- print is the "Default function" --> print.ts(.) is called
+for(i in 1:3) print(1:i)
+
+## Printing of factors
+attenu$station ## 117 levels -> 'max.levels' depending on width
+
+## ordered factors: levels "l1 < l2 < .."
+esoph$agegp[1:12]
+esoph$alcgp[1:12]
+
+## Printing of sparse (contingency) tables
+set.seed(521)
+t1 <- round(abs(rt(200, df = 1.8)))
+t2 <- round(abs(rt(200, df = 1.4)))
+table(t1, t2) # simple
+print(table(t1, t2), zero.print = ".") # nicer to read
+
+## same for non-integer "table":
+T <- table(t2,t1)
+T <- T * (1+round(rlnorm(length(T)))/4)
+print(T, zero.print = ".") # quite nicer,
+print.table(T[,2:8] * 1e9, digits=3, zero.print = ".")
+## still slightly inferior to Matrix::Matrix(T) for larger T
+
+## Corner cases with empty extents:
+table(1, NA) # < table of extent 1 x 0 >
+
+
+
+cleanEx()
+nameEx("print.dataframe")
+### * print.dataframe
+
+flush(stderr()); flush(stdout())
+
+### Name: print.data.frame
+### Title: Printing Data Frames
+### Aliases: print.data.frame
+### Keywords: print
+
+### ** Examples
+
+(dd <- data.frame(x = 1:8, f = gl(2,4), ch = I(letters[1:8])))
+ # print() with defaults
+print(dd, quote = TRUE, row.names = FALSE)
+ # suppresses row.names and quotes all entries
+
+
+
+cleanEx()
+nameEx("print.default")
+### * print.default
+
+flush(stderr()); flush(stdout())
+
+### Name: print.default
+### Title: Default Printing
+### Aliases: print.default
+### Keywords: print
+
+### ** Examples
+
+pi
+print(pi, digits = 16)
+LETTERS[1:16]
+print(LETTERS, quote = FALSE)
+
+M <- cbind(I = 1, matrix(1:10000, ncol = 10,
+ dimnames = list(NULL, LETTERS[1:10])))
+utils::head(M) # makes more sense than
+print(M, max = 1000) # prints 90 rows and a message about omitting 910
+
+
+
+cleanEx()
+nameEx("prmatrix")
+### * prmatrix
+
+flush(stderr()); flush(stdout())
+
+### Name: prmatrix
+### Title: Print Matrices, Old-style
+### Aliases: prmatrix
+### Keywords: print
+
+### ** Examples
+
+prmatrix(m6 <- diag(6), rowlab = rep("", 6), collab = rep("", 6))
+
+chm <- matrix(scan(system.file("help", "AnIndex", package = "splines"),
+ what = ""), , 2, byrow = TRUE)
+chm # uses print.matrix()
+prmatrix(chm, collab = paste("Column", 1:3), right = TRUE, quote = FALSE)
+
+
+
+cleanEx()
+nameEx("proc.time")
+### * proc.time
+
+flush(stderr()); flush(stdout())
+
+### Name: proc.time
+### Title: Running Time of R
+### Aliases: proc.time print.proc_time summary.proc_time
+### Keywords: utilities
+
+### ** Examples
+
+
+cleanEx()
+nameEx("prod")
+### * prod
+
+flush(stderr()); flush(stdout())
+
+### Name: prod
+### Title: Product of Vector Elements
+### Aliases: prod
+### Keywords: arith
+
+### ** Examples
+
+print(prod(1:7)) == print(gamma(8))
+
+
+
+cleanEx()
+nameEx("prop.table")
+### * prop.table
+
+flush(stderr()); flush(stdout())
+
+### Name: prop.table
+### Title: Express Table Entries as Fraction of Marginal Table
+### Aliases: prop.table
+### Keywords: array
+
+### ** Examples
+
+m <- matrix(1:4, 2)
+m
+prop.table(m, 1)
+
+
+
+cleanEx()
+nameEx("pushBack")
+### * pushBack
+
+flush(stderr()); flush(stdout())
+
+### Name: pushBack
+### Title: Push Text Back on to a Connection
+### Aliases: pushBack pushBackLength clearPushBack
+### Keywords: connection
+
+### ** Examples
+
+zz <- textConnection(LETTERS)
+readLines(zz, 2)
+pushBack(c("aa", "bb"), zz)
+pushBackLength(zz)
+readLines(zz, 1)
+pushBackLength(zz)
+readLines(zz, 1)
+readLines(zz, 1)
+close(zz)
+
+
+
+cleanEx()
+nameEx("qr")
+### * qr
+
+flush(stderr()); flush(stdout())
+
+### Name: qr
+### Title: The QR Decomposition of a Matrix
+### Aliases: qr qr.default qr.coef qr.qy qr.qty qr.resid qr.fitted qr.solve
+### is.qr as.qr solve.qr
+### Keywords: algebra array
+
+### ** Examples
+
+hilbert <- function(n) { i <- 1:n; 1 / outer(i - 1, i, "+") }
+h9 <- hilbert(9); h9
+qr(h9)$rank #--> only 7
+qrh9 <- qr(h9, tol = 1e-10)
+qrh9$rank #--> 9
+##-- Solve linear equation system H %*% x = y :
+y <- 1:9/10
+x <- qr.solve(h9, y, tol = 1e-10) # or equivalently :
+x <- qr.coef(qrh9, y) #-- is == but much better than
+ #-- solve(h9) %*% y
+h9 %*% x # = y
+
+
+## overdetermined system
+A <- matrix(runif(12), 4)
+b <- 1:4
+qr.solve(A, b) # or solve(qr(A), b)
+solve(qr(A, LAPACK = TRUE), b)
+# this is a least-squares solution, cf. lm(b ~ 0 + A)
+
+## underdetermined system
+A <- matrix(runif(12), 3)
+b <- 1:3
+qr.solve(A, b)
+solve(qr(A, LAPACK = TRUE), b)
+# solutions will have one zero, not necessarily the same one
+
+
+
+cleanEx()
+nameEx("qraux")
+### * qraux
+
+flush(stderr()); flush(stdout())
+
+### Name: QR.Auxiliaries
+### Title: Reconstruct the Q, R, or X Matrices from a QR Object
+### Aliases: qr.X qr.Q qr.R
+### Keywords: algebra array
+
+### ** Examples
+
+p <- ncol(x <- LifeCycleSavings[, -1]) # not the 'sr'
+qrstr <- qr(x) # dim(x) == c(n,p)
+qrstr $ rank # = 4 = p
+Q <- qr.Q(qrstr) # dim(Q) == dim(x)
+R <- qr.R(qrstr) # dim(R) == ncol(x)
+X <- qr.X(qrstr) # X == x
+range(X - as.matrix(x)) # ~ < 6e-12
+## X == Q %*% R if there has been no pivoting, as here:
+all.equal(unname(X),
+ unname(Q %*% R))
+
+# example of pivoting
+x <- cbind(int = 1,
+ b1 = rep(1:0, each = 3), b2 = rep(0:1, each = 3),
+ c1 = rep(c(1,0,0), 2), c2 = rep(c(0,1,0), 2), c3 = rep(c(0,0,1),2))
+x # is singular, columns "b2" and "c3" are "extra"
+a <- qr(x)
+zapsmall(qr.R(a)) # columns are int b1 c1 c2 b2 c3
+a$pivot
+pivI <- sort.list(a$pivot) # the inverse permutation
+all.equal (x, qr.Q(a) %*% qr.R(a)) # no, no
+stopifnot(
+ all.equal(x[, a$pivot], qr.Q(a) %*% qr.R(a)), # TRUE
+ all.equal(x , qr.Q(a) %*% qr.R(a)[, pivI])) # TRUE too!
+
+
+
+cleanEx()
+nameEx("quit")
+### * quit
+
+flush(stderr()); flush(stdout())
+
+### Name: quit
+### Title: Terminate an R Session
+### Aliases: quit q .Last .Last.sys
+### Keywords: environment
+
+### ** Examples
+
+## Not run:
+##D ## Unix-flavour example
+##D .Last <- function() {
+##D graphics.off() # close devices before printing
+##D cat("Now sending PDF graphics to the printer:\n")
+##D system("lpr Rplots.pdf")
+##D cat("bye bye...\n")
+##D }
+##D quit("yes")
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("range")
+### * range
+
+flush(stderr()); flush(stdout())
+
+### Name: range
+### Title: Range of Values
+### Aliases: range range.default
+### Keywords: univar arith
+
+### ** Examples
+
+(r.x <- range(stats::rnorm(100)))
+diff(r.x) # the SAMPLE range
+
+x <- c(NA, 1:3, -1:1/0); x
+range(x)
+range(x, na.rm = TRUE)
+range(x, finite = TRUE)
+
+
+
+cleanEx()
+nameEx("rank")
+### * rank
+
+flush(stderr()); flush(stdout())
+
+### Name: rank
+### Title: Sample Ranks
+### Aliases: rank
+### Keywords: univar
+
+### ** Examples
+
+(r1 <- rank(x1 <- c(3, 1, 4, 15, 92)))
+x2 <- c(3, 1, 4, 1, 5, 9, 2, 6, 5, 3, 5)
+names(x2) <- letters[1:11]
+(r2 <- rank(x2)) # ties are averaged
+
+## rank() is "idempotent": rank(rank(x)) == rank(x) :
+stopifnot(rank(r1) == r1, rank(r2) == r2)
+
+## ranks without averaging
+rank(x2, ties.method= "first") # first occurrence wins
+rank(x2, ties.method= "last") # last occurrence wins
+rank(x2, ties.method= "random") # ties broken at random
+rank(x2, ties.method= "random") # and again
+
+## keep ties ties, no average
+(rma <- rank(x2, ties.method= "max")) # as used classically
+(rmi <- rank(x2, ties.method= "min")) # as in Sports
+stopifnot(rma + rmi == round(r2 + r2))
+
+## Comparing all tie.methods:
+tMeth <- eval(formals(rank)$ties.method)
+rx2 <- sapply(tMeth, function(M) rank(x2, ties.method=M))
+cbind(x2, rx2)
+## ties.method's does not matter w/o ties:
+x <- sample(47)
+rx <- sapply(tMeth, function(MM) rank(x, ties.method=MM))
+stopifnot(all(rx[,1] == rx))
+
+
+
+cleanEx()
+nameEx("rapply")
+### * rapply
+
+flush(stderr()); flush(stdout())
+
+### Name: rapply
+### Title: Recursively Apply a Function to a List
+### Aliases: rapply
+### Keywords: iteration list
+
+### ** Examples
+
+X <- list(list(a = pi, b = list(c = 1:1)), d = "a test")
+rapply(X, function(x) x, how = "replace")
+rapply(X, sqrt, classes = "numeric", how = "replace")
+rapply(X, nchar, classes = "character",
+ deflt = as.integer(NA), how = "list")
+rapply(X, nchar, classes = "character",
+ deflt = as.integer(NA), how = "unlist")
+rapply(X, nchar, classes = "character", how = "unlist")
+rapply(X, log, classes = "numeric", how = "replace", base = 2)
+
+
+
+cleanEx()
+nameEx("raw")
+### * raw
+
+flush(stderr()); flush(stdout())
+
+### Name: raw
+### Title: Raw Vectors
+### Aliases: raw as.raw is.raw
+### Keywords: classes
+
+### ** Examples
+
+xx <- raw(2)
+xx[1] <- as.raw(40) # NB, not just 40.
+xx[2] <- charToRaw("A")
+xx ## 28 41 -- raw prints hexadecimals
+dput(xx) ## as.raw(c(0x28, 0x41))
+as.integer(xx) ## 40 65
+
+x <- "A test string"
+(y <- charToRaw(x))
+is.vector(y) # TRUE
+rawToChar(y)
+is.raw(x)
+is.raw(y)
+stopifnot( charToRaw("\xa3") == as.raw(0xa3) )
+
+isASCII <- function(txt) all(charToRaw(txt) <= as.raw(127))
+isASCII(x) # true
+isASCII("\xa325.63") # false (in Latin-1, this is an amount in UK pounds)
+
+
+
+cleanEx()
+nameEx("rawConnection")
+### * rawConnection
+
+flush(stderr()); flush(stdout())
+
+### Name: rawConnection
+### Title: Raw Connections
+### Aliases: rawConnection rawConnectionValue
+### Keywords: file connection
+
+### ** Examples
+
+zz <- rawConnection(raw(0), "r+") # start with empty raw vector
+writeBin(LETTERS, zz)
+seek(zz, 0)
+readLines(zz) # raw vector has embedded nuls
+seek(zz, 0)
+writeBin(letters[1:3], zz)
+rawConnectionValue(zz)
+close(zz)
+
+
+
+cleanEx()
+nameEx("rawConversion")
+### * rawConversion
+
+flush(stderr()); flush(stdout())
+
+### Name: rawConversion
+### Title: Convert to or from Raw Vectors
+### Aliases: charToRaw rawToChar rawShift rawToBits intToBits packBits
+### Keywords: classes
+
+### ** Examples
+
+x <- "A test string"
+(y <- charToRaw(x))
+is.vector(y) # TRUE
+
+rawToChar(y)
+rawToChar(y, multiple = TRUE)
+(xx <- c(y, charToRaw("&"), charToRaw("more")))
+rawToChar(xx)
+
+rawShift(y, 1)
+rawShift(y, -2)
+
+rawToBits(y)
+
+showBits <- function(r) stats::symnum(as.logical(rawToBits(r)))
+
+z <- as.raw(5)
+z ; showBits(z)
+showBits(rawShift(z, 1)) # shift to right
+showBits(rawShift(z, 2))
+showBits(z)
+showBits(rawShift(z, -1)) # shift to left
+showBits(rawShift(z, -2)) # ..
+showBits(rawShift(z, -3)) # shifted off entirely
+
+
+
+cleanEx()
+nameEx("readBin")
+### * readBin
+
+flush(stderr()); flush(stdout())
+
+### Name: readBin
+### Title: Transfer Binary Data To and From Connections
+### Aliases: readBin writeBin
+### Keywords: file connection
+
+### ** Examples
+
+zz <- file("testbin", "wb")
+writeBin(1:10, zz)
+writeBin(pi, zz, endian = "swap")
+writeBin(pi, zz, size = 4)
+writeBin(pi^2, zz, size = 4, endian = "swap")
+writeBin(pi+3i, zz)
+writeBin("A test of a connection", zz)
+z <- paste("A very long string", 1:100, collapse = " + ")
+writeBin(z, zz)
+if(.Machine$sizeof.long == 8 || .Machine$sizeof.longlong == 8)
+ writeBin(as.integer(5^(1:10)), zz, size = 8)
+if((s <- .Machine$sizeof.longdouble) > 8)
+ writeBin((pi/3)^(1:10), zz, size = s)
+close(zz)
+
+zz <- file("testbin", "rb")
+readBin(zz, integer(), 4)
+readBin(zz, integer(), 6)
+readBin(zz, numeric(), 1, endian = "swap")
+readBin(zz, numeric(), size = 4)
+readBin(zz, numeric(), size = 4, endian = "swap")
+readBin(zz, complex(), 1)
+readBin(zz, character(), 1)
+z2 <- readBin(zz, character(), 1)
+if(.Machine$sizeof.long == 8 || .Machine$sizeof.longlong == 8)
+ readBin(zz, integer(), 10, size = 8)
+if((s <- .Machine$sizeof.longdouble) > 8)
+ readBin(zz, numeric(), 10, size = s)
+close(zz)
+unlink("testbin")
+stopifnot(z2 == z)
+
+## signed vs unsigned ints
+zz <- file("testbin", "wb")
+x <- as.integer(seq(0, 255, 32))
+writeBin(x, zz, size = 1)
+writeBin(x, zz, size = 1)
+x <- as.integer(seq(0, 60000, 10000))
+writeBin(x, zz, size = 2)
+writeBin(x, zz, size = 2)
+close(zz)
+zz <- file("testbin", "rb")
+readBin(zz, integer(), 8, size = 1)
+readBin(zz, integer(), 8, size = 1, signed = FALSE)
+readBin(zz, integer(), 7, size = 2)
+readBin(zz, integer(), 7, size = 2, signed = FALSE)
+close(zz)
+unlink("testbin")
+
+## use of raw
+z <- writeBin(pi^{1:5}, raw(), size = 4)
+readBin(z, numeric(), 5, size = 4)
+z <- writeBin(c("a", "test", "of", "character"), raw())
+readBin(z, character(), 4)
+
+
+
+cleanEx()
+nameEx("readChar")
+### * readChar
+
+flush(stderr()); flush(stdout())
+
+### Name: readChar
+### Title: Transfer Character Strings To and From Connections
+### Aliases: readChar writeChar
+### Keywords: file connection
+
+### ** Examples
+
+## test fixed-length strings
+zz <- file("testchar", "wb")
+x <- c("a", "this will be truncated", "abc")
+nc <- c(3, 10, 3)
+writeChar(x, zz, nc, eos = NULL)
+writeChar(x, zz, eos = "\r\n")
+close(zz)
+
+zz <- file("testchar", "rb")
+readChar(zz, nc)
+readChar(zz, nchar(x)+3) # need to read the terminator explicitly
+close(zz)
+unlink("testchar")
+
+
+
+cleanEx()
+nameEx("readLines")
+### * readLines
+
+flush(stderr()); flush(stdout())
+
+### Name: readLines
+### Title: Read Text Lines from a Connection
+### Aliases: readLines
+### Keywords: file connection
+
+### ** Examples
+
+cat("TITLE extra line", "2 3 5 7", "", "11 13 17", file = "ex.data",
+ sep = "\n")
+readLines("ex.data", n = -1)
+unlink("ex.data") # tidy up
+
+## difference in blocking
+cat("123\nabc", file = "test1")
+readLines("test1") # line with a warning
+
+con <- file("test1", "r", blocking = FALSE)
+readLines(con) # empty
+cat(" def\n", file = "test1", append = TRUE)
+readLines(con) # gets both
+close(con)
+
+unlink("test1") # tidy up
+
+## Not run:
+##D # read a 'Windows Unicode' file
+##D A <- readLines(con <- file("Unicode.txt", encoding = "UCS-2LE"))
+##D close(con)
+##D unique(Encoding(A)) # will most likely be UTF-8
+## End(Not run)
+
+
+cleanEx()
+nameEx("readRDS")
+### * readRDS
+
+flush(stderr()); flush(stdout())
+
+### Name: readRDS
+### Title: Serialization Interface for Single Objects
+### Aliases: readRDS saveRDS
+### Keywords: file connection
+
+### ** Examples
+
+## save a single object to file
+saveRDS(women, "women.rds")
+## restore it under a different name
+women2 <- readRDS("women.rds")
+identical(women, women2)
+## or examine the object via a connection, which will be opened as needed.
+con <- gzfile("women.rds")
+readRDS(con)
+close(con)
+
+## Less convenient ways to restore the object
+## which demonstrate compatibility with unserialize()
+con <- gzfile("women.rds", "rb")
+identical(unserialize(con), women)
+close(con)
+con <- gzfile("women.rds", "rb")
+wm <- readBin(con, "raw", n = 1e4) # size is a guess
+close(con)
+identical(unserialize(wm), women)
+
+## Format compatibility with serialize():
+con <- file("women2", "w")
+serialize(women, con) # ASCII, uncompressed
+close(con)
+identical(women, readRDS("women2"))
+con <- bzfile("women3", "w")
+serialize(women, con) # binary, bzip2-compressed
+close(con)
+identical(women, readRDS("women2"))
+
+## Don't show:
+unlink(c("women.rds", "women2", "women3"))
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("readRenviron")
+### * readRenviron
+
+flush(stderr()); flush(stdout())
+
+### Name: readRenviron
+### Title: Set Environment Variables from a File
+### Aliases: readRenviron
+### Keywords: file
+
+### ** Examples
+## Not run:
+##D ## re-read a startup file (or read it in a vanilla session)
+##D readRenviron("~/.Renviron")
+## End(Not run)
+
+
+cleanEx()
+nameEx("readline")
+### * readline
+
+flush(stderr()); flush(stdout())
+
+### Name: readline
+### Title: Read a Line from the Terminal
+### Aliases: readline
+### Keywords: utilities
+
+### ** Examples
+
+fun <- function() {
+ ANSWER <- readline("Are you a satisfied R user? ")
+ ## a better version would check the answer less cursorily, and
+ ## perhaps re-prompt
+ if (substr(ANSWER, 1, 1) == "n")
+ cat("This is impossible. YOU LIED!\n")
+ else
+ cat("I knew it.\n")
+}
+if(interactive()) fun()
+
+
+
+cleanEx()
+nameEx("reg.finalizer")
+### * reg.finalizer
+
+flush(stderr()); flush(stdout())
+
+### Name: reg.finalizer
+### Title: Finalization of Objects
+### Aliases: reg.finalizer finalizer
+### Keywords: programming environment
+
+### ** Examples
+
+f <- function(e) print("cleaning....")
+g <- function(x){ e <- environment(); reg.finalizer(e, f) }
+g()
+invisible(gc()) # trigger cleanup
+
+
+
+cleanEx()
+nameEx("regmatches")
+### * regmatches
+
+flush(stderr()); flush(stdout())
+
+### Name: regmatches
+### Title: Extract or Replace Matched Substrings
+### Aliases: regmatches regmatches<-
+### Keywords: character utilities
+
+### ** Examples
+
+x <- c("A and B", "A, B and C", "A, B, C and D", "foobar")
+pattern <- "[[:space:]]*(,|and)[[:space:]]"
+## Match data from regexpr()
+m <- regexpr(pattern, x)
+regmatches(x, m)
+regmatches(x, m, invert = TRUE)
+## Match data from gregexpr()
+m <- gregexpr(pattern, x)
+regmatches(x, m)
+regmatches(x, m, invert = TRUE)
+
+## Consider
+x <- "John (fishing, hunting), Paul (hiking, biking)"
+## Suppose we want to split at the comma (plus spaces) between the
+## persons, but not at the commas in the parenthesized hobby lists.
+## One idea is to "blank out" the parenthesized parts to match the
+## parts to be used for splitting, and extract the persons as the
+## non-matched parts.
+## First, match the parenthesized hobby lists.
+m <- gregexpr("\\([^)]*\\)", x)
+## Write a little utility for creating blank strings with given numbers
+## of characters.
+blanks <- function(n) strrep(" ", n)
+## Create a copy of x with the parenthesized parts blanked out.
+s <- x
+regmatches(s, m) <- Map(blanks, lapply(regmatches(s, m), nchar))
+s
+## Compute the positions of the split matches (note that we cannot call
+## strsplit() on x with match data from s).
+m <- gregexpr(", *", s)
+## And finally extract the non-matched parts.
+regmatches(x, m, invert = TRUE)
+
+
+
+cleanEx()
+nameEx("rep")
+### * rep
+
+flush(stderr()); flush(stdout())
+
+### Name: rep
+### Title: Replicate Elements of Vectors and Lists
+### Aliases: rep rep.factor rep.int rep.POSIXct rep.POSIXlt rep.Date
+### rep_len
+### Keywords: manip chron
+
+### ** Examples
+
+rep(1:4, 2)
+rep(1:4, each = 2) # not the same.
+rep(1:4, c(2,2,2,2)) # same as second.
+rep(1:4, c(2,1,2,1))
+rep(1:4, each = 2, len = 4) # first 4 only.
+rep(1:4, each = 2, len = 10) # 8 integers plus two recycled 1's.
+rep(1:4, each = 2, times = 3) # length 24, 3 complete replications
+
+rep(1, 40*(1-.8)) # length 7 on most platforms
+rep(1, 40*(1-.8)+1e-7) # better
+
+## replicate a list
+fred <- list(happy = 1:10, name = "squash")
+rep(fred, 5)
+
+# date-time objects
+x <- .leap.seconds[1:3]
+rep(x, 2)
+rep(as.POSIXlt(x), rep(2, 3))
+
+## named factor
+x <- factor(LETTERS[1:4]); names(x) <- letters[1:4]
+x
+rep(x, 2)
+rep(x, each = 2)
+rep.int(x, 2) # no names
+rep_len(x, 10)
+
+
+
+cleanEx()
+nameEx("rev")
+### * rev
+
+flush(stderr()); flush(stdout())
+
+### Name: rev
+### Title: Reverse Elements
+### Aliases: rev rev.default
+### Keywords: manip
+
+### ** Examples
+
+x <- c(1:5, 5:3)
+## sort into descending order; first more efficiently:
+stopifnot(sort(x, decreasing = TRUE) == rev(sort(x)))
+stopifnot(rev(1:7) == 7:1) #- don't need 'rev' here
+
+
+
+cleanEx()
+nameEx("rle")
+### * rle
+
+flush(stderr()); flush(stdout())
+
+### Name: rle
+### Title: Run Length Encoding
+### Aliases: rle inverse.rle print.rle
+### Keywords: manip
+
+### ** Examples
+
+x <- rev(rep(6:10, 1:5))
+rle(x)
+## lengths [1:5] 5 4 3 2 1
+## values [1:5] 10 9 8 7 6
+
+z <- c(TRUE, TRUE, FALSE, FALSE, TRUE, FALSE, TRUE, TRUE, TRUE)
+rle(z)
+rle(as.character(z))
+print(rle(z), prefix = "..| ")
+
+N <- integer(0)
+stopifnot(x == inverse.rle(rle(x)),
+ identical(N, inverse.rle(rle(N))),
+ z == inverse.rle(rle(z)))
+
+
+
+cleanEx()
+nameEx("rm")
+### * rm
+
+flush(stderr()); flush(stdout())
+
+### Name: remove
+### Title: Remove Objects from a Specified Environment
+### Aliases: rm remove
+### Keywords: environment
+
+### ** Examples
+
+tmp <- 1:4
+## work with tmp and cleanup
+rm(tmp)
+
+## Not run:
+##D ## remove (almost) everything in the working environment.
+##D ## You will get no warning, so don't do this unless you are really sure.
+##D rm(list = ls())
+## End(Not run)
+
+
+cleanEx()
+nameEx("round.POSIXt")
+### * round.POSIXt
+
+flush(stderr()); flush(stdout())
+
+### Name: round.POSIXt
+### Title: Round / Truncate Data-Time Objects
+### Aliases: round.POSIXt trunc.POSIXt round.Date trunc.Date
+### Keywords: chron
+
+### ** Examples
+
+round(.leap.seconds + 1000, "hour")
+
+
+
+cleanEx()
+nameEx("row")
+### * row
+
+flush(stderr()); flush(stdout())
+
+### Name: row
+### Title: Row Indexes
+### Aliases: row
+### Keywords: array
+
+### ** Examples
+
+x <- matrix(1:12, 3, 4)
+# extract the diagonal of a matrix
+dx <- x[row(x) == col(x)]
+dx
+
+# create an identity 5-by-5 matrix
+x <- matrix(0, nrow = 5, ncol = 5)
+x[row(x) == col(x)] <- 1
+x
+
+
+
+cleanEx()
+nameEx("rowsum")
+### * rowsum
+
+flush(stderr()); flush(stdout())
+
+### Name: rowsum
+### Title: Give Column Sums of a Matrix or Data Frame, Based on a Grouping
+### Variable
+### Aliases: rowsum rowsum.default rowsum.data.frame
+### Keywords: manip
+
+### ** Examples
+
+require(stats)
+
+x <- matrix(runif(100), ncol = 5)
+group <- sample(1:8, 20, TRUE)
+(xsum <- rowsum(x, group))
+## Slower versions
+tapply(x, list(group[row(x)], col(x)), sum)
+t(sapply(split(as.data.frame(x), group), colSums))
+aggregate(x, list(group), sum)[-1]
+
+
+
+cleanEx()
+nameEx("sQuote")
+### * sQuote
+
+flush(stderr()); flush(stdout())
+
+### Name: sQuote
+### Title: Quote Text
+### Aliases: sQuote dQuote
+### Keywords: character
+
+### ** Examples
+
+op <- options("useFancyQuotes")
+paste("argument", sQuote("x"), "must be non-zero")
+options(useFancyQuotes = FALSE)
+cat("\ndistinguish plain", sQuote("single"), "and",
+ dQuote("double"), "quotes\n")
+options(useFancyQuotes = TRUE)
+cat("\ndistinguish fancy", sQuote("single"), "and",
+ dQuote("double"), "quotes\n")
+options(useFancyQuotes = "TeX")
+cat("\ndistinguish TeX", sQuote("single"), "and",
+ dQuote("double"), "quotes\n")
+if(l10n_info()$`Latin-1`) {
+ options(useFancyQuotes = c("\xab", "\xbb", "\xbf", "?"))
+ cat("\n", sQuote("guillemet"), "and",
+ dQuote("Spanish question"), "styles\n")
+} else if(l10n_info()$`UTF-8`) {
+ options(useFancyQuotes = c("\xc2\xab", "\xc2\xbb", "\xc2\xbf", "?"))
+ cat("\n", sQuote("guillemet"), "and",
+ dQuote("Spanish question"), "styles\n")
+}
+options(op)
+
+
+
+cleanEx()
+nameEx("sample")
+### * sample
+
+flush(stderr()); flush(stdout())
+
+### Name: sample
+### Title: Random Samples and Permutations
+### Aliases: sample sample.int
+### Keywords: distribution
+
+### ** Examples
+
+x <- 1:12
+# a random permutation
+sample(x)
+# bootstrap resampling -- only if length(x) > 1 !
+sample(x, replace = TRUE)
+
+# 100 Bernoulli trials
+sample(c(0,1), 100, replace = TRUE)
+
+## More careful bootstrapping -- Consider this when using sample()
+## programmatically (i.e., in your function or simulation)!
+
+# sample()'s surprise -- example
+x <- 1:10
+ sample(x[x > 8]) # length 2
+ sample(x[x > 9]) # oops -- length 10!
+ sample(x[x > 10]) # length 0
+
+## safer version:
+resample <- function(x, ...) x[sample.int(length(x), ...)]
+resample(x[x > 8]) # length 2
+resample(x[x > 9]) # length 1
+resample(x[x > 10]) # length 0
+
+## R 3.x.y only
+sample.int(1e10, 12, replace = TRUE)
+sample.int(1e10, 12) # not that there is much chance of duplicates
+
+
+
+cleanEx()
+nameEx("save")
+### * save
+
+flush(stderr()); flush(stdout())
+
+### Name: save
+### Title: Save R Objects
+### Aliases: save save.image
+### Keywords: file
+
+### ** Examples
+
+x <- stats::runif(20)
+y <- list(a = 1, b = TRUE, c = "oops")
+save(x, y, file = "xy.RData")
+save.image()
+unlink("xy.RData")
+unlink(".RData")
+
+# set save defaults using option:
+options(save.defaults = list(ascii = TRUE, safe = FALSE))
+save.image()
+unlink(".RData")
+
+
+
+cleanEx()
+nameEx("scale")
+### * scale
+
+flush(stderr()); flush(stdout())
+
+### Name: scale
+### Title: Scaling and Centering of Matrix-like Objects
+### Aliases: scale scale.default
+### Keywords: array
+
+### ** Examples
+
+require(stats)
+x <- matrix(1:10, ncol = 2)
+(centered.x <- scale(x, scale = FALSE))
+cov(centered.scaled.x <- scale(x)) # all 1
+
+
+
+cleanEx()
+nameEx("scan")
+### * scan
+
+flush(stderr()); flush(stdout())
+
+### Name: scan
+### Title: Read Data Values
+### Aliases: scan
+### Keywords: file connection
+
+### ** Examples
+
+cat("TITLE extra line", "2 3 5 7", "11 13 17", file = "ex.data", sep = "\n")
+pp <- scan("ex.data", skip = 1, quiet = TRUE)
+scan("ex.data", skip = 1)
+scan("ex.data", skip = 1, nlines = 1) # only 1 line after the skipped one
+scan("ex.data", what = list("","","")) # flush is F -> read "7"
+scan("ex.data", what = list("","",""), flush = TRUE)
+unlink("ex.data") # tidy up
+
+## "inline" usage
+scan(text = "1 2 3")
+
+
+
+
+cleanEx()
+nameEx("search")
+### * search
+
+flush(stderr()); flush(stdout())
+
+### Name: search
+### Title: Give Search Path for R Objects
+### Aliases: search searchpaths .rmpkg
+### Keywords: data
+
+### ** Examples
+
+search()
+searchpaths()
+
+
+
+cleanEx()
+nameEx("seq.Date")
+### * seq.Date
+
+flush(stderr()); flush(stdout())
+
+### Name: seq.Date
+### Title: Generate Regular Sequences of Dates
+### Aliases: seq.Date
+### Keywords: manip chron
+
+### ** Examples
+
+## first days of years
+seq(as.Date("1910/1/1"), as.Date("1999/1/1"), "years")
+## by month
+seq(as.Date("2000/1/1"), by = "month", length.out = 12)
+## quarters
+seq(as.Date("2000/1/1"), as.Date("2003/1/1"), by = "quarter")
+
+## find all 7th of the month between two dates, the last being a 7th.
+st <- as.Date("1998-12-17")
+en <- as.Date("2000-1-7")
+ll <- seq(en, st, by = "-1 month")
+rev(ll[ll > st & ll < en])
+
+
+
+cleanEx()
+nameEx("seq.POSIXt")
+### * seq.POSIXt
+
+flush(stderr()); flush(stdout())
+
+### Name: seq.POSIXt
+### Title: Generate Regular Sequences of Times
+### Aliases: seq.POSIXt
+### Keywords: manip chron
+
+### ** Examples
+
+## first days of years
+seq(ISOdate(1910,1,1), ISOdate(1999,1,1), "years")
+## by month
+seq(ISOdate(2000,1,1), by = "month", length.out = 12)
+seq(ISOdate(2000,1,31), by = "month", length.out = 4)
+## quarters
+seq(ISOdate(1990,1,1), ISOdate(2000,1,1), by = "quarter") # or "3 months"
+## days vs DSTdays: use c() to lose the time zone.
+seq(c(ISOdate(2000,3,20)), by = "day", length.out = 10)
+seq(c(ISOdate(2000,3,20)), by = "DSTday", length.out = 10)
+seq(c(ISOdate(2000,3,20)), by = "7 DSTdays", length.out = 4)
+
+
+
+cleanEx()
+nameEx("seq")
+### * seq
+
+flush(stderr()); flush(stdout())
+
+### Name: seq
+### Title: Sequence Generation
+### Aliases: seq seq.default seq.int seq_along seq_len
+### Keywords: manip
+
+### ** Examples
+
+seq(0, 1, length.out = 11)
+seq(stats::rnorm(20)) # effectively 'along'
+seq(1, 9, by = 2) # matches 'end'
+seq(1, 9, by = pi) # stays below 'end'
+seq(1, 6, by = 3)
+seq(1.575, 5.125, by = 0.05)
+seq(17) # same as 1:17, or even better seq_len(17)
+
+
+
+cleanEx()
+nameEx("sequence")
+### * sequence
+
+flush(stderr()); flush(stdout())
+
+### Name: sequence
+### Title: Create A Vector of Sequences
+### Aliases: sequence
+### Keywords: manip
+
+### ** Examples
+
+sequence(c(3, 2)) # the concatenated sequences 1:3 and 1:2.
+#> [1] 1 2 3 1 2
+
+
+
+cleanEx()
+nameEx("serialize")
+### * serialize
+
+flush(stderr()); flush(stdout())
+
+### Name: serialize
+### Title: Simple Serialization Interface
+### Aliases: serialize unserialize
+### Keywords: file connection
+
+### ** Examples
+
+x <- serialize(list(1,2,3), NULL)
+unserialize(x)
+
+## see also the examples for saveRDS
+
+
+
+cleanEx()
+nameEx("sets")
+### * sets
+
+flush(stderr()); flush(stdout())
+
+### Name: sets
+### Title: Set Operations
+### Aliases: union intersect setdiff is.element setequal intersection
+### Keywords: misc
+
+### ** Examples
+
+(x <- c(sort(sample(1:20, 9)), NA))
+(y <- c(sort(sample(3:23, 7)), NA))
+union(x, y)
+intersect(x, y)
+setdiff(x, y)
+setdiff(y, x)
+setequal(x, y)
+
+## True for all possible x & y :
+setequal( union(x, y),
+ c(setdiff(x, y), intersect(x, y), setdiff(y, x)))
+
+is.element(x, y) # length 10
+is.element(y, x) # length 8
+
+
+
+cleanEx()
+nameEx("shQuote")
+### * shQuote
+
+flush(stderr()); flush(stdout())
+
+### Name: shQuote
+### Title: Quote Strings for Use in OS Shells
+### Aliases: shQuote
+### Keywords: utilities
+
+### ** Examples
+
+test <- "abc$def`gh`i\\j"
+cat(shQuote(test), "\n")
+## Not run: system(paste("echo", shQuote(test)))
+test <- "don't do it!"
+cat(shQuote(test), "\n")
+
+tryit <- paste("use the", sQuote("-c"), "switch\nlike this")
+cat(shQuote(tryit), "\n")
+## Not run: system(paste("echo", shQuote(tryit)))
+cat(shQuote(tryit, type = "csh"), "\n")
+
+## Windows-only example, assuming cmd.exe:
+perlcmd <- 'print "Hello World\\n";'
+## Not run:
+##D shell(shQuote(paste("perl -e",
+##D shQuote(perlcmd, type = "cmd")),
+##D type = "cmd2"))
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("showConnections")
+### * showConnections
+
+flush(stderr()); flush(stdout())
+
+### Name: showConnections
+### Title: Display Connections
+### Aliases: showConnections getConnection getAllConnections
+### closeAllConnections stdin stdout stderr isatty
+### Keywords: connection
+
+### ** Examples
+
+showConnections(all = TRUE)
+## Not run:
+##D textConnection(letters)
+##D # oops, I forgot to record that one
+##D showConnections()
+##D # class description mode text isopen can read can write
+##D #3 "letters" "textConnection" "r" "text" "opened" "yes" "no"
+##D mycon <- getConnection(3)
+## End(Not run)
+
+c(isatty(stdin()), isatty(stdout()), isatty(stderr()))
+
+
+
+cleanEx()
+nameEx("sign")
+### * sign
+
+flush(stderr()); flush(stdout())
+
+### Name: sign
+### Title: Sign Function
+### Aliases: sign
+### Keywords: arith
+
+### ** Examples
+
+sign(pi) # == 1
+sign(-2:3) # -1 -1 0 1 1 1
+
+
+
+cleanEx()
+nameEx("sink")
+### * sink
+
+flush(stderr()); flush(stdout())
+
+### Name: sink
+### Title: Send R Output to a File
+### Aliases: sink sink.number
+### Keywords: file connection
+
+### ** Examples
+
+sink("sink-examp.txt")
+i <- 1:10
+outer(i, i, "*")
+sink()
+## Don't show:
+unlink("sink-examp.txt")
+## End(Don't show)
+
+
+cleanEx()
+nameEx("slice.index")
+### * slice.index
+
+flush(stderr()); flush(stdout())
+
+### Name: slice.index
+### Title: Slice Indexes in an Array
+### Aliases: slice.index
+### Keywords: array
+
+### ** Examples
+
+x <- array(1 : 24, c(2, 3, 4))
+slice.index(x, 2)
+
+
+
+cleanEx()
+nameEx("socketSelect")
+### * socketSelect
+
+flush(stderr()); flush(stdout())
+
+### Name: socketSelect
+### Title: Wait on Socket Connections
+### Aliases: socketSelect
+### Keywords: connection
+
+### ** Examples
+
+## Not run:
+##D ## test whether socket connection s is available for writing or reading
+##D socketSelect(list(s, s), c(TRUE, FALSE), timeout = 0)
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("solve")
+### * solve
+
+flush(stderr()); flush(stdout())
+
+### Name: solve
+### Title: Solve a System of Equations
+### Aliases: solve solve.default
+### Keywords: algebra
+
+### ** Examples
+
+hilbert <- function(n) { i <- 1:n; 1 / outer(i - 1, i, "+") }
+h8 <- hilbert(8); h8
+sh8 <- solve(h8)
+round(sh8 %*% h8, 3)
+
+A <- hilbert(4)
+A[] <- as.complex(A)
+## might not be supported on all platforms
+try(solve(A))
+
+
+
+cleanEx()
+nameEx("sort")
+### * sort
+
+flush(stderr()); flush(stdout())
+
+### Name: sort
+### Title: Sorting or Ordering Vectors
+### Aliases: sort sort.default sort.POSIXlt sort.int
+### Keywords: univar manip arith
+
+### ** Examples
+
+require(stats)
+
+x <- swiss$Education[1:25]
+x; sort(x); sort(x, partial = c(10, 15))
+
+## illustrate 'stable' sorting (of ties):
+sort(c(10:3, 2:12), method = "shell", index.return = TRUE) # is stable
+## $x : 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 12
+## $ix: 9 8 10 7 11 6 12 5 13 4 14 3 15 2 16 1 17 18 19
+sort(c(10:3, 2:12), method = "quick", index.return = TRUE) # is not
+## $x : 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 12
+## $ix: 9 10 8 7 11 6 12 5 13 4 14 3 15 16 2 17 1 18 19
+
+x <- c(1:3, 3:5, 10)
+is.unsorted(x) # FALSE: is sorted
+is.unsorted(x, strictly = TRUE) # TRUE : is not (and cannot be)
+ # sorted strictly
+## Not run:
+##D ## Small speed comparison simulation:
+##D N <- 2000
+##D Sim <- 20
+##D rep <- 1000 # << adjust to your CPU
+##D c1 <- c2 <- numeric(Sim)
+##D for(is in seq_len(Sim)){
+##D x <- rnorm(N)
+##D c1[is] <- system.time(for(i in 1:rep) sort(x, method = "shell"))[1]
+##D c2[is] <- system.time(for(i in 1:rep) sort(x, method = "quick"))[1]
+##D stopifnot(sort(x, method = "shell") == sort(x, method = "quick"))
+##D }
+##D rbind(ShellSort = c1, QuickSort = c2)
+##D cat("Speedup factor of quick sort():\n")
+##D summary({qq <- c1 / c2; qq[is.finite(qq)]})
+##D
+##D ## A larger test
+##D x <- rnorm(1e7)
+##D system.time(x1 <- sort(x, method = "shell"))
+##D system.time(x2 <- sort(x, method = "quick"))
+##D system.time(x3 <- sort(x, method = "radix"))
+##D stopifnot(identical(x1, x2))
+##D stopifnot(identical(x1, x3))
+## End(Not run)
+
+
+cleanEx()
+nameEx("source")
+### * source
+
+flush(stderr()); flush(stdout())
+
+### Name: source
+### Title: Read R Code from a File, a Connection or Expressions
+### Aliases: source withAutoprint
+### Keywords: file programming connection
+
+### ** Examples
+
+someCond <- 7 > 6
+## want an if-clause to behave "as top level" wrt auto-printing :
+## (all should look "as if on top level", e.g. non-assignments should print:
+if(someCond) withAutoprint({
+ x <- 1:12
+ x-1
+ (y <- (x-5)^2)
+ z <- y
+ z - 10
+})
+
+## If you want to source() a bunch of files, something like
+## the following may be useful:
+ sourceDir <- function(path, trace = TRUE, ...) {
+ for (nm in list.files(path, pattern = "[.][RrSsQq]$")) {
+ if(trace) cat(nm,":")
+ source(file.path(path, nm), ...)
+ if(trace) cat("\n")
+ }
+ }
+
+suppressWarnings( rm(x,y) ) # remove 'x' or 'y' from global env
+withAutoprint({ x <- 1:2; cat("x=",x,"\n"); y <- x^2 })
+## x and y now exist:
+stopifnot(identical(x, 1:2), identical(y, x^2))
+
+withAutoprint({ formals(sourceDir); body(sourceDir) },
+ max.dep = 20, verbose = TRUE)
+
+
+
+cleanEx()
+nameEx("split")
+### * split
+
+flush(stderr()); flush(stdout())
+
+### Name: split
+### Title: Divide into Groups and Reassemble
+### Aliases: split split.default split.data.frame split<- split<-.default
+### split<-.data.frame unsplit
+### Keywords: category
+
+### ** Examples
+
+require(stats); require(graphics)
+n <- 10; nn <- 100
+g <- factor(round(n * runif(n * nn)))
+x <- rnorm(n * nn) + sqrt(as.numeric(g))
+xg <- split(x, g)
+boxplot(xg, col = "lavender", notch = TRUE, varwidth = TRUE)
+sapply(xg, length)
+sapply(xg, mean)
+
+### Calculate 'z-scores' by group (standardize to mean zero, variance one)
+z <- unsplit(lapply(split(x, g), scale), g)
+
+# or
+
+zz <- x
+split(zz, g) <- lapply(split(x, g), scale)
+
+# and check that the within-group std dev is indeed one
+tapply(z, g, sd)
+tapply(zz, g, sd)
+
+
+### data frame variation
+
+## Notice that assignment form is not used since a variable is being added
+
+g <- airquality$Month
+l <- split(airquality, g)
+l <- lapply(l, transform, Oz.Z = scale(Ozone))
+aq2 <- unsplit(l, g)
+head(aq2)
+with(aq2, tapply(Oz.Z, Month, sd, na.rm = TRUE))
+
+
+### Split a matrix into a list by columns
+ma <- cbind(x = 1:10, y = (-4:5)^2)
+split(ma, col(ma))
+
+split(1:10, 1:2)
+
+
+
+cleanEx()
+nameEx("sprintf")
+### * sprintf
+
+flush(stderr()); flush(stdout())
+
+### Name: sprintf
+### Title: Use C-style String Formatting Commands
+### Aliases: sprintf gettextf
+### Keywords: print character
+
+### ** Examples
+
+## be careful with the format: most things in R are floats
+## only integer-valued reals get coerced to integer.
+
+sprintf("%s is %f feet tall\n", "Sven", 7.1) # OK
+try(sprintf("%s is %i feet tall\n", "Sven", 7.1)) # not OK
+ sprintf("%s is %i feet tall\n", "Sven", 7 ) # OK
+
+## use a literal % :
+
+sprintf("%.0f%% said yes (out of a sample of size %.0f)", 66.666, 3)
+
+## various formats of pi :
+
+sprintf("%f", pi)
+sprintf("%.3f", pi)
+sprintf("%1.0f", pi)
+sprintf("%5.1f", pi)
+sprintf("%05.1f", pi)
+sprintf("%+f", pi)
+sprintf("% f", pi)
+sprintf("%-10f", pi) # left justified
+sprintf("%e", pi)
+sprintf("%E", pi)
+sprintf("%g", pi)
+sprintf("%g", 1e6 * pi) # -> exponential
+sprintf("%.9g", 1e6 * pi) # -> "fixed"
+sprintf("%G", 1e-6 * pi)
+
+## no truncation:
+sprintf("%1.f", 101)
+
+## re-use one argument three times, show difference between %x and %X
+xx <- sprintf("%1$d %1$x %1$X", 0:15)
+xx <- matrix(xx, dimnames = list(rep("", 16), "%d%x%X"))
+noquote(format(xx, justify = "right"))
+
+## More sophisticated:
+
+sprintf("min 10-char string '%10s'",
+ c("a", "ABC", "and an even longer one"))
+
+
+n <- 1:18
+sprintf(paste0("e with %2d digits = %.", n, "g"), n, exp(1))
+
+## Using arguments out of order
+sprintf("second %2$1.0f, first %1$5.2f, third %3$1.0f", pi, 2, 3)
+
+## Using asterisk for width or precision
+sprintf("precision %.*f, width '%*.3f'", 3, pi, 8, pi)
+
+## Asterisk and argument re-use, 'e' example reiterated:
+sprintf("e with %1$2d digits = %2$.*1$g", n, exp(1))
+
+## re-cycle arguments
+sprintf("%s %d", "test", 1:3)
+
+## binary output showing rounding/representation errors
+x <- seq(0, 1.0, 0.1); y <- c(0,.1,.2,.3,.4,.5,.6,.7,.8,.9,1)
+cbind(x, sprintf("%a", x), sprintf("%a", y))
+
+
+
+cleanEx()
+nameEx("srcfile")
+### * srcfile
+
+flush(stderr()); flush(stdout())
+
+### Name: srcfile
+### Title: References to Source Files and Code
+### Aliases: srcfile srcfilecopy getSrcLines srcref srcfile-class
+### srcfilecopy-class srcref-class print.srcfile summary.srcfile
+### open.srcfile open.srcfilecopy close.srcfile print.srcref
+### summary.srcref as.character.srcref .isOpen srcfilealias-class
+### srcfilealias open.srcfilealias close.srcfilealias
+### Keywords: debugging utilities
+
+### ** Examples
+
+
+cleanEx()
+nameEx("startsWith")
+### * startsWith
+
+flush(stderr()); flush(stdout())
+
+### Name: startsWith
+### Title: Does String Start or End With Another String?
+### Aliases: endsWith startsWith
+### Keywords: character utilities
+
+### ** Examples
+
+startsWith(search(), "package:") # typically at least two FALSE, nowadays often three
+
+x1 <- c("Foobar", "bla bla", "something", "another", "blu", "brown",
+ "blau blüht der Enzian")# non-ASCII
+x2 <- cbind(
+ startsWith(x1, "b"),
+ startsWith(x1, "bl"),
+ startsWith(x1, "bla"),
+ endsWith(x1, "n"),
+ endsWith(x1, "an"))
+rownames(x2) <- x1; colnames(x2) <- c("b", "b1", "bla", "n", "an")
+x2
+
+
+
+cleanEx()
+nameEx("stop")
+### * stop
+
+flush(stderr()); flush(stdout())
+
+### Name: stop
+### Title: Stop Function Execution
+### Aliases: stop geterrmessage
+### Keywords: environment programming error
+
+### ** Examples
+
+iter <- 12
+try(if(iter > 10) stop("too many iterations"))
+
+tst1 <- function(...) stop("dummy error")
+try(tst1(1:10, long, calling, expression))
+
+tst2 <- function(...) stop("dummy error", call. = FALSE)
+try(tst2(1:10, longcalling, expression, but.not.seen.in.Error))
+
+
+
+cleanEx()
+nameEx("stopifnot")
+### * stopifnot
+
+flush(stderr()); flush(stdout())
+
+### Name: stopifnot
+### Title: Ensure the Truth of R Expressions
+### Aliases: stopifnot
+### Keywords: environment programming error
+
+### ** Examples
+
+stopifnot(1 == 1, all.equal(pi, 3.14159265), 1 < 2) # all TRUE
+
+m <- matrix(c(1,3,3,1), 2, 2)
+stopifnot(m == t(m), diag(m) == rep(1, 2)) # all(.) |=> TRUE
+
+op <- options(error = expression(NULL))
+# "disabling stop(.)" << Use with CARE! >>
+
+stopifnot(all.equal(pi, 3.141593), 2 < 2, all(1:10 < 12), "a" < "b")
+stopifnot(all.equal(pi, 3.1415927), 2 < 2, all(1:10 < 12), "a" < "b")
+
+# long all.equal() error messages are abbreviated:
+stopifnot(all.equal(rep(list(pi),4), list(3.1, 3.14, 3.141, 3.1415)))
+
+options(op) # revert to previous error handler
+
+
+
+cleanEx()
+nameEx("strptime")
+### * strptime
+
+flush(stderr()); flush(stdout())
+
+### Name: strptime
+### Title: Date-time Conversion Functions to and from Character
+### Aliases: format.POSIXct format.POSIXlt strftime strptime
+### as.character.POSIXt
+### Keywords: utilities chron
+
+### ** Examples
+
+
+cleanEx()
+nameEx("strrep")
+### * strrep
+
+flush(stderr()); flush(stdout())
+
+### Name: strrep
+### Title: Repeat the Elements of a Character Vector
+### Aliases: strrep
+### Keywords: character
+
+### ** Examples
+
+strrep("ABC", 2)
+strrep(c("A", "B", "C"), 1 : 3)
+## Create vectors with the given numbers of spaces:
+strrep(" ", 1 : 5)
+
+
+
+cleanEx()
+nameEx("strsplit")
+### * strsplit
+
+flush(stderr()); flush(stdout())
+
+### Name: strsplit
+### Title: Split the Elements of a Character Vector
+### Aliases: strsplit
+### Keywords: character
+
+### ** Examples
+
+noquote(strsplit("A text I want to display with spaces", NULL)[[1]])
+
+x <- c(as = "asfef", qu = "qwerty", "yuiop[", "b", "stuff.blah.yech")
+# split x on the letter e
+strsplit(x, "e")
+
+unlist(strsplit("a.b.c", "."))
+## [1] "" "" "" "" ""
+## Note that 'split' is a regexp!
+## If you really want to split on '.', use
+unlist(strsplit("a.b.c", "[.]"))
+## [1] "a" "b" "c"
+## or
+unlist(strsplit("a.b.c", ".", fixed = TRUE))
+
+## a useful function: rev() for strings
+strReverse <- function(x)
+ sapply(lapply(strsplit(x, NULL), rev), paste, collapse = "")
+strReverse(c("abc", "Statistics"))
+
+## get the first names of the members of R-core
+a <- readLines(file.path(R.home("doc"),"AUTHORS"))[-(1:8)]
+a <- a[(0:2)-length(a)]
+(a <- sub(" .*","", a))
+# and reverse them
+strReverse(a)
+
+## Note that final empty strings are not produced:
+strsplit(paste(c("", "a", ""), collapse="#"), split="#")[[1]]
+# [1] "" "a"
+## and also an empty string is only produced before a definite match:
+strsplit("", " ")[[1]] # character(0)
+strsplit(" ", " ")[[1]] # [1] ""
+
+
+
+cleanEx()
+nameEx("strtoi")
+### * strtoi
+
+flush(stderr()); flush(stdout())
+
+### Name: strtoi
+### Title: Convert Strings to Integers
+### Aliases: strtoi
+### Keywords: classes character utilities
+
+### ** Examples
+
+strtoi(c("0xff", "077", "123"))
+strtoi(c("ffff", "FFFF"), 16L)
+strtoi(c("177", "377"), 8L)
+
+
+
+cleanEx()
+nameEx("strtrim")
+### * strtrim
+
+flush(stderr()); flush(stdout())
+
+### Name: strtrim
+### Title: Trim Character Strings to Specified Display Widths
+### Aliases: strtrim
+### Keywords: character utilities
+
+### ** Examples
+
+strtrim(c("abcdef", "abcdef", "abcdef"), c(1,5,10))
+
+
+
+cleanEx()
+nameEx("structure")
+### * structure
+
+flush(stderr()); flush(stdout())
+
+### Name: structure
+### Title: Attribute Specification
+### Aliases: structure
+### Keywords: attribute manip
+
+### ** Examples
+
+structure(1:6, dim = 2:3)
+
+
+
+cleanEx()
+nameEx("strwrap")
+### * strwrap
+
+flush(stderr()); flush(stdout())
+
+### Name: strwrap
+### Title: Wrap Character Strings to Format Paragraphs
+### Aliases: strwrap
+### Keywords: character
+
+### ** Examples
+
+## Read in file 'THANKS'.
+x <- paste(readLines(file.path(R.home("doc"), "THANKS")), collapse = "\n")
+## Split into paragraphs and remove the first three ones
+x <- unlist(strsplit(x, "\n[ \t\n]*\n"))[-(1:3)]
+## Join the rest
+x <- paste(x, collapse = "\n\n")
+## Now for some fun:
+writeLines(strwrap(x, width = 60))
+writeLines(strwrap(x, width = 60, indent = 5))
+writeLines(strwrap(x, width = 60, exdent = 5))
+writeLines(strwrap(x, prefix = "THANKS> "))
+
+## Note that messages are wrapped AT the target column indicated by
+## 'width' (and not beyond it).
+## From an R-devel posting by J. Hosking <jh910@juno.com>.
+x <- paste(sapply(sample(10, 100, replace = TRUE),
+ function(x) substring("aaaaaaaaaa", 1, x)), collapse = " ")
+sapply(10:40,
+ function(m)
+ c(target = m, actual = max(nchar(strwrap(x, m)))))
+
+
+
+cleanEx()
+nameEx("subset")
+### * subset
+
+flush(stderr()); flush(stdout())
+
+### Name: subset
+### Title: Subsetting Vectors, Matrices and Data Frames
+### Aliases: subset subset.default subset.matrix subset.data.frame
+### Keywords: manip
+
+### ** Examples
+
+subset(airquality, Temp > 80, select = c(Ozone, Temp))
+subset(airquality, Day == 1, select = -Temp)
+subset(airquality, select = Ozone:Wind)
+
+with(airquality, subset(Ozone, Temp > 80))
+
+## sometimes requiring a logical 'subset' argument is a nuisance
+nm <- rownames(state.x77)
+start_with_M <- nm %in% grep("^M", nm, value = TRUE)
+subset(state.x77, start_with_M, Illiteracy:Murder)
+# but in recent versions of R this can simply be
+subset(state.x77, grepl("^M", nm), Illiteracy:Murder)
+
+
+
+cleanEx()
+nameEx("substitute")
+### * substitute
+
+flush(stderr()); flush(stdout())
+
+### Name: substitute
+### Title: Substituting and Quoting Expressions
+### Aliases: substitute quote enquote
+### Keywords: programming data
+
+### ** Examples
+
+require(graphics)
+(s.e <- substitute(expression(a + b), list(a = 1))) #> expression(1 + b)
+(s.s <- substitute( a + b, list(a = 1))) #> 1 + b
+c(mode(s.e), typeof(s.e)) # "call", "language"
+c(mode(s.s), typeof(s.s)) # (the same)
+# but:
+(e.s.e <- eval(s.e)) #> expression(1 + b)
+c(mode(e.s.e), typeof(e.s.e)) # "expression", "expression"
+
+substitute(x <- x + 1, list(x = 1)) # nonsense
+
+myplot <- function(x, y)
+ plot(x, y, xlab = deparse(substitute(x)),
+ ylab = deparse(substitute(y)))
+
+## Simple examples about lazy evaluation, etc:
+
+f1 <- function(x, y = x) { x <- x + 1; y }
+s1 <- function(x, y = substitute(x)) { x <- x + 1; y }
+s2 <- function(x, y) { if(missing(y)) y <- substitute(x); x <- x + 1; y }
+a <- 10
+f1(a) # 11
+s1(a) # 11
+s2(a) # a
+typeof(s2(a)) # "symbol"
+
+
+
+cleanEx()
+nameEx("substr")
+### * substr
+
+flush(stderr()); flush(stdout())
+
+### Name: substr
+### Title: Substrings of a Character Vector
+### Aliases: substr substring substr<- substring<-
+### Keywords: character
+
+### ** Examples
+
+substr("abcdef", 2, 4)
+substring("abcdef", 1:6, 1:6)
+## strsplit is more efficient ...
+
+substr(rep("abcdef", 4), 1:4, 4:5)
+x <- c("asfef", "qwerty", "yuiop[", "b", "stuff.blah.yech")
+substr(x, 2, 5)
+substring(x, 2, 4:6)
+
+substring(x, 2) <- c("..", "+++")
+x
+
+
+
+cleanEx()
+nameEx("sum")
+### * sum
+
+flush(stderr()); flush(stdout())
+
+### Name: sum
+### Title: Sum of Vector Elements
+### Aliases: sum
+### Keywords: arith
+
+### ** Examples
+
+## Pass a vector to sum, and it will add the elements together.
+sum(1:5)
+
+## Pass several numbers to sum, and it also adds the elements.
+sum(1, 2, 3, 4, 5)
+
+## In fact, you can pass vectors into several arguments, and everything gets added.
+sum(1:2, 3:5)
+
+## If there are missing values, the sum is unknown, i.e., also missing, ....
+sum(1:5, NA)
+## ... unless we exclude missing values explicitly:
+sum(1:5, NA, na.rm = TRUE)
+
+
+
+cleanEx()
+nameEx("summary")
+### * summary
+
+flush(stderr()); flush(stdout())
+
+### Name: summary
+### Title: Object Summaries
+### Aliases: summary summary.default summary.data.frame summary.factor
+### summary.matrix format.summaryDefault print.summaryDefault
+### Keywords: methods
+
+### ** Examples
+
+summary(attenu, digits = 4) #-> summary.data.frame(...), default precision
+summary(attenu $ station, maxsum = 20) #-> summary.factor(...)
+
+lst <- unclass(attenu$station) > 20 # logical with NAs
+## summary.default() for logicals -- different from *.factor:
+summary(lst)
+summary(as.factor(lst))
+
+
+
+cleanEx()
+nameEx("svd")
+### * svd
+
+flush(stderr()); flush(stdout())
+
+### Name: svd
+### Title: Singular Value Decomposition of a Matrix
+### Aliases: svd La.svd
+### Keywords: algebra array
+
+### ** Examples
+
+hilbert <- function(n) { i <- 1:n; 1 / outer(i - 1, i, "+") }
+X <- hilbert(9)[, 1:6]
+(s <- svd(X))
+D <- diag(s$d)
+s$u %*% D %*% t(s$v) # X = U D V'
+t(s$u) %*% X %*% s$v # D = U' X V
+
+
+
+cleanEx()
+nameEx("sweep")
+### * sweep
+
+flush(stderr()); flush(stdout())
+
+### Name: sweep
+### Title: Sweep out Array Summaries
+### Aliases: sweep
+### Keywords: array iteration
+
+### ** Examples
+
+require(stats) # for median
+med.att <- apply(attitude, 2, median)
+sweep(data.matrix(attitude), 2, med.att) # subtract the column medians
+
+## More sweeping:
+A <- array(1:24, dim = 4:2)
+
+## no warnings in normal use
+sweep(A, 1, 5)
+(A.min <- apply(A, 1, min)) # == 1:4
+sweep(A, 1, A.min)
+sweep(A, 1:2, apply(A, 1:2, median))
+
+## warnings when mismatch
+sweep(A, 1, 1:3) # STATS does not recycle
+sweep(A, 1, 6:1) # STATS is longer
+
+## exact recycling:
+sweep(A, 1, 1:2) # no warning
+sweep(A, 1, as.array(1:2)) # warning
+
+
+
+cleanEx()
+nameEx("switch")
+### * switch
+
+flush(stderr()); flush(stdout())
+
+### Name: switch
+### Title: Select One of a List of Alternatives
+### Aliases: switch
+### Keywords: programming
+
+### ** Examples
+
+require(stats)
+centre <- function(x, type) {
+ switch(type,
+ mean = mean(x),
+ median = median(x),
+ trimmed = mean(x, trim = .1))
+}
+x <- rcauchy(10)
+centre(x, "mean")
+centre(x, "median")
+centre(x, "trimmed")
+
+ccc <- c("b","QQ","a","A","bb")
+# note: cat() produces no output for NULL
+for(ch in ccc)
+ cat(ch,":", switch(EXPR = ch, a = 1, b = 2:3), "\n")
+for(ch in ccc)
+ cat(ch,":", switch(EXPR = ch, a =, A = 1, b = 2:3, "Otherwise: last"),"\n")
+
+## switch(f, *) with a factor f
+ff <- gl(3,1, labels=LETTERS[3:1])
+ff[1] # C
+## so one might expect " is C" here, but
+switch(ff[1], A = "I am A", B="Bb..", C=" is C")# -> "I am A"
+## so we give a warning
+
+## Numeric EXPR does not allow a default value to be specified
+## -- it is always NULL
+for(i in c(-1:3, 9)) print(switch(i, 1, 2 , 3, 4))
+
+## visibility
+switch(1, invisible(pi), pi)
+switch(2, invisible(pi), pi)
+
+
+
+cleanEx()
+nameEx("sys.parent")
+### * sys.parent
+
+flush(stderr()); flush(stdout())
+
+### Name: sys.parent
+### Title: Functions to Access the Function Call Stack
+### Aliases: sys.parent sys.call sys.calls sys.frame sys.frames sys.nframe
+### sys.function sys.parents sys.on.exit sys.status parent.frame
+### Keywords: programming data
+
+### ** Examples
+
+
+cleanEx()
+nameEx("sys.source")
+### * sys.source
+
+flush(stderr()); flush(stdout())
+
+### Name: sys.source
+### Title: Parse and Evaluate Expressions from a File
+### Aliases: sys.source
+### Keywords: file utilities
+
+### ** Examples
+
+## a simple way to put some objects in an environment
+## high on the search path
+tmp <- tempfile()
+writeLines("aaa <- pi", tmp)
+env <- attach(NULL, name = "myenv")
+sys.source(tmp, env)
+unlink(tmp)
+search()
+aaa
+detach("myenv")
+
+
+
+cleanEx()
+nameEx("system")
+### * system
+
+flush(stderr()); flush(stdout())
+
+### Name: system
+### Title: Invoke a System Command
+### Aliases: system shell
+### Keywords: interface file utilities
+
+### ** Examples
+
+# list all files in the current directory using the -F flag
+## Not run: system("ls -F")
+
+# t1 is a character vector, each element giving a line of output from who
+# (if the platform has who)
+t1 <- try(system("who", intern = TRUE))
+
+try(system("ls fizzlipuzzli", intern = TRUE, ignore.stderr = TRUE))
+# zero-length result since file does not exist, and will give warning.
+
+
+
+cleanEx()
+nameEx("system.file")
+### * system.file
+
+flush(stderr()); flush(stdout())
+
+### Name: system.file
+### Title: Find Names of R System Files
+### Aliases: system.file
+### Keywords: file utilities
+
+### ** Examples
+
+system.file() # The root of the 'base' package
+system.file(package = "stats") # The root of package 'stats'
+system.file("INDEX")
+system.file("help", "AnIndex", package = "splines")
+
+
+
+cleanEx()
+nameEx("system.time")
+### * system.time
+
+flush(stderr()); flush(stdout())
+
+### Name: system.time
+### Title: CPU Time Used
+### Aliases: system.time unix.time
+### Keywords: utilities
+
+### ** Examples
+
+require(stats)
+## Not run:
+##D exT <- function(n = 10000) {
+##D # Purpose: Test if system.time works ok; n: loop size
+##D system.time(for(i in 1:n) x <- mean(rt(1000, df = 4)))
+##D }
+##D #-- Try to interrupt one of the following (using Ctrl-C / Escape):
+##D exT() #- about 4 secs on a 2.5GHz Xeon
+##D system.time(exT()) #~ +/- same
+## End(Not run)
+
+
+cleanEx()
+nameEx("t")
+### * t
+
+flush(stderr()); flush(stdout())
+
+### Name: t
+### Title: Matrix Transpose
+### Aliases: t t.default t.data.frame
+### Keywords: array
+
+### ** Examples
+
+a <- matrix(1:30, 5, 6)
+ta <- t(a) ##-- i.e., a[i, j] == ta[j, i] for all i,j :
+for(j in seq(ncol(a)))
+ if(! all(a[, j] == ta[j, ])) stop("wrong transpose")
+
+
+
+cleanEx()
+nameEx("table")
+### * table
+
+flush(stderr()); flush(stdout())
+
+### Name: table
+### Title: Cross Tabulation and Table Creation
+### Aliases: table summary.table print.summary.table as.data.frame.table
+### as.table as.table.default is.table [.table
+### Keywords: category
+
+### ** Examples
+
+require(stats) # for rpois and xtabs
+## Simple frequency distribution
+table(rpois(100, 5))
+## Check the design:
+with(warpbreaks, table(wool, tension))
+table(state.division, state.region)
+
+# simple two-way contingency table
+with(airquality, table(cut(Temp, quantile(Temp)), Month))
+
+a <- letters[1:3]
+table(a, sample(a)) # dnn is c("a", "")
+table(a, sample(a), deparse.level = 0) # dnn is c("", "")
+table(a, sample(a), deparse.level = 2) # dnn is c("a", "sample(a)")
+
+## xtabs() <-> as.data.frame.table() :
+UCBAdmissions ## already a contingency table
+DF <- as.data.frame(UCBAdmissions)
+class(tab <- xtabs(Freq ~ ., DF)) # xtabs & table
+## tab *is* "the same" as the original table:
+all(tab == UCBAdmissions)
+all.equal(dimnames(tab), dimnames(UCBAdmissions))
+
+a <- rep(c(NA, 1/0:3), 10)
+table(a) # does not report NA's
+table(a, exclude = NULL) # reports NA's
+b <- factor(rep(c("A","B","C"), 10))
+table(b)
+table(b, exclude = "B")
+d <- factor(rep(c("A","B","C"), 10), levels = c("A","B","C","D","E"))
+table(d, exclude = "B")
+print(table(b, d), zero.print = ".")
+
+## NA counting:
+is.na(d) <- 3:4
+d. <- addNA(d)
+d.[1:7]
+table(d.) # ", exclude = NULL" is not needed
+## i.e., if you want to count the NA's of 'd', use
+table(d, useNA = "ifany")
+
+## "pathological" case:
+d.patho <- addNA(c(1,NA,1:2,1:3))[-7]; is.na(d.patho) <- 3:4
+d.patho
+## just 3 consecutive NA's ? --- well, have *two* kinds of NAs here :
+as.integer(d.patho) # 1 4 NA NA 1 2
+##
+## In R >= 3.4.0, table() allows to differentiate:
+table(d.patho) # counts the "unusual" NA
+table(d.patho, useNA = "ifany") # counts all three
+table(d.patho, exclude = NULL) # (ditto)
+table(d.patho, exclude = NA) # counts none
+
+## Two-way tables with NA counts. The 3rd variant is absurd, but shows
+## something that cannot be done using exclude or useNA.
+with(airquality,
+ table(OzHi = Ozone > 80, Month, useNA = "ifany"))
+with(airquality,
+ table(OzHi = Ozone > 80, Month, useNA = "always"))
+with(airquality,
+ table(OzHi = Ozone > 80, addNA(Month)))
+
+
+
+cleanEx()
+nameEx("tabulate")
+### * tabulate
+
+flush(stderr()); flush(stdout())
+
+### Name: tabulate
+### Title: Tabulation for Vectors
+### Aliases: tabulate
+### Keywords: arith
+
+### ** Examples
+
+tabulate(c(2,3,5))
+tabulate(c(2,3,3,5), nbins = 10)
+tabulate(c(-2,0,2,3,3,5)) # -2 and 0 are ignored
+tabulate(c(-2,0,2,3,3,5), nbins = 3)
+tabulate(factor(letters[1:10]))
+
+
+
+cleanEx()
+nameEx("tapply")
+### * tapply
+
+flush(stderr()); flush(stdout())
+
+### Name: tapply
+### Title: Apply a Function Over a Ragged Array
+### Aliases: tapply
+### Keywords: iteration category
+
+### ** Examples
+
+require(stats)
+groups <- as.factor(rbinom(32, n = 5, prob = 0.4))
+tapply(groups, groups, length) #- is almost the same as
+table(groups)
+
+## contingency table from data.frame : array with named dimnames
+tapply(warpbreaks$breaks, warpbreaks[,-1], sum)
+tapply(warpbreaks$breaks, warpbreaks[, 3, drop = FALSE], sum)
+
+n <- 17; fac <- factor(rep_len(1:3, n), levels = 1:5)
+table(fac)
+tapply(1:n, fac, sum)
+tapply(1:n, fac, sum, default = 0) # maybe more desirable
+tapply(1:n, fac, sum, simplify = FALSE)
+tapply(1:n, fac, range)
+tapply(1:n, fac, quantile)
+tapply(1:n, fac, length) ## NA's
+tapply(1:n, fac, length, default = 0) # == table(fac)
+## Don't show:
+stopifnot(all.equal(
+ unname(unclass(table(fac))),
+ unname( tapply(1:n, fac, length, default = 0))))
+## End(Don't show)
+## example of ... argument: find quarterly means
+tapply(presidents, cycle(presidents), mean, na.rm = TRUE)
+
+ind <- list(c(1, 2, 2), c("A", "A", "B"))
+table(ind)
+tapply(1:3, ind) #-> the split vector
+tapply(1:3, ind, sum)
+
+## Some assertions (not held by all patch propsals):
+nq <- names(quantile(1:5))
+stopifnot(
+ identical(tapply(1:3, ind), c(1L, 2L, 4L)),
+ identical(tapply(1:3, ind, sum),
+ matrix(c(1L, 2L, NA, 3L), 2, dimnames = list(c("1", "2"), c("A", "B")))),
+ identical(tapply(1:n, fac, quantile)[-1],
+ array(list(`2` = structure(c(2, 5.75, 9.5, 13.25, 17), .Names = nq),
+ `3` = structure(c(3, 6, 9, 12, 15), .Names = nq),
+ `4` = NULL, `5` = NULL), dim=4, dimnames=list(as.character(2:5)))))
+
+
+
+cleanEx()
+nameEx("taskCallback")
+### * taskCallback
+
+flush(stderr()); flush(stdout())
+
+### Name: taskCallback
+### Title: Add or Remove a Top-Level Task Callback
+### Aliases: addTaskCallback removeTaskCallback
+### Keywords: environment
+
+### ** Examples
+
+times <- function(total = 3, str = "Task a") {
+ ctr <- 0
+ function(expr, value, ok, visible) {
+ ctr <<- ctr + 1
+ cat(str, ctr, "\n")
+ keep.me <- (ctr < total)
+ if (!keep.me)
+ cat("handler removing itself\n")
+
+ # return
+ keep.me
+ }
+}
+
+# add the callback that will work for
+# 4 top-level tasks and then remove itself.
+n <- addTaskCallback(times(4))
+
+# now remove it, assuming it is still first in the list.
+removeTaskCallback(n)
+
+## See how the handler is called every time till "self destruction":
+
+addTaskCallback(times(4)) # counts as once already
+
+sum(1:10) ; mean(1:3) # two more
+sinpi(1) # 4th - and "done"
+cospi(1)
+tanpi(1)
+
+
+
+cleanEx()
+nameEx("taskCallbackManager")
+### * taskCallbackManager
+
+flush(stderr()); flush(stdout())
+
+### Name: taskCallbackManager
+### Title: Create an R-level Task Callback Manager
+### Aliases: taskCallbackManager
+### Keywords: environment
+
+### ** Examples
+
+# create the manager
+h <- taskCallbackManager()
+
+# add a callback
+h$add(function(expr, value, ok, visible) {
+ cat("In handler\n")
+ return(TRUE)
+ }, name = "simpleHandler")
+
+# look at the internal callbacks.
+getTaskCallbackNames()
+
+# look at the R-level callbacks
+names(h$callbacks())
+
+getTaskCallbackNames()
+removeTaskCallback("R-taskCallbackManager")
+
+
+
+cleanEx()
+nameEx("taskCallbackNames")
+### * taskCallbackNames
+
+flush(stderr()); flush(stdout())
+
+### Name: taskCallbackNames
+### Title: Query the Names of the Current Internal Top-Level Task Callbacks
+### Aliases: getTaskCallbackNames
+### Keywords: environment
+
+### ** Examples
+
+ n <- addTaskCallback(function(expr, value, ok, visible) {
+ cat("In handler\n")
+ return(TRUE)
+ }, name = "simpleHandler")
+
+ getTaskCallbackNames()
+
+ # now remove it by name
+ removeTaskCallback("simpleHandler")
+
+
+ h <- taskCallbackManager()
+ h$add(function(expr, value, ok, visible) {
+ cat("In handler\n")
+ return(TRUE)
+ }, name = "simpleHandler")
+ getTaskCallbackNames()
+ removeTaskCallback("R-taskCallbackManager")
+
+
+
+cleanEx()
+nameEx("tempfile")
+### * tempfile
+
+flush(stderr()); flush(stdout())
+
+### Name: tempfile
+### Title: Create Names for Temporary Files
+### Aliases: tempfile tempdir
+### Keywords: file
+
+### ** Examples
+
+
+cleanEx()
+nameEx("textconnections")
+### * textconnections
+
+flush(stderr()); flush(stdout())
+
+### Name: textConnection
+### Title: Text Connections
+### Aliases: textConnection textConnectionValue
+### Keywords: file connection
+
+### ** Examples
+
+zz <- textConnection(LETTERS)
+readLines(zz, 2)
+scan(zz, "", 4)
+pushBack(c("aa", "bb"), zz)
+scan(zz, "", 4)
+close(zz)
+
+zz <- textConnection("foo", "w")
+writeLines(c("testit1", "testit2"), zz)
+cat("testit3 ", file = zz)
+isIncomplete(zz)
+cat("testit4\n", file = zz)
+isIncomplete(zz)
+close(zz)
+foo
+
+
+
+
+cleanEx()
+nameEx("timezones")
+### * timezones
+
+flush(stderr()); flush(stdout())
+
+### Name: timezones
+### Title: Time Zones
+### Aliases: Sys.timezone OlsonNames timezone timezones 'time zone' 'time
+### zones' TZ TZDIR
+### Keywords: utilities chron
+
+### ** Examples
+
+Sys.timezone()
+
+str(OlsonNames()) ## a few hundred names
+
+
+
+cleanEx()
+nameEx("toString")
+### * toString
+
+flush(stderr()); flush(stdout())
+
+### Name: toString
+### Title: Convert an R Object to a Character String
+### Aliases: toString toString.default
+### Keywords: utilities
+
+### ** Examples
+
+x <- c("a", "b", "aaaaaaaaaaa")
+toString(x)
+toString(x, width = 8)
+
+
+
+cleanEx()
+nameEx("trace")
+### * trace
+
+flush(stderr()); flush(stdout())
+
+### Name: trace
+### Title: Interactive Tracing and Debugging of Calls to a Function or
+### Method
+### Aliases: trace untrace tracingState .doTrace returnValue
+### Keywords: programming debugging
+
+### ** Examples
+
+require(stats)
+
+## Very simple use
+trace(sum)
+hist(rnorm(100)) # shows about 3-4 calls to sum()
+untrace(sum)
+
+## Show how pt() is called from inside power.t.test():
+if(FALSE)
+ trace(pt) ## would show ~20 calls, but we want to see more:
+trace(pt, tracer = quote(cat(sprintf("tracing pt(*, ncp = %.15g)\n", ncp))),
+ print = FALSE) # <- not showing typical extra
+power.t.test(20, 1, power=0.8, sd=NULL) ##--> showing the ncp root finding:
+untrace(pt)
+
+f <- function(x, y) {
+ y <- pmax(y, 0.001)
+ if (x > 0) x ^ y else stop("x must be positive")
+}
+
+## arrange to call the browser on entering and exiting
+## function f
+trace("f", quote(browser(skipCalls = 4)),
+ exit = quote(browser(skipCalls = 4)))
+
+## instead, conditionally assign some data, and then browse
+## on exit, but only then. Don't bother me otherwise
+
+trace("f", quote(if(any(y < 0)) yOrig <- y),
+ exit = quote(if(exists("yOrig")) browser(skipCalls = 4)),
+ print = FALSE)
+
+## Enter the browser just before stop() is called. First, find
+## the step numbers
+
+as.list(body(f))
+as.list(body(f)[[3]])
+
+## Now call the browser there
+
+trace("f", quote(browser(skipCalls = 4)), at = list(c(3,4)))
+
+## trace a utility function, with recover so we
+## can browse in the calling functions as well.
+
+trace("as.matrix", recover)
+
+
+## turn off the tracing
+
+untrace(c("f", "as.matrix"))
+
+## Not run:
+##D ## trace calls to the function lm() that come from
+##D ## the nlme package.
+##D ## (The function nlme is in that package, and the package
+##D ## has a namespace, so the where= argument must be used
+##D ## to get the right version of lm)
+##D
+##D trace(lm, exit = recover, where = asNamespace("nlme"))
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("traceback")
+### * traceback
+
+flush(stderr()); flush(stdout())
+
+### Name: traceback
+### Title: Get and Print Call Stacks
+### Aliases: traceback .traceback .Traceback
+### Keywords: programming
+
+### ** Examples
+
+foo <- function(x) { print(1); bar(2) }
+bar <- function(x) { x + a.variable.which.does.not.exist }
+## Not run:
+##D foo(2) # gives a strange error
+##D traceback()
+## End(Not run)
+## 2: bar(2)
+## 1: foo(2)
+bar
+## Ah, this is the culprit ...
+
+## This will print the stack trace at the time of the error.
+options(error = function() traceback(2))
+
+
+
+cleanEx()
+nameEx("tracemem")
+### * tracemem
+
+flush(stderr()); flush(stdout())
+
+### Name: tracemem
+### Title: Trace Copying of Objects
+### Aliases: tracemem untracemem retracemem
+### Keywords: utilities
+
+### ** Examples
+## Not run:
+##D a <- 1:10
+##D tracemem(a)
+##D ## b and a share memory
+##D b <- a
+##D b[1] <- 1
+##D untracemem(a)
+##D
+##D ## copying in lm: less than R <= 2.15.0
+##D d <- stats::rnorm(10)
+##D tracemem(d)
+##D lm(d ~ a+log(b))
+##D
+##D ## f is not a copy and is not traced
+##D f <- d[-1]
+##D f+1
+##D ## indicate that f should be traced as a copy of d
+##D retracemem(f, retracemem(d))
+##D f+1
+## End(Not run)
+
+
+cleanEx()
+nameEx("transform")
+### * transform
+
+flush(stderr()); flush(stdout())
+
+### Name: transform
+### Title: Transform an Object, for Example a Data Frame
+### Aliases: transform transform.default transform.data.frame
+### Keywords: manip
+
+### ** Examples
+
+transform(airquality, Ozone = -Ozone)
+transform(airquality, new = -Ozone, Temp = (Temp-32)/1.8)
+
+attach(airquality)
+transform(Ozone, logOzone = log(Ozone)) # marginally interesting ...
+detach(airquality)
+
+
+
+cleanEx()
+nameEx("trimws")
+### * trimws
+
+flush(stderr()); flush(stdout())
+
+### Name: trimws
+### Title: Remove Leading/Trailing Whitespace
+### Aliases: trimws
+### Keywords: character
+
+### ** Examples
+
+x <- " Some text. "
+x
+trimws(x)
+trimws(x, "l")
+trimws(x, "r")
+
+
+
+cleanEx()
+nameEx("try")
+### * try
+
+flush(stderr()); flush(stdout())
+
+### Name: try
+### Title: Try an Expression Allowing Error Recovery
+### Aliases: try
+### Keywords: programming
+
+### ** Examples
+
+## this example will not work correctly in example(try), but
+## it does work correctly if pasted in
+options(show.error.messages = FALSE)
+try(log("a"))
+print(.Last.value)
+options(show.error.messages = TRUE)
+
+## alternatively,
+print(try(log("a"), TRUE))
+
+## run a simulation, keep only the results that worked.
+set.seed(123)
+x <- stats::rnorm(50)
+doit <- function(x)
+{
+ x <- sample(x, replace = TRUE)
+ if(length(unique(x)) > 30) mean(x)
+ else stop("too few unique points")
+}
+## alternative 1
+res <- lapply(1:100, function(i) try(doit(x), TRUE))
+## alternative 2
+## Not run:
+##D res <- vector("list", 100)
+##D for(i in 1:100) res[[i]] <- try(doit(x), TRUE)
+## End(Not run)
+unlist(res[sapply(res, function(x) !inherits(x, "try-error"))])
+
+
+
+cleanEx()
+nameEx("typeof")
+### * typeof
+
+flush(stderr()); flush(stdout())
+
+### Name: typeof
+### Title: The Type of an Object
+### Aliases: typeof type
+### Keywords: attribute
+
+### ** Examples
+
+typeof(2)
+mode(2)
+
+
+
+cleanEx()
+nameEx("unique")
+### * unique
+
+flush(stderr()); flush(stdout())
+
+### Name: unique
+### Title: Extract Unique Elements
+### Aliases: unique unique.default unique.data.frame unique.matrix
+### unique.array
+### Keywords: manip logic
+
+### ** Examples
+
+x <- c(3:5, 11:8, 8 + 0:5)
+(ux <- unique(x))
+(u2 <- unique(x, fromLast = TRUE)) # different order
+stopifnot(identical(sort(ux), sort(u2)))
+
+length(unique(sample(100, 100, replace = TRUE)))
+## approximately 100(1 - 1/e) = 63.21
+
+unique(iris)
+
+
+
+cleanEx()
+nameEx("unlist")
+### * unlist
+
+flush(stderr()); flush(stdout())
+
+### Name: unlist
+### Title: Flatten Lists
+### Aliases: unlist
+### Keywords: list manip
+
+### ** Examples
+
+unlist(options())
+unlist(options(), use.names = FALSE)
+
+l.ex <- list(a = list(1:5, LETTERS[1:5]), b = "Z", c = NA)
+unlist(l.ex, recursive = FALSE)
+unlist(l.ex, recursive = TRUE)
+
+l1 <- list(a = "a", b = 2, c = pi+2i)
+unlist(l1) # a character vector
+l2 <- list(a = "a", b = as.name("b"), c = pi+2i)
+unlist(l2) # remains a list
+
+ll <- list(as.name("sinc"), quote( a + b ), 1:10, letters, expression(1+x))
+utils::str(ll)
+for(x in ll)
+ stopifnot(identical(x, unlist(x)))
+
+
+
+cleanEx()
+nameEx("unname")
+### * unname
+
+flush(stderr()); flush(stdout())
+
+### Name: unname
+### Title: Remove 'names' or 'dimnames'
+### Aliases: unname
+### Keywords: utilities
+
+### ** Examples
+
+require(graphics); require(stats)
+
+## Answering a question on R-help (14 Oct 1999):
+col3 <- 750+ 100*rt(1500, df = 3)
+breaks <- factor(cut(col3, breaks = 360+5*(0:155)))
+z <- table(breaks)
+z[1:5] # The names are larger than the data ...
+barplot(unname(z), axes = FALSE)
+
+
+
+cleanEx()
+nameEx("userhooks")
+### * userhooks
+
+flush(stderr()); flush(stdout())
+
+### Name: userhooks
+### Title: Functions to Get and Set Hooks for Load, Attach, Detach and
+### Unload
+### Aliases: getHook setHook packageEvent .userHooksEnv
+### Keywords: utilities
+
+### ** Examples
+
+setHook(packageEvent("grDevices", "onLoad"),
+ function(...) grDevices::ps.options(horizontal = FALSE))
+
+
+
+cleanEx()
+nameEx("utf8Conversion")
+### * utf8Conversion
+
+flush(stderr()); flush(stdout())
+
+### Name: utf8Conversion
+### Title: Convert Integer Vectors to or from UTF-8-encoded Character
+### Vectors
+### Aliases: utf8ToInt intToUtf8 Unicode 'code point'
+### Keywords: character utilities
+
+### ** Examples
+utf8ToInt("bi\u00dfchen")
+utf8ToInt("\xfa\xb4\xbf\xbf\x9f")
+
+
+
+cleanEx()
+nameEx("validUTF8")
+### * validUTF8
+
+flush(stderr()); flush(stdout())
+
+### Name: validUTF8
+### Title: Check if a Character Vector is Validly Encoded
+### Aliases: validUTF8 validEnc
+
+### ** Examples
+
+x <-
+ ## from example(text)
+c("Jetz", "no", "chli", "z\xc3\xbcrit\xc3\xbc\xc3\xbctsch:",
+ "(noch", "ein", "bi\xc3\x9fchen", "Z\xc3\xbc", "deutsch)",
+ ## from a CRAN check log
+ "\xfa\xb4\xbf\xbf\x9f")
+validUTF8(x)
+validEnc(x) # depends on the locale
+Encoding(x) <-"UTF-8"
+validEnc(x)
+
+
+
+cleanEx()
+nameEx("vector")
+### * vector
+
+flush(stderr()); flush(stdout())
+
+### Name: vector
+### Title: Vectors
+### Aliases: vector as.vector as.vector.factor is.vector atomic
+### Keywords: classes
+
+### ** Examples
+
+df <- data.frame(x = 1:3, y = 5:7)
+## Error:
+try(as.vector(data.frame(x = 1:3, y = 5:7), mode = "numeric"))
+
+x <- c(a = 1, b = 2)
+is.vector(x)
+as.vector(x)
+all.equal(x, as.vector(x)) ## FALSE
+
+
+###-- All the following are TRUE:
+is.list(df)
+! is.vector(df)
+! is.vector(df, mode = "list")
+
+is.vector(list(), mode = "list")
+
+
+
+cleanEx()
+nameEx("warning")
+### * warning
+
+flush(stderr()); flush(stdout())
+
+### Name: warning
+### Title: Warning Messages
+### Aliases: warning suppressWarnings
+### Keywords: programming error
+
+### ** Examples
+
+## Don't show:
+oldopt <- options(warn = 1)
+## End(Don't show)
+testit <- function() warning("testit")
+testit() ## shows call
+testit <- function() warning("problem in testit", call. = FALSE)
+testit() ## no call
+suppressWarnings(warning("testit"))
+## Don't show:
+eigenval <- 10 ^ -stats::rnorm(1, mean = 6)
+if(eigenval < 1.e-7) warning("system near singular")
+options(oldopt)
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("warnings")
+### * warnings
+
+flush(stderr()); flush(stdout())
+
+### Name: warnings
+### Title: Print Warning Messages
+### Aliases: warnings last.warning print.warnings [.warnings c.warnings
+### duplicated.warnings unique.warnings
+### Keywords: programming error
+
+### ** Examples
+
+## NB this example is intended to be pasted in,
+## rather than run by example()
+ow <- options("warn")
+for(w in -1:1) {
+ options(warn = w); cat("\n warn =", w, "\n")
+ for(i in 1:3) { cat(i,"..\n"); m <- matrix(1:7, 3,4) }
+}
+warnings()
+options(ow) # reset
+tail(warnings(), 2) # see the last two warnings only (via '[' method)
+## Don't show:
+ww <- warnings()
+uw <- unique(ww)
+stopifnot(identical(c(ww[1], ww[3]), ww[c(1, 3)]),
+ length(uw) == 1, nchar(names(uw)) > 10)
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("weekday.POSIXt")
+### * weekday.POSIXt
+
+flush(stderr()); flush(stdout())
+
+### Name: weekdays
+### Title: Extract Parts of a POSIXt or Date Object
+### Aliases: weekdays weekdays.POSIXt weekdays.Date months months.POSIXt
+### months.Date quarters quarters.POSIXt quarters.Date julian
+### julian.POSIXt julian.Date
+### Keywords: chron
+
+### ** Examples
+
+
+cleanEx()
+nameEx("which")
+### * which
+
+flush(stderr()); flush(stdout())
+
+### Name: which
+### Title: Which indices are TRUE?
+### Aliases: which arrayInd
+### Keywords: logic attribute
+
+### ** Examples
+
+which(LETTERS == "R")
+which(ll <- c(TRUE, FALSE, TRUE, NA, FALSE, FALSE, TRUE)) #> 1 3 7
+names(ll) <- letters[seq(ll)]
+which(ll)
+which((1:12)%%2 == 0) # which are even?
+which(1:10 > 3, arr.ind = TRUE)
+
+( m <- matrix(1:12, 3, 4) )
+div.3 <- m %% 3 == 0
+which(div.3)
+which(div.3, arr.ind = TRUE)
+rownames(m) <- paste("Case", 1:3, sep = "_")
+which(m %% 5 == 0, arr.ind = TRUE)
+
+dim(m) <- c(2, 2, 3); m
+which(div.3, arr.ind = FALSE)
+which(div.3, arr.ind = TRUE)
+
+vm <- c(m)
+dim(vm) <- length(vm) #-- funny thing with length(dim(...)) == 1
+which(div.3, arr.ind = TRUE)
+## Don't show:
+dimnames(m) <- list(X = c("U", "V"), Z = c("y","z"), three = LETTERS[1:3])
+wm <- which(m %% 3 == 0, arr.ind = TRUE)
+vn <- vm; dimnames(vn) <- list(LETTERS[1:12])
+wv <- which(vn %% 3 == 0, arr.ind = TRUE)
+
+stopifnot(identical(wv, array(3L*(1:4), dim = c(4, 1),
+ dimnames = list(c("C", "F", "I", "L"), "dim1"))),
+ identical(wm, array(c(1:2, 1:2, 2:1, 1:2, 1:3, 3L),
+ dim = 4:3,
+ dimnames = list(rep(c("U","V"),2),
+ c("X", "Z", "three"))))
+)
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("which.min")
+### * which.min
+
+flush(stderr()); flush(stdout())
+
+### Name: which.min
+### Title: Where is the Min() or Max() or first TRUE or FALSE ?
+### Aliases: which.min which.max
+### Keywords: utilities
+
+### ** Examples
+
+x <- c(1:4, 0:5, 11)
+which.min(x)
+which.max(x)
+
+## it *does* work with NA's present, by discarding them:
+presidents[1:30]
+range(presidents, na.rm = TRUE)
+which.min(presidents) # 28
+which.max(presidents) # 2
+
+## Find the first occurrence, i.e. the first TRUE, if there is at least one:
+x <- rpois(10000, lambda = 10); x[sample.int(50, 20)] <- NA
+## where is the first value >= 20 ?
+which.max(x >= 20)
+
+## Also works for lists (which can be coerced to numeric vectors):
+which.min(list(A = 7, pi = pi)) ## -> c(pi = 2L)
+## Don't show:
+stopifnot(identical(which.min(list(A = 7, pi = pi)), c(pi = 2L)))
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("with")
+### * with
+
+flush(stderr()); flush(stdout())
+
+### Name: with
+### Title: Evaluate an Expression in a Data Environment
+### Aliases: with with.default within within.list within.data.frame
+### Keywords: data programming
+
+### ** Examples
+
+with(mtcars, mpg[cyl == 8 & disp > 350])
+ # is the same as, but nicer than
+mtcars$mpg[mtcars$cyl == 8 & mtcars$disp > 350]
+
+require(stats); require(graphics)
+
+# examples from glm:
+with(data.frame(u = c(5,10,15,20,30,40,60,80,100),
+ lot1 = c(118,58,42,35,27,25,21,19,18),
+ lot2 = c(69,35,26,21,18,16,13,12,12)),
+ list(summary(glm(lot1 ~ log(u), family = Gamma)),
+ summary(glm(lot2 ~ log(u), family = Gamma))))
+
+aq <- within(airquality, { # Notice that multiple vars can be changed
+ lOzone <- log(Ozone)
+ Month <- factor(month.abb[Month])
+ cTemp <- round((Temp - 32) * 5/9, 1) # From Fahrenheit to Celsius
+ S.cT <- Solar.R / cTemp # using the newly created variable
+ rm(Day, Temp)
+})
+head(aq)
+
+# example from boxplot:
+with(ToothGrowth, {
+ boxplot(len ~ dose, boxwex = 0.25, at = 1:3 - 0.2,
+ subset = (supp == "VC"), col = "yellow",
+ main = "Guinea Pigs' Tooth Growth",
+ xlab = "Vitamin C dose mg",
+ ylab = "tooth length", ylim = c(0, 35))
+ boxplot(len ~ dose, add = TRUE, boxwex = 0.25, at = 1:3 + 0.2,
+ subset = supp == "OJ", col = "orange")
+ legend(2, 9, c("Ascorbic acid", "Orange juice"),
+ fill = c("yellow", "orange"))
+})
+
+# alternate form that avoids subset argument:
+with(subset(ToothGrowth, supp == "VC"),
+ boxplot(len ~ dose, boxwex = 0.25, at = 1:3 - 0.2,
+ col = "yellow", main = "Guinea Pigs' Tooth Growth",
+ xlab = "Vitamin C dose mg",
+ ylab = "tooth length", ylim = c(0, 35)))
+with(subset(ToothGrowth, supp == "OJ"),
+ boxplot(len ~ dose, add = TRUE, boxwex = 0.25, at = 1:3 + 0.2,
+ col = "orange"))
+legend(2, 9, c("Ascorbic acid", "Orange juice"),
+ fill = c("yellow", "orange"))
+
+
+
+cleanEx()
+nameEx("withVisible")
+### * withVisible
+
+flush(stderr()); flush(stdout())
+
+### Name: withVisible
+### Title: Return both a Value and its Visibility
+### Aliases: withVisible
+### Keywords: programming
+
+### ** Examples
+
+x <- 1
+withVisible(x <- 1) # *$visible is FALSE
+x
+withVisible(x) # *$visible is TRUE
+
+# Wrap the call in evalq() for special handling
+
+df <- data.frame(a = 1:5, b = 1:5)
+evalq(withVisible(a + b), envir = df)
+
+
+
+cleanEx()
+nameEx("write")
+### * write
+
+flush(stderr()); flush(stdout())
+
+### Name: write
+### Title: Write Data to a File
+### Aliases: write
+### Keywords: file connection
+
+### ** Examples
+
+# create a 2 by 5 matrix
+x <- matrix(1:10, ncol = 5)
+
+# the file data contains x, two rows, five cols
+# 1 3 5 7 9 will form the first row
+write(t(x))
+
+# Writing to the "console" 'tab-delimited'
+# two rows, five cols but the first row is 1 2 3 4 5
+write(x, "", sep = "\t")
+unlink("data") # tidy up
+
+
+
+cleanEx()
+nameEx("zMachine")
+### * zMachine
+
+flush(stderr()); flush(stdout())
+
+### Name: .Machine
+### Title: Numerical Characteristics of the Machine
+### Aliases: .Machine
+### Keywords: sysdata programming math
+
+### ** Examples
+
+.Machine
+## or for a neat printout
+noquote(unlist(format(.Machine)))
+
+
+
+cleanEx()
+nameEx("zapsmall")
+### * zapsmall
+
+flush(stderr()); flush(stdout())
+
+### Name: zapsmall
+### Title: Rounding of Numbers
+### Aliases: zapsmall
+### Keywords: arith
+
+### ** Examples
+
+x2 <- pi * 100^(-1:3)
+print(x2 / 1000, digits = 4)
+zapsmall(x2 / 1000, digits = 4)
+
+zapsmall(exp(1i*0:4*pi/2))
+
+
+
+cleanEx()
+nameEx("zpackages")
+### * zpackages
+
+flush(stderr()); flush(stdout())
+
+### Name: zpackages
+### Title: Listing of Packages
+### Aliases: .packages
+### Keywords: data
+
+### ** Examples
+
+(.packages()) # maybe just "base"
+.packages(all.available = TRUE) # return all available as character vector
+require(splines)
+(.packages()) # "splines", too
+detach("package:splines")
+
+
+
+### * <FOOTER>
+###
+options(digits = 7L)
+base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n")
+#grDevices::dev.off()
+###
+### Local variables: ***
+### mode: outline-minor ***
+### outline-regexp: "\\(> \\)?### [*]+" ***
+### End: ***
+quit('no')
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/Examples/example-1_def.R b/com.oracle.truffle.r.native/gnur/tests/src/Examples/example-1_def.R
new file mode 100644
index 0000000000000000000000000000000000000000..6fbbf48cd8b928c11707abac654bf2dfb6e53b83
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/Examples/example-1_def.R
@@ -0,0 +1,23 @@
+### R code from vignette source '/s/a/k/fastr/library/utils/Sweave/example-1.Rnw'
+
+###################################################
+### code chunk number 1: example-1.Rnw:13-16
+###################################################
+data(airquality, package="datasets")
+library("stats")
+kruskal.test(Ozone ~ Month, data = airquality)
+
+
+###################################################
+### code chunk number 2: boxp (eval = FALSE)
+###################################################
+## boxplot(Ozone ~ Month, data = airquality)
+
+
+###################################################
+### code chunk number 3: example-1.Rnw:27-29
+###################################################
+library("graphics")
+boxplot(Ozone ~ Month, data = airquality)
+
+
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/Examples/example-1_myA-noF.R b/com.oracle.truffle.r.native/gnur/tests/src/Examples/example-1_myA-noF.R
new file mode 100644
index 0000000000000000000000000000000000000000..4121a94b198fd9a3d7aee883f0623952bed541cb
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/Examples/example-1_myA-noF.R
@@ -0,0 +1,13 @@
+### R code from vignette source '/s/a/k/fastr/library/utils/Sweave/example-1.Rnw'
+
+### chunk #1: example-1.Rnw:13-16
+data(airquality, package="datasets")
+library("stats")
+kruskal.test(Ozone ~ Month, data = airquality)
+
+
+### chunk #3: example-1.Rnw:27-29
+library("graphics")
+boxplot(Ozone ~ Month, data = airquality)
+
+
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/Examples/example-1_myA.R b/com.oracle.truffle.r.native/gnur/tests/src/Examples/example-1_myA.R
new file mode 100644
index 0000000000000000000000000000000000000000..405b4d9e1a97533f52290d31398b5d44920cdce6
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/Examples/example-1_myA.R
@@ -0,0 +1,17 @@
+### R code from vignette source '/s/a/k/fastr/library/utils/Sweave/example-1.Rnw'
+
+### chunk #1: example-1.Rnw:13-16
+data(airquality, package="datasets")
+library("stats")
+kruskal.test(Ozone ~ Month, data = airquality)
+
+
+### chunk #2: boxp (eval = FALSE)
+## boxplot(Ozone ~ Month, data = airquality)
+
+
+### chunk #3: example-1.Rnw:27-29
+library("graphics")
+boxplot(Ozone ~ Month, data = airquality)
+
+
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/Examples/grDevices-Ex.R b/com.oracle.truffle.r.native/gnur/tests/src/Examples/grDevices-Ex.R
new file mode 100644
index 0000000000000000000000000000000000000000..b3b94be9b86feb99f1d94cd9be0ae61264c552b5
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/Examples/grDevices-Ex.R
@@ -0,0 +1,1609 @@
+pkgname <- "grDevices"
+source(file.path(R.home("share"), "R", "examples-header.R"))
+options(warn = 1)
+library('grDevices')
+
+base::assign(".oldSearch", base::search(), pos = 'CheckExEnv')
+cleanEx()
+nameEx("Devices")
+### * Devices
+
+flush(stderr()); flush(stdout())
+
+### Name: Devices
+### Title: List of Graphical Devices
+### Aliases: Devices device
+### Keywords: device
+
+### ** Examples
+## Not run:
+##D ## open the default screen device on this platform if no device is
+##D ## open
+##D if(dev.cur() == 1) dev.new()
+## End(Not run)
+
+
+cleanEx()
+nameEx("Hershey")
+### * Hershey
+
+flush(stderr()); flush(stdout())
+
+### Name: Hershey
+### Title: Hershey Vector Fonts in R
+### Aliases: Hershey
+### Keywords: aplot
+
+### ** Examples
+
+Hershey
+
+## for tables of examples, see demo(Hershey)
+
+
+
+cleanEx()
+nameEx("Japanese")
+### * Japanese
+
+flush(stderr()); flush(stdout())
+
+### Name: Japanese
+### Title: Japanese characters in R
+### Aliases: Japanese
+### Keywords: aplot
+
+### ** Examples
+
+require(graphics)
+
+plot(1:9, type = "n", axes = FALSE, frame = TRUE, ylab = "",
+ main = "example(Japanese)", xlab = "using Hershey fonts")
+par(cex = 3)
+Vf <- c("serif", "plain")
+text(4, 2, "\\#J244b\\#J245b\\#J2473", vfont = Vf)
+text(4, 4, "\\#J2538\\#J2563\\#J2551\\#J2573", vfont = Vf)
+text(4, 6, "\\#J467c\\#J4b5c", vfont = Vf)
+text(4, 8, "Japan", vfont = Vf)
+par(cex = 1)
+text(8, 2, "Hiragana")
+text(8, 4, "Katakana")
+text(8, 6, "Kanji")
+text(8, 8, "English")
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("Type1Font")
+### * Type1Font
+
+flush(stderr()); flush(stdout())
+
+### Name: Type1Font
+### Title: Type 1 and CID Fonts
+### Aliases: Type1Font CIDFont
+### Keywords: device
+
+### ** Examples
+
+## This duplicates "ComputerModernItalic".
+CMitalic <- Type1Font("ComputerModern2",
+ c("CM_regular_10.afm", "CM_boldx_10.afm",
+ "cmti10.afm", "cmbxti10.afm",
+ "CM_symbol_10.afm"),
+ encoding = "TeXtext.enc")
+
+## Not run:
+##D ## This could be used by
+##D postscript(family = CMitalic)
+##D ## or
+##D postscriptFonts(CMitalic = CMitalic) # once in a session
+##D postscript(family = "CMitalic", encoding = "TeXtext.enc")
+## End(Not run)
+
+
+cleanEx()
+nameEx("adjustcolor")
+### * adjustcolor
+
+flush(stderr()); flush(stdout())
+
+### Name: adjustcolor
+### Title: Adjust Colors in One or More Directions Conveniently.
+### Aliases: adjustcolor
+
+### ** Examples
+
+## Illustrative examples :
+opal <- palette("default")
+stopifnot(identical(adjustcolor(1:8, 0.75),
+ adjustcolor(palette(), 0.75)))
+cbind(palette(), adjustcolor(1:8, 0.75))
+
+## alpha = 1/2 * previous alpha --> opaque colors
+x <- palette(adjustcolor(palette(), 0.5))
+
+sines <- outer(1:20, 1:4, function(x, y) sin(x / 20 * pi * y))
+matplot(sines, type = "b", pch = 21:23, col = 2:5, bg = 2:5,
+ main = "Using an 'opaque ('translucent') color palette")
+
+x. <- adjustcolor(x, offset = c(0.5, 0.5, 0.5, 0), # <- "more white"
+ transform = diag(c(.7, .7, .7, 0.6)))
+cbind(x, x.)
+op <- par(bg = adjustcolor("goldenrod", offset = -rep(.4, 4)), xpd = NA)
+plot(0:9, 0:9, type = "n", axes = FALSE, xlab = "", ylab = "",
+ main = "adjustcolor() -> translucent")
+text(1:8, labels = paste0(x,"++"), col = x., cex = 8)
+par(op)
+
+## and
+
+(M <- cbind( rbind( matrix(1/3, 3, 3), 0), c(0, 0, 0, 1)))
+adjustcolor(x, transform = M)
+
+## revert to previous palette: active
+palette(opal)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("as.raster")
+### * as.raster
+
+flush(stderr()); flush(stdout())
+
+### Name: as.raster
+### Title: Create a Raster Object
+### Aliases: is.raster as.raster as.raster.logical as.raster.numeric
+### as.raster.raw as.raster.character as.raster.matrix as.raster.array
+### Keywords: dplot
+
+### ** Examples
+
+# A red gradient
+as.raster(matrix(hcl(0, 80, seq(50, 80, 10)),
+ nrow = 4, ncol = 5))
+
+# Vectors are 1-column matrices ...
+# character vectors are color names ...
+as.raster(hcl(0, 80, seq(50, 80, 10)))
+# numeric vectors are greyscale ...
+as.raster(1:5, max = 5)
+# logical vectors are black and white ...
+as.raster(1:10 %% 2 == 0)
+
+# ... unless nrow/ncol are supplied ...
+as.raster(1:10 %% 2 == 0, nrow = 1)
+
+# Matrix can also be logical or numeric (or raw) ...
+as.raster(matrix(c(TRUE, FALSE), nrow = 3, ncol = 2))
+as.raster(matrix(1:3/4, nrow = 3, ncol = 4))
+
+# An array can be 3-plane numeric (R, G, B planes) ...
+as.raster(array(c(0:1, rep(0.5, 4)), c(2, 1, 3)))
+
+# ... or 4-plane numeric (R, G, B, A planes)
+as.raster(array(c(0:1, rep(0.5, 6)), c(2, 1, 4)))
+
+# subsetting
+r <- as.raster(matrix(colors()[1:100], ncol = 10))
+r[, 2]
+r[2:4, 2:5]
+
+# assigning to subset
+r[2:4, 2:5] <- "white"
+
+# comparison
+r == "white"
+
+## Don't show:
+stopifnot(r[] == r,
+ identical(r[3:5], colors()[3:5]))
+r[2:4] <- "black"
+stopifnot(identical(r[1:4, 1], as.raster(c("white", rep("black", 3)))))
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("axisTicks")
+### * axisTicks
+
+flush(stderr()); flush(stdout())
+
+### Name: axisTicks
+### Title: Compute Pretty Axis Tick Scales
+### Aliases: axisTicks .axisPars
+### Keywords: dplot
+
+### ** Examples
+
+##--- Demonstrating correspondence between graphics'
+##--- axis() and the graphics-engine agnostic axisTicks() :
+
+require("graphics")
+plot(10*(0:10)); (pu <- par("usr"))
+aX <- function(side, at, ...)
+ axis(side, at = at, labels = FALSE, lwd.ticks = 2, col.ticks = 2,
+ tck = 0.05, ...)
+aX(1, print(xa <- axisTicks(pu[1:2], log = FALSE))) # x axis
+aX(2, print(ya <- axisTicks(pu[3:4], log = FALSE))) # y axis
+
+axisTicks(pu[3:4], log = FALSE, n = 10)
+
+plot(10*(0:10), log = "y"); (pu <- par("usr"))
+aX(2, print(ya <- axisTicks(pu[3:4], log = TRUE))) # y axis
+
+plot(2^(0:9), log = "y"); (pu <- par("usr"))
+aX(2, print(ya <- axisTicks(pu[3:4], log = TRUE))) # y axis
+
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("boxplot.stats")
+### * boxplot.stats
+
+flush(stderr()); flush(stdout())
+
+### Name: boxplot.stats
+### Title: Box Plot Statistics
+### Aliases: boxplot.stats
+### Keywords: dplot
+
+### ** Examples
+
+require(stats)
+x <- c(1:100, 1000)
+(b1 <- boxplot.stats(x))
+(b2 <- boxplot.stats(x, do.conf = FALSE, do.out = FALSE))
+stopifnot(b1 $ stats == b2 $ stats) # do.out = FALSE is still robust
+boxplot.stats(x, coef = 3, do.conf = FALSE)
+## no outlier treatment:
+boxplot.stats(x, coef = 0)
+
+boxplot.stats(c(x, NA)) # slight change : n is 101
+(r <- boxplot.stats(c(x, -1:1/0)))
+stopifnot(r$out == c(1000, -Inf, Inf))
+
+## Don't show:
+ ## Difference between quartiles and hinges :
+ nn <- 1:17 ; n4 <- nn %% 4
+ hin <- sapply(sapply(nn, seq), function(x) boxplot.stats(x)$stats[c(2,4)])
+ q13 <- sapply(sapply(nn, seq), quantile, probs = c(1,3)/4, names = FALSE)
+ m <- t(rbind(q13,hin))[, c(1,3,2,4)]
+ dimnames(m) <- list(paste(nn), c("q1","lH", "q3","uH"))
+ stopifnot(m[n4 == 1, 1:2] == (nn[n4 == 1] + 3)/4, # quart. = hinge
+ m[n4 == 1, 3:4] == (3*nn[n4 == 1] + 1)/4,
+ m[,"lH"] == ( (nn+3) %/% 2) / 2,
+ m[,"uH"] == ((3*nn+2)%/% 2) / 2)
+ cm <- noquote(format(m))
+ cm[m[,2] == m[,1], 2] <- " = "
+ cm[m[,4] == m[,3], 4] <- " = "
+ cm
+## End(Don't show)
+
+
+
+
+cleanEx()
+nameEx("check.options")
+### * check.options
+
+flush(stderr()); flush(stdout())
+
+### Name: check.options
+### Title: Set Options with Consistency Checks
+### Aliases: check.options
+### Keywords: utilities programming
+
+### ** Examples
+
+(L1 <- list(a = 1:3, b = pi, ch = "CH"))
+check.options(list(a = 0:2), name.opt = "L1")
+check.options(NULL, reset = TRUE, name.opt = "L1")
+
+
+
+cleanEx()
+nameEx("chull")
+### * chull
+
+flush(stderr()); flush(stdout())
+
+### Name: chull
+### Title: Compute Convex Hull of a Set of Points
+### Aliases: chull
+### Keywords: graphs
+
+### ** Examples
+
+X <- matrix(stats::rnorm(2000), ncol = 2)
+chull(X)
+## Not run:
+##D # Example usage from graphics package
+##D plot(X, cex = 0.5)
+##D hpts <- chull(X)
+##D hpts <- c(hpts, hpts[1])
+##D lines(X[hpts, ])
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("cm")
+### * cm
+
+flush(stderr()); flush(stdout())
+
+### Name: cm
+### Title: Unit Transformation
+### Aliases: cm
+### Keywords: dplot
+
+### ** Examples
+
+cm(1) # = 2.54
+
+## Translate *from* cm *to* inches:
+
+10 / cm(1) # -> 10cm are 3.937 inches
+
+
+
+cleanEx()
+nameEx("col2rgb")
+### * col2rgb
+
+flush(stderr()); flush(stdout())
+
+### Name: col2rgb
+### Title: Color to RGB Conversion
+### Aliases: col2rgb
+### Keywords: color dplot
+
+### ** Examples
+
+col2rgb("peachpuff")
+col2rgb(c(blu = "royalblue", reddish = "tomato")) # note: colnames
+
+col2rgb(1:8) # the ones from the palette() (if the default)
+
+col2rgb(paste0("gold", 1:4))
+
+col2rgb("#08a0ff")
+## all three kinds of color specifications:
+col2rgb(c(red = "red", hex = "#abcdef"))
+col2rgb(c(palette = 1:3))
+
+##-- NON-INTRODUCTORY examples --
+
+grC <- col2rgb(paste0("gray", 0:100))
+table(print(diff(grC["red",]))) # '2' or '3': almost equidistant
+## The 'named' grays are in between {"slate gray" is not gray, strictly}
+col2rgb(c(g66 = "gray66", darkg = "dark gray", g67 = "gray67",
+ g74 = "gray74", gray = "gray", g75 = "gray75",
+ g82 = "gray82", light = "light gray", g83 = "gray83"))
+
+crgb <- col2rgb(cc <- colors())
+colnames(crgb) <- cc
+t(crgb) # The whole table
+
+ccodes <- c(256^(2:0) %*% crgb) # = internal codes
+## How many names are 'aliases' of each other:
+table(tcc <- table(ccodes))
+length(uc <- unique(sort(ccodes))) # 502
+## All the multiply named colors:
+mult <- uc[tcc >= 2]
+cl <- lapply(mult, function(m) cc[ccodes == m])
+names(cl) <- apply(col2rgb(sapply(cl, function(x)x[1])),
+ 2, function(n)paste(n, collapse = ","))
+utils::str(cl)
+## Not run:
+##D if(require(xgobi)) { ## Look at the color cube dynamically :
+##D tc <- t(crgb[, !duplicated(ccodes)])
+##D table(is.gray <- tc[,1] == tc[,2] & tc[,2] == tc[,3]) # (397, 105)
+##D xgobi(tc, color = c("gold", "gray")[1 + is.gray])
+##D }
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("colorRamp")
+### * colorRamp
+
+flush(stderr()); flush(stdout())
+
+### Name: colorRamp
+### Title: Color interpolation
+### Aliases: colorRamp colorRampPalette
+### Keywords: color
+
+### ** Examples
+
+## Both return a *function* :
+colorRamp(c("red", "green"))( (0:4)/4 ) ## (x) , x in [0,1]
+colorRampPalette(c("blue", "red"))( 4 ) ## (n)
+## a ramp in opacity of blue values
+colorRampPalette(c(rgb(0,0,1,1), rgb(0,0,1,0)), alpha = TRUE)(8)
+
+require(graphics)
+
+## Here space="rgb" gives palettes that vary only in saturation,
+## as intended.
+## With space="Lab" the steps are more uniform, but the hues
+## are slightly purple.
+filled.contour(volcano,
+ color.palette =
+ colorRampPalette(c("red", "white", "blue")),
+ asp = 1)
+filled.contour(volcano,
+ color.palette =
+ colorRampPalette(c("red", "white", "blue"),
+ space = "Lab"),
+ asp = 1)
+
+## Interpolating a 'sequential' ColorBrewer palette
+YlOrBr <- c("#FFFFD4", "#FED98E", "#FE9929", "#D95F0E", "#993404")
+filled.contour(volcano,
+ color.palette = colorRampPalette(YlOrBr, space = "Lab"),
+ asp = 1)
+filled.contour(volcano,
+ color.palette = colorRampPalette(YlOrBr, space = "Lab",
+ bias = 0.5),
+ asp = 1)
+
+## 'jet.colors' is "as in Matlab"
+## (and hurting the eyes by over-saturation)
+jet.colors <-
+ colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan",
+ "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000"))
+filled.contour(volcano, color = jet.colors, asp = 1)
+
+## space="Lab" helps when colors don't form a natural sequence
+m <- outer(1:20,1:20,function(x,y) sin(sqrt(x*y)/3))
+rgb.palette <- colorRampPalette(c("red", "orange", "blue"),
+ space = "rgb")
+Lab.palette <- colorRampPalette(c("red", "orange", "blue"),
+ space = "Lab")
+filled.contour(m, col = rgb.palette(20))
+filled.contour(m, col = Lab.palette(20))
+
+
+
+cleanEx()
+nameEx("colors")
+### * colors
+
+flush(stderr()); flush(stdout())
+
+### Name: colors
+### Title: Color Names
+### Aliases: colors colours
+### Keywords: color dplot sysdata
+
+### ** Examples
+
+cl <- colors()
+length(cl); cl[1:20]
+
+length(cl. <- colors(TRUE))
+## only 502 of the 657 named ones
+
+## ----------- Show all named colors and more:
+demo("colors")
+## -----------
+
+
+
+cleanEx()
+nameEx("contourLines")
+### * contourLines
+
+flush(stderr()); flush(stdout())
+
+### Name: contourLines
+### Title: Calculate Contour Lines
+### Aliases: contourLines
+### Keywords: dplot
+
+### ** Examples
+
+x <- 10*1:nrow(volcano)
+y <- 10*1:ncol(volcano)
+contourLines(x, y, volcano)
+
+
+
+cleanEx()
+nameEx("convertColor")
+### * convertColor
+
+flush(stderr()); flush(stdout())
+
+### Name: convertColor
+### Title: Convert between Colour Spaces
+### Aliases: convertColor colorspaces
+### Keywords: color
+
+### ** Examples
+
+## The displayable colors from four planes of Lab space
+ab <- expand.grid(a = (-10:15)*10,
+ b = (-15:10)*10)
+require(graphics); require(stats) # for na.omit
+par(mfrow = c(2, 2), mar = .1+c(3, 3, 3, .5), mgp = c(2, .8, 0))
+
+Lab <- cbind(L = 20, ab)
+srgb <- convertColor(Lab, from = "Lab", to = "sRGB", clip = NA)
+clipped <- attr(na.omit(srgb), "na.action")
+srgb[clipped, ] <- 0
+cols <- rgb(srgb[, 1], srgb[, 2], srgb[, 3])
+image((-10:15)*10, (-15:10)*10, matrix(1:(26*26), ncol = 26), col = cols,
+ xlab = "a", ylab = "b", main = "Lab: L=20")
+
+Lab <- cbind(L = 40, ab)
+srgb <- convertColor(Lab, from = "Lab", to = "sRGB", clip = NA)
+clipped <- attr(na.omit(srgb), "na.action")
+srgb[clipped, ] <- 0
+cols <- rgb(srgb[, 1], srgb[, 2], srgb[, 3])
+image((-10:15)*10, (-15:10)*10, matrix(1:(26*26), ncol = 26), col = cols,
+ xlab = "a", ylab = "b", main = "Lab: L=40")
+
+Lab <- cbind(L = 60, ab)
+srgb <- convertColor(Lab, from = "Lab", to = "sRGB", clip = NA)
+clipped <- attr(na.omit(srgb), "na.action")
+srgb[clipped, ] <- 0
+cols <- rgb(srgb[, 1], srgb[, 2], srgb[, 3])
+image((-10:15)*10, (-15:10)*10, matrix(1:(26*26), ncol = 26), col = cols,
+ xlab = "a", ylab = "b", main = "Lab: L=60")
+
+Lab <- cbind(L = 80, ab)
+srgb <- convertColor(Lab, from = "Lab", to = "sRGB", clip = NA)
+clipped <- attr(na.omit(srgb), "na.action")
+srgb[clipped, ] <- 0
+cols <- rgb(srgb[, 1], srgb[, 2], srgb[, 3])
+image((-10:15)*10, (-15:10)*10, matrix(1:(26*26), ncol = 26), col = cols,
+ xlab = "a", ylab = "b", main = "Lab: L=80")
+
+cols <- t(col2rgb(palette())); rownames(cols) <- palette(); cols
+zapsmall(lab <- convertColor(cols, from = "sRGB", to = "Lab", scale.in = 255))
+stopifnot(all.equal(cols, # converting back.. getting the original:
+ round(convertColor(lab, from = "Lab", to = "sRGB", scale.out = 255)),
+ check.attributes = FALSE))
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("densCols")
+### * densCols
+
+flush(stderr()); flush(stdout())
+
+### Name: densCols
+### Title: Colors for Smooth Density Plots
+### Aliases: densCols blues9
+### Keywords: dplot
+
+### ** Examples
+
+
+cleanEx()
+nameEx("dev")
+### * dev
+
+flush(stderr()); flush(stdout())
+
+### Name: dev
+### Title: Control Multiple Devices
+### Aliases: dev.cur dev.list dev.next dev.prev dev.off dev.set dev.new
+### graphics.off
+### Keywords: device iplot
+
+### ** Examples
+
+## Not run:
+##D ## Unix-specific example
+##D x11()
+##D plot(1:10)
+##D x11()
+##D plot(rnorm(10))
+##D dev.set(dev.prev())
+##D abline(0, 1) # through the 1:10 points
+##D dev.set(dev.next())
+##D abline(h = 0, col = "gray") # for the residual plot
+##D dev.set(dev.prev())
+##D dev.off(); dev.off() #- close the two X devices
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("dev.capabilities")
+### * dev.capabilities
+
+flush(stderr()); flush(stdout())
+
+### Name: dev.capabilities
+### Title: Query Capabilities of the Current Graphics Device
+### Aliases: dev.capabilities
+### Keywords: dplot
+
+### ** Examples
+
+dev.capabilities()
+
+
+
+cleanEx()
+nameEx("dev.interactive")
+### * dev.interactive
+
+flush(stderr()); flush(stdout())
+
+### Name: dev.interactive
+### Title: Is the Current Graphics Device Interactive?
+### Aliases: dev.interactive deviceIsInteractive
+### Keywords: device
+
+### ** Examples
+
+dev.interactive()
+print(deviceIsInteractive(NULL))
+
+
+
+cleanEx()
+nameEx("dev.size")
+### * dev.size
+
+flush(stderr()); flush(stdout())
+
+### Name: dev.size
+### Title: Find Size of Device Surface
+### Aliases: dev.size
+### Keywords: dplot
+
+### ** Examples
+
+dev.size("cm")
+
+
+
+cleanEx()
+nameEx("dev2")
+### * dev2
+
+flush(stderr()); flush(stdout())
+
+### Name: dev2
+### Title: Copy Graphics Between Multiple Devices
+### Aliases: dev.copy dev.print dev.copy2eps dev.copy2pdf dev.control
+### Keywords: device
+
+### ** Examples
+
+## Not run:
+##D x11() # on a Unix-alike
+##D plot(rnorm(10), main = "Plot 1")
+##D dev.copy(device = x11)
+##D mtext("Copy 1", 3)
+##D dev.print(width = 6, height = 6, horizontal = FALSE) # prints it
+##D dev.off(dev.prev())
+##D dev.off()
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("extendrange")
+### * extendrange
+
+flush(stderr()); flush(stdout())
+
+### Name: extendrange
+### Title: Extend a Numerical Range by a Small Percentage
+### Aliases: extendrange
+### Keywords: dplot
+
+### ** Examples
+
+x <- 1:5
+(r <- range(x)) # 1 5
+extendrange(x) # 0.8 5.2
+extendrange(x, f= 0.01) # 0.96 5.04
+## Use 'r' if you have it already:
+stopifnot(identical(extendrange(r = r),
+ extendrange(x)))
+
+
+
+cleanEx()
+nameEx("getGraphicsEvent")
+### * getGraphicsEvent
+
+flush(stderr()); flush(stdout())
+
+### Name: getGraphicsEvent
+### Title: Wait for a mouse or keyboard event from a graphics window
+### Aliases: getGraphicsEvent setGraphicsEventHandlers getGraphicsEventEnv
+### setGraphicsEventEnv
+### Keywords: iplot
+
+### ** Examples
+
+# This currently only works on the Windows, X11(type = "Xlib"), and
+# X11(type = "cairo") screen devices...
+## Not run:
+##D savepar <- par(ask = FALSE)
+##D dragplot <- function(..., xlim = NULL, ylim = NULL, xaxs = "r", yaxs = "r") {
+##D plot(..., xlim = xlim, ylim = ylim, xaxs = xaxs, yaxs = yaxs)
+##D startx <- NULL
+##D starty <- NULL
+##D prevx <- NULL
+##D prevy <- NULL
+##D usr <- NULL
+##D
+##D devset <- function()
+##D if (dev.cur() != eventEnv$which) dev.set(eventEnv$which)
+##D
+##D dragmousedown <- function(buttons, x, y) {
+##D startx <<- x
+##D starty <<- y
+##D prevx <<- 0
+##D prevy <<- 0
+##D devset()
+##D usr <<- par("usr")
+##D eventEnv$onMouseMove <- dragmousemove
+##D NULL
+##D }
+##D
+##D dragmousemove <- function(buttons, x, y) {
+##D devset()
+##D deltax <- diff(grconvertX(c(startx, x), "ndc", "user"))
+##D deltay <- diff(grconvertY(c(starty, y), "ndc", "user"))
+##D if (abs(deltax-prevx) + abs(deltay-prevy) > 0) {
+##D plot(..., xlim = usr[1:2]-deltax, xaxs = "i",
+##D ylim = usr[3:4]-deltay, yaxs = "i")
+##D prevx <<- deltax
+##D prevy <<- deltay
+##D }
+##D NULL
+##D }
+##D
+##D mouseup <- function(buttons, x, y) {
+##D eventEnv$onMouseMove <- NULL
+##D }
+##D
+##D keydown <- function(key) {
+##D if (key == "q") return(invisible(1))
+##D eventEnv$onMouseMove <- NULL
+##D NULL
+##D }
+##D
+##D setGraphicsEventHandlers(prompt = "Click and drag, hit q to quit",
+##D onMouseDown = dragmousedown,
+##D onMouseUp = mouseup,
+##D onKeybd = keydown)
+##D eventEnv <- getGraphicsEventEnv()
+##D }
+##D
+##D dragplot(rnorm(1000), rnorm(1000))
+##D getGraphicsEvent()
+##D par(savepar)
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("grSoftVersion")
+### * grSoftVersion
+
+flush(stderr()); flush(stdout())
+
+### Name: grSoftVersion
+### Title: Report Versions of Graphics Software
+### Aliases: grSoftVersion
+
+### ** Examples
+
+
+
+
+cleanEx()
+nameEx("gray")
+### * gray
+
+flush(stderr()); flush(stdout())
+
+### Name: gray
+### Title: Gray Level Specification
+### Aliases: gray grey
+### Keywords: color
+
+### ** Examples
+
+gray(0:8 / 8)
+
+
+
+cleanEx()
+nameEx("gray.colors")
+### * gray.colors
+
+flush(stderr()); flush(stdout())
+
+### Name: gray.colors
+### Title: Gray Color Palette
+### Aliases: gray.colors grey.colors
+### Keywords: color
+
+### ** Examples
+
+require(graphics)
+
+pie(rep(1, 12), col = gray.colors(12))
+barplot(1:12, col = gray.colors(12))
+
+
+
+cleanEx()
+nameEx("hcl")
+### * hcl
+
+flush(stderr()); flush(stdout())
+
+### Name: hcl
+### Title: HCL Color Specification
+### Aliases: hcl
+### Keywords: color dplot
+
+### ** Examples
+
+require(graphics)
+
+# The Foley and Van Dam PhD Data.
+csd <- matrix(c( 4,2,4,6, 4,3,1,4, 4,7,7,1,
+ 0,7,3,2, 4,5,3,2, 5,4,2,2,
+ 3,1,3,0, 4,4,6,7, 1,10,8,7,
+ 1,5,3,2, 1,5,2,1, 4,1,4,3,
+ 0,3,0,6, 2,1,5,5), nrow = 4)
+
+csphd <- function(colors)
+ barplot(csd, col = colors, ylim = c(0,30),
+ names = 72:85, xlab = "Year", ylab = "Students",
+ legend = c("Winter", "Spring", "Summer", "Fall"),
+ main = "Computer Science PhD Graduates", las = 1)
+
+# The Original (Metaphorical) Colors (Ouch!)
+csphd(c("blue", "green", "yellow", "orange"))
+
+# A Color Tetrad (Maximal Color Differences)
+csphd(hcl(h = c(30, 120, 210, 300)))
+
+# Same, but lighter and less colorful
+# Turn off automatic correction to make sure
+# that we have defined real colors.
+csphd(hcl(h = c(30, 120, 210, 300),
+ c = 20, l = 90, fixup = FALSE))
+
+# Analogous Colors
+# Good for those with red/green color confusion
+csphd(hcl(h = seq(60, 240, by = 60)))
+
+# Metaphorical Colors
+csphd(hcl(h = seq(210, 60, length = 4)))
+
+# Cool Colors
+csphd(hcl(h = seq(120, 0, length = 4) + 150))
+
+# Warm Colors
+csphd(hcl(h = seq(120, 0, length = 4) - 30))
+
+# Single Color
+hist(stats::rnorm(1000), col = hcl(240))
+
+## Exploring the hcl() color space {in its mapping to R's sRGB colors}:
+demo(hclColors)
+
+
+
+
+cleanEx()
+nameEx("hsv")
+### * hsv
+
+flush(stderr()); flush(stdout())
+
+### Name: hsv
+### Title: HSV Color Specification
+### Aliases: hsv
+### Keywords: color dplot
+
+### ** Examples
+
+require(graphics)
+
+hsv(.5,.5,.5)
+
+## Red tones:
+n <- 20; y <- -sin(3*pi*((1:n)-1/2)/n)
+op <- par(mar = rep(1.5, 4))
+plot(y, axes = FALSE, frame.plot = TRUE,
+ xlab = "", ylab = "", pch = 21, cex = 30,
+ bg = rainbow(n, start = .85, end = .1),
+ main = "Red tones")
+par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("make.rgb")
+### * make.rgb
+
+flush(stderr()); flush(stdout())
+
+### Name: make.rgb
+### Title: Create colour spaces
+### Aliases: make.rgb colorConverter
+### Keywords: color
+
+### ** Examples
+
+(pal <- make.rgb(red = c(0.6400, 0.3300),
+ green = c(0.2900, 0.6000),
+ blue = c(0.1500, 0.0600),
+ name = "PAL/SECAM RGB"))
+
+## converter for sRGB in #rrggbb format
+hexcolor <- colorConverter(toXYZ = function(hex, ...) {
+ rgb <- t(col2rgb(hex))/255
+ colorspaces$sRGB$toXYZ(rgb, ...) },
+ fromXYZ = function(xyz, ...) {
+ rgb <- colorspaces$sRGB$fromXYZ(xyz, ..)
+ rgb <- round(rgb, 5)
+ if (min(rgb) < 0 || max(rgb) > 1)
+ as.character(NA)
+ else rgb(rgb[1], rgb[2], rgb[3])},
+ white = "D65", name = "#rrggbb")
+
+(cols <- t(col2rgb(palette())))
+zapsmall(luv <- convertColor(cols, from = "sRGB", to = "Luv", scale.in = 255))
+(hex <- convertColor(luv, from = "Luv", to = hexcolor, scale.out = NULL))
+
+## must make hex a matrix before using it
+(cc <- round(convertColor(as.matrix(hex), from = hexcolor, to = "sRGB",
+ scale.in = NULL, scale.out = 255)))
+stopifnot(cc == cols)
+
+
+
+cleanEx()
+nameEx("n2mfrow")
+### * n2mfrow
+
+flush(stderr()); flush(stdout())
+
+### Name: n2mfrow
+### Title: Compute Default mfrow From Number of Plots
+### Aliases: n2mfrow
+### Keywords: dplot utilities
+
+### ** Examples
+
+require(graphics)
+
+n2mfrow(8) # 3 x 3
+
+n <- 5 ; x <- seq(-2, 2, len = 51)
+## suppose now that 'n' is not known {inside function}
+op <- par(mfrow = n2mfrow(n))
+for (j in 1:n)
+ plot(x, x^j, main = substitute(x^ exp, list(exp = j)), type = "l",
+ col = "blue")
+
+sapply(1:10, n2mfrow)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("nclass")
+### * nclass
+
+flush(stderr()); flush(stdout())
+
+### Name: nclass
+### Title: Compute the Number of Classes for a Histogram
+### Aliases: nclass.Sturges nclass.scott nclass.FD
+### Keywords: univar
+
+### ** Examples
+
+set.seed(1)
+x <- stats::rnorm(1111)
+nclass.Sturges(x)
+
+## Compare them:
+NC <- function(x) c(Sturges = nclass.Sturges(x),
+ Scott = nclass.scott(x), FD = nclass.FD(x))
+NC(x)
+onePt <- rep(1, 11)
+NC(onePt) # no longer gives NaN
+
+
+
+cleanEx()
+nameEx("palette")
+### * palette
+
+flush(stderr()); flush(stdout())
+
+### Name: palette
+### Title: Set or View the Graphics Palette
+### Aliases: palette
+### Keywords: color sysdata
+
+### ** Examples
+
+require(graphics)
+
+palette() # obtain the current palette
+palette(rainbow(6)) # six color rainbow
+
+(palette(gray(seq(0,.9,len = 25)))) # gray scales; print old palette
+matplot(outer(1:100, 1:30), type = "l", lty = 1,lwd = 2, col = 1:30,
+ main = "Gray Scales Palette",
+ sub = "palette(gray(seq(0, .9, len=25)))")
+palette("default") # reset back to the default
+
+## on a device where alpha-transparency is supported,
+## use 'alpha = 0.3' transparency with the default palette :
+mycols <- adjustcolor(palette(), alpha.f = 0.3)
+opal <- palette(mycols)
+x <- rnorm(1000); xy <- cbind(x, 3*x + rnorm(1000))
+plot (xy, lwd = 2,
+ main = "Alpha-Transparency Palette\n alpha = 0.3")
+xy[,1] <- -xy[,1]
+points(xy, col = 8, pch = 16, cex = 1.5)
+palette("default")
+
+
+
+cleanEx()
+nameEx("palettes")
+### * palettes
+
+flush(stderr()); flush(stdout())
+
+### Name: Palettes
+### Title: Color Palettes
+### Aliases: rainbow heat.colors terrain.colors topo.colors cm.colors
+### Keywords: color dplot
+
+### ** Examples
+
+require(graphics)
+# A Color Wheel
+pie(rep(1, 12), col = rainbow(12))
+
+##------ Some palettes ------------
+demo.pal <-
+ function(n, border = if (n < 32) "light gray" else NA,
+ main = paste("color palettes; n=", n),
+ ch.col = c("rainbow(n, start=.7, end=.1)", "heat.colors(n)",
+ "terrain.colors(n)", "topo.colors(n)",
+ "cm.colors(n)"))
+{
+ nt <- length(ch.col)
+ i <- 1:n; j <- n / nt; d <- j/6; dy <- 2*d
+ plot(i, i+d, type = "n", yaxt = "n", ylab = "", main = main)
+ for (k in 1:nt) {
+ rect(i-.5, (k-1)*j+ dy, i+.4, k*j,
+ col = eval(parse(text = ch.col[k])), border = border)
+ text(2*j, k * j + dy/4, ch.col[k])
+ }
+}
+n <- if(.Device == "postscript") 64 else 16
+ # Since for screen, larger n may give color allocation problem
+demo.pal(n)
+
+
+
+cleanEx()
+nameEx("pdf")
+### * pdf
+
+flush(stderr()); flush(stdout())
+
+### Name: pdf
+### Title: PDF Graphics Device
+### Aliases: pdf
+### Keywords: device
+
+### ** Examples
+
+
+
+cleanEx()
+nameEx("pdf.options")
+### * pdf.options
+
+flush(stderr()); flush(stdout())
+
+### Name: pdf.options
+### Title: Auxiliary Function to Set/View Defaults for Arguments of pdf
+### Aliases: pdf.options
+### Keywords: device
+
+### ** Examples
+
+pdf.options(bg = "pink")
+utils::str(pdf.options())
+pdf.options(reset = TRUE) # back to factory-fresh
+
+
+
+cleanEx()
+nameEx("pictex")
+### * pictex
+
+flush(stderr()); flush(stdout())
+
+### Name: pictex
+### Title: A PicTeX Graphics Driver
+### Aliases: pictex
+### Keywords: device
+
+### ** Examples
+
+require(graphics)
+
+pictex()
+plot(1:11, (-5:5)^2, type = "b", main = "Simple Example Plot")
+dev.off()
+##--------------------
+## Not run:
+##D %% LaTeX Example
+##D \documentclass{article}
+##D \usepackage{pictex}
+##D \usepackage{graphics} % for \rotatebox
+##D \begin{document}
+##D %...
+##D \begin{figure}[h]
+##D \centerline{\input{Rplots.tex}}
+##D \caption{}
+##D \end{figure}
+##D %...
+##D \end{document}
+## End(Not run)
+##--------------------
+unlink("Rplots.tex")
+
+
+
+cleanEx()
+nameEx("plotmath")
+### * plotmath
+
+flush(stderr()); flush(stdout())
+
+### Name: plotmath
+### Title: Mathematical Annotation in R
+### Aliases: plotmath symbol plain bold italic bolditalic hat bar dot ring
+### widehat widetilde displaystyle textstyle scriptstyle
+### scriptscriptstyle underline phantom over frac atop integral inf sup
+### group bgroup
+### Keywords: aplot
+
+### ** Examples
+
+require(graphics)
+
+x <- seq(-4, 4, len = 101)
+y <- cbind(sin(x), cos(x))
+matplot(x, y, type = "l", xaxt = "n",
+ main = expression(paste(plain(sin) * phi, " and ",
+ plain(cos) * phi)),
+ ylab = expression("sin" * phi, "cos" * phi), # only 1st is taken
+ xlab = expression(paste("Phase Angle ", phi)),
+ col.main = "blue")
+axis(1, at = c(-pi, -pi/2, 0, pi/2, pi),
+ labels = expression(-pi, -pi/2, 0, pi/2, pi))
+
+
+## How to combine "math" and numeric variables :
+plot(1:10, type="n", xlab="", ylab="", main = "plot math & numbers")
+theta <- 1.23 ; mtext(bquote(hat(theta) == .(theta)), line= .25)
+for(i in 2:9)
+ text(i, i+1, substitute(list(xi, eta) == group("(",list(x,y),")"),
+ list(x = i, y = i+1)))
+## note that both of these use calls rather than expressions.
+##
+text(1, 10, "Derivatives:", adj = 0)
+text(1, 9.6, expression(
+ " first: {f * minute}(x) " == {f * minute}(x)), adj = 0)
+text(1, 9.0, expression(
+ " second: {f * second}(x) " == {f * second}(x)), adj = 0)
+
+
+plot(1:10, 1:10)
+text(4, 9, expression(hat(beta) == (X^t * X)^{-1} * X^t * y))
+text(4, 8.4, "expression(hat(beta) == (X^t * X)^{-1} * X^t * y)",
+ cex = .8)
+text(4, 7, expression(bar(x) == sum(frac(x[i], n), i==1, n)))
+text(4, 6.4, "expression(bar(x) == sum(frac(x[i], n), i==1, n))",
+ cex = .8)
+text(8, 5, expression(paste(frac(1, sigma*sqrt(2*pi)), " ",
+ plain(e)^{frac(-(x-mu)^2, 2*sigma^2)})),
+ cex = 1.2)
+
+## some other useful symbols
+plot.new(); plot.window(c(0,4), c(15,1))
+text(1, 1, "universal", adj = 0); text(2.5, 1, "\\042")
+text(3, 1, expression(symbol("\042")))
+text(1, 2, "existential", adj = 0); text(2.5, 2, "\\044")
+text(3, 2, expression(symbol("\044")))
+text(1, 3, "suchthat", adj = 0); text(2.5, 3, "\\047")
+text(3, 3, expression(symbol("\047")))
+text(1, 4, "therefore", adj = 0); text(2.5, 4, "\\134")
+text(3, 4, expression(symbol("\134")))
+text(1, 5, "perpendicular", adj = 0); text(2.5, 5, "\\136")
+text(3, 5, expression(symbol("\136")))
+text(1, 6, "circlemultiply", adj = 0); text(2.5, 6, "\\304")
+text(3, 6, expression(symbol("\304")))
+text(1, 7, "circleplus", adj = 0); text(2.5, 7, "\\305")
+text(3, 7, expression(symbol("\305")))
+text(1, 8, "emptyset", adj = 0); text(2.5, 8, "\\306")
+text(3, 8, expression(symbol("\306")))
+text(1, 9, "angle", adj = 0); text(2.5, 9, "\\320")
+text(3, 9, expression(symbol("\320")))
+text(1, 10, "leftangle", adj = 0); text(2.5, 10, "\\341")
+text(3, 10, expression(symbol("\341")))
+text(1, 11, "rightangle", adj = 0); text(2.5, 11, "\\361")
+text(3, 11, expression(symbol("\361")))
+
+
+
+cleanEx()
+nameEx("postscriptFonts")
+### * postscriptFonts
+
+flush(stderr()); flush(stdout())
+
+### Name: postscriptFonts
+### Title: PostScript and PDF Font Families
+### Aliases: postscriptFonts pdfFonts
+### Keywords: device
+
+### ** Examples
+
+postscriptFonts()
+## This duplicates "ComputerModernItalic".
+CMitalic <- Type1Font("ComputerModern2",
+ c("CM_regular_10.afm", "CM_boldx_10.afm",
+ "cmti10.afm", "cmbxti10.afm",
+ "CM_symbol_10.afm"),
+ encoding = "TeXtext.enc")
+postscriptFonts(CMitalic = CMitalic)
+
+## A CID font for Japanese using a different CMap and
+## corresponding cmapEncoding.
+`Jp_UCS-2` <- CIDFont("TestUCS2",
+ c("Adobe-Japan1-UniJIS-UCS2-H.afm",
+ "Adobe-Japan1-UniJIS-UCS2-H.afm",
+ "Adobe-Japan1-UniJIS-UCS2-H.afm",
+ "Adobe-Japan1-UniJIS-UCS2-H.afm"),
+ "UniJIS-UCS2-H", "UCS-2")
+pdfFonts(`Jp_UCS-2` = `Jp_UCS-2`)
+names(pdfFonts())
+
+
+
+cleanEx()
+nameEx("pretty.Date")
+### * pretty.Date
+
+flush(stderr()); flush(stdout())
+
+### Name: pretty.Date
+### Title: Pretty Breakpoints for Date-Time Classes
+### Aliases: pretty.Date pretty.POSIXt
+### Keywords: dplot
+
+### ** Examples
+
+pretty(as.Date("2000-03-01")) # R 1.0.0 came in a leap year
+
+## time ranges in diverse scales:% also in ../../../../tests/reg-tests-1c.R
+require(stats)
+steps <- setNames(,
+ c("10 secs", "1 min", "5 mins", "30 mins", "6 hours", "12 hours",
+ "1 DSTday", "2 weeks", "1 month", "6 months", "1 year",
+ "10 years", "50 years", "1000 years"))
+x <- as.POSIXct("2002-02-02 02:02")
+lapply(steps,
+ function(s) {
+ at <- pretty(seq(x, by = s, length = 2), n = 5)
+ attr(at, "labels")
+ })
+
+
+
+cleanEx()
+nameEx("ps.options")
+### * ps.options
+
+flush(stderr()); flush(stdout())
+
+### Name: ps.options
+### Title: Auxiliary Function to Set/View Defaults for Arguments of
+### postscript
+### Aliases: ps.options setEPS setPS
+### Keywords: device
+
+### ** Examples
+
+ps.options(bg = "pink")
+utils::str(ps.options())
+
+### ---- error checking of arguments: ----
+ps.options(width = 0:12, onefile = 0, bg = pi)
+# override the check for 'width', but not 'bg':
+ps.options(width = 0:12, bg = pi, override.check = c(TRUE,FALSE))
+utils::str(ps.options())
+ps.options(reset = TRUE) # back to factory-fresh
+
+
+
+cleanEx()
+nameEx("recordGraphics")
+### * recordGraphics
+
+flush(stderr()); flush(stdout())
+
+### Name: recordGraphics
+### Title: Record Graphics Operations
+### Aliases: recordGraphics
+### Keywords: device
+
+### ** Examples
+
+require(graphics)
+
+plot(1:10)
+# This rectangle remains 1inch wide when the device is resized
+recordGraphics(
+ {
+ rect(4, 2,
+ 4 + diff(par("usr")[1:2])/par("pin")[1], 3)
+ },
+ list(),
+ getNamespace("graphics"))
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("rgb")
+### * rgb
+
+flush(stderr()); flush(stdout())
+
+### Name: rgb
+### Title: RGB Color Specification
+### Aliases: rgb
+### Keywords: color
+
+### ** Examples
+
+rgb(0, 1, 0)
+
+rgb((0:15)/15, green = 0, blue = 0, names = paste("red", 0:15, sep = "."))
+
+rgb(0, 0:12, 0, max = 255) # integer input
+
+ramp <- colorRamp(c("red", "white"))
+rgb( ramp(seq(0, 1, length = 5)), max = 255)
+
+
+
+cleanEx()
+nameEx("rgb2hsv")
+### * rgb2hsv
+
+flush(stderr()); flush(stdout())
+
+### Name: rgb2hsv
+### Title: RGB to HSV Conversion
+### Aliases: rgb2hsv
+### Keywords: color dplot
+
+### ** Examples
+
+## These (saturated, bright ones) only differ by hue
+(rc <- col2rgb(c("red", "yellow","green","cyan", "blue", "magenta")))
+(hc <- rgb2hsv(rc))
+6 * hc["h",] # the hues are equispaced
+
+## Don't show:
+set.seed(151)
+## End(Don't show)
+(rgb3 <- floor(256 * matrix(stats::runif(3*12), 3, 12)))
+(hsv3 <- rgb2hsv(rgb3))
+## Consistency :
+stopifnot(rgb3 == col2rgb(hsv(h = hsv3[1,], s = hsv3[2,], v = hsv3[3,])),
+ all.equal(hsv3, rgb2hsv(rgb3/255, maxColorValue = 1)))
+
+## A (simplified) pure R version -- originally by Wolfram Fischer --
+## showing the exact algorithm:
+rgb2hsvR <- function(rgb, gamma = 1, maxColorValue = 255)
+{
+ if(!is.numeric(rgb)) stop("rgb matrix must be numeric")
+ d <- dim(rgb)
+ if(d[1] != 3) stop("rgb matrix must have 3 rows")
+ n <- d[2]
+ if(n == 0) return(cbind(c(h = 1, s = 1, v = 1))[,0])
+ rgb <- rgb/maxColorValue
+ if(gamma != 1) rgb <- rgb ^ (1/gamma)
+
+ ## get the max and min
+ v <- apply( rgb, 2, max)
+ s <- apply( rgb, 2, min)
+ D <- v - s # range
+
+ ## set hue to zero for undefined values (gray has no hue)
+ h <- numeric(n)
+ notgray <- ( s != v )
+
+ ## blue hue
+ idx <- (v == rgb[3,] & notgray )
+ if (any (idx))
+ h[idx] <- 2/3 + 1/6 * (rgb[1,idx] - rgb[2,idx]) / D[idx]
+ ## green hue
+ idx <- (v == rgb[2,] & notgray )
+ if (any (idx))
+ h[idx] <- 1/3 + 1/6 * (rgb[3,idx] - rgb[1,idx]) / D[idx]
+ ## red hue
+ idx <- (v == rgb[1,] & notgray )
+ if (any (idx))
+ h[idx] <- 1/6 * (rgb[2,idx] - rgb[3,idx]) / D[idx]
+
+ ## correct for negative red
+ idx <- (h < 0)
+ h[idx] <- 1+h[idx]
+
+ ## set the saturation
+ s[! notgray] <- 0;
+ s[notgray] <- 1 - s[notgray] / v[notgray]
+
+ rbind( h = h, s = s, v = v )
+}
+
+## confirm the equivalence:
+all.equal(rgb2hsv (rgb3),
+ rgb2hsvR(rgb3), tolerance = 1e-14) # TRUE
+
+
+
+cleanEx()
+nameEx("trans3d")
+### * trans3d
+
+flush(stderr()); flush(stdout())
+
+### Name: trans3d
+### Title: 3D to 2D Transformation for Perspective Plots
+### Aliases: trans3d
+### Keywords: dplot
+
+### ** Examples
+
+## See help(persp) {after attaching the 'graphics' package}
+## -----------
+
+
+
+cleanEx()
+nameEx("xy.coords")
+### * xy.coords
+
+flush(stderr()); flush(stdout())
+
+### Name: xy.coords
+### Title: Extracting Plotting Structures
+### Aliases: xy.coords
+### Keywords: dplot
+
+### ** Examples
+
+ff <- stats::fft(1:9)
+xy.coords(ff)
+xy.coords(ff, xlab = "fft") # labels "Re(fft)", "Im(fft)"
+## Don't show:
+stopifnot(identical(xy.coords(ff, xlab = "fft"),
+ xy.coords(ff, ylab = "fft")))
+xy.labs <- function(...) xy.coords(...)[c("xlab","ylab")]
+stopifnot(identical(xy.labs(ff, xlab = "fft", setLab = FALSE),
+ list(xlab = "fft", ylab = "fft")),
+ identical(xy.labs(ff, ylab = "fft", setLab = FALSE),
+ list(xlab = NULL, ylab = "fft")),
+ identical(xy.labs(ff, xlab = "Re(fft)", ylab = "Im(fft)", setLab = FALSE),
+ list(xlab = "Re(fft)", ylab = "Im(fft)")))
+## End(Don't show)
+with(cars, xy.coords(dist ~ speed, NULL)$xlab ) # = "speed"
+
+xy.coords(1:3, 1:2, recycle = TRUE) # otherwise error "lengths differ"
+xy.coords(-2:10, log = "y")
+##> xlab: "Index" \\ warning: 3 y values <= 0 omitted ..
+
+
+
+cleanEx()
+nameEx("xyTable")
+### * xyTable
+
+flush(stderr()); flush(stdout())
+
+### Name: xyTable
+### Title: Multiplicities of (x,y) Points, e.g., for a Sunflower Plot
+### Aliases: xyTable
+### Keywords: dplot
+
+### ** Examples
+
+xyTable(iris[, 3:4], digits = 6)
+
+## Discretized uncorrelated Gaussian:
+## Don't show:
+set.seed(1)
+## End(Don't show)
+require(stats)
+xy <- data.frame(x = round(sort(rnorm(100))), y = rnorm(100))
+xyTable(xy, digits = 1)
+
+
+
+cleanEx()
+nameEx("xyz.coords")
+### * xyz.coords
+
+flush(stderr()); flush(stdout())
+
+### Name: xyz.coords
+### Title: Extracting Plotting Structures
+### Aliases: xyz.coords
+### Keywords: dplot
+
+### ** Examples
+
+xyz.coords(data.frame(10*1:9, -4), y = NULL, z = NULL)
+
+xyz.coords(1:5, stats::fft(1:5), z = NULL, xlab = "X", ylab = "Y")
+
+y <- 2 * (x2 <- 10 + (x1 <- 1:10))
+xyz.coords(y ~ x1 + x2, y = NULL, z = NULL)
+
+xyz.coords(data.frame(x = -1:9, y = 2:12, z = 3:13), y = NULL, z = NULL,
+ log = "xy")
+##> Warning message: 2 x values <= 0 omitted ...
+
+
+
+### * <FOOTER>
+###
+options(digits = 7L)
+base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n")
+#grDevices::dev.off()
+###
+### Local variables: ***
+### mode: outline-minor ***
+### outline-regexp: "\\(> \\)?### [*]+" ***
+### End: ***
+quit('no')
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/Examples/graphics-Ex.R b/com.oracle.truffle.r.native/gnur/tests/src/Examples/graphics-Ex.R
new file mode 100644
index 0000000000000000000000000000000000000000..8569b769f756e4d576c6d29cc9a03a2aa2a1b96d
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/Examples/graphics-Ex.R
@@ -0,0 +1,2696 @@
+pkgname <- "graphics"
+source(file.path(R.home("share"), "R", "examples-header.R"))
+options(warn = 1)
+library('graphics')
+
+base::assign(".oldSearch", base::search(), pos = 'CheckExEnv')
+cleanEx()
+nameEx("abline")
+### * abline
+
+flush(stderr()); flush(stdout())
+
+### Name: abline
+### Title: Add Straight Lines to a Plot
+### Aliases: abline
+### Keywords: aplot
+
+### ** Examples
+
+## Setup up coordinate system (with x == y aspect ratio):
+plot(c(-2,3), c(-1,5), type = "n", xlab = "x", ylab = "y", asp = 1)
+## the x- and y-axis, and an integer grid
+abline(h = 0, v = 0, col = "gray60")
+text(1,0, "abline( h = 0 )", col = "gray60", adj = c(0, -.1))
+abline(h = -1:5, v = -2:3, col = "lightgray", lty = 3)
+abline(a = 1, b = 2, col = 2)
+text(1,3, "abline( 1, 2 )", col = 2, adj = c(-.1, -.1))
+
+## Simple Regression Lines:
+require(stats)
+sale5 <- c(6, 4, 9, 7, 6, 12, 8, 10, 9, 13)
+plot(sale5)
+abline(lsfit(1:10, sale5))
+abline(lsfit(1:10, sale5, intercept = FALSE), col = 4) # less fitting
+
+z <- lm(dist ~ speed, data = cars)
+plot(cars)
+abline(z) # equivalent to abline(reg = z) or
+abline(coef = coef(z))
+
+## trivial intercept model
+abline(mC <- lm(dist ~ 1, data = cars)) ## the same as
+abline(a = coef(mC), b = 0, col = "blue")
+
+
+
+cleanEx()
+nameEx("arrows")
+### * arrows
+
+flush(stderr()); flush(stdout())
+
+### Name: arrows
+### Title: Add Arrows to a Plot
+### Aliases: arrows
+### Keywords: aplot
+
+### ** Examples
+
+x <- stats::runif(12); y <- stats::rnorm(12)
+i <- order(x, y); x <- x[i]; y <- y[i]
+plot(x,y, main = "arrows(.) and segments(.)")
+## draw arrows from point to point :
+s <- seq(length(x)-1) # one shorter than data
+arrows(x[s], y[s], x[s+1], y[s+1], col = 1:3)
+s <- s[-length(s)]
+segments(x[s], y[s], x[s+2], y[s+2], col = "pink")
+
+
+
+cleanEx()
+nameEx("assocplot")
+### * assocplot
+
+flush(stderr()); flush(stdout())
+
+### Name: assocplot
+### Title: Association Plots
+### Aliases: assocplot
+### Keywords: hplot
+
+### ** Examples
+
+## Aggregate over sex:
+x <- margin.table(HairEyeColor, c(1, 2))
+x
+assocplot(x, main = "Relation between hair and eye color")
+
+
+
+cleanEx()
+nameEx("axTicks")
+### * axTicks
+
+flush(stderr()); flush(stdout())
+
+### Name: axTicks
+### Title: Compute Axis Tickmark Locations
+### Aliases: axTicks
+### Keywords: dplot
+
+### ** Examples
+
+ plot(1:7, 10*21:27)
+ axTicks(1)
+ axTicks(2)
+ stopifnot(identical(axTicks(1), axTicks(3)),
+ identical(axTicks(2), axTicks(4)))
+
+## Show how axTicks() and axis() correspond :
+op <- par(mfrow = c(3, 1))
+for(x in 9999 * c(1, 2, 8)) {
+ plot(x, 9, log = "x")
+ cat(formatC(par("xaxp"), width = 5),";", T <- axTicks(1),"\n")
+ rug(T, col = adjustcolor("red", 0.5), lwd = 4)
+}
+par(op)
+
+x <- 9.9*10^(-3:10)
+plot(x, 1:14, log = "x")
+axTicks(1) # now length 5, in R <= 2.13.x gave the following
+axTicks(1, nintLog = Inf) # rather too many
+
+## An example using axTicks() without reference to an existing plot
+## (copying R's internal procedures for setting axis ranges etc.),
+## You do need to supply _all_ of axp, usr, log, nintLog
+## standard logarithmic y axis labels
+ylims <- c(0.2, 88)
+get_axp <- function(x) 10^c(ceiling(x[1]), floor(x[2]))
+## mimic par("yaxs") == "i"
+usr.i <- log10(ylims)
+(aT.i <- axTicks(side = 2, usr = usr.i,
+ axp = c(get_axp(usr.i), n = 3), log = TRUE, nintLog = 5))
+## mimic (default) par("yaxs") == "r"
+usr.r <- extendrange(r = log10(ylims), f = 0.04)
+(aT.r <- axTicks(side = 2, usr = usr.r,
+ axp = c(get_axp(usr.r), 3), log = TRUE, nintLog = 5))
+
+## Prove that we got it right :
+plot(0:1, ylims, log = "y", yaxs = "i")
+stopifnot(all.equal(aT.i, axTicks(side = 2)))
+
+plot(0:1, ylims, log = "y", yaxs = "r")
+stopifnot(all.equal(aT.r, axTicks(side = 2)))
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("axis.POSIXct")
+### * axis.POSIXct
+
+flush(stderr()); flush(stdout())
+
+### Name: axis.POSIXct
+### Title: Date and Date-time Plotting Functions
+### Aliases: axis.POSIXct axis.Date
+### Keywords: utilities chron
+
+### ** Examples
+
+with(beaver1, {
+time <- strptime(paste(1990, day, time %/% 100, time %% 100),
+ "%Y %j %H %M")
+plot(time, temp, type = "l") # axis at 4-hour intervals.
+# now label every hour on the time axis
+plot(time, temp, type = "l", xaxt = "n")
+r <- as.POSIXct(round(range(time), "hours"))
+axis.POSIXct(1, at = seq(r[1], r[2], by = "hour"), format = "%H")
+})
+
+plot(.leap.seconds, seq_along(.leap.seconds), type = "n", yaxt = "n",
+ xlab = "leap seconds", ylab = "", bty = "n")
+rug(.leap.seconds)
+## or as dates
+lps <- as.Date(.leap.seconds)
+plot(lps, seq_along(.leap.seconds),
+ type = "n", yaxt = "n", xlab = "leap seconds",
+ ylab = "", bty = "n")
+rug(lps)
+
+## 100 random dates in a 10-week period
+random.dates <- as.Date("2001/1/1") + 70*sort(stats::runif(100))
+plot(random.dates, 1:100)
+# or for a better axis labelling
+plot(random.dates, 1:100, xaxt = "n")
+axis.Date(1, at = seq(as.Date("2001/1/1"), max(random.dates)+6, "weeks"))
+axis.Date(1, at = seq(as.Date("2001/1/1"), max(random.dates)+6, "days"),
+ labels = FALSE, tcl = -0.2)
+
+
+
+cleanEx()
+nameEx("axis")
+### * axis
+
+flush(stderr()); flush(stdout())
+
+### Name: axis
+### Title: Add an Axis to a Plot
+### Aliases: axis
+### Keywords: aplot
+
+### ** Examples
+
+require(stats) # for rnorm
+plot(1:4, rnorm(4), axes = FALSE)
+axis(1, 1:4, LETTERS[1:4])
+axis(2)
+box() #- to make it look "as usual"
+
+plot(1:7, rnorm(7), main = "axis() examples",
+ type = "s", xaxt = "n", frame = FALSE, col = "red")
+axis(1, 1:7, LETTERS[1:7], col.axis = "blue")
+# unusual options:
+axis(4, col = "violet", col.axis = "dark violet", lwd = 2)
+axis(3, col = "gold", lty = 2, lwd = 0.5)
+
+# one way to have a custom x axis
+plot(1:10, xaxt = "n")
+axis(1, xaxp = c(2, 9, 7))
+
+
+
+cleanEx()
+nameEx("barplot")
+### * barplot
+
+flush(stderr()); flush(stdout())
+
+### Name: barplot
+### Title: Bar Plots
+### Aliases: barplot barplot.default
+### Keywords: hplot
+
+### ** Examples
+
+require(grDevices) # for colours
+tN <- table(Ni <- stats::rpois(100, lambda = 5))
+r <- barplot(tN, col = rainbow(20))
+#- type = "h" plotting *is* 'bar'plot
+lines(r, tN, type = "h", col = "red", lwd = 2)
+
+barplot(tN, space = 1.5, axisnames = FALSE,
+ sub = "barplot(..., space= 1.5, axisnames = FALSE)")
+
+barplot(VADeaths, plot = FALSE)
+barplot(VADeaths, plot = FALSE, beside = TRUE)
+
+mp <- barplot(VADeaths) # default
+tot <- colMeans(VADeaths)
+text(mp, tot + 3, format(tot), xpd = TRUE, col = "blue")
+barplot(VADeaths, beside = TRUE,
+ col = c("lightblue", "mistyrose", "lightcyan",
+ "lavender", "cornsilk"),
+ legend = rownames(VADeaths), ylim = c(0, 100))
+title(main = "Death Rates in Virginia", font.main = 4)
+
+hh <- t(VADeaths)[, 5:1]
+mybarcol <- "gray20"
+mp <- barplot(hh, beside = TRUE,
+ col = c("lightblue", "mistyrose",
+ "lightcyan", "lavender"),
+ legend = colnames(VADeaths), ylim = c(0,100),
+ main = "Death Rates in Virginia", font.main = 4,
+ sub = "Faked upper 2*sigma error bars", col.sub = mybarcol,
+ cex.names = 1.5)
+segments(mp, hh, mp, hh + 2*sqrt(1000*hh/100), col = mybarcol, lwd = 1.5)
+stopifnot(dim(mp) == dim(hh)) # corresponding matrices
+mtext(side = 1, at = colMeans(mp), line = -2,
+ text = paste("Mean", formatC(colMeans(hh))), col = "red")
+
+# Bar shading example
+barplot(VADeaths, angle = 15+10*1:5, density = 20, col = "black",
+ legend = rownames(VADeaths))
+title(main = list("Death Rates in Virginia", font = 4))
+
+# border :
+barplot(VADeaths, border = "dark blue")
+
+# log scales (not much sense here):
+barplot(tN, col = heat.colors(12), log = "y")
+barplot(tN, col = gray.colors(20), log = "xy")
+
+# args.legend
+barplot(height = cbind(x = c(465, 91) / 465 * 100,
+ y = c(840, 200) / 840 * 100,
+ z = c(37, 17) / 37 * 100),
+ beside = FALSE,
+ width = c(465, 840, 37),
+ col = c(1, 2),
+ legend.text = c("A", "B"),
+ args.legend = list(x = "topleft"))
+
+
+
+cleanEx()
+nameEx("box")
+### * box
+
+flush(stderr()); flush(stdout())
+
+### Name: box
+### Title: Draw a Box around a Plot
+### Aliases: box
+### Keywords: aplot
+
+### ** Examples
+
+plot(1:7, abs(stats::rnorm(7)), type = "h", axes = FALSE)
+axis(1, at = 1:7, labels = letters[1:7])
+box(lty = '1373', col = 'red')
+
+
+
+cleanEx()
+nameEx("boxplot")
+### * boxplot
+
+flush(stderr()); flush(stdout())
+
+### Name: boxplot
+### Title: Box Plots
+### Aliases: boxplot boxplot.default boxplot.formula
+### Keywords: hplot
+
+### ** Examples
+
+## boxplot on a formula:
+boxplot(count ~ spray, data = InsectSprays, col = "lightgray")
+# *add* notches (somewhat funny here):
+boxplot(count ~ spray, data = InsectSprays,
+ notch = TRUE, add = TRUE, col = "blue")
+
+boxplot(decrease ~ treatment, data = OrchardSprays,
+ log = "y", col = "bisque")
+
+rb <- boxplot(decrease ~ treatment, data = OrchardSprays, col = "bisque")
+title("Comparing boxplot()s and non-robust mean +/- SD")
+
+mn.t <- tapply(OrchardSprays$decrease, OrchardSprays$treatment, mean)
+sd.t <- tapply(OrchardSprays$decrease, OrchardSprays$treatment, sd)
+xi <- 0.3 + seq(rb$n)
+points(xi, mn.t, col = "orange", pch = 18)
+arrows(xi, mn.t - sd.t, xi, mn.t + sd.t,
+ code = 3, col = "pink", angle = 75, length = .1)
+
+## boxplot on a matrix:
+mat <- cbind(Uni05 = (1:100)/21, Norm = rnorm(100),
+ `5T` = rt(100, df = 5), Gam2 = rgamma(100, shape = 2))
+boxplot(mat) # directly, calling boxplot.matrix()
+
+## boxplot on a data frame:
+df. <- as.data.frame(mat)
+par(las = 1) # all axis labels horizontal
+boxplot(df., main = "boxplot(*, horizontal = TRUE)", horizontal = TRUE)
+
+## Using 'at = ' and adding boxplots -- example idea by Roger Bivand :
+boxplot(len ~ dose, data = ToothGrowth,
+ boxwex = 0.25, at = 1:3 - 0.2,
+ subset = supp == "VC", col = "yellow",
+ main = "Guinea Pigs' Tooth Growth",
+ xlab = "Vitamin C dose mg",
+ ylab = "tooth length",
+ xlim = c(0.5, 3.5), ylim = c(0, 35), yaxs = "i")
+boxplot(len ~ dose, data = ToothGrowth, add = TRUE,
+ boxwex = 0.25, at = 1:3 + 0.2,
+ subset = supp == "OJ", col = "orange")
+legend(2, 9, c("Ascorbic acid", "Orange juice"),
+ fill = c("yellow", "orange"))
+
+## With less effort (slightly different) using factor *interaction*:
+boxplot(len ~ dose:supp, data = ToothGrowth,
+ boxwex = 0.5, col = c("orange", "yellow"),
+ main = "Guinea Pigs' Tooth Growth",
+ xlab = "Vitamin C dose mg", ylab = "tooth length",
+ sep = ":", lex.order = TRUE, ylim = c(0, 35), yaxs = "i")
+
+## more examples in help(bxp)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("boxplot.matrix")
+### * boxplot.matrix
+
+flush(stderr()); flush(stdout())
+
+### Name: boxplot.matrix
+### Title: Draw a Boxplot for each Column (Row) of a Matrix
+### Aliases: boxplot.matrix
+### Keywords: hplot
+
+### ** Examples
+
+## Very similar to the example in ?boxplot
+mat <- cbind(Uni05 = (1:100)/21, Norm = rnorm(100),
+ T5 = rt(100, df = 5), Gam2 = rgamma(100, shape = 2))
+boxplot(mat, main = "boxplot.matrix(...., main = ...)",
+ notch = TRUE, col = 1:4)
+
+
+
+cleanEx()
+nameEx("bxp")
+### * bxp
+
+flush(stderr()); flush(stdout())
+
+### Name: bxp
+### Title: Draw Box Plots from Summaries
+### Aliases: bxp
+### Keywords: aplot
+
+### ** Examples
+
+require(stats)
+set.seed(753)
+(bx.p <- boxplot(split(rt(100, 4), gl(5, 20))))
+op <- par(mfrow = c(2, 2))
+bxp(bx.p, xaxt = "n")
+bxp(bx.p, notch = TRUE, axes = FALSE, pch = 4, boxfill = 1:5)
+bxp(bx.p, notch = TRUE, boxfill = "lightblue", frame = FALSE,
+ outl = FALSE, main = "bxp(*, frame= FALSE, outl= FALSE)")
+bxp(bx.p, notch = TRUE, boxfill = "lightblue", border = 2:6,
+ ylim = c(-4,4), pch = 22, bg = "green", log = "x",
+ main = "... log = 'x', ylim = *")
+par(op)
+op <- par(mfrow = c(1, 2))
+
+## single group -- no label
+boxplot (weight ~ group, data = PlantGrowth, subset = group == "ctrl")
+## with label
+bx <- boxplot(weight ~ group, data = PlantGrowth,
+ subset = group == "ctrl", plot = FALSE)
+bxp(bx, show.names=TRUE)
+par(op)
+
+z <- split(rnorm(1000), rpois(1000, 2.2))
+boxplot(z, whisklty = 3, main = "boxplot(z, whisklty = 3)")
+
+## Colour support similar to plot.default:
+op <- par(mfrow = 1:2, bg = "light gray", fg = "midnight blue")
+boxplot(z, col.axis = "skyblue3", main = "boxplot(*, col.axis=..,main=..)")
+plot(z[[1]], col.axis = "skyblue3", main = "plot(*, col.axis=..,main=..)")
+mtext("par(bg=\"light gray\", fg=\"midnight blue\")",
+ outer = TRUE, line = -1.2)
+par(op)
+
+## Mimic S-Plus:
+splus <- list(boxwex = 0.4, staplewex = 1, outwex = 1, boxfill = "grey40",
+ medlwd = 3, medcol = "white", whisklty = 3, outlty = 1, outpch = NA)
+boxplot(z, pars = splus)
+## Recycled and "sweeping" parameters
+op <- par(mfrow = c(1,2))
+ boxplot(z, border = 1:5, lty = 3, medlty = 1, medlwd = 2.5)
+ boxplot(z, boxfill = 1:3, pch = 1:5, lwd = 1.5, medcol = "white")
+par(op)
+## too many possibilities
+boxplot(z, boxfill = "light gray", outpch = 21:25, outlty = 2,
+ bg = "pink", lwd = 2,
+ medcol = "dark blue", medcex = 2, medpch = 20)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("cdplot")
+### * cdplot
+
+flush(stderr()); flush(stdout())
+
+### Name: cdplot
+### Title: Conditional Density Plots
+### Aliases: cdplot cdplot.default cdplot.formula
+### Keywords: hplot
+
+### ** Examples
+
+## NASA space shuttle o-ring failures
+fail <- factor(c(2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 2, 1, 2, 1, 1, 1,
+ 1, 2, 1, 1, 1, 1, 1),
+ levels = 1:2, labels = c("no", "yes"))
+temperature <- c(53, 57, 58, 63, 66, 67, 67, 67, 68, 69, 70, 70,
+ 70, 70, 72, 73, 75, 75, 76, 76, 78, 79, 81)
+
+## CD plot
+cdplot(fail ~ temperature)
+cdplot(fail ~ temperature, bw = 2)
+cdplot(fail ~ temperature, bw = "SJ")
+
+## compare with spinogram
+(spineplot(fail ~ temperature, breaks = 3))
+
+## highlighting for failures
+cdplot(fail ~ temperature, ylevels = 2:1)
+
+## scatter plot with conditional density
+cdens <- cdplot(fail ~ temperature, plot = FALSE)
+plot(I(as.numeric(fail) - 1) ~ jitter(temperature, factor = 2),
+ xlab = "Temperature", ylab = "Conditional failure probability")
+lines(53:81, 1 - cdens[[1]](53:81), col = 2)
+
+
+
+cleanEx()
+nameEx("clip")
+### * clip
+
+flush(stderr()); flush(stdout())
+
+### Name: clip
+### Title: Set Clipping Region
+### Aliases: clip
+### Keywords: dplot
+
+### ** Examples
+
+x <- rnorm(1000)
+hist(x, xlim = c(-4,4))
+usr <- par("usr")
+clip(usr[1], -2, usr[3], usr[4])
+hist(x, col = 'red', add = TRUE)
+clip(2, usr[2], usr[3], usr[4])
+hist(x, col = 'blue', add = TRUE)
+do.call("clip", as.list(usr)) # reset to plot region
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("contour")
+### * contour
+
+flush(stderr()); flush(stdout())
+
+### Name: contour
+### Title: Display Contours
+### Aliases: contour contour.default
+### Keywords: hplot aplot
+
+### ** Examples
+
+require(grDevices) # for colours
+x <- -6:16
+op <- par(mfrow = c(2, 2))
+contour(outer(x, x), method = "edge", vfont = c("sans serif", "plain"))
+z <- outer(x, sqrt(abs(x)), FUN = "/")
+image(x, x, z)
+contour(x, x, z, col = "pink", add = TRUE, method = "edge",
+ vfont = c("sans serif", "plain"))
+contour(x, x, z, ylim = c(1, 6), method = "simple", labcex = 1,
+ xlab = quote(x[1]), ylab = quote(x[2]))
+contour(x, x, z, ylim = c(-6, 6), nlev = 20, lty = 2, method = "simple",
+ main = "20 levels; \"simple\" labelling method")
+par(op)
+
+## Persian Rug Art:
+x <- y <- seq(-4*pi, 4*pi, len = 27)
+r <- sqrt(outer(x^2, y^2, "+"))
+opar <- par(mfrow = c(2, 2), mar = rep(0, 4))
+for(f in pi^(0:3))
+ contour(cos(r^2)*exp(-r/f),
+ drawlabels = FALSE, axes = FALSE, frame = TRUE)
+
+rx <- range(x <- 10*1:nrow(volcano))
+ry <- range(y <- 10*1:ncol(volcano))
+ry <- ry + c(-1, 1) * (diff(rx) - diff(ry))/2
+tcol <- terrain.colors(12)
+par(opar); opar <- par(pty = "s", bg = "lightcyan")
+plot(x = 0, y = 0, type = "n", xlim = rx, ylim = ry, xlab = "", ylab = "")
+u <- par("usr")
+rect(u[1], u[3], u[2], u[4], col = tcol[8], border = "red")
+contour(x, y, volcano, col = tcol[2], lty = "solid", add = TRUE,
+ vfont = c("sans serif", "plain"))
+title("A Topographic Map of Maunga Whau", font = 4)
+abline(h = 200*0:4, v = 200*0:4, col = "lightgray", lty = 2, lwd = 0.1)
+
+## contourLines produces the same contour lines as contour
+plot(x = 0, y = 0, type = "n", xlim = rx, ylim = ry, xlab = "", ylab = "")
+u <- par("usr")
+rect(u[1], u[3], u[2], u[4], col = tcol[8], border = "red")
+contour(x, y, volcano, col = tcol[1], lty = "solid", add = TRUE,
+ vfont = c("sans serif", "plain"))
+line.list <- contourLines(x, y, volcano)
+invisible(lapply(line.list, lines, lwd=3, col=adjustcolor(2, .3)))
+par(opar)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("convertXY")
+### * convertXY
+
+flush(stderr()); flush(stdout())
+
+### Name: convertXY
+### Title: Convert between Graphics Coordinate Systems
+### Aliases: grconvertX grconvertY
+### Keywords: dplot
+
+### ** Examples
+
+op <- par(omd=c(0.1, 0.9, 0.1, 0.9), mfrow = c(1, 2))
+plot(1:4)
+for(tp in c("in", "dev", "ndc", "nfc", "npc", "nic"))
+ print(grconvertX(c(1.0, 4.0), "user", tp))
+par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("coplot")
+### * coplot
+
+flush(stderr()); flush(stdout())
+
+### Name: coplot
+### Title: Conditioning Plots
+### Aliases: coplot co.intervals
+### Keywords: hplot aplot
+
+### ** Examples
+
+## Tonga Trench Earthquakes
+coplot(lat ~ long | depth, data = quakes)
+given.depth <- co.intervals(quakes$depth, number = 4, overlap = .1)
+coplot(lat ~ long | depth, data = quakes, given.v = given.depth, rows = 1)
+
+## Conditioning on 2 variables:
+ll.dm <- lat ~ long | depth * mag
+coplot(ll.dm, data = quakes)
+coplot(ll.dm, data = quakes, number = c(4, 7), show.given = c(TRUE, FALSE))
+coplot(ll.dm, data = quakes, number = c(3, 7),
+ overlap = c(-.5, .1)) # negative overlap DROPS values
+
+## given two factors
+Index <- seq(length = nrow(warpbreaks)) # to get nicer default labels
+coplot(breaks ~ Index | wool * tension, data = warpbreaks,
+ show.given = 0:1)
+coplot(breaks ~ Index | wool * tension, data = warpbreaks,
+ col = "red", bg = "pink", pch = 21,
+ bar.bg = c(fac = "light blue"))
+
+## Example with empty panels:
+with(data.frame(state.x77), {
+coplot(Life.Exp ~ Income | Illiteracy * state.region, number = 3,
+ panel = function(x, y, ...) panel.smooth(x, y, span = .8, ...))
+## y ~ factor -- not really sensible, but 'show off':
+coplot(Life.Exp ~ state.region | Income * state.division,
+ panel = panel.smooth)
+})
+
+
+
+cleanEx()
+nameEx("curve")
+### * curve
+
+flush(stderr()); flush(stdout())
+
+### Name: curve
+### Title: Draw Function Plots
+### Aliases: curve plot.function
+### Keywords: hplot
+
+### ** Examples
+
+plot(qnorm) # default range c(0, 1) is appropriate here,
+ # but end values are -/+Inf and so are omitted.
+plot(qlogis, main = "The Inverse Logit : qlogis()")
+abline(h = 0, v = 0:2/2, lty = 3, col = "gray")
+
+curve(sin, -2*pi, 2*pi, xname = "t")
+curve(tan, xname = "t", add = NA,
+ main = "curve(tan) --> same x-scale as previous plot")
+
+op <- par(mfrow = c(2, 2))
+curve(x^3 - 3*x, -2, 2)
+curve(x^2 - 2, add = TRUE, col = "violet")
+
+## simple and advanced versions, quite similar:
+plot(cos, -pi, 3*pi)
+curve(cos, xlim = c(-pi, 3*pi), n = 1001, col = "blue", add = TRUE)
+
+chippy <- function(x) sin(cos(x)*exp(-x/2))
+curve(chippy, -8, 7, n = 2001)
+plot (chippy, -8, -5)
+
+for(ll in c("", "x", "y", "xy"))
+ curve(log(1+x), 1, 100, log = ll, sub = paste0("log = '", ll, "'"))
+par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("dotchart")
+### * dotchart
+
+flush(stderr()); flush(stdout())
+
+### Name: dotchart
+### Title: Cleveland's Dot Plots
+### Aliases: dotchart
+### Keywords: hplot
+
+### ** Examples
+
+dotchart(VADeaths, main = "Death Rates in Virginia - 1940")
+op <- par(xaxs = "i") # 0 -- 100%
+dotchart(t(VADeaths), xlim = c(0,100),
+ main = "Death Rates in Virginia - 1940")
+par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("filled.contour")
+### * filled.contour
+
+flush(stderr()); flush(stdout())
+
+### Name: filled.contour
+### Title: Level (Contour) Plots
+### Aliases: filled.contour .filled.contour
+### Keywords: hplot aplot
+
+### ** Examples
+
+require(grDevices) # for colours
+filled.contour(volcano, color = terrain.colors, asp = 1) # simple
+
+x <- 10*1:nrow(volcano)
+y <- 10*1:ncol(volcano)
+filled.contour(x, y, volcano, color = terrain.colors,
+ plot.title = title(main = "The Topography of Maunga Whau",
+ xlab = "Meters North", ylab = "Meters West"),
+ plot.axes = { axis(1, seq(100, 800, by = 100))
+ axis(2, seq(100, 600, by = 100)) },
+ key.title = title(main = "Height\n(meters)"),
+ key.axes = axis(4, seq(90, 190, by = 10))) # maybe also asp = 1
+mtext(paste("filled.contour(.) from", R.version.string),
+ side = 1, line = 4, adj = 1, cex = .66)
+
+# Annotating a filled contour plot
+a <- expand.grid(1:20, 1:20)
+b <- matrix(a[,1] + a[,2], 20)
+filled.contour(x = 1:20, y = 1:20, z = b,
+ plot.axes = { axis(1); axis(2); points(10, 10) })
+
+## Persian Rug Art:
+x <- y <- seq(-4*pi, 4*pi, len = 27)
+r <- sqrt(outer(x^2, y^2, "+"))
+filled.contour(cos(r^2)*exp(-r/(2*pi)), axes = FALSE)
+## rather, the key *should* be labeled:
+filled.contour(cos(r^2)*exp(-r/(2*pi)), frame.plot = FALSE,
+ plot.axes = {})
+
+
+
+cleanEx()
+nameEx("fourfoldplot")
+### * fourfoldplot
+
+flush(stderr()); flush(stdout())
+
+### Name: fourfoldplot
+### Title: Fourfold Plots
+### Aliases: fourfoldplot
+### Keywords: hplot
+
+### ** Examples
+
+## Use the Berkeley admission data as in Friendly (1995).
+x <- aperm(UCBAdmissions, c(2, 1, 3))
+dimnames(x)[[2]] <- c("Yes", "No")
+names(dimnames(x)) <- c("Sex", "Admit?", "Department")
+stats::ftable(x)
+
+## Fourfold display of data aggregated over departments, with
+## frequencies standardized to equate the margins for admission
+## and sex.
+## Figure 1 in Friendly (1994).
+fourfoldplot(margin.table(x, c(1, 2)))
+
+## Fourfold display of x, with frequencies in each table
+## standardized to equate the margins for admission and sex.
+## Figure 2 in Friendly (1994).
+fourfoldplot(x)
+
+## Fourfold display of x, with frequencies in each table
+## standardized to equate the margins for admission. but not
+## for sex.
+## Figure 3 in Friendly (1994).
+fourfoldplot(x, margin = 2)
+
+
+
+cleanEx()
+nameEx("grid")
+### * grid
+
+flush(stderr()); flush(stdout())
+
+### Name: grid
+### Title: Add Grid to a Plot
+### Aliases: grid
+### Keywords: aplot
+
+### ** Examples
+
+plot(1:3)
+grid(NA, 5, lwd = 2) # grid only in y-direction
+
+## maybe change the desired number of tick marks: par(lab = c(mx, my, 7))
+op <- par(mfcol = 1:2)
+with(iris,
+ {
+ plot(Sepal.Length, Sepal.Width, col = as.integer(Species),
+ xlim = c(4, 8), ylim = c(2, 4.5), panel.first = grid(),
+ main = "with(iris, plot(...., panel.first = grid(), ..) )")
+ plot(Sepal.Length, Sepal.Width, col = as.integer(Species),
+ panel.first = grid(3, lty = 1, lwd = 2),
+ main = "... panel.first = grid(3, lty = 1, lwd = 2), ..")
+ }
+ )
+par(op)
+
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("hist.POSIXt")
+### * hist.POSIXt
+
+flush(stderr()); flush(stdout())
+
+### Name: hist.POSIXt
+### Title: Histogram of a Date or Date-Time Object
+### Aliases: hist.POSIXt hist.Date
+### Keywords: chron dplot hplot
+
+### ** Examples
+
+hist(.leap.seconds, "years", freq = TRUE)
+hist(.leap.seconds,
+ seq(ISOdate(1970, 1, 1), ISOdate(2020, 1, 1), "5 years"))
+rug(.leap.seconds, lwd=2)
+
+## 100 random dates in a 10-week period
+random.dates <- as.Date("2001/1/1") + 70*stats::runif(100)
+hist(random.dates, "weeks", format = "%d %b")
+
+
+
+cleanEx()
+nameEx("hist")
+### * hist
+
+flush(stderr()); flush(stdout())
+
+### Name: hist
+### Title: Histograms
+### Aliases: hist hist.default
+### Keywords: dplot hplot distribution
+
+### ** Examples
+
+op <- par(mfrow = c(2, 2))
+hist(islands)
+utils::str(hist(islands, col = "gray", labels = TRUE))
+
+hist(sqrt(islands), breaks = 12, col = "lightblue", border = "pink")
+##-- For non-equidistant breaks, counts should NOT be graphed unscaled:
+r <- hist(sqrt(islands), breaks = c(4*0:5, 10*3:5, 70, 100, 140),
+ col = "blue1")
+text(r$mids, r$density, r$counts, adj = c(.5, -.5), col = "blue3")
+sapply(r[2:3], sum)
+sum(r$density * diff(r$breaks)) # == 1
+lines(r, lty = 3, border = "purple") # -> lines.histogram(*)
+par(op)
+
+require(utils) # for str
+str(hist(islands, breaks = 12, plot = FALSE)) #-> 10 (~= 12) breaks
+str(hist(islands, breaks = c(12,20,36,80,200,1000,17000), plot = FALSE))
+
+hist(islands, breaks = c(12,20,36,80,200,1000,17000), freq = TRUE,
+ main = "WRONG histogram") # and warning
+
+require(stats)
+set.seed(14)
+x <- rchisq(100, df = 4)
+## Don't show:
+op <- par(mfrow = 2:1, mgp = c(1.5, 0.6, 0), mar = .1 + c(3,3:1))
+## End(Don't show)
+## Comparing data with a model distribution should be done with qqplot()!
+qqplot(x, qchisq(ppoints(x), df = 4)); abline(0, 1, col = 2, lty = 2)
+
+## if you really insist on using hist() ... :
+hist(x, freq = FALSE, ylim = c(0, 0.2))
+curve(dchisq(x, df = 4), col = 2, lty = 2, lwd = 2, add = TRUE)
+## Don't show:
+par(op)
+## End(Don't show)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("identify")
+### * identify
+
+flush(stderr()); flush(stdout())
+
+### Name: identify
+### Title: Identify Points in a Scatter Plot
+### Aliases: identify identify.default
+### Keywords: iplot
+
+### ** Examples
+
+## A function to use identify to select points, and overplot the
+## points with another symbol as they are selected
+identifyPch <- function(x, y = NULL, n = length(x), pch = 19, ...)
+{
+ xy <- xy.coords(x, y); x <- xy$x; y <- xy$y
+ sel <- rep(FALSE, length(x)); res <- integer(0)
+ while(sum(sel) < n) {
+ ans <- identify(x[!sel], y[!sel], n = 1, plot = FALSE, ...)
+ if(!length(ans)) break
+ ans <- which(!sel)[ans]
+ points(x[ans], y[ans], pch = pch)
+ sel[ans] <- TRUE
+ res <- c(res, ans)
+ }
+ res
+}
+
+
+
+cleanEx()
+nameEx("image")
+### * image
+
+flush(stderr()); flush(stdout())
+
+### Name: image
+### Title: Display a Color Image
+### Aliases: image image.default
+### Keywords: hplot aplot
+
+### ** Examples
+
+require(grDevices) # for colours
+x <- y <- seq(-4*pi, 4*pi, len = 27)
+r <- sqrt(outer(x^2, y^2, "+"))
+image(z = z <- cos(r^2)*exp(-r/6), col = gray((0:32)/32))
+image(z, axes = FALSE, main = "Math can be beautiful ...",
+ xlab = expression(cos(r^2) * e^{-r/6}))
+contour(z, add = TRUE, drawlabels = FALSE)
+
+# Volcano data visualized as matrix. Need to transpose and flip
+# matrix horizontally.
+image(t(volcano)[ncol(volcano):1,])
+
+# A prettier display of the volcano
+x <- 10*(1:nrow(volcano))
+y <- 10*(1:ncol(volcano))
+image(x, y, volcano, col = terrain.colors(100), axes = FALSE)
+contour(x, y, volcano, levels = seq(90, 200, by = 5),
+ add = TRUE, col = "peru")
+axis(1, at = seq(100, 800, by = 100))
+axis(2, at = seq(100, 600, by = 100))
+box()
+title(main = "Maunga Whau Volcano", font.main = 4)
+
+
+
+cleanEx()
+nameEx("layout")
+### * layout
+
+flush(stderr()); flush(stdout())
+
+### Name: layout
+### Title: Specifying Complex Plot Arrangements
+### Aliases: layout layout.show lcm
+### Keywords: iplot dplot environment
+
+### ** Examples
+
+def.par <- par(no.readonly = TRUE) # save default, for resetting...
+
+## divide the device into two rows and two columns
+## allocate figure 1 all of row 1
+## allocate figure 2 the intersection of column 2 and row 2
+layout(matrix(c(1,1,0,2), 2, 2, byrow = TRUE))
+## show the regions that have been allocated to each plot
+layout.show(2)
+
+## divide device into two rows and two columns
+## allocate figure 1 and figure 2 as above
+## respect relations between widths and heights
+nf <- layout(matrix(c(1,1,0,2), 2, 2, byrow = TRUE), respect = TRUE)
+layout.show(nf)
+
+## create single figure which is 5cm square
+nf <- layout(matrix(1), widths = lcm(5), heights = lcm(5))
+layout.show(nf)
+
+
+##-- Create a scatterplot with marginal histograms -----
+
+x <- pmin(3, pmax(-3, stats::rnorm(50)))
+y <- pmin(3, pmax(-3, stats::rnorm(50)))
+xhist <- hist(x, breaks = seq(-3,3,0.5), plot = FALSE)
+yhist <- hist(y, breaks = seq(-3,3,0.5), plot = FALSE)
+top <- max(c(xhist$counts, yhist$counts))
+xrange <- c(-3, 3)
+yrange <- c(-3, 3)
+nf <- layout(matrix(c(2,0,1,3),2,2,byrow = TRUE), c(3,1), c(1,3), TRUE)
+layout.show(nf)
+
+par(mar = c(3,3,1,1))
+plot(x, y, xlim = xrange, ylim = yrange, xlab = "", ylab = "")
+par(mar = c(0,3,1,1))
+barplot(xhist$counts, axes = FALSE, ylim = c(0, top), space = 0)
+par(mar = c(3,0,1,1))
+barplot(yhist$counts, axes = FALSE, xlim = c(0, top), space = 0, horiz = TRUE)
+
+par(def.par) #- reset to default
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("legend")
+### * legend
+
+flush(stderr()); flush(stdout())
+
+### Name: legend
+### Title: Add Legends to Plots
+### Aliases: legend
+### Keywords: aplot
+
+### ** Examples
+
+## Run the example in '?matplot' or the following:
+leg.txt <- c("Setosa Petals", "Setosa Sepals",
+ "Versicolor Petals", "Versicolor Sepals")
+y.leg <- c(4.5, 3, 2.1, 1.4, .7)
+cexv <- c(1.2, 1, 4/5, 2/3, 1/2)
+matplot(c(1, 8), c(0, 4.5), type = "n", xlab = "Length", ylab = "Width",
+ main = "Petal and Sepal Dimensions in Iris Blossoms")
+for (i in seq(cexv)) {
+ text (1, y.leg[i] - 0.1, paste("cex=", formatC(cexv[i])), cex = 0.8, adj = 0)
+ legend(3, y.leg[i], leg.txt, pch = "sSvV", col = c(1, 3), cex = cexv[i])
+}
+
+## 'merge = TRUE' for merging lines & points:
+x <- seq(-pi, pi, len = 65)
+plot(x, sin(x), type = "l", ylim = c(-1.2, 1.8), col = 3, lty = 2)
+points(x, cos(x), pch = 3, col = 4)
+lines(x, tan(x), type = "b", lty = 1, pch = 4, col = 6)
+title("legend(..., lty = c(2, -1, 1), pch = c(NA, 3, 4), merge = TRUE)",
+ cex.main = 1.1)
+legend(-1, 1.9, c("sin", "cos", "tan"), col = c(3, 4, 6),
+ text.col = "green4", lty = c(2, -1, 1), pch = c(NA, 3, 4),
+ merge = TRUE, bg = "gray90")
+
+## right-justifying a set of labels: thanks to Uwe Ligges
+x <- 1:5; y1 <- 1/x; y2 <- 2/x
+plot(rep(x, 2), c(y1, y2), type = "n", xlab = "x", ylab = "y")
+lines(x, y1); lines(x, y2, lty = 2)
+temp <- legend("topright", legend = c(" ", " "),
+ text.width = strwidth("1,000,000"),
+ lty = 1:2, xjust = 1, yjust = 1,
+ title = "Line Types")
+text(temp$rect$left + temp$rect$w, temp$text$y,
+ c("1,000", "1,000,000"), pos = 2)
+
+
+##--- log scaled Examples ------------------------------
+leg.txt <- c("a one", "a two")
+
+par(mfrow = c(2, 2))
+for(ll in c("","x","y","xy")) {
+ plot(2:10, log = ll, main = paste0("log = '", ll, "'"))
+ abline(1, 1)
+ lines(2:3, 3:4, col = 2)
+ points(2, 2, col = 3)
+ rect(2, 3, 3, 2, col = 4)
+ text(c(3,3), 2:3, c("rect(2,3,3,2, col=4)",
+ "text(c(3,3),2:3,\"c(rect(...)\")"), adj = c(0, 0.3))
+ legend(list(x = 2,y = 8), legend = leg.txt, col = 2:3, pch = 1:2,
+ lty = 1, merge = TRUE) #, trace = TRUE)
+}
+par(mfrow = c(1,1))
+
+##-- Math expressions: ------------------------------
+x <- seq(-pi, pi, len = 65)
+plot(x, sin(x), type = "l", col = 2, xlab = expression(phi),
+ ylab = expression(f(phi)))
+abline(h = -1:1, v = pi/2*(-6:6), col = "gray90")
+lines(x, cos(x), col = 3, lty = 2)
+ex.cs1 <- expression(plain(sin) * phi, paste("cos", phi)) # 2 ways
+utils::str(legend(-3, .9, ex.cs1, lty = 1:2, plot = FALSE,
+ adj = c(0, 0.6))) # adj y !
+legend(-3, 0.9, ex.cs1, lty = 1:2, col = 2:3, adj = c(0, 0.6))
+
+require(stats)
+x <- rexp(100, rate = .5)
+hist(x, main = "Mean and Median of a Skewed Distribution")
+abline(v = mean(x), col = 2, lty = 2, lwd = 2)
+abline(v = median(x), col = 3, lty = 3, lwd = 2)
+ex12 <- expression(bar(x) == sum(over(x[i], n), i == 1, n),
+ hat(x) == median(x[i], i == 1, n))
+utils::str(legend(4.1, 30, ex12, col = 2:3, lty = 2:3, lwd = 2))
+
+## 'Filled' boxes -- for more, see example(plot.factor)
+op <- par(bg = "white") # to get an opaque box for the legend
+plot(cut(weight, 3) ~ group, data = PlantGrowth, col = NULL,
+ density = 16*(1:3))
+par(op)
+
+## Using 'ncol' :
+x <- 0:64/64
+matplot(x, outer(x, 1:7, function(x, k) sin(k * pi * x)),
+ type = "o", col = 1:7, ylim = c(-1, 1.5), pch = "*")
+op <- par(bg = "antiquewhite1")
+legend(0, 1.5, paste("sin(", 1:7, "pi * x)"), col = 1:7, lty = 1:7,
+ pch = "*", ncol = 4, cex = 0.8)
+legend(.8,1.2, paste("sin(", 1:7, "pi * x)"), col = 1:7, lty = 1:7,
+ pch = "*", cex = 0.8)
+legend(0, -.1, paste("sin(", 1:4, "pi * x)"), col = 1:4, lty = 1:4,
+ ncol = 2, cex = 0.8)
+legend(0, -.4, paste("sin(", 5:7, "pi * x)"), col = 4:6, pch = 24,
+ ncol = 2, cex = 1.5, lwd = 2, pt.bg = "pink", pt.cex = 1:3)
+par(op)
+
+## point covering line :
+y <- sin(3*pi*x)
+plot(x, y, type = "l", col = "blue",
+ main = "points with bg & legend(*, pt.bg)")
+points(x, y, pch = 21, bg = "white")
+legend(.4,1, "sin(c x)", pch = 21, pt.bg = "white", lty = 1, col = "blue")
+
+## legends with titles at different locations
+plot(x, y, type = "n")
+legend("bottomright", "(x,y)", pch = 1, title = "bottomright")
+legend("bottom", "(x,y)", pch = 1, title = "bottom")
+legend("bottomleft", "(x,y)", pch = 1, title = "bottomleft")
+legend("left", "(x,y)", pch = 1, title = "left")
+legend("topleft", "(x,y)", pch = 1, title = "topleft, inset = .05",
+ inset = .05)
+legend("top", "(x,y)", pch = 1, title = "top")
+legend("topright", "(x,y)", pch = 1, title = "topright, inset = .02",
+ inset = .02)
+legend("right", "(x,y)", pch = 1, title = "right")
+legend("center", "(x,y)", pch = 1, title = "center")
+
+# using text.font (and text.col):
+op <- par(mfrow = c(2, 2), mar = rep(2.1, 4))
+c6 <- terrain.colors(10)[1:6]
+for(i in 1:4) {
+ plot(1, type = "n", axes = FALSE, ann = FALSE); title(paste("text.font =",i))
+ legend("top", legend = LETTERS[1:6], col = c6,
+ ncol = 2, cex = 2, lwd = 3, text.font = i, text.col = c6)
+}
+par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("lines")
+### * lines
+
+flush(stderr()); flush(stdout())
+
+### Name: lines
+### Title: Add Connected Line Segments to a Plot
+### Aliases: lines lines.default
+### Keywords: aplot
+
+### ** Examples
+
+# draw a smooth line through a scatter plot
+plot(cars, main = "Stopping Distance versus Speed")
+lines(stats::lowess(cars))
+
+
+
+cleanEx()
+nameEx("matplot")
+### * matplot
+
+flush(stderr()); flush(stdout())
+
+### Name: matplot
+### Title: Plot Columns of Matrices
+### Aliases: matplot matpoints matlines
+### Keywords: hplot aplot array
+
+### ** Examples
+
+require(grDevices)
+matplot((-4:5)^2, main = "Quadratic") # almost identical to plot(*)
+sines <- outer(1:20, 1:4, function(x, y) sin(x / 20 * pi * y))
+matplot(sines, pch = 1:4, type = "o", col = rainbow(ncol(sines)))
+matplot(sines, type = "b", pch = 21:23, col = 2:5, bg = 2:5,
+ main = "matplot(...., pch = 21:23, bg = 2:5)")
+
+x <- 0:50/50
+matplot(x, outer(x, 1:8, function(x, k) sin(k*pi * x)),
+ ylim = c(-2,2), type = "plobcsSh",
+ main= "matplot(,type = \"plobcsSh\" )")
+## pch & type = vector of 1-chars :
+matplot(x, outer(x, 1:4, function(x, k) sin(k*pi * x)),
+ pch = letters[1:4], type = c("b","p","o"))
+
+lends <- c("round","butt","square")
+matplot(matrix(1:12, 4), type="c", lty=1, lwd=10, lend=lends)
+text(cbind(2.5, 2*c(1,3,5)-.4), lends, col= 1:3, cex = 1.5)
+
+table(iris$Species) # is data.frame with 'Species' factor
+iS <- iris$Species == "setosa"
+iV <- iris$Species == "versicolor"
+op <- par(bg = "bisque")
+matplot(c(1, 8), c(0, 4.5), type = "n", xlab = "Length", ylab = "Width",
+ main = "Petal and Sepal Dimensions in Iris Blossoms")
+matpoints(iris[iS,c(1,3)], iris[iS,c(2,4)], pch = "sS", col = c(2,4))
+matpoints(iris[iV,c(1,3)], iris[iV,c(2,4)], pch = "vV", col = c(2,4))
+legend(1, 4, c(" Setosa Petals", " Setosa Sepals",
+ "Versicolor Petals", "Versicolor Sepals"),
+ pch = "sSvV", col = rep(c(2,4), 2))
+
+nam.var <- colnames(iris)[-5]
+nam.spec <- as.character(iris[1+50*0:2, "Species"])
+iris.S <- array(NA, dim = c(50,4,3),
+ dimnames = list(NULL, nam.var, nam.spec))
+for(i in 1:3) iris.S[,,i] <- data.matrix(iris[1:50+50*(i-1), -5])
+
+matplot(iris.S[, "Petal.Length",], iris.S[, "Petal.Width",], pch = "SCV",
+ col = rainbow(3, start = 0.8, end = 0.1),
+ sub = paste(c("S", "C", "V"), dimnames(iris.S)[[3]],
+ sep = "=", collapse= ", "),
+ main = "Fisher's Iris Data")
+par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("mosaicplot")
+### * mosaicplot
+
+flush(stderr()); flush(stdout())
+
+### Name: mosaicplot
+### Title: Mosaic Plots
+### Aliases: mosaicplot mosaicplot.default mosaicplot.formula
+### Keywords: hplot
+
+### ** Examples
+
+require(stats)
+mosaicplot(Titanic, main = "Survival on the Titanic", color = TRUE)
+## Formula interface for tabulated data:
+mosaicplot(~ Sex + Age + Survived, data = Titanic, color = TRUE)
+
+mosaicplot(HairEyeColor, shade = TRUE)
+## Independence model of hair and eye color and sex. Indicates that
+## there are more blue eyed blonde females than expected in the case
+## of independence and too few brown eyed blonde females.
+## The corresponding model is:
+fm <- loglin(HairEyeColor, list(1, 2, 3))
+pchisq(fm$pearson, fm$df, lower.tail = FALSE)
+
+mosaicplot(HairEyeColor, shade = TRUE, margin = list(1:2, 3))
+## Model of joint independence of sex from hair and eye color. Males
+## are underrepresented among people with brown hair and eyes, and are
+## overrepresented among people with brown hair and blue eyes.
+## The corresponding model is:
+fm <- loglin(HairEyeColor, list(1:2, 3))
+pchisq(fm$pearson, fm$df, lower.tail = FALSE)
+
+## Formula interface for raw data: visualize cross-tabulation of numbers
+## of gears and carburettors in Motor Trend car data.
+mosaicplot(~ gear + carb, data = mtcars, color = TRUE, las = 1)
+# color recycling
+mosaicplot(~ gear + carb, data = mtcars, color = 2:3, las = 1)
+
+
+
+cleanEx()
+nameEx("mtext")
+### * mtext
+
+flush(stderr()); flush(stdout())
+
+### Name: mtext
+### Title: Write Text into the Margins of a Plot
+### Aliases: mtext
+### Keywords: aplot
+
+### ** Examples
+
+plot(1:10, (-4:5)^2, main = "Parabola Points", xlab = "xlab")
+mtext("10 of them")
+for(s in 1:4)
+ mtext(paste("mtext(..., line= -1, {side, col, font} = ", s,
+ ", cex = ", (1+s)/2, ")"), line = -1,
+ side = s, col = s, font = s, cex = (1+s)/2)
+mtext("mtext(..., line= -2)", line = -2)
+mtext("mtext(..., line= -2, adj = 0)", line = -2, adj = 0)
+##--- log axis :
+plot(1:10, exp(1:10), log = "y", main = "log =\"y\"", xlab = "xlab")
+for(s in 1:4) mtext(paste("mtext(...,side=", s ,")"), side = s)
+
+
+
+cleanEx()
+nameEx("pairs")
+### * pairs
+
+flush(stderr()); flush(stdout())
+
+### Name: pairs
+### Title: Scatterplot Matrices
+### Aliases: pairs pairs.default pairs.formula
+### Keywords: hplot
+
+### ** Examples
+
+pairs(iris[1:4], main = "Anderson's Iris Data -- 3 species",
+ pch = 21, bg = c("red", "green3", "blue")[unclass(iris$Species)])
+
+## formula method
+pairs(~ Fertility + Education + Catholic, data = swiss,
+ subset = Education < 20, main = "Swiss data, Education < 20")
+
+pairs(USJudgeRatings)
+## show only lower triangle (and suppress labeling for whatever reason):
+pairs(USJudgeRatings, text.panel = NULL, upper.panel = NULL)
+
+## put histograms on the diagonal
+panel.hist <- function(x, ...)
+{
+ usr <- par("usr"); on.exit(par(usr))
+ par(usr = c(usr[1:2], 0, 1.5) )
+ h <- hist(x, plot = FALSE)
+ breaks <- h$breaks; nB <- length(breaks)
+ y <- h$counts; y <- y/max(y)
+ rect(breaks[-nB], 0, breaks[-1], y, col = "cyan", ...)
+}
+pairs(USJudgeRatings[1:5], panel = panel.smooth,
+ cex = 1.5, pch = 24, bg = "light blue",
+ diag.panel = panel.hist, cex.labels = 2, font.labels = 2)
+
+## put (absolute) correlations on the upper panels,
+## with size proportional to the correlations.
+panel.cor <- function(x, y, digits = 2, prefix = "", cex.cor, ...)
+{
+ usr <- par("usr"); on.exit(par(usr))
+ par(usr = c(0, 1, 0, 1))
+ r <- abs(cor(x, y))
+ txt <- format(c(r, 0.123456789), digits = digits)[1]
+ txt <- paste0(prefix, txt)
+ if(missing(cex.cor)) cex.cor <- 0.8/strwidth(txt)
+ text(0.5, 0.5, txt, cex = cex.cor * r)
+}
+pairs(USJudgeRatings, lower.panel = panel.smooth, upper.panel = panel.cor)
+
+pairs(iris[-5], log = "xy") # plot all variables on log scale
+pairs(iris, log = 1:4, # log the first four
+ main = "Lengths and Widths in [log]", line.main=1.5, oma=c(2,2,3,2))
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("panel.smooth")
+### * panel.smooth
+
+flush(stderr()); flush(stdout())
+
+### Name: panel.smooth
+### Title: Simple Panel Plot
+### Aliases: panel.smooth
+### Keywords: hplot dplot
+
+### ** Examples
+
+pairs(swiss, panel = panel.smooth, pch = ".") # emphasize the smooths
+pairs(swiss, panel = panel.smooth, lwd = 2, cex = 1.5, col = "blue") # hmm...
+
+
+
+cleanEx()
+nameEx("par")
+### * par
+
+flush(stderr()); flush(stdout())
+
+### Name: par
+### Title: Set or Query Graphical Parameters
+### Aliases: par .Pars 'graphical parameter' 'graphical parameters'
+### Keywords: iplot dplot environment
+
+### ** Examples
+
+op <- par(mfrow = c(2, 2), # 2 x 2 pictures on one plot
+ pty = "s") # square plotting region,
+ # independent of device size
+
+## At end of plotting, reset to previous settings:
+par(op)
+
+## Alternatively,
+op <- par(no.readonly = TRUE) # the whole list of settable par's.
+## do lots of plotting and par(.) calls, then reset:
+par(op)
+## Note this is not in general good practice
+
+par("ylog") # FALSE
+plot(1 : 12, log = "y")
+par("ylog") # TRUE
+
+plot(1:2, xaxs = "i") # 'inner axis' w/o extra space
+par(c("usr", "xaxp"))
+
+( nr.prof <-
+c(prof.pilots = 16, lawyers = 11, farmers = 10, salesmen = 9, physicians = 9,
+ mechanics = 6, policemen = 6, managers = 6, engineers = 5, teachers = 4,
+ housewives = 3, students = 3, armed.forces = 1))
+par(las = 3)
+barplot(rbind(nr.prof)) # R 0.63.2: shows alignment problem
+par(las = 0) # reset to default
+
+require(grDevices) # for gray
+## 'fg' use:
+plot(1:12, type = "b", main = "'fg' : axes, ticks and box in gray",
+ fg = gray(0.7), bty = "7" , sub = R.version.string)
+
+ex <- function() {
+ old.par <- par(no.readonly = TRUE) # all par settings which
+ # could be changed.
+ on.exit(par(old.par))
+ ## ...
+ ## ... do lots of par() settings and plots
+ ## ...
+ invisible() #-- now, par(old.par) will be executed
+}
+ex()
+
+## Line types
+showLty <- function(ltys, xoff = 0, ...) {
+ stopifnot((n <- length(ltys)) >= 1)
+ op <- par(mar = rep(.5,4)); on.exit(par(op))
+ plot(0:1, 0:1, type = "n", axes = FALSE, ann = FALSE)
+ y <- (n:1)/(n+1)
+ clty <- as.character(ltys)
+ mytext <- function(x, y, txt)
+ text(x, y, txt, adj = c(0, -.3), cex = 0.8, ...)
+ abline(h = y, lty = ltys, ...); mytext(xoff, y, clty)
+ y <- y - 1/(3*(n+1))
+ abline(h = y, lty = ltys, lwd = 2, ...)
+ mytext(1/8+xoff, y, paste(clty," lwd = 2"))
+}
+showLty(c("solid", "dashed", "dotted", "dotdash", "longdash", "twodash"))
+par(new = TRUE) # the same:
+showLty(c("solid", "44", "13", "1343", "73", "2262"), xoff = .2, col = 2)
+showLty(c("11", "22", "33", "44", "12", "13", "14", "21", "31"))
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("persp")
+### * persp
+
+flush(stderr()); flush(stdout())
+
+### Name: persp
+### Title: Perspective Plots
+### Aliases: persp persp.default
+### Keywords: hplot aplot
+
+### ** Examples
+
+require(grDevices) # for trans3d
+## More examples in demo(persp) !!
+## -----------
+
+# (1) The Obligatory Mathematical surface.
+# Rotated sinc function.
+
+x <- seq(-10, 10, length= 30)
+y <- x
+f <- function(x, y) { r <- sqrt(x^2+y^2); 10 * sin(r)/r }
+z <- outer(x, y, f)
+z[is.na(z)] <- 1
+op <- par(bg = "white")
+persp(x, y, z, theta = 30, phi = 30, expand = 0.5, col = "lightblue")
+persp(x, y, z, theta = 30, phi = 30, expand = 0.5, col = "lightblue",
+ ltheta = 120, shade = 0.75, ticktype = "detailed",
+ xlab = "X", ylab = "Y", zlab = "Sinc( r )"
+) -> res
+round(res, 3)
+
+# (2) Add to existing persp plot - using trans3d() :
+
+xE <- c(-10,10); xy <- expand.grid(xE, xE)
+points(trans3d(xy[,1], xy[,2], 6, pmat = res), col = 2, pch = 16)
+lines (trans3d(x, y = 10, z = 6 + sin(x), pmat = res), col = 3)
+
+phi <- seq(0, 2*pi, len = 201)
+r1 <- 7.725 # radius of 2nd maximum
+xr <- r1 * cos(phi)
+yr <- r1 * sin(phi)
+lines(trans3d(xr,yr, f(xr,yr), res), col = "pink", lwd = 2)
+## (no hidden lines)
+
+# (3) Visualizing a simple DEM model
+
+z <- 2 * volcano # Exaggerate the relief
+x <- 10 * (1:nrow(z)) # 10 meter spacing (S to N)
+y <- 10 * (1:ncol(z)) # 10 meter spacing (E to W)
+## Don't draw the grid lines : border = NA
+par(bg = "slategray")
+persp(x, y, z, theta = 135, phi = 30, col = "green3", scale = FALSE,
+ ltheta = -120, shade = 0.75, border = NA, box = FALSE)
+
+# (4) Surface colours corresponding to z-values
+
+par(bg = "white")
+x <- seq(-1.95, 1.95, length = 30)
+y <- seq(-1.95, 1.95, length = 35)
+z <- outer(x, y, function(a, b) a*b^2)
+nrz <- nrow(z)
+ncz <- ncol(z)
+# Create a function interpolating colors in the range of specified colors
+jet.colors <- colorRampPalette( c("blue", "green") )
+# Generate the desired number of colors from this palette
+nbcol <- 100
+color <- jet.colors(nbcol)
+# Compute the z-value at the facet centres
+zfacet <- z[-1, -1] + z[-1, -ncz] + z[-nrz, -1] + z[-nrz, -ncz]
+# Recode facet z-values into color indices
+facetcol <- cut(zfacet, nbcol)
+persp(x, y, z, col = color[facetcol], phi = 30, theta = -30)
+
+par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("pie")
+### * pie
+
+flush(stderr()); flush(stdout())
+
+### Name: pie
+### Title: Pie Charts
+### Aliases: pie
+### Keywords: hplot
+
+### ** Examples
+
+require(grDevices)
+pie(rep(1, 24), col = rainbow(24), radius = 0.9)
+
+pie.sales <- c(0.12, 0.3, 0.26, 0.16, 0.04, 0.12)
+names(pie.sales) <- c("Blueberry", "Cherry",
+ "Apple", "Boston Cream", "Other", "Vanilla Cream")
+pie(pie.sales) # default colours
+pie(pie.sales, col = c("purple", "violetred1", "green3",
+ "cornsilk", "cyan", "white"))
+pie(pie.sales, col = gray(seq(0.4, 1.0, length = 6)))
+pie(pie.sales, density = 10, angle = 15 + 10 * 1:6)
+pie(pie.sales, clockwise = TRUE, main = "pie(*, clockwise = TRUE)")
+segments(0, 0, 0, 1, col = "red", lwd = 2)
+text(0, 1, "init.angle = 90", col = "red")
+
+n <- 200
+pie(rep(1, n), labels = "", col = rainbow(n), border = NA,
+ main = "pie(*, labels=\"\", col=rainbow(n), border=NA,..")
+
+## Another case showing pie() is rather fun than science:
+## (original by FinalBackwardsGlance on http://imgur.com/gallery/wWrpU4X)
+pie(c(Sky = 78, "Sunny side of pyramid" = 17, "Shady side of pyramid" = 5),
+ init.angle = 315, col = c("deepskyblue", "yellow", "yellow3"), border = FALSE)
+
+
+
+cleanEx()
+nameEx("plot")
+### * plot
+
+flush(stderr()); flush(stdout())
+
+### Name: plot
+### Title: Generic X-Y Plotting
+### Aliases: plot
+### Keywords: hplot
+
+### ** Examples
+
+require(stats) # for lowess, rpois, rnorm
+plot(cars)
+lines(lowess(cars))
+
+plot(sin, -pi, 2*pi) # see ?plot.function
+
+## Discrete Distribution Plot:
+plot(table(rpois(100, 5)), type = "h", col = "red", lwd = 10,
+ main = "rpois(100, lambda = 5)")
+
+## Simple quantiles/ECDF, see ecdf() {library(stats)} for a better one:
+plot(x <- sort(rnorm(47)), type = "s", main = "plot(x, type = \"s\")")
+points(x, cex = .5, col = "dark red")
+
+
+
+cleanEx()
+nameEx("plot.dataframe")
+### * plot.dataframe
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.data.frame
+### Title: Plot Method for Data Frames
+### Aliases: plot.data.frame
+### Keywords: hplot methods
+
+### ** Examples
+
+plot(OrchardSprays[1], method = "jitter")
+plot(OrchardSprays[c(4,1)])
+plot(OrchardSprays)
+
+plot(iris)
+plot(iris[5:4])
+plot(women)
+
+
+
+cleanEx()
+nameEx("plot.default")
+### * plot.default
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.default
+### Title: The Default Scatterplot Function
+### Aliases: plot.default
+### Keywords: hplot
+
+### ** Examples
+
+Speed <- cars$speed
+Distance <- cars$dist
+plot(Speed, Distance, panel.first = grid(8, 8),
+ pch = 0, cex = 1.2, col = "blue")
+plot(Speed, Distance,
+ panel.first = lines(stats::lowess(Speed, Distance), lty = "dashed"),
+ pch = 0, cex = 1.2, col = "blue")
+
+## Show the different plot types
+x <- 0:12
+y <- sin(pi/5 * x)
+op <- par(mfrow = c(3,3), mar = .1+ c(2,2,3,1))
+for (tp in c("p","l","b", "c","o","h", "s","S","n")) {
+ plot(y ~ x, type = tp, main = paste0("plot(*, type = \"", tp, "\")"))
+ if(tp == "S") {
+ lines(x, y, type = "s", col = "red", lty = 2)
+ mtext("lines(*, type = \"s\", ...)", col = "red", cex = 0.8)
+ }
+}
+par(op)
+
+##--- Log-Log Plot with custom axes
+lx <- seq(1, 5, length = 41)
+yl <- expression(e^{-frac(1,2) * {log[10](x)}^2})
+y <- exp(-.5*lx^2)
+op <- par(mfrow = c(2,1), mar = par("mar")-c(1,0,2,0), mgp = c(2, .7, 0))
+plot(10^lx, y, log = "xy", type = "l", col = "purple",
+ main = "Log-Log plot", ylab = yl, xlab = "x")
+plot(10^lx, y, log = "xy", type = "o", pch = ".", col = "forestgreen",
+ main = "Log-Log plot with custom axes", ylab = yl, xlab = "x",
+ axes = FALSE, frame.plot = TRUE)
+my.at <- 10^(1:5)
+axis(1, at = my.at, labels = formatC(my.at, format = "fg"))
+e.y <- -5:-1 ; at.y <- 10^e.y
+axis(2, at = at.y, col.axis = "red", las = 1,
+ labels = as.expression(lapply(e.y, function(E) bquote(10^.(E)))))
+par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("plot.design")
+### * plot.design
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.design
+### Title: Plot Univariate Effects of a Design or Model
+### Aliases: plot.design
+### Keywords: hplot
+
+### ** Examples
+
+require(stats)
+plot.design(warpbreaks) # automatic for data frame with one numeric var.
+
+Form <- breaks ~ wool + tension
+summary(fm1 <- aov(Form, data = warpbreaks))
+plot.design( Form, data = warpbreaks, col = 2) # same as above
+
+## More than one y :
+utils::str(esoph)
+plot.design(esoph) ## two plots; if interactive you are "ask"ed
+
+## or rather, compare mean and median:
+op <- par(mfcol = 1:2)
+plot.design(ncases/ncontrols ~ ., data = esoph, ylim = c(0, 0.8))
+plot.design(ncases/ncontrols ~ ., data = esoph, ylim = c(0, 0.8),
+ fun = median)
+par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("plot.factor")
+### * plot.factor
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.factor
+### Title: Plotting Factor Variables
+### Aliases: plot.factor
+### Keywords: hplot
+
+### ** Examples
+
+require(grDevices)
+plot(weight ~ group, data = PlantGrowth) # numeric vector ~ factor
+plot(cut(weight, 2) ~ group, data = PlantGrowth) # factor ~ factor
+## passing "..." to spineplot() eventually:
+plot(cut(weight, 3) ~ group, data = PlantGrowth,
+ col = hcl(c(0, 120, 240), 50, 70))
+
+plot(PlantGrowth$group, axes = FALSE, main = "no axes") # extremely silly
+
+
+
+cleanEx()
+nameEx("plot.formula")
+### * plot.formula
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.formula
+### Title: Formula Notation for Scatterplots
+### Aliases: plot.formula lines.formula points.formula text.formula
+### Keywords: hplot aplot
+
+### ** Examples
+
+op <- par(mfrow = c(2,1))
+plot(Ozone ~ Wind, data = airquality, pch = as.character(Month))
+plot(Ozone ~ Wind, data = airquality, pch = as.character(Month),
+ subset = Month != 7)
+par(op)
+
+## text.formula() can be very natural:
+wb <- within(warpbreaks, {
+ time <- seq_along(breaks); W.T <- wool:tension })
+plot(breaks ~ time, data = wb, type = "b")
+text(breaks ~ time, data = wb, label = W.T, col = 1+as.integer(wool))
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("plot.raster")
+### * plot.raster
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.raster
+### Title: Plotting Raster Images
+### Aliases: plot.raster
+### Keywords: hplot
+
+### ** Examples
+
+require(grDevices)
+r <- as.raster(c(0.5, 1, 0.5))
+plot(r)
+# additional arguments to rasterImage()
+plot(r, interpolate=FALSE)
+# distort
+plot(r, asp=NA)
+# fill page
+op <- par(mar=rep(0, 4))
+plot(r, asp=NA)
+par(op)
+# normal annotations work
+plot(r, asp=NA)
+box()
+title(main="This is my raster")
+# add to existing plot
+plot(1)
+plot(r, add=TRUE)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("plot.table")
+### * plot.table
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.table
+### Title: Plot Methods for 'table' Objects
+### Aliases: plot.table lines.table points.table
+### Keywords: hplot category
+
+### ** Examples
+
+## 1-d tables
+(Poiss.tab <- table(N = stats::rpois(200, lambda = 5)))
+plot(Poiss.tab, main = "plot(table(rpois(200, lambda = 5)))")
+
+plot(table(state.division))
+
+## 4-D :
+plot(Titanic, main ="plot(Titanic, main= *)")
+
+
+
+
+cleanEx()
+nameEx("plot.window")
+### * plot.window
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.window
+### Title: Set up World Coordinates for Graphics Window
+### Aliases: plot.window xlim ylim asp
+### Keywords: aplot
+
+### ** Examples
+
+##--- An example for the use of 'asp' :
+require(stats) # normally loaded
+loc <- cmdscale(eurodist)
+rx <- range(x <- loc[,1])
+ry <- range(y <- -loc[,2])
+plot(x, y, type = "n", asp = 1, xlab = "", ylab = "")
+abline(h = pretty(rx, 10), v = pretty(ry, 10), col = "lightgray")
+text(x, y, labels(eurodist), cex = 0.8)
+
+
+
+cleanEx()
+nameEx("plot.xy")
+### * plot.xy
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.xy
+### Title: Basic Internal Plot Function
+### Aliases: plot.xy
+### Keywords: aplot
+
+### ** Examples
+
+points.default # to see how it calls "plot.xy(xy.coords(x, y), ...)"
+
+
+
+cleanEx()
+nameEx("plothistogram")
+### * plothistogram
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.histogram
+### Title: Plot Histograms
+### Aliases: plot.histogram lines.histogram
+### Keywords: hplot iplot
+
+### ** Examples
+
+(wwt <- hist(women$weight, nclass = 7, plot = FALSE))
+plot(wwt, labels = TRUE) # default main & xlab using wwt$xname
+plot(wwt, border = "dark blue", col = "light blue",
+ main = "Histogram of 15 women's weights", xlab = "weight [pounds]")
+
+## Fake "lines" example, using non-default labels:
+w2 <- wwt; w2$counts <- w2$counts - 1
+lines(w2, col = "Midnight Blue", labels = ifelse(w2$counts, "> 1", "1"))
+
+
+
+cleanEx()
+nameEx("points")
+### * points
+
+flush(stderr()); flush(stdout())
+
+### Name: points
+### Title: Add Points to a Plot
+### Aliases: points points.default pch
+### Keywords: aplot
+
+### ** Examples
+
+require(stats) # for rnorm
+plot(-4:4, -4:4, type = "n") # setting up coord. system
+points(rnorm(200), rnorm(200), col = "red")
+points(rnorm(100)/2, rnorm(100)/2, col = "blue", cex = 1.5)
+
+op <- par(bg = "light blue")
+x <- seq(0, 2*pi, len = 51)
+## something "between type='b' and type='o'":
+plot(x, sin(x), type = "o", pch = 21, bg = par("bg"), col = "blue", cex = .6,
+ main = 'plot(..., type="o", pch=21, bg=par("bg"))')
+par(op)
+
+## Not run:
+##D ## The figure was produced by calls like
+##D png("pch.png", height = 0.7, width = 7, res = 100, units = "in")
+##D par(mar = rep(0,4))
+##D plot(c(-1, 26), 0:1, type = "n", axes = FALSE)
+##D text(0:25, 0.6, 0:25, cex = 0.5)
+##D points(0:25, rep(0.3, 26), pch = 0:25, bg = "grey")
+## End(Not run)
+
+##-------- Showing all the extra & some char graphics symbols ---------
+pchShow <-
+ function(extras = c("*",".", "o","O","0","+","-","|","%","#"),
+ cex = 3, ## good for both .Device=="postscript" and "x11"
+ col = "red3", bg = "gold", coltext = "brown", cextext = 1.2,
+ main = paste("plot symbols : points (... pch = *, cex =",
+ cex,")"))
+ {
+ nex <- length(extras)
+ np <- 26 + nex
+ ipch <- 0:(np-1)
+ k <- floor(sqrt(np))
+ dd <- c(-1,1)/2
+ rx <- dd + range(ix <- ipch %/% k)
+ ry <- dd + range(iy <- 3 + (k-1)- ipch %% k)
+ pch <- as.list(ipch) # list with integers & strings
+ if(nex > 0) pch[26+ 1:nex] <- as.list(extras)
+ plot(rx, ry, type = "n", axes = FALSE, xlab = "", ylab = "", main = main)
+ abline(v = ix, h = iy, col = "lightgray", lty = "dotted")
+ for(i in 1:np) {
+ pc <- pch[[i]]
+ ## 'col' symbols with a 'bg'-colored interior (where available) :
+ points(ix[i], iy[i], pch = pc, col = col, bg = bg, cex = cex)
+ if(cextext > 0)
+ text(ix[i] - 0.3, iy[i], pc, col = coltext, cex = cextext)
+ }
+ }
+
+pchShow()
+pchShow(c("o","O","0"), cex = 2.5)
+pchShow(NULL, cex = 4, cextext = 0, main = NULL)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("polygon")
+### * polygon
+
+flush(stderr()); flush(stdout())
+
+### Name: polygon
+### Title: Polygon Drawing
+### Aliases: polygon
+### Keywords: aplot
+
+### ** Examples
+
+x <- c(1:9, 8:1)
+y <- c(1, 2*(5:3), 2, -1, 17, 9, 8, 2:9)
+op <- par(mfcol = c(3, 1))
+for(xpd in c(FALSE, TRUE, NA)) {
+ plot(1:10, main = paste("xpd =", xpd))
+ box("figure", col = "pink", lwd = 3)
+ polygon(x, y, xpd = xpd, col = "orange", lty = 2, lwd = 2, border = "red")
+}
+par(op)
+
+n <- 100
+xx <- c(0:n, n:0)
+yy <- c(c(0, cumsum(stats::rnorm(n))), rev(c(0, cumsum(stats::rnorm(n)))))
+plot (xx, yy, type = "n", xlab = "Time", ylab = "Distance")
+polygon(xx, yy, col = "gray", border = "red")
+title("Distance Between Brownian Motions")
+
+# Multiple polygons from NA values
+# and recycling of col, border, and lty
+op <- par(mfrow = c(2, 1))
+plot(c(1, 9), 1:2, type = "n")
+polygon(1:9, c(2,1,2,1,1,2,1,2,1),
+ col = c("red", "blue"),
+ border = c("green", "yellow"),
+ lwd = 3, lty = c("dashed", "solid"))
+plot(c(1, 9), 1:2, type = "n")
+polygon(1:9, c(2,1,2,1,NA,2,1,2,1),
+ col = c("red", "blue"),
+ border = c("green", "yellow"),
+ lwd = 3, lty = c("dashed", "solid"))
+par(op)
+
+# Line-shaded polygons
+plot(c(1, 9), 1:2, type = "n")
+polygon(1:9, c(2,1,2,1,NA,2,1,2,1),
+ density = c(10, 20), angle = c(-45, 45))
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("polypath")
+### * polypath
+
+flush(stderr()); flush(stdout())
+
+### Name: polypath
+### Title: Path Drawing
+### Aliases: polypath
+### Keywords: aplot
+
+### ** Examples
+
+plotPath <- function(x, y, col = "grey", rule = "winding") {
+ plot.new()
+ plot.window(range(x, na.rm = TRUE), range(y, na.rm = TRUE))
+ polypath(x, y, col = col, rule = rule)
+ if (!is.na(col))
+ mtext(paste("Rule:", rule), side = 1, line = 0)
+}
+
+plotRules <- function(x, y, title) {
+ plotPath(x, y)
+ plotPath(x, y, rule = "evenodd")
+ mtext(title, side = 3, line = 0)
+ plotPath(x, y, col = NA)
+}
+
+op <- par(mfrow = c(5, 3), mar = c(2, 1, 1, 1))
+
+plotRules(c(.1, .1, .9, .9, NA, .2, .2, .8, .8),
+ c(.1, .9, .9, .1, NA, .2, .8, .8, .2),
+ "Nested rectangles, both clockwise")
+plotRules(c(.1, .1, .9, .9, NA, .2, .8, .8, .2),
+ c(.1, .9, .9, .1, NA, .2, .2, .8, .8),
+ "Nested rectangles, outer clockwise, inner anti-clockwise")
+plotRules(c(.1, .1, .4, .4, NA, .6, .9, .9, .6),
+ c(.1, .4, .4, .1, NA, .6, .6, .9, .9),
+ "Disjoint rectangles")
+plotRules(c(.1, .1, .6, .6, NA, .4, .4, .9, .9),
+ c(.1, .6, .6, .1, NA, .4, .9, .9, .4),
+ "Overlapping rectangles, both clockwise")
+plotRules(c(.1, .1, .6, .6, NA, .4, .9, .9, .4),
+ c(.1, .6, .6, .1, NA, .4, .4, .9, .9),
+ "Overlapping rectangles, one clockwise, other anti-clockwise")
+
+par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("rasterImage")
+### * rasterImage
+
+flush(stderr()); flush(stdout())
+
+### Name: rasterImage
+### Title: Draw One or More Raster Images
+### Aliases: rasterImage
+### Keywords: aplot
+
+### ** Examples
+
+require(grDevices)
+## set up the plot region:
+op <- par(bg = "thistle")
+plot(c(100, 250), c(300, 450), type = "n", xlab = "", ylab = "")
+image <- as.raster(matrix(0:1, ncol = 5, nrow = 3))
+rasterImage(image, 100, 300, 150, 350, interpolate = FALSE)
+rasterImage(image, 100, 400, 150, 450)
+rasterImage(image, 200, 300, 200 + xinch(.5), 300 + yinch(.3),
+ interpolate = FALSE)
+rasterImage(image, 200, 400, 250, 450, angle = 15, interpolate = FALSE)
+par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("rect")
+### * rect
+
+flush(stderr()); flush(stdout())
+
+### Name: rect
+### Title: Draw One or More Rectangles
+### Aliases: rect
+### Keywords: aplot
+
+### ** Examples
+
+require(grDevices)
+## set up the plot region:
+op <- par(bg = "thistle")
+plot(c(100, 250), c(300, 450), type = "n", xlab = "", ylab = "",
+ main = "2 x 11 rectangles; 'rect(100+i,300+i, 150+i,380+i)'")
+i <- 4*(0:10)
+## draw rectangles with bottom left (100, 300)+i
+## and top right (150, 380)+i
+rect(100+i, 300+i, 150+i, 380+i, col = rainbow(11, start = 0.7, end = 0.1))
+rect(240-i, 320+i, 250-i, 410+i, col = heat.colors(11), lwd = i/5)
+## Background alternating ( transparent / "bg" ) :
+j <- 10*(0:5)
+rect(125+j, 360+j, 141+j, 405+j/2, col = c(NA,0),
+ border = "gold", lwd = 2)
+rect(125+j, 296+j/2, 141+j, 331+j/5, col = c(NA,"midnightblue"))
+mtext("+ 2 x 6 rect(*, col = c(NA,0)) and col = c(NA,\"m..blue\"))")
+
+## an example showing colouring and shading
+plot(c(100, 200), c(300, 450), type= "n", xlab = "", ylab = "")
+rect(100, 300, 125, 350) # transparent
+rect(100, 400, 125, 450, col = "green", border = "blue") # coloured
+rect(115, 375, 150, 425, col = par("bg"), border = "transparent")
+rect(150, 300, 175, 350, density = 10, border = "red")
+rect(150, 400, 175, 450, density = 30, col = "blue",
+ angle = -30, border = "transparent")
+
+legend(180, 450, legend = 1:4, fill = c(NA, "green", par("fg"), "blue"),
+ density = c(NA, NA, 10, 30), angle = c(NA, NA, 30, -30))
+
+par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("rug")
+### * rug
+
+flush(stderr()); flush(stdout())
+
+### Name: rug
+### Title: Add a Rug to a Plot
+### Aliases: rug
+### Keywords: aplot
+
+### ** Examples
+
+require(stats) # both 'density' and its default method
+with(faithful, {
+ plot(density(eruptions, bw = 0.15))
+ rug(eruptions)
+ rug(jitter(eruptions, amount = 0.01), side = 3, col = "light blue")
+})
+
+
+
+cleanEx()
+nameEx("screen")
+### * screen
+
+flush(stderr()); flush(stdout())
+
+### Name: screen
+### Title: Creating and Controlling Multiple Screens on a Single Device
+### Aliases: screen split.screen erase.screen close.screen
+### Keywords: aplot dplot device
+
+### ** Examples
+
+if (interactive()) {
+par(bg = "white") # default is likely to be transparent
+split.screen(c(2, 1)) # split display into two screens
+split.screen(c(1, 3), screen = 2) # now split the bottom half into 3
+screen(1) # prepare screen 1 for output
+plot(10:1)
+screen(4) # prepare screen 4 for output
+plot(10:1)
+close.screen(all = TRUE) # exit split-screen mode
+
+split.screen(c(2, 1)) # split display into two screens
+split.screen(c(1, 2), 2) # split bottom half in two
+plot(1:10) # screen 3 is active, draw plot
+erase.screen() # forgot label, erase and redraw
+plot(1:10, ylab = "ylab 3")
+screen(1) # prepare screen 1 for output
+plot(1:10)
+screen(4) # prepare screen 4 for output
+plot(1:10, ylab = "ylab 4")
+screen(1, FALSE) # return to screen 1, but do not clear
+plot(10:1, axes = FALSE, lty = 2, ylab = "") # overlay second plot
+axis(4) # add tic marks to right-hand axis
+title("Plot 1")
+close.screen(all = TRUE) # exit split-screen mode
+}
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("segments")
+### * segments
+
+flush(stderr()); flush(stdout())
+
+### Name: segments
+### Title: Add Line Segments to a Plot
+### Aliases: segments
+### Keywords: aplot
+
+### ** Examples
+
+x <- stats::runif(12); y <- stats::rnorm(12)
+i <- order(x, y); x <- x[i]; y <- y[i]
+plot(x, y, main = "arrows(.) and segments(.)")
+## draw arrows from point to point :
+s <- seq(length(x)-1) # one shorter than data
+arrows(x[s], y[s], x[s+1], y[s+1], col= 1:3)
+s <- s[-length(s)]
+segments(x[s], y[s], x[s+2], y[s+2], col= 'pink')
+
+
+
+cleanEx()
+nameEx("smoothScatter")
+### * smoothScatter
+
+flush(stderr()); flush(stdout())
+
+### Name: smoothScatter
+### Title: Scatterplots with Smoothed Densities Color Representation
+### Aliases: smoothScatter
+### Keywords: hplot
+
+### ** Examples
+
+
+cleanEx()
+nameEx("spineplot")
+### * spineplot
+
+flush(stderr()); flush(stdout())
+
+### Name: spineplot
+### Title: Spine Plots and Spinograms
+### Aliases: spineplot spineplot.default spineplot.formula
+### Keywords: hplot
+
+### ** Examples
+
+## treatment and improvement of patients with rheumatoid arthritis
+treatment <- factor(rep(c(1, 2), c(43, 41)), levels = c(1, 2),
+ labels = c("placebo", "treated"))
+improved <- factor(rep(c(1, 2, 3, 1, 2, 3), c(29, 7, 7, 13, 7, 21)),
+ levels = c(1, 2, 3),
+ labels = c("none", "some", "marked"))
+
+## (dependence on a categorical variable)
+(spineplot(improved ~ treatment))
+
+## applications and admissions by department at UC Berkeley
+## (two-way tables)
+(spineplot(margin.table(UCBAdmissions, c(3, 2)),
+ main = "Applications at UCB"))
+(spineplot(margin.table(UCBAdmissions, c(3, 1)),
+ main = "Admissions at UCB"))
+
+## NASA space shuttle o-ring failures
+fail <- factor(c(2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 2, 1, 2, 1,
+ 1, 1, 1, 2, 1, 1, 1, 1, 1),
+ levels = c(1, 2), labels = c("no", "yes"))
+temperature <- c(53, 57, 58, 63, 66, 67, 67, 67, 68, 69, 70, 70,
+ 70, 70, 72, 73, 75, 75, 76, 76, 78, 79, 81)
+
+## (dependence on a numerical variable)
+(spineplot(fail ~ temperature))
+(spineplot(fail ~ temperature, breaks = 3))
+(spineplot(fail ~ temperature, breaks = quantile(temperature)))
+
+## highlighting for failures
+spineplot(fail ~ temperature, ylevels = 2:1)
+
+
+
+cleanEx()
+nameEx("stars")
+### * stars
+
+flush(stderr()); flush(stdout())
+
+### Name: stars
+### Title: Star (Spider/Radar) Plots and Segment Diagrams
+### Aliases: stars
+### Keywords: hplot multivariate
+
+### ** Examples
+
+require(grDevices)
+stars(mtcars[, 1:7], key.loc = c(14, 2),
+ main = "Motor Trend Cars : stars(*, full = F)", full = FALSE)
+stars(mtcars[, 1:7], key.loc = c(14, 1.5),
+ main = "Motor Trend Cars : full stars()", flip.labels = FALSE)
+
+## 'Spider' or 'Radar' plot:
+stars(mtcars[, 1:7], locations = c(0, 0), radius = FALSE,
+ key.loc = c(0, 0), main = "Motor Trend Cars", lty = 2)
+
+## Segment Diagrams:
+palette(rainbow(12, s = 0.6, v = 0.75))
+stars(mtcars[, 1:7], len = 0.8, key.loc = c(12, 1.5),
+ main = "Motor Trend Cars", draw.segments = TRUE)
+stars(mtcars[, 1:7], len = 0.6, key.loc = c(1.5, 0),
+ main = "Motor Trend Cars", draw.segments = TRUE,
+ frame.plot = TRUE, nrow = 4, cex = .7)
+
+## scale linearly (not affinely) to [0, 1]
+USJudge <- apply(USJudgeRatings, 2, function(x) x/max(x))
+Jnam <- row.names(USJudgeRatings)
+Snam <- abbreviate(substring(Jnam, 1, regexpr("[,.]",Jnam) - 1), 7)
+stars(USJudge, labels = Jnam, scale = FALSE,
+ key.loc = c(13, 1.5), main = "Judge not ...", len = 0.8)
+stars(USJudge, labels = Snam, scale = FALSE,
+ key.loc = c(13, 1.5), radius = FALSE)
+
+loc <- stars(USJudge, labels = NULL, scale = FALSE,
+ radius = FALSE, frame.plot = TRUE,
+ key.loc = c(13, 1.5), main = "Judge not ...", len = 1.2)
+text(loc, Snam, col = "blue", cex = 0.8, xpd = TRUE)
+
+## 'Segments':
+stars(USJudge, draw.segments = TRUE, scale = FALSE, key.loc = c(13,1.5))
+
+## 'Spider':
+stars(USJudgeRatings, locations = c(0, 0), scale = FALSE, radius = FALSE,
+ col.stars = 1:10, key.loc = c(0, 0), main = "US Judges rated")
+## Same as above, but with colored lines instead of filled polygons.
+stars(USJudgeRatings, locations = c(0, 0), scale = FALSE, radius = FALSE,
+ col.lines = 1:10, key.loc = c(0, 0), main = "US Judges rated")
+## 'Radar-Segments'
+stars(USJudgeRatings[1:10,], locations = 0:1, scale = FALSE,
+ draw.segments = TRUE, col.segments = 0, col.stars = 1:10, key.loc = 0:1,
+ main = "US Judges 1-10 ")
+palette("default")
+stars(cbind(1:16, 10*(16:1)), draw.segments = TRUE,
+ main = "A Joke -- do *not* use symbols on 2D data!")
+
+
+
+cleanEx()
+nameEx("stem")
+### * stem
+
+flush(stderr()); flush(stdout())
+
+### Name: stem
+### Title: Stem-and-Leaf Plots
+### Aliases: stem
+### Keywords: univar distribution
+
+### ** Examples
+
+stem(islands)
+stem(log10(islands))
+
+
+
+cleanEx()
+nameEx("stripchart")
+### * stripchart
+
+flush(stderr()); flush(stdout())
+
+### Name: stripchart
+### Title: 1-D Scatter Plots
+### Aliases: stripchart stripchart.default stripchart.formula
+### Keywords: hplot
+
+### ** Examples
+
+x <- stats::rnorm(50)
+xr <- round(x, 1)
+stripchart(x) ; m <- mean(par("usr")[1:2])
+text(m, 1.04, "stripchart(x, \"overplot\")")
+stripchart(xr, method = "stack", add = TRUE, at = 1.2)
+text(m, 1.35, "stripchart(round(x,1), \"stack\")")
+stripchart(xr, method = "jitter", add = TRUE, at = 0.7)
+text(m, 0.85, "stripchart(round(x,1), \"jitter\")")
+
+stripchart(decrease ~ treatment,
+ main = "stripchart(OrchardSprays)",
+ vertical = TRUE, log = "y", data = OrchardSprays)
+
+stripchart(decrease ~ treatment, at = c(1:8)^2,
+ main = "stripchart(OrchardSprays)",
+ vertical = TRUE, log = "y", data = OrchardSprays)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("strwidth")
+### * strwidth
+
+flush(stderr()); flush(stdout())
+
+### Name: strwidth
+### Title: Plotting Dimensions of Character Strings and Math Expressions
+### Aliases: strwidth strheight
+### Keywords: dplot character
+
+### ** Examples
+
+str.ex <- c("W","w","I",".","WwI.")
+op <- par(pty = "s"); plot(1:100, 1:100, type = "n")
+sw <- strwidth(str.ex); sw
+all.equal(sum(sw[1:4]), sw[5])
+#- since the last string contains the others
+
+sw.i <- strwidth(str.ex, "inches"); 25.4 * sw.i # width in [mm]
+unique(sw / sw.i)
+# constant factor: 1 value
+mean(sw.i / strwidth(str.ex, "fig")) / par('fin')[1] # = 1: are the same
+
+## See how letters fall in classes
+## -- depending on graphics device and font!
+all.lett <- c(letters, LETTERS)
+shL <- strheight(all.lett, units = "inches") * 72 # 'big points'
+table(shL) # all have same heights ...
+mean(shL)/par("cin")[2] # around 0.6
+
+(swL <- strwidth(all.lett, units = "inches") * 72) # 'big points'
+split(all.lett, factor(round(swL, 2)))
+
+sumex <- expression(sum(x[i], i=1,n), e^{i * pi} == -1)
+strwidth(sumex)
+strheight(sumex)
+
+par(op) #- reset to previous setting
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("sunflowerplot")
+### * sunflowerplot
+
+flush(stderr()); flush(stdout())
+
+### Name: sunflowerplot
+### Title: Produce a Sunflower Scatter Plot
+### Aliases: sunflowerplot sunflowerplot.default sunflowerplot.formula
+### Keywords: hplot smooth nonparametric
+
+### ** Examples
+
+require(stats) # for rnorm
+require(grDevices)
+
+## 'number' is computed automatically:
+sunflowerplot(iris[, 3:4])
+## Imitating Chambers et al, p.109, closely:
+sunflowerplot(iris[, 3:4], cex = .2, cex.fact = 1, size = .035, seg.lwd = .8)
+## or
+sunflowerplot(Petal.Width ~ Petal.Length, data = iris,
+ cex = .2, cex.fact = 1, size = .035, seg.lwd = .8)
+
+
+sunflowerplot(x = sort(2*round(rnorm(100))), y = round(rnorm(100), 0),
+ main = "Sunflower Plot of Rounded N(0,1)")
+## Similarly using a "xyTable" argument:
+xyT <- xyTable(x = sort(2*round(rnorm(100))), y = round(rnorm(100), 0),
+ digits = 3)
+utils::str(xyT, vec.len = 20)
+sunflowerplot(xyT, main = "2nd Sunflower Plot of Rounded N(0,1)")
+
+## A 'marked point process' {explicit 'number' argument}:
+sunflowerplot(rnorm(100), rnorm(100), number = rpois(n = 100, lambda = 2),
+ main = "Sunflower plot (marked point process)",
+ rotate = TRUE, col = "blue4")
+
+
+
+cleanEx()
+nameEx("symbols")
+### * symbols
+
+flush(stderr()); flush(stdout())
+
+### Name: symbols
+### Title: Draw Symbols (Circles, Squares, Stars, Thermometers, Boxplots)
+### Aliases: symbols
+### Keywords: aplot hplot multivariate
+
+### ** Examples
+
+require(stats); require(grDevices)
+x <- 1:10
+y <- sort(10*runif(10))
+z <- runif(10)
+z3 <- cbind(z, 2*runif(10), runif(10))
+symbols(x, y, thermometers = cbind(.5, 1, z), inches = .5, fg = 1:10)
+symbols(x, y, thermometers = z3, inches = FALSE)
+text(x, y, apply(format(round(z3, digits = 2)), 1, paste, collapse = ","),
+ adj = c(-.2,0), cex = .75, col = "purple", xpd = NA)
+
+## Note that example(trees) shows more sensible plots!
+N <- nrow(trees)
+with(trees, {
+## Girth is diameter in inches
+symbols(Height, Volume, circles = Girth/24, inches = FALSE,
+ main = "Trees' Girth") # xlab and ylab automatically
+## Colours too:
+op <- palette(rainbow(N, end = 0.9))
+symbols(Height, Volume, circles = Girth/16, inches = FALSE, bg = 1:N,
+ fg = "gray30", main = "symbols(*, circles = Girth/16, bg = 1:N)")
+palette(op)
+})
+
+
+
+cleanEx()
+nameEx("title")
+### * title
+
+flush(stderr()); flush(stdout())
+
+### Name: title
+### Title: Plot Annotation
+### Aliases: title
+### Keywords: aplot
+
+### ** Examples
+
+plot(cars, main = "") # here, could use main directly
+title(main = "Stopping Distance versus Speed")
+
+plot(cars, main = "")
+title(main = list("Stopping Distance versus Speed", cex = 1.5,
+ col = "red", font = 3))
+
+## Specifying "..." :
+plot(1, col.axis = "sky blue", col.lab = "thistle")
+title("Main Title", sub = "sub title",
+ cex.main = 2, font.main= 4, col.main= "blue",
+ cex.sub = 0.75, font.sub = 3, col.sub = "red")
+
+
+x <- seq(-4, 4, len = 101)
+y <- cbind(sin(x), cos(x))
+matplot(x, y, type = "l", xaxt = "n",
+ main = expression(paste(plain(sin) * phi, " and ",
+ plain(cos) * phi)),
+ ylab = expression("sin" * phi, "cos" * phi), # only 1st is taken
+ xlab = expression(paste("Phase Angle ", phi)),
+ col.main = "blue")
+axis(1, at = c(-pi, -pi/2, 0, pi/2, pi),
+ labels = expression(-pi, -pi/2, 0, pi/2, pi))
+abline(h = 0, v = pi/2 * c(-1,1), lty = 2, lwd = .1, col = "gray70")
+
+
+
+cleanEx()
+nameEx("units")
+### * units
+
+flush(stderr()); flush(stdout())
+
+### Name: units
+### Title: Graphical Units
+### Aliases: xinch yinch xyinch
+### Keywords: dplot
+
+### ** Examples
+
+all(c(xinch(), yinch()) == xyinch()) # TRUE
+xyinch()
+xyinch #- to see that is really delta{"usr"} / "pin"
+
+## plot labels offset 0.12 inches to the right
+## of plotted symbols in a plot
+with(mtcars, {
+ plot(mpg, disp, pch = 19, main = "Motor Trend Cars")
+ text(mpg + xinch(0.12), disp, row.names(mtcars),
+ adj = 0, cex = .7, col = "blue")
+ })
+
+
+
+cleanEx()
+nameEx("xspline")
+### * xspline
+
+flush(stderr()); flush(stdout())
+
+### Name: xspline
+### Title: Draw an X-spline
+### Aliases: xspline
+### Keywords: aplot
+
+### ** Examples
+
+## based on examples in ?grid.xspline
+
+xsplineTest <- function(s, open = TRUE,
+ x = c(1,1,3,3)/4,
+ y = c(1,3,3,1)/4, ...) {
+ plot(c(0,1), c(0,1), type = "n", axes = FALSE, xlab = "", ylab = "")
+ points(x, y, pch = 19)
+ xspline(x, y, s, open, ...)
+ text(x+0.05*c(-1,-1,1,1), y+0.05*c(-1,1,1,-1), s)
+}
+op <- par(mfrow = c(3,3), mar = rep(0,4), oma = c(0,0,2,0))
+xsplineTest(c(0, -1, -1, 0))
+xsplineTest(c(0, -1, 0, 0))
+xsplineTest(c(0, -1, 1, 0))
+xsplineTest(c(0, 0, -1, 0))
+xsplineTest(c(0, 0, 0, 0))
+xsplineTest(c(0, 0, 1, 0))
+xsplineTest(c(0, 1, -1, 0))
+xsplineTest(c(0, 1, 0, 0))
+xsplineTest(c(0, 1, 1, 0))
+title("Open X-splines", outer = TRUE)
+
+par(mfrow = c(3,3), mar = rep(0,4), oma = c(0,0,2,0))
+xsplineTest(c(0, -1, -1, 0), FALSE, col = "grey80")
+xsplineTest(c(0, -1, 0, 0), FALSE, col = "grey80")
+xsplineTest(c(0, -1, 1, 0), FALSE, col = "grey80")
+xsplineTest(c(0, 0, -1, 0), FALSE, col = "grey80")
+xsplineTest(c(0, 0, 0, 0), FALSE, col = "grey80")
+xsplineTest(c(0, 0, 1, 0), FALSE, col = "grey80")
+xsplineTest(c(0, 1, -1, 0), FALSE, col = "grey80")
+xsplineTest(c(0, 1, 0, 0), FALSE, col = "grey80")
+xsplineTest(c(0, 1, 1, 0), FALSE, col = "grey80")
+title("Closed X-splines", outer = TRUE)
+
+par(op)
+
+x <- sort(stats::rnorm(5))
+y <- sort(stats::rnorm(5))
+plot(x, y, pch = 19)
+res <- xspline(x, y, 1, draw = FALSE)
+lines(res)
+## the end points may be very close together,
+## so use last few for direction
+nr <- length(res$x)
+arrows(res$x[1], res$y[1], res$x[4], res$y[4], code = 1, length = 0.1)
+arrows(res$x[nr-3], res$y[nr-3], res$x[nr], res$y[nr], code = 2, length = 0.1)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+### * <FOOTER>
+###
+options(digits = 7L)
+base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n")
+#grDevices::dev.off()
+###
+### Local variables: ***
+### mode: outline-minor ***
+### outline-regexp: "\\(> \\)?### [*]+" ***
+### End: ***
+quit('no')
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/Examples/stats-Ex.R b/com.oracle.truffle.r.native/gnur/tests/src/Examples/stats-Ex.R
new file mode 100644
index 0000000000000000000000000000000000000000..293e974c7b2ff9a85984c1e7a2743a77928c63ea
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/Examples/stats-Ex.R
@@ -0,0 +1,8838 @@
+pkgname <- "stats"
+source(file.path(R.home("share"), "R", "examples-header.R"))
+options(warn = 1)
+library('stats')
+
+base::assign(".oldSearch", base::search(), pos = 'CheckExEnv')
+cleanEx()
+nameEx("AIC")
+### * AIC
+
+flush(stderr()); flush(stdout())
+
+### Name: AIC
+### Title: Akaike's An Information Criterion
+### Aliases: AIC BIC
+### Keywords: models
+
+### ** Examples
+
+lm1 <- lm(Fertility ~ . , data = swiss)
+AIC(lm1)
+stopifnot(all.equal(AIC(lm1),
+ AIC(logLik(lm1))))
+BIC(lm1)
+
+lm2 <- update(lm1, . ~ . -Examination)
+AIC(lm1, lm2)
+BIC(lm1, lm2)
+
+
+
+cleanEx()
+nameEx("ARMAacf")
+### * ARMAacf
+
+flush(stderr()); flush(stdout())
+
+### Name: ARMAacf
+### Title: Compute Theoretical ACF for an ARMA Process
+### Aliases: ARMAacf
+### Keywords: ts
+
+### ** Examples
+
+ARMAacf(c(1.0, -0.25), 1.0, lag.max = 10)
+
+## Example from Brockwell & Davis (1991, pp.92-4)
+## answer: 2^(-n) * (32/3 + 8 * n) /(32/3)
+n <- 1:10
+a.n <- 2^(-n) * (32/3 + 8 * n) /(32/3)
+(A.n <- ARMAacf(c(1.0, -0.25), 1.0, lag.max = 10))
+stopifnot(all.equal(unname(A.n), c(1, a.n)))
+
+ARMAacf(c(1.0, -0.25), 1.0, lag.max = 10, pacf = TRUE)
+zapsmall(ARMAacf(c(1.0, -0.25), lag.max = 10, pacf = TRUE))
+
+## Cov-Matrix of length-7 sub-sample of AR(1) example:
+toeplitz(ARMAacf(0.8, lag.max = 7))
+
+
+
+cleanEx()
+nameEx("ARMAtoMA")
+### * ARMAtoMA
+
+flush(stderr()); flush(stdout())
+
+### Name: ARMAtoMA
+### Title: Convert ARMA Process to Infinite MA Process
+### Aliases: ARMAtoMA
+### Keywords: ts
+
+### ** Examples
+
+ARMAtoMA(c(1.0, -0.25), 1.0, 10)
+## Example from Brockwell & Davis (1991, p.92)
+## answer (1 + 3*n)*2^(-n)
+n <- 1:10; (1 + 3*n)*2^(-n)
+
+
+
+cleanEx()
+nameEx("Beta")
+### * Beta
+
+flush(stderr()); flush(stdout())
+
+### Name: Beta
+### Title: The Beta Distribution
+### Aliases: Beta dbeta pbeta qbeta rbeta
+### Keywords: distribution
+
+### ** Examples
+
+x <- seq(0, 1, length = 21)
+dbeta(x, 1, 1)
+pbeta(x, 1, 1)
+
+## Visualization, including limit cases:
+pl.beta <- function(a,b, asp = if(isLim) 1, ylim = if(isLim) c(0,1.1)) {
+ if(isLim <- a == 0 || b == 0 || a == Inf || b == Inf) {
+ eps <- 1e-10
+ x <- c(0, eps, (1:7)/16, 1/2+c(-eps,0,eps), (9:15)/16, 1-eps, 1)
+ } else {
+ x <- seq(0, 1, length = 1025)
+ }
+ fx <- cbind(dbeta(x, a,b), pbeta(x, a,b), qbeta(x, a,b))
+ f <- fx; f[fx == Inf] <- 1e100
+ matplot(x, f, ylab="", type="l", ylim=ylim, asp=asp,
+ main = sprintf("[dpq]beta(x, a=%g, b=%g)", a,b))
+ abline(0,1, col="gray", lty=3)
+ abline(h = 0:1, col="gray", lty=3)
+ legend("top", paste0(c("d","p","q"), "beta(x, a,b)"),
+ col=1:3, lty=1:3, bty = "n")
+ invisible(cbind(x, fx))
+}
+pl.beta(3,1)
+
+pl.beta(2, 4)
+pl.beta(3, 7)
+pl.beta(3, 7, asp=1)
+
+pl.beta(0, 0) ## point masses at {0, 1}
+
+pl.beta(0, 2) ## point mass at 0 ; the same as
+pl.beta(1, Inf)
+
+pl.beta(Inf, 2) ## point mass at 1 ; the same as
+pl.beta(3, 0)
+
+pl.beta(Inf, Inf)# point mass at 1/2
+
+
+
+cleanEx()
+nameEx("Binomial")
+### * Binomial
+
+flush(stderr()); flush(stdout())
+
+### Name: Binomial
+### Title: The Binomial Distribution
+### Aliases: Binomial dbinom pbinom qbinom rbinom
+### Keywords: distribution
+
+### ** Examples
+
+require(graphics)
+# Compute P(45 < X < 55) for X Binomial(100,0.5)
+sum(dbinom(46:54, 100, 0.5))
+
+## Using "log = TRUE" for an extended range :
+n <- 2000
+k <- seq(0, n, by = 20)
+plot (k, dbinom(k, n, pi/10, log = TRUE), type = "l", ylab = "log density",
+ main = "dbinom(*, log=TRUE) is better than log(dbinom(*))")
+lines(k, log(dbinom(k, n, pi/10)), col = "red", lwd = 2)
+## extreme points are omitted since dbinom gives 0.
+mtext("dbinom(k, log=TRUE)", adj = 0)
+mtext("extended range", adj = 0, line = -1, font = 4)
+mtext("log(dbinom(k))", col = "red", adj = 1)
+
+
+
+cleanEx()
+nameEx("Cauchy")
+### * Cauchy
+
+flush(stderr()); flush(stdout())
+
+### Name: Cauchy
+### Title: The Cauchy Distribution
+### Aliases: Cauchy dcauchy pcauchy qcauchy rcauchy
+### Keywords: distribution
+
+### ** Examples
+
+dcauchy(-1:4)
+
+
+
+cleanEx()
+nameEx("Chisquare")
+### * Chisquare
+
+flush(stderr()); flush(stdout())
+
+### Name: Chisquare
+### Title: The (non-central) Chi-Squared Distribution
+### Aliases: Chisquare dchisq pchisq qchisq rchisq
+### Keywords: distribution
+
+### ** Examples
+
+require(graphics)
+
+dchisq(1, df = 1:3)
+pchisq(1, df = 3)
+pchisq(1, df = 3, ncp = 0:4) # includes the above
+
+x <- 1:10
+## Chi-squared(df = 2) is a special exponential distribution
+all.equal(dchisq(x, df = 2), dexp(x, 1/2))
+all.equal(pchisq(x, df = 2), pexp(x, 1/2))
+
+## non-central RNG -- df = 0 with ncp > 0: Z0 has point mass at 0!
+Z0 <- rchisq(100, df = 0, ncp = 2.)
+graphics::stem(Z0)
+
+
+## "analytical" test
+lam <- seq(0, 100, by = .25)
+p00 <- pchisq(0, df = 0, ncp = lam)
+p.0 <- pchisq(1e-300, df = 0, ncp = lam)
+stopifnot(all.equal(p00, exp(-lam/2)),
+ all.equal(p.0, exp(-lam/2)))
+
+
+
+cleanEx()
+nameEx("Exponential")
+### * Exponential
+
+flush(stderr()); flush(stdout())
+
+### Name: Exponential
+### Title: The Exponential Distribution
+### Aliases: Exponential dexp pexp qexp rexp
+### Keywords: distribution
+
+### ** Examples
+
+dexp(1) - exp(-1) #-> 0
+
+## a fast way to generate *sorted* U[0,1] random numbers:
+rsunif <- function(n) { n1 <- n+1
+ cE <- cumsum(rexp(n1)); cE[seq_len(n)]/cE[n1] }
+plot(rsunif(1000), ylim=0:1, pch=".")
+abline(0,1/(1000+1), col=adjustcolor(1, 0.5))
+
+
+
+cleanEx()
+nameEx("Fdist")
+### * Fdist
+
+flush(stderr()); flush(stdout())
+
+### Name: FDist
+### Title: The F Distribution
+### Aliases: FDist df pf qf rf
+### Keywords: distribution
+
+### ** Examples
+
+## Equivalence of pt(.,nu) with pf(.^2, 1,nu):
+x <- seq(0.001, 5, len = 100)
+nu <- 4
+stopifnot(all.equal(2*pt(x,nu) - 1, pf(x^2, 1,nu)),
+ ## upper tails:
+ all.equal(2*pt(x, nu, lower=FALSE),
+ pf(x^2, 1,nu, lower=FALSE)))
+
+## the density of the square of a t_m is 2*dt(x, m)/(2*x)
+# check this is the same as the density of F_{1,m}
+all.equal(df(x^2, 1, 5), dt(x, 5)/x)
+
+## Identity: qf(2*p - 1, 1, df)) == qt(p, df)^2) for p >= 1/2
+p <- seq(1/2, .99, length = 50); df <- 10
+rel.err <- function(x, y) ifelse(x == y, 0, abs(x-y)/mean(abs(c(x,y))))
+
+
+
+cleanEx()
+nameEx("GammaDist")
+### * GammaDist
+
+flush(stderr()); flush(stdout())
+
+### Name: GammaDist
+### Title: The Gamma Distribution
+### Aliases: GammaDist dgamma pgamma qgamma rgamma
+### Keywords: distribution
+
+### ** Examples
+
+-log(dgamma(1:4, shape = 1))
+p <- (1:9)/10
+pgamma(qgamma(p, shape = 2), shape = 2)
+1 - 1/exp(qgamma(p, shape = 1))
+
+
+
+cleanEx()
+nameEx("Geometric")
+### * Geometric
+
+flush(stderr()); flush(stdout())
+
+### Name: Geometric
+### Title: The Geometric Distribution
+### Aliases: Geometric dgeom pgeom qgeom rgeom
+### Keywords: distribution
+
+### ** Examples
+
+qgeom((1:9)/10, prob = .2)
+Ni <- rgeom(20, prob = 1/4); table(factor(Ni, 0:max(Ni)))
+
+
+
+cleanEx()
+nameEx("HoltWinters")
+### * HoltWinters
+
+flush(stderr()); flush(stdout())
+
+### Name: HoltWinters
+### Title: Holt-Winters Filtering
+### Aliases: HoltWinters print.HoltWinters residuals.HoltWinters
+### Keywords: ts
+
+### ** Examples
+
+## Don't show:
+od <- options(digits = 5)
+## End(Don't show)
+require(graphics)
+
+## Seasonal Holt-Winters
+(m <- HoltWinters(co2))
+plot(m)
+plot(fitted(m))
+
+(m <- HoltWinters(AirPassengers, seasonal = "mult"))
+plot(m)
+
+## Non-Seasonal Holt-Winters
+x <- uspop + rnorm(uspop, sd = 5)
+m <- HoltWinters(x, gamma = FALSE)
+plot(m)
+
+## Exponential Smoothing
+m2 <- HoltWinters(x, gamma = FALSE, beta = FALSE)
+lines(fitted(m2)[,1], col = 3)
+## Don't show:
+options(od)
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("Hypergeometric")
+### * Hypergeometric
+
+flush(stderr()); flush(stdout())
+
+### Name: Hypergeometric
+### Title: The Hypergeometric Distribution
+### Aliases: Hypergeometric dhyper phyper qhyper rhyper
+### Keywords: distribution
+
+### ** Examples
+
+m <- 10; n <- 7; k <- 8
+x <- 0:(k+1)
+rbind(phyper(x, m, n, k), dhyper(x, m, n, k))
+all(phyper(x, m, n, k) == cumsum(dhyper(x, m, n, k))) # FALSE
+
+
+cleanEx()
+nameEx("IQR")
+### * IQR
+
+flush(stderr()); flush(stdout())
+
+### Name: IQR
+### Title: The Interquartile Range
+### Aliases: IQR
+### Keywords: univar robust distribution
+
+### ** Examples
+
+IQR(rivers)
+
+
+
+cleanEx()
+nameEx("KalmanLike")
+### * KalmanLike
+
+flush(stderr()); flush(stdout())
+
+### Name: KalmanLike
+### Title: Kalman Filtering
+### Aliases: KalmanLike KalmanRun KalmanSmooth KalmanForecast makeARIMA
+### Keywords: ts
+
+### ** Examples
+
+## an ARIMA fit
+fit3 <- arima(presidents, c(3, 0, 0))
+predict(fit3, 12)
+## reconstruct this
+pr <- KalmanForecast(12, fit3$model)
+pr$pred + fit3$coef[4]
+sqrt(pr$var * fit3$sigma2)
+## and now do it year by year
+mod <- fit3$model
+for(y in 1:3) {
+ pr <- KalmanForecast(4, mod, TRUE)
+ print(list(pred = pr$pred + fit3$coef["intercept"],
+ se = sqrt(pr$var * fit3$sigma2)))
+ mod <- attr(pr, "mod")
+}
+
+
+
+cleanEx()
+nameEx("Logistic")
+### * Logistic
+
+flush(stderr()); flush(stdout())
+
+### Name: Logistic
+### Title: The Logistic Distribution
+### Aliases: Logistic dlogis plogis qlogis rlogis
+### Keywords: distribution
+
+### ** Examples
+
+var(rlogis(4000, 0, scale = 5)) # approximately (+/- 3)
+pi^2/3 * 5^2
+
+
+
+cleanEx()
+nameEx("Lognormal")
+### * Lognormal
+
+flush(stderr()); flush(stdout())
+
+### Name: Lognormal
+### Title: The Log Normal Distribution
+### Aliases: Lognormal dlnorm plnorm qlnorm rlnorm
+### Keywords: distribution
+
+### ** Examples
+
+dlnorm(1) == dnorm(0)
+
+
+
+cleanEx()
+nameEx("Multinom")
+### * Multinom
+
+flush(stderr()); flush(stdout())
+
+### Name: Multinom
+### Title: The Multinomial Distribution
+### Aliases: Multinomial rmultinom dmultinom
+### Keywords: distribution
+
+### ** Examples
+
+rmultinom(10, size = 12, prob = c(0.1,0.2,0.8))
+
+pr <- c(1,3,6,10) # normalization not necessary for generation
+rmultinom(10, 20, prob = pr)
+
+## all possible outcomes of Multinom(N = 3, K = 3)
+X <- t(as.matrix(expand.grid(0:3, 0:3))); X <- X[, colSums(X) <= 3]
+X <- rbind(X, 3:3 - colSums(X)); dimnames(X) <- list(letters[1:3], NULL)
+X
+round(apply(X, 2, function(x) dmultinom(x, prob = c(1,2,5))), 3)
+
+
+
+cleanEx()
+nameEx("NLSstAsymptotic")
+### * NLSstAsymptotic
+
+flush(stderr()); flush(stdout())
+
+### Name: NLSstAsymptotic
+### Title: Fit the Asymptotic Regression Model
+### Aliases: NLSstAsymptotic NLSstAsymptotic.sortedXyData
+### Keywords: manip
+
+### ** Examples
+
+Lob.329 <- Loblolly[ Loblolly$Seed == "329", ]
+print(NLSstAsymptotic(sortedXyData(expression(age),
+ expression(height),
+ Lob.329)), digits = 3)
+
+
+
+cleanEx()
+nameEx("NLSstClosestX")
+### * NLSstClosestX
+
+flush(stderr()); flush(stdout())
+
+### Name: NLSstClosestX
+### Title: Inverse Interpolation
+### Aliases: NLSstClosestX NLSstClosestX.sortedXyData
+### Keywords: manip
+
+### ** Examples
+
+DNase.2 <- DNase[ DNase$Run == "2", ]
+DN.srt <- sortedXyData(expression(log(conc)), expression(density), DNase.2)
+NLSstClosestX(DN.srt, 1.0)
+
+
+
+cleanEx()
+nameEx("NLSstLfAsymptote")
+### * NLSstLfAsymptote
+
+flush(stderr()); flush(stdout())
+
+### Name: NLSstLfAsymptote
+### Title: Horizontal Asymptote on the Left Side
+### Aliases: NLSstLfAsymptote NLSstLfAsymptote.sortedXyData
+### Keywords: manip
+
+### ** Examples
+
+DNase.2 <- DNase[ DNase$Run == "2", ]
+DN.srt <- sortedXyData( expression(log(conc)), expression(density), DNase.2 )
+NLSstLfAsymptote( DN.srt )
+
+
+
+cleanEx()
+nameEx("NLSstRtAsymptote")
+### * NLSstRtAsymptote
+
+flush(stderr()); flush(stdout())
+
+### Name: NLSstRtAsymptote
+### Title: Horizontal Asymptote on the Right Side
+### Aliases: NLSstRtAsymptote NLSstRtAsymptote.sortedXyData
+### Keywords: manip
+
+### ** Examples
+
+DNase.2 <- DNase[ DNase$Run == "2", ]
+DN.srt <- sortedXyData( expression(log(conc)), expression(density), DNase.2 )
+NLSstRtAsymptote( DN.srt )
+
+
+
+cleanEx()
+nameEx("NegBinomial")
+### * NegBinomial
+
+flush(stderr()); flush(stdout())
+
+### Name: NegBinomial
+### Title: The Negative Binomial Distribution
+### Aliases: NegBinomial dnbinom pnbinom qnbinom rnbinom
+### Keywords: distribution
+
+### ** Examples
+
+require(graphics)
+x <- 0:11
+dnbinom(x, size = 1, prob = 1/2) * 2^(1 + x) # == 1
+126 / dnbinom(0:8, size = 2, prob = 1/2) #- theoretically integer
+
+
+x <- 0:15
+size <- (1:20)/4
+persp(x, size, dnb <- outer(x, size, function(x,s) dnbinom(x, s, prob = 0.4)),
+ xlab = "x", ylab = "s", zlab = "density", theta = 150)
+title(tit <- "negative binomial density(x,s, pr = 0.4) vs. x & s")
+
+image (x, size, log10(dnb), main = paste("log [", tit, "]"))
+contour(x, size, log10(dnb), add = TRUE)
+
+## Alternative parametrization
+x1 <- rnbinom(500, mu = 4, size = 1)
+x2 <- rnbinom(500, mu = 4, size = 10)
+x3 <- rnbinom(500, mu = 4, size = 100)
+h1 <- hist(x1, breaks = 20, plot = FALSE)
+h2 <- hist(x2, breaks = h1$breaks, plot = FALSE)
+h3 <- hist(x3, breaks = h1$breaks, plot = FALSE)
+barplot(rbind(h1$counts, h2$counts, h3$counts),
+ beside = TRUE, col = c("red","blue","cyan"),
+ names.arg = round(h1$breaks[-length(h1$breaks)]))
+
+
+
+cleanEx()
+nameEx("Normal")
+### * Normal
+
+flush(stderr()); flush(stdout())
+
+### Name: Normal
+### Title: The Normal Distribution
+### Aliases: Normal dnorm pnorm qnorm rnorm
+### Keywords: distribution
+
+### ** Examples
+
+require(graphics)
+
+dnorm(0) == 1/sqrt(2*pi)
+dnorm(1) == exp(-1/2)/sqrt(2*pi)
+dnorm(1) == 1/sqrt(2*pi*exp(1))
+
+## Using "log = TRUE" for an extended range :
+par(mfrow = c(2,1))
+plot(function(x) dnorm(x, log = TRUE), -60, 50,
+ main = "log { Normal density }")
+curve(log(dnorm(x)), add = TRUE, col = "red", lwd = 2)
+mtext("dnorm(x, log=TRUE)", adj = 0)
+mtext("log(dnorm(x))", col = "red", adj = 1)
+
+plot(function(x) pnorm(x, log.p = TRUE), -50, 10,
+ main = "log { Normal Cumulative }")
+curve(log(pnorm(x)), add = TRUE, col = "red", lwd = 2)
+mtext("pnorm(x, log=TRUE)", adj = 0)
+mtext("log(pnorm(x))", col = "red", adj = 1)
+
+## if you want the so-called 'error function'
+erf <- function(x) 2 * pnorm(x * sqrt(2)) - 1
+## (see Abramowitz and Stegun 29.2.29)
+## and the so-called 'complementary error function'
+erfc <- function(x) 2 * pnorm(x * sqrt(2), lower = FALSE)
+## and the inverses
+erfinv <- function (x) qnorm((1 + x)/2)/sqrt(2)
+erfcinv <- function (x) qnorm(x/2, lower = FALSE)/sqrt(2)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("Poisson")
+### * Poisson
+
+flush(stderr()); flush(stdout())
+
+### Name: Poisson
+### Title: The Poisson Distribution
+### Aliases: Poisson dpois ppois qpois rpois
+### Keywords: distribution
+
+### ** Examples
+
+require(graphics)
+
+-log(dpois(0:7, lambda = 1) * gamma(1+ 0:7)) # == 1
+Ni <- rpois(50, lambda = 4); table(factor(Ni, 0:max(Ni)))
+
+1 - ppois(10*(15:25), lambda = 100) # becomes 0 (cancellation)
+ ppois(10*(15:25), lambda = 100, lower.tail = FALSE) # no cancellation
+
+par(mfrow = c(2, 1))
+x <- seq(-0.01, 5, 0.01)
+plot(x, ppois(x, 1), type = "s", ylab = "F(x)", main = "Poisson(1) CDF")
+plot(x, pbinom(x, 100, 0.01), type = "s", ylab = "F(x)",
+ main = "Binomial(100, 0.01) CDF")
+
+## The (limit) case lambda = 0 :
+stopifnot(identical(dpois(0,0), 1),
+ identical(ppois(0,0), 1),
+ identical(qpois(1,0), 0))
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("SSD")
+### * SSD
+
+flush(stderr()); flush(stdout())
+
+### Name: SSD
+### Title: SSD Matrix and Estimated Variance Matrix in Multivariate Models
+### Aliases: SSD estVar
+### Keywords: models multivariate
+
+### ** Examples
+
+# Lifted from Baron+Li:
+# "Notes on the use of R for psychology experiments and questionnaires"
+# Maxwell and Delaney, p. 497
+reacttime <- matrix(c(
+420, 420, 480, 480, 600, 780,
+420, 480, 480, 360, 480, 600,
+480, 480, 540, 660, 780, 780,
+420, 540, 540, 480, 780, 900,
+540, 660, 540, 480, 660, 720,
+360, 420, 360, 360, 480, 540,
+480, 480, 600, 540, 720, 840,
+480, 600, 660, 540, 720, 900,
+540, 600, 540, 480, 720, 780,
+480, 420, 540, 540, 660, 780),
+ncol = 6, byrow = TRUE,
+dimnames = list(subj = 1:10,
+ cond = c("deg0NA", "deg4NA", "deg8NA",
+ "deg0NP", "deg4NP", "deg8NP")))
+
+mlmfit <- lm(reacttime ~ 1)
+SSD(mlmfit)
+estVar(mlmfit)
+
+
+
+cleanEx()
+nameEx("SSasymp")
+### * SSasymp
+
+flush(stderr()); flush(stdout())
+
+### Name: SSasymp
+### Title: Self-Starting Nls Asymptotic Regression Model
+### Aliases: SSasymp
+### Keywords: models
+
+### ** Examples
+
+## Don't show:
+options(show.nls.convergence=FALSE)
+## End(Don't show)
+Lob.329 <- Loblolly[ Loblolly$Seed == "329", ]
+SSasymp( Lob.329$age, 100, -8.5, -3.2 ) # response only
+Asym <- 100
+resp0 <- -8.5
+lrc <- -3.2
+SSasymp( Lob.329$age, Asym, resp0, lrc ) # response and gradient
+getInitial(height ~ SSasymp( age, Asym, resp0, lrc), data = Lob.329)
+## Initial values are in fact the converged values
+fm1 <- nls(height ~ SSasymp( age, Asym, resp0, lrc), data = Lob.329)
+summary(fm1)
+## Don't show:
+require(graphics)
+
+ xx <- seq(0, 5, len = 101)
+ yy <- 5 - 4 * exp(-xx/(2*log(2)))
+ par(mar = c(0, 0, 4.1, 0))
+ plot(xx, yy, type = "l", axes = FALSE, ylim = c(0,6), xlim = c(-1, 5),
+ xlab = "", ylab = "", lwd = 2,
+ main = "Parameters in the SSasymp model")
+ usr <- par("usr")
+ arrows(usr[1], 0, usr[2], 0, length = 0.1, angle = 25)
+ arrows(0, usr[3], 0, usr[4], length = 0.1, angle = 25)
+ text(usr[2] - 0.2, 0.1, "x", adj = c(1, 0))
+ text(-0.1, usr[4], "y", adj = c(1, 1))
+ abline(h = 5, lty = 2, lwd = 0)
+ arrows(-0.8, 2.1, -0.8, 0, length = 0.1, angle = 25)
+ arrows(-0.8, 2.9, -0.8, 5, length = 0.1, angle = 25)
+ text(-0.8, 2.5, expression(phi[1]), adj = c(0.5, 0.5))
+ segments(-0.4, 1, 0, 1, lty = 2, lwd = 0.75)
+ arrows(-0.3, 0.25, -0.3, 0, length = 0.07, angle = 25)
+ arrows(-0.3, 0.75, -0.3, 1, length = 0.07, angle = 25)
+ text(-0.3, 0.5, expression(phi[2]), adj = c(0.5, 0.5))
+ segments(1, 3.025, 1, 4, lty = 2, lwd = 0.75)
+ arrows(0.2, 3.5, 0, 3.5, length = 0.08, angle = 25)
+ arrows(0.8, 3.5, 1, 3.5, length = 0.08, angle = 25)
+ text(0.5, 3.5, expression(t[0.5]), adj = c(0.5, 0.5))
+## End(Don't show)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("SSasympOff")
+### * SSasympOff
+
+flush(stderr()); flush(stdout())
+
+### Name: SSasympOff
+### Title: Self-Starting Nls Asymptotic Regression Model with an Offset
+### Aliases: SSasympOff
+### Keywords: models
+
+### ** Examples
+
+CO2.Qn1 <- CO2[CO2$Plant == "Qn1", ]
+SSasympOff(CO2.Qn1$conc, 32, -4, 43) # response only
+Asym <- 32; lrc <- -4; c0 <- 43
+SSasympOff(CO2.Qn1$conc, Asym, lrc, c0) # response and gradient
+getInitial(uptake ~ SSasympOff(conc, Asym, lrc, c0), data = CO2.Qn1)
+## Initial values are in fact the converged values
+fm1 <- nls(uptake ~ SSasympOff(conc, Asym, lrc, c0), data = CO2.Qn1)
+summary(fm1)
+## Don't show:
+require(graphics)
+
+ xx <- seq(0.5, 5, len = 101)
+ yy <- 5 * (1 - exp(-(xx - 0.5)/(2*log(2))))
+ par(mar = c(0, 0, 4.0, 0))
+ plot(xx, yy, type = "l", axes = FALSE, ylim = c(0,6), xlim = c(-1, 5),
+ xlab = "", ylab = "", lwd = 2,
+ main = "Parameters in the SSasympOff model")
+ usr <- par("usr")
+ arrows(usr[1], 0, usr[2], 0, length = 0.1, angle = 25)
+ arrows(0, usr[3], 0, usr[4], length = 0.1, angle = 25)
+ text(usr[2] - 0.2, 0.1, "x", adj = c(1, 0))
+ text(-0.1, usr[4], "y", adj = c(1, 1))
+ abline(h = 5, lty = 2, lwd = 0)
+ arrows(-0.8, 2.1, -0.8, 0, length = 0.1, angle = 25)
+ arrows(-0.8, 2.9, -0.8, 5, length = 0.1, angle = 25)
+ text(-0.8, 2.5, expression(phi[1]), adj = c(0.5, 0.5))
+ segments(0.5, 0, 0.5, 3, lty = 2, lwd = 0.75)
+ text(0.5, 3.1, expression(phi[3]), adj = c(0.5, 0))
+ segments(1.5, 2.525, 1.5, 3, lty = 2, lwd = 0.75)
+ arrows(0.7, 2.65, 0.5, 2.65, length = 0.08, angle = 25)
+ arrows(1.3, 2.65, 1.5, 2.65, length = 0.08, angle = 25)
+ text(1.0, 2.65, expression(t[0.5]), adj = c(0.5, 0.5))
+## End(Don't show)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("SSasympOrig")
+### * SSasympOrig
+
+flush(stderr()); flush(stdout())
+
+### Name: SSasympOrig
+### Title: Self-Starting Nls Asymptotic Regression Model through the Origin
+### Aliases: SSasympOrig
+### Keywords: models
+
+### ** Examples
+## Don't show:
+require(graphics)
+
+ xx <- seq(0, 5, len = 101)
+ yy <- 5 * (1- exp(-xx/(2*log(2))))
+ par(mar = c(0, 0, 3.5, 0))
+ plot(xx, yy, type = "l", axes = FALSE, ylim = c(0,6), xlim = c(-1, 5),
+ xlab = "", ylab = "", lwd = 2,
+ main = "Parameters in the SSasympOrig model")
+ usr <- par("usr")
+ arrows(usr[1], 0, usr[2], 0, length = 0.1, angle = 25)
+ arrows(0, usr[3], 0, usr[4], length = 0.1, angle = 25)
+ text(usr[2] - 0.2, 0.1, "x", adj = c(1, 0))
+ text(-0.1, usr[4], "y", adj = c(1, 1))
+ abline(h = 5, lty = 2, lwd = 0)
+ arrows(-0.8, 2.1, -0.8, 0, length = 0.1, angle = 25)
+ arrows(-0.8, 2.9, -0.8, 5, length = 0.1, angle = 25)
+ text(-0.8, 2.5, expression(phi[1]), adj = c(0.5, 0.5))
+ segments(1, 2.525, 1, 3.5, lty = 2, lwd = 0.75)
+ arrows(0.2, 3.0, 0, 3.0, length = 0.08, angle = 25)
+ arrows(0.8, 3.0, 1, 3.0, length = 0.08, angle = 25)
+ text(0.5, 3.0, expression(t[0.5]), adj = c(0.5, 0.5))
+## End(Don't show)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("SSbiexp")
+### * SSbiexp
+
+flush(stderr()); flush(stdout())
+
+### Name: SSbiexp
+### Title: Self-Starting Nls Biexponential model
+### Aliases: SSbiexp
+### Keywords: models
+
+### ** Examples
+
+Indo.1 <- Indometh[Indometh$Subject == 1, ]
+SSbiexp( Indo.1$time, 3, 1, 0.6, -1.3 ) # response only
+A1 <- 3; lrc1 <- 1; A2 <- 0.6; lrc2 <- -1.3
+SSbiexp( Indo.1$time, A1, lrc1, A2, lrc2 ) # response and gradient
+print(getInitial(conc ~ SSbiexp(time, A1, lrc1, A2, lrc2), data = Indo.1),
+ digits = 5)
+## Initial values are in fact the converged values
+fm1 <- nls(conc ~ SSbiexp(time, A1, lrc1, A2, lrc2), data = Indo.1)
+summary(fm1)
+
+## Show the model components visually
+ require(graphics)
+
+ xx <- seq(0, 5, len = 101)
+ y1 <- 3.5 * exp(-4*xx)
+ y2 <- 1.5 * exp(-xx)
+ plot(xx, y1 + y2, type = "l", lwd=2, ylim = c(-0.2,6), xlim = c(0, 5),
+ main = "Components of the SSbiexp model")
+ lines(xx, y1, lty = 2, col="tomato"); abline(v=0, h=0, col="gray40")
+ lines(xx, y2, lty = 3, col="blue2" )
+ legend("topright", c("y1+y2", "y1 = 3.5 * exp(-4*x)", "y2 = 1.5 * exp(-x)"),
+ lty=1:3, col=c("black","tomato","blue2"), bty="n")
+ axis(2, pos=0, at = c(3.5, 1.5), labels = c("A1","A2"), las=2)
+
+## and how you could have got their sum via SSbiexp():
+ ySS <- SSbiexp(xx, 3.5, log(4), 1.5, log(1))
+ ## --- ---
+ stopifnot(all.equal(y1+y2, ySS, tolerance = 1e-15))
+
+
+
+cleanEx()
+nameEx("SSfol")
+### * SSfol
+
+flush(stderr()); flush(stdout())
+
+### Name: SSfol
+### Title: Self-Starting Nls First-order Compartment Model
+### Aliases: SSfol
+### Keywords: models
+
+### ** Examples
+
+Theoph.1 <- Theoph[ Theoph$Subject == 1, ]
+SSfol(Theoph.1$Dose, Theoph.1$Time, -2.5, 0.5, -3) # response only
+lKe <- -2.5; lKa <- 0.5; lCl <- -3
+SSfol(Theoph.1$Dose, Theoph.1$Time, lKe, lKa, lCl) # response and gradient
+getInitial(conc ~ SSfol(Dose, Time, lKe, lKa, lCl), data = Theoph.1)
+## Initial values are in fact the converged values
+fm1 <- nls(conc ~ SSfol(Dose, Time, lKe, lKa, lCl), data = Theoph.1)
+summary(fm1)
+
+
+
+cleanEx()
+nameEx("SSfpl")
+### * SSfpl
+
+flush(stderr()); flush(stdout())
+
+### Name: SSfpl
+### Title: Self-Starting Nls Four-Parameter Logistic Model
+### Aliases: SSfpl
+### Keywords: models
+
+### ** Examples
+
+Chick.1 <- ChickWeight[ChickWeight$Chick == 1, ]
+SSfpl(Chick.1$Time, 13, 368, 14, 6) # response only
+A <- 13; B <- 368; xmid <- 14; scal <- 6
+SSfpl(Chick.1$Time, A, B, xmid, scal) # response and gradient
+print(getInitial(weight ~ SSfpl(Time, A, B, xmid, scal), data = Chick.1),
+ digits = 5)
+## Initial values are in fact the converged values
+fm1 <- nls(weight ~ SSfpl(Time, A, B, xmid, scal), data = Chick.1)
+summary(fm1)
+## Don't show:
+require(graphics)
+
+ xx <- seq(-0.5, 5, len = 101)
+ yy <- 1 + 4 / ( 1 + exp((2-xx)))
+ par(mar = c(0, 0, 3.5, 0))
+ plot(xx, yy, type = "l", axes = FALSE, ylim = c(0,6), xlim = c(-1, 5),
+ xlab = "", ylab = "", lwd = 2,
+ main = "Parameters in the SSfpl model")
+ usr <- par("usr")
+ arrows(usr[1], 0, usr[2], 0, length = 0.1, angle = 25)
+ arrows(0, usr[3], 0, usr[4], length = 0.1, angle = 25)
+ text(usr[2] - 0.2, 0.1, "x", adj = c(1, 0))
+ text(-0.1, usr[4], "y", adj = c(1, 1))
+ abline(h = 5, lty = 2, lwd = 0)
+ arrows(-0.8, 2.1, -0.8, 0, length = 0.1, angle = 25)
+ arrows(-0.8, 2.9, -0.8, 5, length = 0.1, angle = 25)
+ text(-0.8, 2.5, expression(phi[1]), adj = c(0.5, 0.5))
+ abline(h = 1, lty = 2, lwd = 0)
+ arrows(-0.3, 0.25, -0.3, 0, length = 0.07, angle = 25)
+ arrows(-0.3, 0.75, -0.3, 1, length = 0.07, angle = 25)
+ text(-0.3, 0.5, expression(phi[2]), adj = c(0.5, 0.5))
+ segments(2, 0, 2, 3.3, lty = 2, lwd = 0.75)
+ text(2, 3.3, expression(phi[3]), adj = c(0.5, 0))
+ segments(3, 1+4/(1+exp(-1)) - 0.025, 3, 2.5, lty = 2, lwd = 0.75)
+ arrows(2.3, 2.7, 2.0, 2.7, length = 0.08, angle = 25)
+ arrows(2.7, 2.7, 3.0, 2.7, length = 0.08, angle = 25)
+ text(2.5, 2.7, expression(phi[4]), adj = c(0.5, 0.5))
+## End(Don't show)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("SSgompertz")
+### * SSgompertz
+
+flush(stderr()); flush(stdout())
+
+### Name: SSgompertz
+### Title: Self-Starting Nls Gompertz Growth Model
+### Aliases: SSgompertz
+### Keywords: models
+
+### ** Examples
+
+DNase.1 <- subset(DNase, Run == 1)
+SSgompertz(log(DNase.1$conc), 4.5, 2.3, 0.7) # response only
+Asym <- 4.5; b2 <- 2.3; b3 <- 0.7
+SSgompertz(log(DNase.1$conc), Asym, b2, b3) # response and gradient
+print(getInitial(density ~ SSgompertz(log(conc), Asym, b2, b3),
+ data = DNase.1), digits = 5)
+## Initial values are in fact the converged values
+fm1 <- nls(density ~ SSgompertz(log(conc), Asym, b2, b3),
+ data = DNase.1)
+summary(fm1)
+
+
+
+cleanEx()
+nameEx("SSlogis")
+### * SSlogis
+
+flush(stderr()); flush(stdout())
+
+### Name: SSlogis
+### Title: Self-Starting Nls Logistic Model
+### Aliases: SSlogis
+### Keywords: models
+
+### ** Examples
+## Don't show:
+require(graphics)
+
+ xx <- seq(-0.5, 5, len = 101)
+ yy <- 5 / ( 1 + exp((2-xx)))
+ par(mar = c(0, 0, 3.5, 0))
+ plot(xx, yy, type = "l", axes = FALSE, ylim = c(0,6), xlim = c(-1, 5),
+ xlab = "", ylab = "", lwd = 2,
+ main = "Parameters in the SSlogis model")
+ usr <- par("usr")
+ arrows(usr[1], 0, usr[2], 0, length = 0.1, angle = 25)
+ arrows(0, usr[3], 0, usr[4], length = 0.1, angle = 25)
+ text(usr[2] - 0.2, 0.1, "x", adj = c(1, 0))
+ text(-0.1, usr[4], "y", adj = c(1, 1))
+ abline(h = 5, lty = 2, lwd = 0)
+ arrows(-0.8, 2.1, -0.8, 0, length = 0.1, angle = 25)
+ arrows(-0.8, 2.9, -0.8, 5, length = 0.1, angle = 25)
+ text(-0.8, 2.5, expression(phi[1]), adj = c(0.5, 0.5))
+ segments(2, 0, 2, 4.0, lty = 2, lwd = 0.75)
+ text(2, 4.0, expression(phi[2]), adj = c(0.5, 0))
+ segments(3, 5/(1+exp(-1)) + 0.025, 3, 4.0, lty = 2, lwd = 0.75)
+ arrows(2.3, 3.8, 2.0, 3.8, length = 0.08, angle = 25)
+ arrows(2.7, 3.8, 3.0, 3.8, length = 0.08, angle = 25)
+ text(2.5, 3.8, expression(phi[3]), adj = c(0.5, 0.5))
+## End(Don't show)
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("SSmicmen")
+### * SSmicmen
+
+flush(stderr()); flush(stdout())
+
+### Name: SSmicmen
+### Title: Self-Starting Nls Michaelis-Menten Model
+### Aliases: SSmicmen
+### Keywords: models
+
+### ** Examples
+
+PurTrt <- Puromycin[ Puromycin$state == "treated", ]
+SSmicmen(PurTrt$conc, 200, 0.05) # response only
+Vm <- 200; K <- 0.05
+SSmicmen(PurTrt$conc, Vm, K) # response and gradient
+print(getInitial(rate ~ SSmicmen(conc, Vm, K), data = PurTrt), digits = 3)
+## Initial values are in fact the converged values
+fm1 <- nls(rate ~ SSmicmen(conc, Vm, K), data = PurTrt)
+summary(fm1)
+## Alternative call using the subset argument
+fm2 <- nls(rate ~ SSmicmen(conc, Vm, K), data = Puromycin,
+ subset = state == "treated")
+summary(fm2)
+## Don't show:
+require(graphics)
+
+ xx <- seq(0, 5, len = 101)
+ yy <- 5 * xx/(1+xx)
+ par(mar = c(0, 0, 3.5, 0))
+ plot(xx, yy, type = "l", axes = FALSE, ylim = c(0,6), xlim = c(-1, 5),
+ xlab = "", ylab = "", lwd = 2,
+ main = "Parameters in the SSmicmen model")
+ usr <- par("usr")
+ arrows(usr[1], 0, usr[2], 0, length = 0.1, angle = 25)
+ arrows(0, usr[3], 0, usr[4], length = 0.1, angle = 25)
+ text(usr[2] - 0.2, 0.1, "x", adj = c(1, 0))
+ text(-0.1, usr[4], "y", adj = c(1, 1))
+ abline(h = 5, lty = 2, lwd = 0)
+ arrows(-0.8, 2.1, -0.8, 0, length = 0.1, angle = 25)
+ arrows(-0.8, 2.9, -0.8, 5, length = 0.1, angle = 25)
+ text(-0.8, 2.5, expression(phi[1]), adj = c(0.5, 0.5))
+ segments(1, 0, 1, 2.7, lty = 2, lwd = 0.75)
+ text(1, 2.7, expression(phi[2]), adj = c(0.5, 0))
+## End(Don't show)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("SSweibull")
+### * SSweibull
+
+flush(stderr()); flush(stdout())
+
+### Name: SSweibull
+### Title: Self-Starting Nls Weibull Growth Curve Model
+### Aliases: SSweibull
+### Keywords: models
+
+### ** Examples
+
+Chick.6 <- subset(ChickWeight, (Chick == 6) & (Time > 0))
+SSweibull(Chick.6$Time, 160, 115, -5.5, 2.5) # response only
+Asym <- 160; Drop <- 115; lrc <- -5.5; pwr <- 2.5
+SSweibull(Chick.6$Time, Asym, Drop, lrc, pwr) # response and gradient
+getInitial(weight ~ SSweibull(Time, Asym, Drop, lrc, pwr), data = Chick.6)
+## Initial values are in fact the converged values
+fm1 <- nls(weight ~ SSweibull(Time, Asym, Drop, lrc, pwr), data = Chick.6)
+summary(fm1)
+
+
+
+cleanEx()
+nameEx("SignRank")
+### * SignRank
+
+flush(stderr()); flush(stdout())
+
+### Name: SignRank
+### Title: Distribution of the Wilcoxon Signed Rank Statistic
+### Aliases: SignRank dsignrank psignrank qsignrank rsignrank
+### Keywords: distribution
+
+### ** Examples
+
+require(graphics)
+
+par(mfrow = c(2,2))
+for(n in c(4:5,10,40)) {
+ x <- seq(0, n*(n+1)/2, length = 501)
+ plot(x, dsignrank(x, n = n), type = "l",
+ main = paste0("dsignrank(x, n = ", n, ")"))
+}
+## Don't show:
+p <- c(1, 1, 1, 2, 2:6, 8, 10, 11, 13, 15, 17, 20, 22, 24,
+ 27, 29, 31, 33, 35, 36, 38, 39, 39, 40)
+stopifnot(round(dsignrank(0:56, n = 10)* 2^10) == c(p, rev(p), 0),
+ qsignrank((1:16)/ 16, n = 4) == c(0:2, rep(3:7, each = 2), 8:10))
+## End(Don't show)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("StructTS")
+### * StructTS
+
+flush(stderr()); flush(stdout())
+
+### Name: StructTS
+### Title: Fit Structural Time Series
+### Aliases: StructTS print.StructTS predict.StructTS
+### Keywords: ts
+
+### ** Examples
+
+## see also JohnsonJohnson, Nile and AirPassengers
+require(graphics)
+
+trees <- window(treering, start = 0)
+(fit <- StructTS(trees, type = "level"))
+plot(trees)
+lines(fitted(fit), col = "green")
+tsdiag(fit)
+
+(fit <- StructTS(log10(UKgas), type = "BSM"))
+par(mfrow = c(4, 1)) # to give appropriate aspect ratio for next plot.
+plot(log10(UKgas))
+plot(cbind(fitted(fit), resids=resid(fit)), main = "UK gas consumption")
+
+## keep some parameters fixed; trace optimizer:
+StructTS(log10(UKgas), type = "BSM", fixed = c(0.1,0.001,NA,NA),
+ optim.control = list(trace = TRUE))
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("TDist")
+### * TDist
+
+flush(stderr()); flush(stdout())
+
+### Name: TDist
+### Title: The Student t Distribution
+### Aliases: TDist dt pt qt rt
+### Keywords: distribution
+
+### ** Examples
+
+require(graphics)
+
+1 - pt(1:5, df = 1)
+qt(.975, df = c(1:10,20,50,100,1000))
+
+tt <- seq(0, 10, len = 21)
+ncp <- seq(0, 6, len = 31)
+ptn <- outer(tt, ncp, function(t, d) pt(t, df = 3, ncp = d))
+t.tit <- "Non-central t - Probabilities"
+image(tt, ncp, ptn, zlim = c(0,1), main = t.tit)
+persp(tt, ncp, ptn, zlim = 0:1, r = 2, phi = 20, theta = 200, main = t.tit,
+ xlab = "t", ylab = "non-centrality parameter",
+ zlab = "Pr(T <= t)")
+
+plot(function(x) dt(x, df = 3, ncp = 2), -3, 11, ylim = c(0, 0.32),
+ main = "Non-central t - Density", yaxs = "i")
+
+
+
+cleanEx()
+nameEx("Tukey")
+### * Tukey
+
+flush(stderr()); flush(stdout())
+
+### Name: Tukey
+### Title: The Studentized Range Distribution
+### Aliases: Tukey ptukey qtukey
+### Keywords: distribution
+
+### ** Examples
+
+if(interactive())
+ curve(ptukey(x, nm = 6, df = 5), from = -1, to = 8, n = 101)
+(ptt <- ptukey(0:10, 2, df = 5))
+(qtt <- qtukey(.95, 2, df = 2:11))
+## The precision may be not much more than about 8 digits:
+
+
+
+cleanEx()
+nameEx("TukeyHSD")
+### * TukeyHSD
+
+flush(stderr()); flush(stdout())
+
+### Name: TukeyHSD
+### Title: Compute Tukey Honest Significant Differences
+### Aliases: TukeyHSD
+### Keywords: models design
+
+### ** Examples
+
+require(graphics)
+
+summary(fm1 <- aov(breaks ~ wool + tension, data = warpbreaks))
+TukeyHSD(fm1, "tension", ordered = TRUE)
+plot(TukeyHSD(fm1, "tension"))
+
+
+
+cleanEx()
+nameEx("Uniform")
+### * Uniform
+
+flush(stderr()); flush(stdout())
+
+### Name: Uniform
+### Title: The Uniform Distribution
+### Aliases: Uniform dunif punif qunif runif
+### Keywords: distribution
+
+### ** Examples
+
+u <- runif(20)
+
+## The following relations always hold :
+punif(u) == u
+dunif(u) == 1
+
+var(runif(10000)) #- ~ = 1/12 = .08333
+
+
+
+cleanEx()
+nameEx("Weibull")
+### * Weibull
+
+flush(stderr()); flush(stdout())
+
+### Name: Weibull
+### Title: The Weibull Distribution
+### Aliases: Weibull dweibull pweibull qweibull rweibull
+### Keywords: distribution
+
+### ** Examples
+
+x <- c(0, rlnorm(50))
+all.equal(dweibull(x, shape = 1), dexp(x))
+all.equal(pweibull(x, shape = 1, scale = pi), pexp(x, rate = 1/pi))
+## Cumulative hazard H():
+all.equal(pweibull(x, 2.5, pi, lower.tail = FALSE, log.p = TRUE),
+ -(x/pi)^2.5, tolerance = 1e-15)
+all.equal(qweibull(x/11, shape = 1, scale = pi), qexp(x/11, rate = 1/pi))
+
+
+
+cleanEx()
+nameEx("Wilcoxon")
+### * Wilcoxon
+
+flush(stderr()); flush(stdout())
+
+### Name: Wilcoxon
+### Title: Distribution of the Wilcoxon Rank Sum Statistic
+### Aliases: Wilcoxon dwilcox pwilcox qwilcox rwilcox
+### Keywords: distribution
+
+### ** Examples
+
+require(graphics)
+
+x <- -1:(4*6 + 1)
+fx <- dwilcox(x, 4, 6)
+Fx <- pwilcox(x, 4, 6)
+
+layout(rbind(1,2), widths = 1, heights = c(3,2))
+plot(x, fx, type = "h", col = "violet",
+ main = "Probabilities (density) of Wilcoxon-Statist.(n=6, m=4)")
+plot(x, Fx, type = "s", col = "blue",
+ main = "Distribution of Wilcoxon-Statist.(n=6, m=4)")
+abline(h = 0:1, col = "gray20", lty = 2)
+layout(1) # set back
+
+N <- 200
+hist(U <- rwilcox(N, m = 4,n = 6), breaks = 0:25 - 1/2,
+ border = "red", col = "pink", sub = paste("N =",N))
+mtext("N * f(x), f() = true \"density\"", side = 3, col = "blue")
+ lines(x, N*fx, type = "h", col = "blue", lwd = 2)
+points(x, N*fx, cex = 2)
+
+## Better is a Quantile-Quantile Plot
+qqplot(U, qw <- qwilcox((1:N - 1/2)/N, m = 4, n = 6),
+ main = paste("Q-Q-Plot of empirical and theoretical quantiles",
+ "Wilcoxon Statistic, (m=4, n=6)", sep = "\n"))
+n <- as.numeric(names(print(tU <- table(U))))
+text(n+.2, n+.5, labels = tU, col = "red")
+
+
+
+cleanEx()
+nameEx("acf")
+### * acf
+
+flush(stderr()); flush(stdout())
+
+### Name: acf
+### Title: Auto- and Cross- Covariance and -Correlation Function Estimation
+### Aliases: acf ccf pacf pacf.default [.acf
+### Keywords: ts
+
+### ** Examples
+
+require(graphics)
+
+## Examples from Venables & Ripley
+acf(lh)
+acf(lh, type = "covariance")
+pacf(lh)
+
+acf(ldeaths)
+acf(ldeaths, ci.type = "ma")
+acf(ts.union(mdeaths, fdeaths))
+ccf(mdeaths, fdeaths, ylab = "cross-correlation")
+# (just the cross-correlations)
+
+presidents # contains missing values
+acf(presidents, na.action = na.pass)
+pacf(presidents, na.action = na.pass)
+
+
+
+cleanEx()
+nameEx("acf2AR")
+### * acf2AR
+
+flush(stderr()); flush(stdout())
+
+### Name: acf2AR
+### Title: Compute an AR Process Exactly Fitting an ACF
+### Aliases: acf2AR
+### Keywords: ts
+
+### ** Examples
+
+(Acf <- ARMAacf(c(0.6, 0.3, -0.2)))
+acf2AR(Acf)
+
+
+
+cleanEx()
+nameEx("add1")
+### * add1
+
+flush(stderr()); flush(stdout())
+
+### Name: add1
+### Title: Add or Drop All Possible Single Terms to a Model
+### Aliases: add1 add1.default add1.lm add1.glm drop1 drop1.default
+### drop1.lm drop1.glm
+### Keywords: models
+
+### ** Examples
+
+## Don't show:
+od <- options(digits = 5)
+## End(Don't show)
+require(graphics); require(utils)
+## following example(swiss)
+lm1 <- lm(Fertility ~ ., data = swiss)
+add1(lm1, ~ I(Education^2) + .^2)
+drop1(lm1, test = "F") # So called 'type II' anova
+
+## following example(glm)
+## Don't show:
+example(glm, echo = FALSE)
+## End(Don't show)
+drop1(glm.D93, test = "Chisq")
+drop1(glm.D93, test = "F")
+add1(glm.D93, scope = ~outcome*treatment, test = "Rao") ## Pearson Chi-square
+## Don't show:
+options(od)
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("addmargins")
+### * addmargins
+
+flush(stderr()); flush(stdout())
+
+### Name: addmargins
+### Title: Puts Arbitrary Margins on Multidimensional Tables or Arrays
+### Aliases: addmargins
+### Keywords: manip array
+
+### ** Examples
+
+Aye <- sample(c("Yes", "Si", "Oui"), 177, replace = TRUE)
+Bee <- sample(c("Hum", "Buzz"), 177, replace = TRUE)
+Sea <- sample(c("White", "Black", "Red", "Dead"), 177, replace = TRUE)
+(A <- table(Aye, Bee, Sea))
+addmargins(A)
+## Don't show:
+stopifnot(is.table(addmargins(A)))
+## End(Don't show)
+ftable(A)
+ftable(addmargins(A))
+
+# Non-commutative functions - note differences between resulting tables:
+ftable(addmargins(A, c(1, 3),
+ FUN = list(Sum = sum, list(Min = min, Max = max))))
+ftable(addmargins(A, c(3, 1),
+ FUN = list(list(Min = min, Max = max), Sum = sum)))
+
+# Weird function needed to return the N when computing percentages
+sqsm <- function(x) sum(x)^2/100
+B <- table(Sea, Bee)
+round(sweep(addmargins(B, 1, list(list(All = sum, N = sqsm))), 2,
+ apply(B, 2, sum)/100, "/"), 1)
+round(sweep(addmargins(B, 2, list(list(All = sum, N = sqsm))), 1,
+ apply(B, 1, sum)/100, "/"), 1)
+
+# A total over Bee requires formation of the Bee-margin first:
+mB <- addmargins(B, 2, FUN = list(list(Total = sum)))
+round(ftable(sweep(addmargins(mB, 1, list(list(All = sum, N = sqsm))), 2,
+ apply(mB, 2, sum)/100, "/")), 1)
+
+## Zero.Printing table+margins:
+set.seed(1)
+x <- sample( 1:7, 20, replace = TRUE)
+y <- sample( 1:7, 20, replace = TRUE)
+tx <- addmargins( table(x, y) )
+print(tx, zero.print = ".")
+
+
+
+cleanEx()
+nameEx("aggregate")
+### * aggregate
+
+flush(stderr()); flush(stdout())
+
+### Name: aggregate
+### Title: Compute Summary Statistics of Data Subsets
+### Aliases: aggregate aggregate.default aggregate.data.frame
+### aggregate.formula aggregate.ts
+### Keywords: category array
+
+### ** Examples
+
+## Compute the averages for the variables in 'state.x77', grouped
+## according to the region (Northeast, South, North Central, West) that
+## each state belongs to.
+aggregate(state.x77, list(Region = state.region), mean)
+
+## Compute the averages according to region and the occurrence of more
+## than 130 days of frost.
+aggregate(state.x77,
+ list(Region = state.region,
+ Cold = state.x77[,"Frost"] > 130),
+ mean)
+## (Note that no state in 'South' is THAT cold.)
+
+
+## example with character variables and NAs
+testDF <- data.frame(v1 = c(1,3,5,7,8,3,5,NA,4,5,7,9),
+ v2 = c(11,33,55,77,88,33,55,NA,44,55,77,99) )
+by1 <- c("red", "blue", 1, 2, NA, "big", 1, 2, "red", 1, NA, 12)
+by2 <- c("wet", "dry", 99, 95, NA, "damp", 95, 99, "red", 99, NA, NA)
+aggregate(x = testDF, by = list(by1, by2), FUN = "mean")
+
+# and if you want to treat NAs as a group
+fby1 <- factor(by1, exclude = "")
+fby2 <- factor(by2, exclude = "")
+aggregate(x = testDF, by = list(fby1, fby2), FUN = "mean")
+
+
+## Formulas, one ~ one, one ~ many, many ~ one, and many ~ many:
+aggregate(weight ~ feed, data = chickwts, mean)
+aggregate(breaks ~ wool + tension, data = warpbreaks, mean)
+aggregate(cbind(Ozone, Temp) ~ Month, data = airquality, mean)
+aggregate(cbind(ncases, ncontrols) ~ alcgp + tobgp, data = esoph, sum)
+
+## Dot notation:
+aggregate(. ~ Species, data = iris, mean)
+aggregate(len ~ ., data = ToothGrowth, mean)
+
+## Often followed by xtabs():
+ag <- aggregate(len ~ ., data = ToothGrowth, mean)
+xtabs(len ~ ., data = ag)
+
+
+## Compute the average annual approval ratings for American presidents.
+aggregate(presidents, nfrequency = 1, FUN = mean)
+## Give the summer less weight.
+aggregate(presidents, nfrequency = 1,
+ FUN = weighted.mean, w = c(1, 1, 0.5, 1))
+
+
+
+cleanEx()
+nameEx("alias")
+### * alias
+
+flush(stderr()); flush(stdout())
+
+### Name: alias
+### Title: Find Aliases (Dependencies) in a Model
+### Aliases: alias alias.formula alias.lm
+### Keywords: models
+
+### ** Examples
+
+
+cleanEx()
+nameEx("anova.glm")
+### * anova.glm
+
+flush(stderr()); flush(stdout())
+
+### Name: anova.glm
+### Title: Analysis of Deviance for Generalized Linear Model Fits
+### Aliases: anova.glm
+### Keywords: models regression
+
+### ** Examples
+
+## --- Continuing the Example from '?glm':
+## Don't show:
+require(utils)
+example("glm", echo = FALSE)
+## End(Don't show)
+anova(glm.D93)
+anova(glm.D93, test = "Cp")
+anova(glm.D93, test = "Chisq")
+glm.D93a <-
+ update(glm.D93, ~treatment*outcome) # equivalent to Pearson Chi-square
+anova(glm.D93, glm.D93a, test = "Rao")
+
+
+
+cleanEx()
+nameEx("anova.lm")
+### * anova.lm
+
+flush(stderr()); flush(stdout())
+
+### Name: anova.lm
+### Title: ANOVA for Linear Model Fits
+### Aliases: anova.lm anova.lmlist
+### Keywords: regression models
+
+### ** Examples
+
+## sequential table
+fit <- lm(sr ~ ., data = LifeCycleSavings)
+anova(fit)
+
+## same effect via separate models
+fit0 <- lm(sr ~ 1, data = LifeCycleSavings)
+fit1 <- update(fit0, . ~ . + pop15)
+fit2 <- update(fit1, . ~ . + pop75)
+fit3 <- update(fit2, . ~ . + dpi)
+fit4 <- update(fit3, . ~ . + ddpi)
+anova(fit0, fit1, fit2, fit3, fit4, test = "F")
+
+anova(fit4, fit2, fit0, test = "F") # unconventional order
+
+
+
+cleanEx()
+nameEx("anova.mlm")
+### * anova.mlm
+
+flush(stderr()); flush(stdout())
+
+### Name: anova.mlm
+### Title: Comparisons between Multivariate Linear Models
+### Aliases: anova.mlm
+### Keywords: regression models multivariate
+
+### ** Examples
+
+require(graphics)
+utils::example(SSD) # Brings in the mlmfit and reacttime objects
+
+mlmfit0 <- update(mlmfit, ~0)
+
+### Traditional tests of intrasubj. contrasts
+## Using MANOVA techniques on contrasts:
+anova(mlmfit, mlmfit0, X = ~1)
+
+## Assuming sphericity
+anova(mlmfit, mlmfit0, X = ~1, test = "Spherical")
+
+
+### tests using intra-subject 3x2 design
+idata <- data.frame(deg = gl(3, 1, 6, labels = c(0, 4, 8)),
+ noise = gl(2, 3, 6, labels = c("A", "P")))
+
+anova(mlmfit, mlmfit0, X = ~ deg + noise,
+ idata = idata, test = "Spherical")
+anova(mlmfit, mlmfit0, M = ~ deg + noise, X = ~ noise,
+ idata = idata, test = "Spherical" )
+anova(mlmfit, mlmfit0, M = ~ deg + noise, X = ~ deg,
+ idata = idata, test = "Spherical" )
+
+f <- factor(rep(1:2, 5)) # bogus, just for illustration
+mlmfit2 <- update(mlmfit, ~f)
+anova(mlmfit2, mlmfit, mlmfit0, X = ~1, test = "Spherical")
+anova(mlmfit2, X = ~1, test = "Spherical")
+# one-model form, eqiv. to previous
+
+### There seems to be a strong interaction in these data
+plot(colMeans(reacttime))
+
+
+
+cleanEx()
+nameEx("ansari.test")
+### * ansari.test
+
+flush(stderr()); flush(stdout())
+
+### Name: ansari.test
+### Title: Ansari-Bradley Test
+### Aliases: ansari.test ansari.test.default ansari.test.formula
+### Keywords: htest
+
+### ** Examples
+
+## Hollander & Wolfe (1973, p. 86f):
+## Serum iron determination using Hyland control sera
+ramsay <- c(111, 107, 100, 99, 102, 106, 109, 108, 104, 99,
+ 101, 96, 97, 102, 107, 113, 116, 113, 110, 98)
+jung.parekh <- c(107, 108, 106, 98, 105, 103, 110, 105, 104,
+ 100, 96, 108, 103, 104, 114, 114, 113, 108, 106, 99)
+ansari.test(ramsay, jung.parekh)
+
+ansari.test(rnorm(10), rnorm(10, 0, 2), conf.int = TRUE)
+
+## try more points - failed in 2.4.1
+ansari.test(rnorm(100), rnorm(100, 0, 2), conf.int = TRUE)
+
+
+
+cleanEx()
+nameEx("aov")
+### * aov
+
+flush(stderr()); flush(stdout())
+
+### Name: aov
+### Title: Fit an Analysis of Variance Model
+### Aliases: aov print.aov print.aovlist Error
+### Keywords: models regression
+
+### ** Examples
+
+## From Venables and Ripley (2002) p.165.
+
+## Set orthogonal contrasts.
+op <- options(contrasts = c("contr.helmert", "contr.poly"))
+( npk.aov <- aov(yield ~ block + N*P*K, npk) )
+coefficients(npk.aov)
+
+## to show the effects of re-ordering terms contrast the two fits
+aov(yield ~ block + N * P + K, npk)
+aov(terms(yield ~ block + N * P + K, keep.order = TRUE), npk)
+
+
+## as a test, not particularly sensible statistically
+npk.aovE <- aov(yield ~ N*P*K + Error(block), npk)
+npk.aovE
+summary(npk.aovE)
+options(op) # reset to previous
+
+
+
+base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
+cleanEx()
+nameEx("approxfun")
+### * approxfun
+
+flush(stderr()); flush(stdout())
+
+### Name: approxfun
+### Title: Interpolation Functions
+### Aliases: approx approxfun
+### Keywords: arith dplot
+
+### ** Examples
+
+require(graphics)
+
+x <- 1:10
+y <- rnorm(10)
+par(mfrow = c(2,1))
+plot(x, y, main = "approx(.) and approxfun(.)")
+points(approx(x, y), col = 2, pch = "*")
+points(approx(x, y, method = "constant"), col = 4, pch = "*")
+
+f <- approxfun(x, y)
+curve(f(x), 0, 11, col = "green2")
+points(x, y)
+is.function(fc <- approxfun(x, y, method = "const")) # TRUE
+curve(fc(x), 0, 10, col = "darkblue", add = TRUE)
+## different extrapolation on left and right side :
+plot(approxfun(x, y, rule = 2:1), 0, 11,
+ col = "tomato", add = TRUE, lty = 3, lwd = 2)
+
+## Show treatment of 'ties' :
+
+x <- c(2,2:4,4,4,5,5,7,7,7)
+y <- c(1:6, 5:4, 3:1)
+approx(x, y, xout = x)$y # warning
+(ay <- approx(x, y, xout = x, ties = "ordered")$y)
+stopifnot(ay == c(2,2,3,6,6,6,4,4,1,1,1))
+approx(x, y, xout = x, ties = min)$y
+approx(x, y, xout = x, ties = max)$y
+
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("ar")
+### * ar
+
+flush(stderr()); flush(stdout())
+
+### Name: ar
+### Title: Fit Autoregressive Models to Time Series
+### Aliases: ar ar.burg ar.burg.default ar.burg.mts ar.yw ar.yw.default
+### ar.yw.mts ar.mle print.ar predict.ar
+### Keywords: ts
+
+### ** Examples
+
+ar(lh)
+ar(lh, method = "burg")
+ar(lh, method = "ols")
+ar(lh, FALSE, 4) # fit ar(4)
+
+(sunspot.ar <- ar(sunspot.year))
+predict(sunspot.ar, n.ahead = 25)
+## try the other methods too
+
+ar(ts.union(BJsales, BJsales.lead))
+## Burg is quite different here, as is OLS (see ar.ols)
+ar(ts.union(BJsales, BJsales.lead), method = "burg")
+
+
+
+cleanEx()
+nameEx("ar.ols")
+### * ar.ols
+
+flush(stderr()); flush(stdout())
+
+### Name: ar.ols
+### Title: Fit Autoregressive Models to Time Series by OLS
+### Aliases: ar.ols
+### Keywords: ts
+
+### ** Examples
+
+ar(lh, method = "burg")
+ar.ols(lh)
+ar.ols(lh, FALSE, 4) # fit ar(4)
+
+ar.ols(ts.union(BJsales, BJsales.lead))
+
+x <- diff(log(EuStockMarkets))
+ar.ols(x, order.max = 6, demean = FALSE, intercept = TRUE)
+
+
+
+cleanEx()
+nameEx("arima")
+### * arima
+
+flush(stderr()); flush(stdout())
+
+### Name: arima
+### Title: ARIMA Modelling of Time Series
+### Aliases: arima
+### Keywords: ts
+
+### ** Examples
+
+arima(lh, order = c(1,0,0))
+arima(lh, order = c(3,0,0))
+arima(lh, order = c(1,0,1))
+
+arima(lh, order = c(3,0,0), method = "CSS")
+
+arima(USAccDeaths, order = c(0,1,1), seasonal = list(order = c(0,1,1)))
+arima(USAccDeaths, order = c(0,1,1), seasonal = list(order = c(0,1,1)),
+ method = "CSS") # drops first 13 observations.
+# for a model with as few years as this, we want full ML
+
+arima(LakeHuron, order = c(2,0,0), xreg = time(LakeHuron) - 1920)
+
+## presidents contains NAs
+## graphs in example(acf) suggest order 1 or 3
+require(graphics)
+(fit1 <- arima(presidents, c(1, 0, 0)))
+nobs(fit1)
+tsdiag(fit1)
+(fit3 <- arima(presidents, c(3, 0, 0))) # smaller AIC
+tsdiag(fit3)
+BIC(fit1, fit3)
+## compare a whole set of models; BIC() would choose the smallest
+AIC(fit1, arima(presidents, c(2,0,0)),
+ arima(presidents, c(2,0,1)), # <- chosen (barely) by AIC
+ fit3, arima(presidents, c(3,0,1)))
+
+## An example of ARIMA forecasting:
+predict(fit3, 3)
+
+
+
+cleanEx()
+nameEx("arima.sim")
+### * arima.sim
+
+flush(stderr()); flush(stdout())
+
+### Name: arima.sim
+### Title: Simulate from an ARIMA Model
+### Aliases: arima.sim
+### Keywords: ts
+
+### ** Examples
+
+require(graphics)
+
+arima.sim(n = 63, list(ar = c(0.8897, -0.4858), ma = c(-0.2279, 0.2488)),
+ sd = sqrt(0.1796))
+# mildly long-tailed
+arima.sim(n = 63, list(ar = c(0.8897, -0.4858), ma = c(-0.2279, 0.2488)),
+ rand.gen = function(n, ...) sqrt(0.1796) * rt(n, df = 5))
+
+# An ARIMA simulation
+ts.sim <- arima.sim(list(order = c(1,1,0), ar = 0.7), n = 200)
+ts.plot(ts.sim)
+
+
+
+cleanEx()
+nameEx("arima0")
+### * arima0
+
+flush(stderr()); flush(stdout())
+
+### Name: arima0
+### Title: ARIMA Modelling of Time Series - Preliminary Version
+### Aliases: arima0 print.arima0 predict.arima0
+### Keywords: ts
+
+### ** Examples
+
+## Not run: arima0(lh, order = c(1,0,0))
+arima0(lh, order = c(3,0,0))
+arima0(lh, order = c(1,0,1))
+predict(arima0(lh, order = c(3,0,0)), n.ahead = 12)
+
+arima0(lh, order = c(3,0,0), method = "CSS")
+
+# for a model with as few years as this, we want full ML
+(fit <- arima0(USAccDeaths, order = c(0,1,1),
+ seasonal = list(order=c(0,1,1)), delta = -1))
+predict(fit, n.ahead = 6)
+
+arima0(LakeHuron, order = c(2,0,0), xreg = time(LakeHuron)-1920)
+## Not run:
+##D ## presidents contains NAs
+##D ## graphs in example(acf) suggest order 1 or 3
+##D (fit1 <- arima0(presidents, c(1, 0, 0), delta = -1)) # avoid warning
+##D tsdiag(fit1)
+##D (fit3 <- arima0(presidents, c(3, 0, 0), delta = -1)) # smaller AIC
+##D tsdiag(fit3)
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("as.hclust")
+### * as.hclust
+
+flush(stderr()); flush(stdout())
+
+### Name: as.hclust
+### Title: Convert Objects to Class hclust
+### Aliases: as.hclust as.hclust.default as.hclust.twins
+### Keywords: multivariate cluster
+
+### ** Examples
+
+x <- matrix(rnorm(30), ncol = 3)
+hc <- hclust(dist(x), method = "complete")
+
+
+
+
+cleanEx()
+nameEx("asOneSidedFormula")
+### * asOneSidedFormula
+
+flush(stderr()); flush(stdout())
+
+### Name: asOneSidedFormula
+### Title: Convert to One-Sided Formula
+### Aliases: asOneSidedFormula
+### Keywords: models
+
+### ** Examples
+
+asOneSidedFormula("age")
+asOneSidedFormula(~ age)
+
+
+
+cleanEx()
+nameEx("ave")
+### * ave
+
+flush(stderr()); flush(stdout())
+
+### Name: ave
+### Title: Group Averages Over Level Combinations of Factors
+### Aliases: ave
+### Keywords: univar
+
+### ** Examples
+
+require(graphics)
+
+ave(1:3) # no grouping -> grand mean
+
+attach(warpbreaks)
+ave(breaks, wool)
+ave(breaks, tension)
+ave(breaks, tension, FUN = function(x) mean(x, trim = 0.1))
+plot(breaks, main =
+ "ave( Warpbreaks ) for wool x tension combinations")
+lines(ave(breaks, wool, tension ), type = "s", col = "blue")
+lines(ave(breaks, wool, tension, FUN = median), type = "s", col = "green")
+legend(40, 70, c("mean", "median"), lty = 1,
+ col = c("blue","green"), bg = "gray90")
+detach()
+
+
+
+cleanEx()
+nameEx("bandwidth")
+### * bandwidth
+
+flush(stderr()); flush(stdout())
+
+### Name: bandwidth
+### Title: Bandwidth Selectors for Kernel Density Estimation
+### Aliases: bw.nrd0 bw.nrd bw.ucv bw.bcv bw.SJ
+### Keywords: distribution smooth
+
+### ** Examples
+
+require(graphics)
+
+plot(density(precip, n = 1000))
+rug(precip)
+lines(density(precip, bw = "nrd"), col = 2)
+lines(density(precip, bw = "ucv"), col = 3)
+lines(density(precip, bw = "bcv"), col = 4)
+lines(density(precip, bw = "SJ-ste"), col = 5)
+lines(density(precip, bw = "SJ-dpi"), col = 6)
+legend(55, 0.035,
+ legend = c("nrd0", "nrd", "ucv", "bcv", "SJ-ste", "SJ-dpi"),
+ col = 1:6, lty = 1)
+
+
+
+cleanEx()
+nameEx("bartlett.test")
+### * bartlett.test
+
+flush(stderr()); flush(stdout())
+
+### Name: bartlett.test
+### Title: Bartlett Test of Homogeneity of Variances
+### Aliases: bartlett.test bartlett.test.default bartlett.test.formula
+### Keywords: htest
+
+### ** Examples
+
+require(graphics)
+
+plot(count ~ spray, data = InsectSprays)
+bartlett.test(InsectSprays$count, InsectSprays$spray)
+bartlett.test(count ~ spray, data = InsectSprays)
+
+
+
+cleanEx()
+nameEx("binom.test")
+### * binom.test
+
+flush(stderr()); flush(stdout())
+
+### Name: binom.test
+### Title: Exact Binomial Test
+### Aliases: binom.test
+### Keywords: htest
+
+### ** Examples
+
+## Conover (1971), p. 97f.
+## Under (the assumption of) simple Mendelian inheritance, a cross
+## between plants of two particular genotypes produces progeny 1/4 of
+## which are "dwarf" and 3/4 of which are "giant", respectively.
+## In an experiment to determine if this assumption is reasonable, a
+## cross results in progeny having 243 dwarf and 682 giant plants.
+## If "giant" is taken as success, the null hypothesis is that p =
+## 3/4 and the alternative that p != 3/4.
+binom.test(c(682, 243), p = 3/4)
+binom.test(682, 682 + 243, p = 3/4) # The same.
+## => Data are in agreement with the null hypothesis.
+
+
+
+cleanEx()
+nameEx("biplot.princomp")
+### * biplot.princomp
+
+flush(stderr()); flush(stdout())
+
+### Name: biplot.princomp
+### Title: Biplot for Principal Components
+### Aliases: biplot.princomp biplot.prcomp
+### Keywords: multivariate hplot
+
+### ** Examples
+
+require(graphics)
+biplot(princomp(USArrests))
+
+
+
+cleanEx()
+nameEx("birthday")
+### * birthday
+
+flush(stderr()); flush(stdout())
+
+### Name: birthday
+### Title: Probability of coincidences
+### Aliases: qbirthday pbirthday
+### Keywords: distribution
+
+### ** Examples
+
+require(graphics)
+
+## the standard version
+qbirthday() # 23
+## probability of > 2 people with the same birthday
+pbirthday(23, coincident = 3)
+
+## examples from Diaconis & Mosteller p. 858.
+## 'coincidence' is that husband, wife, daughter all born on the 16th
+qbirthday(classes = 30, coincident = 3) # approximately 18
+qbirthday(coincident = 4) # exact value 187
+qbirthday(coincident = 10) # exact value 1181
+
+## same 4-digit PIN number
+qbirthday(classes = 10^4)
+
+## 0.9 probability of three or more coincident birthdays
+qbirthday(coincident = 3, prob = 0.9)
+
+## Chance of 4 or more coincident birthdays in 150 people
+pbirthday(150, coincident = 4)
+
+## 100 or more coincident birthdays in 1000 people: very rare
+pbirthday(1000, coincident = 100)
+
+
+
+cleanEx()
+nameEx("box.test")
+### * box.test
+
+flush(stderr()); flush(stdout())
+
+### Name: Box.test
+### Title: Box-Pierce and Ljung-Box Tests
+### Aliases: Box.test
+### Keywords: ts
+
+### ** Examples
+
+x <- rnorm (100)
+Box.test (x, lag = 1)
+Box.test (x, lag = 1, type = "Ljung")
+
+
+
+cleanEx()
+nameEx("cancor")
+### * cancor
+
+flush(stderr()); flush(stdout())
+
+### Name: cancor
+### Title: Canonical Correlations
+### Aliases: cancor
+### Keywords: multivariate
+
+### ** Examples
+
+
+cleanEx()
+nameEx("case.names")
+### * case.names
+
+flush(stderr()); flush(stdout())
+
+### Name: case+variable.names
+### Title: Case and Variable Names of Fitted Models
+### Aliases: case.names case.names.lm variable.names variable.names.lm
+### Keywords: regression models
+
+### ** Examples
+
+x <- 1:20
+y <- setNames(x + (x/4 - 2)^3 + rnorm(20, sd = 3),
+ paste("O", x, sep = "."))
+ww <- rep(1, 20); ww[13] <- 0
+summary(lmxy <- lm(y ~ x + I(x^2)+I(x^3) + I((x-10)^2), weights = ww),
+ cor = TRUE)
+variable.names(lmxy)
+variable.names(lmxy, full = TRUE) # includes the last
+case.names(lmxy)
+case.names(lmxy, full = TRUE) # includes the 0-weight case
+
+
+
+cleanEx()
+nameEx("chisq.test")
+### * chisq.test
+
+flush(stderr()); flush(stdout())
+
+### Name: chisq.test
+### Title: Pearson's Chi-squared Test for Count Data
+### Aliases: chisq.test
+### Keywords: htest distribution
+
+### ** Examples
+
+
+## From Agresti(2007) p.39
+M <- as.table(rbind(c(762, 327, 468), c(484, 239, 477)))
+dimnames(M) <- list(gender = c("F", "M"),
+ party = c("Democrat","Independent", "Republican"))
+(Xsq <- chisq.test(M)) # Prints test summary
+Xsq$observed # observed counts (same as M)
+Xsq$expected # expected counts under the null
+Xsq$residuals # Pearson residuals
+Xsq$stdres # standardized residuals
+
+
+## Effect of simulating p-values
+x <- matrix(c(12, 5, 7, 7), ncol = 2)
+chisq.test(x)$p.value # 0.4233
+chisq.test(x, simulate.p.value = TRUE, B = 10000)$p.value
+ # around 0.29!
+
+## Testing for population probabilities
+## Case A. Tabulated data
+x <- c(A = 20, B = 15, C = 25)
+chisq.test(x)
+chisq.test(as.table(x)) # the same
+x <- c(89,37,30,28,2)
+p <- c(40,20,20,15,5)
+try(
+chisq.test(x, p = p) # gives an error
+)
+chisq.test(x, p = p, rescale.p = TRUE)
+ # works
+p <- c(0.40,0.20,0.20,0.19,0.01)
+ # Expected count in category 5
+ # is 1.86 < 5 ==> chi square approx.
+chisq.test(x, p = p) # maybe doubtful, but is ok!
+chisq.test(x, p = p, simulate.p.value = TRUE)
+
+## Case B. Raw data
+x <- trunc(5 * runif(100))
+chisq.test(table(x)) # NOT 'chisq.test(x)'!
+
+
+
+cleanEx()
+nameEx("cmdscale")
+### * cmdscale
+
+flush(stderr()); flush(stdout())
+
+### Name: cmdscale
+### Title: Classical (Metric) Multidimensional Scaling
+### Aliases: cmdscale
+### Keywords: multivariate
+
+### ** Examples
+
+require(graphics)
+
+loc <- cmdscale(eurodist)
+x <- loc[, 1]
+y <- -loc[, 2] # reflect so North is at the top
+## note asp = 1, to ensure Euclidean distances are represented correctly
+plot(x, y, type = "n", xlab = "", ylab = "", asp = 1, axes = FALSE,
+ main = "cmdscale(eurodist)")
+text(x, y, rownames(loc), cex = 0.6)
+
+
+
+cleanEx()
+nameEx("coef")
+### * coef
+
+flush(stderr()); flush(stdout())
+
+### Name: coef
+### Title: Extract Model Coefficients
+### Aliases: coef coefficients
+### Keywords: regression models
+
+### ** Examples
+
+x <- 1:5; coef(lm(c(1:3, 7, 6) ~ x))
+
+
+
+cleanEx()
+nameEx("complete.cases")
+### * complete.cases
+
+flush(stderr()); flush(stdout())
+
+### Name: complete.cases
+### Title: Find Complete Cases
+### Aliases: complete.cases
+### Keywords: NA logic
+
+### ** Examples
+
+x <- airquality[, -1] # x is a regression design matrix
+y <- airquality[, 1] # y is the corresponding response
+
+stopifnot(complete.cases(y) != is.na(y))
+ok <- complete.cases(x, y)
+sum(!ok) # how many are not "ok" ?
+x <- x[ok,]
+y <- y[ok]
+
+
+
+cleanEx()
+nameEx("confint")
+### * confint
+
+flush(stderr()); flush(stdout())
+
+### Name: confint
+### Title: Confidence Intervals for Model Parameters
+### Aliases: confint confint.default confint.lm
+### Keywords: models
+
+### ** Examples
+
+fit <- lm(100/mpg ~ disp + hp + wt + am, data = mtcars)
+confint(fit)
+confint(fit, "wt")
+
+
+
+
+cleanEx()
+nameEx("constrOptim")
+### * constrOptim
+
+flush(stderr()); flush(stdout())
+
+### Name: constrOptim
+### Title: Linearly Constrained Optimization
+### Aliases: constrOptim
+### Keywords: optimize
+
+### ** Examples
+
+
+cleanEx()
+nameEx("contrast")
+### * contrast
+
+flush(stderr()); flush(stdout())
+
+### Name: contrast
+### Title: (Possibly Sparse) Contrast Matrices
+### Aliases: contr.helmert contr.poly contr.sum contr.treatment contr.SAS
+### Keywords: design regression array
+
+### ** Examples
+
+(cH <- contr.helmert(4))
+apply(cH, 2, sum) # column sums are 0
+crossprod(cH) # diagonal -- columns are orthogonal
+contr.helmert(4, contrasts = FALSE) # just the 4 x 4 identity matrix
+
+(cT <- contr.treatment(5))
+all(crossprod(cT) == diag(4)) # TRUE: even orthonormal
+
+(cT. <- contr.SAS(5))
+all(crossprod(cT.) == diag(4)) # TRUE
+
+zapsmall(cP <- contr.poly(3)) # Linear and Quadratic
+zapsmall(crossprod(cP), digits = 15) # orthonormal up to fuzz
+
+
+
+cleanEx()
+nameEx("contrasts")
+### * contrasts
+
+flush(stderr()); flush(stdout())
+
+### Name: contrasts
+### Title: Get and Set Contrast Matrices
+### Aliases: contrasts contrasts<-
+### Keywords: design regression
+
+### ** Examples
+
+utils::example(factor)
+fff <- ff[, drop = TRUE] # reduce to 5 levels.
+contrasts(fff) # treatment contrasts by default
+contrasts(C(fff, sum))
+contrasts(fff, contrasts = FALSE) # the 5x5 identity matrix
+
+contrasts(fff) <- contr.sum(5); contrasts(fff) # set sum contrasts
+contrasts(fff, 2) <- contr.sum(5); contrasts(fff) # set 2 contrasts
+# supply 2 contrasts, compute 2 more to make full set of 4.
+contrasts(fff) <- contr.sum(5)[, 1:2]; contrasts(fff)
+
+
+
+cleanEx()
+nameEx("convolve")
+### * convolve
+
+flush(stderr()); flush(stdout())
+
+### Name: convolve
+### Title: Convolution of Sequences via FFT
+### Aliases: convolve
+### Keywords: math dplot
+
+### ** Examples
+
+require(graphics)
+
+x <- c(0,0,0,100,0,0,0)
+y <- c(0,0,1, 2 ,1,0,0)/4
+zapsmall(convolve(x, y)) # *NOT* what you first thought.
+zapsmall(convolve(x, y[3:5], type = "f")) # rather
+x <- rnorm(50)
+y <- rnorm(50)
+# Circular convolution *has* this symmetry:
+all.equal(convolve(x, y, conj = FALSE), rev(convolve(rev(y),x)))
+
+n <- length(x <- -20:24)
+y <- (x-10)^2/1000 + rnorm(x)/8
+
+Han <- function(y) # Hanning
+ convolve(y, c(1,2,1)/4, type = "filter")
+
+plot(x, y, main = "Using convolve(.) for Hanning filters")
+lines(x[-c(1 , n) ], Han(y), col = "red")
+lines(x[-c(1:2, (n-1):n)], Han(Han(y)), lwd = 2, col = "dark blue")
+
+
+
+cleanEx()
+nameEx("cophenetic")
+### * cophenetic
+
+flush(stderr()); flush(stdout())
+
+### Name: cophenetic
+### Title: Cophenetic Distances for a Hierarchical Clustering
+### Aliases: cophenetic cophenetic.default cophenetic.dendrogram
+### Keywords: cluster multivariate
+
+### ** Examples
+
+require(graphics)
+
+d1 <- dist(USArrests)
+hc <- hclust(d1, "ave")
+d2 <- cophenetic(hc)
+cor(d1, d2) # 0.7659
+
+## Example from Sneath & Sokal, Fig. 5-29, p.279
+d0 <- c(1,3.8,4.4,5.1, 4,4.2,5, 2.6,5.3, 5.4)
+attributes(d0) <- list(Size = 5, diag = TRUE)
+class(d0) <- "dist"
+names(d0) <- letters[1:5]
+d0
+utils::str(upgma <- hclust(d0, method = "average"))
+plot(upgma, hang = -1)
+#
+(d.coph <- cophenetic(upgma))
+cor(d0, d.coph) # 0.9911
+
+
+
+cleanEx()
+nameEx("cor")
+### * cor
+
+flush(stderr()); flush(stdout())
+
+### Name: cor
+### Title: Correlation, Variance and Covariance (Matrices)
+### Aliases: var cov cor cov2cor
+### Keywords: univar multivariate array
+
+### ** Examples
+
+var(1:10) # 9.166667
+
+var(1:5, 1:5) # 2.5
+
+## Two simple vectors
+cor(1:10, 2:11) # == 1
+
+## Correlation Matrix of Multivariate sample:
+(Cl <- cor(longley))
+## Graphical Correlation Matrix:
+symnum(Cl) # highly correlated
+
+## Spearman's rho and Kendall's tau
+symnum(clS <- cor(longley, method = "spearman"))
+symnum(clK <- cor(longley, method = "kendall"))
+## How much do they differ?
+i <- lower.tri(Cl)
+cor(cbind(P = Cl[i], S = clS[i], K = clK[i]))
+
+
+## cov2cor() scales a covariance matrix by its diagonal
+## to become the correlation matrix.
+cov2cor # see the function definition {and learn ..}
+stopifnot(all.equal(Cl, cov2cor(cov(longley))),
+ all.equal(cor(longley, method = "kendall"),
+ cov2cor(cov(longley, method = "kendall"))))
+
+##--- Missing value treatment:
+C1 <- cov(swiss)
+range(eigen(C1, only.values = TRUE)$values) # 6.19 1921
+
+## swM := "swiss" with 3 "missing"s :
+swM <- swiss
+colnames(swM) <- abbreviate(colnames(swiss), min=6)
+swM[1,2] <- swM[7,3] <- swM[25,5] <- NA # create 3 "missing"
+
+## Consider all 5 "use" cases :
+(C. <- cov(swM)) # use="everything" quite a few NA's in cov.matrix
+try(cov(swM, use = "all")) # Error: missing obs...
+C2 <- cov(swM, use = "complete")
+stopifnot(identical(C2, cov(swM, use = "na.or.complete")))
+range(eigen(C2, only.values = TRUE)$values) # 6.46 1930
+C3 <- cov(swM, use = "pairwise")
+range(eigen(C3, only.values = TRUE)$values) # 6.19 1938
+
+## Kendall's tau doesn't change much:
+symnum(Rc <- cor(swM, method = "kendall", use = "complete"))
+symnum(Rp <- cor(swM, method = "kendall", use = "pairwise"))
+symnum(R. <- cor(swiss, method = "kendall"))
+
+## "pairwise" is closer componentwise,
+summary(abs(c(1 - Rp/R.)))
+summary(abs(c(1 - Rc/R.)))
+
+## but "complete" is closer in Eigen space:
+EV <- function(m) eigen(m, only.values=TRUE)$values
+summary(abs(1 - EV(Rp)/EV(R.)) / abs(1 - EV(Rc)/EV(R.)))
+
+
+
+cleanEx()
+nameEx("cor.test")
+### * cor.test
+
+flush(stderr()); flush(stdout())
+
+### Name: cor.test
+### Title: Test for Association/Correlation Between Paired Samples
+### Aliases: cor.test cor.test.default cor.test.formula
+### Keywords: htest
+
+### ** Examples
+
+## Hollander & Wolfe (1973), p. 187f.
+## Assessment of tuna quality. We compare the Hunter L measure of
+## lightness to the averages of consumer panel scores (recoded as
+## integer values from 1 to 6 and averaged over 80 such values) in
+## 9 lots of canned tuna.
+
+x <- c(44.4, 45.9, 41.9, 53.3, 44.7, 44.1, 50.7, 45.2, 60.1)
+y <- c( 2.6, 3.1, 2.5, 5.0, 3.6, 4.0, 5.2, 2.8, 3.8)
+
+## The alternative hypothesis of interest is that the
+## Hunter L value is positively associated with the panel score.
+
+cor.test(x, y, method = "kendall", alternative = "greater")
+## => p=0.05972
+
+cor.test(x, y, method = "kendall", alternative = "greater",
+ exact = FALSE) # using large sample approximation
+## => p=0.04765
+
+## Compare this to
+cor.test(x, y, method = "spearm", alternative = "g")
+cor.test(x, y, alternative = "g")
+
+## Formula interface.
+require(graphics)
+pairs(USJudgeRatings)
+cor.test(~ CONT + INTG, data = USJudgeRatings)
+
+
+
+cleanEx()
+nameEx("cov.wt")
+### * cov.wt
+
+flush(stderr()); flush(stdout())
+
+### Name: cov.wt
+### Title: Weighted Covariance Matrices
+### Aliases: cov.wt
+### Keywords: multivariate
+
+### ** Examples
+
+ (xy <- cbind(x = 1:10, y = c(1:3, 8:5, 8:10)))
+ w1 <- c(0,0,0,1,1,1,1,1,0,0)
+ cov.wt(xy, wt = w1) # i.e. method = "unbiased"
+ cov.wt(xy, wt = w1, method = "ML", cor = TRUE)
+
+
+
+cleanEx()
+nameEx("cpgram")
+### * cpgram
+
+flush(stderr()); flush(stdout())
+
+### Name: cpgram
+### Title: Plot Cumulative Periodogram
+### Aliases: cpgram
+### Keywords: ts hplot
+
+### ** Examples
+
+require(graphics)
+
+par(pty = "s", mfrow = c(1,2))
+cpgram(lh)
+lh.ar <- ar(lh, order.max = 9)
+cpgram(lh.ar$resid, main = "AR(3) fit to lh")
+
+cpgram(ldeaths)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("cutree")
+### * cutree
+
+flush(stderr()); flush(stdout())
+
+### Name: cutree
+### Title: Cut a Tree into Groups of Data
+### Aliases: cutree
+### Keywords: multivariate cluster
+
+### ** Examples
+
+hc <- hclust(dist(USArrests))
+
+cutree(hc, k = 1:5) #k = 1 is trivial
+cutree(hc, h = 250)
+
+## Compare the 2 and 4 grouping:
+g24 <- cutree(hc, k = c(2,4))
+table(grp2 = g24[,"2"], grp4 = g24[,"4"])
+
+
+
+cleanEx()
+nameEx("decompose")
+### * decompose
+
+flush(stderr()); flush(stdout())
+
+### Name: decompose
+### Title: Classical Seasonal Decomposition by Moving Averages
+### Aliases: decompose plot.decomposed.ts
+### Keywords: ts
+
+### ** Examples
+
+require(graphics)
+
+m <- decompose(co2)
+m$figure
+plot(m)
+
+## example taken from Kendall/Stuart
+x <- c(-50, 175, 149, 214, 247, 237, 225, 329, 729, 809,
+ 530, 489, 540, 457, 195, 176, 337, 239, 128, 102, 232, 429, 3,
+ 98, 43, -141, -77, -13, 125, 361, -45, 184)
+x <- ts(x, start = c(1951, 1), end = c(1958, 4), frequency = 4)
+m <- decompose(x)
+## seasonal figure: 6.25, 8.62, -8.84, -6.03
+round(decompose(x)$figure / 10, 2)
+
+
+
+cleanEx()
+nameEx("delete.response")
+### * delete.response
+
+flush(stderr()); flush(stdout())
+
+### Name: delete.response
+### Title: Modify Terms Objects
+### Aliases: reformulate drop.terms delete.response [.terms
+### Keywords: programming
+
+### ** Examples
+
+ff <- y ~ z + x + w
+tt <- terms(ff)
+tt
+delete.response(tt)
+drop.terms(tt, 2:3, keep.response = TRUE)
+tt[-1]
+tt[2:3]
+reformulate(attr(tt, "term.labels"))
+
+## keep LHS :
+reformulate("x*w", ff[[2]])
+fS <- surv(ft, case) ~ a + b
+reformulate(c("a", "b*f"), fS[[2]])
+
+## using non-syntactic names:
+reformulate(c("`P/E`", "`% Growth`"), response = as.name("+-"))
+
+stopifnot(identical( ~ var, reformulate("var")),
+ identical(~ a + b + c, reformulate(letters[1:3])),
+ identical( y ~ a + b, reformulate(letters[1:2], "y"))
+ )
+
+
+
+cleanEx()
+nameEx("dendrapply")
+### * dendrapply
+
+flush(stderr()); flush(stdout())
+
+### Name: dendrapply
+### Title: Apply a Function to All Nodes of a Dendrogram
+### Aliases: dendrapply
+### Keywords: iteration
+
+### ** Examples
+
+require(graphics)
+
+## a smallish simple dendrogram
+dhc <- as.dendrogram(hc <- hclust(dist(USArrests), "ave"))
+(dhc21 <- dhc[[2]][[1]])
+
+## too simple:
+dendrapply(dhc21, function(n) utils::str(attributes(n)))
+
+## toy example to set colored leaf labels :
+local({
+ colLab <<- function(n) {
+ if(is.leaf(n)) {
+ a <- attributes(n)
+ i <<- i+1
+ attr(n, "nodePar") <-
+ c(a$nodePar, list(lab.col = mycols[i], lab.font = i%%3))
+ }
+ n
+ }
+ mycols <- grDevices::rainbow(attr(dhc21,"members"))
+ i <- 0
+ })
+dL <- dendrapply(dhc21, colLab)
+op <- par(mfrow = 2:1)
+ plot(dhc21)
+ plot(dL) ## --> colored labels!
+par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("dendrogram")
+### * dendrogram
+
+flush(stderr()); flush(stdout())
+
+### Name: dendrogram
+### Title: General Tree Structures
+### Aliases: dendrogram as.dendrogram as.dendrogram.dendrogram
+### as.dendrogram.hclust as.hclust.dendrogram cut.dendrogram
+### [[.dendrogram merge.dendrogram nobs.dendrogram plot.dendrogram
+### print.dendrogram rev.dendrogram str.dendrogram is.leaf
+### Keywords: multivariate tree hplot
+
+### ** Examples
+
+require(graphics); require(utils)
+
+hc <- hclust(dist(USArrests), "ave")
+(dend1 <- as.dendrogram(hc)) # "print()" method
+str(dend1) # "str()" method
+str(dend1, max = 2, last.str = "'") # only the first two sub-levels
+oo <- options(str.dendrogram.last = "\\") # yet another possibility
+str(dend1, max = 2) # only the first two sub-levels
+options(oo) # .. resetting them
+
+op <- par(mfrow = c(2,2), mar = c(5,2,1,4))
+plot(dend1)
+## "triangle" type and show inner nodes:
+plot(dend1, nodePar = list(pch = c(1,NA), cex = 0.8, lab.cex = 0.8),
+ type = "t", center = TRUE)
+plot(dend1, edgePar = list(col = 1:2, lty = 2:3),
+ dLeaf = 1, edge.root = TRUE)
+plot(dend1, nodePar = list(pch = 2:1, cex = .4*2:1, col = 2:3),
+ horiz = TRUE)
+
+## simple test for as.hclust() as the inverse of as.dendrogram():
+stopifnot(identical(as.hclust(dend1)[1:4], hc[1:4]))
+
+dend2 <- cut(dend1, h = 70)
+plot(dend2$upper)
+## leaves are wrong horizontally:
+plot(dend2$upper, nodePar = list(pch = c(1,7), col = 2:1))
+## dend2$lower is *NOT* a dendrogram, but a list of .. :
+plot(dend2$lower[[3]], nodePar = list(col = 4), horiz = TRUE, type = "tr")
+## "inner" and "leaf" edges in different type & color :
+plot(dend2$lower[[2]], nodePar = list(col = 1), # non empty list
+ edgePar = list(lty = 1:2, col = 2:1), edge.root = TRUE)
+par(op)
+d3 <- dend2$lower[[2]][[2]][[1]]
+stopifnot(identical(d3, dend2$lower[[2]][[c(2,1)]]))
+str(d3, last.str = "'")
+
+## to peek at the inner structure "if you must", use '[..]' indexing :
+str(d3[2][[1]]) ## or the full
+str(d3[])
+
+## merge() to join dendrograms:
+(d13 <- merge(dend2$lower[[1]], dend2$lower[[3]]))
+## merge() all parts back (using default 'height' instead of original one):
+den.1 <- Reduce(merge, dend2$lower)
+## or merge() all four parts at same height --> 4 branches (!)
+d. <- merge(dend2$lower[[1]], dend2$lower[[2]], dend2$lower[[3]],
+ dend2$lower[[4]])
+## (with a warning) or the same using do.call :
+stopifnot(identical(d., do.call(merge, dend2$lower)))
+plot(d., main = "merge(d1, d2, d3, d4) |-> dendrogram with a 4-split")
+
+## "Zoom" in to the first dendrogram :
+plot(dend1, xlim = c(1,20), ylim = c(1,50))
+
+nP <- list(col = 3:2, cex = c(2.0, 0.75), pch = 21:22,
+ bg = c("light blue", "pink"),
+ lab.cex = 0.75, lab.col = "tomato")
+plot(d3, nodePar= nP, edgePar = list(col = "gray", lwd = 2), horiz = TRUE)
+addE <- function(n) {
+ if(!is.leaf(n)) {
+ attr(n, "edgePar") <- list(p.col = "plum")
+ attr(n, "edgetext") <- paste(attr(n,"members"),"members")
+ }
+ n
+}
+d3e <- dendrapply(d3, addE)
+plot(d3e, nodePar = nP)
+plot(d3e, nodePar = nP, leaflab = "textlike")
+
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("density")
+### * density
+
+flush(stderr()); flush(stdout())
+
+### Name: density
+### Title: Kernel Density Estimation
+### Aliases: density density.default
+### Keywords: distribution smooth
+
+### ** Examples
+
+require(graphics)
+
+plot(density(c(-20, rep(0,98), 20)), xlim = c(-4, 4)) # IQR = 0
+
+# The Old Faithful geyser data
+d <- density(faithful$eruptions, bw = "sj")
+d
+plot(d)
+
+plot(d, type = "n")
+polygon(d, col = "wheat")
+
+## Missing values:
+x <- xx <- faithful$eruptions
+x[i.out <- sample(length(x), 10)] <- NA
+doR <- density(x, bw = 0.15, na.rm = TRUE)
+lines(doR, col = "blue")
+points(xx[i.out], rep(0.01, 10))
+
+## Weighted observations:
+fe <- sort(faithful$eruptions) # has quite a few non-unique values
+## use 'counts / n' as weights:
+dw <- density(unique(fe), weights = table(fe)/length(fe), bw = d$bw)
+utils::str(dw) ## smaller n: only 126, but identical estimate:
+stopifnot(all.equal(d[1:3], dw[1:3]))
+
+## simulation from a density() fit:
+# a kernel density fit is an equally-weighted mixture.
+fit <- density(xx)
+N <- 1e6
+x.new <- rnorm(N, sample(xx, size = N, replace = TRUE), fit$bw)
+plot(fit)
+lines(density(x.new), col = "blue")
+
+
+(kernels <- eval(formals(density.default)$kernel))
+
+## show the kernels in the R parametrization
+plot (density(0, bw = 1), xlab = "",
+ main = "R's density() kernels with bw = 1")
+for(i in 2:length(kernels))
+ lines(density(0, bw = 1, kernel = kernels[i]), col = i)
+legend(1.5,.4, legend = kernels, col = seq(kernels),
+ lty = 1, cex = .8, y.intersp = 1)
+
+## show the kernels in the S parametrization
+plot(density(0, from = -1.2, to = 1.2, width = 2, kernel = "gaussian"),
+ type = "l", ylim = c(0, 1), xlab = "",
+ main = "R's density() kernels with width = 1")
+for(i in 2:length(kernels))
+ lines(density(0, width = 2, kernel = kernels[i]), col = i)
+legend(0.6, 1.0, legend = kernels, col = seq(kernels), lty = 1)
+
+##-------- Semi-advanced theoretic from here on -------------
+
+(RKs <- cbind(sapply(kernels,
+ function(k) density(kernel = k, give.Rkern = TRUE))))
+100*round(RKs["epanechnikov",]/RKs, 4) ## Efficiencies
+
+bw <- bw.SJ(precip) ## sensible automatic choice
+plot(density(precip, bw = bw),
+ main = "same sd bandwidths, 7 different kernels")
+for(i in 2:length(kernels))
+ lines(density(precip, bw = bw, kernel = kernels[i]), col = i)
+
+## Bandwidth Adjustment for "Exactly Equivalent Kernels"
+h.f <- sapply(kernels, function(k)density(kernel = k, give.Rkern = TRUE))
+(h.f <- (h.f["gaussian"] / h.f)^ .2)
+## -> 1, 1.01, .995, 1.007,... close to 1 => adjustment barely visible..
+
+plot(density(precip, bw = bw),
+ main = "equivalent bandwidths, 7 different kernels")
+for(i in 2:length(kernels))
+ lines(density(precip, bw = bw, adjust = h.f[i], kernel = kernels[i]),
+ col = i)
+legend(55, 0.035, legend = kernels, col = seq(kernels), lty = 1)
+
+
+
+cleanEx()
+nameEx("deriv")
+### * deriv
+
+flush(stderr()); flush(stdout())
+
+### Name: deriv
+### Title: Symbolic and Algorithmic Derivatives of Simple Expressions
+### Aliases: D deriv deriv.default deriv.formula deriv3 deriv3.default
+### deriv3.formula
+### Keywords: math nonlinear
+
+### ** Examples
+
+## formula argument :
+dx2x <- deriv(~ x^2, "x") ; dx2x
+## Not run:
+##D expression({
+##D .value <- x^2
+##D .grad <- array(0, c(length(.value), 1), list(NULL, c("x")))
+##D .grad[, "x"] <- 2 * x
+##D attr(.value, "gradient") <- .grad
+##D .value
+##D })
+## End(Not run)
+mode(dx2x)
+x <- -1:2
+eval(dx2x)
+
+## Something 'tougher':
+trig.exp <- expression(sin(cos(x + y^2)))
+( D.sc <- D(trig.exp, "x") )
+all.equal(D(trig.exp[[1]], "x"), D.sc)
+
+( dxy <- deriv(trig.exp, c("x", "y")) )
+y <- 1
+eval(dxy)
+eval(D.sc)
+
+## function returned:
+deriv((y ~ sin(cos(x) * y)), c("x","y"), func = TRUE)
+
+## function with defaulted arguments:
+(fx <- deriv(y ~ b0 + b1 * 2^(-x/th), c("b0", "b1", "th"),
+ function(b0, b1, th, x = 1:7){} ) )
+fx(2, 3, 4)
+
+## First derivative
+
+D(expression(x^2), "x")
+stopifnot(D(as.name("x"), "x") == 1)
+
+## Higher derivatives
+deriv3(y ~ b0 + b1 * 2^(-x/th), c("b0", "b1", "th"),
+ c("b0", "b1", "th", "x") )
+
+## Higher derivatives:
+DD <- function(expr, name, order = 1) {
+ if(order < 1) stop("'order' must be >= 1")
+ if(order == 1) D(expr, name)
+ else DD(D(expr, name), name, order - 1)
+}
+DD(expression(sin(x^2)), "x", 3)
+## showing the limits of the internal "simplify()" :
+## Not run:
+##D -sin(x^2) * (2 * x) * 2 + ((cos(x^2) * (2 * x) * (2 * x) + sin(x^2) *
+##D 2) * (2 * x) + sin(x^2) * (2 * x) * 2)
+## End(Not run)
+
+## New (R 3.4.0, 2017):
+D(quote(log1p(x^2)), "x") ## log1p(x) = log(1 + x)
+stopifnot(identical(
+ D(quote(log1p(x^2)), "x"),
+ D(quote(log(1+x^2)), "x")))
+D(quote(expm1(x^2)), "x") ## expm1(x) = exp(x) - 1
+stopifnot(identical(
+ D(quote(expm1(x^2)), "x") -> Dex1,
+ D(quote(exp(x^2)-1), "x")),
+ identical(Dex1, quote(exp(x^2) * (2 * x))))
+
+D(quote(sinpi(x^2)), "x") ## sinpi(x) = sin(pi*x)
+D(quote(cospi(x^2)), "x") ## cospi(x) = cos(pi*x)
+D(quote(tanpi(x^2)), "x") ## tanpi(x) = tan(pi*x)
+
+stopifnot(identical(D(quote(log2 (x^2)), "x"),
+ quote(2 * x/(x^2 * log(2)))),
+ identical(D(quote(log10(x^2)), "x"),
+ quote(2 * x/(x^2 * log(10)))))
+
+
+
+
+cleanEx()
+nameEx("diffinv")
+### * diffinv
+
+flush(stderr()); flush(stdout())
+
+### Name: diffinv
+### Title: Discrete Integration: Inverse of Differencing
+### Aliases: diffinv diffinv.default diffinv.ts
+### Keywords: ts
+
+### ** Examples
+
+s <- 1:10
+d <- diff(s)
+diffinv(d, xi = 1)
+
+
+
+cleanEx()
+nameEx("dist")
+### * dist
+
+flush(stderr()); flush(stdout())
+
+### Name: dist
+### Title: Distance Matrix Computation
+### Aliases: dist print.dist format.dist labels.dist as.matrix.dist as.dist
+### as.dist.default
+### Keywords: multivariate cluster
+
+### ** Examples
+
+require(graphics)
+
+x <- matrix(rnorm(100), nrow = 5)
+dist(x)
+dist(x, diag = TRUE)
+dist(x, upper = TRUE)
+m <- as.matrix(dist(x))
+d <- as.dist(m)
+stopifnot(d == dist(x))
+
+## Use correlations between variables "as distance"
+dd <- as.dist((1 - cor(USJudgeRatings))/2)
+round(1000 * dd) # (prints more nicely)
+plot(hclust(dd)) # to see a dendrogram of clustered variables
+
+## example of binary and canberra distances.
+x <- c(0, 0, 1, 1, 1, 1)
+y <- c(1, 0, 1, 1, 0, 1)
+dist(rbind(x, y), method = "binary")
+## answer 0.4 = 2/5
+dist(rbind(x, y), method = "canberra")
+## answer 2 * (6/5)
+
+## To find the names
+labels(eurodist)
+
+## Examples involving "Inf" :
+## 1)
+x[6] <- Inf
+(m2 <- rbind(x, y))
+dist(m2, method = "binary") # warning, answer 0.5 = 2/4
+## These all give "Inf":
+stopifnot(Inf == dist(m2, method = "euclidean"),
+ Inf == dist(m2, method = "maximum"),
+ Inf == dist(m2, method = "manhattan"))
+## "Inf" is same as very large number:
+x1 <- x; x1[6] <- 1e100
+stopifnot(dist(cbind(x, y), method = "canberra") ==
+ print(dist(cbind(x1, y), method = "canberra")))
+
+## 2)
+y[6] <- Inf #-> 6-th pair is excluded
+dist(rbind(x, y), method = "binary" ) # warning; 0.5
+dist(rbind(x, y), method = "canberra" ) # 3
+dist(rbind(x, y), method = "maximum") # 1
+dist(rbind(x, y), method = "manhattan") # 2.4
+
+
+
+cleanEx()
+nameEx("dummy.coef")
+### * dummy.coef
+
+flush(stderr()); flush(stdout())
+
+### Name: dummy.coef
+### Title: Extract Coefficients in Original Coding
+### Aliases: dummy.coef dummy.coef.lm dummy.coef.aovlist
+### Keywords: models
+
+### ** Examples
+
+options(contrasts = c("contr.helmert", "contr.poly"))
+## From Venables and Ripley (2002) p.165.
+npk.aov <- aov(yield ~ block + N*P*K, npk)
+dummy.coef(npk.aov)
+
+npk.aovE <- aov(yield ~ N*P*K + Error(block), npk)
+dummy.coef(npk.aovE)
+
+
+
+base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
+cleanEx()
+nameEx("ecdf")
+### * ecdf
+
+flush(stderr()); flush(stdout())
+
+### Name: ecdf
+### Title: Empirical Cumulative Distribution Function
+### Aliases: ecdf plot.ecdf print.ecdf summary.ecdf quantile.ecdf
+### Keywords: dplot hplot
+
+### ** Examples
+
+##-- Simple didactical ecdf example :
+x <- rnorm(12)
+Fn <- ecdf(x)
+Fn # a *function*
+Fn(x) # returns the percentiles for x
+tt <- seq(-2, 2, by = 0.1)
+12 * Fn(tt) # Fn is a 'simple' function {with values k/12}
+summary(Fn)
+##--> see below for graphics
+knots(Fn) # the unique data values {12 of them if there were no ties}
+
+y <- round(rnorm(12), 1); y[3] <- y[1]
+Fn12 <- ecdf(y)
+Fn12
+knots(Fn12) # unique values (always less than 12!)
+summary(Fn12)
+summary.stepfun(Fn12)
+
+## Advanced: What's inside the function closure?
+ls(environment(Fn12))
+##[1] "f" "method" "n" "x" "y" "yleft" "yright"
+utils::ls.str(environment(Fn12))
+stopifnot(all.equal(quantile(Fn12), quantile(y)))
+
+###----------------- Plotting --------------------------
+require(graphics)
+
+op <- par(mfrow = c(3, 1), mgp = c(1.5, 0.8, 0), mar = .1+c(3,3,2,1))
+
+F10 <- ecdf(rnorm(10))
+summary(F10)
+
+plot(F10)
+plot(F10, verticals = TRUE, do.points = FALSE)
+
+plot(Fn12 , lwd = 2) ; mtext("lwd = 2", adj = 1)
+xx <- unique(sort(c(seq(-3, 2, length = 201), knots(Fn12))))
+lines(xx, Fn12(xx), col = "blue")
+abline(v = knots(Fn12), lty = 2, col = "gray70")
+
+plot(xx, Fn12(xx), type = "o", cex = .1) #- plot.default {ugly}
+plot(Fn12, col.hor = "red", add = TRUE) #- plot method
+abline(v = knots(Fn12), lty = 2, col = "gray70")
+## luxury plot
+plot(Fn12, verticals = TRUE, col.points = "blue",
+ col.hor = "red", col.vert = "bisque")
+
+##-- this works too (automatic call to ecdf(.)):
+plot.ecdf(rnorm(24))
+title("via simple plot.ecdf(x)", adj = 1)
+
+par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("eff.aovlist")
+### * eff.aovlist
+
+flush(stderr()); flush(stdout())
+
+### Name: eff.aovlist
+### Title: Compute Efficiencies of Multistratum Analysis of Variance
+### Aliases: eff.aovlist
+### Keywords: models
+
+### ** Examples
+
+## An example from Yates (1932),
+## a 2^3 design in 2 blocks replicated 4 times
+
+Block <- gl(8, 4)
+A <- factor(c(0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,
+ 0,1,0,1,0,1,0,1,0,1,0,1))
+B <- factor(c(0,0,1,1,0,0,1,1,0,1,0,1,1,0,1,0,0,0,1,1,
+ 0,0,1,1,0,0,1,1,0,0,1,1))
+C <- factor(c(0,1,1,0,1,0,0,1,0,0,1,1,0,0,1,1,0,1,0,1,
+ 1,0,1,0,0,0,1,1,1,1,0,0))
+Yield <- c(101, 373, 398, 291, 312, 106, 265, 450, 106, 306, 324, 449,
+ 272, 89, 407, 338, 87, 324, 279, 471, 323, 128, 423, 334,
+ 131, 103, 445, 437, 324, 361, 302, 272)
+aovdat <- data.frame(Block, A, B, C, Yield)
+
+old <- getOption("contrasts")
+options(contrasts = c("contr.helmert", "contr.poly"))
+(fit <- aov(Yield ~ A*B*C + Error(Block), data = aovdat))
+eff.aovlist(fit)
+options(contrasts = old)
+
+
+
+base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
+cleanEx()
+nameEx("effects")
+### * effects
+
+flush(stderr()); flush(stdout())
+
+### Name: effects
+### Title: Effects from Fitted Model
+### Aliases: effects effects.lm effects.glm
+### Keywords: models regression
+
+### ** Examples
+
+y <- c(1:3, 7, 5)
+x <- c(1:3, 6:7)
+( ee <- effects(lm(y ~ x)) )
+c( round(ee - effects(lm(y+10 ~ I(x-3.8))), 3) )
+# just the first is different
+
+
+
+cleanEx()
+nameEx("embed")
+### * embed
+
+flush(stderr()); flush(stdout())
+
+### Name: embed
+### Title: Embedding a Time Series
+### Aliases: embed
+### Keywords: ts
+
+### ** Examples
+
+x <- 1:10
+embed (x, 3)
+
+
+
+cleanEx()
+nameEx("expand.model.frame")
+### * expand.model.frame
+
+flush(stderr()); flush(stdout())
+
+### Name: expand.model.frame
+### Title: Add new variables to a model frame
+### Aliases: expand.model.frame
+### Keywords: manip regression
+
+### ** Examples
+
+model <- lm(log(Volume) ~ log(Girth) + log(Height), data = trees)
+expand.model.frame(model, ~ Girth) # prints data.frame like
+
+dd <- data.frame(x = 1:5, y = rnorm(5), z = c(1,2,NA,4,5))
+model <- glm(y ~ x, data = dd, subset = 1:4, na.action = na.omit)
+expand.model.frame(model, "z", na.expand = FALSE) # = default
+expand.model.frame(model, "z", na.expand = TRUE)
+
+
+
+cleanEx()
+nameEx("extractAIC")
+### * extractAIC
+
+flush(stderr()); flush(stdout())
+
+### Name: extractAIC
+### Title: Extract AIC from a Fitted Model
+### Aliases: extractAIC
+### Keywords: models
+
+### ** Examples
+
+
+cleanEx()
+nameEx("factanal")
+### * factanal
+
+flush(stderr()); flush(stdout())
+
+### Name: factanal
+### Title: Factor Analysis
+### Aliases: factanal
+### Keywords: multivariate
+
+### ** Examples
+
+# A little demonstration, v2 is just v1 with noise,
+# and same for v4 vs. v3 and v6 vs. v5
+# Last four cases are there to add noise
+# and introduce a positive manifold (g factor)
+v1 <- c(1,1,1,1,1,1,1,1,1,1,3,3,3,3,3,4,5,6)
+v2 <- c(1,2,1,1,1,1,2,1,2,1,3,4,3,3,3,4,6,5)
+v3 <- c(3,3,3,3,3,1,1,1,1,1,1,1,1,1,1,5,4,6)
+v4 <- c(3,3,4,3,3,1,1,2,1,1,1,1,2,1,1,5,6,4)
+v5 <- c(1,1,1,1,1,3,3,3,3,3,1,1,1,1,1,6,4,5)
+v6 <- c(1,1,1,2,1,3,3,3,4,3,1,1,1,2,1,6,5,4)
+m1 <- cbind(v1,v2,v3,v4,v5,v6)
+cor(m1)
+factanal(m1, factors = 3) # varimax is the default
+# The following shows the g factor as PC1
+
+## formula interface
+factanal(~v1+v2+v3+v4+v5+v6, factors = 3,
+ scores = "Bartlett")$scores
+
+
+
+cleanEx()
+nameEx("factor.scope")
+### * factor.scope
+
+flush(stderr()); flush(stdout())
+
+### Name: factor.scope
+### Title: Compute Allowed Changes in Adding to or Dropping from a Formula
+### Aliases: add.scope drop.scope factor.scope
+### Keywords: models
+
+### ** Examples
+
+add.scope( ~ a + b + c + a:b, ~ (a + b + c)^3)
+# [1] "a:c" "b:c"
+drop.scope( ~ a + b + c + a:b)
+# [1] "c" "a:b"
+
+
+
+cleanEx()
+nameEx("family")
+### * family
+
+flush(stderr()); flush(stdout())
+
+### Name: family
+### Title: Family Objects for Models
+### Aliases: family binomial gaussian Gamma inverse.gaussian poisson quasi
+### quasibinomial quasipoisson
+### Keywords: models
+
+### ** Examples
+
+require(utils) # for str
+
+nf <- gaussian() # Normal family
+nf
+str(nf)
+
+gf <- Gamma()
+gf
+str(gf)
+gf$linkinv
+gf$variance(-3:4) #- == (.)^2
+
+
+## quasipoisson. compare with example(glm)
+counts <- c(18,17,15,20,10,20,25,13,12)
+outcome <- gl(3,1,9)
+treatment <- gl(3,3)
+d.AD <- data.frame(treatment, outcome, counts)
+glm.qD93 <- glm(counts ~ outcome + treatment, family = quasipoisson())
+
+## Example of user-specified link, a logit model for p^days
+## See Shaffer, T. 2004. Auk 121(2): 526-540.
+logexp <- function(days = 1)
+{
+ linkfun <- function(mu) qlogis(mu^(1/days))
+ linkinv <- function(eta) plogis(eta)^days
+ mu.eta <- function(eta) days * plogis(eta)^(days-1) * binomial()$mu_eta
+ valideta <- function(eta) TRUE
+ link <- paste0("logexp(", days, ")")
+ structure(list(linkfun = linkfun, linkinv = linkinv,
+ mu.eta = mu.eta, valideta = valideta, name = link),
+ class = "link-glm")
+}
+binomial(logexp(3))
+## in practice this would be used with a vector of 'days', in
+## which case use an offset of 0 in the corresponding formula
+## to get the null deviance right.
+
+## Binomial with identity link: often not a good idea.
+## Not run: binomial(link = make.link("identity"))
+
+## tests of quasi
+x <- rnorm(100)
+y <- rpois(100, exp(1+x))
+glm(y ~ x, family = quasi(variance = "mu", link = "log"))
+# which is the same as
+glm(y ~ x, family = poisson)
+glm(y ~ x, family = quasi(variance = "mu^2", link = "log"))
+## Not run: glm(y ~ x, family = quasi(variance = "mu^3", link = "log")) # fails
+y <- rbinom(100, 1, plogis(x))
+# needs to set a starting value for the next fit
+glm(y ~ x, family = quasi(variance = "mu(1-mu)", link = "logit"), start = c(0,1))
+
+
+
+cleanEx()
+nameEx("fft")
+### * fft
+
+flush(stderr()); flush(stdout())
+
+### Name: fft
+### Title: Fast Discrete Fourier Transform (FFT)
+### Aliases: fft mvfft
+### Keywords: math dplot
+
+### ** Examples
+
+x <- 1:4
+fft(x)
+fft(fft(x), inverse = TRUE)/length(x)
+
+## Slow Discrete Fourier Transform (DFT) - e.g., for checking the formula
+fft0 <- function(z, inverse=FALSE) {
+ n <- length(z)
+ if(n == 0) return(z)
+ k <- 0:(n-1)
+ ff <- (if(inverse) 1 else -1) * 2*pi * 1i * k/n
+ vapply(1:n, function(h) sum(z * exp(ff*(h-1))), complex(1))
+}
+
+relD <- function(x,y) 2* abs(x - y) / abs(x + y)
+n <- 2^8
+z <- complex(n, rnorm(n), rnorm(n))
+
+
+cleanEx()
+nameEx("filter")
+### * filter
+
+flush(stderr()); flush(stdout())
+
+### Name: filter
+### Title: Linear Filtering on a Time Series
+### Aliases: filter
+### Keywords: ts
+
+### ** Examples
+
+x <- 1:100
+filter(x, rep(1, 3))
+filter(x, rep(1, 3), sides = 1)
+filter(x, rep(1, 3), sides = 1, circular = TRUE)
+
+filter(presidents, rep(1, 3))
+
+
+
+cleanEx()
+nameEx("fisher.test")
+### * fisher.test
+
+flush(stderr()); flush(stdout())
+
+### Name: fisher.test
+### Title: Fisher's Exact Test for Count Data
+### Aliases: fisher.test
+### Keywords: htest
+
+### ** Examples
+
+## Agresti (1990, p. 61f; 2002, p. 91) Fisher's Tea Drinker
+## A British woman claimed to be able to distinguish whether milk or
+## tea was added to the cup first. To test, she was given 8 cups of
+## tea, in four of which milk was added first. The null hypothesis
+## is that there is no association between the true order of pouring
+## and the woman's guess, the alternative that there is a positive
+## association (that the odds ratio is greater than 1).
+TeaTasting <-
+matrix(c(3, 1, 1, 3),
+ nrow = 2,
+ dimnames = list(Guess = c("Milk", "Tea"),
+ Truth = c("Milk", "Tea")))
+fisher.test(TeaTasting, alternative = "greater")
+## => p = 0.2429, association could not be established
+
+## Fisher (1962, 1970), Criminal convictions of like-sex twins
+Convictions <-
+matrix(c(2, 10, 15, 3),
+ nrow = 2,
+ dimnames =
+ list(c("Dizygotic", "Monozygotic"),
+ c("Convicted", "Not convicted")))
+Convictions
+fisher.test(Convictions, alternative = "less")
+fisher.test(Convictions, conf.int = FALSE)
+fisher.test(Convictions, conf.level = 0.95)$conf.int
+fisher.test(Convictions, conf.level = 0.99)$conf.int
+
+## A r x c table Agresti (2002, p. 57) Job Satisfaction
+Job <- matrix(c(1,2,1,0, 3,3,6,1, 10,10,14,9, 6,7,12,11), 4, 4,
+dimnames = list(income = c("< 15k", "15-25k", "25-40k", "> 40k"),
+ satisfaction = c("VeryD", "LittleD", "ModerateS", "VeryS")))
+fisher.test(Job)
+fisher.test(Job, simulate.p.value = TRUE, B = 1e5)
+
+
+
+cleanEx()
+nameEx("fivenum")
+### * fivenum
+
+flush(stderr()); flush(stdout())
+
+### Name: fivenum
+### Title: Tukey Five-Number Summaries
+### Aliases: fivenum
+### Keywords: univar robust distribution
+
+### ** Examples
+
+fivenum(c(rnorm(100), -1:1/0))
+
+
+
+cleanEx()
+nameEx("fligner.test")
+### * fligner.test
+
+flush(stderr()); flush(stdout())
+
+### Name: fligner.test
+### Title: Fligner-Killeen Test of Homogeneity of Variances
+### Aliases: fligner.test fligner.test.default fligner.test.formula
+### Keywords: htest
+
+### ** Examples
+
+require(graphics)
+
+plot(count ~ spray, data = InsectSprays)
+fligner.test(InsectSprays$count, InsectSprays$spray)
+fligner.test(count ~ spray, data = InsectSprays)
+## Compare this to bartlett.test()
+
+
+
+cleanEx()
+nameEx("formula")
+### * formula
+
+flush(stderr()); flush(stdout())
+
+### Name: formula
+### Title: Model Formulae
+### Aliases: formula formula.default formula.formula formula.terms
+### formula.data.frame as.formula print.formula [.formula
+### Keywords: models
+
+### ** Examples
+
+class(fo <- y ~ x1*x2) # "formula"
+fo
+typeof(fo) # R internal : "language"
+terms(fo)
+
+environment(fo)
+environment(as.formula("y ~ x"))
+environment(as.formula("y ~ x", env = new.env()))
+
+
+## Create a formula for a model with a large number of variables:
+xnam <- paste0("x", 1:25)
+(fmla <- as.formula(paste("y ~ ", paste(xnam, collapse= "+"))))
+
+
+
+cleanEx()
+nameEx("formula.nls")
+### * formula.nls
+
+flush(stderr()); flush(stdout())
+
+### Name: formula.nls
+### Title: Extract Model Formula from nls Object
+### Aliases: formula.nls
+### Keywords: models
+
+### ** Examples
+
+fm1 <- nls(circumference ~ A/(1+exp((B-age)/C)), Orange,
+ start = list(A = 160, B = 700, C = 350))
+formula(fm1)
+
+
+
+cleanEx()
+nameEx("friedman.test")
+### * friedman.test
+
+flush(stderr()); flush(stdout())
+
+### Name: friedman.test
+### Title: Friedman Rank Sum Test
+### Aliases: friedman.test friedman.test.default friedman.test.formula
+### Keywords: htest
+
+### ** Examples
+
+## Hollander & Wolfe (1973), p. 140ff.
+## Comparison of three methods ("round out", "narrow angle", and
+## "wide angle") for rounding first base. For each of 18 players
+## and the three method, the average time of two runs from a point on
+## the first base line 35ft from home plate to a point 15ft short of
+## second base is recorded.
+RoundingTimes <-
+matrix(c(5.40, 5.50, 5.55,
+ 5.85, 5.70, 5.75,
+ 5.20, 5.60, 5.50,
+ 5.55, 5.50, 5.40,
+ 5.90, 5.85, 5.70,
+ 5.45, 5.55, 5.60,
+ 5.40, 5.40, 5.35,
+ 5.45, 5.50, 5.35,
+ 5.25, 5.15, 5.00,
+ 5.85, 5.80, 5.70,
+ 5.25, 5.20, 5.10,
+ 5.65, 5.55, 5.45,
+ 5.60, 5.35, 5.45,
+ 5.05, 5.00, 4.95,
+ 5.50, 5.50, 5.40,
+ 5.45, 5.55, 5.50,
+ 5.55, 5.55, 5.35,
+ 5.45, 5.50, 5.55,
+ 5.50, 5.45, 5.25,
+ 5.65, 5.60, 5.40,
+ 5.70, 5.65, 5.55,
+ 6.30, 6.30, 6.25),
+ nrow = 22,
+ byrow = TRUE,
+ dimnames = list(1 : 22,
+ c("Round Out", "Narrow Angle", "Wide Angle")))
+friedman.test(RoundingTimes)
+## => strong evidence against the null that the methods are equivalent
+## with respect to speed
+
+wb <- aggregate(warpbreaks$breaks,
+ by = list(w = warpbreaks$wool,
+ t = warpbreaks$tension),
+ FUN = mean)
+wb
+friedman.test(wb$x, wb$w, wb$t)
+friedman.test(x ~ w | t, data = wb)
+
+
+
+cleanEx()
+nameEx("ftable")
+### * ftable
+
+flush(stderr()); flush(stdout())
+
+### Name: ftable
+### Title: Flat Contingency Tables
+### Aliases: ftable ftable.default
+### Keywords: category
+
+### ** Examples
+
+## Start with a contingency table.
+ftable(Titanic, row.vars = 1:3)
+ftable(Titanic, row.vars = 1:2, col.vars = "Survived")
+ftable(Titanic, row.vars = 2:1, col.vars = "Survived")
+## Don't show:
+. <- integer()
+(f04 <- ftable(Titanic, col.vars= .))
+(f10 <- ftable(Titanic, col.vars= 1, row.vars= .))
+(f01 <- ftable(Titanic, col.vars= ., row.vars= 1))
+(f00 <- ftable(Titanic, col.vars= ., row.vars= .))
+stopifnot(
+ dim(f04) == c(32,1),
+ dim(f10) == c(1,4),
+ dim(f01) == c(4,1),
+ dim(f00) == c(1,1))
+## End(Don't show)
+## Start with a data frame.
+x <- ftable(mtcars[c("cyl", "vs", "am", "gear")])
+x
+ftable(x, row.vars = c(2, 4))
+
+## Start with expressions, use table()'s "dnn" to change labels
+ftable(mtcars$cyl, mtcars$vs, mtcars$am, mtcars$gear, row.vars = c(2, 4),
+ dnn = c("Cylinders", "V/S", "Transmission", "Gears"))
+
+
+
+cleanEx()
+nameEx("ftable.formula")
+### * ftable.formula
+
+flush(stderr()); flush(stdout())
+
+### Name: ftable.formula
+### Title: Formula Notation for Flat Contingency Tables
+### Aliases: ftable.formula
+### Keywords: category
+
+### ** Examples
+
+Titanic
+x <- ftable(Survived ~ ., data = Titanic)
+x
+ftable(Sex ~ Class + Age, data = x)
+
+
+
+cleanEx()
+nameEx("getInitial")
+### * getInitial
+
+flush(stderr()); flush(stdout())
+
+### Name: getInitial
+### Title: Get Initial Parameter Estimates
+### Aliases: getInitial getInitial.default getInitial.formula
+### getInitial.selfStart
+### Keywords: models nonlinear manip
+
+### ** Examples
+
+PurTrt <- Puromycin[ Puromycin$state == "treated", ]
+print(getInitial( rate ~ SSmicmen( conc, Vm, K ), PurTrt ), digits = 3)
+
+
+
+cleanEx()
+nameEx("glm")
+### * glm
+
+flush(stderr()); flush(stdout())
+
+### Name: glm
+### Title: Fitting Generalized Linear Models
+### Aliases: glm glm.fit weights.glm
+### Keywords: models regression
+
+### ** Examples
+
+## Dobson (1990) Page 93: Randomized Controlled Trial :
+counts <- c(18,17,15,20,10,20,25,13,12)
+outcome <- gl(3,1,9)
+treatment <- gl(3,3)
+print(d.AD <- data.frame(treatment, outcome, counts))
+glm.D93 <- glm(counts ~ outcome + treatment, family = poisson())
+anova(glm.D93)
+
+
+# A Gamma example, from McCullagh & Nelder (1989, pp. 300-2)
+clotting <- data.frame(
+ u = c(5,10,15,20,30,40,60,80,100),
+ lot1 = c(118,58,42,35,27,25,21,19,18),
+ lot2 = c(69,35,26,21,18,16,13,12,12))
+summary(glm(lot1 ~ log(u), data = clotting, family = Gamma))
+summary(glm(lot2 ~ log(u), data = clotting, family = Gamma))
+
+## Not run:
+##D ## for an example of the use of a terms object as a formula
+##D demo(glm.vr)
+## End(Not run)
+
+
+cleanEx()
+nameEx("glm.control")
+### * glm.control
+
+flush(stderr()); flush(stdout())
+
+### Name: glm.control
+### Title: Auxiliary for Controlling GLM Fitting
+### Aliases: glm.control
+### Keywords: optimize models
+
+### ** Examples
+
+
+cleanEx()
+nameEx("hclust")
+### * hclust
+
+flush(stderr()); flush(stdout())
+
+### Name: hclust
+### Title: Hierarchical Clustering
+### Aliases: hclust plot.hclust print.hclust
+### Keywords: multivariate cluster
+
+### ** Examples
+
+require(graphics)
+
+### Example 1: Violent crime rates by US state
+
+hc <- hclust(dist(USArrests), "ave")
+plot(hc)
+plot(hc, hang = -1)
+
+## Do the same with centroid clustering and *squared* Euclidean distance,
+## cut the tree into ten clusters and reconstruct the upper part of the
+## tree from the cluster centers.
+hc <- hclust(dist(USArrests)^2, "cen")
+memb <- cutree(hc, k = 10)
+cent <- NULL
+for(k in 1:10){
+ cent <- rbind(cent, colMeans(USArrests[memb == k, , drop = FALSE]))
+}
+hc1 <- hclust(dist(cent)^2, method = "cen", members = table(memb))
+opar <- par(mfrow = c(1, 2))
+plot(hc, labels = FALSE, hang = -1, main = "Original Tree")
+plot(hc1, labels = FALSE, hang = -1, main = "Re-start from 10 clusters")
+par(opar)
+
+### Example 2: Straight-line distances among 10 US cities
+## Compare the results of algorithms "ward.D" and "ward.D2"
+
+data(UScitiesD)
+
+mds2 <- -cmdscale(UScitiesD)
+plot(mds2, type="n", axes=FALSE, ann=FALSE)
+text(mds2, labels=rownames(mds2), xpd = NA)
+
+hcity.D <- hclust(UScitiesD, "ward.D") # "wrong"
+hcity.D2 <- hclust(UScitiesD, "ward.D2")
+opar <- par(mfrow = c(1, 2))
+plot(hcity.D, hang=-1)
+plot(hcity.D2, hang=-1)
+par(opar)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("heatmap")
+### * heatmap
+
+flush(stderr()); flush(stdout())
+
+### Name: heatmap
+### Title: Draw a Heat Map
+### Aliases: heatmap
+### Keywords: hplot
+
+### ** Examples
+
+require(graphics); require(grDevices)
+x <- as.matrix(mtcars)
+rc <- rainbow(nrow(x), start = 0, end = .3)
+cc <- rainbow(ncol(x), start = 0, end = .3)
+hv <- heatmap(x, col = cm.colors(256), scale = "column",
+ RowSideColors = rc, ColSideColors = cc, margins = c(5,10),
+ xlab = "specification variables", ylab = "Car Models",
+ main = "heatmap(<Mtcars data>, ..., scale = \"column\")")
+utils::str(hv) # the two re-ordering index vectors
+
+## no column dendrogram (nor reordering) at all:
+heatmap(x, Colv = NA, col = cm.colors(256), scale = "column",
+ RowSideColors = rc, margins = c(5,10),
+ xlab = "specification variables", ylab = "Car Models",
+ main = "heatmap(<Mtcars data>, ..., scale = \"column\")")
+## Don't show:
+## no row dendrogram (nor reordering) at all:
+heatmap(x, Rowv = NA, col = cm.colors(256), scale = "column",
+ ColSideColors = cc, margins = c(5,10),
+ xlab = "xlab", ylab = "ylab") # no main
+## End(Don't show)
+## "no nothing"
+heatmap(x, Rowv = NA, Colv = NA, scale = "column",
+ main = "heatmap(*, NA, NA) ~= image(t(x))")
+
+round(Ca <- cor(attitude), 2)
+symnum(Ca) # simple graphic
+heatmap(Ca, symm = TRUE, margins = c(6,6)) # with reorder()
+heatmap(Ca, Rowv = FALSE, symm = TRUE, margins = c(6,6)) # _NO_ reorder()
+## slightly artificial with color bar, without and with ordering:
+cc <- rainbow(nrow(Ca))
+heatmap(Ca, Rowv = FALSE, symm = TRUE, RowSideColors = cc, ColSideColors = cc,
+ margins = c(6,6))
+heatmap(Ca, symm = TRUE, RowSideColors = cc, ColSideColors = cc,
+ margins = c(6,6))
+
+## For variable clustering, rather use distance based on cor():
+symnum( cU <- cor(USJudgeRatings) )
+
+hU <- heatmap(cU, Rowv = FALSE, symm = TRUE, col = topo.colors(16),
+ distfun = function(c) as.dist(1 - c), keep.dendro = TRUE)
+## The Correlation matrix with same reordering:
+round(100 * cU[hU[[1]], hU[[2]]])
+## The column dendrogram:
+utils::str(hU$Colv)
+
+
+
+cleanEx()
+nameEx("identify.hclust")
+### * identify.hclust
+
+flush(stderr()); flush(stdout())
+
+### Name: identify.hclust
+### Title: Identify Clusters in a Dendrogram
+### Aliases: identify.hclust
+### Keywords: cluster iplot
+
+### ** Examples
+## Not run:
+##D require(graphics)
+##D
+##D hca <- hclust(dist(USArrests))
+##D plot(hca)
+##D (x <- identify(hca)) ## Terminate with 2nd mouse button !!
+##D
+##D hci <- hclust(dist(iris[,1:4]))
+##D plot(hci)
+##D identify(hci, function(k) print(table(iris[k,5])))
+##D
+##D # open a new device (one for dendrogram, one for bars):
+##D dev.new() # << make that narrow (& small)
+##D # and *beside* 1st one
+##D nD <- dev.cur() # to be for the barplot
+##D dev.set(dev.prev()) # old one for dendrogram
+##D plot(hci)
+##D ## select subtrees in dendrogram and "see" the species distribution:
+##D identify(hci, function(k) barplot(table(iris[k,5]), col = 2:4), DEV.FUN = nD)
+## End(Not run)
+
+
+cleanEx()
+nameEx("influence.measures")
+### * influence.measures
+
+flush(stderr()); flush(stdout())
+
+### Name: influence.measures
+### Title: Regression Deletion Diagnostics
+### Aliases: influence.measures hat hatvalues hatvalues.lm rstandard
+### rstandard.lm rstandard.glm rstudent rstudent.lm rstudent.glm dfbeta
+### dfbeta.lm dfbetas dfbetas.lm dffits covratio cooks.distance
+### cooks.distance.lm cooks.distance.glm
+### Keywords: regression
+
+### ** Examples
+
+require(graphics)
+
+## Analysis of the life-cycle savings data
+## given in Belsley, Kuh and Welsch.
+lm.SR <- lm(sr ~ pop15 + pop75 + dpi + ddpi, data = LifeCycleSavings)
+
+inflm.SR <- influence.measures(lm.SR)
+which(apply(inflm.SR$is.inf, 1, any))
+# which observations 'are' influential
+summary(inflm.SR) # only these
+plot(rstudent(lm.SR) ~ hatvalues(lm.SR)) # recommended by some
+plot(lm.SR, which = 5) # an enhanced version of that via plot(<lm>)
+
+## The 'infl' argument is not needed, but avoids recomputation:
+rs <- rstandard(lm.SR)
+iflSR <- influence(lm.SR)
+identical(rs, rstandard(lm.SR, infl = iflSR))
+## to "see" the larger values:
+1000 * round(dfbetas(lm.SR, infl = iflSR), 3)
+cat("PRESS :"); (PRESS <- sum( rstandard(lm.SR, type = "predictive")^2 ))
+stopifnot(all.equal(PRESS, sum( (residuals(lm.SR) / (1 - iflSR$hat))^2)))
+
+## Show that "PRE-residuals" == L.O.O. Crossvalidation (CV) errors:
+X <- model.matrix(lm.SR)
+y <- model.response(model.frame(lm.SR))
+## Leave-one-out CV least-squares prediction errors (relatively fast)
+rCV <- vapply(seq_len(nrow(X)), function(i)
+ y[i] - X[i,] %*% .lm.fit(X[-i,], y[-i])$coef,
+ numeric(1))
+## are the same as the *faster* rstandard(*, "pred") :
+stopifnot(all.equal(rCV, unname(rstandard(lm.SR, type = "predictive"))))
+
+
+## Huber's data [Atkinson 1985]
+xh <- c(-4:0, 10)
+yh <- c(2.48, .73, -.04, -1.44, -1.32, 0)
+lmH <- lm(yh ~ xh)
+im <- influence.measures(lmH)
+plot(xh,yh, main = "Huber's data: L.S. line and influential obs.")
+abline(lmH); points(xh[im$is.inf], yh[im$is.inf], pch = 20, col = 2)
+
+## Irwin's data [Williams 1987]
+xi <- 1:5
+yi <- c(0,2,14,19,30) # number of mice responding to dose xi
+mi <- rep(40, 5) # number of mice exposed
+glmI <- glm(cbind(yi, mi -yi) ~ xi, family = binomial)
+signif(cooks.distance(glmI), 3) # ~= Ci in Table 3, p.184
+imI <- influence.measures(glmI)
+stopifnot(all.equal(imI$infmat[,"cook.d"],
+ cooks.distance(glmI)))
+
+
+
+cleanEx()
+nameEx("integrate")
+### * integrate
+
+flush(stderr()); flush(stdout())
+
+### Name: integrate
+### Title: Integration of One-Dimensional Functions
+### Aliases: integrate print.integrate
+### Keywords: math utilities
+
+### ** Examples
+
+integrate(dnorm, -1.96, 1.96)
+integrate(dnorm, -Inf, Inf)
+
+## a slowly-convergent integral
+integrand <- function(x) {1/((x+1)*sqrt(x))}
+integrate(integrand, lower = 0, upper = Inf)
+
+## don't do this if you really want the integral from 0 to Inf
+integrate(integrand, lower = 0, upper = 10)
+integrate(integrand, lower = 0, upper = 100000)
+integrate(integrand, lower = 0, upper = 1000000, stop.on.error = FALSE)
+
+## some functions do not handle vector input properly
+f <- function(x) 2.0
+try(integrate(f, 0, 1))
+integrate(Vectorize(f), 0, 1) ## correct
+integrate(function(x) rep(2.0, length(x)), 0, 1) ## correct
+
+## integrate can fail if misused
+integrate(dnorm, 0, 2)
+integrate(dnorm, 0, 20)
+integrate(dnorm, 0, 200)
+integrate(dnorm, 0, 2000)
+integrate(dnorm, 0, 20000) ## fails on many systems
+integrate(dnorm, 0, Inf) ## works
+## Don't show:
+tools::assertError(
+## End(Don't show)
+integrate(dnorm, 0:1, 20) #-> error!
+## "silently" gave integrate(dnorm, 0, 20) in earlier versions of R
+## Don't show:
+ , verbose=TRUE)
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("interaction.plot")
+### * interaction.plot
+
+flush(stderr()); flush(stdout())
+
+### Name: interaction.plot
+### Title: Two-way Interaction Plot
+### Aliases: interaction.plot
+### Keywords: hplot
+
+### ** Examples
+
+require(graphics)
+
+with(ToothGrowth, {
+interaction.plot(dose, supp, len, fixed = TRUE)
+dose <- ordered(dose)
+interaction.plot(dose, supp, len, fixed = TRUE, col = 2:3, leg.bty = "o")
+interaction.plot(dose, supp, len, fixed = TRUE, col = 2:3, type = "p")
+})
+
+with(OrchardSprays, {
+ interaction.plot(treatment, rowpos, decrease)
+ interaction.plot(rowpos, treatment, decrease, cex.axis = 0.8)
+ ## order the rows by their mean effect
+ rowpos <- factor(rowpos,
+ levels = sort.list(tapply(decrease, rowpos, mean)))
+ interaction.plot(rowpos, treatment, decrease, col = 2:9, lty = 1)
+})
+
+with(esoph, {
+ interaction.plot(agegp, alcgp, ncases/ncontrols, main = "'esoph' Data")
+ interaction.plot(agegp, tobgp, ncases/ncontrols, trace.label = "tobacco",
+ fixed = TRUE, xaxt = "n")
+})
+## deal with NAs:
+esoph[66,] # second to last age group: 65-74
+esophNA <- esoph; esophNA$ncases[66] <- NA
+with(esophNA, {
+ interaction.plot(agegp, alcgp, ncases/ncontrols, col = 2:5)
+ # doesn't show *last* group either
+ interaction.plot(agegp, alcgp, ncases/ncontrols, col = 2:5, type = "b")
+ ## alternative take non-NA's {"cheating"}
+ interaction.plot(agegp, alcgp, ncases/ncontrols, col = 2:5,
+ fun = function(x) mean(x, na.rm = TRUE),
+ sub = "function(x) mean(x, na.rm=TRUE)")
+})
+rm(esophNA) # to clear up
+
+
+
+cleanEx()
+nameEx("is.empty")
+### * is.empty
+
+flush(stderr()); flush(stdout())
+
+### Name: is.empty.model
+### Title: Test if a Model's Formula is Empty
+### Aliases: is.empty.model
+### Keywords: models
+
+### ** Examples
+
+y <- rnorm(20)
+is.empty.model(y ~ 0)
+is.empty.model(y ~ -1)
+is.empty.model(lm(y ~ 0))
+
+
+
+cleanEx()
+nameEx("isoreg")
+### * isoreg
+
+flush(stderr()); flush(stdout())
+
+### Name: isoreg
+### Title: Isotonic / Monotone Regression
+### Aliases: isoreg
+### Keywords: regression smooth
+
+### ** Examples
+
+require(graphics)
+
+(ir <- isoreg(c(1,0,4,3,3,5,4,2,0)))
+plot(ir, plot.type = "row")
+
+(ir3 <- isoreg(y3 <- c(1,0,4,3,3,5,4,2, 3))) # last "3", not "0"
+(fi3 <- as.stepfun(ir3))
+(ir4 <- isoreg(1:10, y4 <- c(5, 9, 1:2, 5:8, 3, 8)))
+cat(sprintf("R^2 = %.2f\n",
+ 1 - sum(residuals(ir4)^2) / ((10-1)*var(y4))))
+
+## If you are interested in the knots alone :
+with(ir4, cbind(iKnots, yf[iKnots]))
+
+## Example of unordered x[] with ties:
+x <- sample((0:30)/8)
+y <- exp(x)
+x. <- round(x) # ties!
+plot(m <- isoreg(x., y))
+stopifnot(all.equal(with(m, yf[iKnots]),
+ as.vector(tapply(y, x., mean))))
+
+
+
+cleanEx()
+nameEx("kernapply")
+### * kernapply
+
+flush(stderr()); flush(stdout())
+
+### Name: kernapply
+### Title: Apply Smoothing Kernel
+### Aliases: kernapply kernapply.default kernapply.ts kernapply.tskernel
+### kernapply.vector
+### Keywords: ts
+
+### ** Examples
+
+## see 'kernel' for examples
+
+
+
+cleanEx()
+nameEx("kernel")
+### * kernel
+
+flush(stderr()); flush(stdout())
+
+### Name: kernel
+### Title: Smoothing Kernel Objects
+### Aliases: kernel bandwidth.kernel df.kernel is.tskernel plot.tskernel
+### Keywords: ts
+
+### ** Examples
+
+require(graphics)
+
+## Demonstrate a simple trading strategy for the
+## financial time series German stock index DAX.
+x <- EuStockMarkets[,1]
+k1 <- kernel("daniell", 50) # a long moving average
+k2 <- kernel("daniell", 10) # and a short one
+plot(k1)
+plot(k2)
+x1 <- kernapply(x, k1)
+x2 <- kernapply(x, k2)
+plot(x)
+lines(x1, col = "red") # go long if the short crosses the long upwards
+lines(x2, col = "green") # and go short otherwise
+
+## More interesting kernels
+kd <- kernel("daniell", c(3, 3))
+kd # note the unusual indexing
+kd[-2:2]
+plot(kernel("fejer", 100, r = 6))
+plot(kernel("modified.daniell", c(7,5,3)))
+
+# Reproduce example 10.4.3 from Brockwell and Davis (1991)
+spectrum(sunspot.year, kernel = kernel("daniell", c(11,7,3)), log = "no")
+
+
+
+cleanEx()
+nameEx("kmeans")
+### * kmeans
+
+flush(stderr()); flush(stdout())
+
+### Name: kmeans
+### Title: K-Means Clustering
+### Aliases: kmeans print.kmeans fitted.kmeans
+### Keywords: multivariate cluster
+
+### ** Examples
+
+require(graphics)
+
+# a 2-dimensional example
+x <- rbind(matrix(rnorm(100, sd = 0.3), ncol = 2),
+ matrix(rnorm(100, mean = 1, sd = 0.3), ncol = 2))
+colnames(x) <- c("x", "y")
+(cl <- kmeans(x, 2))
+plot(x, col = cl$cluster)
+points(cl$centers, col = 1:2, pch = 8, cex = 2)
+
+# sum of squares
+ss <- function(x) sum(scale(x, scale = FALSE)^2)
+
+## cluster centers "fitted" to each obs.:
+fitted.x <- fitted(cl); head(fitted.x)
+resid.x <- x - fitted(cl)
+
+## Equalities : ----------------------------------
+cbind(cl[c("betweenss", "tot.withinss", "totss")], # the same two columns
+ c(ss(fitted.x), ss(resid.x), ss(x)))
+stopifnot(all.equal(cl$ totss, ss(x)),
+ all.equal(cl$ tot.withinss, ss(resid.x)),
+ ## these three are the same:
+ all.equal(cl$ betweenss, ss(fitted.x)),
+ all.equal(cl$ betweenss, cl$totss - cl$tot.withinss),
+ ## and hence also
+ all.equal(ss(x), ss(fitted.x) + ss(resid.x))
+ )
+
+kmeans(x,1)$withinss # trivial one-cluster, (its W.SS == ss(x))
+
+## random starts do help here with too many clusters
+## (and are often recommended anyway!):
+(cl <- kmeans(x, 5, nstart = 25))
+plot(x, col = cl$cluster)
+points(cl$centers, col = 1:5, pch = 8)
+
+
+
+cleanEx()
+nameEx("kruskal.test")
+### * kruskal.test
+
+flush(stderr()); flush(stdout())
+
+### Name: kruskal.test
+### Title: Kruskal-Wallis Rank Sum Test
+### Aliases: kruskal.test kruskal.test.default kruskal.test.formula
+### Keywords: htest
+
+### ** Examples
+
+## Hollander & Wolfe (1973), 116.
+## Mucociliary efficiency from the rate of removal of dust in normal
+## subjects, subjects with obstructive airway disease, and subjects
+## with asbestosis.
+x <- c(2.9, 3.0, 2.5, 2.6, 3.2) # normal subjects
+y <- c(3.8, 2.7, 4.0, 2.4) # with obstructive airway disease
+z <- c(2.8, 3.4, 3.7, 2.2, 2.0) # with asbestosis
+kruskal.test(list(x, y, z))
+## Equivalently,
+x <- c(x, y, z)
+g <- factor(rep(1:3, c(5, 4, 5)),
+ labels = c("Normal subjects",
+ "Subjects with obstructive airway disease",
+ "Subjects with asbestosis"))
+kruskal.test(x, g)
+
+## Formula interface.
+require(graphics)
+boxplot(Ozone ~ Month, data = airquality)
+kruskal.test(Ozone ~ Month, data = airquality)
+
+
+
+cleanEx()
+nameEx("ks.test")
+### * ks.test
+
+flush(stderr()); flush(stdout())
+
+### Name: ks.test
+### Title: Kolmogorov-Smirnov Tests
+### Aliases: ks.test
+### Keywords: htest
+
+### ** Examples
+
+require(graphics)
+
+x <- rnorm(50)
+y <- runif(30)
+# Do x and y come from the same distribution?
+ks.test(x, y)
+# Does x come from a shifted gamma distribution with shape 3 and rate 2?
+ks.test(x+2, "pgamma", 3, 2) # two-sided, exact
+ks.test(x+2, "pgamma", 3, 2, exact = FALSE)
+ks.test(x+2, "pgamma", 3, 2, alternative = "gr")
+
+# test if x is stochastically larger than x2
+x2 <- rnorm(50, -1)
+plot(ecdf(x), xlim = range(c(x, x2)))
+plot(ecdf(x2), add = TRUE, lty = "dashed")
+t.test(x, x2, alternative = "g")
+wilcox.test(x, x2, alternative = "g")
+ks.test(x, x2, alternative = "l")
+
+
+
+cleanEx()
+nameEx("ksmooth")
+### * ksmooth
+
+flush(stderr()); flush(stdout())
+
+### Name: ksmooth
+### Title: Kernel Regression Smoother
+### Aliases: ksmooth
+### Keywords: smooth
+
+### ** Examples
+
+require(graphics)
+
+with(cars, {
+ plot(speed, dist)
+ lines(ksmooth(speed, dist, "normal", bandwidth = 2), col = 2)
+ lines(ksmooth(speed, dist, "normal", bandwidth = 5), col = 3)
+})
+
+
+
+cleanEx()
+nameEx("lag")
+### * lag
+
+flush(stderr()); flush(stdout())
+
+### Name: lag
+### Title: Lag a Time Series
+### Aliases: lag lag.default
+### Keywords: ts
+
+### ** Examples
+
+lag(ldeaths, 12) # starts one year earlier
+
+
+
+cleanEx()
+nameEx("lag.plot")
+### * lag.plot
+
+flush(stderr()); flush(stdout())
+
+### Name: lag.plot
+### Title: Time Series Lag Plots
+### Aliases: lag.plot
+### Keywords: hplot ts
+
+### ** Examples
+
+require(graphics)
+
+lag.plot(nhtemp, 8, diag.col = "forest green")
+lag.plot(nhtemp, 5, main = "Average Temperatures in New Haven")
+## ask defaults to TRUE when we have more than one page:
+lag.plot(nhtemp, 6, layout = c(2,1), asp = NA,
+ main = "New Haven Temperatures", col.main = "blue")
+
+## Multivariate (but non-stationary! ...)
+lag.plot(freeny.x, lags = 3)
+
+## no lines for long series :
+lag.plot(sqrt(sunspots), set = c(1:4, 9:12), pch = ".", col = "gold")
+
+
+
+cleanEx()
+nameEx("line")
+### * line
+
+flush(stderr()); flush(stdout())
+
+### Name: line
+### Title: Robust Line Fitting
+### Aliases: line residuals.tukeyline
+### Keywords: robust regression
+
+### ** Examples
+
+require(graphics)
+
+plot(cars)
+(z <- line(cars))
+abline(coef(z))
+## Tukey-Anscombe Plot :
+plot(residuals(z) ~ fitted(z), main = deparse(z$call))
+
+
+
+cleanEx()
+nameEx("lm")
+### * lm
+
+flush(stderr()); flush(stdout())
+
+### Name: lm
+### Title: Fitting Linear Models
+### Aliases: lm
+### Keywords: regression
+
+### ** Examples
+
+require(graphics)
+
+## Annette Dobson (1990) "An Introduction to Generalized Linear Models".
+## Page 9: Plant Weight Data.
+ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14)
+trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69)
+group <- gl(2, 10, 20, labels = c("Ctl","Trt"))
+weight <- c(ctl, trt)
+lm.D9 <- lm(weight ~ group)
+lm.D90 <- lm(weight ~ group - 1) # omitting intercept
+opar <- par(mfrow = c(2,2), oma = c(0, 0, 1.1, 0))
+plot(lm.D9, las = 1) # Residuals, Fitted, ...
+par(opar)
+## Don't show:
+## model frame :
+stopifnot(identical(lm(weight ~ group, method = "model.frame"),
+ model.frame(lm.D9)))
+## End(Don't show)
+### less simple examples in "See Also" above
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("lm.influence")
+### * lm.influence
+
+flush(stderr()); flush(stdout())
+
+### Name: lm.influence
+### Title: Regression Diagnostics
+### Aliases: lm.influence influence influence.lm influence.glm
+### Keywords: regression
+
+### ** Examples
+
+## Analysis of the life-cycle savings data
+## given in Belsley, Kuh and Welsch.
+summary(lm.SR <- lm(sr ~ pop15 + pop75 + dpi + ddpi,
+ data = LifeCycleSavings),
+ corr = TRUE)
+utils::str(lmI <- lm.influence(lm.SR))
+
+## For more "user level" examples, use example(influence.measures)
+
+
+
+cleanEx()
+nameEx("lm.summaries")
+### * lm.summaries
+
+flush(stderr()); flush(stdout())
+
+### Name: lm.summaries
+### Title: Accessing Linear Model Fits
+### Aliases: family.lm formula.lm residuals.lm labels.lm
+### Keywords: regression models
+
+### ** Examples
+
+## Don't show:
+utils::example("lm", echo = FALSE)
+## End(Don't show)
+##-- Continuing the lm(.) example:
+coef(lm.D90) # the bare coefficients
+
+## The 2 basic regression diagnostic plots [plot.lm(.) is preferred]
+plot(resid(lm.D90), fitted(lm.D90)) # Tukey-Anscombe's
+abline(h = 0, lty = 2, col = "gray")
+
+qqnorm(residuals(lm.D90))
+
+
+
+cleanEx()
+nameEx("lmfit")
+### * lmfit
+
+flush(stderr()); flush(stdout())
+
+### Name: lm.fit
+### Title: Fitter Functions for Linear Models
+### Aliases: lm.fit lm.wfit .lm.fit
+### Keywords: regression array
+
+### ** Examples
+
+require(utils)
+set.seed(129)
+
+n <- 7 ; p <- 2
+X <- matrix(rnorm(n * p), n, p) # no intercept!
+y <- rnorm(n)
+w <- rnorm(n)^2
+
+str(lmw <- lm.wfit(x = X, y = y, w = w))
+
+str(lm. <- lm.fit (x = X, y = y))
+## Don't show:
+ ## These are the same calculations at C level, but a parallel BLAS
+ ## might not do them the same way twice, and if seems serial MKL does not.
+ lm.. <- .lm.fit(X,y)
+ lm.w <- .lm.fit(X*sqrt(w), y*sqrt(w))
+ id <- function(x, y) all.equal(x, y, tolerance = 1e-15, scale = 1)
+ stopifnot(id(unname(lm.$coef), lm..$coef),
+ id(unname(lmw$coef), lm.w$coef))
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("loess")
+### * loess
+
+flush(stderr()); flush(stdout())
+
+### Name: loess
+### Title: Local Polynomial Regression Fitting
+### Aliases: loess
+### Keywords: smooth loess
+
+### ** Examples
+
+cars.lo <- loess(dist ~ speed, cars)
+predict(cars.lo, data.frame(speed = seq(5, 30, 1)), se = TRUE)
+# to allow extrapolation
+cars.lo2 <- loess(dist ~ speed, cars,
+ control = loess.control(surface = "direct"))
+predict(cars.lo2, data.frame(speed = seq(5, 30, 1)), se = TRUE)
+
+
+
+cleanEx()
+nameEx("logLik")
+### * logLik
+
+flush(stderr()); flush(stdout())
+
+### Name: logLik
+### Title: Extract Log-Likelihood
+### Aliases: logLik logLik.lm
+### Keywords: models
+
+### ** Examples
+
+x <- 1:5
+lmx <- lm(x ~ 1)
+logLik(lmx) # using print.logLik() method
+utils::str(logLik(lmx))
+
+## lm method
+(fm1 <- lm(rating ~ ., data = attitude))
+logLik(fm1)
+logLik(fm1, REML = TRUE)
+
+
+
+cleanEx()
+nameEx("loglin")
+### * loglin
+
+flush(stderr()); flush(stdout())
+
+### Name: loglin
+### Title: Fitting Log-Linear Models
+### Aliases: loglin
+### Keywords: category models
+
+### ** Examples
+
+## Model of joint independence of sex from hair and eye color.
+fm <- loglin(HairEyeColor, list(c(1, 2), c(1, 3), c(2, 3)))
+fm
+1 - pchisq(fm$lrt, fm$df)
+## Model with no three-factor interactions fits well.
+
+
+
+cleanEx()
+nameEx("lowess")
+### * lowess
+
+flush(stderr()); flush(stdout())
+
+### Name: lowess
+### Title: Scatter Plot Smoothing
+### Aliases: lowess
+### Keywords: smooth
+
+### ** Examples
+
+require(graphics)
+
+plot(cars, main = "lowess(cars)")
+lines(lowess(cars), col = 2)
+lines(lowess(cars, f = .2), col = 3)
+legend(5, 120, c(paste("f = ", c("2/3", ".2"))), lty = 1, col = 2:3)
+
+
+
+cleanEx()
+nameEx("ls.diag")
+### * ls.diag
+
+flush(stderr()); flush(stdout())
+
+### Name: ls.diag
+### Title: Compute Diagnostics for 'lsfit' Regression Results
+### Aliases: ls.diag
+### Keywords: regression
+
+### ** Examples
+
+
+cleanEx()
+nameEx("lsfit")
+### * lsfit
+
+flush(stderr()); flush(stdout())
+
+### Name: lsfit
+### Title: Find the Least Squares Fit
+### Aliases: lsfit
+### Keywords: regression
+
+### ** Examples
+
+## Don't show:
+utils::example("lm", echo = FALSE)
+## End(Don't show)
+##-- Using the same data as the lm(.) example:
+lsD9 <- lsfit(x = unclass(gl(2, 10)), y = weight)
+ls.print(lsD9)
+
+
+
+cleanEx()
+nameEx("mad")
+### * mad
+
+flush(stderr()); flush(stdout())
+
+### Name: mad
+### Title: Median Absolute Deviation
+### Aliases: mad
+### Keywords: univar robust
+
+### ** Examples
+
+mad(c(1:9))
+print(mad(c(1:9), constant = 1)) ==
+ mad(c(1:8, 100), constant = 1) # = 2 ; TRUE
+x <- c(1,2,3,5,7,8)
+sort(abs(x - median(x)))
+c(mad(x, constant = 1),
+ mad(x, constant = 1, low = TRUE),
+ mad(x, constant = 1, high = TRUE))
+
+
+
+cleanEx()
+nameEx("mahalanobis")
+### * mahalanobis
+
+flush(stderr()); flush(stdout())
+
+### Name: mahalanobis
+### Title: Mahalanobis Distance
+### Aliases: mahalanobis
+### Keywords: multivariate
+
+### ** Examples
+
+require(graphics)
+
+ma <- cbind(1:6, 1:3)
+(S <- var(ma))
+mahalanobis(c(0, 0), 1:2, S)
+
+x <- matrix(rnorm(100*3), ncol = 3)
+stopifnot(mahalanobis(x, 0, diag(ncol(x))) == rowSums(x*x))
+ ##- Here, D^2 = usual squared Euclidean distances
+
+Sx <- cov(x)
+D2 <- mahalanobis(x, colMeans(x), Sx)
+plot(density(D2, bw = 0.5),
+ main="Squared Mahalanobis distances, n=100, p=3") ; rug(D2)
+qqplot(qchisq(ppoints(100), df = 3), D2,
+ main = expression("Q-Q plot of Mahalanobis" * ~D^2 *
+ " vs. quantiles of" * ~ chi[3]^2))
+abline(0, 1, col = 'gray')
+
+
+
+cleanEx()
+nameEx("make.link")
+### * make.link
+
+flush(stderr()); flush(stdout())
+
+### Name: make.link
+### Title: Create a Link for GLM Families
+### Aliases: make.link
+### Keywords: models
+
+### ** Examples
+
+utils::str(make.link("logit"))
+
+
+
+cleanEx()
+nameEx("makepredictcall")
+### * makepredictcall
+
+flush(stderr()); flush(stdout())
+
+### Name: makepredictcall
+### Title: Utility Function for Safe Prediction
+### Aliases: makepredictcall makepredictcall.default SafePrediction
+### Keywords: models
+
+### ** Examples
+
+require(graphics)
+
+## using poly: this did not work in R < 1.5.0
+fm <- lm(weight ~ poly(height, 2), data = women)
+plot(women, xlab = "Height (in)", ylab = "Weight (lb)")
+ht <- seq(57, 73, len = 200)
+lines(ht, predict(fm, data.frame(height = ht)))
+
+## see also example(cars)
+
+## see bs and ns for spline examples.
+
+
+
+cleanEx()
+nameEx("manova")
+### * manova
+
+flush(stderr()); flush(stdout())
+
+### Name: manova
+### Title: Multivariate Analysis of Variance
+### Aliases: manova
+### Keywords: models
+
+### ** Examples
+
+## Set orthogonal contrasts.
+op <- options(contrasts = c("contr.helmert", "contr.poly"))
+
+## Fake a 2nd response variable
+npk2 <- within(npk, foo <- rnorm(24))
+( npk2.aov <- manova(cbind(yield, foo) ~ block + N*P*K, npk2) )
+summary(npk2.aov)
+
+( npk2.aovE <- manova(cbind(yield, foo) ~ N*P*K + Error(block), npk2) )
+summary(npk2.aovE)
+
+
+
+base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
+cleanEx()
+nameEx("mantelhaen.test")
+### * mantelhaen.test
+
+flush(stderr()); flush(stdout())
+
+### Name: mantelhaen.test
+### Title: Cochran-Mantel-Haenszel Chi-Squared Test for Count Data
+### Aliases: mantelhaen.test
+### Keywords: htest
+
+### ** Examples
+
+## Agresti (1990), pages 231--237, Penicillin and Rabbits
+## Investigation of the effectiveness of immediately injected or 1.5
+## hours delayed penicillin in protecting rabbits against a lethal
+## injection with beta-hemolytic streptococci.
+Rabbits <-
+array(c(0, 0, 6, 5,
+ 3, 0, 3, 6,
+ 6, 2, 0, 4,
+ 5, 6, 1, 0,
+ 2, 5, 0, 0),
+ dim = c(2, 2, 5),
+ dimnames = list(
+ Delay = c("None", "1.5h"),
+ Response = c("Cured", "Died"),
+ Penicillin.Level = c("1/8", "1/4", "1/2", "1", "4")))
+Rabbits
+## Classical Mantel-Haenszel test
+mantelhaen.test(Rabbits)
+## => p = 0.047, some evidence for higher cure rate of immediate
+## injection
+## Exact conditional test
+mantelhaen.test(Rabbits, exact = TRUE)
+## => p - 0.040
+## Exact conditional test for one-sided alternative of a higher
+## cure rate for immediate injection
+mantelhaen.test(Rabbits, exact = TRUE, alternative = "greater")
+## => p = 0.020
+
+## UC Berkeley Student Admissions
+mantelhaen.test(UCBAdmissions)
+## No evidence for association between admission and gender
+## when adjusted for department. However,
+apply(UCBAdmissions, 3, function(x) (x[1,1]*x[2,2])/(x[1,2]*x[2,1]))
+## This suggests that the assumption of homogeneous (conditional)
+## odds ratios may be violated. The traditional approach would be
+## using the Woolf test for interaction:
+woolf <- function(x) {
+ x <- x + 1 / 2
+ k <- dim(x)[3]
+ or <- apply(x, 3, function(x) (x[1,1]*x[2,2])/(x[1,2]*x[2,1]))
+ w <- apply(x, 3, function(x) 1 / sum(1 / x))
+ 1 - pchisq(sum(w * (log(or) - weighted.mean(log(or), w)) ^ 2), k - 1)
+}
+woolf(UCBAdmissions)
+## => p = 0.003, indicating that there is significant heterogeneity.
+## (And hence the Mantel-Haenszel test cannot be used.)
+
+## Agresti (2002), p. 287f and p. 297.
+## Job Satisfaction example.
+Satisfaction <-
+ as.table(array(c(1, 2, 0, 0, 3, 3, 1, 2,
+ 11, 17, 8, 4, 2, 3, 5, 2,
+ 1, 0, 0, 0, 1, 3, 0, 1,
+ 2, 5, 7, 9, 1, 1, 3, 6),
+ dim = c(4, 4, 2),
+ dimnames =
+ list(Income =
+ c("<5000", "5000-15000",
+ "15000-25000", ">25000"),
+ "Job Satisfaction" =
+ c("V_D", "L_S", "M_S", "V_S"),
+ Gender = c("Female", "Male"))))
+## (Satisfaction categories abbreviated for convenience.)
+ftable(. ~ Gender + Income, Satisfaction)
+## Table 7.8 in Agresti (2002), p. 288.
+mantelhaen.test(Satisfaction)
+## See Table 7.12 in Agresti (2002), p. 297.
+
+
+
+cleanEx()
+nameEx("mauchly.test")
+### * mauchly.test
+
+flush(stderr()); flush(stdout())
+
+### Name: mauchly.test
+### Title: Mauchly's Test of Sphericity
+### Aliases: mauchly.test mauchly.test.SSD mauchly.test.mlm
+### Keywords: htest models multivariate
+
+### ** Examples
+
+utils::example(SSD) # Brings in the mlmfit and reacttime objects
+
+### traditional test of intrasubj. contrasts
+mauchly.test(mlmfit, X = ~1)
+
+### tests using intra-subject 3x2 design
+idata <- data.frame(deg = gl(3, 1, 6, labels = c(0,4,8)),
+ noise = gl(2, 3, 6, labels = c("A","P")))
+mauchly.test(mlmfit, X = ~ deg + noise, idata = idata)
+mauchly.test(mlmfit, M = ~ deg + noise, X = ~ noise, idata = idata)
+
+
+
+cleanEx()
+nameEx("mcnemar.test")
+### * mcnemar.test
+
+flush(stderr()); flush(stdout())
+
+### Name: mcnemar.test
+### Title: McNemar's Chi-squared Test for Count Data
+### Aliases: mcnemar.test
+### Keywords: htest
+
+### ** Examples
+
+## Agresti (1990), p. 350.
+## Presidential Approval Ratings.
+## Approval of the President's performance in office in two surveys,
+## one month apart, for a random sample of 1600 voting-age Americans.
+Performance <-
+matrix(c(794, 86, 150, 570),
+ nrow = 2,
+ dimnames = list("1st Survey" = c("Approve", "Disapprove"),
+ "2nd Survey" = c("Approve", "Disapprove")))
+Performance
+mcnemar.test(Performance)
+## => significant change (in fact, drop) in approval ratings
+
+
+
+cleanEx()
+nameEx("median")
+### * median
+
+flush(stderr()); flush(stdout())
+
+### Name: median
+### Title: Median Value
+### Aliases: median median.default
+### Keywords: univar robust
+
+### ** Examples
+
+median(1:4) # = 2.5 [even number]
+median(c(1:3, 100, 1000)) # = 3 [odd, robust]
+
+
+
+cleanEx()
+nameEx("medpolish")
+### * medpolish
+
+flush(stderr()); flush(stdout())
+
+### Name: medpolish
+### Title: Median Polish (Robust Twoway Decomposition) of a Matrix
+### Aliases: medpolish
+### Keywords: robust
+
+### ** Examples
+
+require(graphics)
+
+## Deaths from sport parachuting; from ABC of EDA, p.224:
+deaths <-
+ rbind(c(14,15,14),
+ c( 7, 4, 7),
+ c( 8, 2,10),
+ c(15, 9,10),
+ c( 0, 2, 0))
+dimnames(deaths) <- list(c("1-24", "25-74", "75-199", "200++", "NA"),
+ paste(1973:1975))
+deaths
+(med.d <- medpolish(deaths))
+plot(med.d)
+## Check decomposition:
+all(deaths ==
+ med.d$overall + outer(med.d$row,med.d$col, "+") + med.d$residuals)
+
+
+
+cleanEx()
+nameEx("model.extract")
+### * model.extract
+
+flush(stderr()); flush(stdout())
+
+### Name: model.extract
+### Title: Extract Components from a Model Frame
+### Aliases: model.extract model.offset model.response model.weights
+### Keywords: manip programming models
+
+### ** Examples
+
+a <- model.frame(cbind(ncases,ncontrols) ~ agegp + tobgp + alcgp, data = esoph)
+model.extract(a, "response")
+stopifnot(model.extract(a, "response") == model.response(a))
+
+a <- model.frame(ncases/(ncases+ncontrols) ~ agegp + tobgp + alcgp,
+ data = esoph, weights = ncases+ncontrols)
+model.response(a)
+model.extract(a, "weights")
+
+a <- model.frame(cbind(ncases,ncontrols) ~ agegp,
+ something = tobgp, data = esoph)
+names(a)
+stopifnot(model.extract(a, "something") == esoph$tobgp)
+
+
+
+cleanEx()
+nameEx("model.frame")
+### * model.frame
+
+flush(stderr()); flush(stdout())
+
+### Name: model.frame
+### Title: Extracting the Model Frame from a Formula or Fit
+### Aliases: model.frame model.frame.default model.frame.lm model.frame.glm
+### model.frame.aovlist get_all_vars
+### Keywords: models
+
+### ** Examples
+
+data.class(model.frame(dist ~ speed, data = cars))
+
+
+
+cleanEx()
+nameEx("model.matrix")
+### * model.matrix
+
+flush(stderr()); flush(stdout())
+
+### Name: model.matrix
+### Title: Construct Design Matrices
+### Aliases: model.matrix model.matrix.default model.matrix.lm
+### Keywords: models
+
+### ** Examples
+
+ff <- log(Volume) ~ log(Height) + log(Girth)
+utils::str(m <- model.frame(ff, trees))
+mat <- model.matrix(ff, m)
+
+dd <- data.frame(a = gl(3,4), b = gl(4,1,12)) # balanced 2-way
+options("contrasts")
+model.matrix(~ a + b, dd)
+model.matrix(~ a + b, dd, contrasts = list(a = "contr.sum"))
+model.matrix(~ a + b, dd, contrasts = list(a = "contr.sum", b = "contr.poly"))
+m.orth <- model.matrix(~a+b, dd, contrasts = list(a = "contr.helmert"))
+crossprod(m.orth) # m.orth is ALMOST orthogonal
+
+
+
+cleanEx()
+nameEx("model.tables")
+### * model.tables
+
+flush(stderr()); flush(stdout())
+
+### Name: model.tables
+### Title: Compute Tables of Results from an Aov Model Fit
+### Aliases: model.tables model.tables.aov model.tables.aovlist
+### Keywords: models
+
+### ** Examples
+
+
+cleanEx()
+nameEx("monthplot")
+### * monthplot
+
+flush(stderr()); flush(stdout())
+
+### Name: monthplot
+### Title: Plot a Seasonal or other Subseries from a Time Series
+### Aliases: monthplot monthplot.default monthplot.ts monthplot.stl
+### monthplot.StructTS
+### Keywords: hplot ts
+
+### ** Examples
+
+require(graphics)
+
+## The CO2 data
+fit <- stl(log(co2), s.window = 20, t.window = 20)
+plot(fit)
+op <- par(mfrow = c(2,2))
+monthplot(co2, ylab = "data", cex.axis = 0.8)
+monthplot(fit, choice = "seasonal", cex.axis = 0.8)
+monthplot(fit, choice = "trend", cex.axis = 0.8)
+monthplot(fit, choice = "remainder", type = "h", cex.axis = 0.8)
+par(op)
+
+## The CO2 data, grouped quarterly
+quarter <- (cycle(co2) - 1) %/% 3
+monthplot(co2, phase = quarter)
+
+## see also JohnsonJohnson
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("mood.test")
+### * mood.test
+
+flush(stderr()); flush(stdout())
+
+### Name: mood.test
+### Title: Mood Two-Sample Test of Scale
+### Aliases: mood.test mood.test.default mood.test.formula
+### Keywords: htest
+
+### ** Examples
+
+## Same data as for the Ansari-Bradley test:
+## Serum iron determination using Hyland control sera
+ramsay <- c(111, 107, 100, 99, 102, 106, 109, 108, 104, 99,
+ 101, 96, 97, 102, 107, 113, 116, 113, 110, 98)
+jung.parekh <- c(107, 108, 106, 98, 105, 103, 110, 105, 104,
+ 100, 96, 108, 103, 104, 114, 114, 113, 108, 106, 99)
+mood.test(ramsay, jung.parekh)
+## Compare this to ansari.test(ramsay, jung.parekh)
+
+
+
+cleanEx()
+nameEx("na.action")
+### * na.action
+
+flush(stderr()); flush(stdout())
+
+### Name: na.action
+### Title: NA Action
+### Aliases: na.action na.action.default
+### Keywords: NA methods
+
+### ** Examples
+
+na.action(na.omit(c(1, NA)))
+
+
+
+cleanEx()
+nameEx("na.contiguous")
+### * na.contiguous
+
+flush(stderr()); flush(stdout())
+
+### Name: na.contiguous
+### Title: Find Longest Contiguous Stretch of non-NAs
+### Aliases: na.contiguous na.contiguous.default
+### Keywords: ts
+
+### ** Examples
+
+na.contiguous(presidents)
+
+
+
+cleanEx()
+nameEx("na.fail")
+### * na.fail
+
+flush(stderr()); flush(stdout())
+
+### Name: na.fail
+### Title: Handle Missing Values in Objects
+### Aliases: na.fail na.fail.default na.omit na.omit.data.frame
+### na.omit.default na.exclude na.exclude.data.frame na.exclude.default
+### na.pass
+### Keywords: NA
+
+### ** Examples
+
+DF <- data.frame(x = c(1, 2, 3), y = c(0, 10, NA))
+na.omit(DF)
+m <- as.matrix(DF)
+na.omit(m)
+stopifnot(all(na.omit(1:3) == 1:3)) # does not affect objects with no NA's
+try(na.fail(DF)) #> Error: missing values in ...
+
+options("na.action")
+
+
+
+cleanEx()
+nameEx("nextn")
+### * nextn
+
+flush(stderr()); flush(stdout())
+
+### Name: nextn
+### Title: Highly Composite Numbers
+### Aliases: nextn
+### Keywords: math
+
+### ** Examples
+
+nextn(1001) # 1024
+table(sapply(599:630, nextn))
+
+
+
+cleanEx()
+nameEx("nlm")
+### * nlm
+
+flush(stderr()); flush(stdout())
+
+### Name: nlm
+### Title: Non-Linear Minimization
+### Aliases: nlm
+### Keywords: nonlinear optimize
+
+### ** Examples
+
+f <- function(x) sum((x-1:length(x))^2)
+nlm(f, c(10,10))
+nlm(f, c(10,10), print.level = 2)
+utils::str(nlm(f, c(5), hessian = TRUE))
+
+f <- function(x, a) sum((x-a)^2)
+nlm(f, c(10,10), a = c(3,5))
+f <- function(x, a)
+{
+ res <- sum((x-a)^2)
+ attr(res, "gradient") <- 2*(x-a)
+ res
+}
+nlm(f, c(10,10), a = c(3,5))
+
+## more examples, including the use of derivatives.
+## Not run: demo(nlm)
+
+
+
+cleanEx()
+nameEx("nlminb")
+### * nlminb
+
+flush(stderr()); flush(stdout())
+
+### Name: nlminb
+### Title: Optimization using PORT routines
+### Aliases: nlminb
+### Keywords: optimize
+
+### ** Examples
+
+
+cleanEx()
+nameEx("nls")
+### * nls
+
+flush(stderr()); flush(stdout())
+
+### Name: nls
+### Title: Nonlinear Least Squares
+### Aliases: nls
+### Keywords: nonlinear regression models
+
+### ** Examples
+
+## Don't show:
+od <- options(digits=5)
+## End(Don't show)
+require(graphics)
+
+DNase1 <- subset(DNase, Run == 1)
+
+## using a selfStart model
+fm1DNase1 <- nls(density ~ SSlogis(log(conc), Asym, xmid, scal), DNase1)
+summary(fm1DNase1)
+## the coefficients only:
+coef(fm1DNase1)
+## including their SE, etc:
+coef(summary(fm1DNase1))
+
+## using conditional linearity
+fm2DNase1 <- nls(density ~ 1/(1 + exp((xmid - log(conc))/scal)),
+ data = DNase1,
+ start = list(xmid = 0, scal = 1),
+ algorithm = "plinear")
+summary(fm2DNase1)
+
+## without conditional linearity
+fm3DNase1 <- nls(density ~ Asym/(1 + exp((xmid - log(conc))/scal)),
+ data = DNase1,
+ start = list(Asym = 3, xmid = 0, scal = 1))
+summary(fm3DNase1)
+
+## using Port's nl2sol algorithm
+fm4DNase1 <- nls(density ~ Asym/(1 + exp((xmid - log(conc))/scal)),
+ data = DNase1,
+ start = list(Asym = 3, xmid = 0, scal = 1),
+ algorithm = "port")
+summary(fm4DNase1)
+
+## weighted nonlinear regression
+Treated <- Puromycin[Puromycin$state == "treated", ]
+weighted.MM <- function(resp, conc, Vm, K)
+{
+ ## Purpose: exactly as white book p. 451 -- RHS for nls()
+ ## Weighted version of Michaelis-Menten model
+ ## ----------------------------------------------------------
+ ## Arguments: 'y', 'x' and the two parameters (see book)
+ ## ----------------------------------------------------------
+ ## Author: Martin Maechler, Date: 23 Mar 2001
+
+ pred <- (Vm * conc)/(K + conc)
+ (resp - pred) / sqrt(pred)
+}
+
+Pur.wt <- nls( ~ weighted.MM(rate, conc, Vm, K), data = Treated,
+ start = list(Vm = 200, K = 0.1))
+summary(Pur.wt)
+
+## Passing arguments using a list that can not be coerced to a data.frame
+lisTreat <- with(Treated,
+ list(conc1 = conc[1], conc.1 = conc[-1], rate = rate))
+
+weighted.MM1 <- function(resp, conc1, conc.1, Vm, K)
+{
+ conc <- c(conc1, conc.1)
+ pred <- (Vm * conc)/(K + conc)
+ (resp - pred) / sqrt(pred)
+}
+Pur.wt1 <- nls( ~ weighted.MM1(rate, conc1, conc.1, Vm, K),
+ data = lisTreat, start = list(Vm = 200, K = 0.1))
+stopifnot(all.equal(coef(Pur.wt), coef(Pur.wt1)))
+
+## Chambers and Hastie (1992) Statistical Models in S (p. 537):
+## If the value of the right side [of formula] has an attribute called
+## 'gradient' this should be a matrix with the number of rows equal
+## to the length of the response and one column for each parameter.
+
+weighted.MM.grad <- function(resp, conc1, conc.1, Vm, K)
+{
+ conc <- c(conc1, conc.1)
+
+ K.conc <- K+conc
+ dy.dV <- conc/K.conc
+ dy.dK <- -Vm*dy.dV/K.conc
+ pred <- Vm*dy.dV
+ pred.5 <- sqrt(pred)
+ dev <- (resp - pred) / pred.5
+ Ddev <- -0.5*(resp+pred)/(pred.5*pred)
+ attr(dev, "gradient") <- Ddev * cbind(Vm = dy.dV, K = dy.dK)
+ dev
+}
+
+Pur.wt.grad <- nls( ~ weighted.MM.grad(rate, conc1, conc.1, Vm, K),
+ data = lisTreat, start = list(Vm = 200, K = 0.1))
+
+rbind(coef(Pur.wt), coef(Pur.wt1), coef(Pur.wt.grad))
+
+## In this example, there seems no advantage to providing the gradient.
+## In other cases, there might be.
+
+
+## The two examples below show that you can fit a model to
+## artificial data with noise but not to artificial data
+## without noise.
+x <- 1:10
+y <- 2*x + 3 # perfect fit
+yeps <- y + rnorm(length(y), sd = 0.01) # added noise
+nls(yeps ~ a + b*x, start = list(a = 0.12345, b = 0.54321))
+## terminates in an error, because convergence cannot be confirmed:
+try(nls(y ~ a + b*x, start = list(a = 0.12345, b = 0.54321)))
+
+## the nls() internal cheap guess for starting values can be sufficient:
+
+x <- -(1:100)/10
+y <- 100 + 10 * exp(x / 2) + rnorm(x)/10
+nlmod <- nls(y ~ Const + A * exp(B * x))
+
+plot(x,y, main = "nls(*), data, true function and fit, n=100")
+curve(100 + 10 * exp(x / 2), col = 4, add = TRUE)
+lines(x, predict(nlmod), col = 2)
+
+
+## Don't show:
+options(od)
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("nls.control")
+### * nls.control
+
+flush(stderr()); flush(stdout())
+
+### Name: nls.control
+### Title: Control the Iterations in nls
+### Aliases: nls.control
+### Keywords: nonlinear regression models
+
+### ** Examples
+
+nls.control(minFactor = 1/2048)
+
+
+
+cleanEx()
+nameEx("numericDeriv")
+### * numericDeriv
+
+flush(stderr()); flush(stdout())
+
+### Name: numericDeriv
+### Title: Evaluate Derivatives Numerically
+### Aliases: numericDeriv
+### Keywords: models
+
+### ** Examples
+
+## Don't show:
+od <- options(digits = 4)
+## End(Don't show)
+myenv <- new.env()
+assign("mean", 0., envir = myenv)
+assign("sd", 1., envir = myenv)
+assign("x", seq(-3., 3., len = 31), envir = myenv)
+numericDeriv(quote(pnorm(x, mean, sd)), c("mean", "sd"), myenv)
+## Don't show:
+options(od)
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("oneway.test")
+### * oneway.test
+
+flush(stderr()); flush(stdout())
+
+### Name: oneway.test
+### Title: Test for Equal Means in a One-Way Layout
+### Aliases: oneway.test
+### Keywords: htest
+
+### ** Examples
+
+## Not assuming equal variances
+oneway.test(extra ~ group, data = sleep)
+## Assuming equal variances
+oneway.test(extra ~ group, data = sleep, var.equal = TRUE)
+## which gives the same result as
+anova(lm(extra ~ group, data = sleep))
+
+
+
+cleanEx()
+nameEx("optim")
+### * optim
+
+flush(stderr()); flush(stdout())
+
+### Name: optim
+### Title: General-purpose Optimization
+### Aliases: optim optimHess
+### Keywords: nonlinear optimize
+
+### ** Examples
+
+
+cleanEx()
+nameEx("optimize")
+### * optimize
+
+flush(stderr()); flush(stdout())
+
+### Name: optimize
+### Title: One Dimensional Optimization
+### Aliases: optimize optimise
+### Keywords: optimize
+
+### ** Examples
+
+require(graphics)
+
+f <- function (x, a) (x - a)^2
+xmin <- optimize(f, c(0, 1), tol = 0.0001, a = 1/3)
+xmin
+
+## See where the function is evaluated:
+optimize(function(x) x^2*(print(x)-1), lower = 0, upper = 10)
+
+## "wrong" solution with unlucky interval and piecewise constant f():
+f <- function(x) ifelse(x > -1, ifelse(x < 4, exp(-1/abs(x - 1)), 10), 10)
+fp <- function(x) { print(x); f(x) }
+
+plot(f, -2,5, ylim = 0:1, col = 2)
+optimize(fp, c(-4, 20)) # doesn't see the minimum
+optimize(fp, c(-7, 20)) # ok
+
+
+
+cleanEx()
+nameEx("order.dendrogram")
+### * order.dendrogram
+
+flush(stderr()); flush(stdout())
+
+### Name: order.dendrogram
+### Title: Ordering or Labels of the Leaves in a Dendrogram
+### Aliases: order.dendrogram labels.dendrogram
+### Keywords: manip
+
+### ** Examples
+
+set.seed(123)
+x <- rnorm(10)
+hc <- hclust(dist(x))
+hc$order
+dd <- as.dendrogram(hc)
+order.dendrogram(dd) ## the same :
+stopifnot(hc$order == order.dendrogram(dd))
+
+d2 <- as.dendrogram(hclust(dist(USArrests)))
+labels(d2) ## in this case the same as
+stopifnot(identical(labels(d2),
+ rownames(USArrests)[order.dendrogram(d2)]))
+
+
+
+cleanEx()
+nameEx("p.adjust")
+### * p.adjust
+
+flush(stderr()); flush(stdout())
+
+### Name: p.adjust
+### Title: Adjust P-values for Multiple Comparisons
+### Aliases: p.adjust p.adjust.methods
+### Keywords: htest
+
+### ** Examples
+
+require(graphics)
+
+set.seed(123)
+x <- rnorm(50, mean = c(rep(0, 25), rep(3, 25)))
+p <- 2*pnorm(sort(-abs(x)))
+
+round(p, 3)
+round(p.adjust(p), 3)
+round(p.adjust(p, "BH"), 3)
+
+## or all of them at once (dropping the "fdr" alias):
+p.adjust.M <- p.adjust.methods[p.adjust.methods != "fdr"]
+p.adj <- sapply(p.adjust.M, function(meth) p.adjust(p, meth))
+p.adj.60 <- sapply(p.adjust.M, function(meth) p.adjust(p, meth, n = 60))
+stopifnot(identical(p.adj[,"none"], p), p.adj <= p.adj.60)
+round(p.adj, 3)
+## or a bit nicer:
+noquote(apply(p.adj, 2, format.pval, digits = 3))
+
+
+## and a graphic:
+matplot(p, p.adj, ylab="p.adjust(p, meth)", type = "l", asp = 1, lty = 1:6,
+ main = "P-value adjustments")
+legend(0.7, 0.6, p.adjust.M, col = 1:6, lty = 1:6)
+
+## Can work with NA's:
+pN <- p; iN <- c(46, 47); pN[iN] <- NA
+pN.a <- sapply(p.adjust.M, function(meth) p.adjust(pN, meth))
+## The smallest 20 P-values all affected by the NA's :
+round((pN.a / p.adj)[1:20, ] , 4)
+
+
+
+cleanEx()
+nameEx("pairwise.prop.test")
+### * pairwise.prop.test
+
+flush(stderr()); flush(stdout())
+
+### Name: pairwise.prop.test
+### Title: Pairwise comparisons for proportions
+### Aliases: pairwise.prop.test
+### Keywords: htest
+
+### ** Examples
+
+smokers <- c( 83, 90, 129, 70 )
+patients <- c( 86, 93, 136, 82 )
+pairwise.prop.test(smokers, patients)
+
+
+
+cleanEx()
+nameEx("pairwise.t.test")
+### * pairwise.t.test
+
+flush(stderr()); flush(stdout())
+
+### Name: pairwise.t.test
+### Title: Pairwise t tests
+### Aliases: pairwise.t.test
+### Keywords: htest
+
+### ** Examples
+
+attach(airquality)
+Month <- factor(Month, labels = month.abb[5:9])
+pairwise.t.test(Ozone, Month)
+pairwise.t.test(Ozone, Month, p.adj = "bonf")
+pairwise.t.test(Ozone, Month, pool.sd = FALSE)
+detach()
+
+
+
+cleanEx()
+nameEx("pairwise.wilcox.test")
+### * pairwise.wilcox.test
+
+flush(stderr()); flush(stdout())
+
+### Name: pairwise.wilcox.test
+### Title: Pairwise Wilcoxon Rank Sum Tests
+### Aliases: pairwise.wilcox.test
+### Keywords: htest
+
+### ** Examples
+
+attach(airquality)
+Month <- factor(Month, labels = month.abb[5:9])
+## These give warnings because of ties :
+pairwise.wilcox.test(Ozone, Month)
+pairwise.wilcox.test(Ozone, Month, p.adj = "bonf")
+detach()
+
+
+
+cleanEx()
+nameEx("plot.acf")
+### * plot.acf
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.acf
+### Title: Plot Autocovariance and Autocorrelation Functions
+### Aliases: plot.acf
+### Keywords: hplot ts
+
+### ** Examples
+
+require(graphics)
+
+z4 <- ts(matrix(rnorm(400), 100, 4), start = c(1961, 1), frequency = 12)
+z7 <- ts(matrix(rnorm(700), 100, 7), start = c(1961, 1), frequency = 12)
+acf(z4)
+acf(z7, max.mfrow = 7) # squeeze onto 1 page
+acf(z7) # multi-page
+
+
+
+cleanEx()
+nameEx("plot.isoreg")
+### * plot.isoreg
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.isoreg
+### Title: Plot Method for isoreg Objects
+### Aliases: plot.isoreg lines.isoreg
+### Keywords: hplot print
+
+### ** Examples
+
+require(graphics)
+
+utils::example(isoreg) # for the examples there
+
+plot(y3, main = "simple plot(.) + lines(<isoreg>)")
+lines(ir3)
+
+## 'same' plot as above, "proving" that only ranks of 'x' are important
+plot(isoreg(2^(1:9), c(1,0,4,3,3,5,4,2,0)), plot.type = "row", log = "x")
+
+plot(ir3, plot.type = "row", ylab = "y3")
+plot(isoreg(y3 - 4), plot.t="r", ylab = "y3 - 4")
+plot(ir4, plot.type = "ro", ylab = "y4", xlab = "x = 1:n")
+
+## experiment a bit with these (C-c C-j):
+plot(isoreg(sample(9), y3), plot.type = "row")
+plot(isoreg(sample(9), y3), plot.type = "col.wise")
+
+plot(ir <- isoreg(sample(10), sample(10, replace = TRUE)),
+ plot.type = "r")
+
+
+
+cleanEx()
+nameEx("plot.lm")
+### * plot.lm
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.lm
+### Title: Plot Diagnostics for an lm Object
+### Aliases: plot.lm
+### Keywords: hplot regression
+
+### ** Examples
+
+require(graphics)
+
+## Analysis of the life-cycle savings data
+## given in Belsley, Kuh and Welsch.
+lm.SR <- lm(sr ~ pop15 + pop75 + dpi + ddpi, data = LifeCycleSavings)
+plot(lm.SR)
+
+## 4 plots on 1 page;
+## allow room for printing model formula in outer margin:
+par(mfrow = c(2, 2), oma = c(0, 0, 2, 0))
+plot(lm.SR)
+plot(lm.SR, id.n = NULL) # no id's
+plot(lm.SR, id.n = 5, labels.id = NULL) # 5 id numbers
+
+## Was default in R <= 2.1.x:
+## Cook's distances instead of Residual-Leverage plot
+plot(lm.SR, which = 1:4)
+
+## Fit a smooth curve, where applicable:
+plot(lm.SR, panel = panel.smooth)
+## Gives a smoother curve
+plot(lm.SR, panel = function(x, y) panel.smooth(x, y, span = 1))
+
+par(mfrow = c(2,1)) # same oma as above
+plot(lm.SR, which = 1:2, sub.caption = "Saving Rates, n=50, p=5")
+
+## Don't show:
+## An example with *long* formula that needs abbreviation:
+for(i in 1:5) assign(paste("long.var.name", i, sep = "."), runif(10))
+plot(lm(long.var.name.1 ~
+ long.var.name.2 + long.var.name.3 + long.var.name.4 + long.var.name.5))
+## End(Don't show)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("plot.ppr")
+### * plot.ppr
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.ppr
+### Title: Plot Ridge Functions for Projection Pursuit Regression Fit
+### Aliases: plot.ppr
+### Keywords: hplot
+
+### ** Examples
+
+require(graphics)
+
+rock1 <- within(rock, { area1 <- area/10000; peri1 <- peri/10000 })
+par(mfrow = c(3,2)) # maybe: , pty = "s")
+rock.ppr <- ppr(log(perm) ~ area1 + peri1 + shape,
+ data = rock1, nterms = 2, max.terms = 5)
+plot(rock.ppr, main = "ppr(log(perm)~ ., nterms=2, max.terms=5)")
+plot(update(rock.ppr, bass = 5), main = "update(..., bass = 5)")
+plot(update(rock.ppr, sm.method = "gcv", gcvpen = 2),
+ main = "update(..., sm.method=\"gcv\", gcvpen=2)")
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("plot.profile.nls")
+### * plot.profile.nls
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.profile.nls
+### Title: Plot a profile.nls Object
+### Aliases: plot.profile.nls
+### Keywords: nonlinear regression models
+
+### ** Examples
+
+require(graphics)
+
+# obtain the fitted object
+fm1 <- nls(demand ~ SSasympOrig(Time, A, lrc), data = BOD)
+# get the profile for the fitted model
+pr1 <- profile(fm1, alpha = 0.05)
+opar <- par(mfrow = c(2,2), oma = c(1.1, 0, 1.1, 0), las = 1)
+plot(pr1, conf = c(95, 90, 80, 50)/100)
+plot(pr1, conf = c(95, 90, 80, 50)/100, absVal = FALSE)
+mtext("Confidence intervals based on the profile sum of squares",
+ side = 3, outer = TRUE)
+mtext("BOD data - confidence levels of 50%, 80%, 90% and 95%",
+ side = 1, outer = TRUE)
+par(opar)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("plot.stepfun")
+### * plot.stepfun
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.stepfun
+### Title: Plot Step Functions
+### Aliases: plot.stepfun lines.stepfun
+### Keywords: hplot
+
+### ** Examples
+
+require(graphics)
+
+y0 <- c(1,2,4,3)
+sfun0 <- stepfun(1:3, y0, f = 0)
+sfun.2 <- stepfun(1:3, y0, f = .2)
+sfun1 <- stepfun(1:3, y0, right = TRUE)
+
+tt <- seq(0, 3, by = 0.1)
+op <- par(mfrow = c(2,2))
+plot(sfun0); plot(sfun0, xval = tt, add = TRUE, col.hor = "bisque")
+plot(sfun.2);plot(sfun.2, xval = tt, add = TRUE, col = "orange") # all colors
+plot(sfun1);lines(sfun1, xval = tt, col.hor = "coral")
+##-- This is revealing :
+plot(sfun0, verticals = FALSE,
+ main = "stepfun(x, y0, f=f) for f = 0, .2, 1")
+for(i in 1:3)
+ lines(list(sfun0, sfun.2, stepfun(1:3, y0, f = 1))[[i]], col = i)
+legend(2.5, 1.9, paste("f =", c(0, 0.2, 1)), col = 1:3, lty = 1, y.intersp = 1)
+par(op)
+
+# Extend and/or restrict 'viewport':
+plot(sfun0, xlim = c(0,5), ylim = c(0, 3.5),
+ main = "plot(stepfun(*), xlim= . , ylim = .)")
+
+##-- this works too (automatic call to ecdf(.)):
+plot.stepfun(rt(50, df = 3), col.vert = "gray20")
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("plot.ts")
+### * plot.ts
+
+flush(stderr()); flush(stdout())
+
+### Name: plot.ts
+### Title: Plotting Time-Series Objects
+### Aliases: plot.ts lines.ts
+### Keywords: hplot ts
+
+### ** Examples
+
+require(graphics)
+
+## Multivariate
+z <- ts(matrix(rt(200 * 8, df = 3), 200, 8),
+ start = c(1961, 1), frequency = 12)
+plot(z, yax.flip = TRUE)
+plot(z, axes = FALSE, ann = FALSE, frame.plot = TRUE,
+ mar.multi = c(0,0,0,0), oma.multi = c(1,1,5,1))
+title("plot(ts(..), axes=FALSE, ann=FALSE, frame.plot=TRUE, mar..., oma...)")
+
+z <- window(z[,1:3], end = c(1969,12))
+plot(z, type = "b") # multiple
+plot(z, plot.type = "single", lty = 1:3, col = 4:2)
+
+## A phase plot:
+plot(nhtemp, lag(nhtemp, 1), cex = .8, col = "blue",
+ main = "Lag plot of New Haven temperatures")
+
+## xy.lines and xy.labels are FALSE for large series:
+plot(lag(sunspots, 1), sunspots, pch = ".")
+
+SMI <- EuStockMarkets[, "SMI"]
+plot(lag(SMI, 1), SMI, pch = ".")
+plot(lag(SMI, 20), SMI, pch = ".", log = "xy",
+ main = "4 weeks lagged SMI stocks -- log scale", xy.lines = TRUE)
+
+
+
+cleanEx()
+nameEx("poisson.test")
+### * poisson.test
+
+flush(stderr()); flush(stdout())
+
+### Name: poisson.test
+### Title: Exact Poisson tests
+### Aliases: poisson.test
+### Keywords: htest
+
+### ** Examples
+
+### These are paraphrased from data sets in the ISwR package
+
+## SMR, Welsh Nickel workers
+poisson.test(137, 24.19893)
+
+## eba1977, compare Fredericia to other three cities for ages 55-59
+poisson.test(c(11, 6+8+7), c(800, 1083+1050+878))
+
+
+
+cleanEx()
+nameEx("poly")
+### * poly
+
+flush(stderr()); flush(stdout())
+
+### Name: poly
+### Title: Compute Orthogonal Polynomials
+### Aliases: poly polym predict.poly makepredictcall.poly
+### Keywords: math
+
+### ** Examples
+
+od <- options(digits = 3) # avoid too much visual clutter
+(z <- poly(1:10, 3))
+predict(z, seq(2, 4, 0.5))
+zapsmall(poly(seq(4, 6, 0.5), 3, coefs = attr(z, "coefs")))
+
+ zm <- zapsmall(polym ( 1:4, c(1, 4:6), degree = 3)) # or just poly():
+(z1 <- zapsmall(poly(cbind(1:4, c(1, 4:6)), degree = 3)))
+## they are the same :
+stopifnot(all.equal(zm, z1, tol = 1e-15))
+options(od)
+
+
+
+cleanEx()
+nameEx("power")
+### * power
+
+flush(stderr()); flush(stdout())
+
+### Name: power
+### Title: Create a Power Link Object
+### Aliases: power
+### Keywords: models
+
+### ** Examples
+
+power()
+quasi(link = power(1/3))[c("linkfun", "linkinv")]
+
+
+
+cleanEx()
+nameEx("power.anova.test")
+### * power.anova.test
+
+flush(stderr()); flush(stdout())
+
+### Name: power.anova.test
+### Title: Power Calculations for Balanced One-Way Analysis of Variance
+### Tests
+### Aliases: power.anova.test
+### Keywords: htest
+
+### ** Examples
+
+power.anova.test(groups = 4, n = 5, between.var = 1, within.var = 3)
+# Power = 0.3535594
+
+power.anova.test(groups = 4, between.var = 1, within.var = 3,
+ power = .80)
+# n = 11.92613
+
+## Assume we have prior knowledge of the group means:
+groupmeans <- c(120, 130, 140, 150)
+power.anova.test(groups = length(groupmeans),
+ between.var = var(groupmeans),
+ within.var = 500, power = .90) # n = 15.18834
+
+
+
+cleanEx()
+nameEx("power.prop.test")
+### * power.prop.test
+
+flush(stderr()); flush(stdout())
+
+### Name: power.prop.test
+### Title: Power Calculations for Two-Sample Test for Proportions
+### Aliases: power.prop.test
+### Keywords: htest
+
+### ** Examples
+
+power.prop.test(n = 50, p1 = .50, p2 = .75) ## => power = 0.740
+power.prop.test(p1 = .50, p2 = .75, power = .90) ## => n = 76.7
+power.prop.test(n = 50, p1 = .5, power = .90) ## => p2 = 0.8026
+power.prop.test(n = 50, p1 = .5, p2 = 0.9, power = .90, sig.level=NULL)
+ ## => sig.l = 0.00131
+power.prop.test(p1 = .5, p2 = 0.501, sig.level=.001, power=0.90)
+ ## => n = 10451937
+
+
+
+cleanEx()
+nameEx("power.t.test")
+### * power.t.test
+
+flush(stderr()); flush(stdout())
+
+### Name: power.t.test
+### Title: Power calculations for one and two sample t tests
+### Aliases: power.t.test
+### Keywords: htest
+
+### ** Examples
+
+ power.t.test(n = 20, delta = 1)
+ power.t.test(power = .90, delta = 1)
+ power.t.test(power = .90, delta = 1, alternative = "one.sided")
+
+
+
+cleanEx()
+nameEx("pp.test")
+### * pp.test
+
+flush(stderr()); flush(stdout())
+
+### Name: PP.test
+### Title: Phillips-Perron Test for Unit Roots
+### Aliases: PP.test
+### Keywords: ts
+
+### ** Examples
+
+x <- rnorm(1000)
+PP.test(x)
+y <- cumsum(x) # has unit root
+PP.test(y)
+
+
+
+cleanEx()
+nameEx("ppoints")
+### * ppoints
+
+flush(stderr()); flush(stdout())
+
+### Name: ppoints
+### Title: Ordinates for Probability Plotting
+### Aliases: ppoints
+### Keywords: dplot arith distribution
+
+### ** Examples
+
+ppoints(4) # the same as ppoints(1:4)
+ppoints(10)
+ppoints(10, a = 1/2)
+
+## Visualize including the fractions :
+require(graphics)## Don't show:
+lNs <- loadedNamespaces()
+## End(Don't show)
+p.ppoints <- function(n, ..., add = FALSE, col = par("col")) {
+ pn <- ppoints(n, ...)
+ if(add)
+ points(pn, pn, col = col)
+ else {
+ tit <- match.call(); tit[[1]] <- quote(ppoints)
+ plot(pn,pn, main = deparse(tit), col=col,
+ xlim = 0:1, ylim = 0:1, xaxs = "i", yaxs = "i")
+ abline(0, 1, col = adjustcolor(1, 1/4), lty = 3)
+ }
+ if(!add && requireNamespace("MASS", quietly = TRUE))
+ text(pn, pn, as.character(MASS::fractions(pn)),
+ adj = c(0,0)-1/4, cex = 3/4, xpd = NA, col=col)
+ abline(h = pn, v = pn, col = adjustcolor(col, 1/2), lty = 2, lwd = 1/2)
+}
+
+p.ppoints(4)
+p.ppoints(10)
+p.ppoints(10, a = 1/2)
+p.ppoints(21)
+p.ppoints(8) ; p.ppoints(8, a = 1/2, add=TRUE, col="tomato")
+## Don't show:
+if(!any("MASS" == lNs)) unloadNamespace("MASS")
+## End(Don't show)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("ppr")
+### * ppr
+
+flush(stderr()); flush(stdout())
+
+### Name: ppr
+### Title: Projection Pursuit Regression
+### Aliases: ppr ppr.default ppr.formula
+### Keywords: regression
+
+### ** Examples
+
+require(graphics)
+
+# Note: your numerical values may differ
+attach(rock)
+area1 <- area/10000; peri1 <- peri/10000
+rock.ppr <- ppr(log(perm) ~ area1 + peri1 + shape,
+ data = rock, nterms = 2, max.terms = 5)
+rock.ppr
+# Call:
+# ppr.formula(formula = log(perm) ~ area1 + peri1 + shape, data = rock,
+# nterms = 2, max.terms = 5)
+#
+# Goodness of fit:
+# 2 terms 3 terms 4 terms 5 terms
+# 8.737806 5.289517 4.745799 4.490378
+
+summary(rock.ppr)
+# ..... (same as above)
+# .....
+#
+# Projection direction vectors ('alpha'):
+# term 1 term 2
+# area1 0.34357179 0.37071027
+# peri1 -0.93781471 -0.61923542
+# shape 0.04961846 0.69218595
+#
+# Coefficients of ridge terms:
+# term 1 term 2
+# 1.6079271 0.5460971
+
+par(mfrow = c(3,2)) # maybe: , pty = "s")
+plot(rock.ppr, main = "ppr(log(perm)~ ., nterms=2, max.terms=5)")
+plot(update(rock.ppr, bass = 5), main = "update(..., bass = 5)")
+plot(update(rock.ppr, sm.method = "gcv", gcvpen = 2),
+ main = "update(..., sm.method=\"gcv\", gcvpen=2)")
+cbind(perm = rock$perm, prediction = round(exp(predict(rock.ppr)), 1))
+detach()
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("prcomp")
+### * prcomp
+
+flush(stderr()); flush(stdout())
+
+### Name: prcomp
+### Title: Principal Components Analysis
+### Aliases: prcomp prcomp.formula prcomp.default plot.prcomp
+### predict.prcomp print.prcomp summary.prcomp print.summary.prcomp
+### Keywords: multivariate
+
+### ** Examples
+
+C <- chol(S <- toeplitz(.9 ^ (0:31))) # Cov.matrix and its root
+all.equal(S, crossprod(C))
+set.seed(17)
+X <- matrix(rnorm(32000), 1000, 32)
+Z <- X %*% C ## ==> cov(Z) ~= C'C = S
+all.equal(cov(Z), S, tol = 0.08)
+pZ <- prcomp(Z, tol = 0.1)
+summary(pZ) # only ~14 PCs (out of 32)
+## or choose only 3 PCs more directly:
+pz3 <- prcomp(Z, rank. = 3)
+summary(pz3) # same numbers as the first 3 above
+stopifnot(ncol(pZ$rotation) == 14, ncol(pz3$rotation) == 3,
+ all.equal(pz3$sdev, pZ$sdev, tol = 1e-15)) # exactly equal typically
+
+
+
+
+cleanEx()
+nameEx("predict.HoltWinters")
+### * predict.HoltWinters
+
+flush(stderr()); flush(stdout())
+
+### Name: predict.HoltWinters
+### Title: Prediction Function for Fitted Holt-Winters Models
+### Aliases: predict.HoltWinters
+### Keywords: ts
+
+### ** Examples
+
+require(graphics)
+
+m <- HoltWinters(co2)
+p <- predict(m, 50, prediction.interval = TRUE)
+plot(m, p)
+
+
+
+cleanEx()
+nameEx("predict")
+### * predict
+
+flush(stderr()); flush(stdout())
+
+### Name: predict
+### Title: Model Predictions
+### Aliases: predict
+### Keywords: methods
+
+### ** Examples
+
+## Don't show:
+old <- Sys.setlocale("LC_COLLATE", "C")
+## End(Don't show)
+require(utils)
+
+## All the "predict" methods found
+## NB most of the methods in the standard packages are hidden.
+## Output will depend on what namespaces are (or have been) loaded.
+## IGNORE_RDIFF_BEGIN
+for(fn in methods("predict"))
+ try({
+ f <- eval(substitute(getAnywhere(fn)$objs[[1]], list(fn = fn)))
+ cat(fn, ":\n\t", deparse(args(f)), "\n")
+ }, silent = TRUE)
+## IGNORE_RDIFF_END
+## Don't show:
+old <- Sys.setlocale("LC_COLLATE", old)
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("predict.arima")
+### * predict.arima
+
+flush(stderr()); flush(stdout())
+
+### Name: predict.Arima
+### Title: Forecast from ARIMA fits
+### Aliases: predict.Arima
+### Keywords: ts
+
+### ** Examples
+
+od <- options(digits = 5) # avoid too much spurious accuracy
+predict(arima(lh, order = c(3,0,0)), n.ahead = 12)
+
+(fit <- arima(USAccDeaths, order = c(0,1,1),
+ seasonal = list(order = c(0,1,1))))
+predict(fit, n.ahead = 6)
+options(od)
+
+
+
+cleanEx()
+nameEx("predict.glm")
+### * predict.glm
+
+flush(stderr()); flush(stdout())
+
+### Name: predict.glm
+### Title: Predict Method for GLM Fits
+### Aliases: predict.glm
+### Keywords: models regression
+
+### ** Examples
+
+require(graphics)
+
+## example from Venables and Ripley (2002, pp. 190-2.)
+ldose <- rep(0:5, 2)
+numdead <- c(1, 4, 9, 13, 18, 20, 0, 2, 6, 10, 12, 16)
+sex <- factor(rep(c("M", "F"), c(6, 6)))
+SF <- cbind(numdead, numalive = 20-numdead)
+budworm.lg <- glm(SF ~ sex*ldose, family = binomial)
+summary(budworm.lg)
+
+plot(c(1,32), c(0,1), type = "n", xlab = "dose",
+ ylab = "prob", log = "x")
+text(2^ldose, numdead/20, as.character(sex))
+ld <- seq(0, 5, 0.1)
+lines(2^ld, predict(budworm.lg, data.frame(ldose = ld,
+ sex = factor(rep("M", length(ld)), levels = levels(sex))),
+ type = "response"))
+lines(2^ld, predict(budworm.lg, data.frame(ldose = ld,
+ sex = factor(rep("F", length(ld)), levels = levels(sex))),
+ type = "response"))
+
+
+
+cleanEx()
+nameEx("predict.lm")
+### * predict.lm
+
+flush(stderr()); flush(stdout())
+
+### Name: predict.lm
+### Title: Predict method for Linear Model Fits
+### Aliases: predict.lm
+### Keywords: regression
+
+### ** Examples
+
+require(graphics)
+
+## Predictions
+x <- rnorm(15)
+y <- x + rnorm(15)
+predict(lm(y ~ x))
+new <- data.frame(x = seq(-3, 3, 0.5))
+predict(lm(y ~ x), new, se.fit = TRUE)
+pred.w.plim <- predict(lm(y ~ x), new, interval = "prediction")
+pred.w.clim <- predict(lm(y ~ x), new, interval = "confidence")
+matplot(new$x, cbind(pred.w.clim, pred.w.plim[,-1]),
+ lty = c(1,2,2,3,3), type = "l", ylab = "predicted y")
+
+## Prediction intervals, special cases
+## The first three of these throw warnings
+w <- 1 + x^2
+fit <- lm(y ~ x)
+wfit <- lm(y ~ x, weights = w)
+predict(fit, interval = "prediction")
+predict(wfit, interval = "prediction")
+predict(wfit, new, interval = "prediction")
+predict(wfit, new, interval = "prediction", weights = (new$x)^2)
+predict(wfit, new, interval = "prediction", weights = ~x^2)
+
+##-- From aov(.) example ---- predict(.. terms)
+npk.aov <- aov(yield ~ block + N*P*K, npk)
+(termL <- attr(terms(npk.aov), "term.labels"))
+(pt <- predict(npk.aov, type = "terms"))
+pt. <- predict(npk.aov, type = "terms", terms = termL[1:4])
+stopifnot(all.equal(pt[,1:4], pt.,
+ tolerance = 1e-12, check.attributes = FALSE))
+
+
+
+cleanEx()
+nameEx("predict.loess")
+### * predict.loess
+
+flush(stderr()); flush(stdout())
+
+### Name: predict.loess
+### Title: Predict Loess Curve or Surface
+### Aliases: predict.loess
+### Keywords: smooth
+
+### ** Examples
+
+cars.lo <- loess(dist ~ speed, cars)
+predict(cars.lo, data.frame(speed = seq(5, 30, 1)), se = TRUE)
+# to get extrapolation
+cars.lo2 <- loess(dist ~ speed, cars,
+ control = loess.control(surface = "direct"))
+predict(cars.lo2, data.frame(speed = seq(5, 30, 1)), se = TRUE)
+
+
+
+cleanEx()
+nameEx("predict.nls")
+### * predict.nls
+
+flush(stderr()); flush(stdout())
+
+### Name: predict.nls
+### Title: Predicting from Nonlinear Least Squares Fits
+### Aliases: predict.nls
+### Keywords: nonlinear regression models
+
+### ** Examples
+
+## Don't show:
+od <- options(digits = 5)
+## End(Don't show)
+require(graphics)
+
+fm <- nls(demand ~ SSasympOrig(Time, A, lrc), data = BOD)
+predict(fm) # fitted values at observed times
+## Form data plot and smooth line for the predictions
+opar <- par(las = 1)
+plot(demand ~ Time, data = BOD, col = 4,
+ main = "BOD data and fitted first-order curve",
+ xlim = c(0,7), ylim = c(0, 20) )
+tt <- seq(0, 8, length = 101)
+lines(tt, predict(fm, list(Time = tt)))
+par(opar)
+## Don't show:
+options(od)
+## End(Don't show)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("predict.smooth.spline")
+### * predict.smooth.spline
+
+flush(stderr()); flush(stdout())
+
+### Name: predict.smooth.spline
+### Title: Predict from Smoothing Spline Fit
+### Aliases: predict.smooth.spline
+### Keywords: smooth
+
+### ** Examples
+
+require(graphics)
+
+attach(cars)
+cars.spl <- smooth.spline(speed, dist, df = 6.4)
+## Don't show:
+print.default(cars.spl)
+## End(Don't show)
+
+## "Proof" that the derivatives are okay, by comparing with approximation
+diff.quot <- function(x, y) {
+ ## Difference quotient (central differences where available)
+ n <- length(x); i1 <- 1:2; i2 <- (n-1):n
+ c(diff(y[i1]) / diff(x[i1]), (y[-i1] - y[-i2]) / (x[-i1] - x[-i2]),
+ diff(y[i2]) / diff(x[i2]))
+}
+
+xx <- unique(sort(c(seq(0, 30, by = .2), kn <- unique(speed))))
+i.kn <- match(kn, xx) # indices of knots within xx
+op <- par(mfrow = c(2,2))
+plot(speed, dist, xlim = range(xx), main = "Smooth.spline & derivatives")
+lines(pp <- predict(cars.spl, xx), col = "red")
+points(kn, pp$y[i.kn], pch = 3, col = "dark red")
+mtext("s(x)", col = "red")
+for(d in 1:3){
+ n <- length(pp$x)
+ plot(pp$x, diff.quot(pp$x,pp$y), type = "l", xlab = "x", ylab = "",
+ col = "blue", col.main = "red",
+ main = paste0("s" ,paste(rep("'", d), collapse = ""), "(x)"))
+ mtext("Difference quotient approx.(last)", col = "blue")
+ lines(pp <- predict(cars.spl, xx, deriv = d), col = "red")
+## Don't show:
+ print(pp)
+## End(Don't show)
+ points(kn, pp$y[i.kn], pch = 3, col = "dark red")
+ abline(h = 0, lty = 3, col = "gray")
+}
+detach(); par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("princomp")
+### * princomp
+
+flush(stderr()); flush(stdout())
+
+### Name: princomp
+### Title: Principal Components Analysis
+### Aliases: princomp princomp.formula princomp.default plot.princomp
+### print.princomp predict.princomp
+### Keywords: multivariate
+
+### ** Examples
+
+require(graphics)
+
+## The variances of the variables in the
+## USArrests data vary by orders of magnitude, so scaling is appropriate
+(pc.cr <- princomp(USArrests)) # inappropriate
+princomp(USArrests, cor = TRUE) # =^= prcomp(USArrests, scale=TRUE)
+## Similar, but different:
+## The standard deviations differ by a factor of sqrt(49/50)
+
+summary(pc.cr <- princomp(USArrests, cor = TRUE))
+loadings(pc.cr) # note that blank entries are small but not zero
+## The signs of the columns are arbitrary
+plot(pc.cr) # shows a screeplot.
+biplot(pc.cr)
+
+## Formula interface
+princomp(~ ., data = USArrests, cor = TRUE)
+
+## NA-handling
+USArrests[1, 2] <- NA
+pc.cr <- princomp(~ Murder + Assault + UrbanPop,
+ data = USArrests, na.action = na.exclude, cor = TRUE)
+
+## (Simple) Robust PCA:
+## Classical:
+(pc.cl <- princomp(stackloss))
+
+
+cleanEx()
+nameEx("print.power.htest")
+### * print.power.htest
+
+flush(stderr()); flush(stdout())
+
+### Name: print.power.htest
+### Title: Print Methods for Hypothesis Tests and Power Calculation Objects
+### Aliases: print.htest print.power.htest
+### Keywords: htest
+
+### ** Examples
+
+(ptt <- power.t.test(n = 20, delta = 1))
+print(ptt, digits = 4) # using less digits than default
+print(ptt, digits = 12) # using more " " "
+
+
+
+cleanEx()
+nameEx("print.ts")
+### * print.ts
+
+flush(stderr()); flush(stdout())
+
+### Name: print.ts
+### Title: Printing and Formatting of Time-Series Objects
+### Aliases: .preformat.ts print.ts
+### Keywords: ts
+
+### ** Examples
+
+print(ts(1:10, frequency = 7, start = c(12, 2)), calendar = TRUE)
+
+print(sunsp.1 <- window(sunspot.month, end=c(1756, 12)))
+m <- .preformat.ts(sunsp.1) # a character matrix
+
+
+
+cleanEx()
+nameEx("printCoefmat")
+### * printCoefmat
+
+flush(stderr()); flush(stdout())
+
+### Name: printCoefmat
+### Title: Print Coefficient Matrices
+### Aliases: printCoefmat
+### Keywords: print
+
+### ** Examples
+
+cmat <- cbind(rnorm(3, 10), sqrt(rchisq(3, 12)))
+cmat <- cbind(cmat, cmat[, 1]/cmat[, 2])
+cmat <- cbind(cmat, 2*pnorm(-cmat[, 3]))
+colnames(cmat) <- c("Estimate", "Std.Err", "Z value", "Pr(>z)")
+printCoefmat(cmat[, 1:3])
+printCoefmat(cmat)
+op <- options(show.coef.Pvalues = FALSE)
+printCoefmat(cmat, digits = 2)
+printCoefmat(cmat, digits = 2, P.values = TRUE)
+options(op) # restore
+
+
+
+cleanEx()
+nameEx("profile.nls")
+### * profile.nls
+
+flush(stderr()); flush(stdout())
+
+### Name: profile.nls
+### Title: Method for Profiling nls Objects
+### Aliases: profile.nls
+### Keywords: nonlinear regression models
+
+### ** Examples
+
+## Don't show:
+od <- options(digits = 4)
+## End(Don't show)
+# obtain the fitted object
+fm1 <- nls(demand ~ SSasympOrig(Time, A, lrc), data = BOD)
+# get the profile for the fitted model: default level is too extreme
+pr1 <- profile(fm1, alpha = 0.05)
+# profiled values for the two parameters
+pr1$A
+pr1$lrc
+# see also example(plot.profile.nls)
+## Don't show:
+options(od)
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("proj")
+### * proj
+
+flush(stderr()); flush(stdout())
+
+### Name: proj
+### Title: Projections of Models
+### Aliases: proj proj.default proj.lm proj.aov proj.aovlist
+### Keywords: models
+
+### ** Examples
+
+N <- c(0,1,0,1,1,1,0,0,0,1,1,0,1,1,0,0,1,0,1,0,1,1,0,0)
+P <- c(1,1,0,0,0,1,0,1,1,1,0,0,0,1,0,1,1,0,0,1,0,1,1,0)
+K <- c(1,0,0,1,0,1,1,0,0,1,0,1,0,1,1,0,0,0,1,1,1,0,1,0)
+yield <- c(49.5,62.8,46.8,57.0,59.8,58.5,55.5,56.0,62.8,55.8,69.5,
+55.0, 62.0,48.8,45.5,44.2,52.0,51.5,49.8,48.8,57.2,59.0,53.2,56.0)
+
+npk <- data.frame(block = gl(6,4), N = factor(N), P = factor(P),
+ K = factor(K), yield = yield)
+npk.aov <- aov(yield ~ block + N*P*K, npk)
+proj(npk.aov)
+
+## as a test, not particularly sensible
+options(contrasts = c("contr.helmert", "contr.treatment"))
+npk.aovE <- aov(yield ~ N*P*K + Error(block), npk)
+proj(npk.aovE)
+
+
+
+base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
+cleanEx()
+nameEx("prop.test")
+### * prop.test
+
+flush(stderr()); flush(stdout())
+
+### Name: prop.test
+### Title: Test of Equal or Given Proportions
+### Aliases: prop.test
+### Keywords: htest
+
+### ** Examples
+
+heads <- rbinom(1, size = 100, prob = .5)
+prop.test(heads, 100) # continuity correction TRUE by default
+prop.test(heads, 100, correct = FALSE)
+
+## Data from Fleiss (1981), p. 139.
+## H0: The null hypothesis is that the four populations from which
+## the patients were drawn have the same true proportion of smokers.
+## A: The alternative is that this proportion is different in at
+## least one of the populations.
+
+smokers <- c( 83, 90, 129, 70 )
+patients <- c( 86, 93, 136, 82 )
+prop.test(smokers, patients)
+
+
+
+cleanEx()
+nameEx("prop.trend.test")
+### * prop.trend.test
+
+flush(stderr()); flush(stdout())
+
+### Name: prop.trend.test
+### Title: Test for trend in proportions
+### Aliases: prop.trend.test
+### Keywords: htest
+
+### ** Examples
+
+smokers <- c( 83, 90, 129, 70 )
+patients <- c( 86, 93, 136, 82 )
+prop.test(smokers, patients)
+prop.trend.test(smokers, patients)
+prop.trend.test(smokers, patients, c(0,0,0,1))
+
+
+
+cleanEx()
+nameEx("qqnorm")
+### * qqnorm
+
+flush(stderr()); flush(stdout())
+
+### Name: qqnorm
+### Title: Quantile-Quantile Plots
+### Aliases: qqnorm qqnorm.default qqplot qqline
+### Keywords: hplot distribution
+
+### ** Examples
+
+require(graphics)
+
+y <- rt(200, df = 5)
+qqnorm(y); qqline(y, col = 2)
+qqplot(y, rt(300, df = 5))
+
+qqnorm(precip, ylab = "Precipitation [in/yr] for 70 US cities")
+
+## "QQ-Chisquare" : --------------------------
+y <- rchisq(500, df = 3)
+## Q-Q plot for Chi^2 data against true theoretical distribution:
+qqplot(qchisq(ppoints(500), df = 3), y,
+ main = expression("Q-Q plot for" ~~ {chi^2}[nu == 3]))
+qqline(y, distribution = function(p) qchisq(p, df = 3),
+ prob = c(0.1, 0.6), col = 2)
+mtext("qqline(*, dist = qchisq(., df=3), prob = c(0.1, 0.6))")
+
+
+
+cleanEx()
+nameEx("quade.test")
+### * quade.test
+
+flush(stderr()); flush(stdout())
+
+### Name: quade.test
+### Title: Quade Test
+### Aliases: quade.test quade.test.default quade.test.formula
+### Keywords: htest
+
+### ** Examples
+
+## Conover (1999, p. 375f):
+## Numbers of five brands of a new hand lotion sold in seven stores
+## during one week.
+y <- matrix(c( 5, 4, 7, 10, 12,
+ 1, 3, 1, 0, 2,
+ 16, 12, 22, 22, 35,
+ 5, 4, 3, 5, 4,
+ 10, 9, 7, 13, 10,
+ 19, 18, 28, 37, 58,
+ 10, 7, 6, 8, 7),
+ nrow = 7, byrow = TRUE,
+ dimnames =
+ list(Store = as.character(1:7),
+ Brand = LETTERS[1:5]))
+y
+quade.test(y)
+
+
+
+cleanEx()
+nameEx("quantile")
+### * quantile
+
+flush(stderr()); flush(stdout())
+
+### Name: quantile
+### Title: Sample Quantiles
+### Aliases: quantile quantile.default
+### Keywords: univar
+
+### ** Examples
+
+quantile(x <- rnorm(1001)) # Extremes & Quartiles by default
+quantile(x, probs = c(0.1, 0.5, 1, 2, 5, 10, 50, NA)/100)
+
+### Compare different types
+quantAll <- function(x, prob, ...)
+ t(vapply(1:9, function(typ) quantile(x, prob=prob, type = typ, ...), quantile(x, prob, type=1)))
+p <- c(0.1, 0.5, 1, 2, 5, 10, 50)/100
+signif(quantAll(x, p), 4)
+## for complex numbers:
+z <- complex(re=x, im = -10*x)
+signif(quantAll(z, p), 4)
+
+
+
+cleanEx()
+nameEx("r2dtable")
+### * r2dtable
+
+flush(stderr()); flush(stdout())
+
+### Name: r2dtable
+### Title: Random 2-way Tables with Given Marginals
+### Aliases: r2dtable
+### Keywords: distribution
+
+### ** Examples
+
+## Fisher's Tea Drinker data.
+TeaTasting <-
+matrix(c(3, 1, 1, 3),
+ nrow = 2,
+ dimnames = list(Guess = c("Milk", "Tea"),
+ Truth = c("Milk", "Tea")))
+## Simulate permutation test for independence based on the maximum
+## Pearson residuals (rather than their sum).
+rowTotals <- rowSums(TeaTasting)
+colTotals <- colSums(TeaTasting)
+nOfCases <- sum(rowTotals)
+expected <- outer(rowTotals, colTotals, "*") / nOfCases
+maxSqResid <- function(x) max((x - expected) ^ 2 / expected)
+simMaxSqResid <-
+ sapply(r2dtable(1000, rowTotals, colTotals), maxSqResid)
+sum(simMaxSqResid >= maxSqResid(TeaTasting)) / 1000
+## Fisher's exact test gives p = 0.4857 ...
+
+
+
+cleanEx()
+nameEx("rWishart")
+### * rWishart
+
+flush(stderr()); flush(stdout())
+
+### Name: rWishart
+### Title: Random Wishart Distributed Matrices
+### Aliases: rWishart
+### Keywords: multivariate
+
+### ** Examples
+
+## Artificial
+S <- toeplitz((10:1)/10)
+set.seed(11)
+R <- rWishart(1000, 20, S)
+dim(R) # 10 10 1000
+mR <- apply(R, 1:2, mean) # ~= E[ Wish(S, 20) ] = 20 * S
+stopifnot(all.equal(mR, 20*S, tolerance = .009))
+
+## See Details, the variance is
+Va <- 20*(S^2 + tcrossprod(diag(S)))
+vR <- apply(R, 1:2, var)
+stopifnot(all.equal(vR, Va, tolerance = 1/16))
+
+
+
+cleanEx()
+nameEx("read.ftable")
+### * read.ftable
+
+flush(stderr()); flush(stdout())
+
+### Name: read.ftable
+### Title: Manipulate Flat Contingency Tables
+### Aliases: read.ftable write.ftable format.ftable print.ftable
+### Keywords: category
+
+### ** Examples
+
+## Agresti (1990), page 157, Table 5.8.
+## Not in ftable standard format, but o.k.
+file <- tempfile()
+cat(" Intercourse\n",
+ "Race Gender Yes No\n",
+ "White Male 43 134\n",
+ " Female 26 149\n",
+ "Black Male 29 23\n",
+ " Female 22 36\n",
+ file = file)
+ft1 <- read.ftable(file)
+ft1
+unlink(file)
+
+## Agresti (1990), page 297, Table 8.16.
+## Almost o.k., but misses the name of the row variable.
+file <- tempfile()
+cat(" \"Tonsil Size\"\n",
+ " \"Not Enl.\" \"Enl.\" \"Greatly Enl.\"\n",
+ "Noncarriers 497 560 269\n",
+ "Carriers 19 29 24\n",
+ file = file)
+ft <- read.ftable(file, skip = 2,
+ row.var.names = "Status",
+ col.vars = list("Tonsil Size" =
+ c("Not Enl.", "Enl.", "Greatly Enl.")))
+ft
+unlink(file)
+
+ft22 <- ftable(Titanic, row.vars = 2:1, col.vars = 4:3)
+write.ftable(ft22, quote = FALSE)
+write.ftable(ft22, quote = FALSE, method="row.compact")
+write.ftable(ft22, quote = FALSE, method="col.compact")
+write.ftable(ft22, quote = FALSE, method="compact")
+## Don't show:
+ op <- options(warn = 2) # no warnings allowed
+ stopifnot(dim(format(ft)) == 4:5,
+ dim(format(ftable(UCBAdmissions))) == c(6,9))
+ meths <- c("non.compact", "row.compact", "col.compact", "compact")
+ dimform <-
+ function(ft) sapply(meths, function(M) dim(format(ft, method = M)))
+ m.eq <- function(M,m) all.equal(unname(M), m, tolerance = 0)
+ ## All format(..) w/o warnings:
+ stopifnot(m.eq(print(dimform(ft22)),
+ rbind(11:10, rep(7:6, each = 2))),
+ m.eq(print(dimform(ftable(Titanic, row.vars = integer()))),
+ rbind(rep(6:5,2), 33)))
+ options(op)
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("rect.hclust")
+### * rect.hclust
+
+flush(stderr()); flush(stdout())
+
+### Name: rect.hclust
+### Title: Draw Rectangles Around Hierarchical Clusters
+### Aliases: rect.hclust
+### Keywords: aplot cluster
+
+### ** Examples
+
+require(graphics)
+
+hca <- hclust(dist(USArrests))
+plot(hca)
+rect.hclust(hca, k = 3, border = "red")
+x <- rect.hclust(hca, h = 50, which = c(2,7), border = 3:4)
+x
+
+
+
+cleanEx()
+nameEx("relevel")
+### * relevel
+
+flush(stderr()); flush(stdout())
+
+### Name: relevel
+### Title: Reorder Levels of Factor
+### Aliases: relevel relevel.default relevel.factor relevel.ordered
+### Keywords: utilities models
+
+### ** Examples
+
+warpbreaks$tension <- relevel(warpbreaks$tension, ref = "M")
+summary(lm(breaks ~ wool + tension, data = warpbreaks))
+
+
+
+cleanEx()
+nameEx("reorder.dendrogram")
+### * reorder.dendrogram
+
+flush(stderr()); flush(stdout())
+
+### Name: reorder.dendrogram
+### Title: Reorder a Dendrogram
+### Aliases: reorder.dendrogram
+### Keywords: manip
+
+### ** Examples
+
+require(graphics)
+
+set.seed(123)
+x <- rnorm(10)
+hc <- hclust(dist(x))
+dd <- as.dendrogram(hc)
+dd.reorder <- reorder(dd, 10:1)
+plot(dd, main = "random dendrogram 'dd'")
+
+op <- par(mfcol = 1:2)
+plot(dd.reorder, main = "reorder(dd, 10:1)")
+plot(reorder(dd, 10:1, agglo.FUN = mean), main = "reorder(dd, 10:1, mean)")
+par(op)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("reorder.factor")
+### * reorder.factor
+
+flush(stderr()); flush(stdout())
+
+### Name: reorder.default
+### Title: Reorder Levels of a Factor
+### Aliases: reorder reorder.default
+### Keywords: utilities
+
+### ** Examples
+
+require(graphics)
+
+bymedian <- with(InsectSprays, reorder(spray, count, median))
+boxplot(count ~ bymedian, data = InsectSprays,
+ xlab = "Type of spray", ylab = "Insect count",
+ main = "InsectSprays data", varwidth = TRUE,
+ col = "lightgray")
+
+
+
+cleanEx()
+nameEx("replications")
+### * replications
+
+flush(stderr()); flush(stdout())
+
+### Name: replications
+### Title: Number of Replications of Terms
+### Aliases: replications
+### Keywords: models
+
+### ** Examples
+
+## From Venables and Ripley (2002) p.165.
+N <- c(0,1,0,1,1,1,0,0,0,1,1,0,1,1,0,0,1,0,1,0,1,1,0,0)
+P <- c(1,1,0,0,0,1,0,1,1,1,0,0,0,1,0,1,1,0,0,1,0,1,1,0)
+K <- c(1,0,0,1,0,1,1,0,0,1,0,1,0,1,1,0,0,0,1,1,1,0,1,0)
+yield <- c(49.5,62.8,46.8,57.0,59.8,58.5,55.5,56.0,62.8,55.8,69.5,
+55.0, 62.0,48.8,45.5,44.2,52.0,51.5,49.8,48.8,57.2,59.0,53.2,56.0)
+
+npk <- data.frame(block = gl(6,4), N = factor(N), P = factor(P),
+ K = factor(K), yield = yield)
+replications(~ . - yield, npk)
+
+
+
+cleanEx()
+nameEx("reshape")
+### * reshape
+
+flush(stderr()); flush(stdout())
+
+### Name: reshape
+### Title: Reshape Grouped Data
+### Aliases: reshape
+### Keywords: manip
+
+### ** Examples
+
+summary(Indometh)
+wide <- reshape(Indometh, v.names = "conc", idvar = "Subject",
+ timevar = "time", direction = "wide")
+wide
+
+reshape(wide, direction = "long")
+reshape(wide, idvar = "Subject", varying = list(2:12),
+ v.names = "conc", direction = "long")
+
+## times need not be numeric
+df <- data.frame(id = rep(1:4, rep(2,4)),
+ visit = I(rep(c("Before","After"), 4)),
+ x = rnorm(4), y = runif(4))
+df
+reshape(df, timevar = "visit", idvar = "id", direction = "wide")
+## warns that y is really varying
+reshape(df, timevar = "visit", idvar = "id", direction = "wide", v.names = "x")
+
+
+## unbalanced 'long' data leads to NA fill in 'wide' form
+df2 <- df[1:7, ]
+df2
+reshape(df2, timevar = "visit", idvar = "id", direction = "wide")
+
+## Alternative regular expressions for guessing names
+df3 <- data.frame(id = 1:4, age = c(40,50,60,50), dose1 = c(1,2,1,2),
+ dose2 = c(2,1,2,1), dose4 = c(3,3,3,3))
+reshape(df3, direction = "long", varying = 3:5, sep = "")
+
+
+## an example that isn't longitudinal data
+state.x77 <- as.data.frame(state.x77)
+long <- reshape(state.x77, idvar = "state", ids = row.names(state.x77),
+ times = names(state.x77), timevar = "Characteristic",
+ varying = list(names(state.x77)), direction = "long")
+
+reshape(long, direction = "wide")
+
+reshape(long, direction = "wide", new.row.names = unique(long$state))
+
+## multiple id variables
+df3 <- data.frame(school = rep(1:3, each = 4), class = rep(9:10, 6),
+ time = rep(c(1,1,2,2), 3), score = rnorm(12))
+wide <- reshape(df3, idvar = c("school","class"), direction = "wide")
+wide
+## transform back
+reshape(wide)
+
+
+
+
+cleanEx()
+nameEx("runmed")
+### * runmed
+
+flush(stderr()); flush(stdout())
+
+### Name: runmed
+### Title: Running Medians - Robust Scatter Plot Smoothing
+### Aliases: runmed
+### Keywords: smooth robust
+
+### ** Examples
+
+require(graphics)
+
+utils::example(nhtemp)
+myNHT <- as.vector(nhtemp)
+myNHT[20] <- 2 * nhtemp[20]
+plot(myNHT, type = "b", ylim = c(48, 60), main = "Running Medians Example")
+lines(runmed(myNHT, 7), col = "red")
+
+## special: multiple y values for one x
+plot(cars, main = "'cars' data and runmed(dist, 3)")
+lines(cars, col = "light gray", type = "c")
+with(cars, lines(speed, runmed(dist, k = 3), col = 2))
+
+## nice quadratic with a few outliers
+y <- ys <- (-20:20)^2
+y [c(1,10,21,41)] <- c(150, 30, 400, 450)
+all(y == runmed(y, 1)) # 1-neighbourhood <==> interpolation
+plot(y) ## lines(y, lwd = .1, col = "light gray")
+lines(lowess(seq(y), y, f = 0.3), col = "brown")
+lines(runmed(y, 7), lwd = 2, col = "blue")
+lines(runmed(y, 11), lwd = 2, col = "red")
+
+## Lowess is not robust
+y <- ys ; y[21] <- 6666 ; x <- seq(y)
+col <- c("black", "brown","blue")
+plot(y, col = col[1])
+lines(lowess(x, y, f = 0.3), col = col[2])
+lines(runmed(y, 7), lwd = 2, col = col[3])
+legend(length(y),max(y), c("data", "lowess(y, f = 0.3)", "runmed(y, 7)"),
+ xjust = 1, col = col, lty = c(0, 1, 1), pch = c(1,NA,NA))
+
+
+
+cleanEx()
+nameEx("scatter.smooth")
+### * scatter.smooth
+
+flush(stderr()); flush(stdout())
+
+### Name: scatter.smooth
+### Title: Scatter Plot with Smooth Curve Fitted by Loess
+### Aliases: scatter.smooth loess.smooth
+### Keywords: smooth
+
+### ** Examples
+
+require(graphics)
+
+with(cars, scatter.smooth(speed, dist))
+## or with dotted thick smoothed line results :
+with(cars, scatter.smooth(speed, dist, lpars =
+ list(col = "red", lwd = 3, lty = 3)))
+
+
+
+cleanEx()
+nameEx("screeplot")
+### * screeplot
+
+flush(stderr()); flush(stdout())
+
+### Name: screeplot
+### Title: Screeplots
+### Aliases: screeplot screeplot.default
+### Keywords: multivariate
+
+### ** Examples
+
+require(graphics)
+
+## The variances of the variables in the
+## USArrests data vary by orders of magnitude, so scaling is appropriate
+(pc.cr <- princomp(USArrests, cor = TRUE)) # inappropriate
+screeplot(pc.cr)
+
+fit <- princomp(covmat = Harman74.cor)
+screeplot(fit)
+screeplot(fit, npcs = 24, type = "lines")
+
+
+
+cleanEx()
+nameEx("sd")
+### * sd
+
+flush(stderr()); flush(stdout())
+
+### Name: sd
+### Title: Standard Deviation
+### Aliases: sd
+### Keywords: univar
+
+### ** Examples
+
+sd(1:2) ^ 2
+
+
+
+cleanEx()
+nameEx("se.contrast")
+### * se.contrast
+
+flush(stderr()); flush(stdout())
+
+### Name: se.contrast
+### Title: Standard Errors for Contrasts in Model Terms
+### Aliases: se.contrast se.contrast.aov se.contrast.aovlist
+### Keywords: models
+
+### ** Examples
+
+## From Venables and Ripley (2002) p.165.
+N <- c(0,1,0,1,1,1,0,0,0,1,1,0,1,1,0,0,1,0,1,0,1,1,0,0)
+P <- c(1,1,0,0,0,1,0,1,1,1,0,0,0,1,0,1,1,0,0,1,0,1,1,0)
+K <- c(1,0,0,1,0,1,1,0,0,1,0,1,0,1,1,0,0,0,1,1,1,0,1,0)
+yield <- c(49.5,62.8,46.8,57.0,59.8,58.5,55.5,56.0,62.8,55.8,69.5,
+55.0, 62.0,48.8,45.5,44.2,52.0,51.5,49.8,48.8,57.2,59.0,53.2,56.0)
+
+npk <- data.frame(block = gl(6,4), N = factor(N), P = factor(P),
+ K = factor(K), yield = yield)
+## Set suitable contrasts.
+options(contrasts = c("contr.helmert", "contr.poly"))
+npk.aov1 <- aov(yield ~ block + N + K, data = npk)
+se.contrast(npk.aov1, list(N == "0", N == "1"), data = npk)
+# or via a matrix
+cont <- matrix(c(-1,1), 2, 1, dimnames = list(NULL, "N"))
+se.contrast(npk.aov1, cont[N, , drop = FALSE]/12, data = npk)
+
+## test a multi-stratum model
+npk.aov2 <- aov(yield ~ N + K + Error(block/(N + K)), data = npk)
+se.contrast(npk.aov2, list(N == "0", N == "1"))
+
+
+## an example looking at an interaction contrast
+## Dataset from R.E. Kirk (1995)
+## 'Experimental Design: procedures for the behavioral sciences'
+score <- c(12, 8,10, 6, 8, 4,10,12, 8, 6,10,14, 9, 7, 9, 5,11,12,
+ 7,13, 9, 9, 5,11, 8, 7, 3, 8,12,10,13,14,19, 9,16,14)
+A <- gl(2, 18, labels = c("a1", "a2"))
+B <- rep(gl(3, 6, labels = c("b1", "b2", "b3")), 2)
+fit <- aov(score ~ A*B)
+cont <- c(1, -1)[A] * c(1, -1, 0)[B]
+sum(cont) # 0
+sum(cont*score) # value of the contrast
+se.contrast(fit, as.matrix(cont))
+(t.stat <- sum(cont*score)/se.contrast(fit, as.matrix(cont)))
+summary(fit, split = list(B = 1:2), expand.split = TRUE)
+## t.stat^2 is the F value on the A:B: C1 line (with Helmert contrasts)
+## Now look at all three interaction contrasts
+cont <- c(1, -1)[A] * cbind(c(1, -1, 0), c(1, 0, -1), c(0, 1, -1))[B,]
+se.contrast(fit, cont) # same, due to balance.
+rm(A, B, score)
+
+
+## multi-stratum example where efficiencies play a role
+utils::example(eff.aovlist)
+fit <- aov(Yield ~ A + B * C + Error(Block), data = aovdat)
+cont1 <- c(-1, 1)[A]/32 # Helmert contrasts
+cont2 <- c(-1, 1)[B] * c(-1, 1)[C]/32
+cont <- cbind(A = cont1, BC = cont2)
+colSums(cont*Yield) # values of the contrasts
+se.contrast(fit, as.matrix(cont))
+
+
+base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
+cleanEx()
+nameEx("selfStart")
+### * selfStart
+
+flush(stderr()); flush(stdout())
+
+### Name: selfStart
+### Title: Construct Self-starting Nonlinear Models
+### Aliases: selfStart selfStart.default selfStart.formula
+### Keywords: models
+
+### ** Examples
+
+## self-starting logistic model
+
+SSlogis <- selfStart(~ Asym/(1 + exp((xmid - x)/scal)),
+ function(mCall, data, LHS)
+ {
+ xy <- sortedXyData(mCall[["x"]], LHS, data)
+ if(nrow(xy) < 4) {
+ stop("Too few distinct x values to fit a logistic")
+ }
+ z <- xy[["y"]]
+ if (min(z) <= 0) { z <- z + 0.05 * max(z) } # avoid zeroes
+ z <- z/(1.05 * max(z)) # scale to within unit height
+ xy[["z"]] <- log(z/(1 - z)) # logit transformation
+ aux <- coef(lm(x ~ z, xy))
+ parameters(xy) <- list(xmid = aux[1], scal = aux[2])
+ pars <- as.vector(coef(nls(y ~ 1/(1 + exp((xmid - x)/scal)),
+ data = xy, algorithm = "plinear")))
+ setNames(c(pars[3], pars[1], pars[2]),
+ mCall[c("Asym", "xmid", "scal")])
+ }, c("Asym", "xmid", "scal"))
+
+# 'first.order.log.model' is a function object defining a first order
+# compartment model
+# 'first.order.log.initial' is a function object which calculates initial
+# values for the parameters in 'first.order.log.model'
+
+# self-starting first order compartment model
+## Not run:
+##D SSfol <- selfStart(first.order.log.model, first.order.log.initial)
+## End(Not run)
+
+## Explore the self-starting models already available in R's "stats":
+pos.st <- which("package:stats" == search())
+mSS <- apropos("^SS..", where = TRUE, ignore.case = FALSE)
+(mSS <- unname(mSS[names(mSS) == pos.st]))
+fSS <- sapply(mSS, get, pos = pos.st, mode = "function")
+all(sapply(fSS, inherits, "selfStart")) # -> TRUE
+
+## Show the argument list of each self-starting function:
+str(fSS, give.attr = FALSE)
+
+
+
+cleanEx()
+nameEx("setNames")
+### * setNames
+
+flush(stderr()); flush(stdout())
+
+### Name: setNames
+### Title: Set the Names in an Object
+### Aliases: setNames
+### Keywords: list
+
+### ** Examples
+
+setNames( 1:3, c("foo", "bar", "baz") )
+# this is just a short form of
+tmp <- 1:3
+names(tmp) <- c("foo", "bar", "baz")
+tmp
+
+## special case of character vector, using default
+setNames(nm = c("First", "2nd"))
+
+
+
+cleanEx()
+nameEx("shapiro.test")
+### * shapiro.test
+
+flush(stderr()); flush(stdout())
+
+### Name: shapiro.test
+### Title: Shapiro-Wilk Normality Test
+### Aliases: shapiro.test
+### Keywords: htest
+
+### ** Examples
+
+shapiro.test(rnorm(100, mean = 5, sd = 3))
+shapiro.test(runif(100, min = 2, max = 4))
+
+
+
+cleanEx()
+nameEx("sigma")
+### * sigma
+
+flush(stderr()); flush(stdout())
+
+### Name: sigma
+### Title: Extract Residual Standard Deviation 'Sigma'
+### Aliases: sigma sigma.default sigma.mlm
+### Keywords: models
+
+### ** Examples
+
+## -- lm() ------------------------------
+lm1 <- lm(Fertility ~ . , data = swiss)
+sigma(lm1) # ~= 7.165 = "Residual standard error" printed from summary(lm1)
+stopifnot(all.equal(sigma(lm1), summary(lm1)$sigma, tol=1e-15))
+
+## -- nls() -----------------------------
+DNase1 <- subset(DNase, Run == 1)
+fm.DN1 <- nls(density ~ SSlogis(log(conc), Asym, xmid, scal), DNase1)
+sigma(fm.DN1) # ~= 0.01919 as from summary(..)
+stopifnot(all.equal(sigma(fm.DN1), summary(fm.DN1)$sigma, tol=1e-15))
+
+## -- glm() -----------------------------
+## -- a) Binomial -- Example from MASS
+ldose <- rep(0:5, 2)
+numdead <- c(1, 4, 9, 13, 18, 20, 0, 2, 6, 10, 12, 16)
+sex <- factor(rep(c("M", "F"), c(6, 6)))
+SF <- cbind(numdead, numalive = 20-numdead)
+sigma(budworm.lg <- glm(SF ~ sex*ldose, family = binomial))
+
+## -- b) Poisson -- from ?glm :
+## Dobson (1990) Page 93: Randomized Controlled Trial :
+counts <- c(18,17,15,20,10,20,25,13,12)
+outcome <- gl(3,1,9)
+treatment <- gl(3,3)
+sigma(glm.D93 <- glm(counts ~ outcome + treatment, family = poisson()))
+## (currently) *differs* from
+summary(glm.D93)$dispersion # == 1
+## and the *Quasi*poisson's dispersion
+sigma(glm.qD93 <- update(glm.D93, family = quasipoisson()))
+sigma (glm.qD93)^2 # 1.282285 is close, but not the same
+summary(glm.qD93)$dispersion # == 1.2933
+
+## -- Multivariate lm() "mlm" -----------
+utils::example("SSD", echo=FALSE)
+sigma(mlmfit) # is the same as {but more efficient than}
+sqrt(diag(estVar(mlmfit)))
+## Don't show:
+stopifnot(all.equal(sigma(mlmfit), sqrt(diag(estVar(mlmfit)))))
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("simulate")
+### * simulate
+
+flush(stderr()); flush(stdout())
+
+### Name: simulate
+### Title: Simulate Responses
+### Aliases: simulate
+### Keywords: models datagen
+
+### ** Examples
+
+x <- 1:5
+mod1 <- lm(c(1:3, 7, 6) ~ x)
+S1 <- simulate(mod1, nsim = 4)
+## repeat the simulation:
+.Random.seed <- attr(S1, "seed")
+identical(S1, simulate(mod1, nsim = 4))
+
+S2 <- simulate(mod1, nsim = 200, seed = 101)
+rowMeans(S2) # should be about the same as
+fitted(mod1)
+
+## repeat identically:
+(sseed <- attr(S2, "seed")) # seed; RNGkind as attribute
+stopifnot(identical(S2, simulate(mod1, nsim = 200, seed = sseed)))
+
+## To be sure about the proper RNGkind, e.g., after
+RNGversion("2.7.0")
+## first set the RNG kind, then simulate
+do.call(RNGkind, attr(sseed, "kind"))
+identical(S2, simulate(mod1, nsim = 200, seed = sseed))
+
+## Binomial GLM examples
+yb1 <- matrix(c(4, 4, 5, 7, 8, 6, 6, 5, 3, 2), ncol = 2)
+modb1 <- glm(yb1 ~ x, family = binomial)
+S3 <- simulate(modb1, nsim = 4)
+# each column of S3 is a two-column matrix.
+
+x2 <- sort(runif(100))
+yb2 <- rbinom(100, prob = plogis(2*(x2-1)), size = 1)
+yb2 <- factor(1 + yb2, labels = c("failure", "success"))
+modb2 <- glm(yb2 ~ x2, family = binomial)
+S4 <- simulate(modb2, nsim = 4)
+# each column of S4 is a factor
+
+
+
+cleanEx()
+nameEx("smooth")
+### * smooth
+
+flush(stderr()); flush(stdout())
+
+### Name: smooth
+### Title: Tukey's (Running Median) Smoothing
+### Aliases: smooth
+### Keywords: robust smooth
+
+### ** Examples
+
+require(graphics)
+
+## see also demo(smooth) !
+
+x1 <- c(4, 1, 3, 6, 6, 4, 1, 6, 2, 4, 2) # very artificial
+(x3R <- smooth(x1, "3R")) # 2 iterations of "3"
+smooth(x3R, kind = "S")
+
+sm.3RS <- function(x, ...)
+ smooth(smooth(x, "3R", ...), "S", ...)
+
+y <- c(1, 1, 19:1)
+plot(y, main = "misbehaviour of \"3RSR\"", col.main = 3)
+lines(sm.3RS(y))
+lines(smooth(y))
+lines(smooth(y, "3RSR"), col = 3, lwd = 2) # the horror
+
+x <- c(8:10, 10, 0, 0, 9, 9)
+plot(x, main = "breakdown of 3R and S and hence 3RSS")
+matlines(cbind(smooth(x, "3R"), smooth(x, "S"), smooth(x, "3RSS"), smooth(x)))
+
+presidents[is.na(presidents)] <- 0 # silly
+summary(sm3 <- smooth(presidents, "3R"))
+summary(sm2 <- smooth(presidents,"3RSS"))
+summary(sm <- smooth(presidents))
+
+all.equal(c(sm2), c(smooth(smooth(sm3, "S"), "S"))) # 3RSS === 3R S S
+all.equal(c(sm), c(smooth(smooth(sm3, "S"), "3R"))) # 3RS3R === 3R S 3R
+
+plot(presidents, main = "smooth(presidents0, *) : 3R and default 3RS3R")
+lines(sm3, col = 3, lwd = 1.5)
+lines(sm, col = 2, lwd = 1.25)
+
+
+
+cleanEx()
+nameEx("smooth.spline")
+### * smooth.spline
+
+flush(stderr()); flush(stdout())
+
+### Name: smooth.spline
+### Title: Fit a Smoothing Spline
+### Aliases: smooth.spline .nknots.smspl
+### Keywords: smooth
+
+### ** Examples
+
+require(graphics)
+plot(dist ~ speed, data = cars, main = "data(cars) & smoothing splines")
+cars.spl <- with(cars, smooth.spline(speed, dist))
+cars.spl
+## This example has duplicate points, so avoid cv = TRUE
+## Don't show:
+ stopifnot(cars.spl $ w == table(cars$speed)) # weights = multiplicities
+ utils::str(cars.spl, digits = 5, vec.len = 6)
+ cars.spl$fit
+## End(Don't show)
+lines(cars.spl, col = "blue")
+ss10 <- smooth.spline(cars[,"speed"], cars[,"dist"], df = 10)
+lines(ss10, lty = 2, col = "red")
+legend(5,120,c(paste("default [C.V.] => df =",round(cars.spl$df,1)),
+ "s( * , df = 10)"), col = c("blue","red"), lty = 1:2,
+ bg = 'bisque')
+
+
+## Residual (Tukey Anscombe) plot:
+plot(residuals(cars.spl) ~ fitted(cars.spl))
+abline(h = 0, col = "gray")
+
+## consistency check:
+stopifnot(all.equal(cars$dist,
+ fitted(cars.spl) + residuals(cars.spl)))
+
+## Visualize the behavior of .nknots.smspl()
+nKnots <- Vectorize(.nknots.smspl) ; c.. <- adjustcolor("gray20",.5)
+curve(nKnots, 1, 250, n=250)
+abline(0,1, lty=2, col=c..); text(90,90,"y = x", col=c.., adj=-.25)
+abline(h=100,lty=2); abline(v=200, lty=2)
+
+n <- c(1:799, seq(800, 3490, by=10), seq(3500, 10000, by = 50))
+plot(n, nKnots(n), type="l", main = "Vectorize(.nknots.smspl) (n)")
+abline(0,1, lty=2, col=c..); text(180,180,"y = x", col=c..)
+n0 <- c(50, 200, 800, 3200); c0 <- adjustcolor("blue3", .5)
+lines(n0, nKnots(n0), type="h", col=c0)
+axis(1, at=n0, line=-2, col.ticks=c0, col=NA, col.axis=c0)
+axis(4, at=.nknots.smspl(10000), line=-.5, col=c..,col.axis=c.., las=1)
+
+##-- artificial example
+y18 <- c(1:3, 5, 4, 7:3, 2*(2:5), rep(10, 4))
+xx <- seq(1, length(y18), len = 201)
+(s2 <- smooth.spline(y18)) # GCV
+(s02 <- smooth.spline(y18, spar = 0.2))
+(s02. <- smooth.spline(y18, spar = 0.2, cv = NA))
+plot(y18, main = deparse(s2$call), col.main = 2)
+lines(s2, col = "gray"); lines(predict(s2, xx), col = 2)
+lines(predict(s02, xx), col = 3); mtext(deparse(s02$call), col = 3)
+
+## Specifying 'lambda' instead of usual spar :
+(s2. <- smooth.spline(y18, lambda = s2$lambda, tol = s2$tol))
+
+## Don't show:
+nD <- c("spar", "ratio", "iparms", "call"); nn <- setdiff(names(s2), nD)
+stopifnot(all.equal(s2[nn], s2.[nn], tol = 7e-7), # seen 6.86e-8
+ all.equal(predict(s02 , xx),
+ predict(s02., xx), tol = 1e-15))
+## End(Don't show)
+
+
+cleanEx()
+nameEx("smoothEnds")
+### * smoothEnds
+
+flush(stderr()); flush(stdout())
+
+### Name: smoothEnds
+### Title: End Points Smoothing (for Running Medians)
+### Aliases: smoothEnds
+### Keywords: smooth robust
+
+### ** Examples
+
+require(graphics)
+
+y <- ys <- (-20:20)^2
+y [c(1,10,21,41)] <- c(100, 30, 400, 470)
+s7k <- runmed(y, 7, endrule = "keep")
+s7. <- runmed(y, 7, endrule = "const")
+s7m <- runmed(y, 7)
+col3 <- c("midnightblue","blue","steelblue")
+plot(y, main = "Running Medians -- runmed(*, k=7, end.rule = X)")
+lines(ys, col = "light gray")
+matlines(cbind(s7k, s7.,s7m), lwd = 1.5, lty = 1, col = col3)
+legend(1, 470, paste("endrule", c("keep","constant","median"), sep = " = "),
+ col = col3, lwd = 1.5, lty = 1)
+
+stopifnot(identical(s7m, smoothEnds(s7k, 7)))
+
+
+
+cleanEx()
+nameEx("sortedXyData")
+### * sortedXyData
+
+flush(stderr()); flush(stdout())
+
+### Name: sortedXyData
+### Title: Create a 'sortedXyData' Object
+### Aliases: sortedXyData sortedXyData.default
+### Keywords: manip
+
+### ** Examples
+
+DNase.2 <- DNase[ DNase$Run == "2", ]
+sortedXyData( expression(log(conc)), expression(density), DNase.2 )
+
+
+
+cleanEx()
+nameEx("spec.ar")
+### * spec.ar
+
+flush(stderr()); flush(stdout())
+
+### Name: spec.ar
+### Title: Estimate Spectral Density of a Time Series from AR Fit
+### Aliases: spec.ar
+### Keywords: ts
+
+### ** Examples
+
+require(graphics)
+
+spec.ar(lh)
+
+spec.ar(ldeaths)
+spec.ar(ldeaths, method = "burg")
+
+spec.ar(log(lynx))
+spec.ar(log(lynx), method = "burg", add = TRUE, col = "purple")
+spec.ar(log(lynx), method = "mle", add = TRUE, col = "forest green")
+spec.ar(log(lynx), method = "ols", add = TRUE, col = "blue")
+
+
+
+cleanEx()
+nameEx("spec.pgram")
+### * spec.pgram
+
+flush(stderr()); flush(stdout())
+
+### Name: spec.pgram
+### Title: Estimate Spectral Density of a Time Series by a Smoothed
+### Periodogram
+### Aliases: spec.pgram
+### Keywords: ts
+
+### ** Examples
+
+require(graphics)
+
+## Examples from Venables & Ripley
+spectrum(ldeaths)
+spectrum(ldeaths, spans = c(3,5))
+spectrum(ldeaths, spans = c(5,7))
+spectrum(mdeaths, spans = c(3,3))
+spectrum(fdeaths, spans = c(3,3))
+
+## bivariate example
+mfdeaths.spc <- spec.pgram(ts.union(mdeaths, fdeaths), spans = c(3,3))
+# plots marginal spectra: now plot coherency and phase
+plot(mfdeaths.spc, plot.type = "coherency")
+plot(mfdeaths.spc, plot.type = "phase")
+
+## now impose a lack of alignment
+mfdeaths.spc <- spec.pgram(ts.intersect(mdeaths, lag(fdeaths, 4)),
+ spans = c(3,3), plot = FALSE)
+plot(mfdeaths.spc, plot.type = "coherency")
+plot(mfdeaths.spc, plot.type = "phase")
+
+stocks.spc <- spectrum(EuStockMarkets, kernel("daniell", c(30,50)),
+ plot = FALSE)
+plot(stocks.spc, plot.type = "marginal") # the default type
+plot(stocks.spc, plot.type = "coherency")
+plot(stocks.spc, plot.type = "phase")
+
+sales.spc <- spectrum(ts.union(BJsales, BJsales.lead),
+ kernel("modified.daniell", c(5,7)))
+plot(sales.spc, plot.type = "coherency")
+plot(sales.spc, plot.type = "phase")
+
+
+
+cleanEx()
+nameEx("spectrum")
+### * spectrum
+
+flush(stderr()); flush(stdout())
+
+### Name: spectrum
+### Title: Spectral Density Estimation
+### Aliases: spectrum spec
+### Keywords: ts
+
+### ** Examples
+
+require(graphics)
+
+## Examples from Venables & Ripley
+## spec.pgram
+par(mfrow = c(2,2))
+spectrum(lh)
+spectrum(lh, spans = 3)
+spectrum(lh, spans = c(3,3))
+spectrum(lh, spans = c(3,5))
+
+spectrum(ldeaths)
+spectrum(ldeaths, spans = c(3,3))
+spectrum(ldeaths, spans = c(3,5))
+spectrum(ldeaths, spans = c(5,7))
+spectrum(ldeaths, spans = c(5,7), log = "dB", ci = 0.8)
+
+# for multivariate examples see the help for spec.pgram
+
+## spec.ar
+spectrum(lh, method = "ar")
+spectrum(ldeaths, method = "ar")
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("splinefun")
+### * splinefun
+
+flush(stderr()); flush(stdout())
+
+### Name: splinefun
+### Title: Interpolating Splines
+### Aliases: spline splinefun splinefunH
+### Keywords: math dplot
+
+### ** Examples
+
+require(graphics)
+
+op <- par(mfrow = c(2,1), mgp = c(2,.8,0), mar = 0.1+c(3,3,3,1))
+n <- 9
+x <- 1:n
+y <- rnorm(n)
+plot(x, y, main = paste("spline[fun](.) through", n, "points"))
+lines(spline(x, y))
+lines(spline(x, y, n = 201), col = 2)
+
+y <- (x-6)^2
+plot(x, y, main = "spline(.) -- 3 methods")
+lines(spline(x, y, n = 201), col = 2)
+lines(spline(x, y, n = 201, method = "natural"), col = 3)
+lines(spline(x, y, n = 201, method = "periodic"), col = 4)
+legend(6, 25, c("fmm","natural","periodic"), col = 2:4, lty = 1)
+
+y <- sin((x-0.5)*pi)
+f <- splinefun(x, y)
+ls(envir = environment(f))
+splinecoef <- get("z", envir = environment(f))
+curve(f(x), 1, 10, col = "green", lwd = 1.5)
+points(splinecoef, col = "purple", cex = 2)
+curve(f(x, deriv = 1), 1, 10, col = 2, lwd = 1.5)
+curve(f(x, deriv = 2), 1, 10, col = 2, lwd = 1.5, n = 401)
+curve(f(x, deriv = 3), 1, 10, col = 2, lwd = 1.5, n = 401)
+par(op)
+
+## Manual spline evaluation --- demo the coefficients :
+.x <- splinecoef$x
+u <- seq(3, 6, by = 0.25)
+(ii <- findInterval(u, .x))
+dx <- u - .x[ii]
+f.u <- with(splinecoef,
+ y[ii] + dx*(b[ii] + dx*(c[ii] + dx* d[ii])))
+stopifnot(all.equal(f(u), f.u))
+
+## An example with ties (non-unique x values):
+set.seed(1); x <- round(rnorm(30), 1); y <- sin(pi * x) + rnorm(30)/10
+plot(x, y, main = "spline(x,y) when x has ties")
+lines(spline(x, y, n = 201), col = 2)
+## visualizes the non-unique ones:
+tx <- table(x); mx <- as.numeric(names(tx[tx > 1]))
+ry <- matrix(unlist(tapply(y, match(x, mx), range, simplify = FALSE)),
+ ncol = 2, byrow = TRUE)
+segments(mx, ry[, 1], mx, ry[, 2], col = "blue", lwd = 2)
+
+## An example of monotone interpolation
+n <- 20
+set.seed(11)
+x. <- sort(runif(n)) ; y. <- cumsum(abs(rnorm(n)))
+plot(x., y.)
+curve(splinefun(x., y.)(x), add = TRUE, col = 2, n = 1001)
+curve(splinefun(x., y., method = "monoH.FC")(x), add = TRUE, col = 3, n = 1001)
+curve(splinefun(x., y., method = "hyman") (x), add = TRUE, col = 4, n = 1001)
+legend("topleft",
+ paste0("splinefun( \"", c("fmm", "monoH.FC", "hyman"), "\" )"),
+ col = 2:4, lty = 1, bty = "n")
+
+## and one from Fritsch and Carlson (1980), Dougherty et al (1989)
+x. <- c(7.09, 8.09, 8.19, 8.7, 9.2, 10, 12, 15, 20)
+f <- c(0, 2.76429e-5, 4.37498e-2, 0.169183, 0.469428, 0.943740,
+ 0.998636, 0.999919, 0.999994)
+s0 <- splinefun(x., f)
+s1 <- splinefun(x., f, method = "monoH.FC")
+s2 <- splinefun(x., f, method = "hyman")
+plot(x., f, ylim = c(-0.2, 1.2))
+curve(s0(x), add = TRUE, col = 2, n = 1001) -> m0
+curve(s1(x), add = TRUE, col = 3, n = 1001)
+curve(s2(x), add = TRUE, col = 4, n = 1001)
+legend("right",
+ paste0("splinefun( \"", c("fmm", "monoH.FC", "hyman"), "\" )"),
+ col = 2:4, lty = 1, bty = "n")
+
+## they seem identical, but are not quite:
+xx <- m0$x
+plot(xx, s1(xx) - s2(xx), type = "l", col = 2, lwd = 2,
+ main = "Difference monoH.FC - hyman"); abline(h = 0, lty = 3)
+
+x <- xx[xx < 10.2] ## full range: x <- xx .. does not show enough
+ccol <- adjustcolor(2:4, 0.8)
+matplot(x, cbind(s0(x, deriv = 2), s1(x, deriv = 2), s2(x, deriv = 2))^2,
+ lwd = 2, col = ccol, type = "l", ylab = quote({{f*second}(x)}^2),
+ main = expression({{f*second}(x)}^2 ~" for the three 'splines'"))
+legend("topright",
+ paste0("splinefun( \"", c("fmm", "monoH.FC", "hyman"), "\" )"),
+ lwd = 2, col = ccol, lty = 1:3, bty = "n")
+## --> "hyman" has slightly smaller Integral f''(x)^2 dx than "FC",
+## here, and both are 'much worse' than the regular fmm spline.
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("stat.anova")
+### * stat.anova
+
+flush(stderr()); flush(stdout())
+
+### Name: stat.anova
+### Title: GLM Anova Statistics
+### Aliases: stat.anova
+### Keywords: regression models
+
+### ** Examples
+
+##-- Continued from '?glm':
+## Don't show:
+utils::example("glm", echo = FALSE)
+## End(Don't show)
+print(ag <- anova(glm.D93))
+stat.anova(ag$table, test = "Cp",
+ scale = sum(resid(glm.D93, "pearson")^2)/4,
+ df.scale = 4, n = 9)
+
+
+
+cleanEx()
+nameEx("step")
+### * step
+
+flush(stderr()); flush(stdout())
+
+### Name: step
+### Title: Choose a model by AIC in a Stepwise Algorithm
+### Aliases: step
+### Keywords: models
+
+### ** Examples
+
+
+cleanEx()
+nameEx("stepfun")
+### * stepfun
+
+flush(stderr()); flush(stdout())
+
+### Name: stepfun
+### Title: Step Functions - Creation and Class
+### Aliases: stepfun is.stepfun as.stepfun print.stepfun summary.stepfun
+### knots
+### Keywords: dplot
+
+### ** Examples
+
+y0 <- c(1., 2., 4., 3.)
+sfun0 <- stepfun(1:3, y0, f = 0)
+sfun.2 <- stepfun(1:3, y0, f = 0.2)
+sfun1 <- stepfun(1:3, y0, f = 1)
+sfun1c <- stepfun(1:3, y0, right = TRUE) # hence f=1
+sfun0
+summary(sfun0)
+summary(sfun.2)
+
+## look at the internal structure:
+unclass(sfun0)
+ls(envir = environment(sfun0))
+
+x0 <- seq(0.5, 3.5, by = 0.25)
+rbind(x = x0, f.f0 = sfun0(x0), f.f02 = sfun.2(x0),
+ f.f1 = sfun1(x0), f.f1c = sfun1c(x0))
+## Identities :
+stopifnot(identical(y0[-1], sfun0 (1:3)), # right = FALSE
+ identical(y0[-4], sfun1c(1:3))) # right = TRUE
+
+
+
+cleanEx()
+nameEx("stl")
+### * stl
+
+flush(stderr()); flush(stdout())
+
+### Name: stl
+### Title: Seasonal Decomposition of Time Series by Loess
+### Aliases: stl
+### Keywords: ts
+
+### ** Examples
+
+require(graphics)
+
+plot(stl(nottem, "per"))
+plot(stl(nottem, s.window = 7, t.window = 50, t.jump = 1))
+
+plot(stllc <- stl(log(co2), s.window = 21))
+summary(stllc)
+## linear trend, strict period.
+plot(stl(log(co2), s.window = "per", t.window = 1000))
+
+## Two STL plotted side by side :
+ stmd <- stl(mdeaths, s.window = "per") # non-robust
+summary(stmR <- stl(mdeaths, s.window = "per", robust = TRUE))
+op <- par(mar = c(0, 4, 0, 3), oma = c(5, 0, 4, 0), mfcol = c(4, 2))
+plot(stmd, set.pars = NULL, labels = NULL,
+ main = "stl(mdeaths, s.w = \"per\", robust = FALSE / TRUE )")
+plot(stmR, set.pars = NULL)
+# mark the 'outliers' :
+(iO <- which(stmR $ weights < 1e-8)) # 10 were considered outliers
+sts <- stmR$time.series
+points(time(sts)[iO], 0.8* sts[,"remainder"][iO], pch = 4, col = "red")
+par(op) # reset
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("summary.aov")
+### * summary.aov
+
+flush(stderr()); flush(stdout())
+
+### Name: summary.aov
+### Title: Summarize an Analysis of Variance Model
+### Aliases: summary.aov summary.aovlist print.summary.aov
+### print.summary.aovlist
+### Keywords: models regression
+
+### ** Examples
+
+## For a simple example see example(aov)
+
+# Cochran and Cox (1957, p.164)
+# 3x3 factorial with ordered factors, each is average of 12.
+CC <- data.frame(
+ y = c(449, 413, 326, 409, 358, 291, 341, 278, 312)/12,
+ P = ordered(gl(3, 3)), N = ordered(gl(3, 1, 9))
+)
+CC.aov <- aov(y ~ N * P, data = CC , weights = rep(12, 9))
+summary(CC.aov)
+
+# Split both main effects into linear and quadratic parts.
+summary(CC.aov, split = list(N = list(L = 1, Q = 2),
+ P = list(L = 1, Q = 2)))
+
+# Split only the interaction
+summary(CC.aov, split = list("N:P" = list(L.L = 1, Q = 2:4)))
+
+# split on just one var
+summary(CC.aov, split = list(P = list(lin = 1, quad = 2)))
+summary(CC.aov, split = list(P = list(lin = 1, quad = 2)),
+ expand.split = FALSE)
+
+
+cleanEx()
+nameEx("summary.glm")
+### * summary.glm
+
+flush(stderr()); flush(stdout())
+
+### Name: summary.glm
+### Title: Summarizing Generalized Linear Model Fits
+### Aliases: summary.glm print.summary.glm
+### Keywords: models regression
+
+### ** Examples
+
+## For examples see example(glm)
+
+
+
+cleanEx()
+nameEx("summary.lm")
+### * summary.lm
+
+flush(stderr()); flush(stdout())
+
+### Name: summary.lm
+### Title: Summarizing Linear Model Fits
+### Aliases: summary.lm summary.mlm print.summary.lm
+### Keywords: regression models
+
+### ** Examples
+
+## Don't show:
+utils::example("lm", echo = FALSE)
+## End(Don't show)
+##-- Continuing the lm(.) example:
+coef(lm.D90) # the bare coefficients
+sld90 <- summary(lm.D90 <- lm(weight ~ group -1)) # omitting intercept
+sld90
+coef(sld90) # much more
+
+## model with *aliased* coefficient:
+lm.D9. <- lm(weight ~ group + I(group != "Ctl"))
+Sm.D9. <- summary(lm.D9.)
+Sm.D9. # shows the NA NA NA NA line
+stopifnot(length(cc <- coef(lm.D9.)) == 3, is.na(cc[3]),
+ dim(coef(Sm.D9.)) == c(2,4), Sm.D9.$df == c(2, 18, 3))
+
+
+
+cleanEx()
+nameEx("summary.manova")
+### * summary.manova
+
+flush(stderr()); flush(stdout())
+
+### Name: summary.manova
+### Title: Summary Method for Multivariate Analysis of Variance
+### Aliases: summary.manova print.summary.manova
+### Keywords: models
+
+### ** Examples
+
+
+cleanEx()
+nameEx("summary.princomp")
+### * summary.princomp
+
+flush(stderr()); flush(stdout())
+
+### Name: summary.princomp
+### Title: Summary method for Principal Components Analysis
+### Aliases: summary.princomp print.summary.princomp
+### Keywords: multivariate
+
+### ** Examples
+
+summary(pc.cr <- princomp(USArrests, cor = TRUE))
+## The signs of the loading columns are arbitrary
+print(summary(princomp(USArrests, cor = TRUE),
+ loadings = TRUE, cutoff = 0.2), digits = 2)
+
+
+
+cleanEx()
+nameEx("supsmu")
+### * supsmu
+
+flush(stderr()); flush(stdout())
+
+### Name: supsmu
+### Title: Friedman's SuperSmoother
+### Aliases: supsmu
+### Keywords: smooth
+
+### ** Examples
+
+require(graphics)
+
+with(cars, {
+ plot(speed, dist)
+ lines(supsmu(speed, dist))
+ lines(supsmu(speed, dist, bass = 7), lty = 2)
+ })
+
+
+
+cleanEx()
+nameEx("symnum")
+### * symnum
+
+flush(stderr()); flush(stdout())
+
+### Name: symnum
+### Title: Symbolic Number Coding
+### Aliases: symnum
+### Keywords: utilities character
+
+### ** Examples
+
+ii <- setNames(0:8, 0:8)
+symnum(ii, cut = 2*(0:4), sym = c(".", "-", "+", "$"))
+symnum(ii, cut = 2*(0:4), sym = c(".", "-", "+", "$"), show.max = TRUE)
+
+symnum(1:12 %% 3 == 0) # --> "|" = TRUE, "." = FALSE for logical
+
+## Pascal's Triangle modulo 2 -- odd and even numbers:
+N <- 38
+pascal <- t(sapply(0:N, function(n) round(choose(n, 0:N - (N-n)%/%2))))
+rownames(pascal) <- rep("", 1+N) # <-- to improve "graphic"
+symnum(pascal %% 2, symbols = c(" ", "A"), numeric = FALSE)
+
+##-- Symbolic correlation matrices:
+symnum(cor(attitude), diag = FALSE)
+symnum(cor(attitude), abbr. = NULL)
+symnum(cor(attitude), abbr. = FALSE)
+symnum(cor(attitude), abbr. = 2)
+
+symnum(cor(rbind(1, rnorm(25), rnorm(25)^2)))
+symnum(cor(matrix(rexp(30, 1), 5, 18))) # <<-- PATTERN ! --
+symnum(cm1 <- cor(matrix(rnorm(90) , 5, 18))) # < White Noise SMALL n
+symnum(cm1, diag = FALSE)
+symnum(cm2 <- cor(matrix(rnorm(900), 50, 18))) # < White Noise "BIG" n
+symnum(cm2, lower = FALSE)
+
+## NA's:
+Cm <- cor(matrix(rnorm(60), 10, 6)); Cm[c(3,6), 2] <- NA
+symnum(Cm, show.max = NULL)
+
+## Graphical P-values (aka "significance stars"):
+pval <- rev(sort(c(outer(1:6, 10^-(1:3)))))
+symp <- symnum(pval, corr = FALSE,
+ cutpoints = c(0, .001,.01,.05, .1, 1),
+ symbols = c("***","**","*","."," "))
+noquote(cbind(P.val = format(pval), Signif = symp))
+
+
+
+cleanEx()
+nameEx("t.test")
+### * t.test
+
+flush(stderr()); flush(stdout())
+
+### Name: t.test
+### Title: Student's t-Test
+### Aliases: t.test t.test.default t.test.formula
+### Keywords: htest
+
+### ** Examples
+
+require(graphics)
+
+t.test(1:10, y = c(7:20)) # P = .00001855
+t.test(1:10, y = c(7:20, 200)) # P = .1245 -- NOT significant anymore
+
+## Classical example: Student's sleep data
+plot(extra ~ group, data = sleep)
+## Traditional interface
+with(sleep, t.test(extra[group == 1], extra[group == 2]))
+## Formula interface
+t.test(extra ~ group, data = sleep)
+
+
+
+cleanEx()
+nameEx("termplot")
+### * termplot
+
+flush(stderr()); flush(stdout())
+
+### Name: termplot
+### Title: Plot Regression Terms
+### Aliases: termplot
+### Keywords: hplot regression
+
+### ** Examples
+
+require(graphics)
+
+had.splines <- "package:splines" %in% search()
+if(!had.splines) rs <- require(splines)
+x <- 1:100
+z <- factor(rep(LETTERS[1:4], 25))
+y <- rnorm(100, sin(x/10)+as.numeric(z))
+model <- glm(y ~ ns(x, 6) + z)
+
+par(mfrow = c(2,2)) ## 2 x 2 plots for same model :
+termplot(model, main = paste("termplot( ", deparse(model$call)," ...)"))
+termplot(model, rug = TRUE)
+termplot(model, partial.resid = TRUE, se = TRUE, main = TRUE)
+termplot(model, partial.resid = TRUE, smooth = panel.smooth, span.smth = 1/4)
+if(!had.splines && rs) detach("package:splines")
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("terms.object")
+### * terms.object
+
+flush(stderr()); flush(stdout())
+
+### Name: terms.object
+### Title: Description of Terms Objects
+### Aliases: terms.object
+### Keywords: models
+
+### ** Examples
+
+## use of specials (as used for gam() in packages mgcv and gam)
+(tf <- terms(y ~ x + x:z + s(x), specials = "s"))
+## Note that the "factors" attribute has variables as row names
+## and term labels as column names, both as character vectors.
+attr(tf, "specials") # index 's' variable(s)
+rownames(attr(tf, "factors"))[attr(tf, "specials")$s]
+
+## we can keep the order by
+terms(y ~ x + x:z + s(x), specials = "s", keep.order = TRUE)
+
+
+
+cleanEx()
+nameEx("time")
+### * time
+
+flush(stderr()); flush(stdout())
+
+### Name: time
+### Title: Sampling Times of Time Series
+### Aliases: time cycle frequency deltat time.default
+### Keywords: ts
+
+### ** Examples
+
+require(graphics)
+
+cycle(presidents)
+# a simple series plot
+plot(as.vector(time(presidents)), as.vector(presidents), type = "l")
+
+
+
+cleanEx()
+nameEx("toeplitz")
+### * toeplitz
+
+flush(stderr()); flush(stdout())
+
+### Name: toeplitz
+### Title: Form Symmetric Toeplitz Matrix
+### Aliases: toeplitz
+### Keywords: ts
+
+### ** Examples
+
+x <- 1:5
+toeplitz (x)
+
+
+
+cleanEx()
+nameEx("ts")
+### * ts
+
+flush(stderr()); flush(stdout())
+
+### Name: ts
+### Title: Time-Series Objects
+### Aliases: ts as.ts as.ts.default is.ts Ops.ts cbind.ts is.mts [.ts t.ts
+### Keywords: ts
+
+### ** Examples
+
+require(graphics)
+
+ts(1:10, frequency = 4, start = c(1959, 2)) # 2nd Quarter of 1959
+print( ts(1:10, frequency = 7, start = c(12, 2)), calendar = TRUE)
+# print.ts(.)
+## Using July 1954 as start date:
+gnp <- ts(cumsum(1 + round(rnorm(100), 2)),
+ start = c(1954, 7), frequency = 12)
+plot(gnp) # using 'plot.ts' for time-series plot
+
+## Multivariate
+z <- ts(matrix(rnorm(300), 100, 3), start = c(1961, 1), frequency = 12)
+class(z)
+head(z) # as "matrix"
+plot(z)
+plot(z, plot.type = "single", lty = 1:3)
+
+## A phase plot:
+plot(nhtemp, lag(nhtemp, 1), cex = .8, col = "blue",
+ main = "Lag plot of New Haven temperatures")
+
+
+
+cleanEx()
+nameEx("ts.plot")
+### * ts.plot
+
+flush(stderr()); flush(stdout())
+
+### Name: ts.plot
+### Title: Plot Multiple Time Series
+### Aliases: ts.plot
+### Keywords: ts
+
+### ** Examples
+
+require(graphics)
+
+ts.plot(ldeaths, mdeaths, fdeaths,
+ gpars=list(xlab="year", ylab="deaths", lty=c(1:3)))
+
+
+
+cleanEx()
+nameEx("ts.union")
+### * ts.union
+
+flush(stderr()); flush(stdout())
+
+### Name: ts.union
+### Title: Bind Two or More Time Series
+### Aliases: ts.union ts.intersect
+### Keywords: ts
+
+### ** Examples
+
+ts.union(mdeaths, fdeaths)
+cbind(mdeaths, fdeaths) # same as the previous line
+ts.intersect(window(mdeaths, 1976), window(fdeaths, 1974, 1978))
+
+sales1 <- ts.union(BJsales, lead = BJsales.lead)
+ts.intersect(sales1, lead3 = lag(BJsales.lead, -3))
+
+
+
+cleanEx()
+nameEx("tsdiag")
+### * tsdiag
+
+flush(stderr()); flush(stdout())
+
+### Name: tsdiag
+### Title: Diagnostic Plots for Time-Series Fits
+### Aliases: tsdiag tsdiag.arima0 tsdiag.Arima tsdiag.StructTS
+### Keywords: ts
+
+### ** Examples
+
+
+
+cleanEx()
+nameEx("uniroot")
+### * uniroot
+
+flush(stderr()); flush(stdout())
+
+### Name: uniroot
+### Title: One Dimensional Root (Zero) Finding
+### Aliases: uniroot
+### Keywords: optimize
+
+### ** Examples
+
+##--- uniroot() with new interval extension + checking features: --------------
+
+f1 <- function(x) (121 - x^2)/(x^2+1)
+f2 <- function(x) exp(-x)*(x - 12)
+
+try(uniroot(f1, c(0,10)))
+try(uniroot(f2, c(0, 2)))
+##--> error: f() .. end points not of opposite sign
+
+## where as 'extendInt="yes"' simply first enlarges the search interval:
+u1 <- uniroot(f1, c(0,10),extendInt="yes", trace=1)
+u2 <- uniroot(f2, c(0,2), extendInt="yes", trace=2)
+stopifnot(all.equal(u1$root, 11, tolerance = 1e-5),
+ all.equal(u2$root, 12, tolerance = 6e-6))
+
+## The *danger* of interval extension:
+## No way to find a zero of a positive function, but
+## numerically, f(-|M|) becomes zero :
+u3 <- uniroot(exp, c(0,2), extendInt="yes", trace=TRUE)
+
+## Nonsense example (must give an error):
+tools::assertCondition( uniroot(function(x) 1, 0:1, extendInt="yes"),
+ "error", verbose=TRUE)
+
+## Convergence checking :
+sinc <- function(x) ifelse(x == 0, 1, sin(x)/x)
+curve(sinc, -6,18); abline(h=0,v=0, lty=3, col=adjustcolor("gray", 0.8))
+## Don't show:
+tools::assertWarning(
+## End(Don't show)
+uniroot(sinc, c(0,5), extendInt="yes", maxiter=4) #-> "just" a warning
+## Don't show:
+ , verbose=TRUE)
+## End(Don't show)
+
+## now with check.conv=TRUE, must signal a convergence error :
+## Don't show:
+tools::assertError(
+## End(Don't show)
+uniroot(sinc, c(0,5), extendInt="yes", maxiter=4, check.conv=TRUE)
+## Don't show:
+ , verbose=TRUE)
+## End(Don't show)
+
+### Weibull cumulative hazard (example origin, Ravi Varadhan):
+cumhaz <- function(t, a, b) b * (t/b)^a
+froot <- function(x, u, a, b) cumhaz(x, a, b) - u
+
+n <- 1000
+u <- -log(runif(n))
+a <- 1/2
+b <- 1
+## Find failure times
+ru <- sapply(u, function(x)
+ uniroot(froot, u=x, a=a, b=b, interval= c(1.e-14, 1e04),
+ extendInt="yes")$root)
+ru2 <- sapply(u, function(x)
+ uniroot(froot, u=x, a=a, b=b, interval= c(0.01, 10),
+ extendInt="yes")$root)
+stopifnot(all.equal(ru, ru2, tolerance = 6e-6))
+
+r1 <- uniroot(froot, u= 0.99, a=a, b=b, interval= c(0.01, 10),
+ extendInt="up")
+stopifnot(all.equal(0.99, cumhaz(r1$root, a=a, b=b)))
+
+## An error if 'extendInt' assumes "wrong zero-crossing direction":
+## Don't show:
+tools::assertError(
+## End(Don't show)
+uniroot(froot, u= 0.99, a=a, b=b, interval= c(0.1, 10), extendInt="down")
+## Don't show:
+ , verbose=TRUE)
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("update")
+### * update
+
+flush(stderr()); flush(stdout())
+
+### Name: update
+### Title: Update and Re-fit a Model Call
+### Aliases: update update.default getCall getCall.default
+### Keywords: models
+
+### ** Examples
+
+oldcon <- options(contrasts = c("contr.treatment", "contr.poly"))
+## Annette Dobson (1990) "An Introduction to Generalized Linear Models".
+## Page 9: Plant Weight Data.
+ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14)
+trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69)
+group <- gl(2, 10, 20, labels = c("Ctl", "Trt"))
+weight <- c(ctl, trt)
+lm.D9 <- lm(weight ~ group)
+lm.D9
+summary(lm.D90 <- update(lm.D9, . ~ . - 1))
+options(contrasts = c("contr.helmert", "contr.poly"))
+update(lm.D9)
+getCall(lm.D90) # "through the origin"
+
+options(oldcon)
+
+
+
+base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
+cleanEx()
+nameEx("update.formula")
+### * update.formula
+
+flush(stderr()); flush(stdout())
+
+### Name: update.formula
+### Title: Model Updating
+### Aliases: update.formula
+### Keywords: models
+
+### ** Examples
+
+update(y ~ x, ~ . + x2) #> y ~ x + x2
+update(y ~ x, log(.) ~ . ) #> log(y) ~ x
+update(. ~ u+v, res ~ . ) #> res ~ u + v
+
+
+
+cleanEx()
+nameEx("var.test")
+### * var.test
+
+flush(stderr()); flush(stdout())
+
+### Name: var.test
+### Title: F Test to Compare Two Variances
+### Aliases: var.test var.test.default var.test.formula
+### Keywords: htest
+
+### ** Examples
+
+x <- rnorm(50, mean = 0, sd = 2)
+y <- rnorm(30, mean = 1, sd = 1)
+var.test(x, y) # Do x and y have the same variance?
+var.test(lm(x ~ 1), lm(y ~ 1)) # The same.
+
+
+
+cleanEx()
+nameEx("varimax")
+### * varimax
+
+flush(stderr()); flush(stdout())
+
+### Name: varimax
+### Title: Rotation Methods for Factor Analysis
+### Aliases: promax varimax
+### Keywords: multivariate
+
+### ** Examples
+
+## varimax with normalize = TRUE is the default
+fa <- factanal( ~., 2, data = swiss)
+varimax(loadings(fa), normalize = FALSE)
+promax(loadings(fa))
+
+
+
+cleanEx()
+nameEx("weighted.mean")
+### * weighted.mean
+
+flush(stderr()); flush(stdout())
+
+### Name: weighted.mean
+### Title: Weighted Arithmetic Mean
+### Aliases: weighted.mean weighted.mean.default
+### Keywords: univar
+
+### ** Examples
+
+## GPA from Siegel 1994
+wt <- c(5, 5, 4, 1)/15
+x <- c(3.7,3.3,3.5,2.8)
+xm <- weighted.mean(x, wt)
+
+
+
+cleanEx()
+nameEx("weighted.residuals")
+### * weighted.residuals
+
+flush(stderr()); flush(stdout())
+
+### Name: weighted.residuals
+### Title: Compute Weighted Residuals
+### Aliases: weighted.residuals
+### Keywords: regression
+
+### ** Examples
+
+## following on from example(lm)
+## Don't show:
+utils::example("lm", echo = FALSE)
+## End(Don't show)
+all.equal(weighted.residuals(lm.D9),
+ residuals(lm.D9))
+x <- 1:10
+w <- 0:9
+y <- rnorm(x)
+weighted.residuals(lmxy <- lm(y ~ x, weights = w))
+weighted.residuals(lmxy, drop0 = FALSE)
+
+
+
+cleanEx()
+nameEx("wilcox.test")
+### * wilcox.test
+
+flush(stderr()); flush(stdout())
+
+### Name: wilcox.test
+### Title: Wilcoxon Rank Sum and Signed Rank Tests
+### Aliases: wilcox.test wilcox.test.default wilcox.test.formula
+### Keywords: htest
+
+### ** Examples
+
+require(graphics)
+## One-sample test.
+## Hollander & Wolfe (1973), 29f.
+## Hamilton depression scale factor measurements in 9 patients with
+## mixed anxiety and depression, taken at the first (x) and second
+## (y) visit after initiation of a therapy (administration of a
+## tranquilizer).
+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)
+wilcox.test(x, y, paired = TRUE, alternative = "greater")
+wilcox.test(y - x, alternative = "less") # The same.
+wilcox.test(y - x, alternative = "less",
+ exact = FALSE, correct = FALSE) # H&W large sample
+ # approximation
+
+## Two-sample test.
+## Hollander & Wolfe (1973), 69f.
+## Permeability constants of the human chorioamnion (a placental
+## membrane) at term (x) and between 12 to 26 weeks gestational
+## age (y). The alternative of interest is greater permeability
+## of the human chorioamnion for the term pregnancy.
+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)
+wilcox.test(x, y, alternative = "g") # greater
+wilcox.test(x, y, alternative = "greater",
+ exact = FALSE, correct = FALSE) # H&W large sample
+ # approximation
+
+wilcox.test(rnorm(10), rnorm(10, 2), conf.int = TRUE)
+
+## Formula interface.
+boxplot(Ozone ~ Month, data = airquality)
+wilcox.test(Ozone ~ Month, data = airquality,
+ subset = Month %in% c(5, 8))
+
+
+
+cleanEx()
+nameEx("window")
+### * window
+
+flush(stderr()); flush(stdout())
+
+### Name: window
+### Title: Time Windows
+### Aliases: window window.default window.ts window<- window<-.ts
+### Keywords: ts
+
+### ** Examples
+
+window(presidents, 1960, c(1969,4)) # values in the 1960's
+window(presidents, deltat = 1) # All Qtr1s
+window(presidents, start = c(1945,3), deltat = 1) # All Qtr3s
+window(presidents, 1944, c(1979,2), extend = TRUE)
+
+pres <- window(presidents, 1945, c(1949,4)) # values in the 1940's
+window(pres, 1945.25, 1945.50) <- c(60, 70)
+window(pres, 1944, 1944.75) <- 0 # will generate a warning
+window(pres, c(1945,4), c(1949,4), frequency = 1) <- 85:89
+pres
+
+
+
+cleanEx()
+nameEx("xtabs")
+### * xtabs
+
+flush(stderr()); flush(stdout())
+
+### Name: xtabs
+### Title: Cross Tabulation
+### Aliases: xtabs print.xtabs
+### Keywords: category
+
+### ** Examples
+
+## 'esoph' has the frequencies of cases and controls for all levels of
+## the variables 'agegp', 'alcgp', and 'tobgp'.
+xtabs(cbind(ncases, ncontrols) ~ ., data = esoph)
+## Output is not really helpful ... flat tables are better:
+ftable(xtabs(cbind(ncases, ncontrols) ~ ., data = esoph))
+## In particular if we have fewer factors ...
+ftable(xtabs(cbind(ncases, ncontrols) ~ agegp, data = esoph))
+
+## This is already a contingency table in array form.
+DF <- as.data.frame(UCBAdmissions)
+## Now 'DF' is a data frame with a grid of the factors and the counts
+## in variable 'Freq'.
+DF
+## Nice for taking margins ...
+xtabs(Freq ~ Gender + Admit, DF)
+## And for testing independence ...
+summary(xtabs(Freq ~ ., DF))
+
+## with NA's
+DN <- DF; DN[cbind(6:9, c(1:2,4,1))] <- NA; DN
+tools::assertError(# 'na.fail' should fail :
+ xtabs(Freq ~ Gender + Admit, DN, na.action=na.fail))
+xtabs(Freq ~ Gender + Admit, DN)
+xtabs(Freq ~ Gender + Admit, DN, na.action = na.pass)
+## The Female:Rejected combination has NA 'Freq' (and NA prints 'invisibly' as "")
+xtabs(Freq ~ Gender + Admit, DN, addNA = TRUE) # ==> count NAs
+
+## Create a nice display for the warp break data.
+warpbreaks$replicate <- rep_len(1:9, 54)
+ftable(xtabs(breaks ~ wool + tension + replicate, data = warpbreaks))
+
+### ---- Sparse Examples ----
+
+
+
+
+cleanEx()
+nameEx("zC")
+### * zC
+
+flush(stderr()); flush(stdout())
+
+### Name: C
+### Title: Sets Contrasts for a Factor
+### Aliases: C
+### Keywords: models
+
+### ** Examples
+
+## reset contrasts to defaults
+options(contrasts = c("contr.treatment", "contr.poly"))
+tens <- with(warpbreaks, C(tension, poly, 1))
+## tension SHOULD be an ordered factor, but as it is not we can use
+aov(breaks ~ wool + tens + tension, data = warpbreaks)
+
+## show the use of ... The default contrast is contr.treatment here
+summary(lm(breaks ~ wool + C(tension, base = 2), data = warpbreaks))
+
+
+# following on from help(esoph)
+model3 <- glm(cbind(ncases, ncontrols) ~ agegp + C(tobgp, , 1) +
+ C(alcgp, , 1), data = esoph, family = binomial())
+summary(model3)
+
+
+
+base::options(contrasts = c(unordered = "contr.treatment",ordered = "contr.poly"))
+### * <FOOTER>
+###
+options(digits = 7L)
+base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n")
+#grDevices::dev.off()
+###
+### Local variables: ***
+### mode: outline-minor ***
+### outline-regexp: "\\(> \\)?### [*]+" ***
+### End: ***
+quit('no')
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/Examples/tools-Ex.R b/com.oracle.truffle.r.native/gnur/tests/src/Examples/tools-Ex.R
new file mode 100644
index 0000000000000000000000000000000000000000..ff484bc1f5a69bf685bb1a2ab7b6e04bb77fb78f
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/Examples/tools-Ex.R
@@ -0,0 +1,751 @@
+pkgname <- "tools"
+source(file.path(R.home("share"), "R", "examples-header.R"))
+options(warn = 1)
+library('tools')
+
+base::assign(".oldSearch", base::search(), pos = 'CheckExEnv')
+cleanEx()
+nameEx("CRANtools")
+### * CRANtools
+
+flush(stderr()); flush(stdout())
+
+### Name: CRANtools
+### Title: CRAN Package Repository Tools
+### Aliases: CRAN_package_db CRAN_check_results CRAN_check_details
+### CRAN_memtest_notes summarize_CRAN_check_status
+
+### ** Examples
+
+
+cleanEx()
+nameEx("HTMLheader")
+### * HTMLheader
+
+flush(stderr()); flush(stdout())
+
+### Name: HTMLheader
+### Title: Generate a standard HTML header for R help
+### Aliases: HTMLheader
+### Keywords: utilities documentation
+
+### ** Examples
+
+cat(HTMLheader("This is a sample header"), sep="\n")
+
+
+
+cleanEx()
+nameEx("Rd2HTML")
+### * Rd2HTML
+
+flush(stderr()); flush(stdout())
+
+### Name: Rd2HTML
+### Title: Rd Converters
+### Aliases: Rd2txt Rd2HTML Rd2ex Rd2latex
+### Keywords: documentation
+
+### ** Examples
+cleanEx()
+nameEx("Rd2txt_options")
+### * Rd2txt_options
+
+flush(stderr()); flush(stdout())
+
+### Name: Rd2txt_options
+### Title: Set formatting options for text help
+### Aliases: Rd2txt_options
+### Keywords: documentation
+
+### ** Examples
+
+
+
+
+cleanEx()
+nameEx("Rdutils")
+### * Rdutils
+
+flush(stderr()); flush(stdout())
+
+### Name: Rdutils
+### Title: Rd Utilities
+### Aliases: Rd_db
+### Keywords: utilities documentation
+
+### ** Examples
+
+
+cleanEx()
+nameEx("assertCondition")
+### * assertCondition
+
+flush(stderr()); flush(stdout())
+
+### Name: assertCondition
+### Title: Asserting Error Conditions
+### Aliases: assertCondition assertWarning assertError
+### Keywords: programming error
+
+### ** Examples
+
+ assertError(sqrt("abc"))
+ assertWarning(matrix(1:8, 4,3))
+
+ assertCondition( ""-1 ) # ok, any condition would satisfy this
+
+try( assertCondition(sqrt(2), "warning") )
+## .. Failed to get warning in evaluating sqrt(2)
+ assertCondition(sqrt("abc"), "error") # ok
+try( assertCondition(sqrt("abc"), "warning") )# -> error: had no warning
+ assertCondition(sqrt("abc"), "error")
+ ## identical to assertError() call above
+
+assertCondition(matrix(1:5, 2,3), "warning")
+try( assertCondition(matrix(1:8, 4,3), "error") )
+## .. Failed to get expected error ....
+
+## either warning or worse:
+assertCondition(matrix(1:8, 4,3), "error","warning") # OK
+assertCondition(matrix(1:8, 4, 3), "warning") # OK
+
+## when both are signalled:
+ff <- function() { warning("my warning"); stop("my error") }
+ assertCondition(ff(), "warning")
+## but assertWarning does not allow an error to follow
+try(assertWarning(ff()))
+ assertCondition(ff(), "error") # ok
+assertCondition(ff(), "error", "warning") # ok (quietly, catching warning)
+
+## assert that assertC..() does not assert [and use *one* argument only]
+assertCondition( assertCondition(sqrt( 2 ), "warning") )
+assertCondition( assertCondition(sqrt("abc"), "warning"), "error")
+assertCondition( assertCondition(matrix(1:8, 4,3), "error"),
+ "error")
+
+
+
+cleanEx()
+nameEx("bibstyle")
+### * bibstyle
+
+flush(stderr()); flush(stdout())
+
+### Name: bibstyle
+### Title: Select or define a bibliography style.
+### Aliases: bibstyle getBibstyle
+### Keywords: utilties documentation
+
+### ** Examples
+
+## Don't show:
+options(useFancyQuotes = FALSE)
+## End(Don't show)
+refs <-
+c(bibentry(bibtype = "manual",
+ title = "R: A Language and Environment for Statistical Computing",
+ author = person("R Core Team"),
+ organization = "R Foundation for Statistical Computing",
+ address = "Vienna, Austria",
+ year = 2013,
+ url = "https://www.R-project.org"),
+ bibentry(bibtype = "article",
+ author = c(person(c("George", "E.", "P."), "Box"),
+ person(c("David", "R."), "Cox")),
+ year = 1964,
+ title = "An Analysis of Transformations",
+ journal = "Journal of the Royal Statistical Society, Series B",
+ volume = 26,
+ pages = "211-252"))
+
+bibstyle("unsorted", sortKeys = function(refs) seq_along(refs),
+ fmtPrefix = function(paper) paste0("[", paper$.index, "]"),
+ .init = TRUE)
+print(refs, .bibstyle = "unsorted")
+
+
+
+cleanEx()
+nameEx("buildVignettes")
+### * buildVignettes
+
+flush(stderr()); flush(stdout())
+
+### Name: buildVignettes
+### Title: List and Build Package Vignettes
+### Aliases: buildVignettes pkgVignettes
+### Keywords: utilities documentation
+
+### ** Examples
+
+gVigns <- pkgVignettes("grid")
+
+
+
+cleanEx()
+nameEx("charsets")
+### * charsets
+
+flush(stderr()); flush(stdout())
+
+### Name: charsets
+### Title: Conversion Tables between Character Sets
+### Aliases: Adobe_glyphs charset_to_Unicode
+### Keywords: datasets
+
+### ** Examples
+
+## find Adobe names for ISOLatin2 chars.
+latin2 <- charset_to_Unicode[, "ISOLatin2"]
+aUnicode <- as.numeric(paste0("0x", Adobe_glyphs$unicode))
+keep <- aUnicode %in% latin2
+aUnicode <- aUnicode[keep]
+aAdobe <- Adobe_glyphs[keep, 1]
+## first match
+aLatin2 <- aAdobe[match(latin2, aUnicode)]
+## all matches
+bLatin2 <- lapply(1:256, function(x) aAdobe[aUnicode == latin2[x]])
+format(bLatin2, justify = "none")
+
+
+
+cleanEx()
+nameEx("checkFF")
+### * checkFF
+
+flush(stderr()); flush(stdout())
+
+### Name: checkFF
+### Title: Check Foreign Function Calls
+### Aliases: checkFF print.checkFF
+### Keywords: programming utilities
+
+### ** Examples
+
+
+cleanEx()
+nameEx("checkPoFiles")
+### * checkPoFiles
+
+flush(stderr()); flush(stdout())
+
+### Name: checkPoFiles
+### Title: Check translation files for inconsistent format strings.
+### Aliases: checkPoFile checkPoFiles
+### Keywords: utilities
+
+### ** Examples
+
+## Not run:
+##D checkPoFiles("de", "/path/to/R/src/directory")
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("checkRdaFiles")
+### * checkRdaFiles
+
+flush(stderr()); flush(stdout())
+
+### Name: checkRdaFiles
+### Title: Report on Details of Saved Images or Re-saves them
+### Aliases: checkRdaFiles resaveRdaFiles
+### Keywords: utilities
+
+### ** Examples
+## Not run:
+##D ## from a package top-level source directory
+##D paths <- sort(Sys.glob(c("data/*.rda", "data/*.RData")))
+##D (res <- checkRdaFiles(paths))
+##D ## pick out some that may need attention
+##D bad <- is.na(res$ASCII) | res$ASCII | (res$size > 1e4 & res$compress == "none")
+##D res[bad, ]
+## End(Not run)
+
+
+cleanEx()
+nameEx("check_packages_in_dir")
+### * check_packages_in_dir
+
+flush(stderr()); flush(stdout())
+
+### Name: check_packages_in_dir
+### Title: Check Source Packages and Their Reverse Dependencies
+### Aliases: check_packages_in_dir summarize_check_packages_in_dir_depends
+### summarize_check_packages_in_dir_results
+### summarize_check_packages_in_dir_timings check_packages_in_dir_changes
+### check_packages_in_dir_details
+### Keywords: utilities
+
+### ** Examples
+
+## Not run:
+##D ## Check packages in dir without reverse dependencies:
+##D check_packages_in_dir(dir)
+##D ## Check packages in dir and their reverse dependencies using the
+##D ## defaults (all repositories in getOption("repos"), all "strong"
+##D ## reverse dependencies, no recursive reverse dependencies):
+##D check_packages_in_dir(dir, reverse = list())
+##D ## Check packages in dir with their reverse dependencies from CRAN,
+##D ## using all strong reverse dependencies and reverse suggests:
+##D check_packages_in_dir(dir,
+##D reverse = list(repos = getOption("repos")["CRAN"],
+##D which = "most"))
+##D ## Check packages in dir with their reverse dependencies from CRAN,
+##D ## using '--as-cran' for the former but not the latter:
+##D check_packages_in_dir(dir,
+##D check_args = c("--as-cran", ""),
+##D reverse = list(repos = getOption("repos")["CRAN"]))
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("delimMatch")
+### * delimMatch
+
+flush(stderr()); flush(stdout())
+
+### Name: delimMatch
+### Title: Delimited Pattern Matching
+### Aliases: delimMatch
+### Keywords: character
+
+### ** Examples
+
+x <- c("\\value{foo}", "function(bar)")
+delimMatch(x)
+delimMatch(x, c("(", ")"))
+
+
+
+cleanEx()
+nameEx("dependsOnPkgs")
+### * dependsOnPkgs
+
+flush(stderr()); flush(stdout())
+
+### Name: dependsOnPkgs
+### Title: Find Reverse Dependencies
+### Aliases: dependsOnPkgs
+### Keywords: utilities
+
+### ** Examples
+
+
+cleanEx()
+nameEx("encoded")
+### * encoded
+
+flush(stderr()); flush(stdout())
+
+### Name: encoded_text_to_latex
+### Title: Translate non-ASCII Text to LaTeX Escapes
+### Aliases: encoded_text_to_latex
+### Keywords: utilities
+
+### ** Examples
+
+x <- "fa\xE7ile"
+encoded_text_to_latex(x, "latin1")
+## Not run:
+##D ## create a tex file to show the upper half of 8-bit charsets
+##D x <- rawToChar(as.raw(160:255), multiple = TRUE)
+##D (x <- matrix(x, ncol = 16, byrow = TRUE))
+##D xx <- x
+##D xx[] <- encoded_text_to_latex(x, "latin1") # or latin2 or latin9
+##D xx <- apply(xx, 1, paste, collapse = "&")
+##D con <- file("test-encoding.tex", "w")
+##D header <- c(
+##D "\\documentclass{article}",
+##D "\\usepackage[T1]{fontenc}",
+##D "\\usepackage{Rd}",
+##D "\\begin{document}",
+##D "\\HeaderA{test}{}{test}",
+##D "\\begin{Details}\relax",
+##D "\\Tabular{cccccccccccccccc}{")
+##D trailer <- c("}", "\\end{Details}", "\\end{document}")
+##D writeLines(header, con)
+##D writeLines(paste0(xx, "\\"), con)
+##D writeLines(trailer, con)
+##D close(con)
+##D ## and some UTF_8 chars
+##D x <- intToUtf8(as.integer(
+##D c(160:383,0x0192,0x02C6,0x02C7,0x02CA,0x02D8,
+##D 0x02D9, 0x02DD, 0x200C, 0x2018, 0x2019, 0x201C,
+##D 0x201D, 0x2020, 0x2022, 0x2026, 0x20AC)),
+##D multiple = TRUE)
+##D x <- matrix(x, ncol = 16, byrow = TRUE)
+##D xx <- x
+##D xx[] <- encoded_text_to_latex(x, "UTF-8")
+##D xx <- apply(xx, 1, paste, collapse = "&")
+##D con <- file("test-utf8.tex", "w")
+##D writeLines(header, con)
+##D writeLines(paste(xx, "\\", sep = ""), con)
+##D writeLines(trailer, con)
+##D close(con)
+## End(Not run)
+
+
+cleanEx()
+nameEx("fileutils")
+### * fileutils
+
+flush(stderr()); flush(stdout())
+
+### Name: fileutils
+### Title: File Utilities
+### Aliases: file_ext file_path_as_absolute file_path_sans_ext
+### list_files_with_exts list_files_with_type
+### Keywords: file
+
+### ** Examples
+
+
+cleanEx()
+nameEx("find_gs_cmd")
+### * find_gs_cmd
+
+flush(stderr()); flush(stdout())
+
+### Name: find_gs_cmd
+### Title: Find a GhostScript Executable
+### Aliases: find_gs_cmd R_GSCMD GSC
+
+### ** Examples
+## Not run:
+##D ## Suppose a Solaris system has GhostScript 9.00 on the path and
+##D ## 9.07 in /opt/csw/bin. Then one might set
+##D Sys.setenv(R_GSCMD = "/opt/csw/bin/gs")
+## End(Not run)
+
+
+cleanEx()
+nameEx("getVignetteInfo")
+### * getVignetteInfo
+
+flush(stderr()); flush(stdout())
+
+### Name: getVignetteInfo
+### Title: Get information on installed vignettes.
+### Aliases: getVignetteInfo
+### Keywords: utilities documentation
+
+### ** Examples
+
+
+
+
+cleanEx()
+nameEx("loadRdMacros")
+### * loadRdMacros
+
+flush(stderr()); flush(stdout())
+
+### Name: loadRdMacros
+### Title: Load user-defined Rd help system macros.
+### Aliases: loadRdMacros loadPkgRdMacros
+### Keywords: utilities documentation
+
+### ** Examples
+
+
+
+
+cleanEx()
+nameEx("makevars")
+### * makevars
+
+flush(stderr()); flush(stdout())
+
+### Name: makevars
+### Title: User and Site Compilation Variables
+### Aliases: makevars_user makevars_site
+### Keywords: utilities
+
+### ** Examples
+## Don't show:
+checkMV <- function(r)
+ stopifnot(is.character(r),
+ length(r) == 0 || (length(r) == 1 && file.exists(r)))
+checkMV(makevars_user())
+checkMV(makevars_site())
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("md5sum")
+### * md5sum
+
+flush(stderr()); flush(stdout())
+
+### Name: md5sum
+### Title: Compute MD5 Checksums
+### Aliases: md5sum
+### Keywords: utilities
+
+### ** Examples
+
+as.vector(md5sum(dir(R.home(), pattern = "^COPY", full.names = TRUE)))
+
+
+
+cleanEx()
+nameEx("package_dependencies")
+### * package_dependencies
+
+flush(stderr()); flush(stdout())
+
+### Name: package_dependencies
+### Title: Computations on the Dependency Hierarchy of Packages
+### Aliases: package_dependencies
+### Keywords: utilities
+
+### ** Examples
+
+
+
+
+cleanEx()
+nameEx("package_native_routine_registration_skeleton")
+### * package_native_routine_registration_skeleton
+
+flush(stderr()); flush(stdout())
+
+### Name: package_native_routine_registration_skeleton
+### Title: Write Skeleton for Adding Native Routine Registration to a
+### Package
+### Aliases: package_native_routine_registration_skeleton
+
+### ** Examples
+## Not run:
+##D ## with a completed splines/DESCRIPTION file,
+##D tools::package_native_routine_registration_skeleton('splines',,,FALSE)
+##D ## produces
+##D #include <R.h>
+##D #include <Rinternals.h>
+##D #include <stdlib.h> // for NULL
+##D #include <R_ext/Rdynload.h>
+##D
+##D /* FIXME:
+##D Check these declarations against the C/Fortran source code.
+##D */
+##D
+##D /* .Call calls */
+##D extern SEXP spline_basis(SEXP, SEXP, SEXP, SEXP);
+##D extern SEXP spline_value(SEXP, SEXP, SEXP, SEXP, SEXP);
+##D
+##D static const R_CallMethodDef CallEntries[] = {
+##D {"spline_basis", (DL_FUNC) &spline_basis, 4},
+##D {"spline_value", (DL_FUNC) &spline_value, 5},
+##D {NULL, NULL, 0}
+##D };
+##D
+##D void R_init_splines(DllInfo *dll)
+##D {
+##D R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
+##D R_useDynamicSymbols(dll, FALSE);
+##D }
+## End(Not run)
+
+
+cleanEx()
+nameEx("parseLatex")
+### * parseLatex
+
+flush(stderr()); flush(stdout())
+
+### Name: parseLatex
+### Title: These experimental functions work with a subset of LaTeX code.
+### Aliases: parseLatex deparseLatex latexToUtf8
+### Keywords: utilities documentation
+
+### ** Examples
+
+
+cleanEx()
+nameEx("print.via.format")
+### * print.via.format
+
+flush(stderr()); flush(stdout())
+
+### Name: .print.via.format
+### Title: Printing Utilities
+### Aliases: .print.via.format
+### Keywords: utilities
+
+### ** Examples
+
+## The function is simply defined as
+ function (x, ...) {
+ writeLines(format(x, ...))
+ invisible(x)
+ }
+
+## is used for simple print methods in R, and as prototype for new methods.
+
+
+
+cleanEx()
+nameEx("pskill")
+### * pskill
+
+flush(stderr()); flush(stdout())
+
+### Name: pskill
+### Title: Kill a Process
+### Aliases: pskill SIGHUP SIGINT SIGQUIT SIGKILL SIGTERM SIGSTOP SIGTSTP
+### SIGCONT SIGCHLD SIGUSR1 SIGUSR2
+### Keywords: utilities
+
+### ** Examples
+## Not run:
+##D pskill(c(237, 245), SIGKILL)
+## End(Not run)
+
+
+cleanEx()
+nameEx("showNonASCII")
+### * showNonASCII
+
+flush(stderr()); flush(stdout())
+
+### Name: showNonASCII
+### Title: Pick Out Non-ASCII Characters
+### Aliases: showNonASCII showNonASCIIfile
+### Keywords: utilities
+
+### ** Examples
+
+out <- c(
+"fa\xE7ile test of showNonASCII():",
+"\\details{",
+" This is a good line",
+" This has an \xfcmlaut in it.",
+" OK again.",
+"}")
+f <- tempfile()
+cat(out, file = f, sep = "\n")
+
+showNonASCIIfile(f)
+unlink(f)
+
+
+
+cleanEx()
+nameEx("toHTML")
+### * toHTML
+
+flush(stderr()); flush(stdout())
+
+### Name: toHTML
+### Title: Display an object in HTML.
+### Aliases: toHTML toHTML.packageIQR toHTML.news_db
+### Keywords: utilities documentation
+
+### ** Examples
+
+cat(toHTML(demo(package = "base")), sep = "\n")
+
+
+
+cleanEx()
+nameEx("undoc")
+### * undoc
+
+flush(stderr()); flush(stdout())
+
+### Name: undoc
+### Title: Find Undocumented Objects
+### Aliases: undoc print.undoc
+### Keywords: documentation
+
+### ** Examples
+
+undoc("tools") # Undocumented objects in 'tools'
+
+
+
+cleanEx()
+nameEx("vignetteDepends")
+### * vignetteDepends
+
+flush(stderr()); flush(stdout())
+
+### Name: vignetteDepends
+### Title: Retrieve Dependency Information for a Vignette
+### Aliases: vignetteDepends
+### Keywords: utilities
+
+### ** Examples
+
+
+cleanEx()
+nameEx("vignetteEngine")
+### * vignetteEngine
+
+flush(stderr()); flush(stdout())
+
+### Name: vignetteEngine
+### Title: Set or Get a Vignette Processing Engine
+### Aliases: vignetteEngine
+### Keywords: utilities documentation
+
+### ** Examples
+
+str(vignetteEngine("Sweave"))
+
+
+
+cleanEx()
+nameEx("writePACKAGES")
+### * writePACKAGES
+
+flush(stderr()); flush(stdout())
+
+### Name: write_PACKAGES
+### Title: Generate PACKAGES files
+### Aliases: write_PACKAGES
+### Keywords: file utilities
+
+### ** Examples
+
+## Not run:
+##D write_PACKAGES("c:/myFolder/myRepository") # on Windows
+##D write_PACKAGES("/pub/RWin/bin/windows/contrib/2.9",
+##D type = "win.binary") # on Linux
+## End(Not run)
+
+
+cleanEx()
+nameEx("xgettext")
+### * xgettext
+
+flush(stderr()); flush(stdout())
+
+### Name: xgettext
+### Title: Extract Translatable Messages from R Files in a Package
+### Aliases: xgettext xngettext xgettext2pot
+### Keywords: utilities
+
+### ** Examples
+## Not run:
+##D ## in a source-directory build of R:
+##D xgettext(file.path(R.home(), "src", "library", "splines"))
+## End(Not run)
+
+
+### * <FOOTER>
+###
+options(digits = 7L)
+base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n")
+#grDevices::dev.off()
+###
+### Local variables: ***
+### mode: outline-minor ***
+### outline-regexp: "\\(> \\)?### [*]+" ***
+### End: ***
+quit('no')
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/Examples/utils-Ex.R b/com.oracle.truffle.r.native/gnur/tests/src/Examples/utils-Ex.R
new file mode 100644
index 0000000000000000000000000000000000000000..2b93341d8b68731e1061322e686da805781f74bb
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/Examples/utils-Ex.R
@@ -0,0 +1,2793 @@
+pkgname <- "utils"
+source(file.path(R.home("share"), "R", "examples-header.R"))
+options(warn = 1)
+library('utils')
+
+base::assign(".oldSearch", base::search(), pos = 'CheckExEnv')
+cleanEx()
+nameEx("LINK")
+### * LINK
+
+flush(stderr()); flush(stdout())
+
+### Name: LINK
+### Title: Create Executable Programs
+### Aliases: LINK
+### Keywords: utilities
+
+### ** Examples
+## Not run:
+##D ## examples of front-ends linked against R.
+##D ## First a C program
+##D CC=`R CMD config CC`
+##D R CMD LINK $CC -o foo foo.o `R CMD config --ldflags`
+##D
+##D ## if Fortran code has been compiled into ForFoo.o
+##D FLIBS=`R CMD config FLIBS`
+##D R CMD LINK $CC -o foo foo.o ForFoo.o `R CMD config --ldflags` $FLIBS
+##D
+##D ## And for a C++ front-end
+##D CXX=`R CMD config CXX`
+##D R CMD COMPILE foo.cc
+##D R CMD LINK $CXX -o foo foo.o `R CMD config --ldflags`
+## End(Not run)
+
+
+cleanEx()
+nameEx("Question")
+### * Question
+
+flush(stderr()); flush(stdout())
+
+### Name: Question
+### Title: Documentation Shortcuts
+### Aliases: Question ?
+### Keywords: documentation
+
+### ** Examples
+
+?lapply
+
+?"for" # but quotes/backticks are needed
+?`+`
+
+?women # information about data set "women"
+
+## Not run:
+##D require(methods)
+##D ## define a S4 generic function and some methods
+##D combo <- function(x, y) c(x, y)
+##D setGeneric("combo")
+##D setMethod("combo", c("numeric", "numeric"), function(x, y) x+y)
+##D
+##D ## assume we have written some documentation
+##D ## for combo, and its methods ....
+##D
+##D ?combo # produces the function documentation
+##D
+##D methods?combo # looks for the overall methods documentation
+##D
+##D method?combo("numeric", "numeric") # documentation for the method above
+##D
+##D ?combo(1:10, rnorm(10)) # ... the same method, selected according to
+##D # the arguments (one integer, the other numeric)
+##D
+##D ?combo(1:10, letters) # documentation for the default method
+## End(Not run)
+
+
+cleanEx()
+nameEx("RShowDoc")
+### * RShowDoc
+
+flush(stderr()); flush(stdout())
+
+### Name: RShowDoc
+### Title: Show R Manuals and Other Documentation
+### Aliases: RShowDoc
+### Keywords: documentation
+
+### ** Examples
+
+
+cleanEx()
+nameEx("RSiteSearch")
+### * RSiteSearch
+
+flush(stderr()); flush(stdout())
+
+### Name: RSiteSearch
+### Title: Search for Key Words or Phrases in Documentation
+### Aliases: RSiteSearch
+### Keywords: utilities documentation
+
+### ** Examples
+
+
+cleanEx()
+nameEx("Rprof")
+### * Rprof
+
+flush(stderr()); flush(stdout())
+
+### Name: Rprof
+### Title: Enable Profiling of R's Execution
+### Aliases: Rprof
+### Keywords: utilities
+
+### ** Examples
+
+## Not run:
+##D Rprof()
+##D ## some code to be profiled
+##D Rprof(NULL)
+##D ## some code NOT to be profiled
+##D Rprof(append = TRUE)
+##D ## some code to be profiled
+##D Rprof(NULL)
+##D ...
+##D ## Now post-process the output as described in Details
+## End(Not run)
+
+
+cleanEx()
+nameEx("Rprofmem")
+### * Rprofmem
+
+flush(stderr()); flush(stdout())
+
+### Name: Rprofmem
+### Title: Enable Profiling of R's Memory Use
+### Aliases: Rprofmem
+### Keywords: utilities
+
+### ** Examples
+## Not run:
+##D ## not supported unless R is compiled to support it.
+##D Rprofmem("Rprofmem.out", threshold = 1000)
+##D example(glm)
+##D Rprofmem(NULL)
+##D noquote(readLines("Rprofmem.out", n = 5))
+## End(Not run)
+
+
+cleanEx()
+nameEx("Rscript")
+### * Rscript
+
+flush(stderr()); flush(stdout())
+
+### Name: Rscript
+### Title: Scripting Front-End for R
+### Aliases: Rscript
+### Keywords: utilities
+
+### ** Examples
+## Not run:
+##D Rscript -e 'date()' -e 'format(Sys.time(), "%a %b %d %X %Y")'
+##D
+##D # Get the same initial packages in the same order as default R:
+##D Rscript --default-packages=methods,datasets,utils,grDevices,graphics,stats -e 'sessionInfo()'
+##D
+##D ## example #! script for a Unix-alike
+##D
+##D #! /path/to/Rscript --vanilla --default-packages=utils
+##D args <- commandArgs(TRUE)
+##D res <- try(install.packages(args))
+##D if(inherits(res, "try-error")) q(status=1) else q()
+##D
+## End(Not run)
+
+
+cleanEx()
+nameEx("Rtangle")
+### * Rtangle
+
+flush(stderr()); flush(stdout())
+
+### Name: Rtangle
+### Title: R Driver for Stangle
+### Aliases: Rtangle RtangleSetup
+### Keywords: utilities
+
+### ** Examples
+
+nmRnw <- "example-1.Rnw"
+exfile <- system.file("Sweave", nmRnw, package = "utils")
+## Create R source file
+Stangle(exfile)
+nmR <- sub("Rnw$", "R", nmRnw) # the (default) R output file name
+if(interactive()) file.show("example-1.R")
+## Don't show:
+file.rename("example-1.R", "example-1_def.R")
+## End(Don't show)
+## Smaller R source file with custom annotation:
+my.Ann <- function(options, chunk, output) {
+ cat("### chunk #", options$chunknr, ": ",
+ if(!is.null(ol <- options$label)) ol else .RtangleCodeLabel(chunk),
+ if(!options$eval) " (eval = FALSE)", "\n",
+ file = output, sep = "")
+}
+Stangle(exfile, annotate = my.Ann)
+if(interactive()) file.show("example-1.R")
+## Don't show:
+file.rename("example-1.R", "example-1_myA.R")
+## End(Don't show)
+Stangle(exfile, annotate = my.Ann, drop.evalFALSE=TRUE)
+if(interactive()) file.show("example-1.R")
+## Don't show:
+file.rename("example-1.R", "example-1_myA-noF.R")
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("SHLIB")
+### * SHLIB
+
+flush(stderr()); flush(stdout())
+
+### Name: SHLIB
+### Title: Build Shared Object/DLL for Dynamic Loading
+### Aliases: SHLIB
+### Keywords: utilities
+
+### ** Examples
+## Not run:
+##D # To link against a library not on the system library paths:
+##D R CMD SHLIB -o mylib.so a.f b.f -L/opt/acml3.5.0/gnu64/lib -lacml
+## End(Not run)
+
+
+cleanEx()
+nameEx("Sweave")
+### * Sweave
+
+flush(stderr()); flush(stdout())
+
+### Name: Sweave
+### Title: Automatic Generation of Reports
+### Aliases: Sweave Stangle SweaveSyntaxLatex SweaveSyntaxNoweb
+### Keywords: utilities
+
+### ** Examples
+
+testfile <- system.file("Sweave", "Sweave-test-1.Rnw", package = "utils")
+
+## enforce par(ask = FALSE)
+options(device.ask.default = FALSE)
+
+## create a LaTeX file
+Sweave(testfile)
+
+## This can be compiled to PDF by
+## tools::texi2pdf("Sweave-test-1.tex")
+## or outside R by
+## R CMD texi2pdf Sweave-test-1.tex
+## which sets the appropriate TEXINPUTS path.
+## create an R source file from the code chunks
+Stangle(testfile)
+## which can be sourced, e.g.
+source("Sweave-test-1.R")
+
+## Don't show:
+if(!interactive()) unlink("Sweave-test-1*")
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("SweaveSyntConv")
+### * SweaveSyntConv
+
+flush(stderr()); flush(stdout())
+
+### Name: SweaveSyntConv
+### Title: Convert Sweave Syntax
+### Aliases: SweaveSyntConv
+### Keywords: utilities
+
+### ** Examples
+
+testfile <- system.file("Sweave", "Sweave-test-1.Rnw", package = "utils")
+
+## convert the file to latex syntax
+SweaveSyntConv(testfile, SweaveSyntaxLatex)
+
+## and run it through Sweave
+Sweave("Sweave-test-1.Stex")
+
+## Don't show:
+if(!interactive()) unlink("Sweave-test-1*")
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("URLencode")
+### * URLencode
+
+flush(stderr()); flush(stdout())
+
+### Name: URLencode
+### Title: Encode or Decode a (partial) URL
+### Aliases: URLencode URLdecode
+### Keywords: utilities
+
+### ** Examples
+
+(y <- URLencode("a url with spaces and / and @"))
+URLdecode(y)
+(y <- URLencode("a url with spaces and / and @", reserved = TRUE))
+URLdecode(y)
+
+URLdecode(z <- "ab%20cd")
+c(URLencode(z), URLencode(z, repeated = TRUE)) # first is usually wanted
+
+
+
+cleanEx()
+nameEx("adist")
+### * adist
+
+flush(stderr()); flush(stdout())
+
+### Name: adist
+### Title: Approximate String Distances
+### Aliases: adist
+### Keywords: character
+
+### ** Examples
+
+## Cf. https://en.wikipedia.org/wiki/Levenshtein_distance
+adist("kitten", "sitting")
+## To see the transformation counts for the Levenshtein distance:
+drop(attr(adist("kitten", "sitting", counts = TRUE), "counts"))
+## To see the transformation sequences:
+attr(adist(c("kitten", "sitting"), counts = TRUE), "trafos")
+
+## Cf. the examples for agrep:
+adist("lasy", "1 lazy 2")
+## For a "partial approximate match" (as used for agrep):
+adist("lasy", "1 lazy 2", partial = TRUE)
+
+
+
+cleanEx()
+nameEx("alarm")
+### * alarm
+
+flush(stderr()); flush(stdout())
+
+### Name: alarm
+### Title: Alert the User
+### Aliases: alarm
+### Keywords: utilities
+
+### ** Examples
+
+alarm()
+
+
+
+cleanEx()
+nameEx("apropos")
+### * apropos
+
+flush(stderr()); flush(stdout())
+
+### Name: apropos
+### Title: Find Objects by (Partial) Name
+### Aliases: apropos find
+### Keywords: data documentation environment
+
+### ** Examples
+
+require(stats)
+
+## Not run: apropos("lm")
+apropos("GLM") # several
+apropos("GLM", ignore.case = FALSE) # not one
+apropos("lq")
+
+cor <- 1:pi
+find("cor") #> ".GlobalEnv" "package:stats"
+find("cor", numeric = TRUE) # numbers with these names
+find("cor", numeric = TRUE, mode = "function") # only the second one
+rm(cor)
+
+## Not run: apropos(".", mode="list") # a long list
+
+# need a DOUBLE backslash '\\' (in case you don't see it anymore)
+apropos("\\[")
+
+
+
+cleanEx()
+nameEx("aregexec")
+### * aregexec
+
+flush(stderr()); flush(stdout())
+
+### Name: aregexec
+### Title: Approximate String Match Positions
+### Aliases: aregexec
+### Keywords: character
+
+### ** Examples
+
+## Cf. the examples for agrep.
+x <- c("1 lazy", "1", "1 LAZY")
+aregexec("laysy", x, max.distance = 2)
+aregexec("(lay)(sy)", x, max.distance = 2)
+aregexec("(lay)(sy)", x, max.distance = 2, ignore.case = TRUE)
+m <- aregexec("(lay)(sy)", x, max.distance = 2)
+regmatches(x, m)
+
+
+
+cleanEx()
+nameEx("aspell")
+### * aspell
+
+flush(stderr()); flush(stdout())
+
+### Name: aspell
+### Title: Spell Check Interface
+### Aliases: aspell
+### Keywords: utilities
+
+### ** Examples
+
+## Not run:
+##D ## To check all Rd files in a directory, (additionally) skipping the
+##D ## \references sections.
+##D files <- Sys.glob("*.Rd")
+##D aspell(files, filter = list("Rd", drop = "\\references"))
+##D
+##D ## To check all Sweave files
+##D files <- Sys.glob(c("*.Rnw", "*.Snw", "*.rnw", "*.snw"))
+##D aspell(files, filter = "Sweave", control = "-t")
+##D
+##D ## To check all Texinfo files (Aspell only)
+##D files <- Sys.glob("*.texi")
+##D aspell(files, control = "--mode=texinfo")
+## End(Not run)
+
+## List the available R system dictionaries.
+Sys.glob(file.path(R.home("share"), "dictionaries", "*.rds"))
+
+
+
+cleanEx()
+nameEx("available.packages")
+### * available.packages
+
+flush(stderr()); flush(stdout())
+
+### Name: available.packages
+### Title: List Available Packages at CRAN-like Repositories
+### Aliases: available.packages
+### Keywords: utilities
+
+### ** Examples
+## Not run:
+##D ## Restrict install.packages() (etc) to known-to-be-FOSS packages
+##D options(available_packages_filters =
+##D c("R_version", "OS_type", "subarch", "duplicates", "license/FOSS"))
+##D ## or
+##D options(available_packages_filters = list(add = TRUE, "license/FOSS"))
+##D
+##D ## Give priority to released versions on CRAN, rather than development
+##D ## versions on Omegahat, R-Forge etc.
+##D options(available_packages_filters =
+##D c("R_version", "OS_type", "subarch", "CRAN", "duplicates"))
+## End(Not run)
+
+
+cleanEx()
+nameEx("bibentry")
+### * bibentry
+
+flush(stderr()); flush(stdout())
+
+### Name: bibentry
+### Title: Bibliography Entries
+### Aliases: bibentry print.bibentry format.bibentry sort.bibentry
+### print.citation format.citation
+### Keywords: utilities documentation
+
+### ** Examples
+
+## R reference
+rref <- bibentry(
+ bibtype = "Manual",
+ title = "R: A Language and Environment for Statistical Computing",
+ author = person("R Core Team"),
+ organization = "R Foundation for Statistical Computing",
+ address = "Vienna, Austria",
+ year = 2014,
+ url = "https://www.R-project.org/")
+
+## Different printing styles
+print(rref)
+print(rref, style = "Bibtex")
+print(rref, style = "citation")
+print(rref, style = "html")
+print(rref, style = "latex")
+print(rref, style = "R")
+
+## References for boot package and associated book
+bref <- c(
+ bibentry(
+ bibtype = "Manual",
+ title = "boot: Bootstrap R (S-PLUS) Functions",
+ author = c(
+ person("Angelo", "Canty", role = "aut",
+ comment = "S original"),
+ person(c("Brian", "D."), "Ripley", role = c("aut", "trl", "cre"),
+ comment = "R port, author of parallel support",
+ email = "ripley@stats.ox.ac.uk")
+ ),
+ year = "2012",
+ note = "R package version 1.3-4",
+ url = "https://CRAN.R-project.org/package=boot",
+ key = "boot-package"
+ ),
+
+ bibentry(
+ bibtype = "Book",
+ title = "Bootstrap Methods and Their Applications",
+ author = as.person("Anthony C. Davison [aut], David V. Hinkley [aut]"),
+ year = "1997",
+ publisher = "Cambridge University Press",
+ address = "Cambridge",
+ isbn = "0-521-57391-2",
+ url = "http://statwww.epfl.ch/davison/BMA/",
+ key = "boot-book"
+ )
+)
+
+## Combining and subsetting
+c(rref, bref)
+bref[2]
+bref["boot-book"]
+
+## Extracting fields
+bref$author
+bref[1]$author
+bref[1]$author[2]$email
+
+## Convert to BibTeX
+toBibtex(bref)
+
+## Format in R style
+## One bibentry() call for each bibentry:
+writeLines(paste(format(bref, "R"), collapse = "\n\n"))
+## One collapsed call:
+writeLines(format(bref, "R", collapse = TRUE))
+
+
+
+cleanEx()
+nameEx("browseEnv")
+### * browseEnv
+
+flush(stderr()); flush(stdout())
+
+### Name: browseEnv
+### Title: Browse Objects in Environment
+### Aliases: browseEnv wsbrowser
+### Keywords: interface
+
+### ** Examples
+
+if(interactive()) {
+ ## create some interesting objects :
+ ofa <- ordered(4:1)
+ ex1 <- expression(1+ 0:9)
+ ex3 <- expression(u, v, 1+ 0:9)
+ example(factor, echo = FALSE)
+ example(table, echo = FALSE)
+ example(ftable, echo = FALSE)
+ example(lm, echo = FALSE, ask = FALSE)
+ example(str, echo = FALSE)
+
+ ## and browse them:
+ browseEnv()
+
+ ## a (simple) function's environment:
+ af12 <- approxfun(1:2, 1:2, method = "const")
+ browseEnv(envir = environment(af12))
+ }
+
+
+
+cleanEx()
+nameEx("browseURL")
+### * browseURL
+
+flush(stderr()); flush(stdout())
+
+### Name: browseURL
+### Title: Load URL into an HTML Browser
+### Aliases: browseURL
+### Keywords: file
+
+### ** Examples
+
+## Not run:
+##D ## for KDE users who want to open files in a new tab
+##D options(browser = "kfmclient newTab")
+##D browseURL("https://www.r-project.org")
+## End(Not run)
+
+
+cleanEx()
+nameEx("browseVignettes")
+### * browseVignettes
+
+flush(stderr()); flush(stdout())
+
+### Name: browseVignettes
+### Title: List Vignettes in an HTML Browser
+### Aliases: browseVignettes print.browseVignettes
+### Keywords: documentation
+
+### ** Examples
+
+
+cleanEx()
+nameEx("capture.output")
+### * capture.output
+
+flush(stderr()); flush(stdout())
+
+### Name: capture.output
+### Title: Send Output to a Character String or File
+### Aliases: capture.output
+### Keywords: utilities
+
+### ** Examples
+
+require(stats)
+glmout <- capture.output(summary(glm(case ~ spontaneous+induced,
+ data = infert, family = binomial())))
+glmout[1:5]
+capture.output(1+1, 2+2)
+capture.output({1+1; 2+2})
+
+## Not run:
+##D ## on Unix-alike with a2ps available##D
+##D op <- options(useFancyQuotes=FALSE)
+##D pdf <- pipe("a2ps -o - | ps2pdf - tempout.pdf", "w")
+##D capture.output(example(glm), file = pdf)
+##D close(pdf); options(op) ; system("evince tempout.pdf &")
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("changedFiles")
+### * changedFiles
+
+flush(stderr()); flush(stdout())
+
+### Name: changedFiles
+### Title: Detect which files have changed
+### Aliases: fileSnapshot changedFiles print.changedFiles
+### print.fileSnapshot
+### Keywords: utilities file
+
+### ** Examples
+
+# Create some files in a temporary directory
+dir <- tempfile()
+dir.create(dir)
+writeBin(1L, file.path(dir, "file1"))
+writeBin(2L, file.path(dir, "file2"))
+dir.create(file.path(dir, "dir"))
+
+# Take a snapshot
+snapshot <- fileSnapshot(dir, timestamp = tempfile("timestamp"), md5sum=TRUE)
+
+# Change one of the files.
+writeBin(3L:4L, file.path(dir, "file2"))
+
+# Display the detected changes. We may or may not see mtime change...
+changedFiles(snapshot)
+changedFiles(snapshot)$changes
+
+
+
+cleanEx()
+nameEx("citation")
+### * citation
+
+flush(stderr()); flush(stdout())
+
+### Name: citation
+### Title: Citing R and R Packages in Publications
+### Aliases: CITATION citation readCitationFile
+### Keywords: misc
+
+### ** Examples
+
+## the basic R reference
+citation()
+
+## references for a package -- might not have these installed
+if(nchar(system.file(package = "lattice"))) citation("lattice")
+if(nchar(system.file(package = "foreign"))) citation("foreign")
+
+## extract the bibtex entry from the return value
+x <- citation()
+toBibtex(x)
+
+
+
+
+cleanEx()
+nameEx("cite")
+### * cite
+
+flush(stderr()); flush(stdout())
+
+### Name: cite
+### Title: Cite a bibliography entry.
+### Aliases: cite citeNatbib
+### Keywords: utilities documentation
+
+### ** Examples
+
+## R reference
+rref <- bibentry(
+ bibtype = "Manual",
+ title = "R: A Language and Environment for Statistical Computing",
+ author = person("R Core Team"),
+ organization = "R Foundation for Statistical Computing",
+ address = "Vienna, Austria",
+ year = 2013,
+ url = "https://www.R-project.org/",
+ key = "R")
+
+## References for boot package and associated book
+bref <- c(
+ bibentry(
+ bibtype = "Manual",
+ title = "boot: Bootstrap R (S-PLUS) Functions",
+ author = c(
+ person("Angelo", "Canty", role = "aut",
+ comment = "S original"),
+ person(c("Brian", "D."), "Ripley", role = c("aut", "trl", "cre"),
+ comment = "R port, author of parallel support",
+ email = "ripley@stats.ox.ac.uk")
+ ),
+ year = "2012",
+ note = "R package version 1.3-4",
+ url = "https://CRAN.R-project.org/package=boot",
+ key = "boot-package"
+ ),
+
+ bibentry(
+ bibtype = "Book",
+ title = "Bootstrap Methods and Their Applications",
+ author = as.person("Anthony C. Davison [aut], David V. Hinkley [aut]"),
+ year = "1997",
+ publisher = "Cambridge University Press",
+ address = "Cambridge",
+ isbn = "0-521-57391-2",
+ url = "http://statwww.epfl.ch/davison/BMA/",
+ key = "boot-book"
+ )
+)
+
+## Combine and cite
+refs <- c(rref, bref)
+cite("R, boot-package", refs)
+
+## Cite numerically
+savestyle <- tools::getBibstyle()
+tools::bibstyle("JSSnumbered", .init = TRUE,
+ fmtPrefix = function(paper) paste0("[", paper$.index, "]"),
+ cite = function(key, bib, ...)
+ citeNatbib(key, bib, mode = "numbers",
+ bibpunct = c("[", "]", ";", "n", "", ","), ...)
+ )
+cite("R, boot-package", refs, textual = TRUE)
+refs
+
+## restore the old style
+tools::bibstyle(savestyle, .default = TRUE)
+
+
+
+cleanEx()
+nameEx("combn")
+### * combn
+
+flush(stderr()); flush(stdout())
+
+### Name: combn
+### Title: Generate All Combinations of n Elements, Taken m at a Time
+### Aliases: combn
+### Keywords: utilities iteration
+
+### ** Examples
+
+combn(letters[1:4], 2)
+(m <- combn(10, 5, min)) # minimum value in each combination
+mm <- combn(15, 6, function(x) matrix(x, 2, 3))
+stopifnot(round(choose(10, 5)) == length(m),
+ c(2,3, round(choose(15, 6))) == dim(mm))
+
+## Different way of encoding points:
+combn(c(1,1,1,1,2,2,2,3,3,4), 3, tabulate, nbins = 4)
+
+## Compute support points and (scaled) probabilities for a
+## Multivariate-Hypergeometric(n = 3, N = c(4,3,2,1)) p.f.:
+# table.mat(t(combn(c(1,1,1,1,2,2,2,3,3,4), 3, tabulate, nbins = 4)))
+
+## Assuring the identity
+for(n in 1:7)
+ for(m in 0:n) stopifnot(is.array(cc <- combn(n, m)),
+ dim(cc) == c(m, choose(n, m)))
+
+
+
+cleanEx()
+nameEx("compareVersion")
+### * compareVersion
+
+flush(stderr()); flush(stdout())
+
+### Name: compareVersion
+### Title: Compare Two Package Version Numbers
+### Aliases: compareVersion
+### Keywords: utilities
+
+### ** Examples
+
+compareVersion("1.0", "1.0-1")
+compareVersion("7.2-0","7.1-12")
+
+
+
+cleanEx()
+nameEx("count.fields")
+### * count.fields
+
+flush(stderr()); flush(stdout())
+
+### Name: count.fields
+### Title: Count the Number of Fields per Line
+### Aliases: count.fields
+### Keywords: file
+
+### ** Examples
+
+cat("NAME", "1:John", "2:Paul", file = "foo", sep = "\n")
+count.fields("foo", sep = ":")
+unlink("foo")
+
+
+
+cleanEx()
+nameEx("data")
+### * data
+
+flush(stderr()); flush(stdout())
+
+### Name: data
+### Title: Data Sets
+### Aliases: data print.packageIQR
+### Keywords: documentation datasets
+
+### ** Examples
+
+require(utils)
+data() # list all available data sets
+try(data(package = "rpart") ) # list the data sets in the rpart package
+data(USArrests, "VADeaths") # load the data sets 'USArrests' and 'VADeaths'
+## Not run:
+##D ## Alternatively
+##D ds <- c("USArrests", "VADeaths"); data(list = ds)
+## End(Not run)
+help(USArrests) # give information on data set 'USArrests'
+
+
+
+cleanEx()
+nameEx("dataentry")
+### * dataentry
+
+flush(stderr()); flush(stdout())
+
+### Name: dataentry
+### Title: Spreadsheet Interface for Entering Data
+### Aliases: data.entry dataentry de de.ncols de.restore de.setup
+### Keywords: utilities file
+
+### ** Examples
+
+# call data entry with variables x and y
+## Not run: data.entry(x, y)
+
+
+
+cleanEx()
+nameEx("debugcall")
+### * debugcall
+
+flush(stderr()); flush(stdout())
+
+### Name: debugcall
+### Title: Debug a Call
+### Aliases: debugcall undebugcall
+### Keywords: programming environment utilities
+
+### ** Examples
+
+## Not run:
+##D ## Evaluate call after setting debugging
+##D ##
+##D f <- factor(1:10)
+##D res <- eval(debugcall(summary(f)))
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("debugger")
+### * debugger
+
+flush(stderr()); flush(stdout())
+
+### Name: debugger
+### Title: Post-Mortem Debugging
+### Aliases: debugger dump.frames
+### Keywords: utilities error
+
+### ** Examples
+
+## Not run:
+##D options(error = quote(dump.frames("testdump", TRUE)))
+##D
+##D f <- function() {
+##D g <- function() stop("test dump.frames")
+##D g()
+##D }
+##D f() # will generate a dump on file "testdump.rda"
+##D options(error = NULL)
+##D
+##D ## possibly in another R session
+##D load("testdump.rda")
+##D debugger(testdump)
+##D Available environments had calls:
+##D 1: f()
+##D 2: g()
+##D 3: stop("test dump.frames")
+##D
+##D Enter an environment number, or 0 to exit
+##D Selection: 1
+##D Browsing in the environment with call:
+##D f()
+##D Called from: debugger.look(ind)
+##D Browse[1]> ls()
+##D [1] "g"
+##D Browse[1]> g
+##D function() stop("test dump.frames")
+##D <environment: 759818>
+##D Browse[1]>
+##D Available environments had calls:
+##D 1: f()
+##D 2: g()
+##D 3: stop("test dump.frames")
+##D
+##D Enter an environment number, or 0 to exit
+##D Selection: 0
+##D
+##D ## A possible setting for non-interactive sessions
+##D options(error = quote({dump.frames(to.file = TRUE); q(status = 1)}))
+## End(Not run)
+
+
+cleanEx()
+nameEx("demo")
+### * demo
+
+flush(stderr()); flush(stdout())
+
+### Name: demo
+### Title: Demonstrations of R Functionality
+### Aliases: demo
+### Keywords: documentation utilities
+
+### ** Examples
+
+demo() # for attached packages
+
+## All available demos:
+demo(package = .packages(all.available = TRUE))
+
+
+## Not run:
+##D ch <- "scoping"
+##D demo(ch, character = TRUE)
+## End(Not run)
+
+## Find the location of a demo
+system.file("demo", "lm.glm.R", package = "stats")
+
+
+
+cleanEx()
+nameEx("edit")
+### * edit
+
+flush(stderr()); flush(stdout())
+
+### Name: edit
+### Title: Invoke a Text Editor
+### Aliases: edit edit.default vi emacs pico xemacs xedit
+### Keywords: utilities
+
+### ** Examples
+
+## Not run:
+##D # use xedit on the function mean and assign the changes
+##D mean <- edit(mean, editor = "xedit")
+##D
+##D # use vi on mean and write the result to file mean.out
+##D vi(mean, file = "mean.out")
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("edit.data.frame")
+### * edit.data.frame
+
+flush(stderr()); flush(stdout())
+
+### Name: edit.data.frame
+### Title: Edit Data Frames and Matrices
+### Aliases: edit.data.frame edit.matrix
+### Keywords: utilities
+
+### ** Examples
+
+## Not run:
+##D edit(InsectSprays)
+##D edit(InsectSprays, factor.mode = "numeric")
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("example")
+### * example
+
+flush(stderr()); flush(stdout())
+
+### Name: example
+### Title: Run an Examples Section from the Online Help
+### Aliases: example
+### Keywords: documentation utilities
+
+### ** Examples
+
+example(InsectSprays)
+## force use of the standard package 'stats':
+example("smooth", package = "stats", lib.loc = .Library)
+
+## set RNG *before* example as when R CMD check is run:
+
+r1 <- example(quantile, setRNG = TRUE)
+x1 <- rnorm(1)
+u <- runif(1)
+## identical random numbers
+r2 <- example(quantile, setRNG = TRUE)
+x2 <- rnorm(1)
+stopifnot(identical(r1, r2))
+## but x1 and x2 differ since the RNG state from before example()
+## differs and is restored!
+x1; x2
+
+## Exploring examples code:
+## How large are the examples of "lm...()" functions?
+lmex <- sapply(apropos("^lm", mode = "function"),
+ example, character.only = TRUE, give.lines = TRUE)
+sapply(lmex, length)
+
+
+
+cleanEx()
+nameEx("file.edit")
+### * file.edit
+
+flush(stderr()); flush(stdout())
+
+### Name: file.edit
+### Title: Edit One or More Files
+### Aliases: file.edit
+### Keywords: utilities
+
+### ** Examples
+
+## Not run:
+##D # open two R scripts for editing
+##D file.edit("script1.R", "script2.R")
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("filetest")
+### * filetest
+
+flush(stderr()); flush(stdout())
+
+### Name: file_test
+### Title: Shell-style Tests on Files
+### Aliases: file_test
+### Keywords: file
+
+### ** Examples
+
+dir <- file.path(R.home(), "library", "stats")
+file_test("-d", dir)
+file_test("-nt", file.path(dir, "R"), file.path(dir, "demo"))
+
+
+
+cleanEx()
+nameEx("findLineNum")
+### * findLineNum
+
+flush(stderr()); flush(stdout())
+
+### Name: findLineNum
+### Title: Find the Location of a Line of Source Code, or Set a Breakpoint
+### There.
+### Aliases: findLineNum setBreakpoint
+### Keywords: debugging
+
+### ** Examples
+
+## Not run:
+##D # Find what function was defined in the file mysource.R at line 100:
+##D findLineNum("mysource.R#100")
+##D
+##D # Set a breakpoint in both copies of that function, assuming one is in the
+##D # same namespace as myfunction and the other is on the search path
+##D setBreakpoint("mysource.R#100", envir = myfunction)
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("fix")
+### * fix
+
+flush(stderr()); flush(stdout())
+
+### Name: fix
+### Title: Fix an Object
+### Aliases: fix
+### Keywords: utilities
+
+### ** Examples
+
+## Not run:
+##D ## Assume 'my.fun' is a user defined function :
+##D fix(my.fun)
+##D ## now my.fun is changed
+##D ## Also,
+##D fix(my.data.frame) # calls up data editor
+##D fix(my.data.frame, factor.mode="char") # use of ...
+## End(Not run)
+
+
+cleanEx()
+nameEx("format")
+### * format
+
+flush(stderr()); flush(stdout())
+
+### Name: format
+### Title: Format Unordered and Ordered Lists
+### Aliases: formatUL formatOL
+### Keywords: print
+
+### ** Examples
+
+## A simpler recipe.
+x <- c("Mix dry ingredients thoroughly.",
+ "Pour in wet ingredients.",
+ "Mix for 10 minutes.",
+ "Bake for one hour at 300 degrees.")
+## Format and output as an unordered list.
+writeLines(formatUL(x))
+## Format and output as an ordered list.
+writeLines(formatOL(x))
+## Ordered list using lower case roman numerals.
+writeLines(formatOL(x, type = "i"))
+## Ordered list using upper case letters and some offset.
+writeLines(formatOL(x, type = "A", offset = 5))
+
+
+
+cleanEx()
+nameEx("getAnywhere")
+### * getAnywhere
+
+flush(stderr()); flush(stdout())
+
+### Name: getAnywhere
+### Title: Retrieve an R Object, Including from a Namespace
+### Aliases: getAnywhere argsAnywhere [.getAnywhere print.getAnywhere
+### Keywords: data
+
+### ** Examples
+
+getAnywhere("format.dist")
+getAnywhere("simpleLoess") # not exported from stats
+argsAnywhere(format.dist)
+
+
+
+cleanEx()
+nameEx("getFromNamespace")
+### * getFromNamespace
+
+flush(stderr()); flush(stdout())
+
+### Name: getFromNamespace
+### Title: Utility functions for Developing Namespaces
+### Aliases: assignInNamespace assignInMyNamespace getFromNamespace
+### fixInNamespace
+### Keywords: data
+
+### ** Examples
+
+getFromNamespace("findGeneric", "utils")
+## Not run:
+##D fixInNamespace("predict.ppr", "stats")
+##D stats:::predict.ppr
+##D getS3method("predict", "ppr")
+##D ## alternatively
+##D fixInNamespace("predict.ppr", pos = 3)
+##D fixInNamespace("predict.ppr", pos = "package:stats")
+## End(Not run)
+
+
+cleanEx()
+nameEx("getParseData")
+### * getParseData
+
+flush(stderr()); flush(stdout())
+
+### Name: getParseData
+### Title: Get detailed parse information from object.
+### Aliases: getParseData getParseText
+### Keywords: utilities
+
+### ** Examples
+
+fn <- function(x) {
+ x + 1 # A comment, kept as part of the source
+}
+
+d <- getParseData(fn)
+if (!is.null(d)) {
+ plus <- which(d$token == "'+'")
+ sum <- d$parent[plus]
+ print(d[as.character(sum),])
+ print(getParseText(d, sum))
+}
+
+
+
+cleanEx()
+nameEx("getS3method")
+### * getS3method
+
+flush(stderr()); flush(stdout())
+
+### Name: getS3method
+### Title: Get an S3 Method
+### Aliases: getS3method
+### Keywords: data methods
+
+### ** Examples
+
+require(stats)
+exists("predict.ppr") # false
+getS3method("predict", "ppr")
+
+
+
+cleanEx()
+nameEx("glob2rx")
+### * glob2rx
+
+flush(stderr()); flush(stdout())
+
+### Name: glob2rx
+### Title: Change Wildcard or Globbing Pattern into Regular Expression
+### Aliases: glob2rx
+### Keywords: file character utilities
+
+### ** Examples
+
+stopifnot(glob2rx("abc.*") == "^abc\\.",
+ glob2rx("a?b.*") == "^a.b\\.",
+ glob2rx("a?b.*", trim.tail = FALSE) == "^a.b\\..*$",
+ glob2rx("*.doc") == "^.*\\.doc$",
+ glob2rx("*.doc", trim.head = TRUE) == "\\.doc$",
+ glob2rx("*.t*") == "^.*\\.t",
+ glob2rx("*.t??") == "^.*\\.t..$",
+ glob2rx("*[*") == "^.*\\["
+)
+
+
+
+cleanEx()
+nameEx("globalVariables")
+### * globalVariables
+
+flush(stderr()); flush(stdout())
+
+### Name: globalVariables
+### Title: Declarations Used in Checking a Package
+### Aliases: globalVariables suppressForeignCheck
+### Keywords: packages
+
+### ** Examples
+
+## Not run:
+##D ## assume your package has some code that assigns ".obj1" and ".obj2"
+##D ## but not in a way that codetools can find.
+##D ## In the same source file (to remind you that you did it) add:
+##D if(getRversion() >= "2.15.1") utils::globalVariables(c(".obj1", "obj2"))
+##D
+##D ## To suppress messages about a run-time calculated native symbol,
+##D ## save it to a local variable.
+##D
+##D ## At top level, put this:
+##D if(getRversion() >= "3.1.0") utils::suppressForeignCheck("localvariable")
+##D
+##D ## Within your function, do the call like this:
+##D localvariable <- if (condition) entry1 else entry2
+##D .Call(localvariable, 1, 2, 3)
+##D
+##D ## HOWEVER, it is much better practice to write code
+##D ## that can be checked thoroughly, e.g.
+##D if(condition) .Call(entry1, 1, 2, 3) else .Call(entry2, 1, 2, 3)
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("hasName")
+### * hasName
+
+flush(stderr()); flush(stdout())
+
+### Name: hasName
+### Title: Check for name
+### Aliases: hasName
+### Keywords: manip logic
+
+### ** Examples
+
+x <- list(abc = 1, def = 2)
+!is.null(x$abc) # correct
+!is.null(x$a) # this is the wrong test!
+hasName(x, "abc")
+hasName(x, "a")
+
+
+
+cleanEx()
+nameEx("head")
+### * head
+
+flush(stderr()); flush(stdout())
+
+### Name: head
+### Title: Return the First or Last Part of an Object
+### Aliases: head head.default head.data.frame head.function head.ftable
+### head.table head.matrix tail tail.default tail.data.frame
+### tail.function tail.ftable tail.table tail.matrix
+### Keywords: manip
+
+### ** Examples
+
+head(letters)
+head(letters, n = -6L)
+
+head(freeny.x, n = 10L)
+head(freeny.y)
+
+tail(letters)
+tail(letters, n = -6L)
+
+tail(freeny.x)
+tail(freeny.y)
+
+tail(library)
+
+head(stats::ftable(Titanic))
+
+
+
+cleanEx()
+nameEx("help")
+### * help
+
+flush(stderr()); flush(stdout())
+
+### Name: help
+### Title: Documentation
+### Aliases: help
+### Keywords: documentation
+
+### ** Examples
+
+help()
+help(help) # the same
+
+help(lapply)
+
+help("for") # or ?"for", but quotes/backticks are needed
+
+
+topi <- "women"
+help(topi)
+
+try(help("bs", try.all.packages = FALSE)) # reports not found (an error)
+help("bs", try.all.packages = TRUE) # reports can be found
+ # in package 'splines'
+
+
+
+cleanEx()
+nameEx("help.search")
+### * help.search
+
+flush(stderr()); flush(stdout())
+
+### Name: help.search
+### Title: Search the Help System
+### Aliases: help.search ?? print.hsearch
+### Keywords: documentation
+
+### ** Examples
+
+help.search("linear models") # In case you forgot how to fit linear
+ # models
+help.search("non-existent topic")
+
+??utils::help # All the topics matching "help" in the utils package
+
+
+
+cleanEx()
+nameEx("help.start")
+### * help.start
+
+flush(stderr()); flush(stdout())
+
+### Name: help.start
+### Title: Hypertext Documentation
+### Aliases: help.start
+### Keywords: documentation
+
+### ** Examples
+
+## Not run:
+##D ## the 'remote' arg can be tested by
+##D help.start(remote = paste0("file://", R.home()))
+## End(Not run)
+
+
+cleanEx()
+nameEx("hsearch-utils")
+### * hsearch-utils
+
+flush(stderr()); flush(stdout())
+
+### Name: hsearch-utils
+### Title: Help Search Utilities
+### Aliases: hsearch_db hsearch_db_concepts hsearch_db_keywords
+### Keywords: documentation
+
+### ** Examples
+
+db <- hsearch_db()
+## Total numbers of documentation objects, aliases, keywords and
+## concepts (using the current format):
+sapply(db, NROW)
+## Can also be obtained from print method:
+db
+## 10 most frequent concepts:
+head(hsearch_db_concepts(), 10)
+## 10 most frequent keywords:
+head(hsearch_db_keywords(), 10)
+
+
+
+cleanEx()
+nameEx("install.packages")
+### * install.packages
+
+flush(stderr()); flush(stdout())
+
+### Name: install.packages
+### Title: Install Packages from Repositories or Local Files
+### Aliases: install.packages
+### Keywords: utilities
+
+### ** Examples
+## Not run:
+##D ## A Linux example for Fedora's layout of udunits2 headers.
+##D install.packages(c("ncdf4", "RNetCDF"),
+##D configure.args = c(RNetCDF = "--with-netcdf-include=/usr/include/udunits2"))
+## End(Not run)
+
+
+cleanEx()
+nameEx("installed.packages")
+### * installed.packages
+
+flush(stderr()); flush(stdout())
+
+### Name: installed.packages
+### Title: Find Installed Packages
+### Aliases: installed.packages
+### Keywords: utilities
+
+### ** Examples
+
+## confine search to .Library for speed
+str(ip <- installed.packages(.Library, priority = "high"))
+ip[, c(1,3:5)]
+plic <- installed.packages(.Library, priority = "high", fields = "License")
+## what licenses are there:
+table( plic[, "License"] )
+
+
+
+cleanEx()
+nameEx("isS3method")
+### * isS3method
+
+flush(stderr()); flush(stdout())
+
+### Name: isS3method
+### Title: Is 'method' the Name of an S3 Method?
+### Aliases: isS3method
+### Keywords: methods
+
+### ** Examples
+
+isS3method("t") # FALSE - it is an S3 generic
+isS3method("t.default") # TRUE
+isS3method("t.ts") # TRUE
+isS3method("t.test") # FALSE
+isS3method("t.data.frame")# TRUE
+isS3method("t.lm") # FALSE - not existing
+isS3method("t.foo.bar") # FALSE - not existing
+
+## S3 methods with "4 parts" in their name:
+ff <- c("as.list", "as.matrix", "is.na", "row.names", "row.names<-")
+for(m in ff) if(isS3method(m)) stop("wrongly declared an S3 method: ", m)
+(m4 <- paste(ff, "data.frame", sep="."))
+for(m in m4) if(!isS3method(m)) stop("not an S3 method: ", m)
+## Don't show:
+stopifnot(
+ !isS3method("t"), !isS3method("t.test"), !isS3method("qr.coef"), !isS3method("sort.list"),
+ isS3method("t.default"), isS3method("t.ts"), isS3method("t.data.frame"),
+ !isS3method("t.lm"), !isS3method("t.foo.bar"))
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("localeToCharset")
+### * localeToCharset
+
+flush(stderr()); flush(stdout())
+
+### Name: localeToCharset
+### Title: Select a Suitable Encoding Name from a Locale Name
+### Aliases: localeToCharset
+### Keywords: utilities
+
+### ** Examples
+
+localeToCharset()
+
+
+
+cleanEx()
+nameEx("ls_str")
+### * ls_str
+
+flush(stderr()); flush(stdout())
+
+### Name: ls.str
+### Title: List Objects and their Structure
+### Aliases: ls.str lsf.str print.ls_str
+### Keywords: print utilities
+
+### ** Examples
+
+require(stats)
+
+lsf.str() #- how do the functions look like which I am using?
+ls.str(mode = "list") #- what are the structured objects I have defined?
+
+## create a few objects
+example(glm, echo = FALSE)
+ll <- as.list(LETTERS)
+print(ls.str(), max.level = 0)# don't show details
+
+## which base functions have "file" in their name ?
+lsf.str(pos = length(search()), pattern = "file")
+
+## demonstrating that ls.str() works inside functions
+## ["browser/debug mode"]:
+tt <- function(x, y = 1) { aa <- 7; r <- x + y; ls.str() }
+(nms <- sapply(strsplit(capture.output(tt(2))," *: *"), `[`, 1))
+stopifnot(nms == c("aa", "r","x","y"))
+
+
+
+cleanEx()
+nameEx("maintainer")
+### * maintainer
+
+flush(stderr()); flush(stdout())
+
+### Name: maintainer
+### Title: Show Package Maintainer
+### Aliases: maintainer
+### Keywords: utilities
+
+### ** Examples
+
+maintainer("MASS")
+
+
+
+cleanEx()
+nameEx("make.packages.html")
+### * make.packages.html
+
+flush(stderr()); flush(stdout())
+
+### Name: make.packages.html
+### Title: Update HTML Package List
+### Aliases: make.packages.html
+### Keywords: utilities
+
+### ** Examples
+## Not run:
+##D make.packages.html()
+##D # this can be slow for large numbers of installed packages.
+## End(Not run)
+
+
+cleanEx()
+nameEx("make.socket")
+### * make.socket
+
+flush(stderr()); flush(stdout())
+
+### Name: make.socket
+### Title: Create a Socket Connection
+### Aliases: make.socket print.socket
+### Keywords: misc
+
+### ** Examples
+
+daytime <- function(host = "localhost"){
+ a <- make.socket(host, 13)
+ on.exit(close.socket(a))
+ read.socket(a)
+}
+## Official time (UTC) from US Naval Observatory
+## Not run: daytime("tick.usno.navy.mil")
+
+
+
+cleanEx()
+nameEx("menu")
+### * menu
+
+flush(stderr()); flush(stdout())
+
+### Name: menu
+### Title: Menu Interaction Function
+### Aliases: menu
+### Keywords: utilities programming
+
+### ** Examples
+
+## Not run:
+##D switch(menu(c("List letters", "List LETTERS")) + 1,
+##D cat("Nothing done\n"), letters, LETTERS)
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("methods")
+### * methods
+
+flush(stderr()); flush(stdout())
+
+### Name: methods
+### Title: List Methods for S3 Generic Functions or Classes
+### Aliases: .S3methods methods print.MethodsFunction
+### Keywords: methods
+
+### ** Examples
+
+require(stats)
+
+methods(summary)
+methods(class = "aov") # S3 class
+## The same, with more details and more difficult to read:
+print(methods(class = "aov"), byclass=FALSE)
+methods("[[") # uses C-internal dispatching
+methods("$")
+methods("$<-") # replacement function
+methods("+") # binary operator
+methods("Math") # group generic
+require(graphics)
+methods("axis") # looks like a generic, but is not
+
+if(require(Matrix)) {
+print(methods(class = "Matrix")) # S4 class
+m <- methods("dim") # S3 and S4 methods
+print(m)
+print(attr(m, "info")) # more extensive information
+
+## --> help(showMethods) for related examples
+}
+
+
+
+cleanEx()
+nameEx("modifyList")
+### * modifyList
+
+flush(stderr()); flush(stdout())
+
+### Name: modifyList
+### Title: Recursively Modify Elements of a List
+### Aliases: modifyList
+### Keywords: utilities
+
+### ** Examples
+
+foo <- list(a = 1, b = list(c = "a", d = FALSE))
+bar <- modifyList(foo, list(e = 2, b = list(d = TRUE)))
+str(foo)
+str(bar)
+
+
+
+cleanEx()
+nameEx("news")
+### * news
+
+flush(stderr()); flush(stdout())
+
+### Name: news
+### Title: Build and Query R or Package News Information
+### Aliases: news print.news_db
+
+### ** Examples
+
+## Build a db of all R news entries.
+db <- news()
+## Don't show:
+ vv <- capture.output(print(db, doBrowse=FALSE)) # without an error
+ stopifnot(is.character(vv), length(vv) >= 3) # was wrong (for weeks during devel.)
+## End(Don't show)
+## Bug fixes with PR number in 3.0.1.
+db3 <- news(Version == "3.0.1" & grepl("^BUG", Category) & grepl("PR#", Text),
+ db = db)
+## Don't show:
+stopifnot( !any(attr(db3,"bad")) && nrow(db3) == 12 )
+## End(Don't show)
+
+## News from a date range ('Matrix' is there in a regular R installation):
+if(length(iM <- find.package("Matrix", quiet=TRUE)) && nzchar(iM)) {
+ dM <- news(package="Matrix")
+ stopifnot(identical(dM, news(db=dM)))
+ dM2014 <- news("2014-01-01" <= Date & Date <= "2014-12-31", db = dM)
+ stopifnot(paste0("1.1-", 2:4) %in% dM2014[,"Version"])
+}
+
+
+cleanEx()
+nameEx("nsl")
+### * nsl
+
+flush(stderr()); flush(stdout())
+
+### Name: nsl
+### Title: Look up the IP Address by Hostname
+### Aliases: nsl
+### Keywords: utilities
+
+### ** Examples
+
+## Not run: nsl("www.r-project.org")
+
+
+
+cleanEx()
+nameEx("object.size")
+### * object.size
+
+flush(stderr()); flush(stdout())
+
+### Name: object.size
+### Title: Report the Space Allocated for an Object
+### Aliases: object.size format.object_size print.object_size
+### Keywords: utilities
+
+### ** Examples
+
+object.size(letters)
+object.size(ls)
+format(object.size(library), units = "auto")
+
+sl <- object.size(rep(letters, 1000))
+
+print(sl) ## 209288 bytes
+print(sl, units = "auto") ## 204.4 Kb
+print(sl, units = "auto", standard = "IEC") ## 204.4 KiB
+print(sl, units = "auto", standard = "SI") ## 209.3 kB
+
+(fsl <- sapply(c("Kb", "KB", "KiB"),
+ function(u) format(sl, units = u)))
+stopifnot(identical( ## assert that all three are the same :
+ unique(substr(as.vector(fsl), 1,5)),
+ format(round(as.vector(sl)/1024, 1))))
+
+## find the 10 largest objects in the base package
+z <- sapply(ls("package:base"), function(x)
+ object.size(get(x, envir = baseenv())))
+if(interactive()) {
+as.matrix(rev(sort(z))[1:10])
+} else # (more constant over time):
+ names(rev(sort(z))[1:10])
+
+
+
+cleanEx()
+nameEx("package.skeleton")
+### * package.skeleton
+
+flush(stderr()); flush(stdout())
+
+### Name: package.skeleton
+### Title: Create a Skeleton for a New Source Package
+### Aliases: package.skeleton
+### Keywords: file utilities
+
+### ** Examples
+
+require(stats)
+## two functions and two "data sets" :
+f <- function(x, y) x+y
+g <- function(x, y) x-y
+d <- data.frame(a = 1, b = 2)
+e <- rnorm(1000)
+## Don't show:
+ owd <- getwd()
+ setwd(tempdir())
+## End(Don't show)
+package.skeleton(list = c("f","g","d","e"), name = "mypkg")
+## Don't show:
+ setwd(owd)
+## End(Don't show)
+
+
+
+cleanEx()
+nameEx("packageDescription")
+### * packageDescription
+
+flush(stderr()); flush(stdout())
+
+### Name: packageDescription
+### Title: Package Description
+### Aliases: packageDescription packageVersion print.packageDescription
+### Keywords: utilities
+
+### ** Examples
+
+
+cleanEx()
+nameEx("packageName")
+### * packageName
+
+flush(stderr()); flush(stdout())
+
+### Name: packageName
+### Title: Find package associated with an environment.
+### Aliases: packageName
+### Keywords: utilities
+
+### ** Examples
+
+packageName()
+packageName(environment(mean))
+
+
+
+cleanEx()
+nameEx("packageStatus")
+### * packageStatus
+
+flush(stderr()); flush(stdout())
+
+### Name: packageStatus
+### Title: Package Management Tools
+### Aliases: packageStatus print.packageStatus summary.packageStatus
+### update.packageStatus upgrade.packageStatus upgrade
+### Keywords: utilities
+
+### ** Examples
+
+## Not run:
+##D x <- packageStatus()
+##D print(x)
+##D summary(x)
+##D upgrade(x)
+##D x <- update(x)
+##D print(x)
+## End(Not run)
+
+
+cleanEx()
+nameEx("page")
+### * page
+
+flush(stderr()); flush(stdout())
+
+### Name: page
+### Title: Invoke a Pager on an R Object
+### Aliases: page
+### Keywords: utilities
+
+### ** Examples
+## Not run:
+##D ## four ways to look at the code of 'page'
+##D page(page) # as an object
+##D page("page") # a character string
+##D v <- "page"; page(v) # a length-one character vector
+##D page(utils::page) # a call
+## End(Not run)
+
+
+cleanEx()
+nameEx("person")
+### * person
+
+flush(stderr()); flush(stdout())
+
+### Name: person
+### Title: Persons
+### Aliases: person as.person as.person.default [.person $.person
+### as.character.person c.person format.person print.person
+### toBibtex.person personList as.personList as.personList.person
+### as.personList.default
+### Keywords: misc
+
+### ** Examples
+
+## Create a person object directly ...
+p1 <- person("Karl", "Pearson", email = "pearson@stats.heaven")
+
+## ... or convert a string.
+p2 <- as.person("Ronald Aylmer Fisher")
+
+## Combining and subsetting.
+p <- c(p1, p2)
+p[1]
+p[-1]
+
+## Extracting fields.
+p$family
+p$email
+p[1]$email
+
+## Specifying package authors, example from "boot":
+## AC is the first author [aut] who wrote the S original.
+## BR is the second author [aut], who translated the code to R [trl],
+## and maintains the package [cre].
+b <- c(person("Angelo", "Canty", role = "aut", comment =
+ "S original, http://statwww.epfl.ch/davison/BMA/library.html"),
+ person(c("Brian", "D."), "Ripley", role = c("aut", "trl", "cre"),
+ comment = "R port", email = "ripley@stats.ox.ac.uk")
+ )
+b
+
+## Formatting.
+format(b)
+format(b, include = c("family", "given", "role"),
+ braces = list(family = c("", ","), role = c("(Role(s): ", ")")))
+
+## Conversion to BibTeX author field.
+paste(format(b, include = c("given", "family")), collapse = " and ")
+toBibtex(b)
+
+
+
+cleanEx()
+nameEx("prompt")
+### * prompt
+
+flush(stderr()); flush(stdout())
+
+### Name: prompt
+### Title: Produce Prototype of an R Documentation File
+### Aliases: prompt prompt.default prompt.data.frame promptImport
+### Keywords: documentation
+
+### ** Examples
+
+require(graphics)
+prompt(plot.default)
+prompt(interactive, force.function = TRUE)
+unlink("plot.default.Rd")
+unlink("interactive.Rd")
+
+prompt(women) # data.frame
+unlink("women.Rd")
+
+prompt(sunspots) # non-data.frame data
+unlink("sunspots.Rd")
+
+## Not run:
+##D ## Create a help file for each function in the .GlobalEnv:
+##D for(f in ls()) if(is.function(get(f))) prompt(name = f)
+## End(Not run)
+
+
+
+
+cleanEx()
+nameEx("promptData")
+### * promptData
+
+flush(stderr()); flush(stdout())
+
+### Name: promptData
+### Title: Generate Outline Documentation for a Data Set
+### Aliases: promptData
+### Keywords: documentation
+
+### ** Examples
+
+promptData(sunspots)
+unlink("sunspots.Rd")
+
+
+
+cleanEx()
+nameEx("promptPackage")
+### * promptPackage
+
+flush(stderr()); flush(stdout())
+
+### Name: promptPackage
+### Title: Generate a Shell for Documentation of a Package
+### Aliases: promptPackage
+### Keywords: documentation
+
+### ** Examples
+
+
+cleanEx()
+nameEx("read.DIF")
+### * read.DIF
+
+flush(stderr()); flush(stdout())
+
+### Name: read.DIF
+### Title: Data Input from Spreadsheet
+### Aliases: read.DIF
+### Keywords: file connection
+
+### ** Examples
+
+## read.DIF() may need transpose = TRUE for a file exported from Excel
+udir <- system.file("misc", package = "utils")
+dd <- read.DIF(file.path(udir, "exDIF.dif"), header = TRUE, transpose = TRUE)
+dc <- read.csv(file.path(udir, "exDIF.csv"), header = TRUE)
+stopifnot(identical(dd, dc), dim(dd) == c(4,2))
+
+
+
+cleanEx()
+nameEx("read.fortran")
+### * read.fortran
+
+flush(stderr()); flush(stdout())
+
+### Name: read.fortran
+### Title: Read Fixed-Format Data in a Fortran-like Style
+### Aliases: read.fortran
+### Keywords: file connection
+
+### ** Examples
+
+ff <- tempfile()
+cat(file = ff, "123456", "987654", sep = "\n")
+read.fortran(ff, c("F2.1","F2.0","I2"))
+read.fortran(ff, c("2F1.0","2X","2A1"))
+unlink(ff)
+cat(file = ff, "123456AB", "987654CD", sep = "\n")
+read.fortran(ff, list(c("2F3.1","A2"), c("3I2","2X")))
+unlink(ff)
+# Note that the first number is read differently than Fortran would
+# read it:
+cat(file = ff, "12.3456", "1234567", sep = "\n")
+read.fortran(ff, "F7.4")
+unlink(ff)
+
+
+
+cleanEx()
+nameEx("read.fwf")
+### * read.fwf
+
+flush(stderr()); flush(stdout())
+
+### Name: read.fwf
+### Title: Read Fixed Width Format Files
+### Aliases: read.fwf
+### Keywords: file connection
+
+### ** Examples
+
+ff <- tempfile()
+cat(file = ff, "123456", "987654", sep = "\n")
+read.fwf(ff, widths = c(1,2,3)) #> 1 23 456 \ 9 87 654
+read.fwf(ff, widths = c(1,-2,3)) #> 1 456 \ 9 654
+unlink(ff)
+cat(file = ff, "123", "987654", sep = "\n")
+read.fwf(ff, widths = c(1,0, 2,3)) #> 1 NA 23 NA \ 9 NA 87 654
+unlink(ff)
+cat(file = ff, "123456", "987654", sep = "\n")
+read.fwf(ff, widths = list(c(1,0, 2,3), c(2,2,2))) #> 1 NA 23 456 98 76 54
+unlink(ff)
+
+
+
+cleanEx()
+nameEx("read.socket")
+### * read.socket
+
+flush(stderr()); flush(stdout())
+
+### Name: read.socket
+### Title: Read from or Write to a Socket
+### Aliases: read.socket write.socket
+### Keywords: misc
+
+### ** Examples
+
+finger <- function(user, host = "localhost", port = 79, print = TRUE)
+{
+ if (!is.character(user))
+ stop("user name must be a string")
+ user <- paste(user,"\r\n")
+ socket <- make.socket(host, port)
+ on.exit(close.socket(socket))
+ write.socket(socket, user)
+ output <- character(0)
+ repeat{
+ ss <- read.socket(socket)
+ if (ss == "") break
+ output <- paste(output, ss)
+ }
+ close.socket(socket)
+ if (print) cat(output)
+ invisible(output)
+}
+## Not run:
+##D finger("root") ## only works if your site provides a finger daemon
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("read.table")
+### * read.table
+
+flush(stderr()); flush(stdout())
+
+### Name: read.table
+### Title: Data Input
+### Aliases: read.table read.csv read.csv2 read.delim read.delim2
+### Keywords: file connection
+
+### ** Examples
+
+## using count.fields to handle unknown maximum number of fields
+## when fill = TRUE
+test1 <- c(1:5, "6,7", "8,9,10")
+tf <- tempfile()
+writeLines(test1, tf)
+
+read.csv(tf, fill = TRUE) # 1 column
+ncol <- max(count.fields(tf, sep = ","))
+read.csv(tf, fill = TRUE, header = FALSE,
+ col.names = paste0("V", seq_len(ncol)))
+unlink(tf)
+
+## "Inline" data set, using text=
+## Notice that leading and trailing empty lines are auto-trimmed
+
+read.table(header = TRUE, text = "
+a b
+1 2
+3 4
+")
+
+
+
+cleanEx()
+nameEx("recover")
+### * recover
+
+flush(stderr()); flush(stdout())
+
+### Name: recover
+### Title: Browsing after an Error
+### Aliases: recover limitedLabels
+### Keywords: programming debugging
+
+### ** Examples
+
+## Not run:
+##D
+##D options(error = recover) # setting the error option
+##D
+##D ### Example of interaction
+##D
+##D > myFit <- lm(y ~ x, data = xy, weights = w)
+##D Error in lm.wfit(x, y, w, offset = offset, ...) :
+##D missing or negative weights not allowed
+##D
+##D Enter a frame number, or 0 to exit
+##D 1:lm(y ~ x, data = xy, weights = w)
+##D 2:lm.wfit(x, y, w, offset = offset, ...)
+##D Selection: 2
+##D Called from: eval(expr, envir, enclos)
+##D Browse[1]> objects() # all the objects in this frame
+##D [1] "method" "n" "ny" "offset" "tol" "w"
+##D [7] "x" "y"
+##D Browse[1]> w
+##D [1] -0.5013844 1.3112515 0.2939348 -0.8983705 -0.1538642
+##D [6] -0.9772989 0.7888790 -0.1919154 -0.3026882
+##D Browse[1]> dump.frames() # save for offline debugging
+##D Browse[1]> c # exit the browser
+##D
+##D Enter a frame number, or 0 to exit
+##D 1:lm(y ~ x, data = xy, weights = w)
+##D 2:lm.wfit(x, y, w, offset = offset, ...)
+##D Selection: 0 # exit recover
+##D >
+##D
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("relist")
+### * relist
+
+flush(stderr()); flush(stdout())
+
+### Name: relist
+### Title: Allow Re-Listing an unlist()ed Object
+### Aliases: relist relist.default relist.list relist.factor relist.matrix
+### as.relistable is.relistable unlist.relistable
+### Keywords: list manip
+
+### ** Examples
+
+ ipar <- list(mean = c(0, 1), vcov = cbind(c(1, 1), c(1, 0)))
+ initial.param <- as.relistable(ipar)
+ ul <- unlist(initial.param)
+ relist(ul)
+ stopifnot(identical(relist(ul), initial.param))
+
+
+
+cleanEx()
+nameEx("removeSource")
+### * removeSource
+
+flush(stderr()); flush(stdout())
+
+### Name: removeSource
+### Title: Remove Stored Source from a Function.
+### Aliases: removeSource
+### Keywords: utility
+
+### ** Examples
+
+fn <- function(x) {
+ x + 1 # A comment, kept as part of the source
+}
+fn
+fn <- removeSource(fn)
+fn
+
+
+
+cleanEx()
+nameEx("roman")
+### * roman
+
+flush(stderr()); flush(stdout())
+
+### Name: roman
+### Title: Roman Numerals
+### Aliases: as.roman .romans
+### Keywords: arith
+
+### ** Examples
+
+## First five roman 'numbers'.
+(y <- as.roman(1 : 5))
+## Middle one.
+y[3]
+## Current year as a roman number.
+(y <- as.roman(format(Sys.Date(), "%Y")))
+## Today, and 10, 20, 30, and 100 years ago ...
+y - 10*c(0:3,10)
+## Don't show:
+stopifnot(identical(as.character(as.roman("2016") - 10*c(0:3,10)),
+ c("MMXVI", "MMVI", "MCMXCVI", "MCMLXXXVI", "MCMXVI")))
+## End(Don't show)
+## mixture of arabic and roman numbers :
+as.roman(c(NA, 1:3, "", strrep("I", 1:6))) # + NA with a warning for "IIIIII"
+cc <- c(NA, 1:3, strrep("I", 0:5))
+(rc <- as.roman(cc)) # two NAs: 0 is not "roman"
+(ic <- as.integer(rc)) # works automitcally [without an explicit method]
+## simple consistency checks -- arithmetic when result is in {1,2,..,3899} :
+stopifnot(identical(rc, as.roman(rc)), # as.roman(.) is "idempotent"
+ identical(rc + rc + (3*rc), rc*5),
+ identical(ic, c(NA, 1:3, NA, 1:5)),
+ identical(as.integer(5*rc), 5L*ic),
+ identical(as.numeric(rc), as.numeric(ic)),
+ identical(as.list(rc), as.list(ic)))
+
+
+
+cleanEx()
+nameEx("rtags")
+### * rtags
+
+flush(stderr()); flush(stdout())
+
+### Name: rtags
+### Title: An Etags-like Tagging Utility for R
+### Aliases: rtags
+### Keywords: programming utilities
+
+### ** Examples
+
+
+## Not run:
+##D rtags("/path/to/src/repository",
+##D pattern = "[.]*\\.[RrSs]$",
+##D keep.re = "/R/",
+##D verbose = TRUE,
+##D ofile = "TAGS",
+##D append = FALSE,
+##D recursive = TRUE)
+## End(Not run)
+
+
+
+
+cleanEx()
+nameEx("savehistory")
+### * savehistory
+
+flush(stderr()); flush(stdout())
+
+### Name: savehistory
+### Title: Load or Save or Display the Commands History
+### Aliases: loadhistory savehistory history timestamp
+### Keywords: utilities
+
+### ** Examples
+## Not run:
+##D ## Save the history in the home directory: note that it is not
+##D ## (by default) read from there but from the current directory
+##D .Last <- function()
+##D if(interactive()) try(savehistory("~/.Rhistory"))
+## End(Not run)
+
+
+cleanEx()
+nameEx("select.list")
+### * select.list
+
+flush(stderr()); flush(stdout())
+
+### Name: select.list
+### Title: Select Items from a List
+### Aliases: select.list
+### Keywords: utilities
+
+### ** Examples
+## Not run:
+##D select.list(sort(.packages(all.available = TRUE)))
+## End(Not run)
+
+
+cleanEx()
+nameEx("sessionInfo")
+### * sessionInfo
+
+flush(stderr()); flush(stdout())
+
+### Name: sessionInfo
+### Title: Collect Information About the Current R Session
+### Aliases: sessionInfo toLatex.sessionInfo print.sessionInfo
+### Keywords: misc
+
+### ** Examples
+
+
+cleanEx()
+nameEx("setRepositories")
+### * setRepositories
+
+flush(stderr()); flush(stdout())
+
+### Name: setRepositories
+### Title: Select Package Repositories
+### Aliases: setRepositories
+### Keywords: utilities
+
+### ** Examples
+## Not run:
+##D setRepositories(addURLs =
+##D c(CRANxtras = "http://www.stats.ox.ac.uk/pub/RWin"))
+## End(Not run)
+
+
+cleanEx()
+nameEx("sourceutils")
+### * sourceutils
+
+flush(stderr()); flush(stdout())
+
+### Name: sourceutils
+### Title: Source Reference Utilities
+### Aliases: getSrcFilename getSrcDirectory getSrcref getSrcLocation
+### Keywords: utilities
+
+### ** Examples
+
+fn <- function(x) {
+ x + 1 # A comment, kept as part of the source
+}
+
+# Show the temporary file directory
+# where the example was saved
+
+getSrcDirectory(fn)
+getSrcLocation(fn, "line")
+
+
+
+cleanEx()
+nameEx("stack")
+### * stack
+
+flush(stderr()); flush(stdout())
+
+### Name: stack
+### Title: Stack or Unstack Vectors from a Data Frame or List
+### Aliases: stack stack.default stack.data.frame unstack unstack.default
+### unstack.data.frame
+### Keywords: manip
+
+### ** Examples
+
+require(stats)
+formula(PlantGrowth) # check the default formula
+pg <- unstack(PlantGrowth) # unstack according to this formula
+pg
+stack(pg) # now put it back together
+stack(pg, select = -ctrl) # omitting one vector
+
+
+
+cleanEx()
+nameEx("str")
+### * str
+
+flush(stderr()); flush(stdout())
+
+### Name: str
+### Title: Compactly Display the Structure of an Arbitrary R Object
+### Aliases: str str.default str.data.frame strOptions
+### Keywords: print documentation utilities
+
+### ** Examples
+
+require(stats); require(grDevices); require(graphics)
+## The following examples show some of 'str' capabilities
+str(1:12)
+str(ls)
+str(args) #- more useful than args(args) !
+str(freeny)
+str(str)
+str(.Machine, digits.d = 20) # extra digits for identification of binary numbers
+str( lsfit(1:9, 1:9))
+str( lsfit(1:9, 1:9), max.level = 1)
+str( lsfit(1:9, 1:9), width = 60, strict.width = "cut")
+str( lsfit(1:9, 1:9), width = 60, strict.width = "wrap")
+op <- options(); str(op) # save first;
+ # otherwise internal options() is used.
+need.dev <-
+ !exists(".Device") || is.null(.Device) || .Device == "null device"
+{ if(need.dev) postscript()
+ str(par())
+ if(need.dev) graphics.off()
+}
+ch <- letters[1:12]; is.na(ch) <- 3:5
+str(ch) # character NA's
+
+str(list(a = "A", L = as.list(1:100)), list.len = 9)
+## ------------
+## " .. [list output truncated] "
+
+## Long strings, 'nchar.max'; 'strict.width' :
+nchar(longch <- paste(rep(letters,100), collapse = ""))
+str(longch)
+str(longch, nchar.max = 52)
+str(longch, strict.width = "wrap")
+
+## Multibyte characters in strings (in multibyte locales):
+oloc <- Sys.getlocale("LC_CTYPE")
+mbyte.lc <- if(.Platform$OS.type == "windows")
+ "English_United States.28605" else "en_GB.UTF-8"
+try(Sys.setlocale("LC_CTYPE", mbyte.lc))
+## Truncation behavior (<-> correct width measurement) for "long" non-ASCII:
+idx <- c(65313:65338, 65345:65350)
+fwch <- intToUtf8(idx) # full width character string: each has width 2
+ch <- strtrim(paste(LETTERS, collapse="._"), 64)
+(ncc <- c(c.ch = nchar(ch), w.ch = nchar(ch, "w"),
+ c.fw = nchar(fwch), w.fw = nchar(fwch, "w")))
+stopifnot(unname(ncc) == c(64,64, 32, 64))
+## nchar.max: 1st line needs an increase of 2 in order to see 1 (in UTF-8!):
+invisible(lapply(60:66, function(N) str(fwch, nchar.max = N)))
+invisible(lapply(60:66, function(N) str( ch , nchar.max = N))) # "1 is 1" here
+## revert locale to previous:
+Sys.setlocale("LC_CTYPE", oloc)
+
+
+## Settings for narrow transcript :
+op <- options(width = 60,
+ str = strOptions(strict.width = "wrap"))
+str(lsfit(1:9,1:9))
+str(options())
+## reset to previous:
+options(op)
+
+
+## Don't show:
+ ##-- Some "crazy" objects
+ str(array(1:5, dim = 20))
+ str(factor(character(0)))
+ str(as.data.frame(NULL))
+## End(Don't show)
+str(quote( { A+B; list(C, D) } ))
+
+## Don't show:
+had.stats4 <- "package:stats4" %in% search()
+if(!had.stats4)
+ rs <-
+## End(Don't show)
+## S4 classes :
+require(stats4)
+x <- 0:10; y <- c(26, 17, 13, 12, 20, 5, 9, 8, 5, 4, 8)
+ll <- function(ymax = 15, xh = 6)
+ -sum(dpois(y, lambda=ymax/(1+x/xh), log=TRUE))
+fit <- mle(ll)
+str(fit)
+## Don't show:
+if(!had.stats4 && rs) detach("package:stats4")
+## End(Don't show)
+
+
+
+graphics::par(get("par.postscript", pos = 'CheckExEnv'))
+cleanEx()
+nameEx("strcapture")
+### * strcapture
+
+flush(stderr()); flush(stdout())
+
+### Name: strcapture
+### Title: Capture string tokens into a data.frame
+### Aliases: strcapture
+### Keywords: utilities
+
+### ** Examples
+
+x <- "chr1:1-1000"
+pattern <- "(.*?):([[:digit:]]+)-([[:digit:]]+)"
+proto <- data.frame(chr=character(), start=integer(), end=integer())
+strcapture(pattern, x, proto)
+
+
+
+cleanEx()
+nameEx("summaryRprof")
+### * summaryRprof
+
+flush(stderr()); flush(stdout())
+
+### Name: summaryRprof
+### Title: Summarise Output of R Sampling Profiler
+### Aliases: summaryRprof
+### Keywords: utilities
+
+### ** Examples
+
+## Not run:
+##D ## Rprof() is not available on all platforms
+##D Rprof(tmp <- tempfile())
+##D example(glm)
+##D Rprof()
+##D summaryRprof(tmp)
+##D unlink(tmp)
+## End(Not run)
+
+
+
+cleanEx()
+nameEx("txtProgressBar")
+### * txtProgressBar
+
+flush(stderr()); flush(stdout())
+
+### Name: txtProgressBar
+### Title: Text Progress Bar
+### Aliases: txtProgressBar getTxtProgressBar setTxtProgressBar
+### close.txtProgressBar
+### Keywords: utilities
+
+### ** Examples
+
+
+cleanEx()
+nameEx("url.show")
+### * url.show
+
+flush(stderr()); flush(stdout())
+
+### Name: url.show
+### Title: Display a text URL
+### Aliases: url.show
+### Keywords: file misc
+
+### ** Examples
+
+## Not run: url.show("http://www.stats.ox.ac.uk/pub/datasets/csb/ch3a.txt")
+
+
+
+cleanEx()
+nameEx("vignette")
+### * vignette
+
+flush(stderr()); flush(stdout())
+
+### Name: vignette
+### Title: View, List or Get R Source of Package Vignettes
+### Aliases: vignette edit.vignette print.vignette vignettes
+### Keywords: documentation
+
+### ** Examples
+
+## List vignettes from all *attached* packages
+vignette(all = FALSE)
+
+## List vignettes from all *installed* packages (can take a long time!):
+vignette(all = TRUE)
+
+## The grid intro vignette -- open it
+## Not run: vignette("grid") # calling print()
+## The same (conditional on existence of the vignettte).
+## Note that 'package = *' is much faster in the case of many installed packages:
+if(!is.null(v1 <- vignette("grid", package="grid"))) {
+## Not run: v1 # calling print(.)
+ str(v1)
+ ## Now let us have a closer look at the code
+
+
+
+
+## Not run: edit(v1) # e.g., to send lines ...
+}# if( has vignette "installed")
+## A package can have more than one vignette (package grid has several):
+vignette(package = "grid")
+if(interactive()) {
+ ## vignette("rotated")
+ ## The same, but without searching for it:
+ vignette("rotated", package = "grid")
+}
+
+
+
+cleanEx()
+nameEx("write.table")
+### * write.table
+
+flush(stderr()); flush(stdout())
+
+### Name: write.table
+### Title: Data Output
+### Aliases: write.table write.csv write.csv2
+### Keywords: print file
+
+### ** Examples
+
+## Not run:
+##D ## To write a CSV file for input to Excel one might use
+##D x <- data.frame(a = I("a \" quote"), b = pi)
+##D write.table(x, file = "foo.csv", sep = ",", col.names = NA,
+##D qmethod = "double")
+##D ## and to read this file back into R one needs
+##D read.table("foo.csv", header = TRUE, sep = ",", row.names = 1)
+##D ## NB: you do need to specify a separator if qmethod = "double".
+##D
+##D ### Alternatively
+##D write.csv(x, file = "foo.csv")
+##D read.csv("foo.csv", row.names = 1)
+##D ## or without row names
+##D write.csv(x, file = "foo.csv", row.names = FALSE)
+##D read.csv("foo.csv")
+##D
+##D ## To write a file in Mac Roman for simple use in Mac Excel 2004/8
+##D write.csv(x, file = "foo.csv", fileEncoding = "macroman")
+##D ## or for Windows Excel 2007/10
+##D write.csv(x, file = "foo.csv", fileEncoding = "UTF-16LE")
+## End(Not run)
+
+
+### * <FOOTER>
+###
+options(digits = 7L)
+base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n")
+#grDevices::dev.off()
+###
+### Local variables: ***
+### mode: outline-minor ***
+### outline-regexp: "\\(> \\)?### [*]+" ***
+### End: ***
+quit('no')
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/PCRE.R b/com.oracle.truffle.r.native/gnur/tests/src/PCRE.R
new file mode 100644
index 0000000000000000000000000000000000000000..9dcdebd02fac8226c80eaab401445c61c979a737
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/PCRE.R
@@ -0,0 +1,82 @@
+.ptime <- proc.time()
+
+### tests of recursion in PCRE matching
+### Based on PR16757
+
+## This is expected to throw a warning at some point if PCRE uses a stack,
+## depending on the system and stack size.
+## Typical stack 8-10M, some people use 40M.
+
+pcre_config()["stack"]
+
+op <- options(warn = 1)
+for (n in c(seq(5000L, 10000L, 1000L), 20000L, 50000L, 100000L)) {
+ print(n)
+ x <- paste0(rep("a", n), collapse="")
+ print(grepl("(a|b)+", x, perl = TRUE))
+}
+options(op)
+
+
+### tests of PCRE's JIT.
+if(!pcre_config()["JIT"]) {
+ message("These tests are pointless without JIT support")
+ q("no")
+}
+
+
+## Test from example(grep)
+
+txt2 <- c("The", "licenses", "for", "most", "software", "are",
+ "designed", "to", "take", "away", "your", "freedom",
+ "to", "share", "and", "change", "it.",
+ "", "By", "contrast,", "the", "GNU", "General", "Public", "License",
+ "is", "intended", "to", "guarantee", "your", "freedom", "to",
+ "share", "and", "change", "free", "software", "--",
+ "to", "make", "sure", "the", "software", "is",
+ "free", "for", "all", "its", "users")
+grep("[gu]", txt2, perl = TRUE)
+
+st <- function(expr) sum(system.time(expr)[1:2])
+
+## here JIT is slightly slower
+options(PCRE_study = FALSE)
+st(for(i in 1:1e4) grep("[gu]", txt2, perl = TRUE))
+options(PCRE_study = TRUE, PCRE_use_JIT = FALSE)
+st(for(i in 1:1e4) grep("[gu]", txt2, perl = TRUE))
+options(PCRE_study = TRUE, PCRE_use_JIT = TRUE)
+st(for(i in 1:1e4) grep("[gu]", txt2, perl = TRUE))
+
+
+## and for more inputs, study starts to pay off
+txt3 <- rep(txt2, 10)
+options(PCRE_study = FALSE)
+st(for(i in 1:1e3) grep("[gu]", txt3, perl = TRUE))
+options(PCRE_study = TRUE, PCRE_use_JIT = FALSE)
+st(for(i in 1:1e3) grep("[gu]", txt3, perl = TRUE))
+options(PCRE_study = TRUE, PCRE_use_JIT = TRUE)
+st(for(i in 1:1e3) grep("[gu]", txt3, perl = TRUE))
+
+
+## An example where JIT really pays off (e.g. 10x)
+pat <- "([^[:alpha:]]|a|b)+"
+long_string <- paste0(rep("a", 1023), collapse="")
+N <- 10
+options(PCRE_study = FALSE, PCRE_use_JIT = FALSE)
+st(for(i in 1:1e3) grep(pat, rep(long_string, N), perl = TRUE))
+options(PCRE_study = TRUE, PCRE_use_JIT = FALSE)
+st(for(i in 1:1e3) grep(pat, rep(long_string, N), perl = TRUE))
+options(PCRE_study = TRUE, PCRE_use_JIT = TRUE)
+st(for(i in 1:1e3) grep(pat, rep(long_string, N), perl = TRUE))
+
+
+## This needs to test 50 strings to see much gain from study
+txt <- rep("a test of capitalizing", 50)
+options(PCRE_study = FALSE, PCRE_use_JIT = FALSE)
+st(for(i in 1:1e4) gsub("(\\w)(\\w*)", "\\U\\1\\L\\2", txt, perl = TRUE))
+options(PCRE_study = TRUE, PCRE_use_JIT = FALSE)
+st(for(i in 1:1e4) gsub("(\\w)(\\w*)", "\\U\\1\\L\\2", txt, perl = TRUE))
+options(PCRE_study = TRUE, PCRE_use_JIT = TRUE)
+st(for(i in 1:1e4) gsub("(\\w)(\\w*)", "\\U\\1\\L\\2", txt, perl = TRUE))
+
+cat("Time elapsed: ", proc.time() - .ptime,"\n")
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/any-all.R b/com.oracle.truffle.r.native/gnur/tests/src/any-all.R
new file mode 100644
index 0000000000000000000000000000000000000000..80007e29bae09cae3c46d47fcafd8ac7edcd2804
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/any-all.R
@@ -0,0 +1,93 @@
+basic_tests <- list(
+ list(input=c(TRUE, FALSE), any=TRUE, all=FALSE),
+ list(input=c(FALSE, TRUE), any=TRUE, all=FALSE),
+
+ list(input=c(TRUE, TRUE), any=TRUE, all=TRUE),
+ list(input=c(FALSE, FALSE), any=FALSE, all=FALSE),
+
+ list(input=c(NA, FALSE), any=NA, all=FALSE, any.na.rm=FALSE),
+ list(input=c(FALSE, NA), any=NA, all=FALSE, any.na.rm=FALSE),
+
+ list(input=c(NA, TRUE), any=TRUE, all=NA, all.na.rm=TRUE),
+ list(input=c(TRUE, NA), any=TRUE, all=NA, all.na.rm=TRUE),
+
+ list(input=logical(0), any=FALSE, all=TRUE),
+
+ list(input=NA, any=NA, all=NA, any.na.rm=FALSE, any.na.rm=TRUE),
+
+ list(input=c(TRUE, NA, FALSE), any=TRUE, any.na.rm=TRUE,
+ all=FALSE, all.na.rm=FALSE)
+ )
+
+## any, all accept '...' for input.
+list_input_tests <-
+ list(
+ list(input=list(TRUE, TRUE), all=TRUE, any=TRUE),
+ list(input=list(FALSE, FALSE), all=FALSE, any=FALSE),
+ list(input=list(TRUE, FALSE), all=FALSE, any=TRUE),
+ list(input=list(FALSE, TRUE), all=FALSE, any=TRUE),
+
+ list(input=list(FALSE, NA),
+ all=FALSE, all.na.rm=FALSE, any=NA, any.na.rm=FALSE),
+ list(input=list(NA, FALSE),
+ all=FALSE, all.na.rm=FALSE, any=NA, any.na.rm=FALSE),
+
+ list(input=list(TRUE, NA),
+ all=NA, all.na.rm=TRUE, any=TRUE, any.na.rm=TRUE),
+ list(input=list(NA, TRUE),
+ all=NA, all.na.rm=TRUE, any=TRUE, any.na.rm=TRUE),
+
+ list(input=list(NA, NA),
+ any=NA, any.na.rm=FALSE, all=NA, all.na.rm=TRUE),
+
+ list(input=list(rep(TRUE, 2), rep(TRUE, 10)),
+ all=TRUE, any=TRUE),
+
+ list(input=list(rep(TRUE, 2), c(TRUE, NA)),
+ all=NA, all.na.rm=TRUE, any=TRUE),
+
+ list(input=list(rep(TRUE, 2), c(TRUE, FALSE)),
+ all=FALSE, any=TRUE),
+
+ list(input=list(c(TRUE, FALSE), c(TRUE, NA)),
+ all=FALSE, all.na.rm=FALSE, any=TRUE, any.na.rm=TRUE)
+ )
+
+
+
+do_tests <- function(L)
+{
+ run <- function(f, input, na.rm = FALSE)
+ {
+ if (is.list(input))
+ do.call(f, c(input, list(na.rm = na.rm)))
+ else f(input, na.rm = na.rm)
+ }
+
+ do_check <- function(case, f)
+ {
+ fun <- deparse(substitute(f))
+ if (!identical(case[[fun]], run(f, case$input))) {
+ cat("input: "); dput(case$input)
+ stop(fun, " returned ", run(f, case$input),
+ " wanted ", case[[fun]], call. = FALSE)
+ }
+ narm <- paste(fun, ".na.rm", sep = "")
+ if (!is.null(case[[narm]])) {
+ if (!identical(case[[narm]],
+ run(f, case$input, na.rm = TRUE))) {
+ cat("input: "); dput(case$input)
+ stop(narm, " returned ", run(f, case$input, na.rm = TRUE),
+ " wanted ", case[[narm]], call. = FALSE)
+ }
+ }
+ }
+ lab <- deparse(substitute(L))
+ for (case in L) {
+ do_check(case, any)
+ do_check(case, all)
+ }
+}
+
+do_tests(basic_tests)
+do_tests(list_input_tests)
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/arith-true.R b/com.oracle.truffle.r.native/gnur/tests/src/arith-true.R
new file mode 100644
index 0000000000000000000000000000000000000000..a823afea6eebc43c1eba7783044a088dbfed72e8
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/arith-true.R
@@ -0,0 +1,220 @@
+####=== Numerical / Arithmetic Tests
+####--- ALL tests here should return TRUE !
+###
+### '##P': These lines don't give TRUE but relevant ``Print output''
+
+### --> d-p-q-r-tests.R for distribution things
+
+.proctime00 <- proc.time()
+opt.conformance <- 0
+Meps <- .Machine $ double.eps
+
+## this uses random inputs, so set the seed
+set.seed(1)
+
+options(rErr.eps = 1e-30)
+rErr <- function(approx, true, eps = .Options$rErr.eps)
+{
+ if(is.null(eps)) { eps <- 1e-30; options(rErr.eps = eps) }
+ ifelse(Mod(true) >= eps,
+ 1 - approx / true, # relative error
+ true - approx) # absolute error (e.g. when true=0)
+}
+
+abs(1- .Machine$double.xmin * 10^(-.Machine$double.min.exp*log10(2)))/Meps < 1e3
+##P (1- .Machine$double.xmin * 10^(-.Machine$double.min.exp*log10(2)))/Meps
+if(opt.conformance)#fails at least on SGI/IRIX 6.5
+abs(1- .Machine$double.xmax * 10^(-.Machine$double.max.exp*log10(2)))/Meps < 1e3
+
+## More IEEE Infinity/NaN checks
+i1 <- pi / 0
+i1 == (i2 <- 1:1 / 0:0)
+is.infinite( i1) & is.infinite( i2) & i1 > 12 & i2 > 12
+is.infinite(-i1) & is.infinite(-i2) & (-i1) < -12 & (-i2) < -12
+
+is.nan(n1 <- 0 / 0)
+is.nan( - n1)
+
+i1 == i1 + i1
+i1 == i1 * i1
+is.nan(i1 - i1)
+is.nan(i1 / i1)
+
+1/0 == Inf & 0 ^ -1 == Inf
+1/Inf == 0 & Inf ^ -1 == 0
+
+iNA <- as.integer(NA)
+!is.na(Inf) & !is.nan(Inf) & is.infinite(Inf) & !is.finite(Inf)
+!is.na(-Inf)& !is.nan(-Inf)& is.infinite(-Inf)& !is.finite(-Inf)
+ is.na(NA) & !is.nan(NA) & !is.infinite(NA) & !is.finite(NA)
+ is.na(NaN) & is.nan(NaN) & !is.infinite(NaN) & !is.finite(NaN)
+ is.na(iNA) & !is.nan(iNA) & !is.infinite(iNA) & !is.finite(iNA)
+
+## These are "double"s:
+all(!is.nan(c(1.,NA)))
+all(c(FALSE,TRUE,FALSE) == is.nan(c (1.,NaN,NA)))
+## lists are no longer allowed
+## all(c(FALSE,TRUE,FALSE) == is.nan(list(1.,NaN,NA)))
+
+
+## log() and "pow()" -- POSIX is not specific enough..
+log(0) == -Inf
+is.nan(log(-1))# TRUE and warning
+
+rp <- c(1:2,Inf); rn <- rev(- rp)
+r <- c(rn, 0, rp, NA, NaN)
+all(r^0 == 1)
+ir <- suppressWarnings(as.integer(r))
+all(ir^0 == 1)
+all(ir^0L == 1)# not in R <= 2.15.0
+all( 1^r == 1)# not in R 0.64
+all(1L^r == 1)
+all(1L^ir == 1)# not in R <= 2.15.0
+all((rn ^ -3) == -((-rn) ^ -3))
+#
+all(c(1.1,2,Inf) ^ Inf == Inf)
+all(c(1.1,2,Inf) ^ -Inf == 0)
+.9 ^ Inf == 0
+.9 ^ -Inf == Inf
+## Wasn't ok in 0.64:
+all(is.nan(rn ^ .5))# in some C's : (-Inf) ^ .5 gives Inf, instead of NaN
+
+
+## Real Trig.:
+cos(0) == 1
+sin(3*pi/2) == cos(pi)
+x <- rnorm(99)
+all( sin(-x) == - sin(x))
+all( cos(-x) == cos(x))
+
+x <- 1:99/100
+all(abs(1 - x / asin(sin(x))) <= 2*Meps)# "== 2*" for HP-UX
+all(abs(1 - x / atan(tan(x))) < 2*Meps)
+
+## Sun has asin(.) = acos(.) = 0 for these:
+## is.nan(acos(1.1)) && is.nan(asin(-2)) [!]
+
+## gamma()
+abs(gamma(1/2)^2 - pi) < 4* Meps
+r <- rlnorm(5000) # NB random, and next has failed for some seed
+all(abs(rErr(gamma(r+1), r*gamma(r))) < 500 * Meps)
+## more accurate for integers n <= 50 since R 1.8.0 Sol8: perfect
+n <- 20; all( gamma(1:n) == cumprod(c(1,1:(n-1))))# Lnx: up too n=28
+n <- 50; all(abs(rErr( gamma(1:n), cumprod(c(1,1:(n-1))))) < 20*Meps)#Lnx: f=2
+n <- 120; all(abs(rErr( gamma(1:n), cumprod(c(1,1:(n-1))))) < 1000*Meps)
+n <- 10000;all(abs(rErr(lgamma(1:n),cumsum(log(c(1,1:(n-1)))))) < 100*Meps)
+
+n <- 10; all( gamma(1:n) == cumprod(c(1,1:(n-1))))
+n <- 20; all(abs(rErr( gamma(1:n), cumprod(c(1,1:(n-1))))) < 100*Meps)
+n <- 120; all(abs(rErr( gamma(1:n), cumprod(c(1,1:(n-1))))) < 1000*Meps)
+n <- 10000;all(abs(rErr(lgamma(1:n),cumsum(log(c(1,1:(n-1)))))) < 100*Meps)
+
+all(is.nan(gamma(0:-47))) # + warn.
+
+## choose() {and lchoose}:
+n51 <- c(196793068630200, 229591913401900, 247959266474052)
+abs(c(n51, rev(n51))- choose(51, 23:28)) <= 2
+all(choose(0:4,2) == c(0,0,1,3,6))
+## 3 to 8 units off and two NaN's in 1.8.1
+
+## psi[gamma](x) and derivatives:
+## psi == digamma:
+gEuler <- 0.577215664901532860606512# = Euler's gamma
+abs(digamma(1) + gEuler) < 32*Meps # i386 Lx: = 2.5*Meps
+all.equal(digamma(1) - digamma(1/2), log(4), tolerance = 32*Meps)# Linux: < 1*Meps!
+n <- 1:12
+all.equal(digamma(n),
+ - gEuler + c(0, cumsum(1/n)[-length(n)]),tolerance = 32*Meps)#i386 Lx: 1.3 Meps
+all.equal(digamma(n + 1/2),
+ - gEuler - log(4) + 2*cumsum(1/(2*n-1)),tolerance = 32*Meps)#i386 Lx: 1.8 Meps
+## higher psigamma:
+all.equal(psigamma(1, deriv=c(1,3,5)),
+ pi^(2*(1:3)) * c(1/6, 1/15, 8/63), tolerance = 32*Meps)
+x <- c(-100,-3:2, -99.9, -7.7, seq(-3,3, length=61), 5.1, 77)
+## Intel icc showed a < 1ulp difference in the second.
+stopifnot(all.equal( digamma(x), psigamma(x,0), tolerance = 2*Meps),
+ all.equal(trigamma(x), psigamma(x,1), tolerance = 2*Meps))# TRUE (+ NaN warnings)
+## very large x:
+x <- 1e30 ^ (1:10)
+a.relE <- function(appr, true) abs(1 - appr/true)
+stopifnot(a.relE(digamma(x), log(x)) < 1e-13,
+ a.relE(trigamma(x), 1/x) < 1e-13)
+x <- sqrt(x[2:6]); stopifnot(a.relE(psigamma(x,2), - 1/x^2) < 1e-13)
+x <- 10^(10*(2:6));stopifnot(a.relE(psigamma(x,5), +24/x^5) < 1e-13)
+
+## fft():
+ok <- TRUE
+##test EXTENSIVELY: for(N in 1:100) {
+ cat(".")
+ for(n in c(1:30, 1000:1050)) {
+ x <- rnorm(n)
+ er <- Mod(rErr(fft(fft(x), inverse = TRUE)/n, x*(1+0i)))
+ n.ok <- all(er < 1e-8) & quantile(er, 0.95, names=FALSE) < 10000*Meps
+ if(!n.ok) cat("\nn=",n,": quantile(rErr, c(.95,1)) =",
+ formatC(quantile(er, prob= c(.95,1))),"\n")
+ ok <- ok & n.ok
+ }
+ cat("\n")
+##test EXTENSIVELY: }
+ok
+
+## var():
+for(n in 2:10)
+ print(all.equal(n*(n-1)*var(diag(n)),
+ matrix(c(rep(c(n-1,rep(-1,n)),n-1), n-1), nr=n, nc=n),
+ tolerance = 20*Meps)) # use tolerance = 0 to see rel.error
+
+## pmin() & pmax() -- "attributes" !
+v1 <- c(a=2)
+m1 <- cbind( 2:4,3)
+m2 <- cbind(a=2:4,2)
+
+all( pmax(v1, 1:3) == pmax(1:3, v1) & pmax(1:3, v1) == c(2,2,3))
+all( pmin(v1, 1:3) == pmin(1:3, v1) & pmin(1:3, v1) == c(1,2,2))
+
+oo <- options(warn = -1)# These four lines each would give 3-4 warnings :
+ all( pmax(m1, 1:7) == pmax(1:7, m1) & pmax(1:7, m1) == c(2:4,4:7))
+ all( pmin(m1, 1:7) == pmin(1:7, m1) & pmin(1:7, m1) == c(1:3,3,3,3,2))
+ all( pmax(m2, 1:7) == pmax(1:7, m2) & pmax(1:7, m2) == pmax(1:7, m1))
+ all( pmin(m2, 1:7) == pmin(1:7, m2) & pmin(1:7, m2) == c(1:3,2,2,2,2))
+options(oo)
+
+## pretty()
+stopifnot(pretty(1:15) == seq(0,16, by=2),
+ pretty(1:15, h=2) == seq(0,15, by=5),
+ pretty(1) == 0:1,
+ pretty(pi) == c(2,4),
+ pretty(pi, n=6) == 2:4,
+ pretty(pi, n=10) == 2:5,
+ pretty(pi, shr=.1)== c(3, 3.5))
+
+## gave infinite loop [R 0.64; Solaris], seealso PR#390 :
+all(pretty((1-1e-5)*c(1,1+3*Meps), 7) == seq(0,1,len=3))
+
+n <- 1000
+x12 <- matrix(NA, 2,n); x12[,1] <- c(2.8,3) # Bug PR#673
+for(j in 1:2) x12[j, -1] <- round(rnorm(n-1), dig = rpois(n-1, lam=3.5) - 2)
+for(i in 1:n) {
+ lp <- length(p <- pretty(x <- sort(x12[,i])))
+ stopifnot(p[1] <= x[1] & x[2] <= p[lp],
+ all(x==0) || all.equal(p, rev(-pretty(-x)), tolerance = 10*Meps))
+}
+
+## PR#741:
+pi != (pi0 <- pi + 2*.Machine$double.eps)
+is.na(match(c(1,pi,pi0), pi)[3])
+
+## PR#749:
+all(is.na(c(NA && TRUE, TRUE && NA, NA && NA,
+ NA || FALSE,FALSE || NA, NA || NA)))
+
+all((c(NA || TRUE, TRUE || NA,
+ !c(NA && FALSE,FALSE && NA))))
+
+
+## not sure what the point of this is: it gives mean(numeric(0)), that is NaN
+(z <- mean(rep(NA_real_, 2), trim = .1, na.rm = TRUE))
+is.na(z)
+
+## Last Line:
+cat('Time elapsed: ', proc.time() - .proctime00,'\n')
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/arith.R b/com.oracle.truffle.r.native/gnur/tests/src/arith.R
new file mode 100644
index 0000000000000000000000000000000000000000..9ee37234dd599c337375d03838ba31527058a73b
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/arith.R
@@ -0,0 +1,26 @@
+options(digits=7)
+
+## powers
+outer(a <- -4:12, -2:7, "^")
+
+for (n1 in 1:7)
+ print(zapsmall(polyroot(1:n1), digits = 10))
+
+## lowess() {incl. sort, etc}:
+options(digits = 5)
+
+lowess(c(3,2,6,3,8,4))$y # this used to differ on Linux
+
+y1 <- c(3,1:2,5:2,4,1:3,3)
+lowess(y1)$y
+lowess(y1, f = .4)$y
+
+lowess(c(y1,100), f = .4)$y
+
+## this is the test sample from Cleveland's original lowess.doc:
+x <- c(1:5, rep(6,10),8,10,12,14,50)
+y <- c(18,2,15,6,10,4,16,11,7,3,14,17,20,12,9,13,1,8,5,19)
+lowess(x,y, f = .25, iter = 0, delta = 0)$y
+lowess(x,y, f = .25, iter = 0, delta = 3)$y
+lowess(x,y, f = .25, iter = 2, delta = 0)$y
+
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/array-subset.R b/com.oracle.truffle.r.native/gnur/tests/src/array-subset.R
new file mode 100644
index 0000000000000000000000000000000000000000..dc539f2a9d13cf093fd6d37f987825533a3e0b9f
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/array-subset.R
@@ -0,0 +1,86 @@
+## array subsetting tests
+##
+## Tests should be written to raise an error on test failure
+##
+
+## Test for subsetting of an array using a matrix with ncol == length(dim(x))
+
+## first matrix case
+m <- matrix(1:25, ncol=5, dimnames = list(letters[1:5], LETTERS[1:5]))
+
+si <- matrix(c(1, 1, 2, 3, 3, 4), ncol = 2, byrow = TRUE)
+ss <- matrix(c("a", "A", "b", "C", "c", "D"), ncol = 2, byrow = TRUE)
+
+stopifnot(identical(m[si], m[ss]))
+stopifnot(identical(c(1L, 12L, 18L), m[ss]))
+
+## test behavior of NA entries in subset matrix.
+## NA in character matrix should propagate and should not
+## match an NA in a dimname.
+
+## An NA in either column propagates to result
+ssna <- ss; ssna[2, 2] <- NA
+stopifnot(identical(c(1L, NA, 18L), m[ssna]))
+ssna <- ss; ssna[2, 1] <- NA
+stopifnot(identical(c(1L, NA, 18L), m[ssna]))
+
+## An NA in row/column names is not matched
+mnadim <- m
+tmp <- rownames(mnadim)
+tmp[5] <- NA
+rownames(mnadim) <- tmp
+stopifnot(identical(c(1L, NA, 18L), m[ssna]))
+
+## Unmatched subscripts raise an error
+ssnm <- ss
+ssnm[2, 2] <- "NOMATCH"
+stopifnot(inherits(try(m[ssnm], silent=TRUE), "try-error"))
+
+## "" does not match and so raises an error
+mnadim <- m
+tmp <- rownames(mnadim)
+tmp[5] <- ""
+rownames(mnadim) <- tmp
+ssnm <- ss
+ssnm[2, 2] <- ""
+stopifnot(inherits(try(mnadim[ssnm], silent=TRUE), "try-error"))
+
+
+## test assignment
+m3 <- m2 <- m
+m2[si] <- c(100L, 200L, 300L)
+m3[ss] <- c(100L, 200L, 300L)
+stopifnot(identical(m2, m3))
+
+## now an array case
+a <- array(1:75, dim = c(5, 5, 3),
+ dimnames = list(letters[1:5], LETTERS[1:5], letters[24:26]))
+
+si <- matrix(c(1, 1, 1,
+ 2, 3, 1,
+ 3, 4, 1,
+ 5, 1, 3),
+ ncol = 3, byrow = TRUE)
+
+ss <- matrix(c("a", "A", "x",
+ "b", "C", "x",
+ "c", "D", "x",
+ "e", "A", "z"),
+ ncol = 3, byrow = TRUE)
+
+stopifnot(identical(a[si], a[ss]))
+stopifnot(identical(c(1L, 12L, 18L, 55L), a[ss]))
+
+a2 <- a1 <- a
+a1[si] <- c(100L, 1200L, 1800L, 5500L)
+a2[ss] <- c(100L, 1200L, 1800L, 5500L)
+stopifnot(identical(a1, a2))
+
+## it is an error to subset if some dimnames are missing NOTE: this
+## gives a subscript out of bounds error, might want something more
+## informative?
+a3 <- a
+dn <- dimnames(a3)
+dn[2] <- list(NULL)
+dimnames(a3) <- dn
+stopifnot(inherits(try(a3[ss], silent=TRUE), "try-error"))
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/complex.R b/com.oracle.truffle.r.native/gnur/tests/src/complex.R
new file mode 100644
index 0000000000000000000000000000000000000000..42a5dc0a20497f896b607d94544c599af79e8f3a
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/complex.R
@@ -0,0 +1,159 @@
+### Tests of complex arithemetic.
+
+Meps <- .Machine$double.eps
+## complex
+z <- 0i ^ (-3:3)
+stopifnot(Re(z) == 0 ^ (-3:3))
+
+
+## powers, including complex ones
+a <- -4:12
+m <- outer(a +0i, b <- seq(-.5,2, by=.5), "^")
+dimnames(m) <- list(paste(a), "^" = sapply(b,format))
+round(m,3)
+stopifnot(m[,as.character(0:2)] == cbind(1,a,a*a),
+ # latter were only approximate
+ all.equal(unname(m[,"0.5"]),
+ sqrt(abs(a))*ifelse(a < 0, 1i, 1),
+ tolerance = 20*Meps))
+
+## 2.10.0-2.12.1 got z^n wrong in the !HAVE_C99_COMPLEX case
+z <- 0.2853725+0.3927816i
+z2 <- z^(1:20)
+z3 <- z^-(1:20)
+z0 <- cumprod(rep(z, 20))
+stopifnot(all.equal(z2, z0), all.equal(z3, 1/z0))
+## was z^3 had value z^2 ....
+
+## fft():
+for(n in 1:30) cat("\nn=",n,":", round(fft(1:n), 8),"\n")
+
+
+## polyroot():
+stopifnot(abs(1 + polyroot(choose(8, 0:8))) < 1e-10)# maybe smaller..
+
+## precision of complex numbers
+signif(1.678932e80+0i, 5)
+signif(1.678932e-300+0i, 5)
+signif(1.678932e-302+0i, 5)
+signif(1.678932e-303+0i, 5)
+signif(1.678932e-304+0i, 5)
+signif(1.678932e-305+0i, 5)
+signif(1.678932e-306+0i, 5)
+signif(1.678932e-307+0i, 5)
+signif(1.678932e-308+0i, 5)
+signif(1.678932-1.238276i, 5)
+signif(1.678932-1.238276e-1i, 5)
+signif(1.678932-1.238276e-2i, 5)
+signif(1.678932-1.238276e-3i, 5)
+signif(1.678932-1.238276e-4i, 5)
+signif(1.678932-1.238276e-5i, 5)
+signif(8.678932-9.238276i, 5)
+## prior to 2.2.0 rounded real and imaginary parts separately.
+
+
+## Complex Trig.:
+abs(Im(cos(acos(1i))) - 1) < 2*Meps
+abs(Im(sin(asin(1i))) - 1) < 2*Meps
+##P (1 - Im(sin(asin(Ii))))/Meps
+##P (1 - Im(cos(acos(Ii))))/Meps
+abs(Im(asin(sin(1i))) - 1) < 2*Meps
+all.equal(cos(1i), cos(-1i)) # i.e. Im(acos(*)) gives + or - 1i:
+abs(abs(Im(acos(cos(1i)))) - 1) < 4*Meps
+
+
+set.seed(123) # want reproducible output
+Isi <- Im(sin(asin(1i + rnorm(100))))
+all(abs(Isi-1) < 100* Meps)
+##P table(2*abs(Isi-1) / Meps)
+Isi <- Im(cos(acos(1i + rnorm(100))))
+all(abs(Isi-1) < 100* Meps)
+##P table(2*abs(Isi-1) / Meps)
+Isi <- Im(atan(tan(1i + rnorm(100)))) #-- tan(atan(..)) does NOT work (Math!)
+all(abs(Isi-1) < 100* Meps)
+##P table(2*abs(Isi-1) / Meps)
+
+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 * Meps)
+## end of moved from complex.Rd
+
+
+## PR#7781
+## This is not as given by e.g. glibc on AMD64
+(z <- tan(1+1000i)) # 0+1i from R's own code.
+stopifnot(is.finite(z))
+##
+
+
+## Branch cuts in complex inverse trig functions
+atan(2)
+atan(2+0i)
+tan(atan(2+0i))
+## should not expect exactly 0i in result
+round(atan(1.0001+0i), 7)
+round(atan(0.9999+0i), 7)
+## previously not as in Abramowitz & Stegun.
+
+
+## typo in z_atan2.
+(z <- atan2(0+1i, 0+0i))
+stopifnot(all.equal(z, pi/2+0i))
+## was NA in 2.1.1
+
+
+## Hyperbolic
+x <- seq(-3, 3, len=200)
+Meps <- .Machine$double.eps
+stopifnot(
+ Mod(cosh(x) - cos(1i*x)) < 20*Meps,
+ Mod(sinh(x) - sin(1i*x)/1i) < 20*Meps
+)
+## end of moved from Hyperbolic.Rd
+
+## values near and on branch cuts
+options(digits=5)
+z <- c(2+0i, 2-0.0001i, -2+0i, -2+0.0001i)
+asin(z)
+acos(z)
+atanh(z)
+z <- c(0+2i, 0.0001+2i, 0-2i, -0.0001i-2i)
+asinh(z)
+acosh(z)
+atan(z)
+## According to C99, should have continuity from the side given if there
+## are not signed zeros.
+## Both glibc 2.12 and macOS 10.6 used continuity from above in the first set
+## but they seem to assume signed zeros.
+## Windows gave incorrect (NaN) values on the cuts.
+
+stopifnot(identical(tanh(356+0i), 1+0i))
+## Used to be NaN+0i on Windows
+
+## Not a regression test, but rather one of the good cases:
+(cNaN <- as.complex("NaN"))
+stopifnot(identical(cNaN, complex(re = NaN)), is.nan(Re(cNaN)), Im(cNaN) == 0)
+dput(cNaN) ## (real = NaN, imaginary = 0)
+## Partly new behavior:
+(c0NaN <- complex(real=0, im=NaN))
+(cNaNaN <- complex(re=NaN, im=NaN))
+stopifnot(identical(cNaN, as.complex(NaN)),
+ identical(vapply(c(cNaN, c0NaN, cNaNaN), format, ""),
+ c("NaN+0i", "0+NaNi", "NaN+NaNi")),
+ identical(cNaN, NaN + 0i),
+ identical(cNaN, Conj(cNaN)),
+ identical(cNaN, cNaN+cNaN),
+
+ identical(cNaNaN, 1i * NaN),
+ identical(cNaNaN, complex(modulus= NaN)),
+ identical(cNaNaN, complex(argument= NaN)),
+ identical(cNaNaN, complex(arg=NaN, mod=NaN)),
+
+ identical(c0NaN, c0NaN+c0NaN), # !
+ ## Platform dependent, not TRUE e.g. on F21 gcc 4.9.2:
+ ## identical(NA_complex_, NaN + NA_complex_ ) ,
+ ## Probably TRUE, but by a standard ??
+ ## identical(cNaNaN, 2 * c0NaN), # C-library arithmetic
+ ## identical(cNaNaN, 2 * cNaN), # C-library arithmetic
+ ## identical(cNaNaN, NA_complex_ * Inf),
+ TRUE)
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/d-p-q-r-tests.R b/com.oracle.truffle.r.native/gnur/tests/src/d-p-q-r-tests.R
new file mode 100644
index 0000000000000000000000000000000000000000..ace834bb4c5d61b9cd880d3d92583945fe803b12
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/d-p-q-r-tests.R
@@ -0,0 +1,1040 @@
+#### d|ensity
+#### p|robability (cumulative)
+#### q|uantile
+#### r|andom number generation
+####
+#### Functions for ``d/p/q/r''
+
+.ptime <- proc.time()
+F <- FALSE
+T <- TRUE
+
+options(warn = 2)
+## ======== No warnings, unless explicitly asserted via
+assertWarning <- tools::assertWarning
+
+as.nan <- function(x) { x[is.na(x) & !is.nan(x)] <- NaN ; x }
+###-- these are identical in ./arith-true.R ["fixme": use source(..)]
+opt.conformance <- 0
+Meps <- .Machine $ double.eps
+xMax <- .Machine $ double.xmax
+options(rErr.eps = 1e-30)
+rErr <- function(approx, true, eps = getOption("rErr.eps", 1e-30))
+{
+ ifelse(Mod(true) >= eps,
+ 1 - approx / true, # relative error
+ true - approx) # absolute error (e.g. when true=0)
+}
+## Numerical equality: Here want "rel.error" almost always:
+All.eq <- function(x,y) {
+ all.equal.numeric(x,y, tolerance = 64*.Machine$double.eps,
+ scale = max(0, mean(abs(x), na.rm=TRUE)))
+}
+if(!interactive())
+ set.seed(123)
+
+## The prefixes of ALL the PDQ & R functions
+PDQRinteg <- c("binom", "geom", "hyper", "nbinom", "pois","signrank","wilcox")
+PDQR <- c(PDQRinteg, "beta", "cauchy", "chisq", "exp", "f", "gamma",
+ "lnorm", "logis", "norm", "t","unif","weibull")
+PQonly <- c("tukey")
+
+###--- Discrete Distributions --- Consistency Checks pZZ = cumsum(dZZ)
+
+##for(pre in PDQRinteg) { n <- paste("d",pre,sep=""); cat(n,": "); str(get(n))}
+
+##__ 1. Binomial __
+
+## Cumulative Binomial '==' Cumulative F :
+## Abramowitz & Stegun, p.945-6; 26.5.24 AND 26.5.28 :
+n0 <- 50; n1 <- 16; n2 <- 20; n3 <- 8
+for(n in rbinom(n1, size = 2*n0, p = .4)) {
+ for(p in c(0,1,rbeta(n2, 2,4))) {
+ for(k in rbinom(n3, size = n, prob = runif(1)))
+ ## For X ~ Bin(n,p), compute 1 - P[X > k] = P[X <= k] in three ways:
+ stopifnot(all.equal( pbinom(0:k, size = n, prob = p),
+ cumsum(dbinom(0:k, size = n, prob = p))),
+ all.equal(if(k==n || p==0) 1 else
+ pf((k+1)/(n-k)*(1-p)/p, df1=2*(n-k), df2=2*(k+1)),
+ sum(dbinom(0:k, size = n, prob = p))))
+ }
+}
+
+##__ 2. Geometric __
+for(pr in seq(1e-10,1,len=15)) # p=0 is not a distribution
+ stopifnot(All.eq((dg <- dgeom(0:10, pr)),
+ pr * (1-pr)^(0:10)),
+ All.eq(cumsum(dg), pgeom(0:10, pr)))
+
+
+##__ 3. Hypergeometric __
+
+m <- 10; n <- 7
+for(k in 2:m) {
+ x <- 0:(k+1)
+ stopifnot(All.eq(phyper(x, m, n, k), cumsum(dhyper(x, m, n, k))))
+}
+
+##__ 4. Negative Binomial __
+
+## PR #842
+for(size in seq(0.8,2, by=.1))
+ stopifnot(all.equal(cumsum(dnbinom(0:7, size, .5)),
+ pnbinom(0:7, size, .5)))
+stopifnot(All.eq(pnbinom(c(1,3), .9, .5),
+ c(0.777035760338812, 0.946945347071519)))
+
+##__ 5. Poisson __
+
+stopifnot(dpois(0:5,0) == c(1, rep(0,5)),
+ dpois(0:5,0, log=TRUE) == c(0, rep(-Inf, 5)))
+
+## Cumulative Poisson '==' Cumulative Chi^2 :
+## Abramowitz & Stegun, p.941 : 26.4.21 (26.4.2)
+n1 <- 20; n2 <- 16
+for(lambda in rexp(n1))
+ for(k in rpois(n2, lambda))
+ stopifnot(all.equal(1 - pchisq(2*lambda, 2*(1+ 0:k)),
+ pp <- cumsum(dpois(0:k, lambda=lambda)),
+ tolerance = 100*Meps),
+ all.equal(pp, ppois(0:k, lambda=lambda), tolerance = 100*Meps),
+ all.equal(1 - pp, ppois(0:k, lambda=lambda, lower.tail = FALSE)))
+
+
+##__ 6. SignRank __
+for(n in rpois(32, lam=8)) {
+ x <- -1:(n + 4)
+ stopifnot(All.eq(psignrank(x, n), cumsum(dsignrank(x, n))))
+}
+
+##__ 7. Wilcoxon (symmetry & cumulative) __
+is.sym <- TRUE
+for(n in rpois(5, lam=6))
+ for(m in rpois(15, lam=8)) {
+ x <- -1:(n*m + 1)
+ fx <- dwilcox(x, n, m)
+ Fx <- pwilcox(x, n, m)
+ is.sym <- is.sym & all(fx == dwilcox(x, m, n))
+ stopifnot(All.eq(Fx, cumsum(fx)))
+ }
+stopifnot(is.sym)
+
+
+###-------- Continuous Distributions ----------
+
+##--- Gamma (incl. central chi^2) Density :
+x <- round(rgamma(100, shape = 2),2)
+for(sh in round(rlnorm(30),2)) {
+ Ga <- gamma(sh)
+ for(sig in round(rlnorm(30),2))
+ stopifnot(all.equal((d1 <- dgamma( x, shape = sh, scale = sig)),
+ (d2 <- dgamma(x/sig, shape = sh, scale = 1) / sig),
+ tolerance = 1e-14)## __ad interim__ was 1e-15
+ ,
+ All.eq(d1, (d3 <- 1/(Ga * sig^sh) * x^(sh-1) * exp(-x/sig)))
+ )
+}
+
+stopifnot(pgamma(1,Inf,scale=Inf) == 0)
+## Also pgamma(Inf,Inf) == 1 for which NaN was slightly more appropriate
+assertWarning(stopifnot(
+ is.nan(c(pgamma(Inf, 1,scale=Inf),
+ pgamma(Inf,Inf,scale=Inf)))))
+scLrg <- c(2,100, 1e300*c(.1, 1,10,100), 1e307, xMax, Inf)
+stopifnot(pgamma(Inf, 1, scale=xMax) == 1,
+ pgamma(xMax,1, scale=Inf) == 0,
+ all.equal(pgamma(1e300, 2, scale= scLrg, log=TRUE),
+ c(0, 0, -0.000499523968713701, -1.33089326820406,
+ -5.36470502873211, -9.91015144019122,
+ -32.9293385491433, -38.707517174609, -Inf),
+ tolerance = 2e-15)
+ )
+
+p <- 7e-4; df <- 0.9
+stopifnot(
+abs(1-c(pchisq(qchisq(p, df),df)/p, # was 2.31e-8 for R <= 1.8.1
+ pchisq(qchisq(1-p, df,lower=FALSE),df,lower=FALSE)/(1-p),# was 1.618e-11
+ pchisq(qchisq(log(p), df,log=TRUE),df, log=TRUE)/log(p), # was 3.181e-9
+ pchisq(qchisq(log1p(-p),df,log=T,lower=F),df, log=T,lower=F)/log1p(-p)
+ )# 32b-i386: (2.2e-16, 0,0, 3.3e-16); Opteron: (2.2e-16, 0,0, 2.2e-15)
+ ) < 1e-14
+)
+
+##-- non central Chi^2 :
+xB <- c(2000,1e6,1e50,Inf)
+for(df in c(0.1, 1, 10))
+ for(ncp in c(0, 1, 10, 100)) stopifnot(pchisq(xB, df=df, ncp=ncp) == 1)
+stopifnot(all.equal(qchisq(0.025,31,ncp=1,lower.tail=FALSE),# inf.loop PR#875
+ 49.7766246561514, tolerance = 1e-11))
+for(df in c(0.1, 0.5, 1.5, 4.7, 10, 20,50,100)) {
+ xx <- c(10^-(5:1), .9, 1.2, df + c(3,7,20,30,35,38))
+ pp <- pchisq(xx, df=df, ncp = 1) #print(pp)
+ dtol <- 1e-12 *(if(2 < df && df <= 50) 64 else if(df > 50) 20000 else 501)
+ stopifnot(all.equal(xx, qchisq(pp, df=df, ncp=1), tolerance = dtol))
+}
+
+## p ~= 1 (<==> 1-p ~= 0) -- gave infinite loop in R <= 1.8.1 -- PR#6421
+psml <- 2^-(10:54)
+q0 <- qchisq(psml, df=1.2, ncp=10, lower.tail=FALSE)
+q1 <- qchisq(1-psml, df=1.2, ncp=10) # inaccurate in the tail
+p0 <- pchisq(q0, df=1.2, ncp=10, lower.tail=FALSE)
+p1 <- pchisq(q1, df=1.2, ncp=10, lower.tail=FALSE)
+iO <- 1:30
+stopifnot(all.equal(q0[iO], q1[iO], tolerance = 1e-5),# 9.86e-8
+ all.equal(p0[iO], psml[iO])) # 1.07e-13
+
+##--- Beta (need more):
+
+## big a & b (PR #643)
+stopifnot(is.finite(a <- rlnorm(20, 5.5)), a > 0,
+ is.finite(b <- rlnorm(20, 6.5)), b > 0)
+pab <- expand.grid(seq(0,1,by=.1), a, b)
+p <- pab[,1]; a <- pab[,2]; b <- pab[,3]
+stopifnot(all.equal(dbeta(p,a,b),
+ exp(pab <- dbeta(p,a,b, log = TRUE)), tolerance = 1e-11))
+sp <- sample(pab, 50)
+if(!interactive())
+stopifnot(which(isI <- sp == -Inf) ==
+ c(3, 11, 15, 20, 22, 23, 30, 39, 42, 43, 46, 47, 49),
+ all.equal(range(sp[!isI]), c(-2906.123981, 2.197270387))
+ )
+
+
+##--- Normal (& Lognormal) :
+
+stopifnot(
+ qnorm(0) == -Inf, qnorm(-Inf, log = TRUE) == -Inf,
+ qnorm(1) == Inf, qnorm( 0, log = TRUE) == Inf)
+
+assertWarning(stopifnot(
+ is.nan(qnorm(1.1)),
+ is.nan(qnorm(-.1))))
+
+x <- c(-Inf, -1e100, 1:6, 1e200, Inf)
+stopifnot(
+ dnorm(x,3,s=0) == c(0,0,0,0, Inf, 0,0,0,0,0),
+ pnorm(x,3,s=0) == c(0,0,0,0, 1 , 1,1,1,1,1),
+ dnorm(x,3,s=Inf) == 0,
+ pnorm(x,3,s=Inf) == c(0, rep(0.5, 8), 1))
+
+## 3 Test data from Wichura (1988) :
+stopifnot(
+ all.equal(qnorm(c( 0.25, .001, 1e-20)),
+ c(-0.6744897501960817, -3.090232306167814, -9.262340089798408),
+ tolerance = 1e-15)
+ , ## extreme tail -- available on log scale only:
+ all.equal(qnorm(-1e5, log = TRUE), -447.1974945)
+)
+
+z <- rnorm(1000); all.equal(pnorm(z), 1 - pnorm(-z), tolerance = 1e-15)
+z <- c(-Inf,Inf,NA,NaN, rt(1000, df=2))
+z.ok <- z > -37.5 | !is.finite(z)
+for(df in 1:10) stopifnot(all.equal(pt(z, df), 1 - pt(-z,df), tolerance = 1e-15))
+
+stopifnot(All.eq(pz <- pnorm(z), 1 - pnorm(z, lower=FALSE)),
+ All.eq(pz, pnorm(-z, lower=FALSE)),
+ All.eq(log(pz[z.ok]), pnorm(z[z.ok], log=TRUE)))
+y <- seq(-70,0, by = 10)
+cbind(y, "log(pnorm(y))"= log(pnorm(y)), "pnorm(y, log=T)"= pnorm(y, log=TRUE))
+y <- c(1:15, seq(20,40, by=5))
+cbind(y, "log(pnorm(y))"= log(pnorm(y)), "pnorm(y, log=T)"= pnorm(y, log=TRUE),
+ "log(pnorm(-y))"= log(pnorm(-y)), "pnorm(-y, log=T)"= pnorm(-y, log=TRUE))
+## Symmetry:
+y <- c(1:50,10^c(3:10,20,50,150,250))
+y <- c(-y,0,y)
+for(L in c(FALSE,TRUE))
+ stopifnot(identical(pnorm(-y, log= L),
+ pnorm(+y, log= L, lower=FALSE)))
+
+## Log norm
+stopifnot(All.eq(pz, plnorm(exp(z))))
+
+
+###========== p <-> q Inversion consistency =====================
+ok <- 1e-5 < pz & pz < 1 - 1e-5
+all.equal(z[ok], qnorm(pz[ok]), tolerance = 1e-12)
+
+###===== Random numbers -- first, just output:
+
+set.seed(123)
+# .Random.seed <- c(0L, 17292L, 29447L, 24113L)
+n <- 20
+## for(pre in PDQR) { n <- paste("r",pre,sep=""); cat(n,": "); str(get(n))}
+(Rbeta <- rbeta (n, shape1 = .8, shape2 = 2) )
+(Rbinom <- rbinom (n, size = 55, prob = pi/16) )
+(Rcauchy <- rcauchy (n, location = 12, scale = 2) )
+(Rchisq <- rchisq (n, df = 3) )
+(Rexp <- rexp (n, rate = 2) )
+(Rf <- rf (n, df1 = 12, df2 = 6) )
+(Rgamma <- rgamma (n, shape = 2, scale = 5) )
+(Rgeom <- rgeom (n, prob = pi/16) )
+(Rhyper <- rhyper (n, m = 40, n = 30, k = 20) )
+(Rlnorm <- rlnorm (n, meanlog = -1, sdlog = 3) )
+(Rlogis <- rlogis (n, location = 12, scale = 2) )
+(Rnbinom <- rnbinom (n, size = 7, prob = .01) )
+(Rnorm <- rnorm (n, mean = -1, sd = 3) )
+(Rpois <- rpois (n, lambda = 12) )
+(Rsignrank<- rsignrank(n, n = 47) )
+(Rt <- rt (n, df = 11) )
+## Rt2 below (to preserve the following random numbers!)
+(Runif <- runif (n, min = .2, max = 2) )
+(Rweibull <- rweibull (n, shape = 3, scale = 2) )
+(Rwilcox <- rwilcox (n, m = 13, n = 17) )
+(Rt2 <- rt (n, df = 1.01))
+
+(Pbeta <- pbeta (Rbeta, shape1 = .8, shape2 = 2) )
+(Pbinom <- pbinom (Rbinom, size = 55, prob = pi/16) )
+(Pcauchy <- pcauchy (Rcauchy, location = 12, scale = 2) )
+(Pchisq <- pchisq (Rchisq, df = 3) )
+(Pexp <- pexp (Rexp, rate = 2) )
+(Pf <- pf (Rf, df1 = 12, df2 = 6) )
+(Pgamma <- pgamma (Rgamma, shape = 2, scale = 5) )
+(Pgeom <- pgeom (Rgeom, prob = pi/16) )
+(Phyper <- phyper (Rhyper, m = 40, n = 30, k = 20) )
+(Plnorm <- plnorm (Rlnorm, meanlog = -1, sdlog = 3) )
+(Plogis <- plogis (Rlogis, location = 12, scale = 2) )
+(Pnbinom <- pnbinom (Rnbinom, size = 7, prob = .01) )
+(Pnorm <- pnorm (Rnorm, mean = -1, sd = 3) )
+(Ppois <- ppois (Rpois, lambda = 12) )
+(Psignrank<- psignrank(Rsignrank, n = 47) )
+(Pt <- pt (Rt, df = 11) )
+(Pt2 <- pt (Rt2, df = 1.01) )
+(Punif <- punif (Runif, min = .2, max = 2) )
+(Pweibull <- pweibull (Rweibull, shape = 3, scale = 2) )
+(Pwilcox <- pwilcox (Rwilcox, m = 13, n = 17) )
+
+dbeta (Rbeta, shape1 = .8, shape2 = 2)
+dbinom (Rbinom, size = 55, prob = pi/16)
+dcauchy (Rcauchy, location = 12, scale = 2)
+dchisq (Rchisq, df = 3)
+dexp (Rexp, rate = 2)
+df (Rf, df1 = 12, df2 = 6)
+dgamma (Rgamma, shape = 2, scale = 5)
+dgeom (Rgeom, prob = pi/16)
+dhyper (Rhyper, m = 40, n = 30, k = 20)
+dlnorm (Rlnorm, meanlog = -1, sdlog = 3)
+dlogis (Rlogis, location = 12, scale = 2)
+dnbinom (Rnbinom, size = 7, prob = .01)
+dnorm (Rnorm, mean = -1, sd = 3)
+dpois (Rpois, lambda = 12)
+dsignrank(Rsignrank, n = 47)
+dt (Rt, df = 11)
+dunif (Runif, min = .2, max = 2)
+dweibull (Rweibull, shape = 3, scale = 2)
+dwilcox (Rwilcox, m = 13, n = 17)
+
+## Check q*(p*(.)) = identity
+All.eq(Rbeta, qbeta (Pbeta, shape1 = .8, shape2 = 2))
+All.eq(Rbinom, qbinom (Pbinom, size = 55, prob = pi/16))
+All.eq(Rcauchy, qcauchy (Pcauchy, location = 12, scale = 2))
+All.eq(Rchisq, qchisq (Pchisq, df = 3))
+All.eq(Rexp, qexp (Pexp, rate = 2))
+All.eq(Rf, qf (Pf, df1 = 12, df2 = 6))
+All.eq(Rgamma, qgamma (Pgamma, shape = 2, scale = 5))
+All.eq(Rgeom, qgeom (Pgeom, prob = pi/16))
+All.eq(Rhyper, qhyper (Phyper, m = 40, n = 30, k = 20))
+All.eq(Rlnorm, qlnorm (Plnorm, meanlog = -1, sdlog = 3))
+All.eq(Rlogis, qlogis (Plogis, location = 12, scale = 2))
+All.eq(Rnbinom, qnbinom (Pnbinom, size = 7, prob = .01))
+All.eq(Rnorm, qnorm (Pnorm, mean = -1, sd = 3))
+All.eq(Rpois, qpois (Ppois, lambda = 12))
+All.eq(Rsignrank, qsignrank(Psignrank, n = 47))
+All.eq(Rt, qt (Pt, df = 11))
+All.eq(Rt2, qt (Pt2, df = 1.01))
+All.eq(Runif, qunif (Punif, min = .2, max = 2))
+All.eq(Rweibull, qweibull (Pweibull, shape = 3, scale = 2))
+All.eq(Rwilcox, qwilcox (Pwilcox, m = 13, n = 17))
+
+## Same with "upper tail":
+All.eq(Rbeta, qbeta (1- Pbeta, shape1 = .8, shape2 = 2, lower=F))
+All.eq(Rbinom, qbinom (1- Pbinom, size = 55, prob = pi/16, lower=F))
+All.eq(Rcauchy, qcauchy (1- Pcauchy, location = 12, scale = 2, lower=F))
+All.eq(Rchisq, qchisq (1- Pchisq, df = 3, lower=F))
+All.eq(Rexp, qexp (1- Pexp, rate = 2, lower=F))
+All.eq(Rf, qf (1- Pf, df1 = 12, df2 = 6, lower=F))
+All.eq(Rgamma, qgamma (1- Pgamma, shape = 2, scale = 5, lower=F))
+All.eq(Rgeom, qgeom (1- Pgeom, prob = pi/16, lower=F))
+All.eq(Rhyper, qhyper (1- Phyper, m = 40, n = 30, k = 20, lower=F))
+All.eq(Rlnorm, qlnorm (1- Plnorm, meanlog = -1, sdlog = 3, lower=F))
+All.eq(Rlogis, qlogis (1- Plogis, location = 12, scale = 2, lower=F))
+All.eq(Rnbinom, qnbinom (1- Pnbinom, size = 7, prob = .01, lower=F))
+All.eq(Rnorm, qnorm (1- Pnorm, mean = -1, sd = 3,lower=F))
+All.eq(Rpois, qpois (1- Ppois, lambda = 12, lower=F))
+All.eq(Rsignrank, qsignrank(1- Psignrank, n = 47, lower=F))
+All.eq(Rt, qt (1- Pt, df = 11, lower=F))
+All.eq(Rt2, qt (1- Pt2, df = 1.01, lower=F))
+All.eq(Runif, qunif (1- Punif, min = .2, max = 2, lower=F))
+All.eq(Rweibull, qweibull (1- Pweibull, shape = 3, scale = 2, lower=F))
+All.eq(Rwilcox, qwilcox (1- Pwilcox, m = 13, n = 17, lower=F))
+
+## Check q*(p* ( log ), log) = identity
+All.eq(Rbeta, qbeta (log(Pbeta), shape1 = .8, shape2 = 2, log=TRUE))
+All.eq(Rbinom, qbinom (log(Pbinom), size = 55, prob = pi/16, log=TRUE))
+All.eq(Rcauchy, qcauchy (log(Pcauchy), location = 12, scale = 2, log=TRUE))
+All.eq(Rchisq, qchisq (log(Pchisq), df = 3, log=TRUE))
+All.eq(Rexp, qexp (log(Pexp), rate = 2, log=TRUE))
+All.eq(Rf, qf (log(Pf), df1= 12, df2= 6, log=TRUE))
+All.eq(Rgamma, qgamma (log(Pgamma), shape = 2, scale = 5, log=TRUE))
+All.eq(Rgeom, qgeom (log(Pgeom), prob = pi/16, log=TRUE))
+All.eq(Rhyper, qhyper (log(Phyper), m = 40, n = 30, k = 20, log=TRUE))
+All.eq(Rlnorm, qlnorm (log(Plnorm), meanlog = -1, sdlog = 3, log=TRUE))
+All.eq(Rlogis, qlogis (log(Plogis), location = 12, scale = 2, log=TRUE))
+All.eq(Rnbinom, qnbinom (log(Pnbinom), size = 7, prob = .01, log=TRUE))
+All.eq(Rnorm, qnorm (log(Pnorm), mean = -1, sd = 3, log=TRUE))
+All.eq(Rpois, qpois (log(Ppois), lambda = 12, log=TRUE))
+All.eq(Rsignrank, qsignrank(log(Psignrank), n = 47, log=TRUE))
+All.eq(Rt, qt (log(Pt), df = 11, log=TRUE))
+All.eq(Rt2, qt (log(Pt2), df = 1.01, log=TRUE))
+All.eq(Runif, qunif (log(Punif), min = .2, max = 2, log=TRUE))
+All.eq(Rweibull, qweibull (log(Pweibull), shape = 3, scale = 2, log=TRUE))
+All.eq(Rwilcox, qwilcox (log(Pwilcox), m = 13, n = 17, log=TRUE))
+
+## same q*(p* (log) log) with upper tail:
+
+All.eq(Rbeta, qbeta (log1p(-Pbeta), shape1 = .8, shape2 = 2, lower=F, log=T))
+All.eq(Rbinom, qbinom (log1p(-Pbinom), size = 55, prob = pi/16, lower=F, log=T))
+All.eq(Rcauchy, qcauchy (log1p(-Pcauchy), location = 12, scale = 2, lower=F, log=T))
+All.eq(Rchisq, qchisq (log1p(-Pchisq), df = 3, lower=F, log=T))
+All.eq(Rexp, qexp (log1p(-Pexp), rate = 2, lower=F, log=T))
+All.eq(Rf, qf (log1p(-Pf), df1 = 12, df2 = 6, lower=F, log=T))
+All.eq(Rgamma, qgamma (log1p(-Pgamma), shape = 2, scale = 5, lower=F, log=T))
+All.eq(Rgeom, qgeom (log1p(-Pgeom), prob = pi/16, lower=F, log=T))
+All.eq(Rhyper, qhyper (log1p(-Phyper), m = 40, n = 30, k = 20, lower=F, log=T))
+All.eq(Rlnorm, qlnorm (log1p(-Plnorm), meanlog = -1, sdlog = 3, lower=F, log=T))
+All.eq(Rlogis, qlogis (log1p(-Plogis), location = 12, scale = 2, lower=F, log=T))
+All.eq(Rnbinom, qnbinom (log1p(-Pnbinom), size = 7, prob = .01, lower=F, log=T))
+All.eq(Rnorm, qnorm (log1p(-Pnorm), mean = -1, sd = 3, lower=F, log=T))
+All.eq(Rpois, qpois (log1p(-Ppois), lambda = 12, lower=F, log=T))
+All.eq(Rsignrank, qsignrank(log1p(-Psignrank), n = 47, lower=F, log=T))
+All.eq(Rt, qt (log1p(-Pt ), df = 11, lower=F, log=T))
+All.eq(Rt2, qt (log1p(-Pt2), df = 1.01, lower=F, log=T))
+All.eq(Runif, qunif (log1p(-Punif), min = .2, max = 2, lower=F, log=T))
+All.eq(Rweibull, qweibull (log1p(-Pweibull), shape = 3, scale = 2, lower=F, log=T))
+All.eq(Rwilcox, qwilcox (log1p(-Pwilcox), m = 13, n = 17, lower=F, log=T))
+
+
+## Check log( upper.tail ):
+All.eq(log1p(-Pbeta), pbeta (Rbeta, shape1 = .8, shape2 = 2, lower=F, log=T))
+All.eq(log1p(-Pbinom), pbinom (Rbinom, size = 55, prob = pi/16, lower=F, log=T))
+All.eq(log1p(-Pcauchy), pcauchy (Rcauchy, location = 12, scale = 2, lower=F, log=T))
+All.eq(log1p(-Pchisq), pchisq (Rchisq, df = 3, lower=F, log=T))
+All.eq(log1p(-Pexp), pexp (Rexp, rate = 2, lower=F, log=T))
+All.eq(log1p(-Pf), pf (Rf, df1 = 12, df2 = 6, lower=F, log=T))
+All.eq(log1p(-Pgamma), pgamma (Rgamma, shape = 2, scale = 5, lower=F, log=T))
+All.eq(log1p(-Pgeom), pgeom (Rgeom, prob = pi/16, lower=F, log=T))
+All.eq(log1p(-Phyper), phyper (Rhyper, m = 40, n = 30, k = 20, lower=F, log=T))
+All.eq(log1p(-Plnorm), plnorm (Rlnorm, meanlog = -1, sdlog = 3, lower=F, log=T))
+All.eq(log1p(-Plogis), plogis (Rlogis, location = 12, scale = 2, lower=F, log=T))
+All.eq(log1p(-Pnbinom), pnbinom (Rnbinom, size = 7, prob = .01, lower=F, log=T))
+All.eq(log1p(-Pnorm), pnorm (Rnorm, mean = -1, sd = 3, lower=F, log=T))
+All.eq(log1p(-Ppois), ppois (Rpois, lambda = 12, lower=F, log=T))
+All.eq(log1p(-Psignrank), psignrank(Rsignrank, n = 47, lower=F, log=T))
+All.eq(log1p(-Pt), pt (Rt, df = 11, lower=F, log=T))
+All.eq(log1p(-Pt2), pt (Rt2,df = 1.01, lower=F, log=T))
+All.eq(log1p(-Punif), punif (Runif, min = .2, max = 2, lower=F, log=T))
+All.eq(log1p(-Pweibull), pweibull (Rweibull, shape = 3, scale = 2, lower=F, log=T))
+All.eq(log1p(-Pwilcox), pwilcox (Rwilcox, m = 13, n = 17, lower=F, log=T))
+
+
+### (Extreme) tail tests added more recently:
+All.eq(1, -1e-17/ pexp(qexp(-1e-17, log=TRUE),log=TRUE))
+abs(pgamma(30,100, lower=FALSE, log=TRUE) + 7.3384686328784e-24) < 1e-36
+All.eq(1, pcauchy(-1e20) / 3.18309886183791e-21)
+All.eq(1, pcauchy(+1e15, log=TRUE) / -3.18309886183791e-16)## PR#6756
+x <- 10^(ex <- c(1,2,5*(1:5),50,100,200,300,Inf))
+for(a in x[ex > 10]) ## improve pt() : cbind(x,t= pt(-x, df=1), C=pcauchy(-x))
+ stopifnot(all.equal(pt(-a, df=1), pcauchy(-a), tolerance = 1e-15))
+## for PR#7902:
+ex <- -c(rev(1/x), ex)
+All.eq(-x, qcauchy(pcauchy(-x)))
+All.eq(+x, qcauchy(pcauchy(+x, log=TRUE), log=TRUE))
+All.eq(1/x, pcauchy(qcauchy(1/x)))
+All.eq(ex, pcauchy(qcauchy(ex, log=TRUE), log=TRUE))
+II <- c(-Inf,Inf)
+stopifnot(pcauchy(II) == 0:1, qcauchy(0:1) == II,
+ pcauchy(II, log=TRUE) == c(-Inf,0),
+ qcauchy(c(-Inf,0), log=TRUE) == II)
+## PR#15521 :
+p <- 1 - 1/4096
+stopifnot(all.equal(qcauchy(p), 1303.7970381453319163, tolerance = 1e-14))
+
+pr <- 1e-23 ## PR#6757
+stopifnot(all.equal(pr^ 12, pbinom(11, 12, prob= pr,lower=FALSE),
+ tolerance = 1e-12, scale= 1e-270))
+## pbinom(.) gave 0 in R 1.9.0
+pp <- 1e-17 ## PR#6792
+stopifnot(all.equal(2*pp, pgeom(1, pp), scale= 1e-20))
+## pgeom(.) gave 0 in R 1.9.0
+
+x <- 10^(100:295)
+sapply(c(1e-250, 1e-25, 0.9, 1.1, 101, 1e10, 1e100),
+ function(shape)
+ All.eq(-x, pgamma(x, shape=shape, lower=FALSE, log=TRUE)))
+x <- 2^(-1022:-900)
+## where all completely off in R 2.0.1
+all.equal(pgamma(x, 10, log = TRUE) - 10*log(x),
+ rep(-15.104412573076, length(x)), tolerance = 1e-12)# 3.984e-14 (i386)
+all.equal(pgamma(x, 0.1, log = TRUE) - 0.1*log(x),
+ rep(0.0498724412598364, length(x)), tolerance = 1e-13)# 7e-16 (i386)
+
+All.eq(dpois( 10*1:2, 3e-308, log=TRUE),
+ c(-7096.08037610806, -14204.2875435307))
+All.eq(dpois(1e20, 1e-290, log=TRUE), -7.12801378828154e+22)
+## all gave -Inf in R 2.0.1
+
+
+## Inf df in pf etc.
+# apparently pf(df2=Inf) worked in 2.0.1 (undocumented) but df did not.
+x <- c(1/pi, 1, pi)
+oo <- options(digits = 8)
+df(x, 3, 1e6)
+df(x, 3, Inf)
+pf(x, 3, 1e6)
+pf(x, 3, Inf)
+
+df(x, 1e6, 5)
+df(x, Inf, 5)
+pf(x, 1e6, 5)
+pf(x, Inf, 5)
+
+df(x, Inf, Inf)# (0, Inf, 0) - since 2.1.1
+pf(x, Inf, Inf)# (0, 1/2, 1)
+
+pf(x, 5, Inf, ncp=0)
+all.equal(pf(x, 5, 1e6, ncp=1), tolerance = 1e-6,
+ c(0.065933194, 0.470879987, 0.978875867))
+all.equal(pf(x, 5, 1e7, ncp=1), tolerance = 1e-6,
+ c(0.06593309, 0.47088028, 0.97887641))
+all.equal(pf(x, 5, 1e8, ncp=1), tolerance = 1e-6,
+ c(0.0659330751, 0.4708802996, 0.9788764591))
+pf(x, 5, Inf, ncp=1)
+
+dt(1, Inf)
+dt(1, Inf, ncp=0)
+dt(1, Inf, ncp=1)
+dt(1, 1e6, ncp=1)
+dt(1, 1e7, ncp=1)
+dt(1, 1e8, ncp=1)
+dt(1, 1e10, ncp=1) # = Inf
+## Inf valid as from 2.1.1: df(x, 1e16, 5) was way off in 2.0.1.
+
+sml.x <- c(10^-c(2:8,100), 0)
+cbind(x = sml.x, `dt(x,*)` = dt(sml.x, df = 2, ncp=1))
+## small 'x' used to suffer from cancellation
+options(oo)
+x <- c(outer(1:12, 10^c(-3:2, 6:9, 10*(2:30))))
+for(nu in c(.75, 1.2, 4.5, 999, 1e50)) {
+ lfx <- dt(x, df=nu, log=TRUE)
+ stopifnot(is.finite(lfx), All.eq(exp(lfx), dt(x, df=nu)))
+}## dt(1e160, 1.2, log=TRUE) was -Inf up to R 2.15.2
+
+## pf() with large df1 or df2
+## (was said to be PR#7099, but that is about non-central pchisq)
+nu <- 2^seq(25, 34, 0.5)
+target <- pchisq(1, 1) # 0.682...
+y <- pf(1, 1, nu)
+stopifnot(All.eq(pf(1, 1, Inf), target),
+ diff(c(y, target)) > 0, # i.e. pf(1, 1, *) is monotone increasing
+ abs(y[1] - (target - 7.21129e-9)) < 1e-11) # computed value
+## non-monotone in R <= 2.1.0
+
+stopifnot(pgamma(Inf, 1.1) == 1)
+## didn't not terminate in R 2.1.x (only)
+
+## qgamma(q, *) should give {0,Inf} for q={0,1}
+sh <- c(1.1, 0.5, 0.2, 0.15, 1e-2, 1e-10)
+stopifnot(Inf == qgamma(1, sh))
+stopifnot(0 == qgamma(0, sh))
+## the first gave Inf, NaN, and 99.425 in R 2.1.1 and earlier
+
+## In extreme left tail {PR#11030}
+p <- 10:123*1e-12
+qg <- qgamma(p, shape=19)
+qg2<- qgamma(1:100 * 1e-9, shape=11)
+stopifnot(diff(qg, diff=2) < -6e-6,
+ diff(qg2,diff=2) < -6e-6,
+ abs(1 - pgamma(qg, 19)/ p) < 1e-13,
+ All.eq(qg [1], 2.35047385139143),
+ All.eq(qg2[30], 1.11512318734547))
+## was non-continuous in R 2.6.2 and earlier
+
+f2 <- c(0.5, 1:4)
+stopifnot(df(0, 1, f2) == Inf,
+ df(0, 2, f2) == 1,
+ df(0, 3, f2) == 0)
+## only the last one was ok in R 2.2.1 and earlier
+
+x0 <- -2 * 10^-c(22,10,7,5) # ==> d*() warns about non-integer:
+assertWarning(fx0 <- dbinom(x0, size = 3, prob = 0.1))
+stopifnot(fx0 == 0, pbinom(x0, size = 3, prob = 0.1) == 0)
+
+## very small negatives were rounded to 0 in R 2.2.1 and earlier
+
+## dbeta(*, ncp):
+db.x <- c(0, 5, 80, 405, 1280, 3125, 6480, 12005, 20480, 32805,
+ 50000, 73205, 103680, 142805, 192080, 253125, 327680)
+a <- rlnorm(100)
+stopifnot(All.eq(a, dbeta(0, 1, a, ncp=0)),
+ dbeta(0, 0.9, 2.2, ncp = c(0, a)) == Inf,
+ All.eq(65536 * dbeta(0:16/16, 5,1), db.x),
+ All.eq(exp(16 * log(2) + dbeta(0:16/16, 5,1, log=TRUE)), db.x)
+ )
+## the first gave 0, the 2nd NaN in R <= 2.3.0; others use 'TRUE' values
+stopifnot(all.equal(dbeta(0.8, 0.5, 5, ncp=1000),# was way too small in R <= 2.6.2
+ 3.001852308909e-35),
+ all.equal(1, integrate(dbeta, 0,1, 0.8, 0.5, ncp=1000)$value,
+ tolerance = 1e-4),
+ all.equal(1, integrate(dbeta, 0,1, 0.5, 200, ncp=720)$value),
+ all.equal(1, integrate(dbeta, 0,1, 125, 200, ncp=2000)$value)
+ )
+
+## df(*, ncp):
+x <- seq(0, 10, length=101)
+h <- 1e-7
+dx.h <- (pf(x+h, 7, 5, ncp= 2.5) - pf(x-h, 7, 5, ncp= 2.5)) / (2*h)
+stopifnot(all.equal(dx.h, df(x, 7, 5, ncp= 2.5), tolerance = 1e-6),# (1.50 | 1.65)e-8
+ All.eq(df(0, 2, 4, ncp=x), df(1e-300, 2, 4, ncp=x))
+ )
+
+## qt(p ~ 0, df=1) - PR#9804
+p <- 10^(-10:-20)
+qtp <- qt(p, df = 1)
+## relative error < 10^-14 :
+stopifnot(abs(1 - p / pt(qtp, df=1)) < 1e-14)
+
+## Similarly for df = 2 --- both for p ~ 0 *and* p ~ 1/2
+## P ~ 0
+stopifnot(all.equal(qt(-740, df=2, log=TRUE), -exp(370)/sqrt(2)))
+## P ~ 1 (=> p ~ 0.5):
+p.5 <- 0.5 + 2^(-5*(5:8))
+stopifnot(all.equal(qt(p.5, df = 2),
+ c(8.429369702179e-08, 2.634178031931e-09,
+ 8.231806349784e-11, 2.572439484308e-12)))
+## qt(<large>, log = TRUE) is now more finite and monotone (again!):
+stopifnot(all.equal(qt(-1000, df = 4, log=TRUE),
+ -4.930611e108, tolerance = 1e-6))
+qtp <- qt(-(20:850), df=1.2, log=TRUE, lower=FALSE)
+##almost: stopifnot(all(abs(5/6 - diff(log(qtp))) < 1e-11))
+stopifnot(abs(5/6 - quantile(diff(log(qtp)), pr=c(0,0.995))) < 1e-11)
+
+## close to df=1 (where Taylor steps are important!):
+stopifnot(all.equal(-20, pt(qt(-20, df=1.02, log=TRUE),
+ df=1.02, log=TRUE), tolerance = 1e-12),
+ diff(lq <- log(qt(-2^-(10:600), df=1.1, log=TRUE))) > 0.6)
+lq1 <- log(qt(-2^-(20:600), df=1, log=TRUE))
+lq2 <- log(qt(-2^-(20:600), df=2, log=TRUE))
+stopifnot(mean(abs(diff(lq1) - log(2) )) < 1e-8,
+ mean(abs(diff(lq2) - log(sqrt(2)))) < 4e-8)
+## Case, where log.p=TRUE was fine, but log.p=FALSE (default) gave NaN:
+lp <- 40:406
+stopifnot(all.equal(lp, -pt(qt(exp(-lp), 1.2), 1.2, log=TRUE), tolerance = 4e-16))
+
+
+## pbeta(*, log=TRUE) {toms708} -- now improved tail behavior
+x <- c(.01, .10, .25, .40, .55, .71, .98)
+pbval <- c(-0.04605755624088, -0.3182809860569, -0.7503593555585,
+ -1.241555830932, -1.851527837938, -2.76044482378, -8.149862739881)
+stopifnot(all.equal(pbeta(x, 0.8, 2, lower=FALSE, log=TRUE), pbval),
+ all.equal(pbeta(1-x, 2, 0.8, log=TRUE), pbval))
+qq <- 2^(0:1022)
+df.set <- c(0.1, 0.2, 0.5, 1, 1.2, 2.2, 5, 10, 20, 50, 100, 500)
+for(nu in df.set) {
+ pqq <- pt(-qq, df = nu, log=TRUE)
+ stopifnot(is.finite(pqq))
+}
+## PR#14230 -- more extreme beta cases {should no longer rely on denormalized}
+x <- (256:512)/1024
+P <- pbeta(x, 3, 2200, lower.tail=FALSE, log.p=TRUE)
+stopifnot(is.finite(P), P < -600,
+ -.001 < (D3P <- diff(P, diff = 3)), D3P < 0, diff(D3P) < 0)
+## all but the first 43 where -Inf in R <= 2.9.1
+stopifnot(All.eq(pt(2^-30, df=10),
+ 0.50000000036238542))
+## = .5+ integrate(dt, 0,2^-30, df=10, rel.tol=1e-20)
+
+## rbinom(*, size) gave NaN for large size up to R <= 2.6.1
+M <- .Machine$integer.max
+set.seed(7)
+tt <- table(rbinom(100, M, pr = 1e-9)) # had values in {0,2} only
+t2 <- table(rbinom(100, 10*M, pr = 1e-10))
+stopifnot(names(tt) == 0:6, sum(tt) == 100, sum(t2) == 100) ## no NaN there
+
+## qf() with large df1, df2 and/or small p:
+x <- 0.01; f1 <- 1e60; f2 <- 1e90
+stopifnot(qf(1/4, Inf, Inf) == 1,
+ all.equal(1, 1e-18/ pf(qf(1e-18, 12,50), 12,50), tolerance = 1e-10),
+ abs(x - qf(pf(x, f1,f2, log.p=TRUE), f1,f2, log.p=TRUE)) < 1e-4)
+
+## qbeta(*, log.p) for "border" case:
+stopifnot(is.finite(q0 <- qbeta(-1e10, 50,40, log.p=TRUE)),
+ 1 == qbeta(-1e10, 2, 3, log.p=TRUE, lower=FALSE))
+## infinite loop or NaN in R <= 2.7.0
+
+## phyper(x, 0,0,0), notably for huge x
+stopifnot(all(phyper(c(0:3, 1e67), 0,0,0) == 1))
+## practically infinite loop and NaN in R <= 2.7.1 (PR#11813)
+
+## plnorm(<= 0, . , log.p=TRUE)
+stopifnot(plnorm(-1:0, lower.tail=FALSE, log.p=TRUE) == 0,
+ plnorm(-1:0, lower.tail=TRUE, log.p=TRUE) == -Inf)
+## was wrongly == 'log.p=FALSE' up to R <= 2.7.1 (PR#11867)
+
+
+## pchisq(df=0) was wrong in 2.7.1; then, upto 2.10.1, P*(0,0) gave 1
+stopifnot(pchisq(c(-1,0,1), df=0) == c(0,0,1),
+ pchisq(c(-1,0,1), df=0, lower.tail=FALSE) == c(1,1,0),
+ ## for ncp >= 80, gave values >= 1 in 2.10.0
+ pchisq(500:700, 1.01, ncp = 80) <= 1)
+
+## dnbinom for extreme size and/or mu :
+mu <- 20
+d <- dnbinom(17, mu=mu, size = 1e11*2^(1:10)) - dpois(17, lambda=mu)
+stopifnot(d < 0, diff(d) > 0, d[1] < 1e-10)
+## was wrong up to 2.7.1
+## The fix to the above, for x = 0, had a new cancellation problem
+mu <- 1e12 * 2^(0:20)
+stopifnot(all.equal(1/(1+mu), dnbinom(0, size = 1, mu = mu), tolerance = 1e-13))
+## was wrong in 2.7.2 (only)
+mu <- sort(outer(1:7, 10^c(0:10,50*(1:6))))
+NB <- dnbinom(5, size=1e305, mu=mu, log=TRUE)
+P <- dpois (5, mu, log=TRUE)
+stopifnot(abs(rErr(NB,P)) < 9*Meps)# seen 2.5*
+## wrong in 3.1.0 and earlier
+
+
+## Non-central F for large x
+x <- 1e16 * 1.1 ^ (0:20)
+dP <- diff(pf(x, df1=1, df2=1, ncp=20, lower.tail=FALSE, log=TRUE))
+stopifnot(-0.047 < dP, dP < -0.0455)
+## pf(*, log) jumped to -Inf prematurely in 2.8.0 and earlier
+
+
+## Non-central Chi^2 density for large x
+stopifnot(0 == dchisq(c(Inf, 1e80, 1e50, 1e40), df=10, ncp=1))
+## did hang in 2.8.0 and earlier (PR#13309).
+
+
+## qbinom() .. particularly for large sizes, small prob:
+p.s <- c(.01, .001, .1, .25)
+pr <- (2:20)*1e-7
+sizes <- 1000*(5000 + c(0,6,16)) + 279
+k.s <- 0:15; q.xct <- rep(k.s, each=length(pr))
+for(sz in sizes) {
+ for(p in p.s) {
+ qb <- qbinom(p=p, size = sz, prob=pr)
+ pb <- qpois (p=p, lambda = sz * pr)
+ stopifnot(All.eq(qb, pb))
+ }
+ pp.x <- outer(pr, k.s, function(pr, q) pbinom(q, size = sz, prob=pr))
+ qq.x <- apply(pp.x, 2, function(p) qbinom(p, size = sz, prob=pr))
+ stopifnot(qq.x == q.xct)
+}
+## do_search() in qbinom() contained a thinko up to 2.9.0 (PR#13711)
+
+
+## pbeta(x, a,b, log=TRUE) for small x and a is ~ log-linear
+x <- 2^-(200:10)
+for(a in c(1e-8, 1e-12, 16e-16, 4e-16))
+ for(b in c(0.6, 1, 2, 10)) {
+ dp <- diff(pbeta(x, a, b, log=TRUE)) # constant approximately
+ stopifnot(sd(dp) / mean(dp) < 0.0007)
+ }
+## had accidental cancellation '1 - w'
+
+## qgamma(p, a) for small a and (hence) small p
+## pgamma(x, a) for very very small a
+a <- 2^-seq(10,1000, .25)
+q.1c <- qgamma(1e-100,a,lower.tail=FALSE)
+q.3c <- qgamma(1e-300,a,lower.tail=FALSE)
+p.1c <- pgamma(q.1c[q.1c > 0], a[q.1c > 0], lower.tail=FALSE)
+p.3c <- pgamma(q.3c[q.3c > 0], a[q.3c > 0], lower.tail=FALSE)
+x <- 1+1e-7*c(-1,1); pg <- pgamma(x, shape = 2^-64, lower.tail=FALSE)
+stopifnot(qgamma(.99, .00001) == 0,
+ abs(pg[2] - 1.18928249197237758088243e-20) < 1e-33,
+ abs(diff(pg) + diff(x)*dgamma(1, 2^-64)) < 1e-13 * mean(pg),
+ abs(1 - p.1c/1e-100) < 10e-13,# max = 2.243e-13 / 2.442 e-13
+ abs(1 - p.3c/1e-300) < 28e-13)# max = 7.057e-13
+## qgamma() was wrong here, orders of magnitude up to R 2.10.0
+## pgamma() had inaccuracies, e.g.,
+## pgamma(x, shape = 2^-64, lower.tail=FALSE) was discontinuous at x=1
+
+stopifnot(all(qpois((0:8)/8, lambda=0) == 0))
+## gave Inf as p==1 was checked *before* lambda==0
+
+## extreme tail of non-central chisquare
+stopifnot(all.equal(pchisq(200, 4, ncp=.001, log.p=TRUE), -3.851e-42))
+## jumped to zero too early up to R 2.10.1 (PR#14216)
+## left "extreme tail"
+lp <- pchisq(2^-(0:200), 100, 1, log=TRUE)
+stopifnot(is.finite(lp), lp < -184,
+ all.equal(lp[201], -7115.10693158))
+dlp <- diff(lp)
+dd <- abs(dlp[-(1:30)] - -34.65735902799)
+stopifnot(-34.66 < dlp, dlp < -34.41, dd < 1e-8)# 2.2e-10 64bit Lnx
+## underflowed to -Inf much too early in R <= 3.1.0
+for(e in c(0, 2e-16))# continuity at 80 (= branch point)
+stopifnot(all.equal(pchisq(1:2, 1.01, ncp = 80*(1-e), log=TRUE),
+ c(-34.57369629, -31.31514671)))
+
+## logit() == qlogit() on the right extreme:
+x <- c(10:80, 80 + 5*(1:24), 200 + 20*(1:25))
+stopifnot(All.eq(x, qlogis(plogis(x, log.p=TRUE),
+ log.p=TRUE)))
+## qlogis() gave Inf much too early for R <= 2.12.1
+## Part 2:
+x <- c(x, seq(700, 800, by=10))
+stopifnot(All.eq(x, qlogis(plogis(x, lower=FALSE, log.p=TRUE),
+ lower=FALSE, log.p=TRUE)))
+# plogis() underflowed to -Inf too early for R <= 2.15.0
+
+## log upper tail pbeta():
+x <- (25:50)/128
+pbx <- pbeta(x, 1/2, 2200, lower.tail=FALSE, log.p=TRUE)
+d2p <- diff(dp <- diff(pbx))
+b <- 2200*2^(0:50)
+y <- log(-pbeta(.28, 1/2, b, lower.tail=FALSE, log.p=TRUE))
+stopifnot(-1094 < pbx, pbx < -481.66,
+ -29 < dp, dp < -20,
+ -.36 < d2p, d2p < -.2,
+ all.equal(log(b), y+1.113, tolerance = .00002)
+ )
+## pbx had two -Inf; y was all Inf for R <= 2.15.3; PR#15162
+
+## dnorm(x) for "large" |x|
+stopifnot(abs(1 - dnorm(35+3^-9)/ 3.933395747534971e-267) < 1e-15)
+## has been losing up to 8 bit precision for R <= 3.0.x
+
+## pbeta(x, <small a>,<small b>, .., log):
+ldp <- diff(log(diff(pbeta(0.5, 2^-(90+ 1:25), 2^-60, log.p=TRUE))))
+stopifnot(abs(ldp - log(1/2)) < 1e-9)
+## pbeta(*, log) lost all precision here, for R <= 3.0.x (PR#15641)
+##
+## "stair function" effect (from denormalized numbers)
+a <- 43779; b <- 0.06728
+x. <- .9833 + (0:100)*1e-6
+px <- pbeta(x., a,b, log=TRUE) # plot(x., px) # -> "stair"
+d2. <- diff(dpx <- diff(px))
+stopifnot(all.equal(px[1], -746.0986886924, tol=1e-12),
+ 0.0445741 < dpx, dpx < 0.0445783,
+ -4.2e-8 < d2., d2. < -4.18e-8)
+## were way off in R <= 3.1.0
+
+c0 <- system.time(p0 <- pbeta( .9999, 1e30, 1.001, log=TRUE))
+cB <- max(.001, c0[[1]])# base time
+c1 <- system.time(p1 <- pbeta(1- 1e-9, 1e30, 1.001, log=TRUE))
+c2 <- system.time(p2 <- pbeta(1-1e-12, 1e30, 1.001, log=TRUE))
+stopifnot(all.equal(p0, -1.000050003333e26, tol=1e-10),
+ all.equal(p1, -1e21, tol = 1e-6),
+ all.equal(p2, -9.9997788e17),
+ c(c1[[1]], c2[[1]]) < 1000*cB)
+## (almost?) infinite loop in R <= 3.1.0
+
+
+## pbinom(), dbinom(), dhyper(),.. : R allows "almost integer" n
+for (FUN in c(function(n) dbinom(1,n,0.5), function(n) pbinom(1,n,0.5),
+ function(n) dpois(n, n), function(n) dhyper(n+1, n+5,n+5, n)))
+ try( lapply(sample(10000, size=1000), function(M) {
+ ## invisible(lapply(sample(10000, size=1000), function(M) {
+ n <- (M/100)*10^(2:20); if(anyNA(P <- FUN(n)))
+ stop("NA for M=",M, "; 10ex=",paste((2:20)[is.na(P)], collapse=", "))}))
+## check was too tight for large n in R <= 3.1.0 (PR#15734)
+
+## [dpqr]beta(*, a,b) where a and/or b are Inf
+stopifnot(pbeta(.1, Inf, 40) == 0,
+ pbeta(.5, 40, Inf) == 1,
+ pbeta(.4, Inf,Inf) == 0,
+ pbeta(.5, Inf,Inf) == 1,
+ ## gave infinite loop (or NaN) in R <= 3.1.0
+ qbeta(.9, Inf, 100) == 1, # Inf.loop
+ qbeta(.1, Inf, Inf) == 1/2)# NaN + Warning
+## range check (in "close" cases):
+assertWarning(qN <- qbeta(2^-(10^(1:3)), 2,3, log.p=TRUE))
+assertWarning(qn <- qbeta(c(-.1, -1e-300, 1.25), 2,3))
+stopifnot(is.nan(qN), is.nan(qn))
+
+## lognormal boundary case sdlog = 0:
+p <- (0:8)/8; x <- 2^(-10:10)
+stopifnot(all.equal(qlnorm(p, meanlog=1:2, sdlog=0),
+ qlnorm(p, meanlog=1:2, sdlog=1e-200)),
+ dlnorm(x, sdlog=0) == ifelse(x == 1, Inf, 0))
+
+## qbeta(*, a,b) when a,b << 1 : can easily fail
+qbeta(2^-28, 0.125, 2^-26) # 1000 Newton it + warning
+a <- 1/8; b <- 2^-(4:200); alpha <- b/4
+qq <- qbeta(alpha, a,b)# gave warnings intermediately
+pp <- pbeta(qq, a,b)
+stopifnot(pp > 0, diff(pp) < 0, ## pbeta(qbeta(alpha,*),*) == alpha:
+ abs(1 - pp/alpha) < 4e-15)# seeing 2.2e-16
+
+## orig. qbeta() using *many* Newton steps; case where we "know the truth"
+a <- 25; b <- 6; x <- 2^-c(3:15, 100, 200, 250, 300+100*(0:7))
+pb <- c(## via Rmpfr's roundMpfr(pbetaI(x, a,b, log.p=TRUE, precBits = 2048), 64) :
+ -40.7588797271766572448, -57.7574063441183625303, -74.9287878018119846216,
+ -92.1806244636893542185, -109.471318248524419364, -126.781111923947395655,
+ -144.100375042814531426, -161.424352961544612370, -178.750683324909148353,
+ -196.078188674895169383, -213.406281209657976525, -230.734667259724367416,
+ -248.063200048177428608, -1721.00081201679567511, -3453.86876341665894863,
+ -4320.30273911659058550, -5186.73671481652222237, -6919.60466621638549567,
+ -8652.47261761624876897, -10385.3405690161120427, -12118.2085204159753165,
+ -13851.0764718158385902, -15583.9444232157018631, -17316.8123746155651368)
+stopifnot(all.equal(pb, pbeta(x,a,b, log.p=TRUE), tol=8e-16))# seeing {1.5|1.6|2.0}e-16
+qp <- qbeta(pb, a,b, log.p=TRUE)
+## x == qbeta(pbeta(x, *), *) :
+stopifnot(qp > 0, all.equal(x, qp, tol= 1e-15))# seeing {2.4|3.3}e-16
+
+## qbeta(), PR#15755
+a1 <- 0.0672788; b1 <- 226390
+p <- 0.6948886
+qp <- qbeta(p, a1,b1)
+stopifnot(qp < 2e-8, # was '1' (with a warning) in R <= 3.1.0
+ All.eq(p, pbeta(qp, a1,b1)))
+## less extreme example, same phenomenon:
+a <- 43779; b <- 0.06728
+stopifnot(All.eq(0.695, pbeta(qbeta(0.695, b,a), b,a)))
+x <- -exp(seq(0, 14, by=2^-9))
+ct <- system.time(qx <- qbeta(x, a,b, log.p=TRUE))[[1]]
+pqx <- pbeta(qx, a,b, log=TRUE)
+stopifnot(all.equal(x, pqx, tol= 2e-15)) # seeing {3.51|3.54}e-16
+## note that qx[x > -exp(2)] is too close to 1 to get full accuracy:
+## i2 <- x > -exp(2); all.equal(x[i2], pqx[i2], tol= 0)#-> 5.849e-12
+if(ct > 0.5) { cat("system.time:\n"); print(ct) }# lynne(2013): 0.048
+## was Inf, and much slower, for R <= 3.1.0
+x3 <- -(15450:15700)/2^11
+pq3 <- pbeta(qbeta(x3, a,b, log.p=TRUE), a,b, log=TRUE)
+stopifnot(mean(abs(pq3-x3)) < 4e-12,# 1.46e-12
+ max (abs(pq3-x3)) < 8e-12)# 2.95e-12
+##
+.a <- .2; .b <- .03; lp <- -(10^-(1:323))
+qq <- qbeta(lp, .a,.b, log=TRUE) # warnings in R <= 3.1.0
+assertWarning(qN <- qbeta(.5, 2,3, log.p=TRUE))
+assertWarning(qn <- qbeta(c(-.1, 1.25), 2,3))
+stopifnot(1-qq < 1e-15, is.nan(qN), is.nan(qn))# typically qq == 1 exactly
+## failed in intermediate versions
+##
+a <- 2^-8; b <- 2^(200:500)
+pq <- pbeta(qbeta(1/8, a, b), a, b)
+stopifnot(abs(pq - 1/8) < 1/8)
+## whereas qbeta() would underflow to 0 "too early", for R <= 3.1.0
+#
+## very extreme tails on both sides
+x <- c(1e-300, 1e-12, 1e-5, 0.1, 0.21, 0.3)
+stopifnot(0 == qbeta(x, 2^-12, 2^-10))## gave warnings
+a <- 10^-(8:323)
+qb <- qbeta(0.95, a, 20)
+## had warnings and wrong value +1; also NaN
+ct2 <- system.time(q2 <- qbeta(0.95, a,a))[1]
+stopifnot(is.finite(qb), qb < 1e-300, q2 == 1)
+if(ct2 > 0.020) { cat("system.time:\n"); print(ct2) }
+## had warnings and was much slower for R <= 3.1.0
+
+## qt(p, df= Inf, ncp) <==> qnorm(p, m=ncp)
+p <- (0:32)/32
+stopifnot(all.equal(qt(p, df=Inf, ncp=5), qnorm(p, m=5)))
+## qt(*, df=Inf, .) gave NaN in R <= 3.2.1
+
+## rhyper(*, <large>); PR#16489
+ct3 <- system.time(N <- rhyper(100, 8000, 1e9-8000, 1e6))[1]
+table(N)
+summary(N)
+stopifnot(abs(mean(N) - 8) < 1.5)
+if(ct3 > 0.02) { cat("system.time:\n"); print(ct3) }
+## N were all 0 and took very long for R <= 3.2.1
+set.seed(17)
+stopifnot(rhyper(1, 3024, 27466, 251) == 25,
+ rhyper(1, 329, 3059, 225) == 22)
+## failed for a day after a "thinko" in the above bug fix.
+
+## *chisq(*, df=0, ncp=0) == Point mass at 0
+stopifnot(rchisq(32, df=0, ncp=0) == 0,
+ dchisq((0:16)/16, df=0, ncp=0) == c(Inf, rep(0, 16)))
+## gave all NaN's for R <= 3.2.2
+
+## pchisq(*, df=0, ncp > 0, log.p=TRUE) :
+th <- 10*c(1:9,10^c(1:3,7))
+pp <- pchisq(0, df = 0, ncp=th, log.p=TRUE)
+stopifnot(all.equal(pp, -th/2, tol=1e-15))
+## underflowed at about th ~= 60 in R <= 3.2.2
+
+## pnbinom (-> C's bratio())
+op <- options(warn = 1)# -- NaN's giving warnings
+L <- 1e308; p <- suppressWarnings(pnbinom(L, L, mu = 5)) # NaN or 1 (for 64 / 32 bit)
+is.nan(p) || p == 1
+## gave infinite loop on some 64b platforms in R <= 3.2.3
+
+## [dpqr]nbinom(*, mu, size=Inf) -- PR#16727
+L <- 1e308; mu <- 5; pp <- (0:16)/16
+x <- c(0:3, 1e10, 1e100, L, Inf)
+(d <- dnbinom(x, mu = mu, size = Inf)) # gave NaN (for 0 and L)
+(p <- pnbinom(x, mu = mu, size = Inf)) # gave all NaN
+(q <- qnbinom(pp, mu = mu, size = Inf)) # gave all NaN
+set.seed(1); NI <- rnbinom(32, mu = mu, size = Inf)# gave all NaN
+set.seed(1); N2 <- rnbinom(32, mu = mu, size = L )
+stopifnot(all.equal(d, dpois(x, mu)),
+ all.equal(p, ppois(x, mu)),
+ q == qpois(pp, mu),
+ identical(NI, N2))
+options(op)
+## size = Inf -- mostly gave NaN in R <= 3.2.3
+
+## qpois(p, *) for invalid 'p' should give NaN -- PR#16972
+stopifnot(is.nan(suppressWarnings(c(qpois(c(-2,3, NaN), 3), qpois(1, 3, log.p=TRUE),
+ qpois(.5, 0, log.p=TRUE), qpois(c(-1,pi), 0)))))
+## those in the 2nd line gave 0 in R <= 3.3.1
+## Similar but different for qgeom():
+stopifnot(qgeom((0:8)/8, prob=1) == 0, ## p=1 gave Inf in R <= 3.3.1
+ is.nan(suppressWarnings(qgeom(c(-1/4, 1.1), prob=1))))
+
+## all our RNG r<dist>() functions:
+##' catch all: value and warnings or error <-- demo(error.catching) :
+tryCatch.W.E <- function(expr) {
+ W <- NULL
+ w.handler <- function(w){ # warning handler
+ W <<- w
+ invokeRestart("muffleWarning")
+ }
+ list(value = withCallingHandlers(tryCatch(expr, error = function(e) e),
+ warning = w.handler),
+ warning = W)
+}
+.stat.ns <- asNamespace("stats")
+Ns <- 4
+for(dist in PDQR) {
+ fn <- paste0("r",dist)
+ cat(sprintf("%-9s(%d, ..): ", fn, Ns))
+ F <- get(fn, envir = .stat.ns)
+ nArg <- length(fms <- formals(F))
+ if(dist %in% c("nbinom", "gamma")) ## cannot specify *both* 'prob' & 'mu' / 'rate' & 'scale'
+ nArg <- nArg - 1
+ nA1 <- nArg - 1 # those beside the first (= 'n' mostly)
+ expected <- rep(if(dist %in% PDQRinteg) NA_integer_ else NaN, Ns)
+ for(ia in seq_len(nA1)) {
+ aa <- rep(list(1), nA1)
+ aa[[ia]] <- NA
+ cat(ia,"")
+ R <- tryCatch.W.E( do.call(F, c(Ns, aa)) )
+ if(!inherits(R$warning, "simpleWarning")) cat(" .. did *NOT* give a warning! ")
+ if(!(identical(R$value, expected))) { ## allow NA/NaN mismatch in these cases for now:
+ if(!(dist %in% c("beta","f","t") && all(is.na(R$value))))
+ cat(" .. not giving expected NA/NaN's ")
+ }
+ }
+ cat(" [Ok]\n")
+}
+
+
+## qbeta() in very asymmetric cases
+sh2 <- 2^seq(9,16, by=1/16)
+qbet <- qbeta(1e-10, 1.5, shape2=sh2, lower.tail=FALSE)
+plot(sh2, 1- pbeta(qbet, 1.5, sh2, lower.tail=FALSE) * 1e10, log="x")
+dqb <- diff(qbet); d2qb <- diff(dqb); d3qb <- diff(d2qb)
+stopifnot(all.equal(qbet[[1]], 0.047206901483498, tol=1e-12),
+ max(abs(1- pbeta(qbet, 1.5, sh2, lower.tail=FALSE) * 1e10)) < 1e-12,# Lx 64b: 2.4e-13
+ 0 > dqb, dqb > -0.002,
+ 0 < d2qb, d2qb < 0.00427,
+ -3.2e-8 > d3qb, d3qb > -3.1e-6,
+ diff(d3qb) > 1e-9)
+## had discontinuity (from wrong jump out of Newton) in R <= 3.3.2
+
+
+
+cat("Time elapsed: ", proc.time() - .ptime,"\n")
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/datasets.R b/com.oracle.truffle.r.native/gnur/tests/src/datasets.R
new file mode 100644
index 0000000000000000000000000000000000000000..bca05947fbbaae2bca4c916bd9f55cf96c85d70e
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/datasets.R
@@ -0,0 +1,9 @@
+#### Simple integrity tests of the system datasets
+
+options(useFancyQuotes=FALSE)
+env <- as.environment("package:datasets")
+d <- ls(env) # don't want .names
+for(f in d) {
+ cat("\n** structure of dataset ", f, "\n", sep="")
+ str(get(f, envir=env, inherits=FALSE))
+}
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/datetime.R b/com.oracle.truffle.r.native/gnur/tests/src/datetime.R
new file mode 100644
index 0000000000000000000000000000000000000000..61d4c9de500a0c42f522f7500befd7f490fe8206
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/datetime.R
@@ -0,0 +1,37 @@
+#### Test 64-bit date-time functions.
+
+## R's internal fixes are used on 32-bit platforms.
+## macOS gets these wrong: see HAVE_WORKING_64BIT_MKTIME
+
+Sys.setenv(TZ = "UTC")
+(z <- as.POSIXct("1848-01-01 12:00"))
+c(unclass(z))
+(z <- as.POSIXct("2040-01-01 12:00"))
+c(unclass(z))
+(z <- as.POSIXct("2040-07-01 12:00"))
+c(unclass(z))
+
+Sys.setenv(TZ = "Europe/London") # pretty much portable.
+(z <- as.POSIXct("1848-01-01 12:00"))
+c(unclass(z))
+(z <- as.POSIXct("2040-01-01 12:00"))
+c(unclass(z))
+(z <- as.POSIXct("2040-07-01 12:00"))
+c(unclass(z))
+
+Sys.setenv(TZ = "EST5EDT")
+(z <- as.POSIXct("1848-01-01 12:00"))
+c(unclass(z))
+(z <- as.POSIXct("2040-01-01 12:00"))
+c(unclass(z))
+(z <- as.POSIXct("2040-07-01 12:00"))
+c(unclass(z))
+
+## PR15613: had day as > 24hrs.
+as.POSIXlt(ISOdate(2071,1,13,0,0,tz="Etc/GMT-1"))$wday
+as.POSIXlt(ISOdate(2071,1,13,0,1,tz="Etc/GMT-1"))$wday
+
+
+## Incorrect use of %d should work even though abbreviation does match
+old <- Sys.setlocale("LC_TIME", "C") # to be sure
+stopifnot(!is.na(strptime("11-August-1903", "%d-%b-%Y")))
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/datetime2.R b/com.oracle.truffle.r.native/gnur/tests/src/datetime2.R
new file mode 100644
index 0000000000000000000000000000000000000000..48383af344afad8e1be743046a3931925e090bc1
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/datetime2.R
@@ -0,0 +1,47 @@
+### Tests of often platform-dependent features of the POSIX[cl]t implementation.
+
+### Expect differences, especially with 32-bit time_t
+
+z <- ISOdate(1890:1912, 1, 10, tz="UTC")
+## Rome changed to CET for 1894
+as.POSIXlt(z, tz="Europe/Rome")
+## Paris changed to PMT for 1892, WET for 1912
+(zz <- as.POSIXlt(z, tz="Europe/Paris"))
+strftime(zz, "%Y-%m-%d %H:%M:%S %Z")
+## The offset was really 00:09:21 until 1911, then 00:00
+## Many platforms will give the current offset, +0100
+strftime(zz, "%Y-%m-%d %H:%M:%S %z")
+
+## Some platforms give details of the latest conversion.
+z <- ISOdate(c(seq(1890, 1940, 5), 1941:1946, 1950), 1, 10, tz="UTC")
+as.POSIXlt(z, tz="Europe/Paris")
+for(i in seq_along(z)) print(as.POSIXlt(z[i], tz="Europe/Paris"))
+for(i in seq_along(z))
+ print(strftime(as.POSIXlt(z[i], tz="Europe/Paris"), "%Y-%m-%d %H:%M:%S %z"))
+
+strptime("1920-12-27 08:18:23", "%Y-%m-%d %H:%M:%S", tz="Europe/Paris")
+
+## check %V etc
+
+d <- expand.grid(day = 1:7, year = 2000:2010)
+z1 <- with(d, ISOdate(year, 1, day))
+d <- expand.grid(day = 25:31, year = 2000:2010)
+z2 <- with(d, ISOdate(year, 12, day))
+z <- sort(c(z1, z2))
+strftime(z, "%G %g %W %U %u %V %W %w")
+
+## tests of earlier years. Default format is OS-dependent, so don't test it.
+## ISOdate only accepts positive years.
+z <- as.Date(ISOdate(c(0, 8, 9, 10, 11, 20, 110, 1010), 1, 10)) - 3630
+strftime(z, "%04Y-%m-%d") # with leading zero(s)
+strftime(z, "%_4Y-%m-%d") # with leading space(s)
+strftime(z, "%0Y-%m-%d") # without
+
+
+## more test of strftime
+x <- ISOdate(2014, 3, 10, c(7, 13))
+fmts <- c("%Y-%m-%d %H:%M:%S", "%F", "%A %a %b %h %e %I %j",
+ ## locale-dependent ones
+ "%X", # but the same in all English locales
+ "%c", "%x", "%p", "%r")
+for (f in fmts) print(format(x, f))
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/demos.R b/com.oracle.truffle.r.native/gnur/tests/src/demos.R
new file mode 100644
index 0000000000000000000000000000000000000000..b9528c993ebbbf92b8ba4b2d8777dfa42ac03e95
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/demos.R
@@ -0,0 +1,30 @@
+#### Run all demos that do not depend on tcl and other specials.
+.ptime <- proc.time()
+set.seed(123)
+options(keep.source=TRUE, useFancyQuotes=FALSE, warn = 1)
+
+## Drop these for strict testing {and add them to demos2.R)
+## lm.glm is in ../src/library/utils/man/demo.Rd }:
+dont <- list(graphics = c("Hershey", "Japanese", "plotmath"),
+ stats = c("lm.glm", "nlm")
+ )
+## don't take tcltk here
+for(pkg in c("base", "graphics", "stats")) {
+
+ demos <- list.files(file.path(system.file(package = pkg), "demo"),
+ pattern = "\\.R$")
+ demos <- demos[is.na(match(demos, paste(dont[[pkg]], "R",sep=".")))]
+
+ if(length(demos)) {
+ if(need <- pkg != "base" &&
+ !any((fpkg <- paste("package", pkg, sep=":")) == search()))
+ library(pkg, character.only = TRUE)
+
+ for(nam in sub("\\.R$", "", demos))
+ demo(nam, character.only = TRUE)
+
+ if(need) detach(pos = which(fpkg == search()))
+ }
+}
+
+cat("Time elapsed: ", proc.time() - .ptime, "\n")
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/demos2.R b/com.oracle.truffle.r.native/gnur/tests/src/demos2.R
new file mode 100644
index 0000000000000000000000000000000000000000..6684ec7e4a2c8299734e7ce928728b2a2deb30a4
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/demos2.R
@@ -0,0 +1,9 @@
+#### Run all demos for which we do not wish to diff the output
+.ptime <- proc.time()
+set.seed(123)
+
+demos <- c("Hershey", "Japanese", "lm.glm", "nlm", "plotmath")
+
+for(nam in demos) demo(nam, character.only = TRUE)
+
+cat("Time elapsed: ", proc.time() - .ptime, "\n")
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/encodings.R b/com.oracle.truffle.r.native/gnur/tests/src/encodings.R
new file mode 100644
index 0000000000000000000000000000000000000000..f2372601862e087d01a51a9cc84cbce996483309
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/encodings.R
@@ -0,0 +1,27 @@
+## from iconv.Rd
+(x <- "fa\xE7ile")
+charToRaw(xx <- iconv(x, "latin1", "UTF-8"))
+
+iconv(x, "latin1", "ASCII") # NA
+iconv(x, "latin1", "ASCII", "?") # "fa?ile"
+iconv(x, "latin1", "ASCII", "") # "faile"
+iconv(x, "latin1", "ASCII", "byte") # "fa<e7>ile"
+
+# Extracts from R help files
+(x <- c("Ekstr\xf8m", "J\xf6reskog", "bi\xdfchen Z\xfcrcher"))
+iconv(x, "latin1", "ASCII//TRANSLIT")
+iconv(x, "latin1", "ASCII", sub="byte")
+
+## tests of re-encoding in .C
+require("tools")
+x <- "fa\xE7ile"
+.C("Renctest", x, PACKAGE="tools")[[1]]
+.C("Renctest", x, PACKAGE="tools", ENCODING="latin1")[[1]]
+xx <- iconv(x, "latin1", "UTF-8")
+.C("Renctest", xx, PACKAGE="tools", ENCODING="UTF-8")[[1]]
+
+## tests of match length in delimMatch
+x <- c("a{bc}d", "{a\xE7b}")
+delimMatch(x)
+xx <- iconv(x, "latin1", "UTF-8")
+delimMatch(xx) ## 5 6 in latin1, 5 5 in UTF-8
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/eval-etc.R b/com.oracle.truffle.r.native/gnur/tests/src/eval-etc.R
new file mode 100644
index 0000000000000000000000000000000000000000..fbf6e2f02de2bb64a605f8c5db3f181566c2fe8c
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/eval-etc.R
@@ -0,0 +1,150 @@
+#### eval / parse / deparse / substitute etc
+
+##- From: Peter Dalgaard BSA <p.dalgaard@biostat.ku.dk>
+##- Subject: Re: source() / eval() bug ??? (PR#96)
+##- Date: 20 Jan 1999 14:56:24 +0100
+e1 <- parse(text='c(F=(f <- .3), "Tail area" = 2 * if(f < 1) 30 else 90)')[[1]]
+e1
+str(eval(e1))
+mode(e1)
+
+( e2 <- quote(c(a=1,b=2)) )
+names(e2)[2] <- "a b c"
+e2
+parse(text=deparse(e2))
+
+##- From: Peter Dalgaard BSA <p.dalgaard@biostat.ku.dk>
+##- Date: 22 Jan 1999 11:47
+
+( e3 <- quote(c(F=1,"tail area"=pf(1,1,1))) )
+eval(e3)
+names(e3)
+
+names(e3)[2] <- "Variance ratio"
+e3
+eval(e3)
+
+
+##- From: Peter Dalgaard BSA <p.dalgaard@biostat.ku.dk>
+##- Date: 2 Sep 1999
+
+## The first failed in 0.65.0 :
+attach(list(x=1))
+evalq(dim(x) <- 1,as.environment(2))
+dput(get("x", envir=as.environment(2)), control="all")
+
+e <- local({x <- 1;environment()})
+evalq(dim(x) <- 1,e)
+dput(get("x",envir=e), control="all")
+
+### Substitute, Eval, Parse, etc
+
+## PR#3 : "..." matching
+## Revised March 7 2001 -pd
+A <- function(x, y, ...) {
+ B <- function(a, b, ...) { match.call() }
+ B(x+y, ...)
+}
+(aa <- A(1,2,3))
+all.equal(as.list(aa),
+ list(as.name("B"), a = expression(x+y)[[1]], b = 3))
+(a2 <- A(1,2, named = 3)) #A(1,2, named = 3)
+all.equal(as.list(a2),
+ list(as.name("B"), a = expression(x+y)[[1]], named = 3))
+
+CC <- function(...) match.call()
+DD <- function(...) CC(...)
+a3 <- DD(1,2,3)
+all.equal(as.list(a3),
+ list(as.name("CC"), 1, 2, 3))
+
+## More dots issues: March 19 2001 -pd
+## Didn't work up to and including 1.2.2
+
+f <- function(...) {
+ val <- match.call(expand.dots=FALSE)$...
+ x <- val[[1]]
+ eval.parent(substitute(missing(x)))
+}
+g <- function(...) h(f(...))
+h <- function(...) list(...)
+k <- function(...) g(...)
+X <- k(a=)
+all.equal(X, list(TRUE))
+
+## Bug PR#24
+f <- function(x,...) substitute(list(x,...))
+deparse(f(a, b)) == "list(a, b)" &&
+deparse(f(b, a)) == "list(b, a)" &&
+deparse(f(x, y)) == "list(x, y)" &&
+deparse(f(y, x)) == "list(y, x)"
+
+tt <- function(x) { is.vector(x); deparse(substitute(x)) }
+a <- list(b=3); tt(a$b) == "a$b" # tends to break when ...
+
+
+## Parser:
+1 <
+ 2
+2 <=
+ 3
+4 >=
+ 3
+3 >
+ 2
+2 ==
+ 2
+## bug till ...
+1 !=
+ 3
+
+all(NULL == NULL)
+
+## PR #656 (related)
+u <- runif(1); length(find(".Random.seed")) == 1
+
+MyVaR <<- "val";length(find("MyVaR")) == 1
+rm(MyVaR); length(find("MyVaR")) == 0
+
+
+## Martin Maechler: rare bad bug in sys.function() {or match.arg()} (PR#1409)
+callme <- function(a = 1, mm = c("Abc", "Bde")) {
+ mm <- match.arg(mm); cat("mm = "); str(mm) ; invisible()
+}
+## The first two were as desired:
+callme()
+callme(mm="B")
+mycaller <- function(x = 1, callme = pi) { callme(x) }
+mycaller()## wrongly gave `mm = NULL' now = "Abc"
+
+
+## Garbage collection protection problem:
+if(FALSE) ## only here to be run as part of 'make test-Gct'
+ gctorture() # <- for manual testing
+x <- c("a", NA, "b")
+fx <- factor(x, exclude="")
+ST <- if(interactive()) system.time else invisible
+ST(r <- replicate(20, capture.output(print(fx))))
+table(ok. <- r[2,] == "Levels: a b <NA>") # want all TRUE
+stopifnot(ok.) # in case of failure, see
+r[2,] ## the '<NA>' levels part would be wrong occasionally
+
+
+## withAutoprint() : must *not* evaluate twice *and* do it in calling environment:
+CO <- utils::capture.output
+stopifnot(
+ identical(
+ ## ensure it is only evaluated _once_ :
+ CO(withAutoprint({ x <- 1:2; cat("x=",x,"\n") }))[1],
+ paste0(getOption("prompt"), "x <- 1:2"))
+ ,
+ ## need "enough" deparseCtrl for this:
+ grepl("1L, NA_integer_", CO(withAutoprint(x <- c(1L, NA_integer_, NA))))
+ ,
+ identical(CO(r1 <- withAutoprint({ formals(withAutoprint); body(withAutoprint) })),
+ CO(r2 <- source(expr = list(quote(formals(withAutoprint)),
+ quote(body(withAutoprint)) ),
+ echo=TRUE))),
+ identical(r1,r2)
+)
+## partly failed in R 3.4.0 alpha
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/gct-foot.R b/com.oracle.truffle.r.native/gnur/tests/src/gct-foot.R
new file mode 100644
index 0000000000000000000000000000000000000000..22d6e86e1b97c4db834d53a1634ec0c224c6f1a1
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/gct-foot.R
@@ -0,0 +1 @@
+cat("Time used {gctorture()}:", proc.time() - .ptime, "\n")
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/iec60559.R b/com.oracle.truffle.r.native/gnur/tests/src/iec60559.R
new file mode 100644
index 0000000000000000000000000000000000000000..1eec8b487de7a31206a548ad0da152192fa56510
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/iec60559.R
@@ -0,0 +1,18 @@
+## Tests for various features of IEC60559 doubles.
+## Most of these are optional, so this is a sloppy test.
+
+# Goes to denormal (aka subnormal) numbers at -708.4
+exp(c(-745:-740, -730, -720, -710:-705))
+
+# goes to subnormal numbers at -308, to zero at ca 5e-324.
+10^-(324:307)
+2^-(1022:1075)
+
+# And because most libm pow() functions special-case integer powers.
+10^-(324:307-0.01)/10^0.01
+
+# IEC60559 mandates this, but C99/C11 do not.
+# Mingw-w64 did not do so in v 2.0.1
+x <- 0*(-1) # negative zero
+sqrt(x)
+identical(x, sqrt(x))
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/internet.R b/com.oracle.truffle.r.native/gnur/tests/src/internet.R
new file mode 100644
index 0000000000000000000000000000000000000000..ceba22030d8442095265fc012ea4fd41c7e36824
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/internet.R
@@ -0,0 +1,21 @@
+## These are tests that require a working Internet connection.
+## We attempt to test for that.
+
+if(.Platform$OS.type == "unix" &&
+ is.null(nsl("cran.r-project.org"))) q()
+
+# test do_download (and "record" #{packages}):
+ap <- available.packages(contrib.url("http://cran.r-project.org"))
+## IGNORE_RDIFF_BEGIN
+nrow(ap)
+## IGNORE_RDIFF_END
+
+# test url connections on http
+zz <- url("http://cran.r-project.org/")
+readLines(zz)
+close(zz)
+
+# and via read.table, test http and ftp.
+
+read.table("http://www.stats.ox.ac.uk/pub/datasets/csb/ch11b.dat")
+read.table("ftp://ftp.stats.ox.ac.uk/pub/datasets/csb/ch11b.dat")
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/internet2.R b/com.oracle.truffle.r.native/gnur/tests/src/internet2.R
new file mode 100644
index 0000000000000000000000000000000000000000..a83ad1eacb0c371d6bf7eeff0df90158fd4e6647
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/internet2.R
@@ -0,0 +1,55 @@
+## These are tests that require socket and internet functionality, and
+## a working Internet connection.
+## We attempt to test for those.
+
+if(.Platform$OS.type == "unix" &&
+ is.null(nsl("cran.r-project.org"))) q()
+
+
+## check graceful failure:
+try(url("http://foo.bar", "r"))
+
+if(.Platform$OS.type == "windows")
+ try(url("http://foo.bar", "r", method = "wininet"))
+
+## everything from here on is directly over sockets
+if(!capabilities("sockets")) stop("no socket capabilities")
+
+# do the same thing via sockets (cut-down httpclient)
+httpget <- function (url, port = 80)
+{
+ urlel <- strsplit(url, "/")[[1]]
+ if (urlel[1] != "http:") stop("Not an http:// URL")
+ host <- urlel[3]
+ rurl <- paste(c("", urlel[-(1:3)]), collapse = "/")
+ a <- make.socket(host, port = port)
+ on.exit(close.socket(a))
+ headreq <- paste("HEAD", rurl, "HTTP/1.0\r\nConnection: Keep-Alive\r\nAccept: text/plain\r\n\r\n")
+ write.socket(a, headreq)
+ head <- read.socket(a, maxlen = 8000)
+ b <- strsplit(head, "\n")[[1]]
+ if (length(grep("200 OK", b[1])) == 0) stop(b[1])
+ len <- as.numeric(strsplit(grep("Content-Length", b, value = TRUE),
+ ":")[[1]][2])
+ getreq <- paste("GET", rurl, "HTTP/1.0\r\nConnection: Keep-Alive\r\nAccept: text/plain\r\n\r\n")
+ write.socket(a, getreq)
+ junk <- read.socket(a, maxlen = nchar(head))
+ data <- ""
+ b <- strsplit(c(head, junk), "\n")
+ nn <- length(b[[1]])
+ if (length(b[[2]]) > nn)
+ data <- paste(b[[2]][-(1:nn)], collapse = "\n")
+ while (nchar(data) < len) {
+ data <- paste(data, read.socket(a, maxlen = len - nchar(data)),
+ sep = "")
+ }
+ strsplit(data, "\n")[[1]]
+}
+
+if(nzchar(Sys.getenv("http_proxy")) || nzchar(Sys.getenv("HTTP_PROXY"))) {
+ cat("http proxy is set, so skip test of http over sockets\n")
+} else {
+ f <- httpget("http://www.stats.ox.ac.uk/pub/datasets/csb/ch11b.dat")
+ str(f)
+ stopifnot(length(f) == 100L)
+}
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/lapack.R b/com.oracle.truffle.r.native/gnur/tests/src/lapack.R
new file mode 100644
index 0000000000000000000000000000000000000000..2b560635564fd104efebe3a1fdf1931a2a95f40d
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/lapack.R
@@ -0,0 +1,152 @@
+## tests of R functions based on the lapack module
+
+## NB: the signs of singular and eigenvectors are arbitrary,
+## so there may be differences from the reference ouptut,
+## especially when alternative BLAS are used.
+
+options(digits=4)
+
+## ------- examples from ?svd ---------
+
+hilbert <- function(n) { i <- 1:n; 1 / outer(i - 1, i, "+") }
+Eps <- 100 * .Machine$double.eps
+
+X <- hilbert(9)[,1:6]
+(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
+
+# The signs of the vectors are not determined here.
+X <- cbind(1, 1:7)
+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
+
+# test nu and nv
+s <- svd(X, nu = 0)
+s <- svd(X, nu = 7) # the last 5 columns are not determined here
+stopifnot(dim(s$u) == c(7,7))
+s <- svd(X, nv = 0)
+
+# test of complex case
+
+X <- cbind(1, 1:7+(-3:3)*1i)
+s <- svd(X); D <- diag(s$d)
+stopifnot(abs(X - s$u %*% D %*% Conj(t(s$v))) < Eps)
+stopifnot(abs(D - Conj(t(s$u)) %*% X %*% s$v) < Eps)
+
+
+
+## ------- tests of random real and complex matrices ------
+fixsign <- function(A) {
+ A[] <- apply(A, 2, function(x) x*sign(Re(x[1])))
+ A
+}
+## 100 may cause failures here.
+eigenok <- function(A, E, Eps=1000*.Machine$double.eps)
+{
+ print(fixsign(E$vectors))
+ print(zapsmall(E$values))
+ V <- E$vectors; lam <- E$values
+ stopifnot(abs(A %*% V - V %*% diag(lam)) < Eps,
+ abs(lam[length(lam)]/lam[1]) < Eps || # this one not for singular A :
+ abs(A - V %*% diag(lam) %*% t(V)) < Eps)
+}
+
+Ceigenok <- function(A, E, Eps=1000*.Machine$double.eps)
+{
+ print(fixsign(E$vectors))
+ print(signif(E$values, 5))
+ V <- E$vectors; lam <- E$values
+ stopifnot(Mod(A %*% V - V %*% diag(lam)) < Eps,
+ Mod(A - V %*% diag(lam) %*% Conj(t(V))) < Eps)
+}
+
+## failed for some 64bit-Lapack-gcc combinations:
+sm <- cbind(1, 3:1, 1:3)
+eigenok(sm, eigen(sm))
+eigenok(sm, eigen(sm, sym=FALSE))
+
+set.seed(123)
+sm <- matrix(rnorm(25), 5, 5)
+sm <- 0.5 * (sm + t(sm))
+eigenok(sm, eigen(sm))
+eigenok(sm, eigen(sm, sym=FALSE))
+
+sm[] <- as.complex(sm)
+Ceigenok(sm, eigen(sm))
+Ceigenok(sm, eigen(sm, sym=FALSE))
+
+sm[] <- sm + rnorm(25) * 1i
+sm <- 0.5 * (sm + Conj(t(sm)))
+Ceigenok(sm, eigen(sm))
+Ceigenok(sm, eigen(sm, sym=FALSE))
+
+
+## ------- tests of integer matrices -----------------
+
+set.seed(123)
+A <- matrix(rpois(25, 5), 5, 5)
+
+A %*% A
+crossprod(A)
+tcrossprod(A)
+
+solve(A)
+qr(A)
+determinant(A, log = FALSE)
+
+rcond(A)
+rcond(A, "I")
+rcond(A, "1")
+
+eigen(A)
+svd(A)
+La.svd(A)
+
+As <- crossprod(A)
+E <- eigen(As)
+E$values
+abs(E$vectors) # signs vary
+chol(As)
+backsolve(As, 1:5)
+
+## ------- tests of logical matrices -----------------
+
+set.seed(123)
+A <- matrix(runif(25) > 0.5, 5, 5)
+
+A %*% A
+crossprod(A)
+tcrossprod(A)
+
+Q <- qr(A)
+zapsmall(Q$qr)
+zapsmall(Q$qraux)
+determinant(A, log = FALSE) # 0
+
+rcond(A)
+rcond(A, "I")
+rcond(A, "1")
+
+E <- eigen(A)
+zapsmall(E$values)
+zapsmall(Mod(E$vectors))
+S <- svd(A)
+zapsmall(S$d)
+S <- La.svd(A)
+zapsmall(S$d)
+
+As <- A
+As[upper.tri(A)] <- t(A)[upper.tri(A)]
+det(As)
+E <- eigen(As)
+E$values
+zapsmall(E$vectors)
+solve(As)
+
+## quite hard to come up with an example where this might make sense.
+Ac <- A; Ac[] <- as.logical(diag(5))
+chol(Ac)
+
+
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/libcurl.R b/com.oracle.truffle.r.native/gnur/tests/src/libcurl.R
new file mode 100644
index 0000000000000000000000000000000000000000..48dcce434497b5c2cf33aabb57156210960e6861
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/libcurl.R
@@ -0,0 +1,109 @@
+## These are tests that require libcurl functionality and a working
+## Internet connection.
+
+## As from R 3.4.0 method = "libcurl" is the default on a Unix-alike
+## so this is in small part duplication -- but not on Windows.
+
+if(!capabilities()["libcurl"]) {
+ warning("no libcurl support")
+ q()
+}
+
+if(.Platform$OS.type == "unix" &&
+ is.null(nsl("cran.r-project.org"))) q()
+
+example(curlGetHeaders, run.donttest = TRUE)
+
+tf <- tempfile()
+download.file("http://cran.r-project.org/", tf, method = "libcurl")
+file.size(tf)
+unlink(tf)
+
+tf <- tempfile()
+download.file("ftp://ftp.stats.ox.ac.uk/pub/datasets/csb/ch11b.dat",
+ tf, method = "libcurl")
+file.size(tf) # 2102
+unlink(tf)
+
+
+## test url connections on http
+str(readLines(zz <- url("http://cran.r-project.org/", method = "libcurl")))
+zz
+stopifnot(identical(summary(zz)$class, "url-libcurl"))
+close(zz)
+
+## https URL
+head(readLines(zz <- url("https://httpbin.org", method = "libcurl"),
+ warn = FALSE))
+close(zz)
+
+## redirection (to a https:// URL)
+head(readLines(zz <- url("http://bugs.r-project.org", method = "libcurl"),
+ warn = FALSE))
+close(zz)
+
+
+## check graceful failure: warnings leading to error
+## testUnknownUrlError <- tryCatch(suppressWarnings({
+## zz <- url("http://foo.bar", "r", method = "libcurl")
+## }), error=function(e) {
+## conditionMessage(e) == "cannot open connection"
+## })
+## close(zz)
+## stopifnot(testUnknownUrlError)
+
+## tf <- tempfile()
+## testDownloadFileError <- tryCatch(suppressWarnings({
+## download.file("http://foo.bar", tf, method="libcurl")
+## }), error=function(e) {
+## conditionMessage(e) == "cannot download all files"
+## })
+## stopifnot(testDownloadFileError, !file.exists(tf))
+
+tf <- tempfile()
+testDownloadFile404 <- tryCatch(suppressWarnings({
+ download.file("http://httpbin.org/status/404", tf, method="libcurl")
+}), error=function(e) {
+ conditionMessage(e) == "cannot open URL 'http://httpbin.org/status/404'"
+})
+stopifnot(testDownloadFile404, !file.exists(tf))
+
+## check specific warnings
+## testUnknownUrl <- tryCatch({
+## zz <- url("http://foo.bar", "r", method = "libcurl")
+## }, warning=function(e) {
+## grepl("Couldn't resolve host name", conditionMessage(e))
+## })
+## close(zz)
+## stopifnot(testUnknownUrl)
+
+test404.1 <- tryCatch({
+ open(zz <- url("http://httpbin.org/status/404", method="libcurl"))
+}, warning=function(w) {
+ grepl("404 Not Found", conditionMessage(w))
+})
+close(zz)
+stopifnot(test404.1)
+
+## via read.table (which closes the connection)
+tail(read.table(url("http://www.stats.ox.ac.uk/pub/datasets/csb/ch11b.dat",
+ method = "libcurl")))
+tail(read.table(url("ftp://ftp.stats.ox.ac.uk/pub/datasets/csb/ch11b.dat",
+ method = "libcurl")))
+
+## check option works
+options(url.method = "libcurl")
+zz <- url("http://www.stats.ox.ac.uk/pub/datasets/csb/ch11b.dat")
+stopifnot(identical(summary(zz)$class, "url-libcurl"))
+close(zz)
+head(readLines("https://httpbin.org", warn = FALSE))
+
+test404.2 <- tryCatch({
+ open(zz <- url("http://httpbin.org/status/404"))
+}, warning = function(w) {
+ grepl("404 Not Found", conditionMessage(w))
+})
+close(zz)
+stopifnot(test404.2)
+
+showConnections(all = TRUE)
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/lm-tests.R b/com.oracle.truffle.r.native/gnur/tests/src/lm-tests.R
new file mode 100644
index 0000000000000000000000000000000000000000..c50bebcf15c0e18c2b12b2ef0d419bdaaf346804
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/lm-tests.R
@@ -0,0 +1,78 @@
+###-- Linear Models, basic functionality -- weights included.
+
+## From John Maindonald :
+roller <- data.frame(
+ weight = c(1.9, 3.1, 3.3, 4.8, 5.3, 6.1, 6.4, 7.6, 9.8, 12.4),
+ depression = c( 2, 1, 5, 5, 20, 20, 23, 10, 30, 25))
+
+roller.lmu <- lm(weight~depression, data=roller)
+roller.lsfu <- lsfit(roller$depression, roller$weight)
+
+roller.lsf <- lsfit(roller$depression, roller$weight, wt = 1:10)
+roller.lsf0 <- lsfit(roller$depression, roller$weight, wt = 0:9)
+roller.lm <- lm(weight~depression, data=roller, weights= 1:10)
+roller.lm0 <- lm(weight~depression, data=roller, weights= 0:9)
+roller.lm9 <- lm(weight~depression, data=roller[-1,],weights= 1:9)
+roller.glm <- glm(weight~depression, data=roller, weights= 1:10)
+roller.glm0<- glm(weight~depression, data=roller, weights= 0:9)
+
+predict(roller.glm0, type="terms")# failed till 2003-03-31
+
+## FIXME : glm()$residual [1] is NA, lm()'s is ok.
+## all.equal(residuals(roller.glm0, type = "partial"),
+## residuals(roller.lm0, type = "partial") )
+
+
+all.equal(deviance(roller.lm),
+ deviance(roller.glm))
+all.equal(weighted.residuals(roller.lm),
+ residuals (roller.glm))
+
+all.equal(deviance(roller.lm0),
+ deviance(roller.glm0))
+all.equal(weighted.residuals(roller.lm0, drop=FALSE),
+ residuals (roller.glm0))
+
+(im.lm0 <- influence.measures(roller.lm0))
+
+all.equal(unname(im.lm0 $ infmat),
+ unname(cbind( dfbetas (roller.lm0)
+ , dffits (roller.lm0)
+ , covratio (roller.lm0)
+ ,cooks.distance(roller.lm0)
+ ,lm.influence (roller.lm0)$hat)
+ ))
+
+all.equal(rstandard(roller.lm9),
+ rstandard(roller.lm0),tolerance = 1e-14)
+all.equal(rstudent(roller.lm9),
+ rstudent(roller.lm0),tolerance = 1e-14)
+all.equal(rstudent(roller.lm),
+ rstudent(roller.glm))
+all.equal(cooks.distance(roller.lm),
+ cooks.distance(roller.glm))
+
+
+all.equal(summary(roller.lm0)$coefficients,
+ summary(roller.lm9)$coefficients, tolerance = 1e-14)
+all.equal(print(anova(roller.lm0), signif.st=FALSE),
+ anova(roller.lm9), tolerance = 1e-14)
+
+
+### more regression tests for lm(), glm(), etc :
+
+## moved from ?influence.measures:
+lm.SR <- lm(sr ~ pop15 + pop75 + dpi + ddpi, data = LifeCycleSavings)
+(IM <- influence.measures(lm.SR))
+summary(IM)
+## colnames will differ in the next line
+all.equal(dfbetas(lm.SR), IM$infmat[, 1:5], check.attributes = FALSE,
+ tolerance = 1e-12)
+
+signif(dfbeta(lm.SR), 3)
+covratio (lm.SR)
+
+## predict.lm(.)
+
+all.equal(predict(roller.lm, se.fit=TRUE)$se.fit,
+ predict(roller.lm, newdata=roller, se.fit=TRUE)$se.fit, tolerance = 1e-14)
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/method-dispatch.R b/com.oracle.truffle.r.native/gnur/tests/src/method-dispatch.R
new file mode 100644
index 0000000000000000000000000000000000000000..567ecb75ac5d2771ef60807f2730773fbec3e045
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/method-dispatch.R
@@ -0,0 +1,62 @@
+#### Testing UseMethod() and even more NextMethod()
+#### --------------------
+#### i.e., S3 methods *only*. For S4, see reg-S4.R
+## ~~~~~~~~
+
+###-- Group methods
+
+## previous versions used print() and hit an auto-printing bug.
+
+### Arithmetic "Ops" :
+">.bar" <- function(...) {cat("using >.bar\n"); FALSE}
+">.foo" <- function(...) {cat("using >.foo\n"); TRUE}
+Ops.foo <- function(...) {
+ cat("using Ops.foo\n")
+ NextMethod()
+}
+Ops.bar <- function(...) {
+ cat("using Ops.bar\n")
+ TRUE
+}
+
+x <- 2:4 ; class(x) <- c("foo", "bar")
+y <- 4:2 ; class(y) <- c("bar", "foo")
+
+## The next 4 give a warning each about incompatible methods:
+x > y
+y < x # should be the same (warning msg not, however)
+x == y
+x <= y
+
+x > 3 ##[1] ">.foo"
+
+rm(list=">.foo")
+x > 3 #-> "Ops.foo" and ">.bar"
+
+
+
+### ------------ was ./mode-methods.R till R ver. 1.0.x ----------------
+
+###-- Using Method Dispatch on "mode" etc :
+## Tests S3 dispatch with the class attr forced to be data.class
+## Not very relevant when S4 methods are around, but kept for historical interest
+abc <- function(x, ...) {
+ cat("abc: Before dispatching; x has class `", class(x), "':", sep="")
+ str(x)
+ UseMethod("abc", x) ## UseMethod("abc") (as in S) fails
+}
+
+abc.default <- function(x, ...) sys.call()
+
+"abc.(" <- function(x)
+ cat("'(' method of abc:", deparse(sys.call(sys.parent())),"\n")
+abc.expression <- function(x)
+ cat("'expression' method of abc:", deparse(sys.call(sys.parent())),"\n")
+
+abc(1)
+e0 <- expression((x))
+e1 <- expression(sin(x))
+abc(e0)
+abc(e1)
+abc(e0[[1]])
+abc(e1[[1]])
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/ok-errors.R b/com.oracle.truffle.r.native/gnur/tests/src/ok-errors.R
new file mode 100644
index 0000000000000000000000000000000000000000..b6a58f9a9e19285a07800e80980174020fb0749b
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/ok-errors.R
@@ -0,0 +1,24 @@
+#### STRICT test suite in the spirit of no-segfaults,
+#### but with explicit statements.
+
+options(error=expression(NULL))
+stop("test of `options(error=expression(NULL))'")
+
+if(FALSE) {
+## these ought to work on machines with enough memory
+## These segfaulted in 1.3.x , give "could not allocate" errors now
+ integer(2^30+1)
+ double(2^30+1)
+ complex(2^30+1)
+character(2^30+1)
+vector("list", 2^30+2)
+}
+
+## bad infinite recursion / on.exit / ... interactions
+## catch the error to permit different error messages emitted
+## (handling of infinite recursion is different in the AST interpreter
+## and the byte-code interpreter)
+
+bar <- function() 1+1
+foo <- function() { on.exit(bar()); foo() }
+tryCatch(foo(), error=function(x) TRUE) # now simple "infinite recursion"
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/p-qbeta-strict-tst.R b/com.oracle.truffle.r.native/gnur/tests/src/p-qbeta-strict-tst.R
new file mode 100644
index 0000000000000000000000000000000000000000..fe9b27cced57ad87335943510286eb0fd1524cad
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/p-qbeta-strict-tst.R
@@ -0,0 +1,411 @@
+options(warn = 2)# warnings are errors here
+pdf("p-qbeta-strict-tst.pdf")
+
+a <- 25; b <- 6
+x <- 2^-(300:200)
+if(interactive() && require(Rmpfr)) {
+ pbi <- pbetaI(x, a,b, log.p=TRUE, precBits = 2048)
+ ## plus experiments, to see that 2048 bits are way enough ...
+ dput(format(roundMpfr(pbi, 64))) ##
+} ## plus manual editing, removing all ' " ' :
+
+lpb <- c(
+-5186.73671481652222237, -5169.40803530252358966, -5152.07935578852495651,
+-5134.75067627452632379, -5117.42199676052769108, -5100.09331724652905837,
+-5082.76463773253042566, -5065.43595821853179295, -5048.10727870453316024,
+-5030.77859919053452753, -5013.44991967653589482, -4996.12124016253726211,
+-4978.79256064853862940, -4961.46388113453999669, -4944.13520162054136398,
+-4926.80652210654273127, -4909.47784259254409855, -4892.14916307854546584,
+-4874.82048356454683313, -4857.49180405054820042, -4840.16312453654956727,
+-4822.83444502255093456, -4805.50576550855230185, -4788.17708599455366913,
+-4770.84840648055503642, -4753.51972696655640371, -4736.19104745255777100,
+-4718.86236793855913829, -4701.53368842456050558, -4684.20500891056187287,
+-4666.87632939656324016, -4649.54764988256460745, -4632.21897036856597474,
+-4614.89029085456734203, -4597.56161134056870932, -4580.23293182657007661,
+-4562.90425231257144389, -4545.57557279857281118, -4528.24689328457417803,
+-4510.91821377057554532, -4493.58953425657691261, -4476.26085474257827990,
+-4458.93217522857964719, -4441.60349571458101448, -4424.27481620058238176,
+-4406.94613668658374905, -4389.61745717258511634, -4372.28877765858648363,
+-4354.96009814458785092, -4337.63141863058921821, -4320.30273911659058550,
+-4302.97405960259195279, -4285.64538008859332008, -4268.31670057459468737,
+-4250.98802106059605466, -4233.65934154659742195, -4216.33066203259878879,
+-4199.00198251860015608, -4181.67330300460152337, -4164.34462349060289066,
+-4147.01594397660425795, -4129.68726446260562524, -4112.35858494860699253,
+-4095.02990543460835982, -4077.70122592060972710, -4060.37254640661109439,
+-4043.04386689261246168, -4025.71518737861382897, -4008.38650786461519626,
+-3991.05782835061656333, -3973.72914883661793062, -3956.40046932261929791,
+-3939.07178980862066520, -3921.74311029462203249, -3904.41443078062339977,
+-3887.08575126662476706, -3869.75707175262613435, -3852.42839223862750164,
+-3835.09971272462886871, -3817.77103321063023600, -3800.44235369663160329,
+-3783.11367418263297058, -3765.78499466863433787, -3748.45631515463570516,
+-3731.12763564063707245, -3713.79895612663843973, -3696.47027661263980702,
+-3679.14159709864117409, -3661.81291758464254138, -3644.48423807064390867,
+-3627.15555855664527596, -3609.82687904264664325, -3592.49819952864801054,
+-3575.16952001464937783, -3557.84084050065074512, -3540.51216098665211240,
+-3523.18348147265347947, -3505.85480195865484676, -3488.52612244465621405,
+-3471.19744293065758134, -3453.86876341665894863)
+stopifnot( all.equal(lpb, pbeta(x,a,b,log.=TRUE), tol=2e-16) )# pbeta() check
+
+
+qpb <- qbeta(lpb, a,b, log.p=TRUE)
+stopifnot(qpb > 0)# ok R >= 3.2.0, not in R 3.1.x
+## ideally x == qbeta(pbeta(x, *), *) :
+all.equal(x, qpb, tol=0)# now: 4.986e-15 (was 5.238e-15)
+relE <- 1 - qpb/x
+mean(abs(relE)) # 1.145508e-14 (was 1.3182e-14)
+stopifnot(mean(abs(relE)) < 4e-14,
+ max (abs(relE)) < 1e-13)
+
+## a less extreme set -- but which uses *many* Newton iterations in qbeta()
+a <- 25; b <- 6
+x1 <- 2^-((20:120)/8)
+if(interactive() && require(Rmpfr)) {
+ pbi <- pbetaI(x, a,b, log.p=TRUE, precBits = 2048)
+ ## plus experiments, to see that 2048 bits are way enough ...
+ dput(format(roundMpfr(pbi, 64))) ##
+} ## plus manual editing, removing all ' " ' :
+
+lp1 <- c(
+-32.3854423368776834953, -34.4673775119354555037, -36.5575116684945878344,
+-38.6549408996236989744, -40.7588797271766572448, -42.8686422494639326058,
+-44.9836268805878782655, -47.1033038887113481505, -49.2272051373989160267,
+-51.3549155771523890938, -53.4860661393789178081, -55.6203277631858045461,
+-57.7574063441183625303, -59.8970384385116822318, -62.0389875912418167943,
+-64.1830411810069771730, -66.3290076977781794185, -68.4767143831449023872,
+-70.6260051769883206996, -72.7767389240201063513, -74.9287878018119846216,
+-77.0820359384527194757, -79.2363781932417950496, -81.3917190781217361681,
+-83.5479718010642398301, -85.7050574155147660699, -87.8629040623880331051,
+-90.0214462930893329073, -92.1806244636893542185, -94.3403841917643962364,
+-96.5006758685776125997, -98.6614542202591991785, -100.822677912475871277,
+-102.984309193787888156, -105.146313573496065365, -107.308659530298884925,
+-109.471318248524419364, -111.634263379085354198, -113.797470822637087941,
+-115.960918532706589869, -118.124586336810151355, -120.288455773796669625,
+-122.452509945844263323, -124.616733383705931573, -126.781111923947395655,
+-128.945632597050500942, -131.110283525370608940, -133.275053830038264766,
+-135.439933545985967511, -137.604913544361364852, -139.769985461659902712,
+-141.935141634974191005, -144.100375042814531426, -146.265679251006534833,
+-148.431048363217896496, -150.596476975707801879, -152.761960135929819787,
+-154.927493304652777115, -157.093072321294422056, -159.258693372190260479,
+-161.424352961544612370, -163.590047884833502595, -165.755775204449382204,
+-167.921532227396093043, -170.087316484859319879, -172.253125713493005638,
+-174.418957838276008993, -176.584810956806029708, -178.750683324909148353,
+-180.916573343453874659, -183.082479546268141732, -185.248400589066309921,
+-187.414335239301226746, -189.580282366863611607, -191.746240935557583460,
+-193.912209995287317457, -196.078188674895169383, -198.244176175596733075,
+-200.410171764962911981, -202.576174771403232380, -204.742184579108529904,
+-206.908200623414650632, -209.074222386551973982, -211.240249393748649162,
+-213.406281209657976525, -215.572317435082926512, -217.738357703973061677,
+-219.904401680671135980, -222.070449057388595873, -224.236499551890932400,
+-226.402552905375368947, -228.568608880524961821, -230.734667259724367416,
+-232.900727843423843350, -235.066790448639183389, -237.232854907576249937,
+-239.398921066369763294, -241.564988783926857030, -243.731057930866643141,
+-245.897128388547890981, -248.063200048177428608)
+stopifnot( all.equal(lp1, pbeta(x1,a,b,log.=TRUE), tol=2e-16) )# pbeta() check
+
+qp1 <- qbeta(lp1, a,b, log.p=TRUE)
+stopifnot(qp1 > 0)
+## ideally x == qbeta(pbeta(x, *), *) :
+all.equal(x1, qp1, tol=0)# now: 2.99e-16 , but
+relE <- 1 - qp1/x1
+mean(abs(relE)) # 5.463177e-16 was 6.089738e-16
+stopifnot(mean(abs(relE)) < 3e-15,
+ max (abs(relE)) < 1e-14)
+
+## log.p=FALSE: --- here (with DEBUG), see number of Newton steps
+
+p1 <- exp(lp1)
+qp1. <- qbeta(p1, a,b)
+## --> many cases that need "too many" Newton steps (on x0 scale: rather use log(x)-scale!)
+
+relE. <- 1 - qp1./x1
+mean(abs(relE.)) # 4.078146e-16
+ max(abs(relE.)) # 1.332268e-15
+all.equal(qp1, qp1., tol=0) # 3.083e-16
+stopifnot(all.equal(qp1, qp1., tol=8*.Machine$double.eps),
+ mean(abs(relE.)) < 2e-15,
+ max (abs(relE.)) < 7e-15 )
+
+
+a <- 43779; b <- 0.06728; x <- -exp(901/256)
+(qx <- qbeta(x , a,b, log=TRUE)) ## (157 iterations in log_x scale); fast in orig.scale
+## 0.9993614
+(pq <- pbeta(qx, a,b, log=TRUE)) ## = -33.7686
+1 - pq/x # rel.err ~ 8.88e-16 "perfect"
+stopifnot(abs(1 - pq/x) < 1e-15)
+## but it uses probably the wrong swap_tail decision...
+curve(pbeta(exp(x), a,b, log=TRUE), -1e-3, -1e-7, n=1025) # "the same" as
+par(new=TRUE)
+curve(pbeta( x, a,b, log=TRUE), 0.999, 1-1e-7, col=2, ylab="", xaxt="n"); axis(3)
+abline(v = qx, h = x, col="light blue", lty = 2)
+
+## as is this one -- the mirror image:
+(x. <- log1p(-exp(x))) # -2.160156e-15
+(q. <- qbeta(x., b,a, log=TRUE, lower.tail=FALSE))# very quick convergence: u0 is perfect
+## 1.425625e-223
+(p. <- pbeta(q., b,a, log=TRUE, lower.tail=FALSE))
+stopifnot(all.equal(p., x., tol = 1e-15))
+
+## very different picture at the *other tail*:
+(q2 <- qbeta(x., b,a, log=TRUE)) ## 0.0006386087
+stopifnot(all.equal(pbeta(q2, b,a, log=TRUE), x., tol= 1e-13)) # Lx 64b: 2.37e-15
+
+curve(pbeta(x, b,a, log=TRUE), 1e-30, .5, n=1025, log="x")
+# Flip vertically and use log scale ==> "close" to -x. = 2.160156e-15
+curve(-pbeta(x, b,a, log=TRUE), 1e-8, .005, n=1025, log="xy")
+abline(v = q2, h = -x., lty=3, col=2)
+
+### more extreme (a,b) [still computable with Rmpfr pbetaI():]
+a <- 800; b <- 2
+x <- 2^-c(10*(100:4), 37, 2*(17:14), 27:2, (8:1)/8)
+curve(pbeta(x,a,b, log=TRUE), n=1025, log="x", 1e-200, .1); mtext(R.version.string)
+axis(1, at=0.1); abline(h=0, lty=2)
+
+if(interactive() && require(Rmpfr)) {
+ pbi <- pbetaI(x, a,b, log.p=TRUE, precBits = 2048)
+ ## plus experiments, to see that 2048 bits are way enough ...
+ dput(format(roundMpfr(pbi, 64))) ##
+ stopifnot( all.equal(pbi, pbeta(x,a,b,log.=TRUE), tol=2e-16) )
+} ## plus manual editing, removing all ' " ' :
+
+lp2 <- c(-554511.058587009179178, -548965.881142529616682, -543420.703698050054243,
+-537875.526253570491747, -532330.348809090929251, -526785.171364611366812,
+-521239.993920131804316, -515694.816475652241849, -510149.639031172679381,
+-504604.461586693116885, -499059.284142213554418, -493514.106697733991950,
+-487968.929253254429483, -482423.751808774866987, -476878.574364295304520,
+-471333.396919815742052, -465788.219475336179556, -460243.042030856617089,
+-454697.864586377054621, -449152.687141897492154, -443607.509697417929658,
+-438062.332252938367191, -432517.154808458804723, -426971.977363979242256,
+-421426.799919499679760, -415881.622475020117292, -410336.445030540554825,
+-404791.267586060992329, -399246.090141581429862, -393700.912697101867394,
+-388155.735252622304927, -382610.557808142742431, -377065.380363663179963,
+-371520.202919183617496, -365975.025474704055000, -360429.848030224492533,
+-354884.670585744930065, -349339.493141265367598, -343794.315696785805102,
+-338249.138252306242634, -332703.960807826680167, -327158.783363347117700,
+-321613.605918867555204, -316068.428474387992736, -310523.251029908430269,
+-304978.073585428867773, -299432.896140949305305, -293887.718696469742838,
+-288342.541251990180371, -282797.363807510617875, -277252.186363031055407,
+-271707.008918551492940, -266161.831474071930444, -260616.654029592367976,
+-255071.476585112805509, -249526.299140633243027, -243981.121696153680560,
+-238435.944251674118078, -232890.766807194555611, -227345.589362714993129,
+-221800.411918235430647, -216255.234473755868180, -210710.057029276305698,
+-205164.879584796743231, -199619.702140317180749, -194074.524695837618282,
+-188529.347251358055800, -182984.169806878493333, -177438.992362398930851,
+-171893.814917919368369, -166348.637473439805902, -160803.460028960243420,
+-155258.282584480680953, -149713.105140001118471, -144167.927695521556004,
+-138622.750251041993522, -133077.572806562431055, -127532.395362082868573,
+-121987.217917603306098, -116442.040473123743624, -110896.863028644181149,
+-105351.685584164618675, -99806.5081396850562001, -94261.3306952054937184,
+-88716.1532507259312439, -83170.9758062463687693, -77625.7983617668062948,
+-72080.6209172872438202, -66535.4434728076813457, -60990.2660283281188711,
+-55445.0885838485563930, -49899.9111393689939185, -44354.7336948894314439,
+-38809.5562504098689693, -33264.3788059303064912, -27719.2013614507440185,
+-22174.0239169711824498, -20510.4706836273200672, -18846.9174502835021912,
+-17737.8819613877641022, -16628.8464724925492266, -15519.8109835994272112,
+-14965.2932391551916034, -14410.7754947146766344, -13856.2577502816029460,
+-13301.7400058634118150, -12747.2222614749858050, -12192.7045171460900432,
+-11638.1867729362548083, -11083.6690289645407566, -10529.1512854690695820,
+-9974.63354292608620089, -9420.11580228808657456, -8865.59806546008711603,
+-8311.08033625221863883, -7756.56262228513473200, -7202.04493880171055809,
+-6647.52731629396961299, -6093.00981577106128650, -5538.49255935177176768,
+-4983.97579167624661567, -4429.46000364007375882, -3874.94618353590282056,
+-3320.43633428133439223, -2765.93456971959801893, -2211.44957214006085544,
+-1657.00072545683415248, -1102.63689396137728749, -548.523783020649678355,
+-479.303685612597087790, -410.103507771019607286, -340.930746845646155091,
+-271.797948987745926763, -202.728589967468744076, -133.775198381652975971,
+-65.1041210297877634069)
+stopifnot( all.equal(lp2, pbeta(x,a,b,log.=TRUE), tol=2e-16) )# pbeta() check
+
+qp2 <- qbeta(lp2, a,b, log.p=TRUE)# 7 precision warnings in R <= 3.1.0
+pq2 <- pbeta(qp2, a,b, log.p=TRUE)
+stopifnot(qp2 > 0, is.finite(pq2))
+## ideally x == qbeta(pbeta(x, *), *) :
+all.equal( x, qp2, tol=0)# 2.075e-16 was 1.956845e-08, but .. *misleading* a bit
+all.equal(log(x), log(qp2), tol=0)# 1.676e-16 was 1.0755 !!
+plot(qp2 ~ lp2, log='y', type='b', sub=R.version.string); V <- -5e4; abline(v = V, lty=3)
+plot(qp2 ~ lp2, log='y', type='b', sub=R.version.string, subset = lp2 > V)
+## ideally lp2 == pbeta(qbeta(lp2, *), *) :
+all.equal(lp2, pq2, tol=0)# 1.26e-16; was 1.07...
+plot(lp2, pq2, type='b', sub=R.version.string)
+plot(pq2 ~ lp2, type='b', sub=R.version.string, subset = log2(x) >= -80)
+axis(3, at=lp2, labels=log2(x), col="blue3")
+
+relE <- 1 - qp2/x
+rel2 <- 1 - pq2/lp2
+mean(abs(relE)) # 1.53e-14 was 0.9913043 (R 3.1.0), then 0.8521738
+mean(abs(rel2)) # ~ 3e-17 (!); was 0.9913043 (R 3.1.0), then 0.8521738
+stopifnot(mean(abs(relE)) < 7e-14,
+ max (abs(relE)) < 6e-13,
+ mean(abs(rel2)) < 4e-16,
+ max (abs(rel2)) < 8e-16)
+
+
+### even more extreme (a,b) [still computable with Rmpfr pbetaI():]
+a <- 2^12; b <- 2
+x <- 2^-c(10*(100:2), 17, 2*(7:4), 7:1, .5, .25)
+curve(pbeta(x,a,b, log=TRUE), n=1025, log="x", 1e-300, .1);mtext(R.version.string)
+
+if(interactive() && require(Rmpfr)) {
+ pbi <- pbetaI(x, a,b, log.p=TRUE, precBits = 2048)
+ ## plus experiments, to see that 2048 bits are way enough ...
+ dput(format(roundMpfr(pbi, 64))) ##
+ stopifnot( all.equal(pbi, pbeta(x,a,b,log.=TRUE), tol=2e-16) )
+} ## plus manual editing, removing all ' " ' :
+
+lp3 <- c(-2839122.53356325844061, -2810731.22504752308055, -2782339.91653178772071,
+-2753948.60801605236088, -2725557.29950031700105, -2697165.99098458164121,
+-2668774.68246884628115, -2640383.37395311092132, -2611992.06543737556149,
+-2583600.75692164020165, -2555209.44840590484182, -2526818.13989016948199,
+-2498426.83137443412193, -2470035.52285869876209, -2441644.21434296340226,
+-2413252.90582722804243, -2384861.59731149268259, -2356470.28879575732276,
+-2328078.98028002196270, -2299687.67176428660287, -2271296.36324855124303,
+-2242905.05473281588320, -2214513.74621708052337, -2186122.43770134516330,
+-2157731.12918560980347, -2129339.82066987444364, -2100948.51215413908380,
+-2072557.20363840372386, -2044165.89512266836402, -2015774.58660693300419,
+-1987383.27809119764424, -1958991.96957546228441, -1930600.66105972692458,
+-1902209.35254399156463, -1873818.04402825620480, -1845426.73551252084496,
+-1817035.42699678548502, -1788644.11848105012518, -1760252.80996531476535,
+-1731861.50144957940540, -1703470.19293384404557, -1675078.88441810868562,
+-1646687.57590237332579, -1618296.26738663796596, -1589904.95887090260601,
+-1561513.65035516724618, -1533122.34183943188634, -1504731.03332369652639,
+-1476339.72480796116656, -1447948.41629222580673, -1419557.10777649044678,
+-1391165.79926075508695, -1362774.49074501972711, -1334383.18222928436717,
+-1305991.87371354900733, -1277600.56519781364750, -1249209.25668207828755,
+-1220817.94816634292772, -1192426.63965060756777, -1164035.33113487220794,
+-1135644.02261913684811, -1107252.71410340148816, -1078861.40558766612833,
+-1050470.09707193076849, -1022078.78855619540860, -993687.480040460048713,
+-965296.171524724688823, -936904.863008989328989, -908513.554493253969099,
+-880122.245977518609209, -851730.937461783249319, -823339.628946047889485,
+-794948.320430312529595, -766557.011914577169705, -738165.703398841809872,
+-709774.394883106449981, -681383.086367371090091, -652991.777851635730201,
+-624600.469335900370368, -596209.160820165010477, -567817.852304429650587,
+-539426.543788694290754, -511035.235272958930864, -482643.926757223570974,
+-454252.618241488211112, -425861.309725752851222, -397470.001210017491360,
+-369078.692694282131498, -340687.384178546771608, -312296.075662811411746,
+-283904.767147076051856, -255513.458631340691994, -227122.150115605332118,
+-198730.841599869972242, -170339.533084134612366, -141948.224568399252504,
+-113556.916052663893531, -85165.6075369294638477, -56774.2990221466148739,
+-48256.9064741001263457, -39739.5139727740774909, -34061.2524527157125043,
+-28382.9914822588674710, -22704.7327152528820928, -19865.6057919927700013,
+-17026.4828436463425554, -14187.3679884148968711, -11348.2699182657980446,
+-8509.20804096757424162, -5670.23129358494148988, -2831.50574442529708752,
+-1412.47477359632328309, -703.301613239304818981)
+stopifnot( all.equal(lp3, pbeta(x,a,b,log.=TRUE), tol=2e-16) )# pbeta() check
+
+qp3 <- qbeta(lp3, a,b, log.p=TRUE)
+pq3 <- pbeta(qp3, a,b, log.p=TRUE)
+stopifnot(qp3 > 0, is.finite(pq3))
+## ideally x == qbeta(pbeta(x, *), *) :
+all.equal( x, qp3, tol=0)# 1.599e-16
+all.equal(log(x), log(qp3), tol=0)# 1.405e-16
+## ideally lp3 == pbeta(qbeta(lp3, *), *) :
+all.equal(lp3, pq3, tol=0)# 1.07... then TRUE!
+
+plot(pq3 ~ lp3, type='b', sub=R.version.string, subset = log2(x) >= -50)
+axis(3, at=lp3, labels=log2(x), col="blue2", col.axis="blue2")
+
+relE <- 1 - qp3/x
+rel2 <- 1 - pq3/lp3
+mean(abs(relE))# 1.518e-14 \\ 3.584e-14 for --disable-long-double
+mean(abs(rel2))# 0 !!
+
+stopifnot(mean(abs(rel2)) < 3e-15,
+ mean(abs(relE)) < 8e-14,
+ max (abs(relE)) < 4e-13)# 5.251e-14 \\ 2.140e-13 w/o long-double
+
+### pbeta() warnings /// close to underflow situation ----
+options(warn = 1)# warnings allowed, happen immediately
+
+## b = 1 ==> pbeta(x,a,1) = x^a (mathematically, not quite numerically)
+
+x <- 1e-311*2^(-2:5)
+
+a <- 9.9999e-16
+##==> all work via apser():
+all.equal(x^a, pbeta(x, a, 1), tol=0) # 1.11e-16 -- perfect
+all.equal(a*log(x), pbeta(x, a, 1, log=TRUE), tol=0)# 3.5765e-14 -- less perfect
+
+## only very slightly larger a:
+a <- 1e-15
+all.equal(x^a, pbeta(x, a, 1), tol=0)# warnings ! # 7.12208e-13
+## this gives *TWO* warnings per pbeta() !! --- no longer [pbeta / toms708.c fixed]
+all.equal(a*log(x), pbeta(x, a, 1, log=TRUE), tol=0)# 0.853 ... catastrophic!
+
+## pbeta(*, log.p=TRUE) now underflows to -Inf too often
+## If it does it *should* give a warning, at least!
+try.pb <- function(x, a,b, log.p=TRUE)
+ tryCatch(pbeta(x, a,b, log.p=log.p), error=identity, warning=identity)
+check.pb <- function(pb, true)
+ stopifnot((inherits(pb, "warning") && grepl("\\bInf\\b", pb$message)) ||
+ isTRUE(all.equal(print(pb), true, tol = 2e-7))) # << print(.) : see value
+
+## True values via require(Rmpfr); asNumeric(pbetaI(326/512, 1900, 38, log=TRUE))
+##
+## Those with*out* a '#' mark all did *not* underflow in R 2.9.1, nor R 2.10.1,
+## but did give NaN in 2.11.x (x >= 0) and -Inf later === *regression* _FIXME_
+## i.e., the fix for PR#14230 pbeta(x, 3, 2200, lower.tail=FALSE, log.p=TRUE),
+## svn diff -c51327 (2010-03-19) was *not* helpful in these cases
+##
+check.pb(try.pb(437/512, 4711, 19), true = -664.8560)# did work in R <= 2.10.1 (see above)
+check.pb(try.pb(442/512, 4998, 19), true = -653.6326)
+check.pb(try.pb(430/512, 4208, 20), true = -649.9831)
+check.pb(try.pb(428/512, 4348, 20), true = -693.6123)
+check.pb(try.pb(429/512, 4348, 20), true = -683.6925)
+check.pb(try.pb(421/512, 4012, 21), true = -695.9839)
+check.pb(try.pb(422/512, 4012, 21), true = -686.6862)
+check.pb(try.pb(423/512, 4012, 21), true = -677.4135)
+check.pb(try.pb(441/512, 4969, 20), true = -656.8775)
+check.pb(try.pb(442/512, 4969, 20), true = -645.8918)
+check.pb(try.pb(443/512, 4969, 20), true = -634.9354)
+
+check.pb(try.pb(407/512, 3455, 22), true = -700.4242)
+check.pb(try.pb(435/512, 4996, 23), true = -716.9553)
+check.pb(try.pb(397/512, 3000, 24), true = -664.8547)
+check.pb(try.pb(397/512, 3070, 24), true = -682.1341)
+check.pb(try.pb(393/512, 3070, 24), true = -712.4377)
+check.pb(try.pb(412/512, 3530, 24), true = -668.2493)
+
+check.pb(try.pb(400/512, 3085, 25), true = -659.8754)
+check.pb(try.pb(409/512, 3352, 25), true = -651.2284)
+check.pb(try.pb(400/512, 3352, 25), true = -723.8049)
+check.pb(try.pb(415/512, 3541, 25), true = -642.2389)
+check.pb(try.pb(430/512, 4291, 25), true = -646.8498)
+
+check.pb(try.pb(377/512, 2551, 26), true = -675.8778)
+check.pb(try.pb(370/512, 2551, 26), true = -722.4272)
+check.pb(try.pb(412/512, 3505, 26), true = -656.3025)
+
+check.pb(try.pb(370/512, 2499, 27), true = -702.7537)
+check.pb(try.pb(367/512, 2499, 27), true = -722.5556)
+
+check.pb(try.pb(363/512, 2318, 28), true = -685.6969)
+check.pb(try.pb(360/512, 2399, 28), true = -732.005)
+
+check.pb(try.pb(348/512, 2158, 29), true = -717.8487)
+check.pb(try.pb(367/512, 2397, 29), true = -683.2321)
+check.pb(try.pb(380/512, 2661, 29), true = -678.227)
+
+check.pb(try.pb(362/512, 2292, 30), true = -676.8534)
+check.pb(try.pb(369/512, 2495, 30), true = -698.3849)
+
+check.pb(try.pb(326/512, 1900, 38), true = -714.7700)
+## all those check.pb() above *did* work in R <= 2.10.1 ----
+
+## all those below have always underflowed (or worse) -- now give *warning* at least:
+check.pb(try.pb(412/512, 4996, 23), true = -982.6083)#
+check.pb(try.pb(400/512, 4291, 25), true = -949.7046)#
+
+check.pb(try.pb(370/512, 3700, 28), true = -1079.069)#
+check.pb(try.pb(401/512, 3700, 28), true = -788.0158)#
+check.pb(try.pb(351/512, 4777, 28), true = -1670.472)#
+
+check.pb(try.pb(365/512, 3699, 29), true = -1124.502)#
+check.pb(try.pb(341/512, 2146, 30), true = -752.5865)#
+
+check.pb(try.pb(289/512, 1900, 38), true = -936.9607)#
+check.pb(try.pb(290/512, 1900, 38), true = -930.5637)#
+check.pb(try.pb(293/512, 1900, 38), true = -911.5123)#
+check.pb(try.pb(295/512, 1900, 38), true = -898.9261)#
+check.pb(try.pb(296/512, 1900, 38), true = -892.6670)#
+check.pb(try.pb(302/512, 1900, 38), true = -855.5796)#
+check.pb(try.pb(305/512, 1900, 38), true = -837.3302)#
+check.pb(try.pb(308/512, 1900, 38), true = -819.2725)#
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/p-r-random-tests.R b/com.oracle.truffle.r.native/gnur/tests/src/p-r-random-tests.R
new file mode 100644
index 0000000000000000000000000000000000000000..7142d48993b788c6c7b87c8fab00a71c49d5b71e
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/p-r-random-tests.R
@@ -0,0 +1,138 @@
+##
+## RNG tests using DKW inequality for rate of convergence
+##
+## P(sup | F_n - F | > t) < 2 exp(-2nt^2)
+##
+## The 2 in front of exp() was derived by Massart. It is the best possible
+## constant valid uniformly in t,n,F. For large n*t^2 this agrees with the
+## large-sample approximation to the Kolmogorov-Smirnov statistic.
+##
+
+
+superror <- function(rfoo,pfoo,sample.size,...) {
+ x <- rfoo(sample.size,...)
+ tx <- table(signif(x, 12)) # such that xi will be sort(unique(x))
+ xi <- as.numeric(names(tx))
+ f <- pfoo(xi,...)
+ fhat <- cumsum(tx)/sample.size
+ max(abs(fhat-f))
+}
+
+pdkwbound <- function(n,t) 2*exp(-2*n*t*t)
+
+qdkwbound <- function(n,p) sqrt(log(p/2)/(-2*n))
+
+dkwtest <- function(stub = "norm", ...,
+ sample.size = 10000, pthreshold = 0.001,
+ print.result = TRUE, print.detail = FALSE,
+ stop.on.failure = TRUE)
+{
+ rfoo <- eval(as.name(paste("r", stub, sep="")))
+ pfoo <- eval(as.name(paste("p", stub, sep="")))
+ s <- superror(rfoo, pfoo, sample.size, ...)
+ if (print.result || print.detail) {
+ printargs <- substitute(list(...))
+ printargs[[1]] <- as.name(stub)
+ cat(deparse(printargs))
+ if (print.detail)
+ cat("\nsupremum error = ",signif(s,2),
+ " with p-value=",min(1,round(pdkwbound(sample.size,s),4)),"\n")
+ }
+ rval <- (s < qdkwbound(sample.size,pthreshold))
+ if (print.result)
+ cat(c(" FAILED\n"," PASSED\n")[rval+1])
+ if (stop.on.failure && !rval)
+ stop("dkwtest failed")
+ rval
+}
+
+.proctime00 <- proc.time() # start timing
+
+
+dkwtest("binom",size = 1,prob = 0.2)
+dkwtest("binom",size = 2,prob = 0.2)
+dkwtest("binom",size = 100,prob = 0.2)
+dkwtest("binom",size = 1e4,prob = 0.2)
+dkwtest("binom",size = 1,prob = 0.8)
+dkwtest("binom",size = 100,prob = 0.8)
+dkwtest("binom",size = 100,prob = 0.999)
+
+dkwtest("pois",lambda = 0.095)
+dkwtest("pois",lambda = 0.95)
+dkwtest("pois",lambda = 9.5)
+dkwtest("pois",lambda = 95)
+
+dkwtest("nbinom",size = 1,prob = 0.2)
+dkwtest("nbinom",size = 2,prob = 0.2)
+dkwtest("nbinom",size = 100,prob = 0.2)
+dkwtest("nbinom",size = 1e4,prob = 0.2)
+dkwtest("nbinom",size = 1,prob = 0.8)
+dkwtest("nbinom",size = 100,prob = 0.8)
+dkwtest("nbinom",size = 100,prob = 0.999)
+
+dkwtest("norm")
+dkwtest("norm",mean = 5,sd = 3)
+
+dkwtest("gamma",shape = 0.1)
+dkwtest("gamma",shape = 0.2)
+dkwtest("gamma",shape = 10)
+dkwtest("gamma",shape = 20)
+
+dkwtest("hyper",m = 40,n = 30,k = 20)
+dkwtest("hyper",m = 40,n = 3,k = 20)
+dkwtest("hyper",m = 6,n = 3,k = 2)
+dkwtest("hyper",m = 5,n = 3,k = 2)
+dkwtest("hyper",m = 4,n = 3,k = 2)
+
+
+dkwtest("signrank",n = 1)
+dkwtest("signrank",n = 2)
+dkwtest("signrank",n = 10)
+dkwtest("signrank",n = 30)
+
+dkwtest("wilcox",m = 40,n = 30)
+dkwtest("wilcox",m = 40,n = 10)
+dkwtest("wilcox",m = 6,n = 3)
+dkwtest("wilcox",m = 5,n = 3)
+dkwtest("wilcox",m = 4,n = 3)
+
+dkwtest("chisq",df = 1)
+dkwtest("chisq",df = 10)
+
+dkwtest("logis")
+dkwtest("logis",location = 4,scale = 2)
+
+dkwtest("t",df = 1)
+dkwtest("t",df = 10)
+dkwtest("t",df = 40)
+
+dkwtest("beta",shape1 = 1, shape2 = 1)
+dkwtest("beta",shape1 = 2, shape2 = 1)
+dkwtest("beta",shape1 = 1, shape2 = 2)
+dkwtest("beta",shape1 = 2, shape2 = 2)
+dkwtest("beta",shape1 = .2,shape2 = .2)
+
+dkwtest("cauchy")
+dkwtest("cauchy",location = 4,scale = 2)
+
+dkwtest("f",df1 = 1,df2 = 1)
+dkwtest("f",df1 = 1,df2 = 10)
+dkwtest("f",df1 = 10,df2 = 10)
+dkwtest("f",df1 = 30,df2 = 3)
+
+dkwtest("weibull",shape = 1)
+dkwtest("weibull",shape = 4,scale = 4)
+
+## regression test for PR#7314
+dkwtest("hyper", m=60, n=100, k=50)
+dkwtest("hyper", m=6, n=10, k=5)
+dkwtest("hyper", m=600, n=1000, k=500)
+
+## regression test for non-central t bug
+dkwtest("t", df=20, ncp=3)
+## regression test for non-central F bug
+dkwtest("f", df1=10, df2=2, ncp=3)
+
+
+cat('Time elapsed: ', proc.time() - .proctime00,'\n')
+
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/primitives.R b/com.oracle.truffle.r.native/gnur/tests/src/primitives.R
new file mode 100644
index 0000000000000000000000000000000000000000..bc9505ff1cde8959e6e7d957768ee8d81c1fc5eb
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/primitives.R
@@ -0,0 +1,146 @@
+## check that the 'internal generics' are indeed generic.
+
+x <- structure(pi, class="testit")
+xx <- structure("OK", class="testOK")
+
+for(f in ls(.GenericArgsEnv, all.names=TRUE))
+{
+ cat("testing S3 generic '", f, "'\n", sep="")
+ method <- paste(f, "testit", sep=".")
+ if(f %in% "seq.int") {
+ ## note that this dispatches on 'seq'.
+ assign("seq.testit", function(...) xx, .GlobalEnv)
+ res <- seq.int(x, x)
+ } else {
+ if(length(grep("<-$", f)) > 0) {
+ assign(method, function(x, value) xx, .GlobalEnv)
+ y <- x
+ res <- eval(substitute(ff(y, value=pi), list(ff=as.name(f))))
+ } else {
+ ff <- get(f, .GenericArgsEnv)
+ body(ff) <- xx
+ assign(method, ff, .GlobalEnv)
+ res <- eval(substitute(ff(x), list(ff=as.name(f))))
+ }
+ }
+ stopifnot(res == xx)
+ rm(method)
+}
+
+## and that no others are generic
+for(f in ls(.ArgsEnv, all.names=TRUE))
+{
+ if(f == "browser") next
+ cat("testing non-generic '", f, "'\n", sep="")
+ method <- paste(f, "testit", sep=".")
+ fx <- get(f, envir=.ArgsEnv)
+ body(fx) <- quote(return(42))
+ assign(method, fx, .GlobalEnv)
+ na <- length(formals(fx))
+ res <- NULL
+ if(na == 1)
+ res <- try(eval(substitute(ff(x), list(ff=as.name(f)))), silent = TRUE)
+ else if(na == 2)
+ res <- try(eval(substitute(ff(x, x), list(ff=as.name(f)))), silent = TRUE)
+ if(!inherits(res, "try-error") && identical(res, 42)) stop("is generic")
+ rm(method)
+}
+
+
+## check that all primitives are accounted for in .[Generic]ArgsEnv,
+## apart from the language elements:
+ff <- as.list(baseenv(), all.names=TRUE)
+ff <- names(ff)[vapply(ff, is.primitive, logical(1L))]
+
+known <- c(names(.GenericArgsEnv), names(.ArgsEnv), tools::langElts)
+stopifnot(ff %in% known, known %in% ff)
+
+
+## check which are not considered as possibles for S4 generic
+ff4 <- names(meth.FList <- methods:::.BasicFunsList)
+# as.double is the same as as.numeric
+S4generic <- ff %in% c(ff4, "as.double")
+notS4 <- ff[!S4generic]
+if(length(notS4))
+ cat("primitives not covered in methods:::.BasicFunsList:",
+ paste(sQuote(notS4), collapse=", "), "\n")
+stopifnot(S4generic)
+
+# functions which are listed but not primitive
+extraS4 <- c('unlist', 'as.vector')
+ff4[!ff4 %in% c(ff, extraS4)]
+stopifnot(ff4 %in% c(ff, extraS4))
+
+
+## primitives which are not internally generic cannot have S4 methods
+## unless specifically arranged (e.g. %*%)
+nongen_prims <- ff[!ff %in% ls(.GenericArgsEnv, all.names=TRUE)]
+ff3 <- ff4[vapply(meth.FList, function(x) is.logical(x) && !x, NA, USE.NAMES=FALSE)]
+ex <- nongen_prims[!nongen_prims %in% c("$", "$<-", "[", "[[" ,"[[<-", "[<-", "%*%", ff3)]
+if(length(ex))
+ cat("non-generic primitives not excluded in methods:::.BasicFunsList:",
+ paste(sQuote(ex), collapse=", "), "\n")
+stopifnot(length(ex) == 0)
+
+## Now check that (most of) those which are listed really are generic.
+require(methods)
+setClass("foo", representation(x="numeric", y="numeric"))
+xx <- new("foo", x=1, y=2)
+S4gen <- ff4[vapply(meth.FList, is.function, NA, USE.NAMES=FALSE)]
+for(f in S4gen) {
+ g <- get(f)
+ if(!is(g, "genericFunction")) g <- getGeneric(f) # error on non-Generics.
+ ff <- args(g)
+ body(ff) <- "testit"
+ nm <- names(formals(ff))
+ ## the Summary group gives problems
+ if(nm[1] == '...') {
+ cat("skipping '", f, "'\n", sep="")
+ next
+ }
+ cat("testing '", f, "'\n", sep="")
+ setMethod(f, "foo", ff)
+ ## might have created a generic, so redo 'get'
+ stopifnot(identical(getGeneric(f)(xx), "testit"))
+}
+
+## check that they do argument matching, or at least check names
+except <- c("call", "switch", ".C", ".Fortran", ".Call", ".External",
+ ".External2", ".Call.graphics", ".External.graphics",
+ ".subset", ".subset2", ".primTrace", ".primUntrace",
+ "lazyLoadDBfetch", ".Internal", ".Primitive", "^", "|",
+ "%*%", "rep", "seq.int", "forceAndCall",
+ ## these may not be enabled
+ "tracemem", "retracemem", "untracemem")
+
+for(f in ls(.GenericArgsEnv, all.names=TRUE)[-(1:15)])
+{
+ if (f %in% except) next
+ g <- get(f, envir = .GenericArgsEnv)
+ an <- names(formals(args(g)))
+ if(length(an) > 0 && an[1] == "...") next
+ an <- an[an != "..."]
+ a <- rep(list(NULL), length(an))
+ names(a) <- c("zZ", an[-1])
+ res <- try(do.call(f, a), silent = TRUE)
+ m <- geterrmessage()
+ if(!grepl('does not match|unused argument', m))
+ stop("failure on ", f)
+}
+
+for(f in ls(.ArgsEnv, all.names=TRUE))
+{
+ if (f %in% except) next
+ g <- get(f, envir = .ArgsEnv)
+ an <- names(formals(args(g)))
+ if(length(an) > 0 && an[1] == "...") next
+ an <- an[an != "..."]
+ if(length(an)) {
+ a <- rep(list(NULL), length(an))
+ names(a) <- c("zZ", an[-1])
+ } else a <- list(zZ=NULL)
+ res <- try(do.call(f, a), silent = TRUE)
+ m <- geterrmessage()
+ if(!grepl('does not match|unused argument|requires 0|native symbol', m))
+ stop("failure on ", f)
+}
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/print-tests.R b/com.oracle.truffle.r.native/gnur/tests/src/print-tests.R
new file mode 100644
index 0000000000000000000000000000000000000000..0d697288a5d14a7634debf586d3d577004ca7e7e
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/print-tests.R
@@ -0,0 +1,261 @@
+#### Testing print(), format() and the like --- mainly with numeric()
+####
+#### to be run as
+####
+#### R < print-tests.R >& print-tests.out-__version__
+#### == (csh)
+opt.conformance <- 0
+
+DIG <- function(d)
+ if(missing(d)) getOption("digits") else options(digits=as.integer(d))
+
+DIG(7)#-- the default; just to make sure ...
+options(width = 200)
+
+n1 <- 2^(4*1:7)
+i1 <- as.integer(n1)
+
+v1 <- 2^c(-12, 2*(-4:-2),3,6,9)
+v2 <- v1^(63/64)
+## avoid ending in `5' as printing then depends on rounding of
+## the run-time (and not all round to even).
+v1[1:4] <-c(2.44140624e-04, 3.90624e-03, 1.5624e-02, 6.24e-02)
+
+
+v3 <- pi*100^(-1:3)
+v4 <- (0:2)/1000 + 1e-10 #-- tougher one
+
+digs1 <- c(1,2*(1:5),11:15) # 16: platform dependent
+ # 30 gives ERROR : options(digits=30)
+digs2 <- c(1:20)#,30) gives 'error' in R: ``print.default(): invalid digits..''
+
+all(i1 == n1)# TRUE
+i1# prints nicely
+n1# did not; does now (same as 'i1')
+
+round (v3, 3)#S+ & R 0.49:
+##[1] 0.031 3.142 314.159 31415.927 3141592.654
+signif(v3, 3)
+##R.49: [1] 0.0314 3.1400 314.0000 31400.0000 3140000.0000
+##S+ [1] 3.14e-02 3.14e+00 3.14e+02 3.14e+04 3.14e+06
+
+###----------------------------------------------------------------
+##- Date: Tue, 20 May 97 17:11:18 +0200
+
+##- From: Martin Maechler <maechler@stat.math.ethz.ch>
+##- To: R-devel@stat.math.ethz.ch
+##- Subject: R-alpha: print 'problems': print(2^30, digits=12); comments at start of function()
+##-
+##- Both of these bugs are not a real harm,
+##- however, they have been annoying me for too long ... ;-)
+##-
+##- 1)
+print (2^30, digits = 12) #- WAS exponential form, unnecessarily -- now ok
+formatC(2^30, digits = 12) #- shows you what you'd want above
+
+## S and R are now the same here; note that the problem also affects
+## paste(.) & format(.) :
+
+DIG(10); paste(n1); DIG(7)
+
+
+## Assignment to .Options$digits: Does NOT work for print() nor cat()
+for(i in digs1) { .Options$digits <- i; cat(i,":"); print (v1[-1]) }
+
+## using options() *does* things
+for(i in digs1) { DIG(i); cat(i,":"); print (v3) }
+for(i in digs1) { DIG(i); cat(i,":", formatC(v3, digits=i, width=8),"\n") }
+
+
+## R-0.50: switches to NON-exp at 14, but should only at 15...
+## R-0.61++: doesn' switch at all (or at 20 only)
+## S-plus: does not switch at all..
+for(i in digs1) { cat(i,":"); print(v1, digits=i) }
+
+## R 0.50-a1: switches at 10 inst. 11
+for(i in digs1) { cat(i,":"); print(v1[-1], digits=i) }
+
+for(i in digs1) { DIG(i); cat(i,":", formatC(v2, digits=i, width=8),"\n") }
+
+for(i in digs1) { cat(i,":"); print(v2, digits=i) } #-- exponential all thru
+## ^^^^^ digs2 (>= 18: PLATFORM dependent !!
+for(i in digs1) { cat(i,":", formatC(v2, digits=i, width=8),"\n") }
+
+DIG(7)#-- the default; just to make sure ...
+
+N1 <- 10; N2 <- 7; n <- 8
+x <- 0:N1
+Mhyp <- rbind(phyper(x, N1, N2, n), dhyper(x, N1, N2, n))
+Mhyp
+##- [,1] [,2] [,3] [,4] [,5] [,6] [,7]
+##- [1,] 0 0.0004113534 0.01336898 0.117030 0.4193747 0.7821884 0.9635952
+##- [2,] 0 0.0004113534 0.01295763 0.103661 0.3023447 0.3628137 0.1814068
+##- [,8] [,9] [,10] [,11]
+##- [1,] 0.99814891 1.00000000 1 1
+##- [2,] 0.03455368 0.00185109 0 0
+
+m11 <- c(-1,1)
+Mm <- pi*outer(m11, 10^(-5:5))
+Mm <- cbind(Mm, outer(m11, 10^-(5:1)))
+Mm
+do.p <- TRUE
+do.p <- FALSE
+for(di in 1:10) {
+ options(digits=di)
+ cat(if(do.p)"\n",formatC(di,w=2),":", format.info(Mm),"\n")
+ if(do.p)print(Mm)
+}
+##-- R-0.49 (4/1997) R-0.50-a1 (7.7.97)
+##- 1 : 13 5 0 1 : 6 0 1
+##- 2 : 8 1 1 = 2 : 8 1 1
+##- 3 : 9 2 1 = 3 : 9 2 1
+##- 4 : 10 3 1 = 4 : 10 3 1
+##- 5 : 11 4 1 = 5 : 11 4 1
+##- 6 : 12 5 1 = 6 : 12 5 1
+##- 7 : 13 6 1 = 7 : 13 6 1
+##- 8 : 14 7 1 = 8 : 14 7 1
+##- 9 : 15 8 1 = 9 : 15 8 1
+##- 10 : 16 9 1 = 10 : 16 9 1
+nonFin <- list(c(Inf,-Inf), c(NaN,NA), NA_real_, Inf)
+mm <- sapply(nonFin, format.info)
+fm <- lapply(nonFin, format)
+w <- c(4,3,2,3)
+stopifnot(sapply(lapply(fm, nchar), max) == w,
+ mm == rbind(w, 0, 0))# m[2,] was 2147483647; m[3,] was 1
+cnF <- c(lapply(nonFin, function(x) complex(re=x, im=x))[-3],
+ complex(re=NaN, im=-Inf))
+cmm <- sapply(cnF, format.info)
+cfm <- lapply(cnF, format)
+cw <- sapply(lapply(cfm, nchar), max)
+stopifnot(cw == cmm[1,]+1 +cmm[4,]+1,
+ nchar(format(c(NA, 1 + 2i))) == 4)# wrongly was (5,4)
+
+
+##-- Ok now, everywhere
+for(d in 1:9) {cat(d,":"); print(v4, digits=d) }
+DIG(7)
+
+
+###------------ Very big and very small
+umach <- unlist(.Machine)[paste("double.x", c("min","max"), sep='')]
+xmin <- umach[1]
+xmax <- umach[2]
+tx <- unique(c(outer(-1:1,c(.1,1e-3,1e-7))))# 7 values (out of 9)
+tx <- unique(sort(c(outer(umach,1+tx))))# 11 values (+ 1 Inf)
+length(tx <- tx[is.finite(tx)]) # 11
+(txp <- tx[tx >= 1])#-- Positive exponent -- 4 values
+(txn <- tx[tx < 1])#-- Negative exponent -- 7 values
+
+x2 <- c(0.099999994, 0.2)
+x2 # digits=7: show all seven "9"s
+print(x2, digits=6) # 0.1 0.2 , not 0.10 0.20
+v <- 6:8; names(v) <- v; sapply(v, format.info, x=x2)
+
+(z <- sort(c(outer(range(txn), 8^c(0,2:3)))))
+outer(z, 0:6, signif) # had NaN's till 1.1.1
+
+olddig <- options(digits=14) # RH6.0 fails at 15
+z <- 1.234567891234567e27
+for(dig in 1:14) cat(formatC(dig,w=2),
+ format(z, digits=dig), signif(z, digits=dig), "\n")
+options(olddig)
+# The following are tests of printf inside formatC
+##------ Use Emacs screen width 134 ; Courier 12 ----
+# cat("dig| formatC(txp, d=dig)\n")
+# for(dig in 1:17)# about >= 18 is platform dependent [libc's printf()..].
+# cat(formatC(dig,w=2), formatC(txp, dig=dig, wid=-29),"\n")
+# cat("signif() behavior\n~~~~~~~~\n",
+# "dig| formatC(signif(txp, dig=dig), dig = dig\n")
+# for(dig in 1:15)#
+# cat(formatC(dig,w=2), formatC(signif(txp, d=dig), dig=dig, wid=-26),"\n")
+
+# if(opt.conformance >= 1) {
+# noquote(cbind(formatC(txp, dig = 22)))
+# }
+
+# cat("dig| formatC(signif(txn, d = dig), dig=dig\n")
+# for(dig in 1:15)#
+# cat(formatC(dig,w=2), formatC(signif(txn, d=dig), dig=dig, wid=-20),"\n")
+
+# ##-- Testing 'print' / digits :
+# for(dig in 1:13) { ## 12:13: libc-2.0.7 diff; 14:18 --- PLATFORM-dependent !!!
+# cat("dig=",formatC(dig,w=2),": "); print(signif(txp, d=dig),dig=dig+1)
+# }
+
+##-- Wrong alignment when printing character matrices with quote = FALSE
+m1 <- matrix(letters[1:24],6,4)
+m1
+noquote(m1)
+
+##--- Complex matrices and named vectors :
+
+x0 <- x <- c(1+1i, 1.2 + 10i)
+names(x) <- c("a","b")
+x
+(xx <- rbind(x, 2*x))
+ rbind(x0, 2*x0)
+x[4:6] <- c(Inf,Inf*c(-1,1i))
+x + pi
+matrix(x + pi, 2)
+matrix(x + 1i*pi, 3)
+xx + pi
+t(cbind(xx, xx+ 1i*c(1,pi)))
+
+#--- format checks after incorrect changes in Nov 2000
+zz <- data.frame("(row names)" = c("aaaaa", "b"), check.names = FALSE)
+format(zz)
+format(zz, justify = "left")
+zz <- data.frame(a = I("abc"), b = I("def\"gh"))
+format(zz)
+# " (font-locking: closing the string above)
+
+# test format.data.frame on former AsIs's.
+set.seed(321)
+dd <- data.frame(x = 1:5, y = rnorm(5), z = c(1, 2, NA, 4, 5))
+model <- glm(y ~ x, data = dd, subset = 1:4, na.action = na.omit)
+expand.model.frame(model, "z", na.expand = FALSE)
+expand.model.frame(model, "z", na.expand = TRUE)
+
+## print.table() changes affecting summary.data.frame
+options(width=82)
+summary(attenu) # ``one line''
+lst <- levels(attenu$station)
+levels(attenu$station)[lst == "117"] <- paste(rep(letters,3),collapse="")
+summary(attenu) # {2 + one long + 2 } variables
+## in 1.7.0, things were split to more lines
+
+## format.default(*, nsmall > 0) -- for real and complex
+
+sf <- function(x, N=14) sapply(0:N, function(i) format(x,nsmall=i))
+sf(2)
+sf(3.141)
+sf(-1.25, 20)
+
+oDig <- options(digits= 3)
+sf(pi)
+sf(1.2e7)
+sf(1.23e7)
+s <- -0.01234
+sf(s)
+
+sf(pi + 2.2i)
+sf(s + pi*1i)
+
+options(oDig)
+
+e1 <- tryCatch(options(max.print=Inf), error=function(e)e)
+e2 <- tryCatch(options(max.print= 0), error=function(e)e)
+stopifnot(inherits(e1, "error"))
+
+
+## Printing of "Date"s
+options(width = 80)
+op <- options(max.print = 500)
+dd <- as.Date("2012-03-12") + -10000:100
+writeLines(t1 <- tail(capture.output(dd)))
+l6 <- length(capture.output(print(dd, max = 600)))
+options(op)
+t2 <- tail(capture.output(print(dd, max = 500)))
+stopifnot(identical(t1, t2), l6 == 121)
+## not quite consistent in R <= 2.14.x
+
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/r-strict-tst.R b/com.oracle.truffle.r.native/gnur/tests/src/r-strict-tst.R
new file mode 100644
index 0000000000000000000000000000000000000000..06e35398f94d6f35a24cd925df9057fd79d30380
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/r-strict-tst.R
@@ -0,0 +1,57 @@
+#### Strict "regression" (no output comparison) tests
+#### or [R]andom number generating functions
+
+options(warn = 2)# warnings are errors here
+
+## For integer valued comparisons
+all.eq0 <- function(x,y, ...) all.equal(x,y, tolerance = 0, ...)
+
+###------- Discrete Distributions ----------------
+
+set.seed(17)
+stopifnot(
+ all.eq0(rhyper(100, 3024, 27466, 251),
+ c(25, 24, 21, 31, 25, 33, 28, 28, 27, 37, 26, 31, 27, 22, 21,
+ 33, 22, 32, 27, 28, 29, 22, 20, 20, 21, 18, 23, 21, 26, 22, 28,
+ 24, 25, 16, 38, 26, 35, 24, 28, 26, 21, 15, 19, 24, 26, 21, 28,
+ 21, 27, 27, 24, 31, 22, 18, 27, 24, 28, 22, 25, 19, 29, 31, 27,
+ 24, 26, 26, 24, 23, 20, 23, 23, 26, 22, 36, 29, 32, 23, 25, 20,
+ 12, 36, 29, 28, 23, 24, 26, 29, 25, 28, 18, 18, 27, 24, 18, 22,
+ 32, 31, 23, 26, 23))
+ ,
+ all.eq0(rhyper(100, 329, 3059, 225),
+ c(21, 21, 17, 21, 15, 25, 24, 15, 27, 21, 18, 22, 29, 17, 18,
+ 19, 32, 23, 23, 22, 20, 20, 15, 23, 19, 25, 25, 18, 17, 17, 19,
+ 28, 17, 20, 21, 21, 20, 17, 25, 21, 21, 15, 25, 25, 15, 21, 26,
+ 14, 21, 23, 21, 14, 15, 24, 23, 21, 20, 20, 20, 24, 16, 21, 25,
+ 30, 17, 19, 22, 19, 22, 23, 19, 20, 18, 15, 21, 12, 24, 20, 14,
+ 20, 25, 22, 19, 23, 14, 19, 15, 23, 23, 15, 23, 26, 32, 23, 25,
+ 19, 23, 18, 24, 25))
+ ,
+ ## using branch II in ../src/nmath/rhyper.c :
+ print(ct3 <- system.time(N <- rhyper(100, 8000, 1e9-8000, 1e6))[1]) < 0.02
+ ,
+ all.eq0(N, c(11, 9, 7, 4, 8, 6, 10, 5, 9, 8, 10, 5, 8, 8, 4, 10, 9, 8, 7,
+ 9, 11, 5, 7, 9, 8, 8, 5, 5, 10, 7, 8, 5, 4, 11, 9, 7, 8, 6, 7,
+ 9, 14, 9, 8, 8, 8, 4, 12, 9, 8, 11, 10, 12, 9, 13, 13, 8, 8,
+ 10, 9, 4, 7, 9, 11, 2, 5, 8, 7, 8, 11, 8, 6, 8, 6, 3, 4, 12,
+ 8, 10, 9, 6, 3, 6, 7, 10, 7, 4, 5, 8, 10, 8, 7, 11, 8, 12, 4,
+ 9, 5, 9, 7, 11))
+)
+
+
+N <- 1e10; m <- 1e5; n <- N-m; k <- 1e6
+n /.Machine$integer.max ## 4.66
+p <- m/N; q <- 1 - p
+cat(sprintf(
+ "N = n+m = %g, m = Np = %g; k = %g ==> (p,f) = (m,k)/N = (%g, %g)\n k*p*q = %.4g > 1: %s\n",
+ N, m, k, m/N, k/N, k*p*q, k*p*q > 1))
+set.seed(11)
+rH <- rhyper(20, m=m, n=n, k=k) # now via qhyper() - may change!
+stopifnot( is.finite(rH), 3 <= rH, rH <= 24) # allow slack for change
+## gave all NA_integer_ in R < 3.3.0
+
+
+stopifnot(identical(rgamma(1, Inf), Inf),
+ identical(rgamma(1, 0, 0), 0))
+## gave NaN in R <= 3.3.0
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-BLAS.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-BLAS.R
new file mode 100644
index 0000000000000000000000000000000000000000..d84edad565bdf3c334c36efe85325df8f2c84c2b
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-BLAS.R
@@ -0,0 +1,135 @@
+
+## PR#4582 %*% with NAs
+stopifnot(is.na(NA %*% 0), is.na(0 %*% NA))
+## depended on the BLAS in use.
+
+
+## found from fallback test in slam 0.1-15
+## most likely indicates an inaedquate BLAS.
+x <- matrix(c(1, 0, NA, 1), 2, 2)
+y <- matrix(c(1, 0, 0, 2, 1, 0), 3, 2)
+(z <- tcrossprod(x, y))
+stopifnot(identical(z, x %*% t(y)))
+stopifnot(is.nan(log(0) %*% 0))
+## depended on the BLAS in use: some (including the reference BLAS)
+## had z[1,3] == 0 and log(0) %*% 0 as as.matrix(0).
+
+## matrix products
+for(mopt in c("default","internal","default.simd")) {
+
+ # matprod="blas" is excluded because some tests fail due to issues
+ # in NaN/Inf propagation even in Rblas
+ options(matprod=mopt)
+
+ m <- matrix(c(1,2,3,4), ncol=2)
+ v <- c(11,12)
+ rv <- v; dim(rv) <- c(1,2)
+ cv <- v; dim(cv) <- c(2,1)
+
+ Cm <- m+0*1i; # cast to complex keeping dimensions
+ Cv <- v+0*1i;
+ Ccv <- cv+0*1i;
+ Crv <- rv+0*1i;
+
+ cprod <- function(rres, cres, expected) {
+ stopifnot(identical(rres, expected))
+ stopifnot(identical(Re(cres), expected))
+ }
+
+ cprod(m %*% m, Cm %*% Cm, matrix(c(7,10,15,22), 2, 2) )
+ cprod(m %*% cv, Cm %*% Ccv, matrix(c(47,70), 2, 1) )
+ cprod(m %*% v, Cm %*% Cv, matrix(c(47,70), 2, 1) )
+ cprod(rv %*% m, Crv %*% Cm, matrix(c(35,81), 1, 2) )
+ cprod(v %*% m, Cv %*% Cm, matrix(c(35,81), 1, 2) )
+ cprod(rv %*% cv, Crv %*% Ccv, matrix(265,1,1) )
+ cprod(cv %*% rv, Ccv %*% Crv, matrix(c(121,132,132,144), 2, 2) )
+ cprod(v %*% v, Cv %*% Cv, matrix(265,1,1) )
+
+ cprod(crossprod(m, m), crossprod(Cm, Cm), matrix(c(5,11,11,25), 2, 2) )
+ cprod(crossprod(m), crossprod(Cm), matrix(c(5,11,11,25), 2, 2) )
+ cprod(crossprod(m, cv), crossprod(Cm, Ccv), matrix(c(35,81), 2, 1) )
+ cprod(crossprod(m, v), crossprod(Cm, Cv), matrix(c(35,81), 2, 1) )
+ cprod(crossprod(cv, m), crossprod(Ccv, Cm), matrix(c(35,81), 1, 2) )
+ cprod(crossprod(v, m), crossprod(Cv, Cm), matrix(c(35,81), 1, 2) )
+ cprod(crossprod(cv, cv), crossprod(Ccv, Ccv), matrix(265,1,1) )
+ cprod(crossprod(v, v), crossprod(Cv, Cv), matrix(265,1,1) )
+ cprod(crossprod(rv, rv), crossprod(Crv, Crv), matrix(c(121,132,132,144), 2, 2) )
+
+ cprod(tcrossprod(m, m), tcrossprod(Cm, Cm), matrix(c(10,14,14,20), 2, 2) )
+ cprod(tcrossprod(m), tcrossprod(Cm), matrix(c(10,14,14,20), 2, 2) )
+ cprod(tcrossprod(m, rv), tcrossprod(Cm, Crv), matrix(c(47,70), 2, 1) )
+ cprod(tcrossprod(rv, m), tcrossprod(Crv, Cm), matrix(c(47,70), 1, 2) )
+ cprod(tcrossprod(v, m), tcrossprod(Cv, Cm), matrix(c(47,70), 1, 2) )
+ cprod(tcrossprod(rv, rv), tcrossprod(Crv, Crv), matrix(265,1,1) )
+ cprod(tcrossprod(cv, cv), tcrossprod(Ccv, Ccv), matrix(c(121,132,132,144), 2, 2) )
+ cprod(tcrossprod(v, v), tcrossprod(Cv, Cv), matrix(c(121,132,132,144), 2, 2) )
+
+ ## non-square matrix, with Inf
+
+ m1 <- matrix(c(1,2,Inf,4,5,6), ncol=2)
+ m2 <- matrix(c(1,2,3,4), ncol=2)
+
+ v <- c(11,12)
+ rv <- v; dim(rv) <- c(1,2)
+ cv <- v; dim(cv) <- c(2,1)
+
+ v1 <- c(11,12,13)
+ rv1 <- v1; dim(rv1) <- c(1,3)
+ cv1 <- v1; dim(cv1) <- c(3,1)
+
+ Cm1 <- m1+0*1i
+ Cm2 <- m2+0*1i
+ Cv <- v+0*1i
+ Crv <- rv+0*1i
+ Ccv <- cv+0*1i
+ Cv1 <- v1+0*1i
+ Crv1 <- rv1+0*1i
+ Ccv1 <- cv1+0*1i
+
+ cprod(m1 %*% m2, Cm1 %*% Cm2, matrix(c(9,12,Inf,19,26,Inf), 3, 2) )
+ cprod(m1 %*% cv, Cm1 %*% Ccv, matrix(c(59,82,Inf), 3, 1) )
+
+ # the following 7 lines fail with Rblas and matprod = "blas"
+ cprod(rv1 %*% m1, Crv1 %*% Cm1, matrix(c(Inf,182), 1, 2) )
+
+ cprod(crossprod(m1, m1), crossprod(Cm1, Cm1), matrix(c(Inf,Inf,Inf,77), 2, 2) )
+ cprod(crossprod(m1, cv1), crossprod(Cm1, Ccv1), matrix(c(Inf,182), 2, 1) )
+ cprod(crossprod(cv1, m1), crossprod(Ccv1, Cm1), matrix(c(Inf,182), 1, 2) )
+
+ cprod(tcrossprod(m1, m1), tcrossprod(Cm1, Cm1), matrix(c(17,22,Inf,22,29,Inf,Inf,Inf,Inf), 3,3) )
+ cprod(tcrossprod(m2, m1), tcrossprod(Cm2, Cm1), matrix(c(13,18,17,24,Inf,Inf), 2, 3) )
+ cprod(tcrossprod(rv, m1), tcrossprod(Crv, Cm1), matrix(c(59,82,Inf), 1, 3) )
+ # the previous 7 lines fail with Rblas and matprod = "blas"
+
+ cprod(tcrossprod(m1, rv), tcrossprod(Cm1, Crv), matrix(c(59,82,Inf), 3, 1) )
+
+ ## complex
+
+ m1 <- matrix(c(1+1i,2+2i,3+3i,4+4i,5+5i,6+6i), ncol=2)
+ m2 <- matrix(c(1+1i,2+2i,3+3i,4+4i), ncol=2)
+
+ stopifnot(identical(m1 %*% m2, matrix(c(18i,24i,30i,38i,52i,66i), 3, 2) ))
+ stopifnot(identical(crossprod(m1, m1), t(m1) %*% m1))
+ stopifnot(identical(tcrossprod(m1, m1), m1 %*% t(m1)))
+}
+
+## check that propagation of NaN/Inf values in multiplication of complex
+## numbers is the same as in multiplication of complex matrices
+
+for(mopt in c("default","internal","default.simd")) {
+ # matprod="blas" is excluded because some tests fail due to issues
+ # in NaN/Inf propagation even in Rblas
+ options(matprod=mopt)
+
+ vals <- c(0, 1, NaN, Inf)
+ for(ar in vals)
+ for(ai in vals)
+ for(br in vals)
+ for(bi in vals) {
+ a = ar + 1i * ai
+ b = br + 1i * bi
+ stopifnot(identical(a * b, as.complex(a %*% b)))
+ stopifnot(identical(a * b, as.complex(crossprod(a,b))))
+ stopifnot(identical(a * b, as.complex(tcrossprod(a,b))))
+ }
+}
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-IO.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-IO.R
new file mode 100644
index 0000000000000000000000000000000000000000..62fcb0da45031886e318a28924ec3ac7b99bf6aa
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-IO.R
@@ -0,0 +1,60 @@
+## NB: this file must be a DOS (CRLF) format file
+
+## Keep comments and original formatting
+options(keep.source=TRUE)
+
+## simple tests that multiple lines are read correctly
+print(2+3)
+print(4+5)
+
+## generate some files to source
+
+z <- c("# line 1", "2+3", "ls()", "pi", "# last line")
+
+## ======== LF file
+cat(z, file="testIO.R", sep="\n")
+readLines("testIO.R")
+source("testIO.R", echo=TRUE)
+unlink("testIO.R")
+
+## ======== LF file, incomplete final line
+zz <- file("testIO.R", "wt")
+cat(z, file=zz, sep="\n")
+cat("5+6", file=zz)
+close(zz)
+readLines("testIO.R")
+source("testIO.R", echo=TRUE)
+unlink("testIO.R")
+
+## ======== CRLF file
+cat(z, file="testIO.R", sep="\r\n")
+source("testIO.R", echo=TRUE)
+readLines("testIO.R")
+unlink("testIO.R")
+
+## ======== CRLF file, incomplete final line
+zz <- file("testIO.R", "wt")
+cat(z, file=zz, sep="\r\n")
+cat("5+6", file=zz)
+close(zz)
+readLines("testIO.R")
+source("testIO.R", echo=TRUE)
+unlink("testIO.R")
+
+## ======== CR file
+cat(z, file="testIO.R", sep="\r")
+readLines("testIO.R")
+source("testIO.R", echo=TRUE)
+unlink("testIO.R")
+
+## ======== CR file, incomplete final line
+zz <- file("testIO.R", "wt")
+cat(z, file=zz, sep="\r")
+cat("\r5+6", file=zz)
+close(zz)
+readLines("testIO.R")
+source("testIO.R", echo=TRUE)
+unlink("testIO.R")
+
+## end of reg-IO.R: the next line has no EOL chars
+2 + 2
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-IO2.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-IO2.R
new file mode 100644
index 0000000000000000000000000000000000000000..303992136d916d75935fb350214aed466cf97f4f
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-IO2.R
@@ -0,0 +1,124 @@
+## tests of boundary cases in read.table()
+
+## force standard handling for character cols
+options(stringsAsFactors=TRUE)
+
+# empty file
+file.create("foo1")
+try(read.table("foo1")) # fails
+read.table("foo1", col.names=LETTERS[1:4])
+unlink("foo1")
+
+# header only
+cat("head\n", file = "foo2")
+read.table("foo2")
+try(read.table("foo2", header=TRUE)) # fails in 1.2.3
+unlink("foo2")
+# header detection
+cat("head\n", 1:2, "\n", 3:4, "\n", file = "foo3")
+read.table("foo3", header=TRUE)
+read.table("foo3", header=TRUE, col.names="V1")
+read.table("foo3", header=TRUE, row.names=1)
+read.table("foo3", header=TRUE, row.names="row.names")
+read.table("foo3", header=TRUE, row.names="head") # fails in 1.2.3
+
+# wrong col.names
+try(read.table("foo3", header=TRUE, col.names=letters[1:4]))
+unlink("foo3")
+
+# incomplete last line
+cat("head\n", 1:2, "\n", 3:4, file = "foo4")
+read.table("foo4", header=TRUE)
+unlink("foo4")
+
+# blank last line
+cat("head\n\n", 1:2, "\n", 3:4, "\n\n", file = "foo5")
+read.table("foo5", header=TRUE)
+
+# test of fill
+read.table("foo5", header=FALSE, fill=TRUE, blank.lines.skip=FALSE) # fails in 1.2.3
+unlink("foo5")
+
+cat("head\n", 1:2, "\n", 3:5, "\n", 6:9, "\n", file = "foo6")
+try(read.table("foo6", header=TRUE))
+try(read.table("foo6", header=TRUE, fill=TRUE))
+read.table("foo6", header=FALSE, fill=TRUE)
+unlink("foo6")
+
+# test of type conversion in 1.4.0 and later.
+cat("A B C D E F\n",
+ "1 1 1.1 1.1+0i NA F abc\n",
+ "2 NA NA NA NA NA NA\n",
+ "3 1 2 3 NA TRUE def\n",
+ sep = "", file = "foo7")
+(res <- read.table("foo7"))
+sapply(res, typeof)
+sapply(res, class)
+(res2 <- read.table("foo7",
+ colClasses = c("character", rep("numeric", 2),
+ "complex", "integer", "logical", "character")))
+sapply(res2, typeof)
+sapply(res2, class)
+unlink("foo7")
+
+# should be logical
+type.convert(character(0))
+
+# test of comments in data files
+cat("# a test file",
+ "# line 2",
+ "# line 3",
+ "# line 4",
+ "# line 5",
+ "## now the header",
+ " a b c",
+ "# some more comments",
+ "1 2 3",
+ "4 5 6# this is the second data row of the file",
+ " # some more comments",
+ "7 8 9",
+ "# trailing comment\n",
+ file= "ex.data", sep="\n")
+read.table("ex.data", header = T)
+unlink("ex.data")
+
+## comment chars in headers
+cat("x1\tx#2\tx3\n1\t2\t2\n2\t3\t3\n", file = "test.dat")
+read.table("test.dat", header=T, comment.char="")
+unlink("test.dat")
+
+cat('#comment\n\n#another\n#\n#\n',
+ 'C1\tC2\tC3\n"Panel"\t"Area Examined"\t"# Blemishes"\n',
+ '"1"\t"0.8"\t"3"\n', '"2"\t"0.6"\t"2"\n', '"3"\t"0.8"\t"3"\n',
+ file = "test.dat", sep="")
+read.table("test.dat")
+unlink("test.dat")
+
+cat('%comment\n\n%another\n%\n%\n',
+ 'C1\tC2\tC3\n"Panel"\t"Area Examined"\t"% Blemishes"\n',
+ '"1"\t"0.8"\t"3"\n', '"2"\t"0.6"\t"2"\n', '"3"\t"0.8"\t"3"\n',
+ file = "test.dat", sep="")
+read.table("test.dat", comment.char = "%")
+unlink("test.dat")
+
+## test on Windows Unicode file
+con <- file(file.path(Sys.getenv("SRCDIR"), "WinUnicode.dat"),
+ encoding="UCS-2LE")
+scan(con, 0, quiet=TRUE)
+close(con)
+
+## tests of allowEscape
+x <- "1 2 3 \\ab\\c"
+writeLines(x, "test.dat")
+readLines("test.dat")
+scan("test.dat", "", allowEscapes=TRUE)
+scan("test.dat", "", allowEscapes=FALSE)
+read.table("test.dat", header=FALSE, allowEscapes=TRUE)
+read.table("test.dat", header=FALSE, allowEscapes=FALSE)
+x <- c("TEST", 1, 2, "\\b", 4, 5, "\\040", "\\x20",
+ "c:\\spencer\\tests",
+ "\\t", "\\n", "\\r")
+writeLines(x, "test.dat")
+read.table("test.dat", allowEscapes=FALSE, header = TRUE)
+unlink("test.dat")
+## end of tests
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-S4-examples.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-S4-examples.R
new file mode 100644
index 0000000000000000000000000000000000000000..a52a11fdfabc6d4a2e9b07881b91818c725d2de6
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-S4-examples.R
@@ -0,0 +1,357 @@
+## examples for a simple class with two numeric slots.
+## (Run example(setMethod) to see the class and function definitions)
+
+ setClass("track", slots = c(x="numeric", y = "numeric"))
+
+ cumdist <- function(x, y) c(0., cumsum(sqrt(diff(x)^2 + diff(y)^2)))
+ setClass("trackMultiCurve", slots = c(x="numeric", y="matrix", smooth="matrix"),
+ prototype = list(x=numeric(), y=matrix(0,0,0), smooth= matrix(0,0,0)))
+
+require(graphics)
+
+
+## methods for plotting track objects
+##
+## First, with only one object as argument, plot the two slots
+## y must be included in the signature, it would default to "ANY"
+setMethod("plot", signature(x="track", y="missing"),
+ function(x, y, ...) plot(x@x, x@y, ...)
+)
+
+## plot numeric data on either axis against a track object
+## (reducing the track object to the cumulative distance along the track)
+## Using a short form for the signature, which matches like formal arguments
+setMethod("plot", c("track", "numeric"),
+ function(x, y, ...) plot(cumdist(x@x, x@y), y, xlab = "Distance",...)
+)
+
+## and similarly for the other axis
+setMethod("plot", c("numeric", "track"),
+ function(x, y, ...) plot(x, cumdist(y@x, y@y), ylab = "Distance",...)
+)
+
+t1 <- new("track", x=1:20, y=(1:20)^2)
+plot(t1)
+plot(qnorm(ppoints(20)), t1)
+
+## Now a class that inherits from "track", with a vector for data at
+## the points
+ setClass("trackData", contains = c("numeric", "track"))
+
+
+tc1 <- new("trackData", t1, rnorm(20))
+
+
+## a method for plotting the object
+## This method has an extra argument, allowed because ... is an
+## argument to the generic function.
+setMethod("plot", c("trackData", "missing"),
+function(x, y, maxRadius = max(par("cin")), ...) {
+ plot(x@x, x@y, type = "n", ...)
+ symbols(x@x, x@y, circles = abs(x), inches = maxRadius)
+ }
+)
+plot(tc1)
+
+## Without other methods for "trackData", methods for "track"
+## will be selected by inheritance
+
+plot(qnorm(ppoints(20)), tc1)
+
+## defining methods for primitive functions.
+## Although "[" and "length" are not ordinary functions
+## methods can be defined for them.
+setMethod("[", "track",
+ function(x, i, j, ..., drop) {
+ x@x <- x@x[i]; x@y <- x@y[i]
+ x
+ })
+plot(t1[1:15])
+
+setMethod("length", "track", function(x)length(x@y))
+length(t1)
+
+
+setMethod("summary", "missing", function() "<No Object>")
+
+stopifnot(identical(summary(), "<No Object>"))
+
+removeMethods("summary")
+
+## for the primitives
+## inherited methods
+
+length(tc1)
+tc1[-1]
+
+## make sure old-style methods still work.
+t11 <- t1[1:15]
+identical(t1@y[1:15], t11@y)
+
+## S3 methods, with nextMethod
+form <- y ~ x
+form[1]
+
+## S3 arithmetic methods
+ISOdate(1990, 12, 1)- ISOdate(1980, 12, 1)
+
+## group methods
+
+setMethod("Arith", c("track", "numeric"), function(e1, e2){e1@y <-
+ callGeneric(e1@y , e2); e1})
+
+t1 - 100.
+t1/2
+
+## check it hasn't screwed up S3 methods
+ISOdate(1990, 12, 1)- ISOdate(1980, 12, 1)
+
+## test the .Generic mechanism
+
+setMethod("Compare", signature("track", "track"),
+ function(e1,e2) {
+ switch(.Generic,
+ "==" = e1@y == e2@y,
+ NA)
+ })
+
+#stopifnot(all(t1==t1))
+#stopifnot(identical(t1<t1, NA))
+
+
+## A test of nested calls to "[" with matrix-style arguments
+## applied to data.frames (S3 methods)
+
+setMethod("[", c("trackMultiCurve", "numeric", "numeric"), function(x, i, j, ..., drop) {
+### FIXME: a better version has only 1st arg in signature
+### and uses callNextMethod, when this works with primitives.
+ x@y <- x@y[i, j, drop=FALSE]
+ x@x <- x@x[i]
+ x
+})
+
+
+"testFunc" <-
+function(cur) {
+ sorted <- cur[order(cur[,1]),]
+ sorted[ !is.na(sorted[,1]), ]
+}
+
+Nrow <- 1000 # at one time, values this large triggered a bug in gc/protect
+## the loop here was a trigger for the bug
+Niter <- 10
+for(i in 1:Niter) {
+ yy <- matrix(stats::rnorm(10*Nrow), 10, Nrow)
+ tDF <- as.data.frame(yy)
+ testFunc(tDF)
+}
+
+
+tMC <- new("trackMultiCurve", x=seq_len(Nrow), y = yy)
+## not enough functions have methods for this class to use testFunc
+
+stopifnot(identical(tMC[1:10, 1:10]@y, yy[1:10, 1:10]))
+
+
+## verify we can remove methods and generic
+
+removeMethods("-")
+removeMethod("length", "track")
+removeMethods("Arith")
+removeMethods("Compare")
+
+## repeat the test one more time on the primitives
+
+length(ISOdate(1990, 12, 1)- ISOdate(1980, 12, 1))
+
+removeMethods("length")
+
+## methods for %*%, which isn't done by the same C code as other ops
+
+setClass("foo", slots = c(m="matrix"))
+m1 <- matrix(1:12,3,4)
+f1 = new("foo", m=m1)
+f2 = new("foo", m=t(m1))
+
+setMethod("%*%", c("foo", "foo"),
+ function(x,y) callGeneric(x@m, y@m))
+
+stopifnot(identical(f1%*%f2, m1%*% t(m1)))
+
+removeMethods("%*%")
+removeMethods("plot")
+
+if(FALSE) ## Hold until removeMethods revised:
+ stopifnot(existsFunction("plot", FALSE) && !isGeneric("plot", 1))
+
+## methods for plotData
+plotData <- function(x, y, ...) plot(x, y, ...)
+
+setGeneric("plotData")
+
+setMethod("plotData", signature(x="track", y="missing"),
+ function(x, y, ...) plot(slot(x, "x"), slot(x, "y"), ...))
+
+## and now remove the whole generic
+removeGeneric("plotData")
+
+stopifnot(!exists("plotData", 1))
+
+## Tests of method inheritance & multiple dispatch
+setClass("A0", slots = c(a0 = "numeric"))
+setClass("A1", contains = "A0", slots = c(a1 = "character"))
+
+setClass("B0", slots = c(b0 = "numeric"))
+setClass("B1", "B0") # (meaning 'contains = *')
+setClass("B2", contains = "B1", slots = c(b2 = "logical"))
+
+setClass("AB0", contains = c("A1", "B2"), slots = c(ab0 = "matrix"))
+
+f1 <- function(x, y)"ANY"
+
+setGeneric("f1")
+
+setMethod("f1", c("A0", "B1"), function(x, y)"A0 B1")
+setMethod("f1", c("B1", "A0"), function(x, y)"B1 A0")
+
+a0 <- new("A0")
+a1 <- new("A1")
+b0 <- new("B0")
+b1 <- new("B1")
+b2 <- new("B2")
+
+deparseText <- function(expr)
+ paste(deparse(expr), collapse = " ")
+
+mustEqual <- function(e1, e2){
+ if(!identical(e1, e2))
+ stop(paste("!identical(", deparseText(substitute(e1)),
+ ", ", deparseText(substitute(e2)), ")", sep=""))
+}
+
+mustEqual(f1(a0, b0), "ANY")
+mustEqual(f1(a1,b0), "ANY")
+mustEqual(f1(a1,b1), "A0 B1")
+mustEqual(f1(b1,a1), "B1 A0")
+mustEqual(f1(b1,b1), "ANY")
+
+## remove classes: order matters so as not to undefine earlier classes
+for(.cl in c("AB0", "A1", "A0", "B2", "B1", "B0"))
+ removeClass(.cl)
+
+removeGeneric("f1")
+
+## test of nonstandard generic definition
+
+setGeneric("doubleAnything", function(x) {
+ methodValue <- standardGeneric("doubleAnything")
+ c(methodValue, methodValue)
+})
+
+setMethod("doubleAnything", "ANY", function(x)x)
+
+setMethod("doubleAnything", "character",
+ function(x) paste("<",x,">",sep=""))
+
+mustEqual(doubleAnything(1:10), c(1:10, 1:10))
+mustEqual(doubleAnything("junk"), rep("<junk>",2))
+
+removeGeneric("doubleAnything")
+
+### From setOldClass.Rd
+## Examples of S3 classes with guaranteed attributes
+## an S3 class "stamped" with a vector and a "date" attribute
+## Here is a generator function and an S3 print method.
+## NOTE: it's essential that the generator checks the attribute classes
+stamped <- function(x, date = Sys.time()) {
+ if(!inherits(date, "POSIXt"))
+ stop("bad date argument")
+ if(!is.vector(x))
+ stop("x must be a vector")
+ attr(x, "date") <- date
+ class(x) <- "stamped"
+ x
+}
+
+print.stamped <- function(x, ...) {
+ print(as.vector(x))
+ cat("Date: ", format(attr(x,"date")), "\n")
+}
+
+## Now, an S4 class with the same structure:
+setClass("stamped4", contains = "vector", slots = c(date = "POSIXt"))
+
+## We can use the S4 class to register "stamped", with its attributes:
+setOldClass("stamped", S4Class = "stamped4")
+selectMethod("show", "stamped")
+## and then remove "stamped4" to clean up
+removeClass("stamped4")
+
+set.seed(113)
+someLetters <- stamped(sample(letters, 10),
+ ISOdatetime(2008, 10, 15, 12, 0, 0))
+
+st <- new("stamped", someLetters)
+st
+# show() method prints the object's class, then calls the S3 print method.
+
+stopifnot(identical(S3Part(st, TRUE), someLetters))
+
+# creating the S4 object directly from its data part and slots
+new("stamped", 1:10, date = ISOdatetime(1976, 5, 5, 15, 10, 0))
+
+
+ removeClass("stamped")
+ rm(someLetters, st)
+
+### from S3Part.Rd
+
+## extending S3 class "lm", "xlm" directly
+## and "ylm" indirectly
+xlm <- setClass("xlm", slots = c(eps = "numeric"), contains = "lm")
+ylm <- setClass("ylm", slots = c(header = "character"), contains = "xlm")
+
+ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14)
+trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69)
+group <- gl(2,10,20, labels=c("Ctl","Trt"))
+weight <- c(ctl, trt)
+lm.D9 <- lm(weight ~ group)
+
+## lm.D9 is as computed in the example for stats::lm
+y1 <-ylm(lm.D9, header = "test", eps = .1)
+xx <- xlm(lm.D9, eps =.1)
+y2 <- ylm(xx, header = "test")
+stopifnot(inherits(y2, "lm"))
+stopifnot(identical(y1, y2))
+stopifnot(identical(S3Part(y1, strict = TRUE), lm.D9))
+
+## note the these classes can insert an S3 subclass of "lm" as the S3 part:
+myData <- data.frame(time = 1:10, y = (1:10)^.5)
+myLm <- lm(cbind(y, y^3) ~ time, myData) # S3 class: c("mlm", "lm")
+ym1 <- new("ylm", myLm, header = "Example", eps = 0.)
+
+##similar classes to "xlm" and "ylm", but extending S3 class c("mlm", "lm")
+setClass("xmm", slots = c(eps = "numeric"), contains = "mlm")
+setClass("ymm", slots = c(header="character"), contains = "xmm")
+
+ym2 <- new("ymm", myLm, header = "Example2", eps = .001)
+
+# but for class "ymm", an S3 part of class "lm" is an error:
+try(new("ymm", lm.D9, header = "Example2", eps = .001))
+tools::assertError(
+ new("ymm", lm.D9, header = "Example2", eps = .001))
+
+setClass("dataFrameD", slots = c(date = "Date"),
+ contains = "data.frame")
+myDD <- new("dataFrameD", myData, date = Sys.Date())
+
+## S3Part() applied to classes with a data part (.Data slot)
+
+setClass("NumX", contains="numeric", slots = c(id="character"))
+nn <- new("NumX", 1:10, id="test")
+stopifnot(identical(1:10, S3Part(nn, strict = TRUE)))
+
+m1 <- cbind(group, weight)
+setClass("MatX", contains = "matrix", slots = c(date = "Date"))
+mx1 <- new("MatX", m1, date = Sys.Date())
+stopifnot(identical(m1, S3Part(mx1, strict = TRUE)))
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-S4.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-S4.R
new file mode 100644
index 0000000000000000000000000000000000000000..3b37e5319de2eb244357418e56ed7d5743ef5994
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-S4.R
@@ -0,0 +1,907 @@
+####--- S4 Methods (and Classes) --- see also ../src/library/methods/tests/
+options(useFancyQuotes=FALSE)
+require(methods)
+assertError <- tools::assertError # "import"
+##too fragile: showMethods(where = "package:methods")
+
+## When this test comes too late, it fails too early in R <= 3.2.2
+require(stats4)
+detach("package:methods")
+require("methods")
+cc <- methods::getClassDef("standardGeneric")
+cc ## (auto) print failed here, in R <= 3.2.2
+stopifnot(.isMethodsDispatchOn()) ## was FALSE in R <= 3.2.2
+
+
+## Needs cached primitive generic for '$'
+new("envRefClass")# failed in R <= 3.2.0
+
+##-- S4 classes with S3 slots [moved from ./reg-tests-1.R]
+setClass("test1", representation(date="POSIXct"))
+x <- new("test1", date=as.POSIXct("2003-10-09"))
+stopifnot(format(x @ date) == "2003-10-09")
+## line 2 failed in 1.8.0 because of an extraneous space in "%in%"
+
+stopifnot(all.equal(3:3, 3.), all.equal(1., 1:1))
+
+## trace (requiring 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)),
+ identical(xy, c("A", 4, "Z")))
+
+stopifnot(identical(f("B", "C"), paste(c("A","B"), "C")),
+ 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")))
+stopifnot(identical(xyy, c("A", "B", "D", "W")))
+# got broken by Luke's lexical scoping fix:
+#stopifnot(identical(xy, xyy))
+
+## but the default method is unchanged
+stopifnot(identical(f(4,5), c("A",4,5)),
+ identical(xy, c("A", 4, "Z")))
+
+removeGeneric("f")
+## end of moved from trace.Rd
+
+
+## print/show dispatch [moved from ./reg-tests-2.R ]
+## The results have waffled back and forth.
+## Currently (R 2.4.0) the intent is that automatic printing of S4
+## objects should correspond to a call to show(), as per the green
+## book, p. 332. Therefore, the show() method is called, once defined,
+## for auto-printing foo, regardless of the S3 or S4 print() method.
+## (But most of this example is irrelevant if one avoids S3 methods for
+## S4 classes, as one should.)
+setClass("bar", representation(a="numeric"))
+foo <- new("bar", a=pi)
+foo
+show(foo)
+print(foo)
+
+setMethod("show", "bar", function(object){cat("show method\n")})
+show(foo)
+foo
+print(foo)
+# suppressed because output depends on current choice of S4 type or
+# not. Can reinstate when S4 type is obligatory
+# print(foo, digits = 4)
+
+## DON'T DO THIS: S3 methods for S4 classes are a design error JMC iii.9.09
+## print.bar <- function(x, ...) cat("print method\n")
+## foo
+## print(foo)
+## show(foo)
+
+setMethod("print", "bar", function(x, ...){cat("S4 print method\n")})
+foo
+print(foo)
+show(foo)
+## calling print() with more than one argument suppresses the show()
+## method, largely to prevent an infinite loop if there is in fact no
+## show() method for this class. A better solution would be desirable.
+print(foo, digits = 4)
+
+setClassUnion("integer or NULL", members = c("integer","NULL"))
+setClass("c1", representation(x = "integer", code = "integer or NULL"))
+nc <- new("c1", x = 1:2)
+str(nc)# gave ^ANULL^A in 2.0.0
+##
+
+
+library(stats4)
+showMethods("coerce", classes=c("matrix", "numeric"))
+## {gave wrong result for a while in R 2.4.0}
+
+## the following showMethods() output tends to generate errors in the tests
+## whenever the contents of the packages change. Searching in the
+## diff's can easily mask real problems. If there is a point
+## to the printout, e.g., to verify that certain methods exist,
+## hasMethod() would be a useful replacement
+
+## showMethods(where = "package:stats4")
+## showMethods("show")
+## showMethods("show")
+## showMethods("plot") # (ANY,ANY) and (profile.mle, missing)
+## showMethods(classes="mle")
+## showMethods(classes="matrix")
+
+
+##--- "[" fiasco before R 2.2.0 :
+d2 <- data.frame(b= I(matrix(1:6,3,2)))
+## all is well:
+d2[2,]
+stopifnot(identical(d2[-1,], d2[2:3,]))
+## Now make "[" into S4 generic by defining a trivial method
+setClass("Mat", representation(Dim = "integer", "VIRTUAL"))
+setMethod("[", signature(x = "Mat",
+ i = "missing", j = "missing", drop = "ANY"),
+ function (x, i, j, drop) x)
+## Can even remove the method: it doesn't help
+removeMethod("[", signature(x = "Mat",
+ i = "missing", j = "missing", drop = "ANY"))
+d2[1:2,] ## used to fail badly; now okay
+stopifnot(identical(d2[-1,], d2[2:3,]))
+## failed in R <= 2.1.x
+
+
+## Fritz' S4 "odditiy"
+setClass("X", representation(bar="numeric"))
+setClass("Y", contains="X")
+## Now we define a generic foo() and two different methods for "X" and
+## "Y" objects for arg missing:
+setGeneric("foo", function(object, arg) standardGeneric("foo"))
+setMethod("foo", signature(object= "X", arg="missing"),
+ function(object, arg) cat("an X object with bar =", object@bar, "\n"))
+setMethod("foo", signature(object= "Y", arg="missing"),
+ function(object, arg) cat("a Y object with bar =", object@bar, "\n"))
+## Finally we create a method where arg is "logical" only for class
+## "X", hence class "Y" should inherit that:
+setMethod("foo", signature(object= "X", arg= "logical"),
+ function(object, arg) cat("Hello World!\n") )
+## now create objects and call methods:
+y <- new("Y", bar=2)
+## showMethods("foo")
+foo(y)
+foo(y, arg=TRUE)## Hello World!
+## OK, inheritance worked, and we have
+## showMethods("foo")
+foo(y)
+## still 'Y' -- was 'X object' in R < 2.3
+
+
+## Multiple inheritance
+setClass("A", representation(x = "numeric"))
+setClass("B", representation(y = "character"))
+setClass("C", contains = c("A", "B"), representation(z = "logical"))
+new("C")
+setClass("C", contains = c("A", "B"), representation(z = "logical"),
+ prototype = prototype(x = 1.5, y = "test", z = TRUE))
+(cc <- new("C"))
+## failed reconcilePropertiesAndPrototype(..) after svn r37018
+stopifnot(identical(selectSuperClasses("C", dropVirtual = TRUE), c("A", "B")),
+ 0 == length(.selectSuperClasses(getClass("B")@contains)))
+
+## "Logic" group -- was missing in R <= 2.4.0
+stopifnot(all(getGroupMembers("Logic") %in% c("&", "|")),
+ any(getGroupMembers("Ops") == "Logic"))
+setClass("brob", contains="numeric")
+b <- new("brob", 3.14)
+logic.brob.error <- function(nm)
+ stop("logic operator '", nm, "' not applicable to brobs")
+logic2 <- function(e1,e2) logic.brob.error(.Generic)
+setMethod("Logic", signature("brob", "ANY"), logic2)
+setMethod("Logic", signature("ANY", "brob"), logic2)
+## Now ensure that using group members gives error:
+assertError(b & b)
+assertError(b | 1)
+assertError(TRUE & b)
+
+
+## methods' hidden cbind() / rbind:
+setClass("myMat", representation(x = "numeric"))
+setMethod("cbind2", signature(x = "myMat", y = "missing"), function(x,y) x)
+m <- new("myMat", x = c(1, pi))
+stopifnot(identical(m, methods:::cbind(m)), identical(m, cbind(m)))
+
+
+## explicit print or show on a basic class with an S4 bit
+## caused infinite recursion
+setClass("Foo", representation(name="character"), contains="matrix")
+(f <- new("Foo", name="Sam", matrix()))
+f2 <- new("Foo", .Data = diag(2), name="Diag")# explicit .Data
+(m <- as(f, "matrix"))
+## this has no longer (2.7.0) an S4 bit: set it explicitly just for testing:
+stopifnot(isS4(m. <- asS4(m)),
+ identical(m, f@.Data),
+ .hasSlot(f, "name"))# failed in R <= 2.13.1
+show(m.)
+print(m.)
+## fixed in 2.5.0 patched
+
+## callGeneric inside a method with new arguments {hence using .local()}:
+setGeneric("Gfun", function(x, ...) standardGeneric("Gfun"),
+ useAsDefault = function(x, ...) sum(x, ...))
+setClass("myMat", contains="matrix")
+setClass("mmat2", contains="matrix")
+setClass("mmat3", contains="mmat2")
+setMethod(Gfun, signature(x = "myMat"),
+ function(x, extrarg = TRUE) {
+ cat("in 'myMat' method for 'Gfun() : extrarg=", extrarg, "\n")
+ Gfun(unclass(x))
+ })
+setMethod(Gfun, signature(x = "mmat2"),
+ function(x, extrarg = TRUE) {
+ cat("in 'mmat2' method for 'Gfun() : extrarg=", extrarg, "\n")
+ x <- unclass(x)
+ callGeneric()
+ })
+setMethod(Gfun, signature(x = "mmat3"),
+ function(x, extrarg = TRUE) {
+ cat("in 'mmat3' method for 'Gfun() : extrarg=", extrarg, "\n")
+ x <- as(x, "mmat2")
+ callGeneric()
+ })
+wrapG <- function(x, a1, a2) {
+ myextra <- missing(a1) && missing(a2)
+ Gfun(x, extrarg = myextra)
+}
+
+(mm <- new("myMat", diag(3)))
+Gfun(mm)
+stopifnot(identical(wrapG(mm), Gfun(mm, TRUE)),
+ identical(wrapG(mm,,2), Gfun(mm, FALSE)))
+
+Gfun(mm, extrarg = FALSE)
+m2 <- new("mmat2", diag(3))
+Gfun(m2)
+Gfun(m2, extrarg = FALSE)
+## The last two gave Error ...... variable ".local" was not found
+(m3 <- new("mmat3", diag(3)))
+Gfun(m3)
+Gfun(m3, extrarg = FALSE) # used to not pass 'extrarg'
+
+## -- a variant of the above which failed in version <= 2.5.1 :
+setGeneric("Gf", function(x, ...) standardGeneric("Gf"))
+setMethod(Gf, signature(x = "mmat2"),
+ function(x, ...) {
+ cat("in 'mmat2' method for 'Gf()\n")
+ x <- unclass(x)
+ callGeneric()
+ })
+setMethod(Gf, signature(x = "mmat3"),
+ function(x, ...) {
+ cat("in 'mmat3' method for 'Gf()\n")
+ x <- as(x, "mmat2")
+ callGeneric()
+ })
+setMethod(Gf, signature(x = "matrix"),
+ function(x, a1, ...) {
+ cat(sprintf("matrix %d x %d ...\n", nrow(x), ncol(x)))
+ list(x=x, a1=a1, ...)
+ })
+
+wrap2 <- function(x, a1, ...) {
+ A1 <- if(missing(a1)) "A1" else as.character(a1)
+ Gf(x, ..., a1 = A1)
+}
+## Gave errors in R 2.5.1 :
+wrap2(m2, foo = 3.14)
+wrap2(m2, 10, answer.all = 42)
+
+
+## regression tests of dispatch: most of these became primitive in 2.6.0
+setClass("c1", "numeric")
+setClass("c2", "numeric")
+x_c1 <- new("c1")
+# the next failed < 2.5.0 as the signature in .BasicFunsList was wrong
+setMethod("as.character", "c1", function(x, ...) "fn test")
+as.character(x_c1)
+
+setMethod("as.integer", "c1", function(x, ...) 42)
+as.integer(x_c1)
+
+setMethod("as.logical", "c1", function(x, ...) NA)
+as.logical(x_c1)
+
+setMethod("as.complex", "c1", function(x, ...) pi+0i)
+as.complex(x_c1)
+
+setMethod("as.raw", "c1", function(x) as.raw(10))
+as.raw(x_c1)
+
+# as.double, as.real use as.numeric for their methods to maintain equivalence
+setMethod("as.numeric", "c1", function(x, ...) 42+pi)
+identical(as.numeric(x_c1),as.double(x_c1))
+
+
+setMethod(as.double, "c2", function(x, ...) x@.Data+pi)
+x_c2 <- new("c2", pi)
+identical(as.numeric(x_c2),as.double(x_c2))
+
+## '!' changed signature from 'e1' to 'x' in 2.6.0
+setClass("foo", "logical")
+setMethod("!", "foo", function(e1) e1+NA)
+selectMethod("!", "foo")
+xx <- new("foo", FALSE)
+!xx
+
+## This fails in R versions earlier than 2.6.0:
+setMethod("as.vector", "foo", function(x) unclass(x))
+stopifnot(removeClass("foo"))
+
+## stats4::AIC in R < 2.7.0 used to clobber stats::AIC
+pfit <- function(data) {
+ m <- mean(data)
+ loglik <- sum(dpois(data, m))
+ ans <- list(par = m, loglik = loglik)
+ class(ans) <- "pfit"
+ ans
+}
+AIC.pfit <- function(object, ..., k = 2) -2*object$loglik + k
+AIC(pfit(1:10))
+library(stats4) # and keep on search() for tests below
+AIC(pfit(1:10)) # failed in R < 2.7.0
+
+## For a few days (~ 2008-01-30), this failed to work without any notice:
+setClass("Mat", representation(Dim = "integer","VIRTUAL"))
+setClass("dMat", representation(x = "numeric", "VIRTUAL"), contains = "Mat")
+setClass("CMat", representation(dnames = "list","VIRTUAL"), contains = "Mat")
+setClass("dCMat", contains = c("dMat", "CMat"))
+stopifnot(!isVirtualClass("dCMat"),
+ length(slotNames(new("dCMat"))) == 3)
+
+
+## Passing "..." arguments in nested callGeneric()s
+setClass("m1", contains="matrix")
+setClass("m2", contains="m1")
+setClass("m3", contains="m2")
+##
+setGeneric("foo", function(x, ...) standardGeneric("foo"))
+setMethod("foo", signature(x = "m1"),
+ function(x, ...) cat(" <m1> ", format(match.call()),"\n"))
+setMethod("foo", signature(x = "m2"),
+ function(x, ...) {
+ cat(" <m2> ", format(match.call()),"\n")
+ x <- as(x, "m1"); callGeneric()
+ })
+setMethod("foo", signature(x = "m3"),
+ function(x, ...) {
+ cat(" <m3> ", format(match.call()),"\n")
+ x <- as(x, "m2"); callGeneric()
+ })
+foo(new("m1"), bla = TRUE)
+foo(new("m2"), bla = TRUE)
+foo(new("m3"), bla = TRUE)
+## The last one used to loose 'bla = TRUE' {the "..."} when it got to m1
+
+## is() for S3 objects with multiple class strings
+setClassUnion("OptionalPOSIXct", c("POSIXct", "NULL"))
+stopifnot(is(Sys.time(), "OptionalPOSIXct"))
+## failed in R 2.7.0
+
+## getGeneric() / getGenerics() "problems" related to 'tools' usage:
+e4 <- as.environment("package:stats4")
+gg4 <- getGenerics(e4)
+stopifnot(c("BIC", "coef", "confint", "logLik", "plot", "profile",
+ "show", "summary", "update", "vcov") %in% gg4, # %in% : "future proof"
+ unlist(lapply(gg4, function(g) !is.null(getGeneric(g, where = e4)))),
+ unlist(lapply(gg4, function(g) !is.null(getGeneric(g)))))
+em <- as.environment("package:methods")
+ggm <- getGenerics(em)
+gms <- c("addNextMethod", "body<-", "cbind2", "initialize",
+ "loadMethod", "Ops", "rbind2", "show")
+stopifnot(unlist(lapply(ggm, function(g) !is.null(getGeneric(g, where = em)))),
+ unlist(lapply(ggm, function(g) !is.null(getGeneric(g)))),
+ gms %in% ggm,
+ gms %in% tools:::get_S4_generics_with_methods(em), # with "message"
+ ## all above worked in 2.7.0, however:
+ isGeneric("show", where=e4),
+ hasMethods("show", where=e4), hasMethods("show", where=em),
+ identical(as.character(gg4), #gg4 has packages attr.; tools::: doesn't
+ tools:::get_S4_generics_with_methods(e4))
+ )
+## the last failed in R 2.7.0 : was not showing "show"
+
+if(require("Matrix")) {
+ D5. <- Diagonal(x = 5:1)
+ D5N <- D5.; D5N[5,5] <- NA
+ stopifnot(isGeneric("dim", where=as.environment("package:Matrix")),
+ identical(D5., pmin(D5.)),
+ identical(D5., pmax(D5.)),
+ identical(D5., pmax(D5., -1)),
+ identical(D5., pmin(D5., 7)),
+ inherits((D5.3 <- pmin(D5.+2, 3)), "Matrix"),
+ identical(as.matrix(pmin(D5.+2 , 3)),
+ pmin(as.matrix(D5.+2), 3)),
+ identical(pmin(1, D5.), pmin(1, as.matrix(D5.))),
+ identical(D5N, pmax(D5N, -1)),
+ identical(D5N, pmin(D5N, 5)),
+ identical(unname(as.matrix(pmin(D5N+1, 3))),
+ pmin(as.matrix(D5N)+1, 3)),
+ ##
+ TRUE)
+}
+
+
+## containing "array" ("matrix", "ts", ..)
+t. <- ts(1:10, frequency = 4, start = c(1959, 2))
+setClass("Arr", contains= "array"); x <- new("Arr", cbind(17))
+setClass("Ts", contains= "ts"); tt <- new("Ts", t.); t2 <- as(t., "Ts")
+setClass("ts2", representation(x = "Ts", y = "ts"))
+tt2 <- new("ts2", x=t2, y=t.)
+stopifnot(dim(x) == c(1,1), is(tt, "ts"), is(t2, "ts"),
+ ## FIXME: identical(tt, t2)
+ length(tt) == length(t.),
+ identical(tt2@x, t2), identical(tt2@y, t.))
+## new(..) failed in R 2.7.0
+
+## Method with wrong argument order :
+setGeneric("test1", function(x, printit = TRUE, name = "tmp")
+ standardGeneric("test1"))
+tools::assertCondition(
+setMethod("test1", "numeric", function(x, name, printit) match.call()),
+"warning", "error")## did not warn or error in R 2.7.0 and earlier
+
+library(stats4)
+c1 <- getClass("mle", where = "stats4")
+c2 <- getClass("mle", where = "package:stats4")
+s1 <- getMethod("summary", "mle", where = "stats4")
+s2 <- getMethod("summary", "mle", where = "package:stats4")
+stopifnot(is(c1, "classRepresentation"),
+ is(s1, "MethodDefinition"),
+ identical(c1,c2), identical(s1,s2))
+## failed at times in the past
+
+## Extending "matrix", the .Data slot etc:
+setClass("moo", representation("matrix"))
+m <- matrix(1:4, 2, dimnames= list(NULL, c("A","B")))
+nf <- new("moo", .Data = m)
+n2 <- new("moo", 3:1, 3,2)
+n3 <- new("moo", 1:6, ncol=2)
+stopifnot(identical(m, as(nf, "matrix")),
+ identical(matrix(3:1,3,2), as(n2, "matrix")),
+ identical(matrix(1:6,ncol=2), as(n3, "matrix")))
+## partly failed at times in pre-2.8.0
+
+## From "Michael Lawrence" <....@fhcrc.org> To r-devel@r-project, 25 Nov 2008:
+## NB: setting a generic on order() is *not* the approved method
+## -- set xtfrm() methods instead
+setGeneric("order", signature="...",
+ function (..., na.last=TRUE, decreasing=FALSE)
+ standardGeneric("order"))
+stopifnot(identical(rbind(1), matrix(1,1,1)))
+setGeneric("rbind", function(..., deparse.level=1)
+ standardGeneric("rbind"), signature = "...")
+stopifnot(identical(rbind(1), matrix(1,1,1)))
+## gave Error in .Method( .... in R 2.8.0
+
+## median( <simple S4> )
+## FIXME: if we use "C" instead of "L", this fails because of caching
+setClass("L", contains = "list")
+## {simplistic, just for the sake of testing here} :
+setMethod("Compare", signature(e1="L", e2="ANY"),
+ function(e1,e2) sapply(e1, .Generic, e2=e2))
+## note the next does *not* return an object of the class.
+setMethod("Summary", "L",
+ function(x, ..., na.rm=FALSE) {x <- unlist(x); callNextMethod()})
+setMethod("[", signature(x="L", i="ANY", j="missing",drop="missing"),
+ function(x,i,j,drop) new(class(x), x@.Data[i]))
+## defining S4 methods for sort() has no effect on calls to
+## sort() from functions in a namespace; e.g., median.default.
+## but setting an xtfrm() method works.
+setMethod("xtfrm", "L", function(x) xtfrm(unlist(x@.Data)))
+## median is documented to use mean(), so we need an S3 mean method:
+## An S4 method will not do because of the long-standing S4 scoping bug.
+mean.L <- function(x, ...) new("L", mean(unlist(x@.Data), ...))
+x <- new("L", 1:3); x2 <- x[-2]
+stopifnot(unlist(x2) == (1:3)[-2],
+ is(mx <- median(x), "L"), mx == 2,
+ ## median of two
+ median(x2) == x[2])
+## NB: quantile() is not said to work on such an object, and only does so
+## for order statistics (so should not be tested, but was in earlier versions).
+
+## Buglet in as() generation for class without own slots
+setClass("SIG", contains="signature")
+stopifnot(packageSlot(class(S <- new("SIG"))) == ".GlobalEnv",
+ packageSlot(class(ss <- new("signature"))) == "methods",
+ packageSlot(class(as(S, "signature"))) == "methods")
+## the 3rd did not have "methods"
+
+## Invalid "factor"s -- now "caught" by validity check :
+ ok.f <- gl(3,5, labels = letters[1:3])
+bad.f <- structure(rep(1:3, each=5), levels=c("a","a","b"), class="factor")
+validObject(ok.f) ; assertError(validObject(bad.f))
+setClass("myF", contains = "factor")
+validObject(new("myF", ok.f))
+assertError(validObject(new("myF", bad.f)))
+removeClass("myF")
+## no validity check in R <= 2.9.0
+
+## as(x, .) when x is from an "unregistered" S3 class :
+as(structure(1:3, class = "foobar"), "vector")
+## failed to work in R <= 2.9.0
+
+## S4 dispatch in the internal generic xtfrm (added in 2.11.0)
+setClass("numWithId", representation(id = "character"), contains = "numeric")
+x <- new("numWithId", 1:3, id = "An Example")
+xtfrm(x) # works as the base representation is numeric
+setMethod('xtfrm', 'numWithId', function(x) x@.Data)
+xtfrm(x)
+stopifnot(identical(xtfrm(x), 1:3))# "integer" is "numeric"
+## new in 2.11.0
+
+## [-dispatch using callNextMethod()
+setClass("C1", representation(a = "numeric"))
+setClass("C2", contains = "C1")
+setMethod("[", "C1", function(x,i,j,...,drop=TRUE)
+ cat("drop in C1-[ :", drop, "\n"))
+setMethod("[", "C2", function(x,i,j,...,drop=TRUE) {
+ cat("drop in C2-[ :", drop, "\n")
+ callNextMethod()
+})
+x <- new("C1"); y <- new("C2")
+x[1, drop=FALSE]
+y[1, drop=FALSE]
+## the last gave TRUE on C1-level in R 2.10.x;
+## the value of drop was wrongly taken from the default.
+
+## All slot names -- but "class" -- should work now
+problNames <- c("names", "dimnames", "row.names",
+ "class", "comment", "dim", "tsp")
+myTry <- function(expr, ...) tryCatch(expr, error = function(e) e)
+tstSlotname <- function(nm) {
+ r <- myTry(setClass("foo", representation =
+ structure(list("character"), .Names = nm)))
+ if(is(r, "error")) return(r$message)
+ ## else
+ ch <- LETTERS[1:5]
+ ## instead of new("foo", <...> = ch):
+ x <- myTry(do.call(new, structure(list("foo", ch), .Names=c("", nm))))
+ if(is(x, "error")) return(x$message)
+ y <- myTry(new("foo")); if(is(y, "error")) return(y$message)
+ r <- myTry(capture.output(show(x))); if(is(r, "error")) return(r$message)
+ r <- myTry(capture.output(show(y))); if(is(r, "error")) return(r$message)
+ ## else
+ slot(y, nm) <- slot(x, nm)
+ stopifnot(validObject(x), identical(x,y), identical(slot(x, nm), ch))
+ return(TRUE)
+}
+R <- sapply(problNames, tstSlotname, simplify = FALSE)
+str(R) # just so ...
+stopifnot(is.character(R[["class"]]),
+ sapply(R[names(R) != "class"], isTRUE))
+## only "class" (and ".Data", ...) is reserved as slot name
+
+## implicit generics ..
+setMethod("sample", "C2",
+ function(x, size, replace=FALSE, prob=NULL) {"sample.C2"})
+stopifnot(is(sample,"standardGeneric"),
+ ## the signature must come from the implicit generic:
+ identical(sample@signature, c("x", "size")),
+ identical(packageSlot(sample), "base"),
+ ## default method must still work:
+ identical({set.seed(3); sample(3)}, 1:3))
+## failed in R 2.11.0
+
+## Still, signature is taken from "def"inition, if one is provided:
+## (For test, qqplot must be a "simple" function:)
+stopifnot(is.function(qqplot) && identical(class(qqplot), "function"))
+setGeneric("qqplot", function(x, y, ...) standardGeneric("qqplot"))
+stopifnot(is(qqplot, "standardGeneric"),
+ identical(qqplot@signature, c("x","y")))
+## failed for a day ~ 2005-05-26, for R-devel only
+
+
+## 'L$A@x <- ..'
+setClass("foo", representation(x = "numeric"))
+f <- new("foo", x = pi*1:2)
+L <- list()
+L$A <- f
+L$A@x[] <- 7
+if( identical(f, L$A) )
+ stop("Oops! f is identical to L$A, even though not touched!")
+## did not duplicate in 2.0.0 <= Rversion <= 2.11.1
+
+
+## prototypes for virtual classes: NULL if legal, otherwise 1st member
+## OptionalPosixct above includes NULL
+stopifnot(is.null(getClass("OptionalPOSIXct")@prototype))
+## "IntOrChar" had invalid NULL prototype < 2.15.0
+setClassUnion("IntOrChar", c("integer", "character"))
+stopifnot(is.integer(getClass("IntOrChar")@prototype))
+## produced an error < 2.15.0
+stopifnot(identical(isGeneric("&&"), FALSE))
+
+
+## mapply() on S4 objects with a "non-primitive" length() method
+setClass("A", representation(aa="integer"))
+aa <- 11:16
+a <- new("A", aa=aa)
+setMethod(length, "A", function(x) length(x@aa))
+setMethod(`[[`, "A", function(x, i, j, ...) x@aa[[i]])
+setMethod(`[`, "A", function(x, i, j, ...) new("A", aa = x@aa[i]))
+setMethod("is.na","A", function(x) is.na(x@aa))
+stopifnot(length(a) == 6, identical(a[[5]], aa[[5]]),
+ identical(a, rev(rev(a))), # using '['
+ identical(mapply(`*`, aa, rep(1:3, 2)),
+ mapply(`*`, a, rep(1:3, 2))))
+## Up to R 2.15.2, internally 'a' is treated as if it was of length 1
+## because internal dispatch did not work for length().
+
+setMethod("is.unsorted", "A", function(x, na.rm, strictly)
+ is.unsorted(x@aa, na.rm=na.rm, strictly=strictly))
+
+stopifnot(!is.unsorted(a), # 11:16 *is* sorted
+ is.unsorted(rev(a)))
+
+# getSrcref failed when rematchDefinition was used
+text <- '
+setClass("MyClass", representation(val = "numeric"))
+setMethod("plot", signature(x = "MyClass"),
+ function(x, y, ...) {
+ # comment
+ NULL
+ })
+setMethod("initialize", signature = "MyClass",
+ function(.Object, value) {
+ # comment
+ .Object@val <- value
+ return(.Object)
+ })
+'
+source(textConnection(text), keep.source = TRUE)
+getSrcref(getMethod("plot", "MyClass"))
+getSrcref(getMethod("initialize", "MyClass"))
+
+
+## PR#15691
+setGeneric("fun", function(x, ...) standardGeneric("fun"))
+setMethod("fun", "character", identity)
+setMethod("fun", "numeric", function(x) {
+ x <- as.character(x)
+ callGeneric()
+})
+
+stopifnot(identical(fun(1), do.call(fun, list(1))))
+## failed in R < 3.1.0
+
+
+## PR#15680
+setGeneric("f", function(x, y) standardGeneric("f"))
+setMethod("f", c("numeric", "missing"), function(x, y) x)
+try(?f(1))
+
+## "..." is not handled
+setGeneric("f", function(...) standardGeneric("f"))
+setMethod("f", "numeric", function(...) c(...))
+try(?f(1,2))
+
+## defaults in the generic formal arguments are not considered
+setGeneric("f", function(x, y=0) standardGeneric("f"))
+setMethod("f", c("numeric", "numeric"), function(x, y) x+y)
+try(?f(1))
+
+## Objects with S3 classes fail earlier
+setGeneric("f", function(x) standardGeneric("f"))
+setMethod("f", "numeric", function(x) x)
+setOldClass(c("foo", "numeric"))
+n <- structure(1, class=c("foo", "numeric"))
+try(?f(n))
+## different failures in R < 3.1.0.
+
+
+## identical() did not look at S4 bit:
+a <- 1:5
+b <- setClass("B", "integer")(a)
+stopifnot(is.character(all.equal(a, b)))
+attributes(a) <- attributes(b)
+if(!isS4(a)) { # still (unfortunately)
+ message("'a' is not S4 yet")
+ if(identical(a,b)) stop("identical() not looking at S4 bit")
+ ## set S4 bit manually:
+ a <- asS4(a)
+}
+stopifnot(identical(a, b), isS4(a))
+## failed in R <= 3.1.1
+
+
+### cbind(), rbind() now work both via rbind2(), cbind2() and rbind.
+##__ 1) __
+setClass("A", representation(a = "matrix"))
+setMethod("initialize", signature(.Object = "A"),
+ function(.Object, y) {
+ .Object@a <- y
+ .Object
+ })
+setMethod("rbind2", signature(x = "A", y = "matrix"),
+ function(x, y, ...) {
+ cat("rbind2(<A>, <matrix>) : ")
+ x@a <- rbind(x@a, y)
+ cat(" x@a done\n")
+ x
+ })
+setMethod("dim", "A", function(x) dim(x@a))
+mat1 <- matrix(1:9, nrow = 3)
+obj1 <- new("A", 10*mat1)
+om1 <- rbind(obj1, mat1)## now does work {it does need a working "dim" method!}
+stopifnot(identical(om1, rbind2(obj1, mat1)))
+rm(obj1,om1); removeClass("A")
+##
+##
+###__ 2) --- Matrix --- via cbind2(), rbind2()
+## this has its output checked strictly, so test depending on Matrix
+## has been moved to reg-tests-3.R
+##
+###__ 3) --- package 'its' like
+setClass("its",representation("matrix", dates="POSIXt"))
+m <- outer(1:3, setNames(1:5,LETTERS[1:5]))
+im <- new("its", m, dates=as.POSIXct(Sys.Date()))
+stopifnot(identical(m, im@.Data))
+ii <- rbind(im, im-1)
+i.i <- cbind(im, im-7)
+stopifnot(identical(m, rbind(im)),
+ identical(m, cbind(im)),
+ identical(ii , rbind(m, m-1)),
+ identical(i.i, cbind(m, m-7)))
+rm(im, ii, i.i)
+removeClass("its")
+##
+##
+###__ 4) --- pkg 'mondate' like --
+setClass("mondate",
+ slots = c(timeunits = "character"), contains = "numeric")
+three <- 3
+m1 <- new("mondate", 1:4, timeunits = "hrs")
+m2 <- new("mondate", 7:8, timeunits = "min")
+stopifnot(identical(colnames(cbind(m1+1, deparse.level=2)), "m1 + 1"),
+ is.null (colnames(cbind(m1+1, deparse.level=0))),
+ is.null (colnames(cbind(m1+1, deparse.level=1))),
+ identical(colnames(cbind(m1)), "m1"),
+ colnames(cbind(m1 , M2 = 2, deparse.level=0)) == c("" , "M2"),
+ colnames(cbind(m1 , M2 = 2)) == c("m1", "M2"),
+ colnames(cbind(m1 , M2 = 2, deparse.level=2)) == c("m1", "M2"),
+ colnames(cbind(m1+1, M2 = 2, deparse.level=2)) == c("m1 + 1", "M2"),
+ colnames(cbind(m1+1, M2 = 2, deparse.level=1)) == c("", "M2"))
+cbind(m1, three, m2)
+cbind(m1, three, m2, deparse.level = 0) # none
+cbind(m1, three, m2+3, deparse.level = 1) # "m1" "three"
+cbind(m1, three, m2+3, deparse.level = 2) -> m3
+m3 # .... and "m2 + 3"
+stopifnot(identical(t(m3), rbind(m1, three, m2+3, deparse.level = 2)),
+ identical(cbind(m1, m2) -> m12,
+ cbind(m1=m1@.Data, m2=m2@.Data)),
+ identical(rbind(m1, m2), t(m12)),
+ identical(cbind(m1, m2, T=T, deparse.level=0),
+ cbind(m1@.Data, m2@.Data, T=T) -> mm),
+ identical(colnames(mm), c("", "", "T")),
+ identical(cbind(m1, m2, deparse.level=0),
+ cbind(m1@.Data, m2@.Data)))
+##
+## Cleanup all class definitions etc -- seems necessary for the following "re"-definitions:
+invisible(lapply(getClasses(globalenv()), removeClass))
+nn <- names(globalenv())
+rm(list = c("nn", nn))
+
+## Using "data.frame" in a slot -- all have worked for long:
+setClass("A", representation(slot1="numeric", slot2="logical"))
+setClass("D1", contains="A", representation(design="data.frame"))
+setClass("D2", contains="D1")
+validObject(a <- new("A", slot1=77, slot2=TRUE))
+validObject(D. <- new("D2", a, design = data.frame(x = 1)))
+## using "formula" in a slot -- from Hervé Pages :
+setClass("B", contains="A", representation(design="formula"))
+setClass("C", contains="B")
+##
+a <- new("A", slot1=77, slot2=TRUE)
+validObject(C1 <- new("C", a, design = x ~ y))# failed for R <= 3.2.0
+C2 <- new("C", slot1=a@slot1, slot2=a@slot2, design=x ~ y)
+stopifnot(identical(C1, C2),
+ identical(formula(), formula(NULL)),
+ length(N <- new("formula")) == 0, inherits(N, "formula"),
+ length(N <- new("table") ) == 0, is.table(N),
+ validObject(N <- new("summary.table")),
+ length(N <- new("ordered")) == 0, is.ordered(N))
+## formula() and new("formula"), new("..") also failed in R <= 3.2.0
+
+require("stats4")# -> "mle" class
+validObject(sig <- new("signature", obj = "mle"))
+stopifnot(c("package", "names") %in% slotNames(sig))
+str(sig) # failed, too
+
+cl4 <- getClasses("package:stats4")
+stopifnot(identical(getClasses(which(search() == "package:stats4")), cl4),
+ c("mle", "profile.mle", "summary.mle") %in% cl4)
+## failed after an optimization patch
+
+detach("package:methods", force=TRUE)
+C1@slot1 <- pi
+stopifnot(identical(C1@slot1, pi))
+stopifnot(require("methods"))
+## Slot assignment failed in R <= 3.2.2, C code calling checkAtAssignment()
+
+## Error in argument evaluation of S4 generic - PR#16111
+f <- function() {
+ signal <- FALSE
+ withCallingHandlers({ g(sqrt(-1)) }, warning = function(w) {
+ signal <<- TRUE
+ invokeRestart("muffleWarning")
+ })
+ signal
+}
+g <- function(x) x
+op <- options(warn = 2)# warnings give errors
+stopifnot(isTRUE( f() ))
+setGeneric("g")
+stopifnot(isTRUE( f() ))
+options(op)
+## the second f() gave a warning and FALSE in R versions 2.12.0 <= . <= 3.2.3
+
+
+stopifnot(
+ identical(formals(getGeneric("as.vector")), formals(base::as.vector)),
+ identical(formals(getGeneric("unlist")), formals(base::unlist)))
+## failed for a while in R-devel (3.3.0)
+
+setClass("myInteger", contains=c("integer", "VIRTUAL"))
+setClass("mySubInteger", contains="myInteger")
+new("mySubInteger", 1L)
+## caused infinite recursion in R 3.3.0
+
+detach("package:methods", force=TRUE)
+methods::setClass("test1", methods::representation(date="POSIXct"))
+methods::setClass("test2", contains="test1")
+test <- function(x) UseMethod('test', x)
+test.test1 <- function(x) 'Hi'
+test(methods::new("test2", date=as.POSIXct("2003-10-09")))
+stopifnot(require("methods"))
+## S3 dispatch to superclass methods failed on S4 objects when
+## methods package was not attached
+
+
+## Tests for class fetching and conflict resolution
+setClass("htest1", slots=c(a="numeric",b="data.frame"), package="package1")
+setClass("htest2", slots=c(a="logical"), package="package2")
+class.list = list(
+ package1=getClassDef("htest1", where=class_env1),
+ package2=getClassDef("htest2", where=class_env2)
+)
+
+firstclass <- methods:::.resolveClassList(class.list,.GlobalEnv,
+ package="package1")
+secondclass <- methods:::.resolveClassList(class.list,.GlobalEnv,
+ package="package2")
+alsofirstclass <- methods:::.resolveClassList(class.list,.GlobalEnv,
+ package="package3")
+stopifnot(!identical(firstclass, secondclass))
+stopifnot(identical(firstclass, class.list[[1]]))
+stopifnot(identical(secondclass, class.list[[2]]))
+stopifnot(identical(alsofirstclass, class.list[[1]]))
+
+## implicit coercion of S4 object to vector via as.vector() in sub-assignment
+setClass("A", representation(stuff="numeric"))
+as.vector.A <- function (x, mode="any") x@stuff
+v <- c(3.5, 0.1)
+a <- new("A", stuff=v)
+x <- y <- numeric(10)
+x[3:4] <- a
+y[3:4] <- v
+stopifnot(identical(x, y))
+
+## callNextMethod() was broken when augmenting args of primitive generics
+foo <- setClass("foo")
+bar <- setClass("bar", contains = "foo")
+
+setMethod("[", "foo", function(x, i, j, ..., flag = FALSE, drop = FALSE) {
+ flag
+})
+
+setMethod("[", "bar", function(x, i, j, ..., flag = FALSE, drop = FALSE) {
+ callNextMethod()
+})
+
+BAR <- new("bar")
+stopifnot(identical(BAR[1L], FALSE))
+stopifnot(identical(BAR[1L, , flag=TRUE], TRUE))
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-examples1.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-examples1.R
new file mode 100644
index 0000000000000000000000000000000000000000..b135b9a46a266e1901df16f88f48cdd7c1af41d9
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-examples1.R
@@ -0,0 +1,90 @@
+## For examples skipped in testing because they are 'random'
+
+set.seed(1)
+if(.Platform$OS.type == "windows") options(pager = "console")
+
+pdf("reg-examples-1.pdf", encoding = "ISOLatin1.enc")
+
+
+## base
+example(Cstack_info, run.donttest = TRUE)
+example(DateTimeClasses, run.donttest = TRUE)
+example(Dates, run.donttest = TRUE)
+example(Ops.Date, run.donttest = TRUE)
+example(Random, run.donttest = TRUE)
+example(Sys.getpid, run.donttest = TRUE)
+example(Sys.sleep, run.donttest = TRUE)
+example(Sys.time, run.donttest = TRUE)
+example(as.POSIXlt, run.donttest = TRUE)
+example(difftime, run.donttest = TRUE)
+example(format.Date, run.donttest = TRUE)
+example(Reduce, run.donttest = TRUE) # funprog.Rd
+example(gc, run.donttest = TRUE)
+example(memory.profile, run.donttest = TRUE)
+paste("Today is", date()) # from paste.Rd
+trunc(Sys.time(), "day") # from round.POSIXt.Rd
+example(srcref, run.donttest = TRUE)
+example(strptime, run.donttest = TRUE)
+example(sys.parent, run.donttest = TRUE)
+example(system.time, run.donttest = TRUE)
+example(tempfile, run.donttest = TRUE)
+example(weekdays, run.donttest = TRUE)
+library(help = "splines")
+
+## for example(NA)
+if(require("microbenchmark")) {
+ x <- c(NaN, 1:10000)
+ print(microbenchmark(any(is.na(x)), anyNA(x)))
+} else { ## much less accurate
+ x <- c(NaN, 1e6)
+ nSim <- 2^13
+ print(rbind(is.na = system.time(replicate(nSim, any(is.na(x)))),
+ anyNA = system.time(replicate(nSim, anyNA(x)))))
+}
+
+## utils
+example(news, run.donttest = TRUE)
+example(sessionInfo, run.donttest = TRUE)
+
+## datasets
+example(JohnsonJohnson, run.donttest = TRUE)
+example(ability.cov, run.donttest = TRUE)
+example(npk, run.donttest = TRUE)
+
+## grDevices
+example(grSoftVersion, run.donttest = TRUE)
+if(.Platform$OS.type == "windows") {
+ example(windowsFonts, run.donttest = TRUE)
+} else {
+ example(X11Fonts, run.donttest = TRUE)
+ example(quartzFonts, run.donttest = TRUE)
+}
+
+library(tools)
+example(Rdutils, run.donttest = TRUE)
+example(fileutils, run.donttest = TRUE)
+example(makevars_user, run.donttest = TRUE)
+## results are location- and OS-specific
+example(parseLatex, run.donttest = TRUE) # charset-specific
+example(loadRdMacros, run.donttest = TRUE) # collation-specific
+
+## part of example(buildVignettes) at one time
+gVigns <- pkgVignettes("grid")
+str(gVigns) # contains paths
+
+vind <- system.file(package = "grid", "doc", "index.html")
+if(nzchar(vind)) { # so vignettes have been installed
+ `%=f=%` <- function(a, b) normalizePath(a) == normalizePath(b)
+ with(gVigns,
+ stopifnot(engines == "utils::Sweave",
+ pkgdir %=f=% system.file(package="grid"),
+ dir %=f=% system.file(package = "grid", "doc"),
+ (n. <- length(docs)) >= 12, # have 13
+ n. == length(names), n. == length(engines),
+ length(msg) == 0) ) # as it is a 'base' package
+ stopifnot("grid" %in% gVigns$names, inherits(gVigns, "pkgVignettes"))
+}
+
+## This might leave collation changed, so do not put other things after it.
+example(icuSetCollate, run.donttest = TRUE)
+proc.time()
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-examples2.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-examples2.R
new file mode 100644
index 0000000000000000000000000000000000000000..0e17c822a6570cc9347880c1671f972b8535e960
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-examples2.R
@@ -0,0 +1,38 @@
+## For examples skipped in testing because they are 'random'
+
+## some should still be skipped when --with-recommended-packages=no :
+## (This is not really right as could be installed elsewhere.)
+base.and.rec <- .packages(all.available = TRUE, lib = .Library)
+
+set.seed(1)
+if(.Platform$OS.type == "windows") options(pager = "console")
+
+pdf("reg-examples-2.pdf", encoding = "ISOLatin1.enc")
+
+
+## stats
+example(SSasympOrig, run.donttest = TRUE)
+example(SSlogis, run.donttest = TRUE)
+example(constrOptim, run.donttest = TRUE)
+example(cancor, run.donttest = TRUE)
+example(aov, run.donttest = TRUE)
+# signs for promax rotation are arbitrary
+example(factanal, run.donttest = TRUE)
+example(family, run.donttest = TRUE)
+example(fft, run.donttest = TRUE)
+example(glm, run.donttest = ("MASS" %in% base.and.rec))
+example(glm.control, run.donttest = TRUE)
+# from extractAIC
+extractAIC(glm.D93)
+example(influence.measures, run.donttest = TRUE)
+example(lm, run.donttest = TRUE)
+example(ls.diag, run.donttest = TRUE)
+example(model.tables, run.donttest = TRUE)
+example(nlminb, run.donttest = TRUE)
+example(optim, run.donttest = TRUE)
+example(prcomp, run.donttest = TRUE)
+example(step, run.donttest = TRUE)
+example(summary.manova, run.donttest = TRUE)
+example(uniroot, run.donttest = TRUE)
+
+proc.time()
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-examples3.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-examples3.R
new file mode 100644
index 0000000000000000000000000000000000000000..0fcaeb7f1be118e72deed81ccffc1ac72de8311f
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-examples3.R
@@ -0,0 +1,188 @@
+## For examples skipped in testing because they need recommended packages.
+
+## This is skipped entirely on a Unix-alike if recommended packages are,
+## so for Windows
+if(!require("MASS")) q()
+
+pdf("reg-examples-3.pdf", encoding = "ISOLatin1.enc")
+
+## From datasets
+if(require("survival")) {
+ model3 <- clogit(case ~ spontaneous+induced+strata(stratum), data = infert)
+ print(summary(model3))
+ detach("package:survival", unload = TRUE) # survival (conflicts)
+}
+
+
+## From grDevices
+x1 <- matrix(rnorm(1e3), ncol = 2)
+x2 <- matrix(rnorm(1e3, mean = 3, sd = 1.5), ncol = 2)
+x <- rbind(x1, x2)
+
+dcols <- densCols(x)
+graphics::plot(x, col = dcols, pch = 20, main = "n = 1000")
+
+
+## From graphics:
+## A largish data set
+set.seed(123)
+n <- 10000
+x1 <- matrix(rnorm(n), ncol = 2)
+x2 <- matrix(rnorm(n, mean = 3, sd = 1.5), ncol = 2)
+x <- rbind(x1, x2)
+
+oldpar <- par(mfrow = c(2, 2))
+smoothScatter(x, nrpoints = 0)
+smoothScatter(x)
+
+## a different color scheme:
+Lab.palette <- colorRampPalette(c("blue", "orange", "red"), space = "Lab")
+smoothScatter(x, colramp = Lab.palette)
+
+## somewhat similar, using identical smoothing computations,
+## but considerably *less* efficient for really large data:
+plot(x, col = densCols(x), pch = 20)
+
+## use with pairs:
+par(mfrow = c(1, 1))
+y <- matrix(rnorm(40000), ncol = 4) + 3*rnorm(10000)
+y[, c(2,4)] <- -y[, c(2,4)]
+pairs(y, panel = function(...) smoothScatter(..., nrpoints = 0, add = TRUE))
+
+par(oldpar)
+
+
+## From stats
+# alias.Rd
+op <- options(contrasts = c("contr.helmert", "contr.poly"))
+npk.aov <- aov(yield ~ block + N*P*K, npk)
+alias(npk.aov)
+options(op) # reset
+
+# as.hclust.Rd
+if(require("cluster", quietly = TRUE)) {# is a recommended package
+ set.seed(123)
+ x <- matrix(rnorm(30), ncol = 3)
+ hc <- hclust(dist(x), method = "complete")
+ ag <- agnes(x, method = "complete")
+ hcag <- as.hclust(ag)
+ ## The dendrograms order slightly differently:
+ op <- par(mfrow = c(1,2))
+ plot(hc) ; mtext("hclust", side = 1)
+ plot(hcag); mtext("agnes", side = 1)
+ detach("package:cluster")
+}
+
+# confint.Rd
+counts <- c(18,17,15,20,10,20,25,13,12)
+outcome <- gl(3, 1, 9); treatment <- gl(3, 3)
+glm.D93 <- glm(counts ~ outcome + treatment, family = poisson())
+confint(glm.D93)
+confint.default(glm.D93) # based on asymptotic normality}
+
+# contrasts.Rd
+utils::example(factor)
+fff <- ff[, drop = TRUE] # reduce to 5 levels.
+contrasts(fff) <- contr.sum(5)[, 1:2]; contrasts(fff)
+
+## using sparse contrasts: % useful, once model.matrix() works with these :
+ffs <- fff
+contrasts(ffs) <- contr.sum(5, sparse = TRUE)[, 1:2]; contrasts(ffs)
+stopifnot(all.equal(ffs, fff))
+contrasts(ffs) <- contr.sum(5, sparse = TRUE); contrasts(ffs)
+
+# glm.Rd
+utils::data(anorexia, package = "MASS")
+
+anorex.1 <- glm(Postwt ~ Prewt + Treat + offset(Prewt),
+ family = gaussian, data = anorexia)
+summary(anorex.1)
+
+# logLik.Rd
+utils::data(Orthodont, package = "nlme")
+fm1 <- lm(distance ~ Sex * age, Orthodont)
+logLik(fm1)
+logLik(fm1, REML = TRUE)
+
+# nls.Rd
+od <- options(digits=5)
+## The muscle dataset in MASS is from an experiment on muscle
+## contraction on 21 animals. The observed variables are Strip
+## (identifier of muscle), Conc (Cacl concentration) and Length
+## (resulting length of muscle section).
+utils::data(muscle, package = "MASS")
+
+## The non linear model considered is
+## Length = alpha + beta*exp(-Conc/theta) + error
+## where theta is constant but alpha and beta may vary with Strip.
+
+with(muscle, table(Strip)) # 2, 3 or 4 obs per strip
+
+## We first use the plinear algorithm to fit an overall model,
+## ignoring that alpha and beta might vary with Strip.
+
+musc.1 <- nls(Length ~ cbind(1, exp(-Conc/th)), muscle,
+ start = list(th = 1), algorithm = "plinear")
+summary(musc.1)
+
+## Then we use nls' indexing feature for parameters in non-linear
+## models to use the conventional algorithm to fit a model in which
+## alpha and beta vary with Strip. The starting values are provided
+## by the previously fitted model.
+## Note that with indexed parameters, the starting values must be
+## given in a list (with names):
+b <- coef(musc.1)
+musc.2 <- nls(Length ~ a[Strip] + b[Strip]*exp(-Conc/th), muscle,
+ start = list(a = rep(b[2], 21), b = rep(b[3], 21), th = b[1]))
+summary(musc.2)
+options(od)
+
+# princomp.Rd
+## Robust:
+(pc.rob <- princomp(stackloss, covmat = MASS::cov.rob(stackloss)))
+
+# termplot.R
+library(MASS)
+hills.lm <- lm(log(time) ~ log(climb)+log(dist), data = hills)
+termplot(hills.lm, partial.resid = TRUE, smooth = panel.smooth,
+ terms = "log(dist)", main = "Original")
+termplot(hills.lm, transform.x = TRUE,
+ partial.resid = TRUE, smooth = panel.smooth,
+ terms = "log(dist)", main = "Transformed")
+
+# xtabs.Rd
+if(require("Matrix")) {
+ ## similar to "nlme"s 'ergoStool' :
+ d.ergo <- data.frame(Type = paste0("T", rep(1:4, 9*4)),
+ Subj = gl(9, 4, 36*4))
+ print(xtabs(~ Type + Subj, data = d.ergo)) # 4 replicates each
+ set.seed(15) # a subset of cases:
+ print(xtabs(~ Type + Subj, data = d.ergo[sample(36, 10), ], sparse = TRUE))
+
+ ## Hypothetical two-level setup:
+ inner <- factor(sample(letters[1:25], 100, replace = TRUE))
+ inout <- factor(sample(LETTERS[1:5], 25, replace = TRUE))
+ fr <- data.frame(inner = inner, outer = inout[as.integer(inner)])
+ print(xtabs(~ inner + outer, fr, sparse = TRUE))
+}
+
+## From utils
+example(packageDescription)
+
+
+## From splines
+library(splines)
+Matrix::drop0(zapsmall(6*splineDesign(knots = 1:40, x = 4:37, sparse = TRUE)))
+
+
+## From tools
+
+library(tools)
+## there are few dependencies in a vanilla R installation:
+## lattice may not be installed
+## Avoid possibly large list from R_HOME/site-library, which --vanilla includes.
+dependsOnPkgs("lattice", lib.loc = .Library)
+
+## This may not be installed
+gridEx <- system.file("doc", "grid.Rnw", package = "grid")
+vignetteDepends(gridEx)
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-packages.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-packages.R
new file mode 100644
index 0000000000000000000000000000000000000000..73f65c62a53032f375969ca2ed1ce882f4a3643c
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-packages.R
@@ -0,0 +1,179 @@
+## PR 1271 detach("package:base") crashes R.
+tools::assertError(detach("package:base"))
+
+
+## invalid 'lib.loc'
+stopifnot(length(installed.packages("mgcv")) == 0)
+## gave a low-level error message
+
+
+## package.skeleton() with metadata-only code
+## work in current (= ./tests/ directory):
+tmp <- tempfile()
+writeLines(c('setClass("foo", contains="numeric")',
+ 'setMethod("show", "foo",',
+ ' function(object) cat("I am a \\"foo\\"\\n"))'),
+ tmp)
+if(file.exists("myTst")) unlink("myTst", recursive=TRUE)
+package.skeleton("myTst", code_files = tmp)# with a file name warning
+file.copy(tmp, (tm2 <- paste(tmp,".R", sep="")))
+unlink("myTst", recursive=TRUE)
+op <- options(warn=2) # *NO* "invalid file name" warning {failed in 2.7.[01]}:
+package.skeleton("myTst", code_files = tm2)
+options(op)
+##_2_ only a class, no generics/methods:
+writeLines(c('setClass("DocLink",',
+ 'representation(name="character",',
+ ' desc="character"))'), tmp)
+if(file.exists("myTst2")) unlink("myTst2", recursive=TRUE)
+package.skeleton("myTst2", code_files = tmp)
+##- end_2_ # failed in R 2.11.0
+stopifnot(1 == grep("setClass",
+ readLines(list.files("myTst/R", full.names=TRUE))),
+ c("foo-class.Rd","show-methods.Rd") %in% list.files("myTst/man"))
+## failed for several reasons in R < 2.7.0
+##
+## Part 2: -- build, install, load and "inspect" the package:
+build.pkg <- function(dir) {
+ stopifnot(dir.exists(dir))
+ patt <- paste(basename(dir), ".*tar\\.gz$", sep="_")
+ unlink(dir('.', pattern = patt))
+ Rcmd <- paste(file.path(R.home("bin"), "R"), "CMD")
+ r <- tail(system(paste(Rcmd, "build --keep-empty-dirs", shQuote(dir)),
+ intern = TRUE), 3)
+ ## return name of tar file built
+ dir('.', pattern = patt)
+}
+build.pkg("myTst")
+## clean up any previous attempt (which might have left a 00LOCK)
+unlink("myLib", recursive = TRUE)
+dir.create("myLib")
+install.packages("myTst", lib = "myLib", repos=NULL, type = "source") # with warnings
+print(installed.packages(lib.loc= "myLib", priority= "NA"))## (PR#13332)
+stopifnot(require("myTst",lib = "myLib"))
+sm <- findMethods(show, where= as.environment("package:myTst"))
+stopifnot(names(sm@names) == "foo")
+unlink("myTst_*")
+
+## getPackageName() for "package:foo":
+require('methods')
+library(tools)
+oo <- options(warn=2)
+detach("package:tools", unload=TRUE)
+options(oo)
+## gave warning (-> Error) about creating package name
+
+## --- keep this at end --- so we do not need a large if(.) { .. }
+## More building & installing packages
+## NB: tests were added here for 2.11.0.
+## NB^2: do not do this in the R sources (but in a build != src directory!)
+## and this testdir is not installed.
+if(interactive() && Sys.getenv("USER") == "maechler")
+ Sys.setenv(SRCDIR = normalizePath("~/R/D/r-devel/R/tests"))
+(pkgSrcPath <- file.path(Sys.getenv("SRCDIR"), "Pkgs"))# e.g., -> "../../R/tests/Pkgs"
+if(!file_test("-d", pkgSrcPath) && !interactive()) {
+ unlink("myTst", recursive=TRUE)
+ print(proc.time())
+ q("no")
+}
+## else w/o clause:
+
+do.cleanup <- !nzchar(Sys.getenv("R_TESTS_NO_CLEAN"))
+has.symlink <- (.Platform$OS.type != "windows")
+## Installing "on to" a package existing as symlink in the lib.loc
+## -- used to fail with misleading error message (#PR 16725):
+if(has.symlink && dir.create("myLib_2") &&
+ file.rename("myLib/myTst", "myLib_2/myTst") &&
+ file.symlink("../myLib_2/myTst", "myLib/myTst"))
+ install.packages("myTst", lib = "myLib", repos=NULL, type = "source")
+## In R <= 3.3.2 gave error with *misleading* error message:
+## ERROR: ‘myTst’ is not a legal package name
+
+
+## file.copy(pkgSrcPath, tempdir(), recursive = TRUE) - not ok: replaces symlink by copy
+system(paste('cp -R', shQuote(pkgSrcPath), shQuote(tempdir())))
+pkgPath <- file.path(tempdir(), "Pkgs")
+## pkgB tests an empty R directory
+dir.create(file.path(pkgPath, "pkgB", "R"), recursive = TRUE,
+ showWarnings = FALSE)
+p.lis <- if("Matrix" %in% row.names(installed.packages(.Library)))
+ c("pkgA", "pkgB", "exNSS4") else "exNSS4"
+pkgApath <- file.path(pkgPath, "pkgA")
+if("pkgA" %in% p.lis && !dir.exists(d <- pkgApath)) {
+ cat("symlink 'pkgA' does not exist as directory ",d,"; copying it\n", sep='')
+ file.copy(file.path(pkgPath, "xDir", "pkg"), to = d, recursive=TRUE)
+ ## if even the copy failed (NB: pkgB depends on pkgA)
+ if(!dir.exists(d)) p.lis <- p.lis[!(p.lis %in% c("pkgA", "pkgB"))]
+}
+for(p. in p.lis) {
+ cat("building package", p., "...\n")
+ r <- build.pkg(file.path(pkgPath, p.))
+ cat("installing package", p., "using file", r, "...\n")
+ ## we could install the tar file ... (see build.pkg()'s definition)
+ install.packages(r, lib = "myLib", repos=NULL, type = "source")
+ stopifnot(require(p.,lib = "myLib", character.only=TRUE))
+ detach(pos = match(p., sub("^package:","", search())))
+}
+(res <- installed.packages(lib.loc = "myLib", priority = "NA"))
+stopifnot(identical(res[,"Package"], setNames(,sort(c(p.lis, "myTst")))),
+ res[,"LibPath"] == "myLib")
+### Specific Tests on our "special" packages: ------------------------------
+
+## These used to fail because of the sym.link in pkgA
+if("pkgA" %in% p.lis && dir.exists(pkgApath)) {
+ cat("undoc(pkgA):\n"); print(uA <- tools::undoc(dir = pkgApath))
+ cat("codoc(pkgA):\n"); print(cA <- tools::codoc(dir = pkgApath))
+ stopifnot(identical(uA$`code objects`, c("nil", "search")),
+ identical(uA$`data sets`, "nilData"))
+}
+
+## - Check conflict message.
+## - Find objects which are NULL via "::" -- not to be expected often
+## we have one in our pkgA, but only if Matrix is present.
+if(dir.exists(file.path("myLib", "pkgA"))) {
+ msgs <- capture.output(require(pkgA, lib="myLib"), type = "message")
+ writeLines(msgs)
+ stopifnot(length(msgs) > 2,
+ length(grep("The following object is masked.*package:base", msgs)) > 0,
+ length(grep("\\bsearch\\b", msgs)) > 0)
+ data(package = "pkgA") # -> nilData
+ stopifnot(is.null( pkgA:: nil),
+ is.null( pkgA::: nil),
+ is.null( pkgA:: nilData)) # <-
+ ## R-devel (pre 3.2.0) wrongly errored for NULL lazy data
+ ## ::: does not apply to data sets:
+ tools::assertError(is.null(pkgA:::nilData))
+}
+
+## tests here should *NOT* assume recommended packages,
+## let alone where they are installed
+if(dir.exists(file.path("myLib", "exNSS4")) &&
+ dir.exists(file.path(.Library, "Matrix"))) {
+ for(ns in c(rev(p.lis), "Matrix")) unloadNamespace(ns)
+ ## Both exNSS4 and Matrix define "atomicVector" *the same*,
+ ## but 'exNSS4' has it extended - and hence *both* are registered in cache -> "conflicts"
+ requireNamespace("exNSS4", lib= "myLib")
+ ## Found in cache, since there is only one definition.
+ ## Might confuse users.
+ stopifnot(isVirtualClass(getClass("atomicVector")))
+ requireNamespace("Matrix", lib= .Library)
+ ## Throws an error, because there is ambiguity in the cache,
+ ## and the dynamic search will not find anything, since the packages
+ ## are not attached.
+ tools::assertCondition(
+ acl <- getClass("atomicVector")
+ )
+ ## Once Matrix is attached, we find a unique definition.
+ library(Matrix)
+ stopifnot(isVirtualClass(getClass("atomicVector")))
+}
+
+## clean up
+rmL <- c("myLib", if(has.symlink) "myLib_2", "myTst", file.path(pkgPath))
+if(do.cleanup) {
+ for(nm in rmL) unlink(nm, recursive = TRUE)
+} else {
+ cat("Not cleaning, i.e., keeping ", paste(rmL, collapse=", "), "\n")
+}
+
+proc.time()
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-plot-latin1.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-plot-latin1.R
new file mode 100644
index 0000000000000000000000000000000000000000..6d990d634d1e030f8de136e8fb6117fb64318040
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-plot-latin1.R
@@ -0,0 +1,5 @@
+pdf(file = "reg-plot-latin1.pdf", encoding = "ISOLatin1",
+ width = 7, height = 7, paper = "a4r", compress = FALSE)
+library(graphics) # to be sure
+example(text) # has examples that need to he plotted in latin-1
+q("no")
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-plot.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-plot.R
new file mode 100644
index 0000000000000000000000000000000000000000..e567e3cfc7f09ed0f7da5b41ff2107cb11cfba41
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-plot.R
@@ -0,0 +1,160 @@
+#### Regression tests for GRAPHICS & PLOTS
+
+pdf("reg-plot.pdf", paper="a4r", encoding ="ISOLatin1.enc", compress = FALSE)
+
+## since we supply the font metrics, the results depend only on
+## the encoding used: Windows is different from Unix by default.
+
+options(warn = 1) # print as they occur
+
+plot(0) # this should remain constant
+str(par(c("usr","xaxp","yaxp")))
+stopifnot(all.equal(
+ par(c("usr","xaxp","yaxp"))
+ ,
+ list(usr = c(0.568, 1.432, -1.08, 1.08),
+ xaxp = c(0.6, 1.4, 4), yaxp = c(-1, 1, 4))))
+
+
+### Test for centring of chars. All the chars which are plotted should
+### be centred, and there should be no warnings about
+### font metrics unknown for character `?'
+
+par(pty="s")
+plot(c(-1,16), c(-1,16), type="n", xlab="", ylab="", xaxs="i", yaxs="i")
+title("Centred chars in default char set (ISO Latin1)")
+grid(17, 17, lty=1)
+known <- c(32:126, 160:255)
+
+for(i in known) {
+ x <- i %% 16
+ y <- i %/% 16
+ points(x, y, pch=-i)
+}
+
+par(pty="m")
+
+## PR 816 (label sizes in dotchart)
+
+### Prior to 1.2.2, the label sizes were unaffected by cex.
+
+dotchart(VADeaths, main = "Death Rates in Virginia - 1940", cex = 0.5)
+dotchart(VADeaths, main = "Death Rates in Virginia - 1940", cex = 1.5)
+
+## killed by 0 prior to 1.4.0 and in 1.4.1:
+t1 <- ts(0:100)
+## only warnings about values <= 0
+plot(t1, log = "y")
+plot(cbind(t1, 10*t1, t1 - 4), log="y", plot.type = "single")
+stopifnot(par("usr")[4] > 3) # log10: ylim[2] = 1000
+
+
+## This one needs to be looked at.
+## lty = "blank" killed the fill colour too.
+plot(1:10, type="n")
+polygon(c(1, 3, 3, 1), c(1, 1, 3, 3), col="yellow", border="red", lty="blank")
+rect(6, 6, 10, 10, col="blue", border="red", lty="blank")
+## in 1.5.0 all omit the fill colours.
+with(trees, symbols(Height, Volume, circles=Girth/24, inches=FALSE,
+ lty="blank", bg="blue"))
+## in 1.5.0 ignored the lty.
+
+## axis() and par(mgp < 0) {keep this example S+ compatible!}:
+lt <- if(is.R()) "31" else 2
+x <- seq(-2,3, len=1001)
+op <- par(tck= +0.02, mgp = -c(3,2,0))
+plot(x, x^2 - 1.2, xaxt = "n", xlab="", type ='l', col = 2,
+ main = "mgp < 0: all ticks and labels inside `frame'")
+x <- -2:3
+lines(x, x^2 - 1.2, type ="h", col = 3, lwd=3)
+axis(1, pos = 0, at=-1:1, lty = lt, col=4)## col & lty work only from R 1.6
+par(op)
+axis(1, pos = 0, at=c(-2,2,3), lty = lt, col=4)
+mtext(side=1,"note the x-ticks on the other side of the bars")
+
+## plot.table(): explicit xlab and ylab for non-1D
+plot(UCBAdmissions)# default x- and y-lab
+plot(UCBAdmissions, xlab = "x label", ylab = "YY")# wrong in 1.5.1
+## axis suppression
+plot(tt <- table(c(rep(0,7), rep(1,4), rep(5, 3))), axes = FALSE)
+plot(tt, xaxt = "n")
+## wrong till (incl.) 1.6.x
+
+## legend with call
+lo <- legend(2,2, substitute(hat(theta) == that, list(that= pi)))
+stopifnot(length(lo$text$x) == 1)
+## length() was 3 till 1.7.x
+
+plot(ecdf(c(1:4,8,12)), ylab = "ECDF", main=NULL)
+## ylab didn't work till 1.8.0
+
+plot(1:10, pch = NA) # gave error till 1.9.0
+points(1:3, pch=c("o",NA,"x"))# used "N"
+try(points(4, pch=c(NA,FALSE)))# still give an error
+
+## 'lwd' should transfer to plot symbols
+legend(1,10, c("A","bcd"), lwd = 2:3, pch= 21:22, pt.bg="skyblue",
+ col = 2:3, bg = "thistle")
+## (gave an error for 2 days in "2.0.0 unstable")
+
+x <- 2^seq(1,1001, length=20)
+plot(x, x^0.9, type="l", log="xy")
+## gave error 'Infinite axis extents [GEPretty(1.87013e-12,inf,5)]' for R 2.0.1
+
+plot(as.Date("2001/1/1") + 12*(1:9), 1:9)
+## used bad 'xlab/ylab' in some versions of R 2.2.0(unstable)
+
+## dotchart() restoring par()
+Opar <- par(no.readonly=TRUE) ; dotchart(1:4, cex= 0.7)
+Npar <- par(no.readonly=TRUE)
+ii <- c(37, 50:51, 58:59, 63)
+stopifnot(identical(names(Opar)[ii],
+ c("mai","pin","plt","usr","xaxp","yaxp")),
+ identical(Opar[-ii], Npar[-ii]))
+## did not correctly restore par("mar") up to (incl) R 2.4.0
+
+## plot.function() [n=11, ... : since we store and diff PS file !]
+plot(cos, xlim=c(-5,5), n=11, axes=FALSE); abline(v=0)
+## did *not* plot for negative x up to R 2.5.1
+plot(sin, -2,3, xlim=c(-5,5), n=11, axes=FALSE, xlab="")# plot from -2
+axis(1, at=c(-2,3), tcl=-1); axis(1, at=c(-5,5))
+## (from,to) & xlim should work simultaneously
+
+plot(cos, -7,7, n=11, axes=FALSE)
+## gave wrong ylab in R 2.6.0
+plot(cos, -7,7, ylab = "Cosine cos(x)", n=11, axes=FALSE)
+## partial matching of 'ylab'; mapping [0,1] (not [-7.7]):
+## margins chosen to avoid rouding error showing to 2dp.
+op <- par(mar=c(5,4.123,4,2)+0.1)
+plot(gamma, yla = expression(Gamma(x)), n=11, yaxt="n")
+par(op)
+
+## plot.ts(x, y) could get the labels wrong in R <= 2.6.0:
+x <- ts(1:5);x1 <- lag(x, 2); plot(x1, x, axes=FALSE)
+
+# adding a curve in log scale :
+curve(5*exp(-x), 0.1, 100, n = 3, log="x", ylab="", axes=FALSE)
+curve(5*exp(-x), add=TRUE, n = 3, col=2,lwd=3)
+## should fully overplot; wrong default xlim in 2.6.1
+## (and *slightly* wrong up to 2.6.0)
+
+## Axis() calls via plot() {[xy]axt to keep *.ps small}
+x <- as.Date("2008-04-22 09:45") + (i <- c(0,4))
+plot(x, xaxt="n")# not ok in 2.6.2, nor 2.7.0
+plot(x, i, yaxt="n")# ok in 2.6.2 and 2.7.0
+plot(i, x, xaxt="n")# ok in 2.6.2 and not in 2.7.0
+
+## table methods should be bypassed:
+dotchart(table(infert$education))
+## failed in 2.12.[12]
+
+## cex as "..." in "high level" function
+hc <- hclust(dst <- dist(c(1:2, 5)), method="ave")
+plot(hc, cex = 2, axes=FALSE, ann=FALSE)
+## cex was not used in 3.0.[01]
+
+## axis.Date() and axis.POSIXct() with reversed 'xlim'
+toD <- as.Date("2016-08-19"); dates <- c(toD - 10, toD)
+plot(dates, 1:2, xlim = rev(dates),
+ ann=FALSE, yaxt="n", frame.plot=FALSE)
+## failed to label the dates in R <= 3.3.1
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-1a.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-1a.R
new file mode 100644
index 0000000000000000000000000000000000000000..0a886b2a60b54e8b704cae13bcd75f681c1dc131
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-1a.R
@@ -0,0 +1,4854 @@
+## Up to PR#9999 for R < 3.0.0
+
+pdf("reg-tests-1a.pdf", encoding = "ISOLatin1.enc")
+
+## force standard handling for data frames
+options(stringsAsFactors=TRUE)
+## .Machine
+(Meps <- .Machine$double.eps)# and use it in this file
+## Facilitate diagnosing of testing startup:
+envLst <- c(t(outer(c("R_ENVIRON","R_PROFILE"), c("","_USER"), paste0)),
+ "R_CHECK_ENVIRON","R_LIBS")
+cbind(Sys.getenv(envLst))
+.libPaths()
+
+assertError <- tools::assertError
+
+## 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
+
+
+## array
+# funny object, but whatever was the point of that?
+utils::str(array(1:3, 0))
+## end of moved from array.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
+
+
+## axis
+Y <- c(10.50, 4.0, 13.75, 7.25)
+plot(1:4, Y, xlim=c(0,5), ylim=c(0,15))
+axis(side=4, at=Y, labels=LETTERS[1:4])
+## end of moved from axis.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* Meps)
+
+## check with pivoting
+( m <- matrix(c(5,1,1,3),2,2) )
+( cm <- chol(m, TRUE) )
+stopifnot(abs(m - t(cm) %*% cm) < 100* Meps)
+
+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)))
+## 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
+
+
+## colnames
+m0 <- matrix(NA, 4, 0)
+rownames(m0, do.NULL = FALSE)
+colnames(m0, do.NULL = FALSE)
+## end of moved from colnames.Rd
+
+
+## Constants
+stopifnot(
+ nchar(letters) == 1,
+ month.abb == substr(month.name, 1, 3)
+)
+
+stopifnot(all.equal(pi, 4*atan(1), tol= 2*Meps))
+
+# John Machin (1705) computed 100 decimals of pi :
+stopifnot(all.equal(pi/4, 4*atan(1/5) - atan(1/239), 4*Meps))
+## 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
+## Spearman correlations ranked missing values at end <= 1.8.1
+X <- cbind(c(1,3,4,NA),c(1,4,2,NA))
+X1 <- X[-4,]
+stopifnot(all.equal(cor(X,X,method="spearman",use="complete"),
+ cor(X1,X1,method="spearman",use="complete")))
+stopifnot(all.equal(cov(X,X,method="spearman",use="complete"),
+ cov(X1,X1,method="spearman",use="complete")))
+
+## DateTimeClasses
+(dls <- .leap.seconds[-1] - .leap.seconds[-length(.leap.seconds)])
+table(dls)
+stopifnot(sum(dls == 365) >= 11)
+## 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)]))
+
+stopifnot(duplicated(iris)[143] == TRUE)
+## end of moved from duplicated.Rd
+
+
+## eigen
+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]) < 100 * Meps) # comparing two solns
+
+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
+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)
+stopifnot(it[c(1,203)] == c(0, 100),
+ all.equal(N * stats::ecdf(X)(tt),
+ findInterval(tt, X), tol = 100 * Meps),
+ findInterval(tt,X) == apply( outer(tt, X, ">="), 1, sum)
+ )
+## end of moved from findint.Rd
+## NA & Inf's :
+tt[ina <- c(2,3,5,7)] <- NA
+tt[300] <- Inf
+X <- c(-Inf, X, Inf)
+it <- findInterval(tt,X)
+stopifnot(identical(it, as.integer(rowSums(outer(tt, X, ">=")))),
+ is.na(it[ina]))
+
+
+## fix
+oo <- options(editor="touch") # not really changing anything
+fix(pi)
+if(!is.numeric(pi) || length(pi)!=1 ||
+ !is.null(attributes(pi)) || abs(pi - 3.1415) > 1e-4)
+ stop("OOPS: fix() is broken ...")
+rm(pi); options(oo)
+## end of moved from fix.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(2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
+2L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L,
+3L), .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 = 1: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
+x <- seq(-3, 3, len=200)
+stopifnot(
+ abs(cosh(x) - (exp(x) + exp(-x))/2) < 20*Meps,
+ abs(sinh(x) - (exp(x) - exp(-x))/2) < 20*Meps,
+ abs(tanh(x)*cosh(x) - sinh(x)) < 20*Meps
+)
+
+stopifnot(abs(asinh(sinh(x)) - x) < 20*Meps)
+stopifnot(abs(acosh(cosh(x)) - abs(x)) < 1000*Meps) #- imprecise for small x
+stopifnot(abs(atanh(tanh(x)) - x) < 100*Meps)
+
+stopifnot(abs(asinh(x) - log(x + sqrt(x^2 + 1))) < 100*Meps)
+cx <- cosh(x)
+stopifnot(abs(acosh(cx) - log(cx + sqrt(cx^2 - 1))) < 1000*Meps)
+## 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))
+)
+assertError(is.nan(list(1,NaN,NA))) #-> result allowed but varies 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
+
+
+## list
+str(pl <- as.pairlist(ps.options()))
+
+## These are all TRUE:
+stopifnot(is.list(pl) && is.pairlist(pl),
+ !is.null(list()),
+ is.null(pairlist()),
+ !is.list(NULL),
+ is.pairlist(pairlist()),
+ is.null(as.pairlist(list())),
+ is.null(as.pairlist(NULL))
+ )
+## end of moved from list.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* Meps)
+stopifnot(Mod(1+exp(pi*1i)) < 10* Meps)
+## end of moved from Log.Rd
+
+
+## logistic
+eps <- 100 * Meps
+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 * Meps * 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(all.equal(sum(px), 1))
+}
+## end of moved from Multinom.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
+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*Meps)
+
+dim(Qc <- qr.Q(qrstr, complete=TRUE)) # Square: dim(Qc) == rep(nrow(x),2)
+stopifnot((crossprod(Qc) - diag(nrow(x))) < 10*Meps)
+
+QD <- qr.Q(qrstr, D=1:p) # QD == Q \%*\% diag(1:p)
+stopifnot(QD - Q %*% diag(1:p) < 8* Meps)
+
+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*Meps)
+## end of moved from quantile.Rd
+
+
+## rep
+stopifnot(identical(rep(letters, 0), character(0)),
+ identical(rep.int(1:2, 0), integer(0)))
+
+stopifnot(sum(1:8) == length(rep(1:4, 1:8, each=2)))
+## 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
+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 * Meps
+
+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
+
+
+## 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 * Meps)
+stopifnot(abs(atan2(y, x) - atan(y/x)) < 10 * Meps)
+
+x <- 1:99/100
+stopifnot(Mod(1 - (cos(x) + 1i*sin(x)) / exp(1i*x)) < 10 * Meps)
+## error is about 650* at x=0.01:
+stopifnot(abs(1 - x / acos(cos(x))) < 1000 * Meps)
+stopifnot(abs(1 - x / asin(sin(x))) <= 10 * Meps)
+stopifnot(abs(1 - x / atan(tan(x))) <= 10 *Meps)
+## 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)) }
+
+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 * Meps)
+## end of moved from Wilcoxon.Rd
+
+
+## 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))
+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)
+##
+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(all.equal(a1, a2))
+## Comments:
+# both should be 236.9645
+# changed to use all.equal rather than == in 2.1.0 -pd
+
+## 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.
+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.txt", 1:10, sep="\n")
+x <- try(readLines("foo.txt", 100, ok=FALSE))
+unlink("foo.txt")
+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(y ~ z * I(x), data=DF))
+dummy.coef(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.
+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))
+
+
+## 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)
+## 2.0.0: La.eigen is defunct
+
+
+## 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
+
+
+## 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)) # 2.0.0: La.eigen is defunct
+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#1283 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
+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)
+
+## 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:
+Fn <- ecdf(rnorm(50))
+ls.str(envir = environment(Fn))
+## 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
+## NA+0 is not guaranteed to be NA: could be NaN
+
+
+## identical on specials (BDR 2002-08-02)
+stopifnot(identical(as.double(NA), NaN) == FALSE)
+## was identical on 1.5.1
+
+
+## safe prediction (PR#1840)
+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(1L, 1L,
+1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L,
+3L, 3L, 3L, 3L, 3L, 3L), .Label = c("1", "2", "3"), class = "factor"),
+ AAAAAAAA = structure(c(1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 1L,
+ 1L, 1L, 1L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L
+ ), .Label = c("E1", "E2"), class = "factor"), B2 = structure(c(1L,
+ 1L, 2L, 2L, 1L, 1L, 2L, 2L, 1L, 1L, 2L, 2L, 1L, 1L, 2L, 2L,
+ 1L, 1L, 2L, 2L, 1L, 1L, 2L, 2L), .Label = c("Red", "Unred"
+ ), class = "factor"), C2 = structure(c(1L, 2L, 1L, 2L, 1L,
+ 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L, 1L, 2L,
+ 1L, 2L, 1L, 2L), .Label = c("Agent", "Patient"), class = "factor")),
+ .Names = c("Y2", "P2", "AAAAAAAA", "B2", "C2"),
+ class = "data.frame", row.names = 1: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)
+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
+
+
+## Formerly undocumented line limit in system(intern=TRUE)
+## Naoki Takebayashi <ntakebay@bio.indiana.edu> 2002-12-07
+tmp <- tempfile()
+long <- paste(rep("0123456789", 20L), collapse="")
+cat(long, "\n", sep="", file=tmp)
+junk <- system(paste("cat", shQuote(tmp)), intern = TRUE)
+stopifnot(length(junk) == 1L, nchar(junk[1]) == 200L)
+## 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 Mac OS 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))
+close(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
+
+plot(sf <- stepfun(2, 3:4))
+## 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"))
+##
+
+
+## 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)
+im1 <- influence.measures(mod)
+stopifnot(all.equal(unname(im1$infmat[,1:6]), unname(dfbetas(mod))))
+
+## 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)) { # 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])
+ )
+ detach("package:cluster")
+}
+## 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#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))
+## gave vector in 1.7.0
+
+
+## [[<-.data.frame
+testdata <- data.frame(a=1:2, b = c(TRUE, NA))
+td <- strptime(c("31121991", "31121992"), "%d%m%Y")
+testdata[["a"]] <- td
+if(FALSE)
+stopifnot(inherits(.Last.value, "try-error"))
+## succeeded in 1.7.0 and again in 2.11.x {should it not?}
+
+
+## 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 <- NA_character_
+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",""))))
+a9 <- strsplit(a, "NA", fixed = TRUE)
+stopifnot(identical(a9, list("", na ,c("BA",""))))
+a9 <- strsplit(a, "NA", perl = TRUE)
+stopifnot(identical(a9, list("", na ,c("BA",""))))
+a10 <- strsplit(a, na)
+stopifnot(identical(a10, as.list(a)))
+## nchar() differs a bit
+stopifnot(identical(is.na(a), is.na(nchar(a))),
+ all(!is.na(nchar(a, type = "width"))))
+## 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",
+ "NA_integer_", "NA_real_", "NA_complex_", "NA_character_")) {
+ 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)))
+x <- 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
+m <- cbind(1, c(1, 1))
+stopifnot(det(m) == 0, determinant(m)$mod == -Inf,
+ determinant(m, log=FALSE)$mod == 0)
+## gave error for singular matrices in earlier Aug.2003
+
+
+## tests of model fitting in the presence of non-syntactic names
+names(swiss)[6] <- "Infant Mortality"
+(lm1 <- lm(Fertility ~ ., data = swiss))
+formula(lm1) # is expanded out
+slm1 <- step(lm1)
+add1(lm1, ~ I(Education^2) + .^2)
+step(lm1, scope=~ I(Education^2) + .^2)
+
+Quine <- structure(list(Eth = structure(c(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, 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, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 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, 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, 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), .Label = c("A", "N"), class = "factor"),
+ Sex = 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, 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, 1, 1, 1, 1, 1, 1, 1, 1, 1, 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, 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, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1), .Label = c("F",
+ "M"), class = "factor"), Age = structure(c(1, 1, 1, 1, 1,
+ 1, 1, 1, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+ 4, 4, 4, 4, 4, 4, 4, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4,
+ 4, 4, 4, 4, 4, 4, 4, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4,
+ 4, 4, 4, 4, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4,
+ 4, 4, 4, 4, 4, 4, 4, 4), .Label = c("F0", "F1", "F2", "F3"
+ ), class = "factor"), Lrn = structure(c(2, 2, 2, 1, 1, 1,
+ 1, 1, 2, 2, 2, 1, 1, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 2, 2, 2, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2,
+ 2, 2, 2, 1, 1, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 2, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1), .Label = c("AL", "SL"), class = "factor"),
+ Days = c(2, 11, 14, 5, 5, 13, 20, 22, 6, 6, 15, 7, 14, 6,
+ 32, 53, 57, 14, 16, 16, 17, 40, 43, 46, 8, 23, 23, 28, 34,
+ 36, 38, 3, 5, 11, 24, 45, 5, 6, 6, 9, 13, 23, 25, 32, 53,
+ 54, 5, 5, 11, 17, 19, 8, 13, 14, 20, 47, 48, 60, 81, 2, 0,
+ 2, 3, 5, 10, 14, 21, 36, 40, 6, 17, 67, 0, 0, 2, 7, 11, 12,
+ 0, 0, 5, 5, 5, 11, 17, 3, 4, 22, 30, 36, 8, 0, 1, 5, 7, 16,
+ 27, 0, 30, 10, 14, 27, 41, 69, 25, 10, 11, 20, 33, 5, 7,
+ 0, 1, 5, 5, 5, 5, 7, 11, 15, 5, 14, 6, 6, 7, 28, 0, 5, 14,
+ 2, 2, 3, 8, 10, 12, 1, 1, 9, 22, 3, 3, 5, 15, 18, 22, 37)),
+ .Names = c("Eth", "Sex", "Age", "Slow or fast", "Days"),
+ class = "data.frame", row.names = 1:46)
+step(aov(log(Days+2.5) ~ .^4, data=Quine))
+set.seed(11)
+DF <- data.frame(y=rnorm(21), `x 1`=-10:10., check.names = FALSE)
+lm(y ~ ., data = DF)
+(fm <- lm(y ~ `x 1` + I(`x 1`^2), data = DF))
+step(fm)
+
+N <- c(0,1,0,1,1,1,0,0,0,1,1,0,1,1,0,0,1,0,1,0,1,1,0,0)
+P <- c(1,1,0,0,0,1,0,1,1,1,0,0,0,1,0,1,1,0,0,1,0,1,1,0)
+K <- c(1,0,0,1,0,1,1,0,0,1,0,1,0,1,1,0,0,0,1,1,1,0,1,0)
+yield <- c(49.5,62.8,46.8,57.0,59.8,58.5,55.5,56.0,62.8,55.8,69.5,55.0,
+ 62.0,48.8,45.5,44.2,52.0,51.5,49.8,48.8,57.2,59.0,53.2,56.0)
+npk <- data.frame(`block no`=gl(6,4), N=factor(N), P=factor(P),
+ K=factor(K), yield=yield, check.names=FALSE)
+op <- options(contrasts=c("contr.helmert", "contr.treatment"))
+(npk.aovE <- aov(yield ~ N*P*K + Error(`block no`), npk))
+summary(npk.aovE)
+model.tables(npk.aovE)
+model.tables(npk.aovE, "means")
+options(op)# reset to previous
+## Didn't work before 1.8.0
+
+
+## cmdscale
+## failed in versions <= 1.4.0 :
+cm1 <- cmdscale(eurodist, k=1, add=TRUE, x.ret = TRUE)
+cmdsE <- cmdscale(eurodist, k=20, add = TRUE, eig = TRUE, x.ret = TRUE)
+# FAILED on Debian testing just prior to 1.9.0!
+#stopifnot(identical(cm1$x, cmdsE$x),
+# identical(cm1$ac, cmdsE$ac))
+stopifnot(all.equal(cm1$x, cmdsE$x),
+ all.equal(cm1$ac, cmdsE$ac))
+## end of moved from cmdscale.Rd
+
+
+## cutree
+hc <- hclust(dist(USArrests))
+ct <- cutree(hc, h = c(0, hc$height[c(1,49)], 1000))
+stopifnot(ct[,"0"]== 1:50,
+ unique(ct[,2]) == 1:49,
+ ct[,3] == ct[,4],
+ ct[,4] == 1)
+## end of moved from cutree.Rd
+
+
+## princomp
+USArrests[1, 2] <- NA
+pc.cr <- princomp(~ Murder + Assault + UrbanPop,
+ data = USArrests, na.action=na.exclude, cor = TRUE)
+update(pc.cr, ~ . + Rape)
+## end of moved from princomp.Rd
+
+
+## arima{0}
+(fit <- arima(lh, c(1,0,0)))
+tsdiag(fit)
+(fit <- arima0(lh, c(1,0,0)))
+tsdiag(fit)
+## end of moved from arima{0}.Rd
+
+
+## predict.arima
+predict(arima(lh, order=c(1,0,1)), n.ahead=5)
+predict(arima(lh, order=c(1,1,0)), n.ahead=5)
+predict(arima(lh, order=c(0,2,1)), n.ahead=5)
+## end of moved from predict.arima.Rd
+
+
+library(splines)
+## ns
+## Consistency:
+x <- c(1:3,5:6)
+stopifnot(identical(ns(x), ns(x, df = 1)),
+ !is.null(kk <- attr(ns(x), "knots")),# not true till 1.5.1
+ length(kk) == 0)
+## end of moved from ns.Rd
+
+
+## predict.bs
+## Consistency:
+basis <- ns(women$height, df = 5)
+newX <- seq(58, 72, len = 51)
+wh <- women$height
+bbase <- bs(wh)
+nbase <- ns(wh)
+stopifnot(identical(predict(basis), predict(basis, newx=wh)),
+ identical(predict(bbase), predict(bbase, newx=wh)),
+ identical(predict(nbase), predict(nbase, newx=wh)))
+## end of moved from predict.bs.Rd
+
+
+## internal coerceVector() was too lenient
+plot(1)
+r <- try(strwidth(plot))## Error: cannot coerce
+stopifnot(inherits(r, "try-error"),
+ grep("cannot coerce", r) == 1)
+## gave seg.fault or memory allocation error before 1.8.0
+
+
+## rank sometimes kept and sometimes dropped names
+x2 <- c(3, 1, 4, 1, 5, NA, 9, 2, 6, 5, 3, 5)
+names(x2) <- letters[1:12]
+(y1 <- rank(x2))
+(y2 <- rank(x2, na.last=FALSE))
+(y3 <- rank(x2, na.last=NA))
+(y4 <- rank(x2, na.last="keep"))
+stopifnot(identical(names(y1), names(x2)),
+ identical(names(y2), names(x2)),
+ identical(names(y4), names(x2)),
+ identical(names(y3), names(x2)[-6]))
+##
+
+## as.dist(x) only obeyed `diag=TRUE' or `upper=TRUE' when x was "dist" already
+m <- as.matrix(dist(matrix(rnorm(100), nrow=5)))
+stopifnot(identical(TRUE, attr(as.dist(m, diag=TRUE), "Diag")))
+## failed previous to 1.8.0
+
+stopifnot(1:2 == ave(1:2,factor(2:3,levels=1:3)))
+## gave "2 NA" previous to 1.8.0, because unused levels weren't dropped
+
+
+## PR#4092: arrays with length(dim(.)) = 1
+z <- array(c(-2:1, 1.4),5)
+cz <- crossprod(as.vector(z))
+dimnames(z) <- list(letters[1:5])
+z0 <- z
+names(dimnames(z)) <- "D1"
+stopifnot(crossprod(z) == cz,# the first has NULL dimnames
+ identical(crossprod(z), crossprod(z0)),
+ identical(crossprod(z), crossprod(z,z0)))
+## crossprod(z) segfaulted (or gave silly error message) before 1.8.0
+
+
+## PR#4431
+stopifnot(!is.na(rmultinom(12,100, c(3, 4, 2, 0,0))))
+## 3rd line was all NA before 1.8.0
+
+
+## PR#4275: getAnywhere with extra "."
+g0 <- getAnywhere("predict.loess")
+g1 <- getAnywhere("as.dendrogram.hclust")
+g2 <- getAnywhere("predict.smooth.spline")
+g3 <- getAnywhere("print.data.frame")
+is.S3meth <- function(ga) any(substr(ga$where, 1,20) == "registered S3 method")
+stopifnot(is.S3meth(g0), is.S3meth(g1),
+ is.S3meth(g2), is.S3meth(g3))
+## all but g0 failed until 1.8.0 (Oct 6)
+
+
+## symnum(x) for length 0 and some logical arrays:
+sm <- symnum(m <- matrix(1:8 %% 3 == 0, 2))
+stopifnot(identical(symnum(FALSE[FALSE]), noquote(""[FALSE])),
+ identical(symnum(c(m)), c(symnum(m))),
+ dim(sm) == dim(m), class(sm) == "noquote")
+## symnum(<length 0>) gave noquote("()") before 1.8.1
+
+
+## abbreviate with leading (or trailing) space differences (PR#4564)
+abbreviate(c("A"," A"), 4)
+## this gave infinite loop before 1.8.1
+
+
+## crossprod on 0-extent matrices
+a <- matrix(,0,5)
+stopifnot(crossprod(a) == 0)
+stopifnot(crossprod(a,a) == 0)
+stopifnot(crossprod(a+0i) == 0+0i)
+## were random areas in <= 1.8.0
+
+
+## DF[[i, j]] should be row i, col j
+stopifnot(women[[2, 1]] == women[2, 1])
+women[[2, 1]] <- 77
+stopifnot(women[2, 1] == 77)
+## was reversed from May 2002 to Oct 2003
+
+
+## merge.data.frame with a single-column df (PR#4299)
+x <- data.frame(x = 1:5, y = letters[1:5])
+y <- data.frame(z = 1:2)
+z <- merge(x, y)
+stopifnot(identical(names(z), c("x", "y", "z")))
+## third name was wrong in 1.8.0
+
+
+## cor(mat, use = "pair") was plainly wrong
+# longley has no NA's -- hence all "use = " should give the same!
+X <- longley
+ep <- 32 * Meps
+for(meth in eval(formals(cor)$method)) {
+ cat("method = ", meth,"\n")
+ Cl <- cor(X, method = meth)
+ stopifnot(all.equal(Cl, cor(X, method= meth, use= "complete"), tol=ep),
+ all.equal(Cl, cor(X, method= meth, use= "pairwise"), tol=ep),
+ all.equal(Cl, cor(X, X, method= meth), tol=ep),
+ all.equal(Cl, cor(X, X, method= meth, use= "pairwise"), tol=ep),
+ all.equal(Cl, cor(X, X, method= meth, use= "pairwise"), tol=ep)
+ )
+}
+## "pairwise" failed in 1.8.0
+
+
+## regexpr(*, fixed=TRUE) had 0-index from C
+txt <- c("english", "french", "swiss")
+ir <- regexpr("en", txt, fixed = TRUE)
+stopifnot(ir == c(1, 3, -1),
+ identical(ir, regexpr("en", txt)))
+## (*, fixed=TRUE) gave 0 2 -1 before R 1.8.1
+
+
+## PR#5017: filter(init=) had the wrong time order
+xx <- filter(4:8, c(1, 0.5, 0.25), method="recursive", init=3:1)
+stopifnot(identical(xx[1:3], c(8.25, 15.25, 26.125)))
+## 1.8.0 gave 6.75 12.75 22.375
+
+
+## PR#5090 user error with writeChar could segfault
+tf <- tempfile()
+zz <- file(tf, "wb")
+writeChar("", zz, nchars=10000000)
+close(zz)
+unlink(tf)
+## segfaults in 1.8.0
+
+
+## PR#4710 round (and signif) dropped attributes
+x <- round(matrix(0, 0, 3))
+stopifnot(identical(dim(x), as.integer(c(0, 3))))
+## numeric(0) in 1.8.0
+
+
+## PR#5405
+try(stepfun(c(), 1)(2))# > Error
+## segfaults in 1.8.1 and earlier
+
+
+## PR#4955 now allow embedded newlines in quoted fields in read.table
+temp <- tempfile()
+data <- data.frame(a=c("c", "e\nnewline"))
+write.table(data, sep=",", row.names=FALSE, file=temp)
+data2 <- read.csv(temp)
+unlink(temp)
+# attributes get a different order here
+stopifnot(identical(data$a, data2$a))
+## not allowed prior to 1.9.0
+
+
+## scoping problems with model.frame methods
+foo <- c(1,1,0,0,1,1)
+rep <- 1:6
+m <- lm(foo ~ rep, model=FALSE)
+model.matrix(m)
+n <- 1:6
+m <- lm(foo ~ n, model=FALSE)
+model.matrix(m)
+## failed in 1.8.0 because the wrong n or rep was found.
+rm(foo, rep)
+func <- function()
+{
+ foo <- c(1,1,0,0,1,1)
+ rep <- 1:6
+ m <- lm(foo ~ rep, model=FALSE)
+ model.matrix(m)
+}
+func()
+##
+
+
+## broken strptime in glibc (and code used on Windows)
+# the spec says %d is allowed in 1-31, but it seems HP-UX thinks
+# the date is invalid.
+# stopifnot(!is.na(strptime("2003-02-30", format="%Y-%m-%d")))
+stopifnot(is.na(strptime("2003-02-35", format="%Y-%m-%d")))
+# this one is still wrong in glibc
+stopifnot(is.na(strptime("2003-02-40", format="%Y-%m-%d")))
+stopifnot(is.na(strptime("2003-22-20", format="%Y-%m-%d")))
+# and so is this one
+stopifnot(is.na(strptime("2003 22 20", format="%Y %m %d")))
+stopifnot(is.na(ISOdate(year=2003, month=22, day=20)))
+## several after the first gave non-NA values in 1.8.1 on some broken OSes
+
+
+## PR#4688
+reli <- cbind(Si = c(2121, 100, 27, 0),
+ av = c(4700, 216, 67, 0),
+ Nc = c(6234,2461,502,14))
+stopifnot(inherits(try(fisher.test(reli, workspace=2000000)), "try-error"))
+## gave p.value = Inf ; now gives FEXACT error 501
+
+
+## PR#5701
+chisq.test(matrix(23171,2,2), simulate=TRUE)
+## gave infinite loop in 1.8.1 and earlier
+
+
+## as.matrix on an all-logical data frame
+ll <- data.frame(a = rpois(10,1) > 0, b = rpois(10,1) > 0)
+stopifnot(mode(as.matrix(ll)) == "logical")
+lll <- data.frame(a = LETTERS[1:10], b = rpois(10,1) > 0)
+stopifnot(mode(as.matrix(lll)) == "character")
+## both were char before 1.9.0
+
+
+## outer called rep with a non-generic arg
+x <- .leap.seconds[1:6]
+outer(x, x, "<")
+outer(x, x, "-")
+(z <- outer(x, x, "difftime", units="days"))
+stopifnot(class(z) == "difftime")
+## failed in 1.8.1
+
+
+## PR#5900 qbinom when probability is 1
+stopifnot(qbinom(0.95, 10, 1) == 10)
+stopifnot(qbinom(0, 10, 1) == 0)
+# and for prob = 0
+stopifnot(qbinom(0.95, 10, 0) == 0)
+stopifnot(qbinom(0, 10, 0) == 0)
+# and size = 0
+stopifnot(qbinom(0.95, 0, 0.5) == 0)
+## 1.8.1 was programmed to give NaN
+
+
+## base:: and ::: were searching in the wrong places
+stopifnot(inherits(try(base::lm), "try-error"))
+stopifnot(inherits(try(graphics::log), "try-error"))
+## equivalent constructs succeeded in 1.8.1
+
+
+## (PR#6452) princomp prediction without specifying centers should give NAs
+x <- matrix(rnorm(400), ncol=4)
+fit <- princomp(covmat=cov(x))
+stopifnot(is.null(fit$scores))
+stopifnot(is.na(predict(fit, newdata=x[1:10, ])))
+## failed in 1.8.1
+
+
+## (PR#6451) regex functions did not coerce args to character.
+sub(x=NA, pattern="x", replacement="y")
+## failed in 1.8.1
+
+
+## length<- needed a factor method, and so needed to be generic
+aa <- factor(letters)
+length(aa) <- 20
+aa
+stopifnot(is.factor(aa))
+## returned a vector in 1.8.1
+
+
+## spec.pgram() was too
+pAR <- c(2.7607, -3.82, 2.6535, -0.9238)
+N <- 1 + 2^14# 16385
+set.seed(123)
+x <- arima.sim(model = list(ar = pAR), n = N)
+spP <- spec.pgram(x, spans = 41, plot=FALSE)
+spA <- spec.ar(x=list(ar=pAR, order=4, var.pred=1, frequency=1),
+ n.freq = spP$n.used %/% 2, plot=FALSE)
+r <- spP$spec / spA$spec
+stopifnot(abs(mean(r) - 1) < 0.003)
+## was 0.0268 in R 1.8.1
+
+
+## check for a Microsoft bug in timezones ahead of GMT
+stopifnot(!is.na(as.POSIXct("1970-01-01 00:00:00")))
+##
+
+
+## PR#6672, split.default on factors
+x <- c(NA, 1, 2)
+y <- as.factor(x)
+split(x, y)
+split(y, y) # included NAs in 1.8.1
+r1 <- tapply(x, y, length)
+r2 <- tapply(y, y, length)
+stopifnot(r1 == r2)
+##
+
+
+## PR#6652, points.formula with subset and extra arguments.
+roller <-
+ data.frame(weight = c(1.9, 3.1, 3.3, 4.8, 5.3, 6.1, 6.4, 7.6, 9.8, 12.4),
+ depression = c(2, 1, 5, 5, 20, 20, 23, 10, 30, 25))
+plot(depression ~ weight, data=roller, type="n")
+with(roller, points( depression~weight, subset=8:10, col=2))
+with(roller, points( depression~weight, subset=8:10, col=2:4))
+plot(depression ~ weight, data=roller, type="n")
+points(depression~weight, subset=8:10, col=2:4, data=roller)
+## first two gave error in 1.8.1
+
+
+## PR#4558 part 2
+x <- seq(as.POSIXct("2004-03-25"), as.POSIXct("2004-03-31"), by="DSTdays")
+stopifnot(length(x) == 7)
+## was length 6 in the UK time zone.
+
+
+## PR#6702 c/rbind on list matrices
+A <- matrix(as.list(1:4), 2, 2)
+(res <- cbind(A, A))
+stopifnot(typeof(res) == "list")
+(res <- rbind(A, A))
+stopifnot(typeof(res) == "list")
+## were not implemented in 1.8.1
+
+
+## Date objects with NA's
+(t1 <- strptime(c("6. Aug. 1930", "3. Nov. 1925", "28. Mar. 1959",
+ NA, paste(1:29," Feb. 1960", sep=".")),
+ format = "%d. %b. %Y"))
+stopifnot(6 == length(print(s1 <- summary(t1))),
+ s1== summary(as.POSIXct(t1)),
+ 6 == length(print(format(as.Date(s1)))) )
+## gave bizarre "NA's" entry in R 1.8.1 and 1.9.0alpha
+
+
+## as.Date on a factor
+as.Date(factor("2000-01-02"))
+## failed in 1.9.0
+
+
+## as.data.frame.list (PR#6782)
+xx <- list(row.names=1:2,foxglove=3:4,toadflax=5:6)
+foo <- as.data.frame(xx)
+stopifnot(identical(names(xx), names(foo)))
+## 1.9.0 changed the last name to "x".
+
+
+## type.convert quirk (PR#6781)
+res1 <- type.convert( c("abc","-"), as.is=TRUE, na.strings="-" )
+stopifnot(identical(mode(res1), "character"), is.na(res1[2]))
+## res1[2] was "-" <= 1.9.0.
+
+
+## subsetting factor swaps order of attributes (PR#6799)
+af <- factor(c('A','B'))
+stopifnot(identical(af, af[1:2]))
+## failed in 1.9.0 as the attributes were class, level for af[1:2]
+
+
+## Comparison between lists and expressions
+stopifnot(inherits(try(list(1) <= list(2)), "try-error"))
+e <- expression(3 + 2 * 4)
+stopifnot(inherits(try(e == e), "try-error"))
+## both were allowed but nonsense in 1.9.0
+
+
+## "nowhere" interpolation (PR#6809)
+try(approx(list(x=rep(NaN, 9), y=1:9), xout=NaN))
+## gave a seg.fault in 1.9.0
+
+
+## aggregate.data.frame failed if result would have one row
+## Philippe Hupé, R-help, 2004-05-14
+dat <- data.frame(a=rep(2,10),b=rep("a",10))
+aggregate(dat$a, by=list(a1=dat$a, b1=dat$b), NROW)
+## failed due to missing drop = FALSE
+
+
+## [<-.data.frame with a data-frame value
+x <- data.frame(a=1:3, b=4:6, c=7:9)
+info <- x[1:2]
+x[, names(info)] <- info[1,]
+##
+
+
+## as.dendrogram.hclust()
+d <- as.dendrogram(hEU <- hclust(eurodist, "ave"))
+stopifnot(order.dendrogram(d) == hEU$order)# not new
+##N require(gclus); hE1 <- reorder.hclust(hEU, dis)
+## reconstruct without gclus (for R's testing)
+hE2 <- hEU; ii <- c(5,9:11, 13, 15:18); hE2$merge[ii,] <- hEU$merge[ii, 2:1]
+hE2$order <- as.integer(c(1,19,9,12,14,2,15,8,13,16,17,21,6,3,11,4,18,5,10,7,20))
+##N stopifnot(identical(hE1, hE2))
+d1 <- as.dendrogram(hE2)
+stopifnot(order.dendrogram(d1) == hE2$order,
+ identical(d1, rev(rev(d1))))
+## not true in 1.9.0
+
+
+## trunc on a Date
+trunc(xx <- Sys.Date()) # failed in 1.9.1
+x <- xx + 0.9
+stopifnot(identical(trunc(x), xx)) # gave next day in 1.9.1
+xx <- as.Date("1960-02-02")
+x <- xx + 0.2
+stopifnot(identical(trunc(x), xx)) # must not truncate towards 0.
+##
+
+### end of tests added in 1.9.1 ###
+
+## 1.9.1 patched
+
+## options(list('..', '..'))
+try(options(list('digits', 'width')))# give an error
+## gave a segfault in 1.9.1
+
+
+## PR#7100 seg faulted or path too long error on ././././././. ...
+length( list.files('.', all.files = TRUE, recursive = TRUE) )
+
+
+## PR#7116 segfaulted on A, later versions segfaulted on B or gave different
+## dims for the results.
+A <- cor(as.array(c(a=1,b=2)), cbind(1:2))
+B <- cor(cbind(1:2), as.array(c(a=1,b=2)))
+stopifnot(identical(A, B))
+
+
+## regression test for PR#7108
+ans <- gsub(" ", "", "b c + d | a * b", perl=TRUE) # NULL in 1.9.1
+stopifnot(identical(ans, gsub(" ", "", "b c + d | a * b")))
+gsub(" ", "", "a: 12345 :a", perl=TRUE) # segfaulted in 1.9.1
+## wrong answers, segfaults in 1.9.1.
+
+
+## regression test for PR#7132
+tmp <- data.frame(y=rnorm(8),
+ aa=factor(c(1,1,1,1,2,2,2,2)),
+ bb=factor(c(1,1,2,2,1,1,2,2)),
+ cc=factor(c(1,2,3,4,1,2,3,4)))
+tmp.aov <- aov(y ~ cc + bb/aa, data=tmp)
+anova(tmp.aov)
+model.tables(tmp.aov, type="means")
+## failed in 1.9.1.
+
+if(require(survival)) { # required package
+ a <- Surv(1:4, 2:5, c(0,1,1,0))
+ str(a)
+ str(a[rep(1:4,3)], vec.len = 7)
+ detach("package:survival")
+}
+
+### end of tests added in 1.9.1 patched ###
+
+
+## names in columns of data frames
+x <- 1:10
+names(x) <- letters[x]
+DF <- data.frame(x=x)
+(nm <- names(DF$x))
+stopifnot(is.null(nm))
+DF$y1 <- x
+DF["y2"] <- x
+DF[, "y3"] <- x
+DF[["y4"]] <- x
+stopifnot(is.null(names(DF$y1)), is.null(names(DF$y2)),
+ is.null(names(DF$y3)), is.null(names(DF$y4)))
+# names were preserved in 1.9.x
+# check factors
+xx <- as.factor(x)
+DF <- data.frame(x=xx)
+(nm <- names(DF$xx))
+stopifnot(is.null(nm))
+DF$y1 <- xx
+DF["y2"] <- xx
+DF[, "y3"] <- xx
+DF[["y4"]] <- xx
+stopifnot(is.null(names(DF$y1)), is.null(names(DF$y2)),
+ is.null(names(DF$y3)), is.null(names(DF$y4)))
+# how about AsIs? This should preserve names
+DF <- data.frame(x=I(x))
+(nm <- names(DF$x))
+stopifnot(identical(nm, names(x)))
+DF2 <- rbind(DF, DF[7:8,, drop=FALSE])
+(nm <- names(DF2$x))
+stopifnot(identical(nm, c(names(x), names(x)[7:8])))
+# and matrices? Ordinary matrices will be split into columns
+x <- 1:10
+dim(x) <- c(5,2)
+dimnames(x) <- list(letters[1:5], c("i", "ii"))
+DF <- data.frame(x=I(x))
+DF2 <- rbind(DF, DF)
+(rn <- rownames(DF2$x))
+stopifnot(identical(rn, c(rownames(x), rownames(x))))
+class(x) <- "model.matrix"
+DF <- data.frame(x=x)
+DF2 <- rbind(DF, DF)
+(rn <- rownames(DF2$x))
+stopifnot(identical(rn, c(rownames(x), rownames(x))))
+## names were always preserved in 1.9.x, but rbind dropped names and dimnames.
+
+
+## cumsum etc dropped names
+x <- rnorm(10)
+names(x) <- nm <- letters[1:10]
+stopifnot(identical(names(cumsum(x)), nm),
+ identical(names(cumprod(x)), nm),
+ identical(names(cummax(x)), nm),
+ identical(names(cummin(x)), nm))
+x <- x+1i
+stopifnot(identical(names(cumsum(x)), nm),
+ identical(names(cumprod(x)), nm))
+## 1.9.x dropped names
+
+## cumsum etc preserve NAs
+# double
+x <- c(1, NA, 3)
+r <- c(1, NA, NA)
+stopifnot(identical(cumsum(x), r))
+stopifnot(identical(cumprod(x), r))
+stopifnot(identical(cummin(x), r))
+stopifnot(identical(cummax(x), r))
+# complex
+x <- c(1+1i, NA, 3)
+r <- c(1+1i, NA, NA)
+stopifnot(identical(cumsum(x), r))
+stopifnot(identical(cumprod(x), r))
+# integer
+x <- c(1L, NA, 3L)
+r <- c(1L, NA, NA)
+stopifnot(identical(cumsum(x), r))
+stopifnot(identical(cumprod(x), c(1, NA, NA))) # returns double
+stopifnot(identical(cummin(x), r))
+stopifnot(identical(cummax(x), r))
+
+## complex superassignments
+e <- c(a=1, b=2)
+f <- c(a=1, b=2)
+g <- e
+h <- list(a=1, list(b=2, list(c=3, d=4), list(e=5)))
+j <- matrix(1, 2, 2)
+a <- "A"
+local({
+ eold <- e <- c(A=10, B=11)
+ hold <- h <- 2
+ jold <- j <- 7
+ gold <- g <- e
+ a <- "B"
+
+ e[2] <<- e[2]+1
+ names(f)[2] <<- a
+ g <<- 1
+ h[[2]][[h]][[ f[e==10] ]] <<- h
+ names(h[[2]][[h]])[f[e==10] ] <<- a
+ j[h, h] <<- h
+ colnames(j)[2] <<- a
+
+ stopifnot(identical(e, eold))
+ stopifnot(identical(h, hold))
+ stopifnot(identical(g, gold))
+ stopifnot(identical(j, jold))
+})
+
+stopifnot(identical(e, c(a=1, b=12)))
+stopifnot(identical(f, c(a=1, B=2)))
+stopifnot(identical(g, 1))
+stopifnot(identical(h, list(a=1, list(b=2, list(B=2, d=4), list(e=5)))))
+stopifnot(identical(as.vector(j), c(1, 1, 1, 2)))
+stopifnot(identical(colnames(j), c(NA,"B")))
+## gave error 'subscript out of bounds' in 1.9.1
+
+## make sure we don't get cycles out of changes to subassign3.
+x <- list(a=1, y=2)
+x$a <- x
+print(x)
+x$d <- x
+print(x)
+y <- x
+x$b <- y
+print(x)
+x$f <- y
+print(x)
+##
+
+
+## model.frame incorrectly preserved ts attributes
+x1 <- ts(c(1:10, NA))
+y1 <- ts(rnorm(11))
+lm(y1 ~ x1)
+lm(y1 ~ x1 + I(x1^2)) # second term has two classes
+## failed in 1.9.1
+
+
+## range checks missing in recursive assignments (PR#7196)
+l <- list()
+try(l[[2:3]] <- 1)
+l <- list(x=2)
+try(l[[2:3]] <- 1)
+l <- list(x=2, y=3)
+l[[2:3]] <- 1
+## first two segfaulted in 1.9.x
+
+
+## apply() on an array of dimension >=3 AND when for each iteration
+## the function returns a named vector of length >=2 (PR#7205)
+a <- array(1:24, dim=2:4)
+func1 <- function(x) c(a=mean(x), b=max(x))
+apply(a, 1:2, func1)
+## failed in 1.9.1
+
+
+# col2rgb must return a matrix for a single colour
+stopifnot(is.matrix(col2rgb("red")))
+## was vector at one point in pre-2.0.0
+
+
+## Subscripting matrices with NA's
+AAA <- array(1:6, c(6,1,1))
+idx <- c(1,2,NA,NA,5,6)
+B <- 10
+AAA[idx,1,1] <- B
+stopifnot(all.equal(as.vector(AAA), c(10,10,3,4,10,10)))
+## assigned only the first two elements in 1.9.1.
+## Tests for >= 2.0.0
+A <- c(1,2,3,4,5,6)
+A[idx] <- 27 # OK, one value
+stopifnot(identical(A, c(27,27,3,4,27,27)))
+try(A[idx] <- 6:1) # was 6 5 3 4 2 1 in 1.9.1
+stopifnot(inherits(.Last.value, "try-error"))
+
+AA <- matrix(c(1,2,3,4,5,6), 6, 1)
+AA[idx,] <- 27 # OK, one value
+stopifnot(identical(AA, matrix(c(27,27,3,4,27,27), 6, 1)))
+try(AA[idx,] <- 6:1) # was 6 5 3 4 4 3 in 1.9.1
+stopifnot(inherits(.Last.value, "try-error"))
+
+AAA <- array(c(1,2,3,4,5,6), c(6,1,1))
+AAA[idx,,] <- 27 # OK, one value
+stopifnot(identical(AAA, array(c(27,27,3,4,27,27), c(6,1,1))))
+try(AAA[idx,,] <- 6:1) # was 6 5 3 4 5 6 in 1.9.1
+stopifnot(inherits(.Last.value, "try-error"))
+## only length-1 values are allowed in >= 2.0.0.
+
+
+## hist with infinite values (PR#7220)
+hist(log(-5:100), plot = FALSE)
+## failed in 1.9.1: will warn, correctly.
+
+
+## merge problem with names/not in rbind.data.frame
+x <- structure(c("a", "b", "2", "0.2-26", "O", "O"), .Dim = 2:3,
+ .Dimnames = list(c("1", "2"), c("P", "V", "2")))
+y <- structure(c("a", "b", "2", "0.2-25", "O", "O"), .Dim = 2:3,
+ .Dimnames = list(c("1", "2"), c("P", "V", "1")))
+merge(x, y, all.y = TRUE)
+## failed for a while in pre-2.0.0
+
+
+## matrix responses in binomial glm lost names prior to 2.0.0
+y <- rbinom(10, 10, 0.5)
+x <- 1:10
+names(y) <- letters[1:10]
+ym <- cbind(y, 10-y)
+fit2 <- glm(ym ~ x, binomial)
+stopifnot(identical(names(resid(fit2)), names(y)))
+## Note: fit <- glm(y/10 ~ x, binomial, weights=rep(10, 10))
+## Does not preserve names in R < 2.0.1, but does in S.
+fit <- glm(y/10 ~ x, binomial, weights=rep(10, 10))
+stopifnot(identical(names(resid(fit)), names(y)))
+## The problem was glm.fit assumed a vector response.
+
+
+## dlogis(-2000) was NaN in <= 2.0.0.
+stopifnot(identical(dlogis(-2000), 0.0))
+##
+
+
+## short vectors in spline[fun] (PR#7290)
+try(splinefun(1[0], 1[0])(1)) # segfault in <= 2.0.0
+for(meth in c("fmm", "nat", "per"))
+ stopifnot(all(splinefun(1, pi, method = meth)(0:2) == rep(pi, 3)))
+## exactly constant for n=1; was NA for "periodic" in <= 2.0.0
+
+
+## ecdf with NAs (part of PR#7292).
+x <- c(1,2,2,4,7, NA, 10,12, 15,20)
+ecdf(x)
+## failed in <= 2.0.0.
+
+
+## Incorrect use of as.Date segfaulted on some x86_64 systems.
+as.Date("2001", "%Y")
+## answer is usually current mon & day, but 2001-01-01 on Solaris.
+
+
+## rank and order accepted invalid inputs (and gave nonsense)
+x1 <- as.list(10:1)
+x2 <- charToRaw("A test string")
+stopifnot(inherits(try(order(x1)), "try-error"),
+ inherits(try(order(x2)), "try-error"),
+ inherits(try(rank(x1)), "try-error"),
+ inherits(try(rank(x2)), "try-error"))
+## worked but gave 1:n in 2.0.0.
+stopifnot(inherits(try(sort(x1)), "try-error"),
+ inherits(try(sort(x2)), "try-error"),
+ inherits(try(sort(x1, partial=5)), "try-error"),
+ inherits(try(sort(x2, partial=5)), "try-error"))
+##
+
+
+## pmax failed with NA inputs
+pmax(c(1,2,NA), c(3,4,NA), na.rm=TRUE)
+## failed after for 2.0.0 change to subassignment
+
+
+## subassigning expression could segfault (PR#7326)
+foo <- expression(alpha, beta, gamma)
+foo[2]
+foo[2] <- NA
+foo
+## segfaulted in 2.0.0
+
+
+## incorrect arg matching in sum min max prod any all
+## Pat Burns, R-devel 2004-11-19
+stopifnot(identical(sum(1:4, NA, n = 78, na.rm = TRUE), 88))
+## was 11 in 2.0.1
+
+
+## segfault from text, P Ehlers, R-devel 2004-11-24
+plot(1:10)
+loc <- list(5, 6)
+try(text(loc, labels = "a"))
+## segfaulted in 2.0.1
+
+
+## automatic row.names can be number-like, MM, 2004-11-26
+d0 <- data.frame(x=1:3, y=pi*2:0)
+row.names(d0)[3] <- c("01.00")
+write.table(d0, (tf <- tempfile()))
+d <- read.table(tf)
+## gave error ("duplicate row.names") in 2.0.1
+stopifnot(all.equal(d,d0))
+unlink(tf)
+
+
+## seq() should be more consistent in returning "integer"
+stopifnot(typeof(seq(length=0)) == "integer",
+ identical(seq(length=0), seq(along.with=0[0])),
+ identical(seq(length=3), 1:3),
+ identical(seq(length=3), seq(along.with=1:3)))
+
+
+## labels.lm was broken (PR#7417)
+# part of example(lm)
+ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14)
+trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69)
+group <- gl(2,10,20, labels=c("Ctl","Trt"))
+weight <- c(ctl, trt)
+lm.D9 <- lm(weight ~ group)
+stopifnot(labels(lm.D9) == "group")
+## failed in 2.0.1, giving length 0
+
+
+## sprintf had no length check (PR#7554)
+a <- matrix (ncol=100, nrow=100, data=c(1,2,3,4,5))
+a.serial <- rawToChar(serialize(a, NULL, ascii=TRUE))
+try(sprintf('foo: %s\n', a.serial))
+## seqfaulted in 2.0.1
+
+
+## all/any did not coerce as the Blue Book described.
+for(x in c("F", "FALSE", "T", "TRUE", "NA")) {
+ print(all(x))
+ print(any(x))
+}
+all(list())
+any(list())
+## all failed in 2.0.1 with 'incorrect argument type'
+
+
+##---- named dimnames of %*% and crossprod() -- matrices and 1-d arrays:
+tst1 <- function(m) {
+ stopifnot(identical(t(m) %*% (m), crossprod(m)))
+ stopifnot(identical(m %*% t(m), crossprod(t(m))))
+}
+tst2 <- function(x, y=x) {
+ stopifnot(identical(t(x) %*% (y),(crossprod(x,y) -> C)))
+ stopifnot(identical(t(y) %*% (x),(crossprod(y,x) -> tC)))
+ stopifnot(identical(tC, t(C)))
+}
+
+{m1 <- array(1:2,1:2); dimnames(m1) <- list(D1="A", D2=c("a","b")); m1}
+tst1(m1)
+m2 <- m1; names(dimnames(m2)) <- c("", "d2"); tst1(m2)
+m3 <- m1; names(dimnames(m3)) <- c("", "") ; tst1(m3)
+m4 <- m1; names(dimnames(m4)) <- NULL ; tst1(m4)
+
+tst2(m1,m2)
+tst2(m1,m3)
+tst2(m1,m4)
+tst2(m2,m3)
+tst2(m2,m4)
+tst2(m3,m4)
+
+## 2) Now the 'same' with 1-d arrays:
+a1 <- m1; dim(a1) <- length(a1); dimnames(a1) <- dimnames(m1)[2]; a1 # named dn
+a2 <- a1; names(dimnames(a2)) <- NULL ; a2 # unnamed dn
+a3 <- a1; dimnames(a3) <- NULL ; a3 # no dn
+stopifnot(identical(dimnames(t(a1))[2], dimnames(a1)))
+## in version <= 2.0.1, t(.) was loosing names of dimnames()
+tst1(a1)# failed in 2.0.1 ("twice")
+tst1(a2)# failed in 2.0.1
+tst1(a3)# ok
+## these all three failed in (2.0.1) for more than one reason:
+tst2(a1,a2)
+tst2(a1,a3)
+tst2(a2,a3)
+## end {testing named dimnames for %*% and crossprod()}
+
+
+## -- coercing as.data.frame(NULL) to a pairlist didn't work
+y<-1:10
+eval(quote(y), as.data.frame(NULL))
+## NULL as the second argument of eval should be treated
+## like a list or data frame
+eval(quote(y), NULL)
+## end
+
+
+## data frame with nothing to replace
+A <- matrix(1:4, 2, 2)
+A[is.na(A)] <- 0
+A <- as.data.frame(A)
+A[is.na(A)] <- 0
+## last not accepted prior to 2.1.0
+
+
+## scan on partial lines on an open connection
+cat("TITLE extra line", "235 335 535 735", "115 135 175",
+ file="ex.data", sep="\n")
+cn.x <- file("ex.data", open="r")
+res <- scan(cn.x, skip=1, n=2)
+res <- c(res, scan(cn.x, n=2))
+res <- c(res, scan(cn.x, n=2))
+res <- c(res, scan(cn.x, n=2))
+close(cn.x, sep=" ")
+unlink("ex.data")
+stopifnot(identical(res, c(235, 335, 535, 735, 115, 135, 175)))
+## dropped some first chars < 2.1.0
+
+
+## PR#7686 formatC does not pick up on incorrect 'flag' inputs
+try(formatC(1, flag="s"))
+## segfaulted in 2.0.1
+
+
+## PR#7695 contrasts needed coercion to double
+c <- matrix(c(0,1,2), nrow=3)
+storage.mode(c) <- "integer"
+f <- factor(1:3)
+contrasts(f, 1) <- c
+x <- model.matrix(~f)
+stopifnot(x == c(1,1,1,0,1,2))
+## gave machine-dependendent silly numbers in 2.0.1
+
+
+## extreme (de-normalized) axis range
+x <- 2^-seq(67, 1067, length=20)
+plot(x^.9, x, type="l", log="xy") # still warning and ugly labels because
+ ## e.g., 10^-323 |==> 9.881313e-324 numerically
+## gave error "log - axis(), 'at' creation, _LARGE_ range..." in 2.0.1
+
+
+## torture test of scan() with allowEscape=TRUE
+tf <- tempfile()
+x <- c('ABC', '"123"', "a'b")
+cat(shQuote(x, "cmd"), sep="\n", file=tf)
+(x2 <- scan(tf, ""))
+unlink(tf)
+stopifnot(identical(x, x2))
+## At one point pre-2.1.0 got confused
+
+
+## se.contrast failed in 2.0.1 with some effectively one-stratum designs.
+old <- getOption("contrasts")
+options(contrasts = c("contr.helmert", "contr.poly"))
+Lab <- factor(rep(c("1","2","3"), each=12))
+Material <- factor(rep(c("A","B","C","D"),each=3,times=3))
+Measurement <- c(12.20,12.28,12.16,15.51,15.02,15.29,18.14,18.08,18.21,
+ 18.54,18.36,18.45,12.59,12.30,12.67,14.98,15.46,15.22,
+ 18.54,18.31,18.60,19.21,18.77,18.69,12.72,12.78,12.66,
+ 15.33,15.19,15.24,18.00,18.15,17.93,18.88,18.12,18.03)
+testdata <- data.frame(Lab, Material, Measurement)
+(test.aov <- aov(Measurement ~ Material + Error(Lab/Material),
+ data = testdata))
+eff.aovlist(test.aov)
+(res <- se.contrast(test.aov,
+ list(Material=="A", Material=="B",
+ Material=="C", Material=="D"),
+ coef = c(1, 1, -1, -1), data = testdata))
+## failed in 2.0.1 as a matrix was 1 x 1.
+
+## 2.0.1 also failed to check for orthogonal contrasts
+## in calculating the efficiencies (which are 1 here).
+options(contrasts = c("contr.treatment", "contr.poly"))
+(test2.aov <- aov(Measurement ~ Material + Error(Lab/Material),
+ data = testdata))
+(res2 <- se.contrast(test2.aov,
+ list(Material=="A", Material=="B",
+ Material=="C", Material=="D"),
+ coef = c(1, 1, -1, -1), data = testdata))
+stopifnot(all.equal(res, res2))
+
+## related checks on eff.aovlist
+# from example(eff.aovlist) # helmert contrasts
+Block <- gl(8, 4)
+A<-factor(c(0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1,0,1))
+B<-factor(c(0,0,1,1,0,0,1,1,0,1,0,1,1,0,1,0,0,0,1,1,0,0,1,1,0,0,1,1,0,0,1,1))
+C<-factor(c(0,1,1,0,1,0,0,1,0,0,1,1,0,0,1,1,0,1,0,1,1,0,1,0,0,0,1,1,1,1,0,0))
+Yield <- c(101, 373, 398, 291, 312, 106, 265, 450, 106, 306, 324, 449,
+ 272, 89, 407, 338, 87, 324, 279, 471, 323, 128, 423, 334,
+ 131, 103, 445, 437, 324, 361, 302, 272)
+aovdat <- data.frame(Block, A, B, C, Yield)
+old <- getOption("contrasts")
+options(contrasts=c("contr.helmert", "contr.poly"))
+fit <- aov(Yield ~ A * B * C + Error(Block), data = aovdat)
+eff1 <- eff.aovlist(fit)
+options(contrasts = old)
+fit <- aov(Yield ~ A * B * C + Error(Block), data = aovdat)
+eff2 <- eff.aovlist(fit)
+stopifnot(all.equal(eff1, eff2)) # will have rounding-error differences
+## Were different in earlier versions
+
+
+## parts of PR#7742 and other examples
+sub('^','v_', 1:3, perl=TRUE)
+## 2.0.1 did not coerce to character (nor was it documented to).
+x <- LETTERS[1:3]
+stopifnot(identical(paste('v_', x, sep=""),
+ sub('^','v_', x, perl = TRUE)))
+## 2.0.1 added random chars at the end
+stopifnot(identical(paste('v_', x, sep=""), sub('^','v_', x)))
+## 2.0.1 did not substitute at all
+(x <- gsub("\\b", "|", "The quick brown fox", perl = TRUE))
+stopifnot(identical(x, "|The| |quick| |brown| |fox|"))
+## checked against sed: 2.0.1 infinite-looped.
+## NB, the help page warns you not to do this one except in perl
+(x <- gsub("\\b", "|", "The quick brown fox", perl = TRUE))
+stopifnot(identical(x, "|The| |quick| |brown| |fox|"))
+## 2.0.1 gave wrong answer
+## Another boundary case, same warning
+## (x <- gsub("\\b", "|", " The quick "))
+## stopifnot(identical(x, " |The| |quick| "))
+(x <- gsub("\\b", "|", " The quick ", perl = TRUE))
+stopifnot(identical(x, " |The| |quick| "))
+## and some from a comment in the GNU sed code
+x <- gsub("a*", "x", "baaaac")
+stopifnot(identical(x, "xbxcx"))
+x <- gsub("a*", "x", "baaaac", perl = TRUE)
+stopifnot(identical(x, "xbxcx"))
+## earlier versions got "bxc" or "xbxxcx"
+(x <- gsub("^12", "x", "1212")) # was "xx"
+stopifnot(identical(x, "x12"))
+(x <- gsub("^12", "x", "1212", perl = TRUE)) # was "xx"
+stopifnot(identical(x, "x12"))
+## various fixes in 2.1.0
+
+## length(0) "dist":
+(d01. <- dist(matrix(0., 0,1)))
+## failed in 2.0.1 and earlier
+
+
+## Wish of PR#7775
+x <- matrix(0, nrow=0, ncol=2)
+colSums(x); rowSums(x)
+x <- matrix(0, nrow=2, ncol=0)
+colSums(x); rowSums(x)
+## not allowed in 2.0.1
+
+
+## infinite recursion in 2.0.1 (and R-beta 2005-04-11):
+summary(data.frame(mat = I(matrix(1:8, 2))))
+summary(data.frame(x = gl(2,2), I(matrix(1:8, 4))))
+##
+
+
+
+### fixes for 2.1.1 ###
+
+## PR#7792: predict.glm dropped names
+nm <- names(predict(glm(y ~ x, family=binomial,
+ data=data.frame(y=c(1, 0, 1, 0), x=c(1, 1, 0, 0))),
+ newdata=data.frame(x=c(0, 0.5, 1)), type="response"))
+stopifnot(identical(nm, as.character(1:3)))
+## no names in 2.1.0
+
+
+## PR#7808: as.data.frame: Error in "names<-.default"
+x1 <- array(1:9, c(3, 3, 3))
+FUN <- function(x1, x2, x3, x4) cbind(x1[, 1, 1:2], x1[, 2, 1:2])[, 1]
+as.data.frame(FUN(x1[1:3,,], x2 = c("a", "b"),
+ x3 = c("a", "b"), x4 = c("a", "b")))
+## failed in 2.1.0
+
+
+## PR#7797 citation() chops "Roeland "
+stopifnot(as.personList("Roeland Lastname")[[1]]$given[1] == "Roeland")
+## was empty in 2.1.0.
+
+
+## runmed()'s Turlach algorithm seg.faulted in rare cases:
+t2 <- c(-2,-7,5,2,-3, 0,1,3,2,-1,2,1,2,1,1,1,-2,4, 1,1,1, 32)
+rS <- runmed(t2, k=21, algorithm= "Stuetzle")
+rT <- runmed(t2, k=21, algorithm= "Turlach")
+stopifnot(identical(rS, rT))
+## seg.fault in 2.1.0
+
+
+## duplicated and unique on a list
+x <- list(1, 2, 3, 2)
+duplicated(x)
+unique(x)
+## unique failed in 2.1.0
+
+
+## prog.aovlist on data with row.names
+N <- c(0,1,0,1,1,1,0,0,0,1,1,0,1,1,0,0,1,0,1,0,1,1,0,0)
+P <- c(1,1,0,0,0,1,0,1,1,1,0,0,0,1,0,1,1,0,0,1,0,1,1,0)
+K <- c(1,0,0,1,0,1,1,0,0,1,0,1,0,1,1,0,0,0,1,1,1,0,1,0)
+yield <- c(49.5,62.8,46.8,57.0,59.8,58.5,55.5,56.0,62.8,55.8,69.5,
+ 55.0, 62.0,48.8,45.5,44.2,52.0,51.5,49.8,48.8,57.2,59.0,53.2,56.0)
+npk <- data.frame(block=gl(6,4), N=factor(N), P=factor(P),
+ K=factor(K), yield=yield)
+row.names(npk) <- letters[2:25]
+npk.aovE <- aov(yield ~ N*P*K + Error(block), npk)
+pr <- proj(npk.aovE)
+## failed in 2.1.0
+
+
+## PR#7894: Reversing axis in a log plot
+x <- 1:3
+plot(x, exp(x), log = "y", ylim = c(30,1))
+## gave error (and warning) in log - axis(), 'at' creation
+
+### end of tests added in 2.1.0 patched ###
+
+
+
+## Multibyte character set regular expressions had buffer overrun
+regexpr("[a-z]", NA)
+## crashed on 2.1.1 on Windows in MBCS build.
+
+
+## PR#8033: density with 'Inf' in x:
+d <- density(1/0:2, kern = "rect", bw=1, from=0, to=1, n=2)
+stopifnot(all.equal(rep(1/sqrt(27), 2), d$y, tol=1e-14))
+## failed in R 2.1.1 (since about 1.9.0)
+
+stopifnot(all.equal(Arg(-1), pi))
+## failed in R <= 2.1.1
+
+
+## PR#7973: reversed log-scaled axis
+plot(1:100, log="y", ylim=c(100,10))
+stopifnot(axTicks(2) == 10*c(10,5,2,1))
+## empty < 2.2.0
+
+
+## rounding errors in window.default (reported by Stefano Iacus)
+x <- ts(rnorm(50001), start=0, deltat=0.1)
+length(window(x, deltat=0.4))
+length(window(x, deltat=1))
+length(window(x, deltat=4.9))
+length(window(x, deltat=5))
+## last failed in 2.1.1
+
+
+## incorrect sort in order with na.last != NA
+x <- c("5","6",NA,"4",NA)
+y <- x[order(x,na.last=FALSE)]
+stopifnot(identical(y, c(NA, NA, "4", "5", "6")))
+## 2.1.1 sorted "4" first: the fence was wrong.
+
+
+## integer overflow in cor.test (PR#8087)
+n <- 46341
+(z <- cor.test(runif(n), runif(n), method = "spearman"))
+stopifnot(!is.na(z$p.value))
+##
+
+## seek on a file messed up in Windows (PR#7896)
+tf <- tempfile()
+f <- file(tf, "w+b")
+writeChar("abcdefghijklmnopqrstuvwxyz", f, eos=NULL)
+seek(f, 0, "end", rw="r")
+stopifnot(seek(f, NA, rw="r") == 26) # MinGW messed up seek to end of file that was open for writing
+close(f)
+f <- file(tf, "rb")
+seek(f, 12)
+stopifnot(readChar(f, 1) == "m") # First patch messed up on read-only files
+close(f)
+unlink(tf)
+##
+
+### end of tests added in 2.1.1 patched ###
+
+
+
+## tests of hexadecimal constants
+x <- 0xAbc
+stopifnot(x == 2748)
+xx <- as.integer("0xAbc")
+stopifnot(x == xx)
+xx <- as.numeric("0xAbc")
+stopifnot(x == xx)
+stopifnot(as.integer("13.7") == 13)
+## new in 2.2.0
+
+
+## save() of raw vector was incorrect on big-endian system
+(y <- x <- charToRaw("12345"))
+save(x, file="x.Rda")
+rm(x)
+load("x.Rda")
+x
+stopifnot(identical(x, y))
+unlink("x.Rda")
+## 00 00 00 00 00 in 2.1.0 on OS X (now macOS)
+## fixed for 2.1.1, but test added only in 2.2.x
+
+
+## PR#7922: Could not use expression() as an initial expression value
+setClass("test2", representation(bar = "expression"))
+new("test2", bar = expression())
+## failed
+
+
+## Ops.data.frame had the default check.names=TRUE
+DF <- data.frame("100"=1:2, "200"=3:4, check.names=FALSE)
+DF/DF
+stopifnot(identical(names(DF), names(DF/DF)))
+## DF/DF names had X prepended < 2.2.0
+
+
+## sum(T) was double
+x <- 1:10
+stopifnot(typeof(sum(x)) == "integer")
+x <- c(TRUE, FALSE)
+stopifnot(typeof(sum(x)) == "integer")
+## double < 2.2.0
+
+
+## Overflow in PrintGenericVector
+x <- paste(1:5000, collapse="+")
+as.matrix(list(a=1:2, b=2:3, c=x))
+## segfault in 2.1.1, silent truncation in 2.1.1 patched
+
+
+## weighted.residuals for glm fits (PR#7961)
+set.seed(1)
+x <- runif(10)
+y <- x + rnorm(10)
+w <- 0:9
+r1 <- weighted.residuals(lm(y ~ x, weights = w))
+r2 <- weighted.residuals(glm(y ~ x, weights = w))
+stopifnot(all.equal(r1, r2))
+## different in 2.1.1
+
+
+## errors in add1.{lm,glm} when adding vars with missing values(PR#8049)
+set.seed(2)
+y <- rnorm(10)
+x <- 1:10
+is.na(x[9]) <- TRUE
+
+lm0 <- lm(y ~ 1)
+lm1 <- lm(y ~ 1, weights = rep(1, 10))
+
+add1(lm0, scope = ~ x)
+add1(lm1, scope = ~ x) ## error in 2.1.1
+
+glm0 <- glm(y ~ 1)
+glm1 <- glm(y ~ 1, weights = rep(1, 10))
+glm2 <- glm(y ~ 1, offset = rep(0, 10))
+
+add1(glm0, scope = ~ x) ## error in 2.1.1
+add1(glm1, scope = ~ x) ## error in 2.1.1
+add1(glm2, scope = ~ x) ## error in 2.1.1
+##
+
+
+## levels<-.factor dropped other attributes.
+## Heinz Tuechler, R-help, 2005-07-18
+f1 <- factor(c("level c", "level b", "level a", "level c"), ordered=TRUE)
+attr(f1, "testattribute") <- "teststring"
+(old <- attributes(f1))
+levels(f1) <- c("L-A", "L-B", "L-C")
+f1
+(new <- attributes(f1))
+new$levels <- old$levels <- NULL
+stopifnot(identical(old, new))
+f2 <- factor(letters[1:4])
+levels(f2) <- as.character(c(1:3, NA))
+f2
+stopifnot(nlevels(f2) == 3)
+## dropped other attributes < 2.2.0.
+
+
+## regressed at one point in pre-2.2.0
+A <- matrix(pi, 0, 2)
+stopifnot(identical(dim(A), dim(format(A))))
+## dropped dim at one point
+
+
+## ls.diag with missing values (PR#8139)
+x <- matrix(c(1,-1,1,-1,1,-1,1,-1,1,-1, 1,2,3,4,5,6,7,8,9,10), 10, 2)
+y <- as.matrix(c(1,2,3,NA,3,4,3,4,5,4))
+wt <- c(1,1,1,1,1,1,1,1,1,0)
+regres <- lsfit(x, y, wt=wt)
+regdiag <- ls.diag(regres)
+## failed < 2.2.0.
+
+
+## window.default had an inappropriate tolerance
+a <- ts(1:5000, start = 0, freq = 10)
+b <- lag(a, 1)
+bb <- window(b, start = 0)
+stopifnot(length(bb) == length(a) - 1)
+## was length(a) - 2 in 2.1.1, since the tolerance was abs(start) * ts.end
+
+
+## subassignment of length zero vector to NULL gave garbage answer (PR#8157)
+x <- NULL
+x[[1]] <- numeric(0)
+stopifnot(length(x[[1]]) == 0)
+## failed < 2.2.0
+
+
+## some checks for raw in data frames and lists
+x <- charToRaw("test")
+(z <- data.frame(x))
+z$y <- x
+z[["y2"]] <- x
+z["y3"] <- x
+z
+## lists use separate code
+z <- list(x=x)
+z$y <- x
+z[["y2"]] <- x
+z["y3"] <- list(x)
+z
+## Not completely supported prior to 2.2.0
+
+
+### end of tests added in 2.2.0 ###
+
+
+## summary.matrix failed on some classed objects
+surv <- structure(c(2.06, 2.13, 0.09, 0.27, 1, 0.36, 3.04, 0.67, 0.35,
+ 0.24, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0),
+ .Dim = c(10L, 2L),
+ .Dimnames = list(NULL, c("time", "status")),
+ type = "right", class = "Surv")
+summary(surv)
+## Had infinite recursion (sometimes segfault) on 2.2.0.
+
+## need fuzz even for ">=" :
+set.seed(1)
+stopifnot(all.equal(chisq.test(cbind(1:0, c(7,16)), simulate.p = TRUE)$p.value,
+ 0.3368315842, tol = 1e-6))
+## some i686 platforms gave 0.00049975
+
+
+## PR#8228 image() failed on a matrix with all NAs
+image(z=matrix(NA, 1, 1), x=0:1, y=0:1)
+
+
+## read.fwf(header=TRUE) failed (PR#8226)
+ff <- tempfile()
+cat(file=ff, "A\tB\tC", "123456", "987654", sep="\n")
+z <- read.fwf(ff, width=c(1,2,3), header=TRUE)
+stopifnot(identical(names(z), LETTERS[1:3]))
+unlink(ff)
+## failed in <= 2.2.0
+
+## diag() failed if matrix had NA dimnames
+x <- matrix(1, 2, 2)
+dimnames(x) <- list(c("a", NA), c("a", NA))
+diag(x)
+
+
+## colnames in pivoted decompositions (PR#8258)
+A <- 1:10
+X <- cbind(A,B=A^2, C=A^2-A, D=1)
+qrX <- qr(X)
+oo <- order(qrX$pivot)
+Q <- qr.Q(qrX)
+R <- qr.R(qrX)
+(z <- (Q%*%R)[,oo])
+stopifnot(identical(colnames(X), colnames(z)))
+
+qrX <- qr(X, LAPACK=TRUE)
+oo <- order(qrX$pivot)
+Q <- qr.Q(qrX)
+R <- qr.R(qrX)
+(z <- (Q%*%R)[,oo])
+stopifnot(identical(colnames(X), colnames(z)))
+
+Y <- crossprod(X)
+U <- chol(Y, pivot=TRUE)
+oo <- order(attr(U, "pivot"))
+(z <- t(U[,oo])%*% U[,oo])
+stopifnot(identical(colnames(X), colnames(z)))
+## unpivoted colnames in R <= 2.2.0
+
+
+## Im(-1) (PR#8272)
+stopifnot(all.equal(Im(c(1, 0, -1)), rep(0, 3)))
+## R <= 2.2.0 had Im and Arg the same for non-complex numbers
+
+
+## rounding errors in aggregate.ts
+aggregate(as.ts(c(1,2,3,4,5,6,7,8,9,10)),1/5,mean)
+## failed in 2.2.0
+
+
+## prcomp(tol=1e-6)
+set.seed(16)
+x <- matrix(runif(30),ncol=10)
+s <- prcomp(x, tol=1e-6)
+stopifnot(length(s$sdev) == 3, ncol(s$rotation) == 2)
+summary(s)
+## last failed in 2.2.0
+
+
+## mapply did not test type of MoreArgs
+try(mapply(rep,times=1:4, MoreArgs=42))
+## segfaulted in 2.2.0
+
+
+## qbinom had incorrect test for p with log=TRUE
+(z <- qbinom(-Inf, 1, 0.5, log.p = TRUE))
+stopifnot(is.finite(z))
+## was NaN in 2.2.0
+
+
+## t(.) with NULL dimnames
+x <- diag(2)
+dimnames(x) <- list(NULL, NULL)
+stopifnot(identical(x, t(x)),
+ identical(dimnames(x), dimnames(t(array(3, 1, dimnames=list(NULL))))))## dropped the length-2 list till 2.2.0
+
+
+## infinite influence measures (PR#8367)
+data(occupationalStatus)
+Diag <- as.factor(diag(1:8))
+Rscore <- scale(as.numeric(row(occupationalStatus)), scale = FALSE)
+Cscore <- scale(as.numeric(col(occupationalStatus)), scale = FALSE)
+Uniform <- glm(Freq ~ origin + destination + Diag + Rscore:Cscore,
+ family = poisson, data = occupationalStatus)
+Ind <- as.logical(diag(8))
+residuals(Uniform)[Ind] #zero/near-zero
+stopifnot(is.nan(rstandard(Uniform)[Ind]),
+ is.nan(rstudent (Uniform)[Ind]),
+ is.nan(dffits (Uniform)[Ind]),
+ is.nan(covratio (Uniform)[Ind]),
+ is.nan(cooks.distance(Uniform)[Ind]))
+## had infinities in 2.2.0 on some platforms
+## plot.lm() on <glm> objects:
+plot(Uniform) # last plot gives warning on h_ii ~= 1
+plot(Uniform, 6) # added 2006-01-10
+plot(Uniform, 5:6)# failed for a few days 2008-05
+plot(Uniform, 1:2, caption = "")# ditto
+##
+
+
+### end of tests added in 2.2.1 ###
+
+## sub(fixed=TRUE), reported by Roger Peng 2005-12-21
+x <- 0:10
+v <- paste(x, "asdf", sep=".")
+(xx <- sub(".asdf", "", v, fixed = TRUE))
+stopifnot(nchar(xx) == nchar(x), xx == x)
+## had random trailing bytes from second element on in 2.2.1.
+## identical reported true, fixed in 2.3.0.
+
+
+## rbind on data frames with 0 rows (PR#8506)
+foo <- data.frame(x = 1:10, y = rnorm(10))
+bar1 <- rbind.data.frame(foo[1:5,], foo[numeric(0),])
+stopifnot(dim(bar1) == c(5,2))
+bar2 <- rbind.data.frame(a = foo[1:5,], b = foo[numeric(0),])
+stopifnot(dim(bar2) == c(5,2))
+## Last had 6 rows in 2.2.1, and was a corrupt data frame
+
+## environments are recursive but cannot be indexed - all.equal.default()
+d <- data.frame(k=1:7, n=2:8, x=0:6)
+r <- glm(cbind(k, n-k) ~ x, family=binomial, data=d)
+stopifnot(all.equal(r,r))
+## failed in 2.2.1
+
+### end of tests added in 2.2.1 patched ###
+
+
+## sort used to preserve inappropriate attributes and not always sort names.
+x <- runif(10)
+tsp(x) <- c(1,10,1)
+(z <- sort(x)) # kept tsp attribute
+stopifnot(is.null(attributes(z)))
+(z <- sort(x, method="quick")) # same
+stopifnot(is.null(attributes(z)))
+(z <- sort(x, partial = 1:10)) # same
+stopifnot(is.null(attributes(z)))
+
+names(x) <- letters[1:10]
+o <- sort.list(x)
+z2 <- structure(c(x)[o], names=names(x)[o])
+(z <- sort(x)) # sorted names, dropped the tsp attribute
+stopifnot(identical(z, z2))
+(z <- sort(x, method="quick")) # sorted names, kept the tsp attribute.
+stopifnot(identical(z, z2))
+(z <- sort(x, partial = 1:10)) # did not sort names, kept tsp attribute
+stopifnot(is.null(attributes(z)))
+## fixed for 2.3.0 to sort names (except partial), drop all other attributes.
+
+
+## formatC on as.single (PR#8211)
+# not documented to work but someone tried it.
+(z <- formatC(as.single(1)))
+stopifnot(identical(z, "1"))
+## was wrong < 2.3.0
+
+
+## outer on factors was broken in pre-2.3.0
+x <- factor(1:3)
+outer(x, x, "!=")
+## failed 2005-10-17
+
+
+## add tests for < 0 shape in [dpqr]gamma
+dgamma(1, -2)
+pgamma(1, -2)
+qgamma(0.95, -2)
+rgamma(3, -20)
+## all errors < 2.1.1, now NaNs
+
+
+## Make sure reference to local environment is serialized
+f <- function() { function(){} }
+serialize(f(), NULL)
+##
+
+
+## dummy_vfprintf with overlong format
+xx <- paste(rep("a", 10000), collapse="+")
+con <- gzfile("test.gz", "w")
+writeLines(xx, con)
+close(con)
+unlink("test.gz")
+## segfaulted in 2.2.0 on some x86_64 systems.
+
+
+## format() with *.marks:
+x <- 1.2345 + 10^(0:5)
+ff <- format(x, width = 11, big.mark = "'")
+stopifnot(nchar(ff) == 12)
+## small marks test
+f2 <- format(x, big.mark = "'", small.mark="_", small.interval = 2)
+nc <- nchar(f2)
+stopifnot(substring(f2, nc,nc) != "_", # no traling small mark
+ nc == nc[1])# all the same
+fc <- formatC(1.234 + 10^(0:8), format="fg", width=11, big.mark = "'")
+stopifnot(nchar(fc) == 11)
+## had non-adjusted strings before 2.3.0
+
+
+## data.matrix on zero-length columns
+DF <- data.frame(x=c("a", "b"), y=2:3)[FALSE,]
+stopifnot(is.numeric(data.matrix(DF)))
+# was logical in 2.2.1.
+DF <- data.frame(a=I(character(0)))
+X <- data.matrix(DF)
+stopifnot(is.numeric(X))
+## gave logical matrix in 2.2.1.
+
+stopifnot(pbirthday(950, coincident=250) == 0,
+ pbirthday(950, coincident=200) > 0)
+## gave error before 2.3.0
+
+
+## raw matrices (PR#8529/30)
+v <- as.raw(c(1:6))
+dim(v) <- c(2,3)
+dimnames(v) <- list(c("x","y"), c("P", "Q", "R"))
+v
+s <- as.raw(c(11:16))
+dim(s) <- c(2,3)
+s
+rbind(s,v,v)
+(m <- cbind(s,v,v,s))
+m[2,4] <- as.raw(254)
+m
+m[1:2,2:4] <- s
+m
+## unimplemented before 2.3.0
+
+
+## window with non-overlapping ranges (PR#8545)
+test <- ts(1:144, start=c(1,1), frequency=12)
+window(test, start=c(15,1), end=c(17,1), extend=TRUE)
+## failed < 2.3.0
+
+
+## pbinom(size=0) gave NaN (PR#8560)
+x <- c(-1,0,1,2)
+stopifnot(identical(pbinom(x, size = 0, p = 0.5), c(0,1,1,1)))
+## 2.2.1 gave NaN in all cases (forced explicitly in C code).
+
+
+## Limits on [dpqr]nbinom and [dqpr]geom
+stopifnot(is.nan(dnbinom(0, 1, 0)), dnbinom(0, 1, 1) == 1,
+ pnbinom(c(-1, 0, 1), 1, 1) == c(0, 1, 1),
+ is.nan(pnbinom(0, 1, 0)),
+ qnbinom(0.5, 1, 1) == 0,
+ is.nan(qnbinom(0.5, 1, 0)),
+ is.finite(rnbinom(1, 1, 1)),
+ !is.finite(rnbinom(1, 1, 0)))
+## d allowed p=0, [pq] disallowed p=1 for R < 2.3.0, r gave NaN for p=1.
+stopifnot(is.nan(dgeom(0, 0)), dgeom(0, 1) == 1,
+ pgeom(c(-1, 0, 1), 1) == c(0, 1, 1), is.nan(pgeom(0, 0)),
+ qgeom(0.5, 1) == 0, is.nan(qgeom(0.5, 0)),
+ is.finite(rgeom(1, 1)),
+ !is.finite(rgeom(1, 0)))
+
+
+## A response to PR#8528 incorrectly claimed these to be wrong.
+stopifnot(all.equal(df(0, 2, 2), 1))
+stopifnot(is.infinite(df(0, 1.3, 2)))
+x <- 1e-170
+stopifnot(all.equal(pbeta(x,x,x), 0.5))
+## just a regression check.
+## This underflowed
+stopifnot(all.equal(dbeta(x,x,x), 0.5))
+## this was slow
+stopifnot(system.time(qnbinom(1e-10, 1e3, 1e-7))[3] < 0.1)
+## but this failed
+qnbinom(0.5, 10000000000, 0.000000002)
+## infinite-looped in 2.2.1 (answer is approx 4e18)
+qpois(0.9, 1e50)
+## infinite-looped in 2.2.1
+z <- 10^seq(10, 300, 10)
+stopifnot(all.equal(pt(-z, 1, log=TRUE), pcauchy(-z, 1, log=TRUE)))
+## failed at about 1e150 in 2.2.1
+stopifnot(pt(-1e200, 0.001) > 0)
+## was 0 in 2.2.1, should be about 31%
+
+
+## all.equal.numeric overflowed for large integers
+set.seed(1); r1 <- .Random.seed
+set.seed(2); r2 <- .Random.seed
+stopifnot(is.character(all.equal(r1, r2)))
+## all.equal() gave NA in 2.2.1
+
+
+## support for raw indices in for() was added in 2.3.0
+xx <- as.raw(40:48)
+for(i in xx) print(i)
+## was error < 2.3.0
+
+
+## as.list on a symbol, for S-compatibility
+as.list(as.name("data.frame"))
+## was error in 2.2.1
+
+
+## min ignored INT_MAX, (PR#8731)
+stopifnot(min(.Machine$integer.max) == .Machine$integer.max)
+stopifnot(max(-.Machine$integer.max) == -.Machine$integer.max)
+op <- options(warn=2)
+min(Inf)
+max(-Inf)
+options(op)
+## were +/-Inf with warning in 2.2.1.
+
+
+## PR#8718: invalid usage in R >= 2.7.0
+#a <- matrix(2,2,2)
+#apply(a,1,"$","a")
+#apply(a,1,sum)
+## first apply was corrupting apply() code in 2.2.1
+
+
+## NULL results in apply()
+apply(as.matrix(1), 1, function(x) NULL)
+## was error in 2.2.1.
+
+
+## sum on data frames (PR#8385)
+DF <- data.frame(m1=1:2, m2=3:4)
+sum(DF)
+sum(DF=DF) # needed arg named x
+sum(DF, DF) # failed
+DF[1, 1] <- NA
+stopifnot(is.na(sum(DF)), sum(DF, na.rm=TRUE) == 9)
+## failures < 2.4.0
+
+## plot.lm
+# which=4 failed in R 1.0.1
+par(mfrow=c(1,1), oma= rep(0,4))
+summary(lm.fm2 <- lm(Employed ~ . - Population - GNP.deflator, data = longley))
+for(wh in 1:6) plot(lm.fm2, which = wh)
+
+op <- par(mfrow = c(2,2), mar = .1+c(3,3,2,1), mgp = c(1.5, .6, 0))
+y <- rt(200, df= 3)
+plot(lm(y ~ 1))
+par(op)
+## 4th plot (which = 5: "leverages") failed in 2.2.0 <= R <= 2.3.0
+
+
+## Re-fix PR#8506
+z <- rbind(x = data.frame(a = 1, b = 2), y = data.frame(a = 1, b = 2))
+stopifnot(row.names(z) == c("x", "y"))
+## were NAs (and failed to print) in 2.3.0
+
+dd <- data.frame(x = 3:4)
+stopifnot(identical(rownames(dd), row.names(dd)),
+ identical(rownames(dd), c("1", "2")))
+## one was integer in an intermediate version of "pre 2.4.0"
+
+
+## mean on integer vector ignored NAs
+stopifnot(is.na(mean(NA)))
+## failed in R 2.3.0
+
+
+## title etc failed if passed col etc of length > 1
+plot(1:2)
+title("foo", col=1:3)
+title("foo", cex=1:3)
+title("foo", lty=1:3)
+title("foo", lwd=1:3)
+title("foo", bg=4:7)
+## threw errors in R <= 2.3.0
+
+
+## glm did not allow array offsets
+df1 <- data.frame(u=1:10,
+ v=rpois(10,10),
+ z=array(1,10, dimnames=list(1:10)))
+glm(v ~ u+offset(log(z)), data=df1, family=poisson)
+## was error in R <= 2.3.0
+
+
+## invalid values of a logical vector from bindingIsLocked
+## Martin Morgan, R-devel, 2006-05-14
+e <- new.env()
+e$x <- 1
+e$y <- 2
+lockBinding("x", e)
+stopifnot(bindingIsLocked("x", e), bindingIsLocked("x", e)==TRUE,
+ !bindingIsLocked("y", e), bindingIsLocked("y", e)==FALSE)
+## on some systems in R <= 2.3.0, bindingIsLocked("x", e)==TRUE was false
+
+
+## ccf on non-aligned time series
+x <- ts(rnorm(100), start=1)
+y <- ts(rnorm(120), start=3)
+ccf(x, y)
+## needed na.action=na.contiguous in 2.3.0
+
+
+## merge.data.frame was not making column names unique when
+## doing a Cartesian product.
+DF <- data.frame(col=1:3)
+DF2 <- merge(DF, DF, by=numeric(0))
+stopifnot(identical(names(DF2), c("col.x", "col.y")))
+## both were 'col' in 2.3.0.
+
+
+## [pq]unif were not consistent on infinite ranges.
+stopifnot(is.na(qunif(.5, 0, Inf)))
+## was Inf in 2.3.1.
+stopifnot(is.na(punif(1, 0, Inf)))
+## was 0 in 2.3.1
+## and failed on zero ranges despite the documentation.
+stopifnot(punif(c(0, 1, 2), 1, 1) == c(0, 1, 1))
+stopifnot(qunif(c(0, 0.5, 1), 1, 1) == 1)
+## were all NaN on 2.3.1
+
+
+## cbind segfaulted if coercion of the result to list failed.
+cbind(as.name("foo"), 1:3)
+# segfaulted in 2.3.1
+(x <- cbind(y ~ x, 1))
+x[,1]
+## last is 3 x 2 list matrix
+
+
+## empty point set
+r <- xy.coords(numeric(0))
+## gave an error with misleading message in 2.3.1
+
+
+## [<- could extend a ts but not change tsp.
+xx <- x <- ts(rnorm(6), frequency=7)
+try(x[8] <- NA)
+stopifnot(identical(x, xx))
+## Allowed in R < 2.4.0, but corrupted tsp.
+
+
+## Looking up generic in UseMethod
+mycoef <- function(object, ....) UseMethod("coef")
+x <- list(coefficients=1:3)
+mycoef(x)
+## failed to find default method < 2.4.0
+
+
+## regression tests on changes to model.frame and model.matrix
+A <- data.frame(y = 1:10, z = 1:10+1i,
+ x = rep(c("a", "b"), each = 5),
+ r = as.raw(1:10),
+ stringsAsFactors = FALSE)
+model.frame(z ~ x+y+r, data = A) # includes character, raw and complex
+lm(z ~ x+y, data = A) # complex response, character RHS
+# but we do not allow complex nor raw variables on the rhs
+stopifnot(inherits(try(model.matrix(y ~ x+z, data = A)), "try-error"))
+stopifnot(inherits(try(model.matrix(y ~ r, data = A)), "try-error"))
+## new in 2.4.0
+
+
+## tests of stringsAsFactors
+a <- letters[1:8]
+aa <- matrix(a, 4, 2)
+aaa <- list(aaa=letters[20:23])
+colnames(aa) <- paste("aa", 1:2, sep=".")
+(A <- data.frame(a=a[1:4], aa, aaa, stringsAsFactors = FALSE))
+stopifnot(all(sapply(A, class) == "character"))
+stopifnot(class(as.data.frame(list(a=a), stringsAsFactors = TRUE)$a)
+ == "factor")
+## new in 2.4.0
+
+
+## failure to duplicate in environment<-().
+## Thomas Petzoldt, R-help, 2006-06-23.
+envfun <- function(L) {
+ p <- parent.frame()
+ assign("test", L$test, p)
+ environment(p$test) <- p
+}
+solver <- function(L) envfun(L)
+L <- list(test = function() 1 + 2)
+
+environment(L$test)
+solver(L)
+(e <- environment(L$test))
+stopifnot(identical(e, .GlobalEnv))
+## failed to look at NAMED
+
+
+## sort.list(<a factor>, method="radix") stopped working at some point
+x <- factor(sample(letters, 1000, replace=TRUE))
+o <- sort.list(x, method = "radix")
+## failed in 2.3.1
+
+
+## qt() bisection search: PR#9050
+x <- -2:2
+stopifnot(isTRUE(all.equal(x, qt(pt(x, df=20, ncp=1),df=20,ncp=1))))
+## failed in 2.3.1
+
+
+## poly() didn't pass 'raw' to polym()
+x <- -3:3
+y <- 10*(1:7)
+stopifnot(identical(poly (x,y, degree = 2, raw = TRUE),
+ polym(x,y, degree = 2, raw = TRUE)))
+## failed in 2.3.1
+
+
+## plot.xy( type = "s" | "S" ) was missing an initial test: PR#9046
+types <- c("p", "l", "b", "o", "h", "s", "S")
+p <- palette(hcl(h = seq(30,330, length= length(types))))
+plot(c(1,6), c(-.4, 1.5), type="n", ann = FALSE); off <- 1:6 / 16
+for(i in seq(types)) {
+ lines(i*off /-1:4, type = types[i], col = i, pch = types[i])
+ mtext(types[i], 4, line= .5, at = i*off[6]/4, col = i, las = 1)
+}
+palette(p)# restored to previous
+## failed in 2.3.1
+
+
+## qf for large df2
+stopifnot(isTRUE(all.equal(qf(0.9,df1=1,df2=1e10,ncp=0),
+ qf(0.9,df1=1,df2=1e10))))
+## failed in 2.3.1
+
+
+## some regression tests of as.vector() and as.list()
+x <- list(a=1, b=2)
+stopifnot(identical(x, as.list(x))) # was said to drop names
+x <- pairlist(a=1, b=2)
+stopifnot(is.list(x))
+xx <- as.vector(x, "list")
+stopifnot(typeof(xx) == "list")
+stopifnot(!identical(x, xx))
+stopifnot(identical(names(x), names(xx)))
+
+x <- expression(a=2+3, b=pi)
+xx <- as.vector(x, "list") # not allowed in 2.3.1
+stopifnot(identical(names(x), names(xx)))
+xx <- as.list(x) # lost names in 2.3.1
+stopifnot(identical(names(x), names(xx)))
+## was incorrectly documented in 2.3.1
+
+
+## subsetting arrays preserved attributes, although it did not for matrices
+x <- structure(1:8, names=letters[1:8], comm="a comment", dim = c(2L,2L,2L))
+stopifnot(is.null(attr(x[,,], "comm")))
+x <- structure(1:8, names=letters[1:8], comm="a comment", dim = c(2L,4L))
+stopifnot(is.null(attr(x[,], "comm")))
+x <- structure(1:8, names=letters[1:8], comm="a comment")
+stopifnot(!is.null(attr(x[], "comm"))) # this does preserve
+stopifnot(is.null(attr(x[1:8], "comm")))
+## 2.3.1 preserved the first.
+
+
+## diff() for POSIX(cl)t :
+ds1 <- diff(lsec <- .leap.seconds[1:12])
+(ds2 <- diff(llsec <- as.POSIXlt(lsec))) # in days
+stopifnot(ds1 == ds2)
+## gave different result for POSIXlt up to 2.3.1
+
+
+## format(trim = TRUE, big.mark=",") did not work correctly (PR#9118)
+(a <- format(c(-1,1,10,999,1e6), trim=TRUE))
+(b <- format(c(-1,1,10,999,1e6), big.mark=",", trim=TRUE))
+stopifnot(a[1:4] == b[1:4])
+## no trim in 2.3.1 if big.mark was used.
+
+
+## residuals.glm needed 'y = TRUE' (PR#9124)
+# example for poisson GLM from ?glm
+d.AD <- data.frame(treatment = gl(3,3), outcome = gl(3,1,9),
+ counts = c(18,17,15,20,10,20,25,13,12))
+glm.D93 <- glm(counts ~ outcome + treatment, family = poisson,
+ data = d.AD, y = FALSE)
+residuals(glm.D93, type = "working")
+residuals(glm.D93, type = "partial")
+residuals(glm.D93, type = "response")
+residuals(glm.D93, type = "deviance")
+residuals(glm.D93, type = "pearson")
+## all failed in 2.3.1
+
+
+## anova.mlm failed
+dat<-matrix( c(9,7,8,8,12,11,8,13, 6,5,6,3,6,7,10,9,
+ 10,13,8,13,12,14,14,16, 9,11,13,14,16,12,15,14),
+ ncol = 4, dimnames = list(s=1:8, c=1:4))
+mlmfit <- lm(dat ~ 1)
+anova(mlmfit, X = ~1)
+## worked in 2.2.1, failed in 2.3.1
+
+
+## stopifnot(<expr>) for a long expression (do not wrap the following line!!):
+r <- try(stopifnot(c("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O")),
+ silent = TRUE)
+if(length(grep("TRUE.*TRUE",r)))
+ stop("stopifnot() gives bad message for long expression")
+## happened in 2.3.[01]
+
+
+## rownames on 0-extent matrix (PR#9136)
+A <- matrix(NA, 0, 0)
+stopifnot(identical(rownames(A, do.NULL = FALSE), character(0)))
+stopifnot(identical(colnames(A, do.NULL = FALSE), character(0)))
+## were 'row' etc in 2.3.1.
+
+
+## grep(value = TRUE) sometimes preserved names, sometimes not
+x <- 1:3
+xx <- letters[1:3]
+names(x) <- names(xx) <- xx
+z <- grep(1, x, value = TRUE)
+stopifnot(!is.null(names(z)), names(z) == xx[1])
+z <- grep(1, x, value = TRUE, perl = TRUE)
+stopifnot(!is.null(names(z)), names(z) == xx[1])
+z <- grep("a", xx, value = TRUE)
+stopifnot(!is.null(names(z)), names(z) == xx[1])
+z <- grep("a", xx, value = TRUE, perl = TRUE)
+stopifnot(!is.null(names(z)), names(z) == xx[1])
+z <- agrep("a", xx, value = TRUE)
+stopifnot(!is.null(names(z)), names(z) == xx[1:3])
+## perl=TRUE, agrep did not in 2.3.1, all did not for pre-2.4.0
+x[2] <- xx[2] <- NA
+z <- grep(NA, x, value = TRUE)
+stopifnot(identical(names(z), names(xx)))
+z <- grep(NA, x, value = TRUE, perl = TRUE)
+stopifnot(identical(names(z), names(xx)))
+z <- grep(NA, xx, value = TRUE)
+stopifnot(identical(names(z), names(xx)))
+z <- grep(NA, xx, value = TRUE, perl = TRUE)
+stopifnot(identical(names(z), names(xx)))
+z <- agrep(NA, xx, value = TRUE)
+stopifnot(identical(names(z), names(xx)))
+## always dropped names on NA matches < 2.4.0
+
+
+oo <- options(max.print = 20)
+cc <- capture.output(women)
+options(oo)
+c2 <- capture.output(women[1:10,])
+stopifnot(length(cc) == 1 + 20/2 + 1,
+ identical(cc[-12], c2[1:11]))
+## was wrong for some days in Aug.2006
+
+
+## errors in identical()
+stopifnot(!identical(pairlist(a=1, b=2), pairlist(a=1, aa=2)))
+stopifnot(!identical(structure(pi, a=1, b=2), structure(pi, a=1, aa=2)))
+stopifnot(identical(structure(pi, a=1, b=2), structure(pi, b=2, a=1)))
+## ignored names of pairlists, but tested order of attributes < 2.4.0
+
+
+## failed subassign could leave '*tmp*' around
+## Parlamis Franklin, R-devel, 2006-09-20
+test <- 1:10
+try(test[2:4] <- ls) # fails
+stopifnot(!exists("*tmp*", where=1))
+## was true < 2.4.0
+
+
+## merge on zero-row data frames
+L3 <- LETTERS[1:3]
+d <- data.frame(cbind(x=1, y=1), fac=sample(L3, 1, repl=TRUE))
+e <- d[-1,]
+merge(d, e, by.x = "x", by.y = "x", all.x = TRUE)
+## not allowed <= 2.4.0
+
+
+## PR#9313
+library(stats4)
+g <- function(x, y) -cos(x) + abs(y)
+fit1 <- mle(g, start = list(x = 0, y = 7))
+fit2 <- mle(g, start = list(y = 7, x = 0))
+stopifnot(all.equal(coef(fit1), coef(fit2)))
+## Found different solutions in 2.4.0, as names were not remapped in fit2
+
+
+## PR#9446
+rbind( data.frame(x=1), list(x=2) )
+## was error in 2.4.0 as list gave double row names.
+
+
+## extreme case
+bs <- boxplot.stats(c(1,Inf,Inf,Inf))
+## gave an error in 2.4.0
+
+
+## t.test with one group of size one
+x <- c(23,25,29,27,30,30)
+t.test(x=x[1], y=x[-1], var.equal=TRUE)
+t.test(y=x[1], x=x[-1], var.equal=TRUE)
+## failed in 2.4.0
+
+
+## corrupted "ts" objects
+structure(1:3, class="ts")
+## failed in print method < 2.4.1
+
+
+## PR#9399
+x1 <- "x2"
+x2 <- pi
+rm(x1) # removes x1, not x2
+stopifnot(!exists("x1", .GlobalEnv), exists("x2", .GlobalEnv))
+rm("x2")
+# incorrectly documented <= 2.4.0
+a <- b <- c <- 1
+z <- try(rm(c("a", "b")))
+stopifnot(inherits(z, "try-error"))
+## removed 'a', 'b' and 'c' in 2.4.0
+
+### end of tests added in 2.4.1 ###
+
+
+## translation error in optimize (PR#9438)
+ex2 <- function(x) log((18/41) * x - 2 * x^2) +
+ 16 * log(4 * x^2 - (36/41) * x + (9/41)) +
+ 24 * log((23/82) + (18/41) * x - 2 * x^2)
+opt <- optimise(ex2, lower = 0, upper = 9/41, maximum = TRUE)$maximum
+# there are two global maxima
+stopifnot(abs(opt - 0.187) < 0.01 || abs(opt - 0.033) < 0.01)
+## changed both ends of interval at the first step, gave opt = 0.136
+
+
+## Needlessly failing subassignments
+e <- 1:10
+e[2] <- expression(e)
+e <- pi
+e[2] <- expression(e)
+e <- letters
+e[2] <- expression(e)
+e <- as.raw(1:3)
+e[2] <- list(e=pi)
+## all failed < 2.5.0
+
+
+## uniroot did not allow zero at the end of an interval
+f <- function(x) x-1
+uniroot(f, c(0,2))
+uniroot(f, c(0,1))
+uniroot(f, c(1,2))
+## last two failed in 2.4.x
+
+
+## PR#9360 and PR#9394
+acf(1, lag.max=0, plot=FALSE)
+## gave an error in 2.4.0
+stopifnot( all.equal(ccf(1:3,-(1:3))$acf[2,1,1], -1) )
+## gave positive lag 0 cross-correlation after patching PR#9360
+
+
+## regression tests for complex sum/prod (briefly broken in Jan 2007)
+z <- rnorm(10) + rnorm(10)*(0+1i)
+sum(z)
+(x <- sum(pi, z))
+stopifnot(all.equal(x, sum(pi,Re(z)) + sum(Im(z))*(0+1i)))
+prod(z)
+##
+
+
+## problems with 0-row data frames created by read.table
+x <- structure(list(one = NULL, two = NULL, three = NULL),
+ .Names = c("one", "two", "three"), class = "data.frame")
+y <- data.frame(one=1,two=2,three=3)
+(z <- rbind(x,y))
+stopifnot(dim(z) == c(1, 3))
+(z <- rbind(y,x))
+stopifnot(dim(z) == c(1, 3))
+(z <- rbind(x,x))
+stopifnot(dim(z) == c(0, 3))
+## variously failed or gave zero-column data frame in 2.4.1
+
+
+## tests of partial matching of attributes
+x <- 1:4
+attr(x, "ab") <- 1
+for(y in c("abc", "abcd", "abcde")) {
+ attr(x, y) <- 1
+ stopifnot(is.null(attr(x, "a")))
+}
+# second was '1' on 2.4.1.
+x <- 1:4
+names(x) <- letters[x]
+stopifnot(identical(attr(x, "n"), names(x)))
+x <- as.pairlist(x)
+stopifnot(identical(attr(x, "n"), names(x)))
+## worked for pairlists but not vectors in 2.4.1
+
+
+## which(arr.ind = TRUE) failed to give matrix on a 0-length input
+C <- matrix(1:16, 4)
+(ind <- which(C < 0, arr.ind = TRUE))
+stopifnot(is.matrix(ind))
+## gave integer(0) in 2.4.1
+
+
+## plnorm wrong for out-of-range values (PR#9520)
+stopifnot(plnorm(0, lower.tail=FALSE) == 1, plnorm(0, lower.tail=TRUE) == 0)
+## both lower tail in R < 2.5.0
+
+
+## supsmu with all NA values (PR#9519)
+x <- seq(0, 1, len = 100)
+y <- x + NA
+try(supsmu(x,y))
+## segfaulted < 2.5.0
+
+
+## which.max when max is Inf (PR#9522)
+which.min(c(NA, NA, Inf))
+which.max(c(NA, NA, -Inf, -Inf))
+## were integer(0) in < 2.5.0
+
+
+## str.dendrogram did not work with 'max.level=NA'
+## which has become default when called from str.default():
+cm <- cor(USJudgeRatings)
+hm <- heatmap(cm, symm = TRUE, keep.dendro = TRUE)
+str(hm, max=2) # reasonable
+str(hm) # gave error (less reasonable than above)
+
+
+## [<-.data.frame did not allow deleting the last column (PR#9565)
+DF <- data.frame(x = 1:3, y = 4:6, z = 7:9)
+DF[, "z"] <- NULL
+stopifnot(identical(dim(DF), c(3L, 2L)))
+## 'subscript out of bounds' in 2.4.1.
+
+## new tryCatch() based try() with anonymous function
+v <- try(do.call(function(x) stop("died"), list(1)), silent=TRUE)
+stopifnot(inherits(v, "try-error"))
+## failed in some version of R-devel (2.5.0)
+
+
+## choose(n,k) should be integer if n is
+stopifnot(choose(11,6) == 462)
+## was < 462 on some AMD64 Linux
+
+
+## fix up use of %j" format in strptime (PR#9577)
+x <- strptime(31:33, "%j")
+x
+stopifnot(!is.na(x))
+## day 32 was NA in R < 2.5.0
+
+
+## mosaicplot() broken by undocumented 'bug fix' r39655
+x <- matrix(1:4,2,2)
+mosaicplot(x, sort = seq_len(dim(x)))
+## failed in 2.4.1, fixed in 2.5.0
+
+
+## jitter failed in wierd case (PR#9580)
+stopifnot(is.finite( jitter(c(-1, 3)) ))
+## was repeated NaN in 2.4.1
+
+
+## max.col() problems (PR#9542)
+x <- rep(0, 10)
+dim(x) <- c(1, 10)
+# max.col(x) should be random.
+ans <- numeric(100)
+for(i in 1:100) ans[i] <- max.col(x)
+table(ans)
+stopifnot(any(ans != 10))
+## always gave last in 2.4.1
+
+
+## rep could segfault: Hiroyuki Kawakatsu, R-help, 2007-03-30
+try(rep(each = 0, length.out = 1))
+# segfaulted in 2.4.1
+
+
+## readBin could read beyond the end of a raw vector.
+# Henrik Bengtsson, Rdevel, 2007-04-07
+bfr <- as.raw(1:12)
+(x <- readBin(con=bfr, what="raw", n=20))
+stopifnot(length(x) == 12)
+(x <- readBin(con=bfr, what="integer", n=20))
+stopifnot(length(x) == 3)
+(x <- readBin(con=bfr, what="integer", size=4, n=20))
+stopifnot(length(x) == 3)
+(x <- readBin(con=bfr, what="integer", size=2, n=20))
+stopifnot(length(x) == 6)
+(x <- readBin(con=bfr, what="integer", size=1, n=20))
+stopifnot(length(x) == 12)
+## read too far where size-changing was involved in 2.4.x
+
+
+## density() could give negative values by rounding error (PR#8876)
+x <- c(0.006, 0.002, 0.024, 0.02, 0.034, 0.09, 0.074, 0.072, 0.122,
+ 0.048, 0.044, 0.168)
+result <- density(x, n = 20, from = -1, to = 1)
+stopifnot(result$y >= 0)
+## slightly negative < 2.5.0
+
+
+## bw.SJ() used too small search interval in rare cases:
+bw.SJ(1:20) # error: "no solution in the specified range of bandwidths" in < 2.5.1
+## this is not ok when called as density(1:20, bw = "SJ")
+## [that's a matter of opinion, since the example is ridiculous.]
+
+
+## hexadecimal integer constants failed on some platforms (PR#9648)
+stopifnot(identical(0x10L, 16L))
+## first was 0L on Windows in 2.5.0
+
+
+## rbind failed if the only data frame had 0 rows (PR#9657)
+A <- data.frame(foo=character(0), bar=character(0))
+rbind(A, c(foo="a", bar="b"))
+## failed in 2.5.0
+
+
+## factor() with NA in dimnames():
+x <- matrix(1:2, 2)
+rownames(x) <- factor(c("A", NA))
+## segfaulted <= 2.5.0
+
+
+## return value of median.
+z <- median(integer(0))
+stopifnot(identical(z, NA_integer_))
+z <- median(numeric(0))
+stopifnot(identical(z, NA_real_))
+## returned logical NA in 2.5.0
+
+
+## seq.int on small reversed 'by'
+stopifnot(inherits(try(seq.int(1.2, 1, by=1)), "try-error"))
+## was '1.2' in 2.5.0
+
+
+## subassignment on pairlists: Uwe Ligges on R-help, 2007-05-29
+Call <- call("round", 10.5)
+try({Call[] <- NULL; Call})
+## seqgfaulted in 2.5.0
+
+
+## Bessel bugs for nu < 0:
+x <- seq(0., 3, length = 101)
+nu <- -0.4
+stopifnot(all.equal(besselI(x,nu, TRUE),
+ exp(-x)*besselI(x,nu, FALSE), tol = 1e-13))
+## wrong in 2.5.0
+stopifnot(all.equal(besselY(seq(0.5, 3, 0.5), nu),
+ c(0.309568577942, 0.568866844337, 0.626095631907,
+ 0.544013906248, 0.366321150943, 0.141533189246),
+ tol = 1e-11))
+## wrong numbers in 2.5.0
+
+### end of tests added in 2.5.1 ###
+
+
+## regression tests for unlink and wildcards
+owd <- setwd(tempdir())
+f <- c("ftest1", "ftest2", "ftestmore", "ftest&more")
+file.create(f)
+stopifnot(file.exists(f))
+unlink("ftest?")
+stopifnot(file.exists(f) == c(FALSE, FALSE, TRUE, TRUE))
+unlink("ftest*", recursive = TRUE)
+stopifnot(!file.exists(f))
+
+stopifnot(unlink("no_such_file") == 0) # not an error
+
+dd <- c("dir1", "dir2", "dirs", "moredirs")
+for(d in dd) dir.create(d)
+dir(".")
+file.create(file.path(dd, "somefile"))
+dir(".", recursive=TRUE)
+stopifnot(unlink("dir?") == 1) # not an error
+unlink("dir?", recursive = TRUE)
+stopifnot(file.exists(dd) == c(FALSE, FALSE, FALSE, TRUE))
+unlink("*dir*", recursive = TRUE)
+stopifnot(!file.exists(dd))
+
+# Windows needs short path names for leading spaces
+dir.create(" test")
+dir(".", recursive=TRUE)
+unlink(" test", recursive = TRUE)
+stopifnot(!file.exists(" test"))
+setwd(owd)
+## wildcards were broken in 2.5.0 on Unix, and always on Windows
+
+
+## duplicated columns in a data frame
+x <- matrix(seq(1:12),ncol=3)
+colnames(x) <- c("A","B","A") #a redundant name for column 2
+x.df <- as.data.frame(x)
+stopifnot(x.df[4,3] == x[4,3])
+## wrong column in 2.5.0
+
+
+## it really is unclear if this should work as the fit is to a
+## numeric variable with levels, and the prediction does not have
+## levels. But some people expected it to.
+worms <- data.frame(sex=gl(2,6), Dose=factor(rep(2^(0:5),2)),
+ deaths=c(1,4,9,13,18,20,0,2,6,10,12,16))
+worms$doselin <- unclass(worms$Dose)
+worms.glm <- glm(cbind(deaths, (20-deaths)) ~ sex+ doselin,
+ data=worms, family=binomial)
+predict(worms.glm, new=data.frame(sex="1", doselin=6))
+## failed < 2.6.0
+
+
+## regression test for changes in aggregate.data.frame
+z <- aggregate(state.x77,
+ list(Region = state.region,
+ Cold = state.x77[,"Frost"] > 130),
+ mean)
+stopifnot(sapply(z, class)[1:2] == c("factor", "logical"),
+ identical(levels(z[[1]]), levels(state.region)) )
+f1 <- c("a","b","a","b")
+f2 <- factor(f1, levels=c("b","c","a"), ordered=TRUE)
+z <- aggregate(1:4, list(groups=f1), sum)
+stopifnot(sapply(z, class) == c("character", "integer"))
+z <- aggregate(1:4, list(groups=f2), sum)
+stopifnot(identical(sapply(z, class), list(groups=class(f2), x="integer")),
+ identical(levels(z[[1]]), levels(f2)),
+ is.ordered(z[[1]]) )
+## converted to factors < 2.6.0
+
+
+## formals<- on function with NULL body (PR#9758)
+f <- function() NULL
+g <- alist(a=, b=4, c=)
+formals(f) <- g
+# identical(formals(f), g) is false as g has .Names attribute
+stopifnot(is.null(body(f)), identical(names(formals(f)), names(g)))
+## was function(a, b=4) before 2.6.0
+
+
+## subsetting R.version
+stopifnot(identical("simple.list", class(R.version[1:7])))
+
+
+## <data frame>[[<character>, j]]
+swiss[["Broye", "Agriculture"]]
+swiss[[7, "Agriculture"]]
+swiss[["Broye", 2]]
+swiss[[7, 2]]
+## first and third failed < 2.6.0
+
+
+## load of raw vector from ASCII save
+s1 <- "this is a test string 123"
+r0 <- r1 <- charToRaw(s1)
+save(r1, file="r1-ascii.rda", ascii=TRUE)
+save(r1, file="r1.rda", ascii=FALSE)
+load("r1.rda")
+unlink("r1.rda")
+stopifnot(identical(r1, r0))
+# was OK, but add regression test
+load("r1-ascii.rda")
+unlink("r1-ascii.rda")
+stopifnot(identical(r1, r0))
+## wrong < 2.5.1 patched
+
+
+## match.arg with multiple values (PR#9859)
+x <- letters[1:3]
+y <- c('aa','bb')
+try(match.arg(x,y)) # gave spurious warning
+res <- match.arg(x,y, several.ok = TRUE) # error
+stopifnot(identical(res, y))
+## failed in 2.5.1
+
+
+## sweep() must work with 0-extent matrix/STATS :
+m <- matrix(1:5, 5,0)
+stopifnot(identical(m, sweep(m, 2, apply(m,2, min))))
+## failed in R-devel around 2007-08-31
+
+
+## julian with POSIXlt origin (PR#9908)
+julian(as.POSIXlt("1999-2-1"), origin=as.POSIXlt("1999-1-1"))
+## failed < 2.6.0
+
+### continued in reg-tests-1b.R ###
+
+proc.time()
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-1b.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-1b.R
new file mode 100644
index 0000000000000000000000000000000000000000..59fb16133f44731bcf5f2a195e3c8c397ea01f6d
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-1b.R
@@ -0,0 +1,2103 @@
+## From PR#10000 on, for R < 3.0.0
+
+pdf("reg-tests-1b.pdf", encoding = "ISOLatin1.enc")
+
+## force standard handling for data frames
+options(stringsAsFactors = TRUE)
+## .Machine
+(Meps <- .Machine$double.eps)# and use it in this file
+
+assertWarning <- tools::assertWarning
+assertError <- tools::assertError
+
+## str() for list-alikes :
+"[[.foo" <- function(x,i) x
+x <- structure(list(2), class="foo")
+str(x)
+## gave infinite recursion < 2.6.0
+
+
+curve(sin, -2*pi, 3*pi); pu1 <- par("usr")[1:2]
+curve(cos, add = NA) # add = NA new in 2.14.0
+stopifnot(all.equal(par("usr")[1:2], pu1))
+## failed in R <= 2.6.0
+
+
+## tests of side-effects with CHARSXP caching
+x <- y <- "abc"
+Encoding(x) <- "UTF-8"
+stopifnot(Encoding(y) == "unknown") # was UTF-8 in 2.6.0
+x <- unserialize(serialize(x, NULL))
+stopifnot(Encoding(y) == "unknown") # was UTF-8 in 2.6.0
+## problems in earlier versions of cache
+
+
+## regression test for adding functions to deriv()
+deriv3(~ gamma(y), namevec="y")
+deriv3(~ lgamma(y), namevec="y")
+# failed in R < 2.7.0
+D(quote(digamma(sin(x))),"x")
+D(quote(trigamma(sin(x))),"x")
+D(quote(psigamma(sin(x))),"x")
+D(quote(psigamma(sin(x), 3)),"x")
+n <- 2L; D(quote(psigamma(sin(x), n)),"x")
+## rest are new
+
+
+## .subset2 quirk
+iris[1, c(TRUE, FALSE, FALSE, FALSE, FALSE)]
+iris[1, c(FALSE, FALSE, FALSE, FALSE, TRUE)]
+## failed in 2.6.0
+
+
+## indexing by "": documented as 'no name' and no match
+x <- structure(1:4, names=c(letters[1:3], ""))
+stopifnot(is.na(x[""])) # always so
+stopifnot(is.na(x[NA_character_]))
+z <- tryCatch(x[[NA_character_]], error=function(...) {})
+stopifnot(is.null(z))
+z <- tryCatch(x[[""]], error=function(...) {})
+stopifnot(is.null(z)) # x[[""]] == 4 < 2.7.0
+x[[""]] <- 5 # no match, so should add an element, but replaced.
+stopifnot(length(x) == 5)
+x[""] <- 6 # also add
+stopifnot(length(x) == 6)
+xx <- list(a=1, 2)
+stopifnot(is.null(xx[[""]])) # 2 < 2.7.0
+##
+
+
+## negative n gave choose(n, k) == 0
+stopifnot(isTRUE(all.equal(choose(-1,3),-1)))
+##
+
+
+## by() on 1-column data frame (PR#10506)
+X <- data.frame(a=1:10)
+g <- gl(2,5)
+by(X, g, colMeans)
+## failed in 2.6.1
+
+
+## range.default omitted na.rm on non-numeric objects
+(z <- range(as.Date(c("2007-11-06", NA)), na.rm = TRUE))
+stopifnot(!is.na(z))
+## NAs in 2.6.1
+
+
+## cut() on constant values used the min, not abs(min)
+z <- cut(rep(-1,5), 2)
+stopifnot(!is.na(z))
+##
+
+
+## extreme example of two-sample wilcox.test
+## reported by Wolfgang Huber to R-devel, 2008-01-01
+## normal approximation is way off here.
+wilcox.test(1, 2:60, conf.int=TRUE, exact=FALSE)
+## failed in R < 2.7.0
+
+
+## more corner cases for cor()
+z <- cor(c(1,2,3),c(3,4,6),use="pairwise.complete.obs",method="kendall")
+stopifnot(!is.matrix(x)) # was 1x1 in R < 2.7.0
+Z <- cbind(c(1,2,3),c(3,4,6))
+# next gave 0x0 matrix < 2.7.0
+z <- try(cor(Z[, FALSE], use="pairwise.complete.obs",method="kendall"))
+stopifnot(inherits(z, "try-error"))
+# next gave NA < 2.7.0
+z <- try(cor(numeric(0), numeric(0), use="pairwise.complete.obs",
+ method="kendall"))
+stopifnot(inherits(z, "try-error"))
+##
+
+
+## infinite loop in format.AsIs reported on R-help by Bert Gunter
+## https://stat.ethz.ch/pipermail/r-help/2008-January/149504.html
+z <- rep(Sys.time(),5)
+data.frame(I(z))
+##
+
+
+## drop with length-one result
+x <- matrix(1:4, 4,1, dimnames=list(letters[1:4], NULL))
+stopifnot(identical(names(drop(x)), letters[1:4])) # was OK
+stopifnot(identical(names(drop(x[1,,drop=FALSE])), "a")) # was no names
+stopifnot(identical(names(x[1,]), "a")) # ditto
+# now consistency tests.
+x <- matrix(1, 1, 1, dimnames=list("a", NULL))
+stopifnot(identical(names(x[,]), "a"))
+x <- matrix(1, 1, 1, dimnames=list(NULL, "a"))
+stopifnot(identical(names(x[,]), "a"))
+x <- matrix(1, 1, 1, dimnames=list("a", "b"))
+stopifnot(is.null(names(x[,])))
+## names were dropped in R < 2.7.0 in all cases except the first.
+
+
+## fisher.test with extreme degeneracy PR#10558
+a <- diag(1:3)
+p <- fisher.test(a, simulate.p.value=TRUE)$p.value
+# true value is 1/60, but should not be small
+stopifnot(p > 0.001)
+## was about 0.0005 in 2.6.1 patched
+
+
+## tests of problems fixed by Marc Schwartz's patch for
+## cut/hist for Dates and POSIXt
+Dates <- seq(as.Date("2005/01/01"), as.Date("2009/01/01"), "day")
+months <- format(Dates, format = "%m")
+years <- format(Dates, format = "%Y")
+mn <- unlist(lapply(unname(split(months, years)), table), use.names=FALSE)
+ty <- as.vector(table(years))
+# Test hist.Date() for months
+stopifnot(identical(hist(Dates, "month", plot = FALSE)$counts, mn))
+# Test cut.Date() for months
+stopifnot(identical(as.vector(table(cut(Dates, "month"))), mn))
+# Test cut.Date() for 3 months
+stopifnot(identical(as.vector(table(cut(Dates, "3 months"))),
+ as.integer(colSums(matrix(c(mn, 0, 0), nrow = 3)))))
+# Test hist.Date() for years
+stopifnot(identical(hist(Dates, "year", plot = FALSE)$counts, ty))
+# Test cut.Date() for years
+stopifnot(identical(as.vector(table(cut(Dates, "years"))),ty))
+# Test cut.Date() for 3 years
+stopifnot(identical(as.vector(table(cut(Dates, "3 years"))),
+ as.integer(colSums(matrix(c(ty, 0), nrow = 3)))))
+
+Dtimes <- as.POSIXlt(Dates)
+# Test hist.POSIXt() for months
+stopifnot(identical(hist(Dtimes, "month", plot = FALSE)$counts, mn))
+# Test cut.POSIXt() for months
+stopifnot(identical(as.vector(table(cut(Dtimes, "month"))), mn))
+# Test cut.POSIXt() for 3 months
+stopifnot(identical(as.vector(table(cut(Dtimes, "3 months"))),
+ as.integer(colSums(matrix(c(mn, 0, 0), nrow = 3)))))
+# Test hist.POSIXt() for years
+stopifnot(identical(hist(Dtimes, "year", plot = FALSE)$counts, ty))
+# Test cut.POSIXt() for years
+stopifnot(identical(as.vector(table(cut(Dtimes, "years"))), ty))
+# Test cut.POSIXt() for 3 years
+stopifnot(identical(as.vector(table(cut(Dtimes, "3 years"))),
+ as.integer(colSums(matrix(c(ty, 0), nrow = 3)))))
+## changed in 2.6.2
+
+
+## zero-length args in tapply (PR#10644)
+tapply(character(0), factor(letters)[FALSE], length)
+## failed < 2.6.2
+
+
+## zero-length patterns in gregexpr
+expect <- structure(1:3, match.length=rep(0L, 3), useBytes = TRUE)
+stopifnot(identical(expect, gregexpr("", "abc")[[1]]))
+stopifnot(identical(expect, gregexpr("", "abc", fixed=TRUE)[[1]]))
+stopifnot(identical(expect, gregexpr("", "abc", perl=TRUE)[[1]]))
+## segfaulted < 2.6.2
+
+
+## test of internal argument matching
+stopifnot(all.equal(round(d=2, x=pi), 3.14))
+## used positional matching in 2.6.x
+
+
+## kappa.tri(x, exact=TRUE) wrongly ended using exact=FALSE:
+data(longley)
+fm1 <- lm(Employed ~ ., data = longley)
+stopifnot(all.equal(23845862, kappa(fm1, exact=TRUE)))
+
+
+## names from pairlists (PR#10807, esoteric)
+m <- c("a", "b", "c")
+mp <- pairlist("a", "b", "c")
+x <- 1:3
+names(x) <- mp
+stopifnot(identical(names(x), m)) # OK before
+x <- 1:3
+attr(x, "names") <- mp
+stopifnot(identical(names(x), m)) # rep("a", 3) in 2.6.x
+##
+
+
+## preserving attributes in [<-.data.frame (PR#10873)
+df <- data.frame(a=1:3, b=letters[1:3])
+attr(df,"foo") <- 10
+df[, "b"] <- 10:12
+stopifnot(identical(attr(df, "foo"), 10))
+## dropped attributes < 2.7.0
+
+
+## r<foo> NA warnings, and rnorm(*, mu = +- Inf) consistency
+op <- options(warn=2)
+m <- c(-Inf,Inf)
+stopifnot(rnorm(2, mean = m) == m,
+ rexp (2, Inf) == 0)
+set.seed(11)
+rt(1, Inf)
+R <- list(try(rnorm(2, numeric())),
+ try(rexp (2, numeric())),
+ try(rnorm(2, c(1,NA))),
+ try(rnorm(1, sd = Inf)) )
+options(op)
+stopifnot(sapply(R, function(ch) sub(".* : ", '', ch) ==
+ "(converted from warning) NAs produced\n"))
+## was inconsistent in R < 2.7.0
+
+
+## predict.loess with transformed variables
+set.seed(11)
+y <- 1:100 + rnorm(100)
+od <- data.frame(x=1:100, z=1:100 + rnorm(100, 10))
+nd <- data.frame(x=1:100, z=11:110)
+fit <- loess(y ~ log(x) + log(z), od)
+p1 <- predict(fit, nd) # failed in 2.6.x
+fit.log <- loess(y ~ x + z, log(od))
+p2 <- predict(fit.log, log(nd))
+stopifnot(all.equal(p1, p2))
+
+
+## wishlist PR#11192
+plot(1:10)
+segments(1, 1, 10, 10, col='green')
+segments(numeric(0), numeric(0), numeric(0), numeric(0), col='green')
+## last was error in R < 2.8.0
+
+
+## merging with a zero-row data frame
+merge(NULL, women)
+merge(women, NULL)
+merge(women[FALSE, ], women)
+merge(women, women[FALSE, ])
+## first two failed in 2.7.0
+
+
+## influence.measures() for lm and glm, and its constituents
+if(require(MASS)) {
+ fit <- lm(formula = 1000/MPG.city ~ Weight + Cylinders + Type + EngineSize + DriveTrain, data = Cars93)
+ gf <- glm(formula(fit), data=Cars93) # should be "identical"
+ im1 <- influence.measures(fit)
+ im2 <- influence.measures(gf)
+ stopifnot(all.equal(im1[1:2], im2[1:2]),
+ all.equal(unname(im1$infmat[,1:15]), unname(dfbetas(fit))),
+ all.equal(im1$infmat[,"dffit"], dffits(fit)),
+ all.equal(im1$infmat[,"cov.r"], covratio(fit)),
+ all.equal(im1$infmat[,"cook.d"], cooks.distance(fit)),
+ all.equal(im2$infmat[,"cook.d"], cooks.distance(gf)),
+ all.equal(im1$infmat[,"hat"], hatvalues(fit)))
+}
+## "cook.d" part of influence.measures(<glm>) differed in R <= 2.7.0
+
+
+## short list value for dimnames
+n <- matrix(c(1259, 845, 719,390,1360,1053,774,413), nrow = 2, byrow = TRUE)
+dimnames(n)[[1]] <- c("a", "b")
+## was (correctly) an error in R < 2.8.0
+
+
+## glob2rx(pattern, .) with "(", "[" or "{" in pattern :
+nm <- "my(ugly[file{name"
+stopifnot(identical(regexpr(glob2rx("*[*"), nm),
+ structure(1L, match.length = 8L, useBytes = TRUE)),
+ identical(regexpr(glob2rx("*{n*"), nm),
+ structure(1L, match.length = 14L, useBytes = TRUE)),
+ identical(regexpr(glob2rx("*y(*{*"), nm),
+ structure(1L, match.length = 13L, useBytes = TRUE))
+ )
+## gave 'Invalid regular expression' in R <= 2.7.0
+
+
+## showDefault() problem with "unregistered" S3 classes:
+show(structure(1:3, class = "myClass"))
+## failed in R <= 2.7.0
+
+
+## formatC(.., format="fg", flag="#"):
+x <- 0.599 * c(.1, .01, .001, 1e-4,1e-5,1e-6)
+(fCx <- formatC(x, digits=2, format="fg", flag="#"))
+stopifnot(sub(".*(..)$", "\\1", fCx) == "60")
+## dropped the trailing "0" in the last 3 cases, in R <= 2.7.0
+
+
+## c.noquote bug, posted to R-devel by Ray Brownrigg, 2008-06-16
+z <- c(noquote('z'), 'y', 'x', 'w')
+stopifnot(identical(unclass(z), c('z', 'y', 'x', 'w')))
+## repeated third and later args in R < 2.7.1.
+
+## PD found that f==f contains NA when f has NA levels (but no missing value)
+f1 <- factor(c(1, 2, NA), levels = 1:2)
+f2 <- factor(c(1, 2, NA), exclude = NULL)
+stopifnot(identical(f1, factor(c(1,2,NA))),
+ nlevels(f1) == 2, nlevels(f2) == 3,
+ all(f2 == f2), !any(f2 != f2),
+ identical(f1 == f1, c(TRUE,TRUE,NA)))
+
+f. <- f <- factor(c(letters[c(1:3,3:1)],"NA", "d","d", NA), exclude=NULL)
+is.na(f.)[2:3] <- TRUE
+f.
+stopifnot(all(f == f), identical(f == f., f. == f.),
+ identical(2:3, which(is.na(f. == f.))))
+## f == f was wrong in R 1.5.0 -- 2.7.1
+
+
+## data.frame[, <char>] must match exactly
+dd <- data.frame(ii = 1:10, xx = pi * -3:6)
+t1 <- try(dd[,"x"])# partial match
+t2 <- try(dd[,"C"])# no match
+stopifnot(inherits(t1, "try-error"),
+ inherits(t2, "try-error"),
+ ## partial matching is "ok" for '$' {hence don't use for dataframes!}
+ identical(dd$x, dd[,"xx"]))
+## From 2.5.0 to 2.7.1, the non-match indexing gave NULL instead of error
+
+
+## data.frame[ (<NA>), ] when row.names had "NA"
+x <- data.frame(x=1:3, y=2:4, row.names=c("a","b","NA"))
+y <- x [c(2:3, NA),]
+y.ok <- data.frame(x=c(2:3,NA), y=c(3:4,NA), row.names=c("b", "NA", "NA.1"))
+stopifnot(identical(y, y.ok))
+## From 2.5.0 to 2.7.1, y had row name "NA" twice
+
+
+stopifnot(shapiro.test(c(0,0,1))$p.value >= 0)
+## was wrong up to 2.7.1, because of rounding errors (in single precision).
+
+
+stopifnot(rcond(cbind(1, c(3,3))) == 0)
+## gave an error (because Lapack's LU detects exact singularity)
+
+
+## dispatch when primitives are called from lapply.
+x <- data.frame(d=Sys.Date())
+stopifnot(sapply(x, is.numeric) == FALSE)
+# TRUE in 2.7.1, tried to dispatch on "FUN"
+(ds <- seq(from=Sys.Date(), by=1, length=4))
+lapply(list(d=ds), round)
+# failed in 2.7.1 with 'dispatch error' since call had '...' arg
+## related to calls being passed unevaluated by lapply.
+
+
+## subsetting data frames with NA cols
+## Dieter Menne: https://stat.ethz.ch/pipermail/r-help/2008-January/151266.html
+df3 <- data.frame(a=0:10,b=10:20,c=20:30)
+names(df3) <- c("A","B", NA)
+df3[-2]
+df3[, -2]
+df3[1:4, -2]
+df3[c(TRUE,FALSE,TRUE)]
+df3[, c(TRUE,FALSE,TRUE)]
+df3[1:4, c(TRUE,FALSE,TRUE)]
+## all gave 'undefined columns selected', 2.6.1 to 2.7.x
+## note that you can only select columns by number, not by name
+
+
+## nls with weights in an unusual model
+Data <- data.frame(x=c(1,1,1,1,1,2,2,3,3,3,3,3,3,4,4,4,5,5,5,5,6,6,6,6,6,6,
+ 7,7,7,7,7,7,7,7,7,8,8,8, 8,8,8,8,8,8,8,9,9,9,9,9,11,12),
+ y=c(73,73,70,74,75,115,105,107,124,107,116,125,102,144,178,
+ 149,177,124,157,128, 169,165,186,152,181,139,173,151,138,
+ 181,152,188,173,196,180,171,188,174,198, 172, 176,162,188,
+ 182,182,141,191,190,159,170,163,197),
+ weight=c(1, rep(0.1, 51)))
+G.st <- c(k=0.005, g1=50, g2=550)
+# model has length-1 (and 52) variables
+Ta <- min(Data$x)
+Tb <- max(Data$x)
+
+#no weights
+nls(y~((g1)*exp((log(g2/g1))*(1-exp(-k*(x-Ta)))
+ /(1-exp(-k*(Tb-Ta))))), data=Data, start=G.st, trace=TRUE)
+
+#with weights
+nls(y ~ ((g1)*exp((log(g2/g1))*(1-exp(-k*(x-Ta)))/(1-exp(-k*(Tb-Ta))))),
+ data = Data, start = G.st, trace = TRUE, weights = weight)
+## failed for find weights in R <= 2.7.1
+
+
+## barplot(log = "y") with NAs (PR#11585)
+dat <- matrix(1:25, 5)
+dat[2,3] <- NA
+barplot(dat, beside = TRUE, log = "y")
+## failed in 2.7.1
+
+
+## related to PR#12551
+unique("a", c("a", "b"))
+unique(1, 1:2)
+# could seqfault in 2.7.1 on some platforms
+stopifnot(!duplicated(rep("a", 3), "a"))
+## wrong answer in 2.7.1
+
+
+## drop1.lm() bug
+dd <- stackloss ; dd[1,3] <- NA
+rr <- lm(stack.loss ~ ., data=dd, na.action=na.exclude)
+drop1(rr)
+## failed in 2.7.x
+
+
+## explicit row.names=NULL in data.frame()
+stopifnot(identical(row.names(data.frame(x=c(a=1,b=2), row.names=NULL)),
+ c("1", "2")))
+stopifnot(identical(row.names(data.frame(x=c(a=1,b=2))), c("a", "b")))
+## same as default in 2.5.0 <= R < 2.7.2
+
+stopifnot(all.equal(chol2inv(2), matrix(0.25, 1), tolerance = 4*Meps),
+ all.equal(solve(chol2inv(chol(4))), matrix(4, 1), tolerance = 10*Meps))
+## chol2inv() did not accept non-matrices up to 2.7.*
+
+
+## seek should discard pushback. (PR#12640)
+cat(c("1\t2\t3", "4\t5\t6"), file="foo.txt", sep="\n")
+fd <- file("foo.txt",open="rt")
+scan(file=fd,what=double(),n=2)
+seek(con=fd,where=0,origin="start")
+z <- scan(file=fd,what=double(),n=2)
+close(fd)
+unlink("foo.txt")
+stopifnot(identical(z, c(1,2)))
+## changed in 2.7.2 patched
+
+
+## cov / cor / var etc with NAs :
+stopifnot(inherits(try(var(NULL)), "try-error"))## gave NA in 1.2.2
+v0 <- var(0[FALSE]) # gave "'x' is empty" in the past; NA in 1.2.2
+x <- c(1:2,NA)
+v1 <- var(c(1,NA))
+v2 <- var(c(NA,0/0, Inf-Inf))
+sx <- sd(x)# sd() -> var()
+## all three gave "missing observations in cov/cor" for a long time in the past
+is.NA <- function(x) is.na(x) & !is.nan(x)
+stopifnot(is.NA(v1), is.NA(v2), is.NA(sx),
+ all.equal(0.5, var(x, na.rm=TRUE), tol=8*Meps)# should even be exact
+ )
+
+
+## write.dcf() indenting for ".<foo>" (PR#12816)
+zz <- textConnection("foo", "w")
+write.dcf(list(Description = 'what a fat goat .haha'),
+ file = zz, indent=1, width=10)
+stopifnot(substring(foo[-1], 1,1) == " ", length(foo) == 4,
+ foo[4] == " .haha")
+close(zz)
+## was " .haha" (not according to DCF standard)
+
+
+## pdf() with CIDfonts active -- they need MBCS to be supported
+pdf(file = "testCID.pdf", family="Japan1") # << for CIDfonts, pd->fonts is NULL
+try({
+ plot(1,1,pch="", axes=FALSE)
+ text(1,1,"F.1", family="Helvetica")
+})
+dev.off()
+unlink("testCID.pdf")
+## text() seg.faulted up to 2.7.2 (and early 2.8.0-alpha)
+
+
+## PS mixing CIDfonts and Type1 - reverse case
+postscript(file = "testCID.ps", family="Helvetica")
+plot(1,1,pch="", axes=FALSE)
+try(text(1,1,"A",family="Japan1"))
+unlink("testCID.ps")
+## error instead of seg.fault
+
+
+## splinefun with derivatives evaluated to the left of first knot
+x <- 1:10; y <- sin(x)
+splfun <- splinefun(x,y, method='natural')
+x1 <- splfun( seq(0,1, 0.1), deriv=1 )
+x2 <- splfun( seq(0,1, 0.1), deriv=2 )
+x3 <- splfun( seq(0,1, 0.1), deriv=3 )
+stopifnot(x1 == x1[1], x2 == 0, x3 == 0)
+##
+
+
+## glm(y = FALSE), in part PR#1398
+fit <- glm(1:10 ~ I(1:10) + I((1:10)^2), y = FALSE)
+anova(fit)
+## obscure errors < 2.8.0
+
+
+## boundary case in cut.Date (PR#13159)
+d <- as.Date("2008-07-07")
+cut(d, "weeks")
+d <- as.POSIXct("2008-07-07", tz="UTC")
+cut(d, "weeks")
+## failed < 2.8.0
+
+
+### end of tests added for 2.8.x
+
+
+## (Deliberate) overshot in seq(from, to, by) because of fuzz
+stopifnot(seq(0, 1, 0.00025+5e-16) <= 1, seq.int(0, 1, 0.00025+5e-16) <= 1)
+## overshot by about 2e-12 in 2.8.x
+## no longer reaches 1 in 2.11.0 (needed a fuzz of 8e-9)
+
+
+## str() with an "invalid object"
+ob <- structure(1, class = "test") # this is fine
+is.object(ob)# TRUE
+ob <- 1 + ob # << this is "broken"
+is.object(ob)# FALSE - hmm..
+identical(ob, unclass(ob)) # TRUE !
+stopifnot(grep("num 2", capture.output(str(ob))) == 1)
+## str(ob) lead to infinite recursion in R <= 2.8.0
+
+
+## row.names(data.frame(matrixWithDimnames)) (PR#13230)
+rn0 <- c("","Row 2","Row 3")
+A <- matrix(1:6, nrow=3, ncol=2, dimnames=list(rn0, paste("Col",1:2)))
+rn <- row.names(data.frame(A))
+stopifnot(identical(rn, rn0))
+# was 1:3 in R 2.8.0, whereas
+rn0 <- c("Row 1","","Row 3")
+A <- matrix(1:6, nrow=3, ncol=2, dimnames=list(rn0, paste("Col",1:2)))
+rn <- row.names(data.frame(A))
+stopifnot(identical(rn, rn0))
+## used the names.
+
+
+## rounding error in windowing a time series (PR#13272)
+x <- ts(1:290, start=c(1984,10), freq=12)
+window(x, start=c(2008,9), end=c(2008,9), extend=FALSE)
+window(x, start=c(2008,9), end=c(2008,9), extend=TRUE)
+## second failed in 2.8.0
+
+
+## deparse(nlines=) should shrink the result (PR#13299)
+stopifnot(length(deparse(quote(foo(1,2,3)), width.cutoff = 20, nlines=7)) ==1)
+## was 7.
+
+
+## legend did not reset xpd correctly (PR#12756)
+par(xpd = FALSE)
+plot(1)
+legend("top", legend="Tops", xpd=NA, inset=-0.1)
+stopifnot(identical(par("xpd"), FALSE))
+## left xpd as NA
+
+
+## lines.formula with 'subset' and no 'data' needed a tweak
+## (R-help, John Field, 20008-11-14)
+x <- 1:5
+y <- c(1,3,NA,2,5)
+plot(y ~ x, type="n")
+lines(y ~ x, subset = !is.na(y), col="red")
+## error in 2.8.0
+
+
+## prettyNum(*, drop0trailing) erronously dropped 0 in '1e10':
+cn <- c("1.107", "2.3120", "3.14e+0", "4.2305400", "120.0",
+ "5.31e-01", "6.3333e-20", "8.1e100", "9.9e+00", "10.1e-0")
+d <- cn != (pcn <- prettyNum(cn, drop0trailing=TRUE))
+stopifnot(identical(pcn[d],
+ c("2.312", "3.14", "4.23054","120","9.9","10.1")),
+ identical("-3", prettyNum("-3.0",drop0trailing=TRUE)) )
+## first failed, e.g. for 8.1e100
+
+
+## (R-help, 2008-12-01)
+transform(mtcars, t1=3, t2=4)
+## failed in 2.8.0 since extra columns were passed as a list.
+
+
+## deparsing transform failed
+parse(text = deparse(transform))
+## failed in 2.8.0
+
+
+## crashed on some systems (PR#13361)
+matrix(1:4, nrow=2, dimnames=list())
+##
+
+
+## col(as.factor=TRUE) failed
+col(matrix(0, 5, 5), as.factor=TRUE)
+## failed in 2.8.0
+
+
+## qt failure in R-devel in early Dec 2008
+stopifnot(!is.nan(qt(0.1, 0.1)))
+##
+
+
+## formals<- gave wrong result for list body
+f <- f0 <- function(x) list(pi)
+formals(f) <- formals(f)
+stopifnot(identical(body(f), body(f)))
+## had body 'pi' < 2.8.1
+
+
+## body<- failed on a function with no arguments.
+f <- function() {pi}
+body(f) <- 2
+f
+## Failed < 2.8.1
+
+
+## body<- with value a list
+f <- function(x) NULL
+body(f) <- list(pi)
+stopifnot(is.list(body(f))) # was 'pi'
+body(f) <- b0 <- list(a=1, b=2)
+stopifnot(identical(body(f), b0)) # 'a' became an argument
+f <- function(x) NULL
+body(f) <- list(1, 2, 3) # was error
+## pre-2.9.0 behaviour was erratic.
+
+
+## PR#13305
+qr.solve(cbind(as.complex(1:11), as.complex(1)),
+ as.complex(2*(20:30)))
+## failed in 2.8.1
+
+
+## PR#13433: is ....\nEOF an empty last line?
+aa <- "field1\tfield2\n 1\ta\n 2\tb"
+zz <- textConnection(aa)
+res <- read.table(zz, blank.lines.skip = FALSE)
+close(zz)
+stopifnot(nrow(res) == 3)
+## was 4 in 2.8.1
+
+
+## segfault from cbind() reported by Hadley Wickham
+## https://stat.ethz.ch/pipermail/r-devel/2009-January/051853.html
+e <- environment()
+a <- matrix(list(e), ncol = 1, nrow = 2)
+b <- matrix(ncol = 0, nrow = 2) # zero-length
+cbind(a, b)
+cbind(a, b)
+## crashed in 2.9.0
+
+
+## besselI(x, -n) == besselI(x, +n) when n is an integer
+set.seed(7) ; x <- rlnorm(216) ; nu <- c(1,44,111)
+## precision lost warnings {may be gone in the future}:
+suppressWarnings(r <- outer(x, c(-nu, nu), besselI))
+stopifnot(identical(r[,1:3], r[,4:6]))
+## suffered from sin(n * pi) imprecision in R <= 2.8.1
+
+
+## Large sanples in mood.test
+## https://stat.ethz.ch/pipermail/r-help/2009-March/190479.html
+set.seed(123)
+x <- rnorm(50, 10, 5)
+y <- rnorm(50, 2 ,5)
+(z <- mood.test(x, y))
+stopifnot(!is.na(z$p.value))
+## gave warning and incorrect result in 2.8.x
+
+
+## heatmap without dendrogram (PR#13512)
+X <- matrix(rnorm(200),20,10)
+XX <- crossprod(X)
+heatmap(XX, Rowv = NA, revC = TRUE)
+heatmap(XX, Rowv = NA, symm = TRUE)
+## both failed in 2.8.1
+
+
+## sprintf with 0-length args
+stopifnot(identical(sprintf("%d", integer(0L)), character(0L)))
+stopifnot(identical(sprintf(character(0L), pi), character(0L)))
+## new feature in 2.9.0
+
+
+## C-level asLogical(x) or c(<raw>, <number>) did not work
+r <- as.raw(1)
+stopifnot(if(r) TRUE)
+for (type in c("null", "logical", "integer", "double", "complex",
+ "character", "list", "expression"))
+ c(r, r, get(sprintf('as.%s', type))(1))
+## failed before 2.9.0
+
+
+### Non-unique levels in factor should be forbidden from R 2.10.0 on
+c1 <- c("a.b","a"); c2 <- c("c","b.c")
+fi <- interaction(c1, c2)
+stopifnot(length(lf <- levels(fi)) == 3, lf[1] == "a.b.c",
+ identical(as.integer(fi), rep.int(1L, 2)))
+## interaction() failed to produce unique levels before 2.9.1
+
+levs <- c("A","A")
+## warnings since 2009; errors since R 3.4.0 (R-devel, June 2016):
+local({
+ assertError(gl(2,3, labels = levs))
+ assertError(factor(levs, levels=levs))
+ assertError(factor(1:2, labels=levs))
+ })
+## failed in R < 2.10.0
+L <- c("no", "yes")
+x <- (5:1)/10; lx <- paste("0.", 1:5, sep="")
+y <- pi + (-9:9)*2^-53
+z <- c(1:2,2:1) ; names(z) <- nz <- letters[seq_along(z)]
+of <- ordered(4:1)
+stopifnot(identical(factor(c(2, 1:2), labels = L),
+ structure(c(2L, 1:2), .Label = L, class="factor")),
+ identical(factor(x),
+ structure(5:1, .Label = lx, class="factor")),
+ length(levels(factor(y))) == 1, length(unique(y)) == 5,
+ identical(factor(z),
+ structure(z, .Names = nz, .Label = c("1","2"),
+ class="factor")),
+ identical(of, factor(of)))
+## partly failed in R <= 2.9.0, partly in R-devel(2.10.0)
+
+
+## "misuses" of sprintf()
+assertError(sprintf("%S%"))
+assertError(sprintf("%n %g", 1))
+## seg.faulted in R <= 2.9.0
+
+
+## sprintf(., e) where length(as.character(e)) < length(e):
+e <- tryCatch(stop(), error=identity)
+stopifnot(identical(sprintf("%s", e),
+ sprintf("%s", as.character(e))))
+## seg.faulted in R <= 2.9.0
+e <- tryCatch(sprintf("%q %d",1), error=function(e)e)
+e2 <- tryCatch(sprintf("%s", quote(list())), error=function(e)e)
+e3 <- tryCatch(sprintf("%s", quote(blabla)), error=function(e)e)
+stopifnot(inherits(e, "error"), inherits(e2, "error"),inherits(e3, "error"),
+ grep("invalid", c(msg <- conditionMessage(e),
+ msg2 <- conditionMessage(e2),
+ msg3 <- conditionMessage(e3))) == 1:3,
+ 1 == c(grep("%q", msg), grep("language", msg2), grep("symbol", msg3))
+ )
+## less helpful error messages previously
+
+
+## bw.SJ on extreme example
+ep <- 1e-3
+stopifnot(all.equal(bw.SJ(c(1:99, 1e6), tol = ep), 0.725, tolerance = ep))
+## bw.SJ(x) failed for R <= 2.9.0 (in two ways!), when x had extreme outlier
+
+
+## anyDuplicated() with 'incomp' ...
+oo <- options(warn=2) # no warnings allowed
+stopifnot(identical(0L, anyDuplicated(c(1,NA,3,NA,5), incomp=NA)),
+ identical(5L, anyDuplicated(c(1,NA,3,NA,3), incomp=NA)),
+ identical(4L, anyDuplicated(c(1,NA,3,NA,3), incomp= 3)),
+ identical(0L, anyDuplicated(c(1,NA,3,NA,3), incomp=c(3,NA))))
+options(oo)
+## missing UNPROTECT and partly wrong in development versions of R
+
+
+## test of 'stringsAsFactors' argument to expand.grid()
+z <- expand.grid(letters[1:3], letters[1:4], stringsAsFactors = TRUE)
+stopifnot(sapply(z, class) == "factor")
+z <- expand.grid(letters[1:3], letters[1:4], stringsAsFactors = FALSE)
+stopifnot(sapply(z, class) == "character")
+## did not work in 2.9.0, fixed in 2.9.1 patched
+
+
+## print.srcref should not fail; a bad encoding should fail; neither should
+## leave an open connection
+nopen <- nrow(showConnections())
+tmp <- tempfile()
+cat( c( "1", "a+b", "2"), file=tmp, sep="\n")
+p <- parse(tmp)
+print(p)
+con <- try(file(tmp, open="r", encoding="unknown"))
+unlink(tmp)
+stopifnot(inherits(con, "try-error") && nopen == nrow(showConnections()))
+##
+
+
+## PR#13574
+x <- 1:11; y <- c(6:1, 7, 11:8)
+stopifnot(all.equal(cor.test(x, y, method="spearman", alternative="greater")$p.value,
+ cor.test(x, -y, method="spearman", alternative="less")$p.value))
+## marginally different < 2.9.0 patched
+
+
+## median should work on POSIXt objects (it did in 2.8.0)
+median(rep(Sys.time(), 2))
+## failed in 2.8.1, 2.9.0
+
+
+## repeated NA in dim() (PR#13729)
+L0 <- logical(0)
+try(dim(L0) <- c(1,NA,NA))
+stopifnot(is.null(dim(L0)))
+L1 <- logical(1)
+try(dim(L1) <- c(-1,-1))
+stopifnot(is.null(dim(L)))
+## dim was set in 2.9.0
+
+
+## as.character(<numeric>)
+nx <- 0.3 + 2e-16 * -2:2
+stopifnot(identical("0.3", unique(as.character(nx))),
+ identical("0.3+0.3i", unique(as.character(nx*(1+1i)))))
+## the first gave ("0.300000000000000" "0.3") in R < 2.10.0
+
+
+## aov evaluated a test in the wrong place ((PR#13733)
+DF <- data.frame(y = c(rnorm(10), rnorm(10, mean=3), rnorm(10, mean=6)),
+ x = factor(rep(c("A", "B", "C"), c(10, 10, 10))),
+ sub = factor(rep(1:10, 3)))
+## In 2.9.0, the following line raised an error because "x" cannot be found
+junk <- summary(aov(y ~ x + Error(sub/x), data=DF, subset=(x!="C")))
+## safety check added in 2.9.0 evaluated the call.
+
+
+## for(var in seq) .. when seq is modified "inside" :
+x <- c(1,2); s <- 0; for (i in x) { x[i+1] <- i + 42.5; s <- s + i }
+stopifnot(s == 3)
+## s was 44.5 in R <= 2.9.0
+
+
+## ":" at the boundary
+M <- .Machine$integer.max
+s <- (M-2):(M+.1)
+stopifnot(is.integer(s), s-M == -2:0)
+## was "double" in R <= 2.9.1
+
+
+## too many columns model.matrix()
+dd <- as.data.frame(sapply(1:40, function(i) gl(2, 100)))
+(f <- as.formula(paste("~ - 1 + ", paste(names(dd), collapse = ":"), sep = "")))
+e <- tryCatch(X <- model.matrix(f, data = dd), error=function(e)e)
+stopifnot(inherits(e, "error"))
+## seg.faulted in R <= 2.9.1
+
+
+## seq_along( <obj> )
+x <- structure(list(a = 1, value = 1:7), class = "FOO")
+length.FOO <- function(x) length(x$value)
+stopifnot(identical(seq_len(length(x)),
+ seq_along(x)))
+## used C-internal non-dispatching length() in R <= 2.9.1
+
+
+## factor(NULL)
+stopifnot(identical(factor(), factor(NULL)))
+## gave an error from R ~1.3.0 to 2.9.1
+
+
+## methods() gave two wrong warnings in some cases:
+op <- options(warn = 2)# no warning, please!
+m1 <- methods(na.omit) ## should give (no warning):
+##
+setClass("bla")
+setMethod("na.omit", "bla", function(object, ...) "na.omit(<bla>)")
+(m2 <- methods(na.omit)) ## should give (no warning):
+stopifnot(identical(m1, .S3methods("na.omit")))
+options(op)
+## gave two warnings, when an S3 generic had turned into an S4 one
+
+
+## raw vector assignment with NA index
+x <- charToRaw("abc")
+y <- charToRaw("bbb")
+x[c(1, NA, 3)] <- x[2]
+stopifnot(identical(x, y))
+## used to segfault
+
+
+## Logic operations with complex
+stopifnot(TRUE & -3i, FALSE | 0+1i,
+ TRUE && 1i, 0+0i || 1+0i)
+## was error-caught explicitly in spite of contrary documentation
+
+
+## Tests of save/load with different types of compression
+x <- xx <- 1:1000
+test1 <- function(ascii, compress)
+{
+ tf <- tempfile()
+ save(x, ascii = ascii, compress = compress, file = tf)
+ load(tf)
+ stopifnot(identical(x, xx))
+ unlink(tf)
+}
+for(compress in c(FALSE, TRUE))
+ for(ascii in c(TRUE, FALSE)) test1(ascii, compress)
+for(compress in c("bzip2", "xz"))
+ for(ascii in c(TRUE, FALSE)) test1(ascii, compress)
+
+
+## tests of read.table with different types of compressed input
+mor <- system.file("data/morley.tab", package="datasets")
+ll <- readLines(mor)
+tf <- tempfile()
+## gzip copression
+writeLines(ll, con <- gzfile(tf)); close(con)
+file.info(tf)$size
+stopifnot(identical(read.table(tf), morley))
+## bzip2 copression
+writeLines(ll, con <- bzfile(tf)); close(con)
+file.info(tf)$size
+stopifnot(identical(read.table(tf), morley))
+## xz copression
+writeLines(ll, con <- xzfile(tf, compression = -9)); close(con)
+file.info(tf)$size
+stopifnot(identical(read.table(tf), morley))
+unlink(tf)
+
+
+## weighted.mean with NAs (PR#14032)
+x <- c(101, 102, NA)
+stopifnot(all.equal(mean(x, na.rm = TRUE), weighted.mean(x, na.rm = TRUE)))
+## divided by 3 in 2.10.0 (only)
+## but *should* give NaN for empty:
+stopifnot(identical(NaN, weighted.mean(0[0])),
+ identical(NaN, weighted.mean(NA, na.rm=TRUE)),
+ identical(NaN, weighted.mean(rep(NA_real_,2), na.rm=TRUE)))
+## all three gave 0 in 2.10.x and 2.11.x (but not previously)
+
+
+## unname() on 0-length vector
+stopifnot(identical(1[FALSE], unname(c(a=1)[FALSE])))
+## failed to drop names in 2.10.0
+
+
+## complete.cases on 0-column data frame
+complete.cases(data.frame(1:10)[-1])
+## failed in 2.10.0
+
+
+## PR#14035, converting (partially) unnamed lists to environments.
+(qq <- with(list(2), ls()))
+nchar(qq)
+with(list(a=1, 2), ls())
+## failed in R < 2.11.0
+
+
+## chisq.test with over-long 'x' or 'y' arg
+# https://stat.ethz.ch/pipermail/r-devel/2009-November/055700.html
+x <- y <- rep(c(1000, 1001, 1002), each=5)
+z <- eval(substitute(chisq.test(x,y), list(x=x)))
+z
+z$observed
+## failed in 2.10.0
+
+
+## unsplit(drop = TRUE) on a data frame failed (PR#14084)
+dff <- data.frame(gr1 = factor(c(1,1,1,1,1,2,2,2,2,2,2), levels=1:4),
+ gr2 = factor(c(1,2,1,2,1,2,1,2,1,2,3), levels=1:4),
+ yy = rnorm(11), row.names = as.character(1:11))
+dff2 <- split(dff, list(dff$gr1, dff$gr2), drop=TRUE)
+dff3 <- unsplit(dff2, list(dff$gr1, dff$gr2), drop=TRUE)
+stopifnot(identical(dff, dff3))
+## failed in 2.10.0
+
+
+## mean.difftime ignored its na.rm argument
+z <- as.POSIXct(c("1980-01-01", "1980-02-01", NA, "1980-03-01", "1980-04-01"))
+zz <- diff(z)
+stopifnot(is.finite(mean(zz, na.rm=TRUE)))
+## was NA in 2.10.0
+
+
+## weighted means with zero weights and infinite values
+x <- c(0, 1, 2, Inf)
+w <- c(1, 1, 1, 0)
+z <- weighted.mean(x, w)
+stopifnot(is.finite(z))
+## was NaN in 2.10.x
+
+
+## Arithmetic operations involving "difftime"
+z <- as.POSIXct(c("2009-12-01", "2009-12-02"), tz="UTC")
+(zz <- z[2] - z[1])
+(zzz <- z[1] + zz)
+stopifnot(identical(zzz, z[2]),
+ identical(zz + z[1], z[2]),
+ identical(z[2] - zz, z[1]))
+z <- as.Date(c("2009-12-01", "2009-12-02"))
+(zz <- z[2] - z[1])
+(zzz <- z[1] + zz)
+stopifnot(identical(zzz, z[2]),
+ identical(zz + z[1], z[2]),
+ identical(z[2] - zz, z[1]))
+## failed/gave wrong answers when Ops.difftime was introduced.
+
+
+## quantiles, new possibilities in 2.11.0
+x <- ordered(1:11, labels=letters[1:11])
+quantile(x, type = 1)
+quantile(x, type = 3)
+st <- as.Date("1998-12-17")
+en <- as.Date("2000-1-7")
+ll <- seq(as.Date("2000-1-7"), as.Date("1997-12-17"), by="-1 month")
+quantile(ll, type = 1)
+quantile(ll, type = 3)
+## failed prior to 2.11.0
+
+
+## (asymptotic) point estimate in wilcox.test(*, conf.int=TRUE)
+alt <- eval(formals(stats:::wilcox.test.default)$alternative)
+Z <- c(-2, 0, 1, 1, 2, 2, 3, 5, 5, 5, 7)
+E1 <- sapply(alt, function(a.)
+ wilcox.test(Z, conf.int = TRUE,
+ alternative = a., exact = FALSE)$estimate)
+X <- c(6.5, 6.8, 7.1, 7.3, 10.2)
+Y <- c(5.8, 5.8, 5.9, 6, 6, 6, 6.3, 6.3, 6.4, 6.5, 6.5)
+E2 <- sapply(alt, function(a.)
+ wilcox.test(X,Y, conf.int = TRUE,
+ alternative = a., exact = FALSE)$estimate)
+stopifnot(E1[-1] == E1[1],
+ E2[-1] == E2[1])
+## was continiuity corrected, dependent on 'alternative', prior to 2.10.1
+
+
+## read.table with embedded newlines in header (PR#14103)
+writeLines(c('"B1', 'B2"', 'B3'), "test.dat")
+z <- read.table("test.dat", header = TRUE)
+unlink("test.dat")
+stopifnot(identical(z, data.frame("B1.B2"="B3")))
+## Left part of header to be read as data in R < 2.11.0
+
+
+## switch() with empty '...'
+stopifnot(is.null(switch("A")),
+ is.null(switch(1)), is.null(switch(3L)))
+## the first one hung, 2nd gave error, in R <= 2.10.1
+
+
+## factors with NA levels
+V <- addNA(c(0,0,NA,0,1,1,0,NA,1,1))
+stopifnot(identical(V, V[, drop = TRUE]))
+stopifnot(identical(model.frame(~V), model.frame(~V, xlev = list(V=levels(V)))))
+# dropped NA levels (in two places) in 2.10.1
+V <- c(0,0,NA,0,1,1,0,NA,1,1)
+stopifnot(identical(V, V[, drop = TRUE]))
+stopifnot(identical(model.frame(~V), model.frame(~V, xlev = list(V=levels(V)))))
+## check other cases have not been changed
+
+
+## ks.test gave p=1 rather than p=0.9524 because abs(1/2-4/5)>3/10 was TRUE
+stopifnot(all.equal(ks.test(1:5, c(2.5,4.5))$p.value, 20/21))
+
+
+## NAs in utf8ToInt and v.v.
+stopifnot(identical(utf8ToInt(NA_character_), NA_integer_),
+ identical(intToUtf8(NA_integer_), NA_character_),
+ identical(intToUtf8(NA_integer_, multiple = TRUE), NA_character_))
+## no NA-handling prior to 2.11.0
+
+
+## tcrossprod() for matrix - vector combination
+u <- 1:3 ; v <- 1:5
+## would not work identically: names(u) <- LETTERS[seq_along(u)]
+U <- as.matrix(u)
+stopifnot(identical(tcrossprod(u,v), tcrossprod(U,v)),
+ identical(tcrossprod(u,v), u %*% t(v)),
+ identical(tcrossprod(v,u), tcrossprod(v,U)),
+ identical(tcrossprod(v,u), v %*% t(u)))
+## tcrossprod(v,U) and (U,v) wrongly failed in R <= 2.10.1
+
+
+## det() and determinant() in NA cases
+m <- matrix(c(0, NA, 0, NA, NA, 0, 0, 0, 1), 3,3)
+m0 <- rbind(0, cbind(0, m))
+if(FALSE) { ## ideally, we'd want -- FIXME --
+stopifnot(is.na(det(m)), 0 == det(m0))
+} else print(c(det.m = det(m), det.m0 = det(m0)))
+## the first wrongly gave 0 (still gives .. FIXME)
+
+
+## c/rbind(deparse.level=2)
+attach(mtcars)
+(cn <- colnames(cbind(qsec, hp, disp)))
+stopifnot(identical(cn, c("qsec", "hp", "disp")))
+(cn <- colnames(cbind(qsec, hp, disp, deparse.level = 2)))
+stopifnot(identical(cn, c("qsec", "hp", "disp")))
+(cn <- colnames(cbind(qsec, log(hp), sqrt(disp))))
+stopifnot(identical(cn, c("qsec", "", "")))
+(cn <- colnames(cbind(qsec, log(hp), sqrt(disp), deparse.level = 2)))
+stopifnot(identical(cn, c("qsec", "log(hp)", "sqrt(disp)")))
+detach()
+## 2.10.1 gave no column names for deparse.level=2
+
+
+## Infinite-loops with match(incomparables=)
+match(c("A", "B", "C"), "A", incomparables=NA)
+match(c("A", "B", "C"), c("A", "B"), incomparables="A")
+## infinite-looped in 2.10.1
+
+
+## path.expand did not propagate NA
+stopifnot(identical(c("foo", NA), path.expand(c("foo", NA))))
+## 2.10.1 gave "NA"
+
+
+## prettyNum(drop0trailing=TRUE) mangled complex values (PR#14201)
+z <- c(1+2i, 1-3i)
+str(z) # a user
+stopifnot(identical(format(z, drop0trailing=TRUE), as.character(z)))
+## 2.10.1 gave 'cplx [1:2] 1+2i 1+3i'
+
+
+## "exact" fisher.test
+dd <- data.frame(group=1, score=c(rep(0,14), rep(1,29), rep(2, 16)))[rep(1:59, 2),]
+dd[,"group"] <- c(rep("DOG", 59), rep("kitty", 59))
+Pv <- with(dd, fisher.test(score, group)$p.value)
+stopifnot(0 <= Pv, Pv <= 1)
+## gave P-value 1 + 1.17e-13 in R < 2.11.0
+
+
+## Use of switch inside lapply (from BioC package ChromHeatMap)
+lapply("forward", switch, forward = "posS", reverse = "negS")
+## failed when first converted to primitive.
+
+
+## evaluation of arguments of log2
+assertError(tryCatch(log2(quote(1:10))))
+## 'worked' in 2.10.x by evaluting the arg twice.
+
+
+## mean with NAs and trim (Bill Dunlap,
+## https://stat.ethz.ch/pipermail/r-devel/2010-March/056982.html)
+stopifnot(is.na(mean(c(1,10,100,NA), trim=0.1)),
+ is.na(mean(c(1,10,100,NA), trim=0.26)))
+## gave error, real value respectively in R <= 2.10.1
+
+
+## all.equal(*, tol) for objects with numeric attributes
+a <- structure(1:17, xtras = c(pi, exp(1)))
+b <- a * (II <- (1 + 1e-7))
+attr(b,"xtras") <- attr(a,"xtras") * II
+stopifnot(all.equal(a,b, tolerance = 2e-7))
+## gave "Attributes: .... relative difference: 1e-07" in R <= 2.10.x
+
+
+## Misuse of gzcon() [PR# 14237]
+(ac <- getAllConnections())
+tc <- textConnection("x", "w")
+try(f <- gzcon(tc)) # -> error.. but did *damage* tc
+newConn <- function(){ A <- getAllConnections(); A[is.na(match(A,ac))] }
+(newC <- newConn())
+gg <- tryCatch(getConnection(newC), error=identity)
+stopifnot(identical(gg, tc))
+close(tc)
+stopifnot(length(newConn()) == 0)
+## getConn..(*) seg.faulted in R <= 2.10.x
+
+
+## splinefun(., method = "monoH.FC")
+x <- 1:7 ; xx <- seq(0.9, 7.1, length=2^12)
+y <- c(-12, -10, 3.5, 4.45, 4.5, 140, 142)
+Smon <- splinefun(x, y, method = "monoH.FC")
+stopifnot(0 <= min(Smon(xx, deriv=1)))
+## slopes in [4.4, 4.66] were slightly negative, because m[] adjustments
+## could be sightly off in cases of adjacency, for R <= 2.11.0
+
+
+## prettyDate( <Date> )
+x <- as.Date("2008-04-22 09:45") + 0:5
+px <- pretty(x, n = 5)
+stopifnot(px[1] == "2008-04-22", length(px) == 6)
+## did depend on the local timezone at first
+
+
+## cut( d, breaks = n) - for d of class 'Date' or 'POSIXt'
+x <- seq(as.POSIXct("2000-01-01"), by = "days", length = 20)
+stopifnot(nlevels(c1 <- cut(x, breaks = 3)) == 3,
+ nlevels(c2 <- cut(as.POSIXlt(x), breaks = 3)) == 3,
+ nlevels(c3 <- cut(as.Date(x), breaks = 3)) == 3,
+ identical(c1, c2))
+## failed in R <= 2.11.0
+
+
+## memDecompress (https://stat.ethz.ch/pipermail/r-devel/2010-May/057419.html)
+char <- paste(replicate(200, "1234567890"), collapse="")
+char.comp <- memCompress(char, type="xz")
+char.dec <- memDecompress(char.comp, type="xz", asChar=TRUE)
+stopifnot(nchar(char.dec) == nchar(char))
+## short in R <= 2.11.0
+
+
+## rbeta() with mass very close to 1 -- bug PR#14291
+set.seed(1)
+if(any(ii <- is.na(rbeta(5000, 100, 0.001))))
+ stop("rbeta() gave NAs at ", paste(which(ii), collapse=", "),
+ "\n")
+## did give several, but platform dependently, in R <= 2.11.0
+
+
+## print.ls_str() should not eval() some objects
+E <- environment((function(miss)function(){})())
+E$i <- 2:4
+E$o <- as.name("foobar")
+E$cl <- expression(sin(x))[[1]]
+ls.str(E)
+## 'o' failed in R <= 2.11.0 (others in earlier versions of R)
+
+
+## print() {& str()} should distinguish named empty lists
+stopifnot(identical("named list()",
+ capture.output(list(.=2)[0])))
+## was just "list()" up to R <= 2.11.x
+
+
+## stripchart with empty first level (PR#14317)
+stripchart(decrease ~ treatment, data = OrchardSprays,
+ subset = treatment != "A")
+## failed in 2.11.1
+
+
+## versions of pre-2.12.0 using zlib 1.2.[45] failed
+zz <- gzfile("ex.gz", "w") # compressed file
+cat("TITLE extra line", "2 3 5 7", "", "11 13 17", file = zz, sep ="\n")
+close(zz)
+blah <- file("ex.gz", "r")
+stopifnot(seek(blah) == 0)
+## gave random large multiple of 2^32 on Linux systems attempting to
+## use LFS support.
+
+
+## pre-2.12.0 wrongly accessed 0-length entries
+o0 <- as.octmode(integer(0))
+stopifnot(identical(o0, o0 & "400"))
+## gave a seg.fault at some point
+
+
+## as.logical on factors
+x <- factor(c("FALSE", "TRUE"))
+stopifnot(identical(as.logical(x), c(FALSE, TRUE)))
+# Lost documented behaviour when taken primitive in R 2.6.0
+stopifnot(identical(as.vector(x, "logical"), c(FALSE, TRUE)))
+# continued to work
+## Reverted in 2.12.0.
+
+
+## missing backquoting of default arguments in in prompt()
+f <- function (FUN = `*`) {}
+pr <- prompt(f, NA)$usage
+stopifnot(identical(pr[2], "f(FUN = `*`)"))
+## see https://stat.ethz.ch/pipermail/r-devel/2010-August/058126.html
+
+
+## cut.POSIXt very near boundaries (PR#14351)
+x <- as.POSIXlt("2010-08-10 00:00:01")
+stopifnot(!is.na(cut(x, "5 hours")))
+## was NA in 2.11.x
+
+
+## summary() on data frames with invalid names -- in UTF-8 locale
+DF <- data.frame(a = 1:3, b = 4:6)
+nm <- names(DF) <- c("\xca", "\xcb")
+cn <- gsub(" ", "", colnames(summary(DF)), useBytes = TRUE)
+stopifnot(identical(cn, nm))
+m <- as.matrix(DF)
+DF <- data.frame(a = 1:3, m=I(m))
+cn <- gsub(" ", "", colnames(summary(DF)), useBytes = TRUE)
+stopifnot(identical(cn, c("a", paste("m.", nm, sep="", collapse=""))))
+## Had NAs in < 2.12.0
+
+
+## [[<- could create invalid objects,
+## https://stat.ethz.ch/pipermail/r-devel/2010-August/058312.html
+z0 <- z <- factor(c("Two","Two","Three"), levels=c("One","Two","Three"))
+z[[2]] <- "One"
+stopifnot(typeof(z) == "integer")
+z[[2]] <- "Two"
+stopifnot(identical(z, z0))
+## failed < 2.12.0
+
+
+## predict.loess with NAs
+cars.lo <- loess(dist ~ speed, cars)
+res <- predict(cars.lo, data.frame(speed = c(5, NA, 25)))
+stopifnot(length(res) == 3L, is.na(res[2]))
+res <- predict(cars.lo, data.frame(speed = c(5, NA, 25)), se = TRUE)
+stopifnot(length(res$fit) == 3L, is.na(res$fit[2]),
+ length(res$se.fit) == 3L, is.na(res$se.fit[2]))
+cars.lo2 <- loess(dist ~ speed, cars, control = loess.control(surface = "direct"))
+res <- predict(cars.lo2, data.frame(speed = c(5, NA, 25)))
+stopifnot(length(res) == 3L, is.na(res[2]))
+res <- predict(cars.lo2, data.frame(speed = c(5, NA, 25)), se = TRUE)
+stopifnot(length(res$fit) == 3L, is.na(res$fit[2]),
+ length(res$se.fit) == 3L, is.na(res$se.fit[2]))
+## Used na.omit prior to 2.12.0
+
+
+## student typo
+try( ksmooth(cars$speed, cars$dists) )
+## now error about y (== NULL); segfaulted <= 2.11.1
+
+
+## do.call()ing NextMethod and empty args:
+try( do.call(function(x) NextMethod('foo'),list()) )
+## segfaulted <= 2.11.1
+
+
+## identical() returned FALSE on external ptr with
+## identical addresses <= 2.11.1
+## Example with getNativeSymbolInfo no longer relevant
+
+
+## getNamespaceVersion() etc
+stopifnot(getNamespaceVersion("stats") == getRversion())
+## failed in R 2.11.x
+
+
+## PR#14383
+x <- rnorm(100)
+z1 <- quantile(x, type = 6, probs = c(0, .5))
+z2 <- quantile(x, type = 6, probs = c(.5, 0))
+stopifnot(z1 == rev(z2))
+## differed in 2.11.x
+
+
+## backSpline() with decreasing knot locations
+require(splines)
+d1 <- c(616.1, 570.1, 523.7, 477.3, 431.3, 386.2, 342.4, 300.4, 260.4,
+ 222.7, 187.8, 155.7, 126.7, 100.8, 78.1, 58.6, 42.2, 28.7,
+ 18.1, 10.2)
+r1 <- c(104.4, 110 , 115.5, 121, 126.6, 132.1, 137.7, 143.2, 148.8,
+ 154.3, 159.9, 165.4, 170.9, 176.5, 182, 187.6, 193.1, 198.7,
+ 204.2, 209.8)
+sp1 <- interpSpline(r1,d1)# 'x' as function of 'y' (!)
+psp1 <- predict(sp1)
+bsp1 <- backSpline(sp1)
+dy <- diff(predict(bsp1, .5 + 18:30)$y)
+stopifnot(-.9 < dy, dy < -.35)
+## failed in R <= 2.11.x: "bizarre jumps"
+detach("package:splines")
+
+
+## PR#14393
+f <- factor(c(NA, 1, 2), levels = 1:3, labels = 1:3)
+mf <- model.frame(~ f, na.action = na.pass, drop.unused.levels = TRUE)
+stopifnot(identical(mf$f, f[,drop=TRUE]))
+## failed to drop < 2.12.0
+
+
+## problem with deparsing variable names of > 500 bytes in model.frame
+## reported by Terry Therneau to R-devel, 2010-10-07
+tname <- paste('var', 1:50, sep='')
+tmat <- matrix(rnorm(500), ncol=50, dimnames=list(NULL, tname))
+tdata <- data.frame(tmat)
+temp1 <- paste( paste(tname, tname, sep='='), collapse=', ')
+temp2 <- paste("~1 + cbind(", temp1, ")")
+foo <- model.frame(as.formula(temp2), tdata)
+## gave invalid variable name.
+
+
+## subassignment to expressions sometimes coerced them to lists.
+x1 <- x2 <- x3 <- expression(a = pi, b = pi^2)
+x1["b"] <- expression(pi^3)
+stopifnot(is.expression(x1)) # OK
+x1["a"] <- NULL
+stopifnot(is.expression(x1))
+x2[["b"]] <- quote(pi^3)
+stopifnot(is.expression(x2)) # OK
+x2[["a"]] <- NULL
+stopifnot(is.expression(x2))
+x3$a <- NULL
+stopifnot(is.expression(x3))
+## coerced to lists
+
+
+## predict on an lm object with type = "terms" and 'terms' specified
+dat <- data.frame(y=log(1:10), x=1:10, fac=rep(LETTERS[11:13],c(3,3,4)))
+fit <- lm(y~fac*x, data=dat)
+pfit <- predict(fit, type="terms", interval="confidence", newdata=dat[7:5,])
+pfit2 <- predict(fit, type="terms", terms=c("x","fac"),
+ interval="confidence", newdata=dat[7:5,])
+pfit2Expected <- lapply(pfit,
+ function(x)if(is.matrix(x))
+ structure(x[, c("x","fac")], constant=attr(x, "constant"))
+ else x)
+stopifnot(identical(pfit2, pfit2Expected))
+## pfit2 failed, and without 'interval' gave se's for all terms.
+
+
+## TRE called assert() on an invalid regexp (PR#14398)
+try(regexpr("a{2-}", ""))
+## terminated R <= 2.12.0
+
+
+## ! on zero-length objects (PR#14244)
+M <- matrix(FALSE, 0, 2)
+stopifnot(identical(attributes(!M), attributes(M)))
+# and for back compatibiility
+!list() # logical(0)
+## dropped all attributes in 2.12.0
+
+
+## Preserve intercepts in drop.terms
+tt <- terms(~ a + b - 1)
+tt2 <- terms(~ b - 1)
+stopifnot(identical(drop.terms(tt, 1), tt2))
+stopifnot(identical(tt[2], tt2))
+stopifnot(identical(tt[1:2], tt))
+## reset intercept term < R 2.13.0
+
+
+## Test new defn of cmdscale()
+mds <- cmdscale(eurodist, eig = TRUE, k = 14)
+stopifnot(ncol(mds$points) < 14L) # usually 11.
+## Used negative eigenvalues in 2.12.0
+
+
+## Sweave regression test moved to utils/tests.
+
+
+## mapply() & sapply() should not simplify e.g. for "call":
+f2 <- function(i,j) call(':',i,j)
+stopifnot(identical(2:3,
+ dim(sapply(1:3, function(i) list(0, 1:i)))),
+ length(r <- mapply(1:2, c(3,7), FUN= f2)) == 2,
+ length(s <- sapply(1:3, f2, j=7)) == 3)
+## length wrongly were 6 and 9, in R <= 2.12.0
+
+
+## 'sep' in reshape() (PR#14335)
+test <- data.frame(x = rnorm(100), y = rnorm(100), famid = rep(1:50, each=2),
+ time = rep(1:2, 50))
+
+wide <- reshape(data = test, v.names = c("x", "y"), idvar = "famid",
+ timevar = "time", sep = "", direction = "wide")
+stopifnot(identical(names(wide), c("famid", "x1", "y1", "x2", "y2")))
+## was c("famid", "x.1", "y.1", "x.2", "y.2") in R <= 2.12.0
+
+
+## PR#14438
+X <- matrix(0+1:10, ncol = 2)[, c(1,1,2,2)]
+colnames(X) <- c("X1","Dup1", "X2", "Dup2")
+X2 <- qr.X(qr(X))
+X2
+identical(colnames(X), colnames(X2))
+## failed to pivot colnames in R <= 2.12.0
+
+
+## improvements to aggregate.data.frame in 2.13.0
+a <- data.frame(nm = c("a", "b", "a", "b"), time = rep(Sys.time(), 4))
+b <- with(a, aggregate(time, list(nm=nm), max))
+stopifnot(inherits(b$x, "POSIXt"))
+##
+
+
+## pretty(<only non-finite>) PR#14468
+stopifnot(length(pretty(-2:1 / 0)) == 0)
+## gave an error in R <= 2.12.1
+
+
+## revised behaviour of as.POSIXlt in R 2.13.0
+x <- c("2001-02-03", "2001-02-03 04:05")
+stopifnot(identical(as.POSIXlt(x), rev(as.POSIXlt(rev(x)))))
+## used different formats earlier
+
+
+## seq.Date could overshoot
+x <- seq(as.Date("2011-01-07"), as.Date("2011-03-01"), by = "month")
+stopifnot(length(x) == 2)
+x <- seq(as.POSIXct("2011-01-07"), as.POSIXct("2011-03-01"), by = "month")
+stopifnot(length(x) == 2)
+## was 3 in R < 2.13.0
+
+
+## mostattributes<- now sometimes works for data frames (PR#14469)
+x <- women
+mostattributes(x) <- attributes(women) # did not set names in R < 2.13.0
+## but there are still problems with row.names (see the help)
+
+
+## naresid.exclude when all cases have been omitted
+## (reported by Simon Wood to R-help, 2011-01-14)
+x <- NA_real_
+na.act <- na.action(na.exclude(x))
+z <- naresid(na.act, rep(0, 0))
+stopifnot(identical(z, x))
+## gave length-0 result
+
+
+## weighted.residuals did not work correctly with mlm fits
+## see https://stat.ethz.ch/pipermail/r-devel/2011-January/059642.html
+d4 <- data.frame(y1=1:4, y2=2^(0:3), wt=log(1:4), fac=LETTERS[c(1,1,2,2)])
+fit <- lm(data=d4, cbind(y1,y2)~fac, weights=wt)
+wtr <- weighted.residuals(fit)
+stopifnot(identical(dim(wtr), 3:2))
+## dropped dims in 2.12.1
+
+
+## ccf did not work with na.action=na.pass
+## https://stat.ethz.ch/pipermail/r-help/2011-January/265992.html
+z <- matrix(rnorm(50),,2); z[6,] <- NA; z <- ts(z)
+acf(z, na.action=na.pass, plot = FALSE)
+ccf(z[,1], z[,2], na.action=na.pass, plot=FALSE)
+## failed in 2.12.1
+
+
+## tests of append mode on compressed connections.
+tf <- tempfile(); con <- gzfile(tf, "w")
+writeLines(as.character(1:50), con)
+close(con); con <- gzfile(tf, "a")
+writeLines(as.character(51:70), con)
+close(con)
+stopifnot(length(readLines(tf)) == 70)
+unlink(tf)
+
+con <- bzfile(tf, "w")
+writeLines(as.character(1:50), con)
+close(con); con <- bzfile(tf, "a")
+writeLines(as.character(51:70), con)
+close(con)
+stopifnot(length(readLines(tf)) == 70)
+unlink(tf)
+
+con <- xzfile(tf, "w")
+writeLines(as.character(1:50), con)
+close(con); con <- xzfile(tf, "a")
+writeLines(as.character(51:70), con)
+close(con)
+stopifnot(length(readLines(tf)) == 70)
+unlink(tf)
+## bzfile warned and did not work R < 2.13.0
+
+
+## NA_complex_ in prettyNum()
+format(c(pi+0i, NA), drop0 = TRUE)
+prettyNum(NA_complex_, drop0 = TRUE)
+## gave errors in R < 2.12.2
+
+
+## Map() needed to call match.fun() itself (PR#14495)
+local({a <- sum; Map("a", list(1:5))})
+## failed R < 2.13.0
+
+
+## correct format() / rounding, print()ing -- (PR#14491)
+stopifnot(format.info(7.921, digits=2) == c(3,1,0),
+ format.info(5.9994001, digits=4) == c(5,3,0))
+## gave (1, 0, 0) in all R versions < 2.13.0
+stopifnot(identical(format(0.2204, digits=3), "0.22"))
+## gave "0.220" previously
+
+
+## regression test for PR#14517
+try(unzip('non-existing_file.zip', list=TRUE, unzip="internal"))
+## crashed on some platforms in pre-2.13.0
+
+
+## plot.formula(*, data=<matrix>) etc
+A <- data.matrix(anscombe)
+plot (y1 ~ x1, data = A, main = "Anscombe's first two sets")
+points(y2 ~ x2, data = A, col=2, pch=2)
+lines (y2 ~ x2, data = A, lwd=2, col="gray")
+## using a matrix failed in R < 2.13.0 *when* there was an extra argument
+
+
+## PR#14530
+dfA <- data.frame(A=1:2, B=3:4, row.names=letters[1:2])
+dfB <- dfA[2:1,]
+res <- try(data.frame(dfA, dfA[2:1,], check.rows=TRUE))
+stopifnot(inherits(res, "try-error"))
+## 'worked' in 2.12.2.
+
+
+## uniroot(f,..) when f(.) == -Inf :
+## now play with different g(.)'s ..
+g <- function(x) exp( 5*sign(x)*abs(x)^2.1 )
+if(FALSE) { ## if you want to see how it *did* go wrong:
+ ff1 <- function(x) {r <- log(g(x)); print(c(x,r)); r}
+ str(ur <- uniroot(ff1, c(-90,100)))
+}
+assertWarning(uniroot(function(x) log(g(x)), c(-90,100)))
+str(ur <- uniroot(function(x) log(g(x)), c(-90,100)))# -> 2 warnings .. -Inf replaced ..
+stopifnot(abs(ur$root) < 0.001)
+## failed badly in R < 2.13.0, as -Inf was replaced by +1e308
+
+
+## as.matrix.dist
+x <- matrix(,0,0)
+d <- dist(x)
+as.matrix(d)
+## Threw an error < 2.13.0
+
+
+## smooth.spline with data with a very small range. (PR#14552)
+dt <- seq(as.POSIXct("2011-01-01"), as.POSIXct("2011-01-01 10:00:00"), by="min")
+x <- as.double(dt)
+y <- sin(seq_along(x) * 3 * pi/180)
+s <- smooth.spline(x, y)
+stopifnot(length(s$x) == length(x))
+## Chose 5 distinct values of x in 2.13.0
+
+
+## readBin on a raw connection
+rawcon <- rawConnection(as.raw(101:110))
+res <- readBin(rawcon, what="integer", size=1, n=4)
+close(rawcon)
+stopifnot(identical(res, 101:104))
+## read the same value repeatedly in 2.13.0
+
+
+## Types of closure bodies
+fun <- eval(substitute(function() x, list(x = environment())))
+body(fun)
+# an external pointer
+y <- file(""); z <- attr(y, "conn_id"); close(y)
+fun <- eval(substitute(function() x, list(x = z)))
+body(fun)
+## not allowed in R < 2.14.0.
+
+
+## Corner cases for signif() and round()
+x <- pi^(-6:6)
+stopifnot(identical(signif(x, -Inf), signif(x, 1L))) # zero in R < 2.14.0
+stopifnot(identical(round(x, -Inf), rep(0, length(x)))) # NAs in R < 2.14.0
+##
+
+
+## (un)stack with character columns
+DF <- data.frame(a = letters[1:3], b = letters[4:6], stringsAsFactors = FALSE)
+DF2 <- stack(DF)
+stopifnot(class(DF2$values) == "character") # was factor
+DF3 <- unstack(DF2) # contained factors
+stopifnot(all(sapply(DF3, class) == "character"))
+DF4 <- stack(DF[1])
+stopifnot(identical(unstack(DF4), DF[1])) # was a list
+## issues in R < 2.14.0
+
+
+## PR#14710 (an instance of PR#8528)
+stopifnot(!is.na(qchisq(p=0.025, df=0.00991)))
+## NaN in 2.13.2
+
+
+## nobs() for zero-weight glm fits:
+DF <- data.frame(x1=log(1:10), x2=c(1/(1:9), NA), y=1:10,
+ wt=c(0,2,0,4,0,6,7,8,9,10))
+stopifnot(nobs(lm(y ~ x1 + x2, weights = wt, data=DF)) ==
+ nobs(glm(y ~ x1 + x2, weights = wt, data = DF)))
+## was 6 and 9 in R < 2.14.1.
+
+
+## anyDuplicated(*, MARGIN=0)
+m. <- m <- cbind(M = c(3,2,7,2),
+ F = c(6,2,7,2))
+rownames(m.) <- LETTERS[1:4]; m.
+stopifnot(identical(attributes(dm <- duplicated(m., MARGIN=0)),
+ attributes(m.)),
+ (dvm <- duplicated(as.vector(m.))) == dm, # all TRUE
+ identical(anyDuplicated( m., MARGIN=0),
+ anyDuplicated(as.vector(m.), MARGIN=0)))
+## gave error in R < 2.14.1
+
+
+## PR#14739
+stopifnot(!is.nan(pbinom(10, 1e6, 0.01, log.p=TRUE)))
+## was NaN thanks to Maechler's misuse of toms708 in 2.11.0.
+
+
+## PR14742
+stopifnot(identical(duplicated(data.frame(c(1, 1)), fromLast = TRUE),
+ duplicated(c(1, 1), fromLast = TRUE)))
+## first ignored fromLast in 2.14.0.
+
+## str(*, list.len, strict.width=.):
+dm <- as.data.frame(matrix( rnorm(10000), nrow=50, ncol=200))
+calls <- list(quote( str(dm, list.len= 7)),
+ quote( str(dm, list.len= 7, digits=10, width=88, strict.width='no')),
+ quote( str(dm, list.len= 7, digits=10, width=88, strict.width='cut')))
+ee <- lapply(calls, function(cl) capture.output(eval(cl)))
+stopifnot(sapply(ee, length) == 1 + 7 + 1)
+## with 'list.len' was not used with 'strict.width="cut"' in R <= 2.14.1
+
+## Tests of serialization (new internal code in 2.15.0)
+input <- pi^(1:10)
+stopifnot(identical(input, unserialize(serialize(input, NULL))))
+stopifnot(identical(input, unserialize(serialize(input, NULL, xdr = FALSE))))
+z <- pi+ 3*1i
+input <- z^(1:10)
+stopifnot(identical(input, unserialize(serialize(input, NULL))))
+stopifnot(identical(input, unserialize(serialize(input, NULL, xdr = FALSE))))
+input <- matrix(1:1000000, 1000, 1000)
+stopifnot(identical(input, unserialize(serialize(input, NULL))))
+stopifnot(identical(input, unserialize(serialize(input, NULL, xdr = FALSE))))
+z <- paste(readLines(file.path(R.home("doc"), "COPYING")), collapse="\n")
+input <- charToRaw(z)
+stopifnot(identical(input, unserialize(serialize(input, NULL))))
+serialize(input, con <- file("serial", "wb")); close(con)
+res <- unserialize(con <- file("serial", "rb")); close(con)
+stopifnot(identical(input, res))
+unlink("serial")
+## Just a test for possible regressions.
+
+
+## mis-PROTECT()ion in printarray C code:
+df <- data.frame(a=1:2080, b=1001:2040, c=letters, d=LETTERS, e=1:1040)
+stopifnot(length(df.ch <- capture.output(df)) == 1+nrow(df))
+## "cannot allocate memory block of size 17179869183.6 Gb" in R <= 2.14.1
+
+
+## logic in one of the many combinations of predict.lm() computations
+fit <- lm(mpg ~ disp+hp, data=mtcars)
+r <- predict(fit, type="terms", terms = 2, se.fit=TRUE)
+stopifnot(dim(r$se.fit) == c(nrow(mtcars), 1))
+## failed in R <= 2.14.1
+
+
+## format.POSIXlt(x) for wrong x
+d0 <- strptime(as.Date(logical(0)), format="%Y-%m-%d", tz = "GMT")
+d0$mday <- 1
+try(format(d0))
+## crashed (Arithmetic exception) for R <= 2.14.1
+
+
+## options("max.print") :
+tools::assertCondition(options(max.print = Inf), "warning") # and then error
+assertError(options(max.print = -2))
+tools::assertCondition(options(max.print = 1e100), "warning")
+## gave only warnings (every print() time, ...) in R <= 2.14.2
+
+
+## attributes with units<- (PR#14839)
+tt <- structure(500, units = "secs", class = "difftime", names = "a")
+tt
+units(tt) <- "mins"
+tt
+stopifnot(identical(names(tt), "a"))
+## R < 2.15.0 changed the name, but then it was not documented to be kept.
+
+
+## predict( VAR(p >= 2) )
+set.seed(42)
+u <- matrix(rnorm(200), 100, 2)
+y <- filter(u, filter=0.8, "recursive")
+est <- ar(y, aic = FALSE, order.max = 2) ## Estimate VAR(2)
+xpred <- predict(object = est, n.ahead = 100, se.fit = FALSE)
+stopifnot(dim(xpred) == c(100, 2), abs(range(xpred)) < 1)
+## values went to +- 1e23 in R <= 2.14.2
+
+
+## regression tests for merge
+d1 <- data.frame(a = 1:10, b = 1:10, b.x = 10:1)
+d2 <- data.frame(a = 1:10, b = 101:110)
+op <- options(warn = 2)
+z <- try(merge(d1, d2, by = 'a'))
+stopifnot(inherits(z, "try-error"))
+merge(d1, d2, by = 'a', suffixes = c("", ".y"))
+z <- try(merge(d1, d2, by = 'a', suffixes = c(".z", ".z")))
+stopifnot(inherits(z, "try-error"))
+options(op)
+# First 'worked' in R < 2.15.0, second was disallowed in early 2012,
+# third 'worked' in R < 2.15.1.
+# example based on package SDMTools::compare.matrix
+# where 'by' is ambiguous.
+x <- expand.grid(x = 1:2, y = 1:2)
+y <- data.frame(x = c(1,2,1,2), y = c(1,1,2,2), z = c(5040,128,1123,3709))
+merge(x, y, all = TRUE)
+names(y)[3] <- "x"
+stopifnot(inherits(try(merge(x, y, all = TRUE)), "try-error"))
+## 'worked' in R < 2.15.1.
+
+
+## misuse of seq() by package 'plotrix'
+stopifnot(inherits(try(seq(1:50, by = 5)), "try-error"))
+## gave 1:50 in R < 2.15.1, with warnings from seq().
+
+
+## regression test for PR#14850 (misuse of dim<-)
+b <- a <- matrix(1:2, ncol = 2)
+`dim<-`(b, c(2, 1))
+stopifnot(ncol(a) == 2)
+## did not duplicate.
+
+
+## deparsing needs escape characters in names (PR#14846)
+f <- function(x) switch(x,"\\dbc"=2,3)
+parse(text=deparse(f))
+## Gave error about unrecognized escape
+
+
+## hclust()'s original algo was not ok for "median" (nor "centroid") -- PR#4195
+n <- 12; p <- 3
+set.seed(46)
+d <- dist(matrix(round(rnorm(n*p), digits = 2), n,p), "manhattan")
+d[] <- d[] * sample(1 + (-4:4)/100, length(d), replace=TRUE)
+hc <- hclust(d, method = "median")
+stopifnot(all.equal(hc$height[5:11],
+ c(1.69805, 1.75134375, 1.34036875, 1.47646406,
+ 3.21380039, 2.9653438476, 6.1418258), tolerance = 1e-9))
+## Also ensure that hclust() remains fast:
+set.seed(1); nn <- 2000
+tm0 <- system.time(dst <- as.dist(matrix(runif(n = nn^2, min = 0, max = 1)^1.1, nn, nn)))
+(tm <- system.time(hc <- hclust(dst, method="average")))
+stopifnot(tm[1] <= tm0[1])
+## was slow from R 1.9.0 up to R 2.15.0
+
+
+## 'infinity' partially matched 'inf'
+stopifnot(as.numeric("infinity") == Inf)
+## was NA in R < 2.15.1
+
+
+## by() failed for a 0-row data frame
+b <- data.frame(ppg.id=1, predvol=2)
+a <- b[b$ppg.id == 2, ]
+by(a, a["ppg.id"], function(x){
+ vol.sum = numeric()
+ id = integer();
+ if(dim(x)[1] > 0) {id = x$ppg.id[1]; vol.sum = sum(x$predvol)}
+ data.frame(ppg.id=id, predVolSum=vol.sum)
+})
+## failed in 2.15.0
+
+
+## model.frame.lm could be fooled if factor levels were re-ordered
+A <- warpbreaks
+fm1 <- lm(breaks ~ wool*tension, data = A, model = TRUE)
+fm2 <- lm(breaks ~ wool*tension, data = A, model = FALSE)
+A$tension <- factor(warpbreaks$tension, levels = c("H", "M", "L"))
+stopifnot(identical(model.frame(fm1), model.frame(fm2)))
+stopifnot(identical(model.frame(fm1), model.frame(fm1, data = A)))
+stopifnot(identical(model.matrix(fm1), model.matrix(fm2)))
+## not true before 2.15.2
+
+
+## model.frame.lm did not make use of predvars
+library(splines)
+fm <- lm(weight ~ ns(height, 3), data = women)
+m1 <- model.frame(fm)[1:3, ]
+m2 <- model.frame(fm, data = women[1:3, ])
+# attributes will differ
+stopifnot(identical(as.vector(m1[,2]), as.vector(m2[,2])))
+## differed in R < 2.15.2
+
+
+## JMC's version of class<- did not work as documented. (PR#14942)
+x <- 1:10
+class(x) <- character()
+class(x) <- "foo"
+class(x) <- character()
+oldClass(x) <- "foo"
+oldClass(x) <- character()
+## class<- version failed: required NULL
+
+
+## anova.lmlist could fail (PR#14960)
+set.seed(1)
+y <- rnorm(20)
+x <- rnorm(20)
+f <- factor(rep(letters[1:2], each = 10))
+model1 <- lm(y ~ x)
+model2 <- lm(y ~ x + f)
+anova(model1, model2, test = "F")
+##
+
+
+## regression test for sunflowerplot's formula method
+sunflowerplot( Sepal.Length ~ Sepal.Width, data = iris, xlab = "A")
+## failed in 2.15.1
+
+
+## misuse of alloca
+for(n in c(200, 722, 1000)) x <- rWishart(1, n, diag(n))
+## failed in various ways in R <= 2.15.1
+
+
+## undocumented used of rep(NULL), from matplot()
+stopifnot(identical(rep(NULL, length.out = 4), NULL))
+## now gives a warning.
+
+
+## PR14974
+a.factor <- as.factor(rep(letters[1:2], 2))
+b.factor <- as.factor(rep(c(1:2), each = 2))
+y <- cbind(aa = as.character(a.factor), bb = b.factor)
+data1 <- data.frame(a.factor, b.factor, y = NA)
+data1$y <- y # inserts a matric
+data1 <- subset(data1, !((a.factor == "b") & (b.factor == 2))) # Delete row
+factorial.data <- data.frame(a.factor, b.factor, row = 1:length(b.factor))
+ans <- merge(factorial.data, data1, by = c("a.factor", "b.factor"),
+ all.x = TRUE)
+stopifnot(is.na(ans[["y"]][4,]))
+## only set the first column of ans[["y"]] to NA.
+
+
+## PR14967
+stopifnot(qgeom(1e-20, prob = 0.1) >= 0)
+## was -1 in R 2.15.1
+
+
+## Regression test for r60116:7
+(p1 <- parse(text="exp(-0.5*u**2)", srcfile=NULL))
+(p2 <- parse(text="exp(-0.5*u^2)", srcfile=NULL))
+stopifnot(identical(p1, p2))
+## p1 was expression(exp((-0.5 * u)^2))
+
+
+## backsolve with k < nrows(rhs)
+r <- rbind(c(1,2,3),c(0,1,1),c(0,0,2))
+b <- c(8,4,2,1)
+x <- backsolve(r, cbind(b,b))
+stopifnot(identical(x[,1], x[,2]))
+## 2.15.1 used elements (4,1), (2,1), (2,2) for second column.
+
+
+## Matrix oddly assumes that solve() drops NULL dimanmes
+A <- diag(3)
+dimnames(A) <- list(NULL, NULL)
+sA <- solve(A)
+stopifnot(is.null(dimnames(sA)))
+# and expm inverts a logical matrix, even though this is not as documented.
+Q <- matrix(c(FALSE, TRUE, TRUE, FALSE), 2, 2)
+is.numeric(Q) # FALSE
+solve(Q)
+## failed in R-devel, which interpreted 'numeric' correctly.
+
+
+## tests of rowsum() with names and for factor groups
+set.seed(123)
+x <- matrix(runif(100), ncol=5)
+group <- sample(1:8, 20, TRUE)
+(xsum <- rowsum(x, group))
+colnames(x) <- letters[16:20]
+(xsum <- rowsum(x, group))
+rowsum(as.data.frame(x), group)
+group <- factor(group)
+(xsum <- rowsum(x, group))
+stopifnot(sapply(dimnames(xsum), is.character))
+rowsum(as.data.frame(x), group)
+## one version had factor row names.
+
+
+## Rather pointless usage in PR#15044
+set.seed(42)
+n <- 10
+y <- rnorm(n)
+x <- rnorm(n)
+w <- rep(0, n)
+lm.wfit(cbind(1, x), y, w)
+## segfaulted in 2.15.1, only
+
+
+## as.data.frame() methods should preferably not barf on an 'nm' arg
+## reported by Bill Dunlap
+## (https://stat.ethz.ch/pipermail/r-devel/2012-September/064848.html)
+as.data.frame(1:10, nm = "OneToTen")
+as.data.frame(LETTERS[1:10], nm = "FirstTenLetters")
+as.data.frame(LETTERS[1:10])
+## second failed in 2.15.1.
+
+
+## Test of stack direction (related to PR#15011)
+f <- function(depth) if(depth < 20) f(depth+1) else Cstack_info()
+(z <- f(0))
+z10 <- f(10)
+if(is.na(z[2]) || is.na(z10[2])) {
+ message("current stack size is not available")
+} else stopifnot(z[2] > z10[2])
+## Previous test ould be defeated by compiler optimization.
+
+
+##
+options(max.print = .Machine$integer.max)
+1 ## segfaulted because of integer overflow
+stopifnot(identical(.Machine$integer.max, getOption("max.print")))
+##
+
+
+## corner cases for arima.sim(), in part PR#15068
+stopifnot(length(arima.sim(list(order = c(0,0,0)), n = 10)) == 10)
+stopifnot(inherits(try(arima.sim(list(order = c(1,0,0), ar = 0.7), n = 0)),
+ "try-error"))
+## one too long in R < 2.15.2
+
+
+## maintainer()
+maintainer('stats')
+maintainer("impossible_package_name")
+## gave an error in R < 2.15.2
+
+
+## PR#15075 and more
+stopifnot(is.finite(c(beta(0.01, 171), beta(171, 0.01), beta(1e-200, 1e-200))))
+## each overflowed to +Inf during calculations in R <= 2.15.2
+
+
+## PR#15077
+default <- 1; z <- eval(bquote(function(y = .(default)) y))
+zz <- function(y = 1) y
+stopifnot(identical(args(z), args(zz))) # zz has attributes
+## was not substituted in R <= 2.15.2
+
+
+## PR#15098
+x <- list()
+x[1:2] <- list(1)
+x[[1]][] <- 2 # change part of first component of x
+x # second component of x should not be affected
+stopifnot(identical(x[[2]], 1))# was 2
+##
+## 2nd example from Comment #5
+x <- list()
+list(1) -> x[1] -> x[2]
+x[[1]][] <- 2
+stopifnot(x[[2]] == 1)## was 2, wrongly, as well ..
+##
+## 3rd example from Comment #5
+y <- list(1)
+x <- list()
+x[1] <- y
+x[[1]][] <- 2
+stopifnot(y[[1]] == 1)## was 2
+## "NAMED": all three were wrong in 2.4.0 <= R <= 2.15.2
+
+
+## PR#15115
+a <- as.name("abc")
+f <- call("==", a, 1L)
+for (i in 2:5)
+ f <- call("+", f, call("==", a, i))
+abc <- 2
+stopifnot(eval(f) == 1)
+## Was 0 in 2.15.2 because the i was not duplicated
+
+
+## Complex subassignment return value
+## From: Justin Talbot to R-devel, 8 Jan 2013
+a <- list( 1 ); b <- (a[[1]] <- a); stopifnot(identical(b, list( 1 )))
+a <- list(x=1); b <- ( a$x <- a); stopifnot(identical(b, list(x=1)))
+## both failed in 2.15.2
+
+
+## TukeyHSD with na.omit = na.exclude, see
+## https://stat.ethz.ch/pipermail/r-help/2012-October/327119.html
+br <- warpbreaks
+br[br$tension == "M", "breaks"] <- NA
+fit1 <- aov(breaks ~ wool + tension, data = br)
+TukeyHSD(fit1, "tension", ordered = TRUE)
+fit2 <- aov(breaks ~ wool + tension, data = br, na.action = na.exclude)
+(z <- TukeyHSD(fit2, "tension", ordered = TRUE))
+stopifnot(!is.na(z$tension))
+## results were NA in R <= 2.15.2
+
+
+## recursive listing of directories
+p <- file.path(R.home("share"),"texmf") # always exists, readable
+lfri <- list.files(p, recursive=TRUE, include.dirs=TRUE)
+subdirs <- c("bibtex", "tex")
+lfnd <- setdiff(list.files(p, all.files=TRUE, no..=TRUE), ".svn")
+stopifnot(!is.na(match(subdirs, lfri)), identical(subdirs, lfnd))
+## the first failed for a few days, unnoticed, in the development version of R
+
+
+## [sd]Quote on 0-length inputs.
+x <- character(0)
+stopifnot(identical(sQuote(x), x), identical(dQuote(x), x))
+## was length one in 2.15.2
+
+## aperm(a, <char>) when a has named dimnames:
+a <- matrix(1:6, 2, dimnames=list(A=NULL, B=NULL))
+stopifnot(identical(unname(aperm(a, c("B","A"))),
+ matrix(1:6, 3, byrow=TRUE)))# worked
+assertError(aperm(a, c("C","A")))# fine, but
+## forgetting one had been detrimental:
+assertError( aperm(a, "A"))
+## seg.faulted in 2.15.2 and earlier
+
+## enc2utf8 failed on NA in non-UTF-8 locales PR#15201
+stopifnot(identical(NA_character_, enc2utf8(NA_character_)))
+## gave "NA" instead of NA_character_
+
+## End of regression tests for R < 3.0.0
+## -------------------------------------
+
+proc.time()
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-1c.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-1c.R
new file mode 100644
index 0000000000000000000000000000000000000000..c3d42ddd60add143939819bde70e1e87678dc9ba
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-1c.R
@@ -0,0 +1,1582 @@
+## Regression tests for R 3.[0-3].*
+
+pdf("reg-tests-1c.pdf", encoding = "ISOLatin1.enc")
+.pt <- proc.time()
+
+## mapply with classed objects with length method
+## was not documented to work in 2.x.y
+setClass("A", representation(aa = "integer"))
+a <- new("A", aa = 101:106)
+setMethod("length", "A", function(x) length(x@aa))
+setMethod("[[", "A", function(x, i, j, ...) x@aa[[i]])
+(z <- mapply(function(x, y) {x * y}, a, rep(1:3, 2)))
+stopifnot(z == c(101, 204, 309, 104, 210, 318))
+## reported as a bug (which it was not) by H. Pages in
+## https://stat.ethz.ch/pipermail/r-devel/2012-November/065229.html
+
+## recyling in split()
+## https://stat.ethz.ch/pipermail/r-devel/2013-January/065700.html
+x <- 1:6
+y <- split(x, 1:2)
+class(x) <- "ABC" ## class(x) <- "A" creates an invalid object
+yy <- split(x, 1:2)
+stopifnot(identical(y, yy))
+## were different in R < 3.0.0
+
+
+## dates with fractional seconds after 2038 (PR#15200)
+## Extremely speculative!
+z <- as.POSIXct(2^31+c(0.4, 0.8), origin=ISOdatetime(1970,1,1,0,0,0,tz="GMT"))
+zz <- format(z)
+stopifnot(zz[1] == zz[2])
+## printed form rounded not truncated in R < 3.0.0
+
+## origin coerced in tz and not GMT by as.POSIXct.numeric()
+x <- as.POSIXct(1262304000, origin="1970-01-01", tz="EST")
+y <- as.POSIXct(1262304000, origin=.POSIXct(0, "GMT"), tz="EST")
+stopifnot(identical(x, y))
+
+## Handling records with quotes in names
+x <- c("a b' c",
+"'d e' f g",
+"h i 'j",
+"k l m'")
+y <- data.frame(V1 = c("a", "d e", "h"), V2 = c("b'", "f", "i"), V3 = c("c", "g", "j\nk l m"))
+f <- tempfile()
+writeLines(x, f)
+stopifnot(identical(count.fields(f), c(3L, 3L, NA_integer_, 3L)))
+stopifnot(identical(read.table(f), y))
+stopifnot(identical(scan(f, ""), as.character(t(as.matrix(y)))))
+
+## docu always said 'length 1 is sorted':
+stopifnot(!is.unsorted(NA))
+
+## str(.) for large factors should be fast:
+u <- as.character(runif(1e5))
+dummy <- str(u); dummy <- str(u); # force compilation of str
+t1 <- max(0.001, system.time(str(u))[[1]]) # get a baseline > 0
+uf <- factor(u)
+(t2 <- system.time(str(uf))[[1]]) / t1 # typically around 1--2
+stopifnot(t2 / t1 < 30)
+## was around 600--850 for R <= 3.0.1
+
+
+## ftable(<array with unusual dimnames>)
+(m <- matrix(1:12, 3,4, dimnames=list(ROWS=paste0("row",1:3), COLS=NULL)))
+ftable(m)
+## failed to format (and hence print) because of NULL 'COLS' dimnames
+
+## regression test formerly in kmeans.Rd, but result differs by platform
+## Artificial example [was "infinite loop" on x86_64; PR#15364]
+rr <- c(rep(-0.4, 5), rep(-0.4- 1.11e-16, 14), -.5)
+r. <- signif(rr, 12)
+k3 <- kmeans(rr, 3, trace=2) ## Warning: Quick-Transfer.. steps exceed
+try ( k. <- kmeans(r., 3) ) # after rounding, have only two distinct points
+ k. <- kmeans(r., 2) # fine
+
+
+## PR#15376
+stem(c(1, Inf))
+## hung in 3.0.1
+
+
+## PR#15377, very long variable names
+x <- 1:10
+y <- x + rnorm(10)
+z <- y + rnorm(10)
+yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy <- y
+fit <- lm(cbind(yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy, z) ~ x)
+## gave spurious error message in 3.0.1.
+
+## PR#15341 singular complex matrix in rcond()
+set.seed(11)
+n <- 5
+A <- matrix(runif(n*n),nrow=n)
+B <- matrix(runif(n*n),nrow=n)
+B[n,] <- (B[n-1,]+B[n-2,])/2
+rcond(B)
+B <- B + 0i
+rcond(B)
+## gave error message (OK) in R 3.0.1: now returns 0 as in real case.
+
+
+## Misuse of formatC as in PR#15303
+days <- as.Date(c("2012-02-02", "2012-03-03", "2012-05-05"))
+(z <- formatC(days))
+stopifnot(!is.object(z), is.null(oldClass(z)))
+## used to copy over class in R < 3.0.2.
+
+
+## PR15219
+val <- sqrt(pi)
+fun <- function(x) (-log(x))^(-1/2)
+(res <- integrate(fun, 0, 1, rel.tol = 1e-4))
+stopifnot(abs(res$value - val) < res$abs.error)
+(res <- integrate(fun, 0, 1, rel.tol = 1e-6))
+stopifnot(abs(res$value - val) < res$abs.error)
+res <- integrate(fun, 0, 1, rel.tol = 1e-8)
+stopifnot(abs(res$value - val) < res$abs.error)
+
+fun <- function(x) x^(-1/2)*exp(-x)
+(res <- integrate(fun, 0, Inf, rel.tol = 1e-4))
+stopifnot(abs(res$value - val) < res$abs.error)
+(res <- integrate(fun, 0, Inf, rel.tol = 1e-6))
+stopifnot(abs(res$value - val) < res$abs.error)
+(res <- integrate(fun, 0, Inf, rel.tol = 1e-8))
+stopifnot(abs(res$value - val) < res$abs.error)
+## sometimes exceeded reported error in 2.12.0 - 3.0.1
+
+
+## Unary + should coerce
+x <- c(TRUE, FALSE, NA, TRUE)
+stopifnot(is.integer(+x))
+## +x was logical in R <= 3.0.1
+
+
+## Attritbutes of value of unary operators
+# +x, -x were ts, !x was not in 3.0.2
+x <- ts(c(a=TRUE, b=FALSE, c=NA, d=TRUE), frequency = 4, start = 2000)
+x; +x; -x; !x
+stopifnot(is.ts(!x), !is.ts(+x), !is.ts(-x))
+# +x, -x were ts, !x was not in 3.0.2
+x <- ts(c(a=1, b=2, c=0, d=4), frequency = 4, start = 2010)
+x; +x; -x; !x
+stopifnot(!is.ts(!x), is.ts(+x), is.ts(-x))
+##
+
+
+## regression test incorrectly in colorRamp.Rd
+bb <- colorRampPalette(2)(4)
+stopifnot(bb[1] == bb)
+## special case, invalid in R <= 2.15.0:
+
+
+## Setting NAMED on ... arguments
+f <- function(...) { x <- (...); x[1] <- 7; (...) }
+stopifnot(f(1+2) == 3)
+## was 7 in 3.0.1
+
+
+## copying attributes from only one arg of a binary operator.
+A <- array(c(1), dim = c(1L,1L), dimnames = list("a", 1))
+x <- c(a = 1)
+B <- A/(pi*x)
+stopifnot(is.null(names(B)))
+## was wrong in R-devel in Aug 2013
+## needed an un-NAMED rhs.
+
+
+## lgamma(x) for very small negative x
+X <- 3e-308; stopifnot(identical(lgamma(-X), lgamma(X)))
+## lgamma(-X) was NaN in R <= 3.0.1
+
+
+## PR#15413
+z <- subset(data.frame(one = numeric()), select = one)
+stopifnot(nrow(z) == 0L)
+## created a row prior to 3.0.2
+
+
+## https://stat.ethz.ch/pipermail/r-devel/2013-September/067524.html
+dbeta(0.9, 9.9e307, 10)
+dbeta(0.1, 9, 9.9e307)
+dbeta(0.1, 9.9e307, 10)
+## first two hung in R <= 3.0.2
+
+## PR#15465 (0-extent matrix / data frame)
+provideDimnames(matrix(nrow = 0, ncol = 1))
+provideDimnames(table(character()))
+as.data.frame(table(character()))
+## all failed in 3.0.2
+
+## PR#15004
+n <- 10
+s <- 3
+l <- 10000
+m <- 20
+x <- data.frame(x1 = 1:n, x2 = 1:n)
+by <- data.frame(V1 = factor(rep(1:3, n %/% s + 1)[1:n], levels = 1:s))
+for(i in 1:m) {
+ by[[i + 1]] <- factor(rep(l, n), levels = 1:l)
+}
+agg <- aggregate.data.frame(x, by, mean)
+stopifnot(nrow(unique(by)) == nrow(agg))
+## rounding caused groups to be falsely merged
+
+## PR#15454
+set.seed(357)
+z <- matrix(c(runif(50, -1, 1), runif(50, -1e-190, 1e-190)), nrow = 10)
+contour(z)
+## failed because rounding made crossing tests inconsistent
+
+## Various cases where zero length vectors were not handled properly
+## by functions in base and utils, including PR#15499
+y <- as.data.frame(list())
+format(y)
+format(I(integer()))
+gl(0, 2)
+z <- list(numeric(0), 1)
+stopifnot(identical(relist(unlist(z), z), z))
+summary(y)
+## all failed in 3.0.2
+
+## PR#15518 Parser catching errors in particular circumstance:
+(ee <- tryCatch(parse(text = "_"), error= function(e)e))
+stopifnot(inherits(ee, "error"))
+## unexpected characters caused the parser to segfault in 3.0.2
+
+
+## nonsense value of nmax
+unique(1:3, nmax = 1)
+## infinite-looped in 3.0.2, now ignored.
+
+
+## besselI() (and others), now using sinpi() etc:
+stopifnot(all.equal(besselI(2.125,-5+1/1024),
+ 0.02679209380095711, tol= 8e-16),
+ all.equal(lgamma(-12+1/1024), -13.053274367453049, tol=8e-16))
+## rel.error was 1.5e-13 / 7.5e-14 in R <= 3.0.x
+ss <- sinpi(2*(-10:10)-2^-12)
+tt <- tanpi( (-10:10)-2^-12)
+stopifnot(ss == ss[1], tt == tt[1], # as internal arithmetic must be exact here
+ all.equal(ss[1], -0.00076699031874270453, tol=8e-16),
+ all.equal(tt[1], -0.00076699054434309260, tol=8e-16))
+## (checked via Rmpfr) The above failed during development
+
+
+## PR#15535 c() "promoted" raw vectors to bad logical values
+stopifnot( c(as.raw(11), TRUE) == TRUE )
+## as.raw(11) became a logical value coded as 11,
+## and did not test equal to TRUE.
+
+
+## PR#15564
+fit <- lm(rnorm(10) ~ I(1:10))
+predict(fit, interval = "confidence", scale = 1)
+## failed in <= 3.0.2 with object 'w' not found
+
+
+## PR#15534 deparse() did not produce reparseable complex vectors
+assert.reparsable <- function(sexp) {
+ deparsed <- paste(deparse(sexp), collapse=" ")
+ reparsed <- tryCatch(eval(parse(text=deparsed)[[1]]), error = function(e) NULL)
+ if (is.null(reparsed))
+ stop(sprintf("Deparsing produced invalid syntax: %s", deparsed))
+ if(!identical(reparsed, sexp))
+ stop(sprintf("Deparsing produced change: value is not %s", reparsed))
+}
+
+assert.reparsable(1)
+assert.reparsable("string")
+assert.reparsable(2+3i)
+assert.reparsable(1:10)
+assert.reparsable(c(NA, 12, NA, 14))
+assert.reparsable(as.complex(NA))
+assert.reparsable(complex(real=Inf, i=4))
+assert.reparsable(complex(real=Inf, i=Inf))
+assert.reparsable(complex(real=Inf, i=-Inf))
+assert.reparsable(complex(real=3, i=-Inf))
+assert.reparsable(complex(real=3, i=NaN))
+assert.reparsable(complex(r=NaN, i=0))
+assert.reparsable(complex(real=NA, i=1))
+assert.reparsable(complex(real=1, i=NA))
+## last 7 all failed
+
+
+## PR#15621 backticks could not be escaped
+stopifnot(deparse(as.name("`"), backtick=TRUE) == "`\\``")
+assign("`", TRUE)
+`\``
+tools::assertError(parse("```"))
+##
+
+
+## We document tanpi(0.5) etc to be NaN
+stopifnot(is.nan(tanpi(c(0.5, 1.5, -0.5, -1.5))))
+## That is not required for system implementations, and some give +/-Inf
+
+
+## PR#15642 segfault when parsing overflowing reals
+as.double("1e1000")
+
+
+ll <- ml <- list(1,2); dim(ml) <- 2:1
+ali <- all.equal(list( ), identity) # failed in R-devel for ~ 30 hours
+al1 <- all.equal(list(1), identity) # failed in R < 3.1.0
+stopifnot(length(ali) == 3, grepl("list", ali[1]),
+ grepl("length", ali[2], ignore.case=TRUE),
+ is.character(al1), length(al1) >= 2,
+ all.equal(ml, ml),
+ all.equal(ll, ml, check.attributes=FALSE))
+
+
+## PR#15699 aggregate failed when there were no grouping variables
+dat <- data.frame(Y = runif(10), X = sample(LETTERS[1:3], 10, TRUE))
+aggregate(Y ~ 1, FUN = mean, data = dat)
+
+
+## merge() with duplicated column names, similar to PR#15618
+X <- data.frame(Date = c("1967-02-01", "1967-02-02", "1967-02-03"),
+ Settle.x = c(NA, NA, NA), Settle.y = c(NA, NA, NA),
+ Settle = c(35.4, 35.15, 34.95))
+Y <- data.frame(Date = c("2013-12-10", "2013-12-11", "2013-12-12"),
+ Settle = c(16.44, 16.65, 16.77))
+merge(X, Y, by = "Date", all = TRUE)
+## failed in R < 3.1.0: now warns (correctly).
+
+
+## PR#15679
+badstructure <- function(depth, key)
+{
+ ch <- if (depth == 1L) list() else list(badstructure(depth-1,key))
+ r <- list()
+ r[[key]] <- ch
+ r
+}
+badstructure(20, "children")
+## overran, segfaulted for the original reporter.
+
+
+## PR#15702 and PR#15703
+d <- as.dendrogram(hclust(dist(sin(1:7))))
+(dl <- d[[c(2,1,2)]]) # single-leaf dendrogram
+stopifnot(inherits(dl, "dendrogram"), is.leaf(dl),
+ identical(attributes(reorder(dl, 1:7)), c(attributes(dl), value = 5L)),
+ identical(order.dendrogram(dl), as.vector(dl)),
+ identical(d, as.dendrogram(d)))
+## as.dendrogram() was hidden; order.*() failed for leaf
+
+
+## using *named* method
+hw <- hclust(dist(sqrt(1:5)), method=c(M = "ward"))
+## failed for 2 days in R-devel/-alpha
+
+
+## PR#15758
+my_env <- new.env(); my_env$one <- 1L
+save(one, file = tempfile(), envir = my_env)
+## failed in R < 3.1.1.
+
+
+## Conversion to numeric in boundary case
+ch <- "0x1.ffa0000000001p-1"
+rr <- type.convert(ch, numerals = "allow.loss")
+rX <- type.convert(ch, numerals = "no.loss")
+stopifnot(is.numeric(rr), identical(rr, rX),
+ all.equal(rr, 0.999267578125),
+ all.equal(type.convert(ch, numerals = "warn"),
+ type.convert("0x1.ffap-1",numerals = "warn"), tol = 5e-15))
+## type.convert(ch) was not numeric in R 3.1.0
+##
+ch <- "1234567890123456789"
+rr <- type.convert(ch, numerals = "allow.loss")
+rX <- type.convert(ch, numerals = "no.loss")
+rx <- type.convert(ch, numerals = "no.loss", as.is = TRUE)
+tools::assertWarning(r. <- type.convert(ch, numerals = "warn.loss"))
+stopifnot(is.numeric(rr), identical(rr, r.), all.equal(rr, 1.234567890e18),
+ is.factor(rX), identical(rx, ch))
+
+
+## PR#15764: integer overflow could happen without a warning or giving NA
+tools::assertWarning(ii <- 1980000020L + 222000000L)
+stopifnot(is.na(ii))
+tools::assertWarning(ii <- (-1980000020L) + (-222000000L))
+stopifnot(is.na(ii))
+tools::assertWarning(ii <- (-1980000020L) - 222000000L)
+stopifnot(is.na(ii))
+tools::assertWarning(ii <- 1980000020L - (-222000000L))
+stopifnot(is.na(ii))
+## first two failed for some version of clang in R < 3.1.1
+
+
+## PR#15735: formulae with exactly 32 variables
+myFormula <- as.formula(paste(c("y ~ x0", paste0("x", 1:30)), collapse = "+"))
+ans <- update(myFormula, . ~ . - w1)
+stopifnot(identical(ans, myFormula))
+
+updateArgument <-
+ as.formula(paste(c(". ~ . ", paste0("w", 1:30)), collapse = " - "))
+ans2 <- update(myFormula, updateArgument)
+stopifnot(identical(ans2, myFormula))
+
+
+## PR#15753
+0x110p-5L # (+ warning)
+stopifnot(.Last.value == 8.5)
+## was 272 with a garbled message in R 3.0.0 - 3.1.0.
+
+
+## numericDeriv failed to duplicate variables in
+## the expression before modifying them. PR#15849
+x <- 10; y <- 10
+d1 <- numericDeriv(quote(x+y),c("x","y"))
+x <- y <- 10
+d2 <- numericDeriv(quote(x+y),c("x","y"))
+stopifnot(identical(d1,d2))
+## The second gave the wrong answer
+
+
+## prettyNum(x, zero.print = .) failed when x had NAs
+pp <- sapply(list(TRUE, FALSE, ".", " "), function(.)
+ prettyNum(c(0:1,NA), zero.print = . ))
+stopifnot(identical(pp[1,], c("0", " ", ".", " ")),
+ pp[2:3,] == c("1","NA"))
+## all 4 prettyNum() would error out
+
+
+## checking all.equal() with externalptr
+library(methods) # getClass()'s versionKey is an e.ptr
+cA <- getClass("ANY")
+stopifnot(all.equal(cA, cA),
+ is.character(all.equal(cA, getClass("S4"))))
+# both all.equal() failed in R <= 3.1.1
+
+
+## as.hexmode(x), as.octmode(x) when x is double
+x <- c(NA, 1)
+stopifnot(identical(x == x,
+ as.hexmode(x) == as.octmode(x)))
+p <- c(1, pi)
+tools::assertError(as.hexmode(p))
+tools::assertError(as.octmode(p))
+## where all "wrong" in R <= 3.1.1
+
+
+## PR#15935
+y <- 1:3
+drop1(lm(y ~ 1))
+drop1(glm(y ~ 1))
+stats:::drop1.default(glm(y ~ 1))
+## gave error in R < 3.1.2
+
+## getAnywhere() wrongly dealing with namespace hidden list object
+nm <- deparse(body(pbinom)[[2]])# == "C_pbinom" currently
+gg <- getAnywhere(nm)
+stopifnot(length(gg$objs) == 1)
+## was 4 and printed "4 differing objects matching ‘C_pbinom’ ..." in R <= 3.1.1
+
+
+## 0-length consistency of options(), PR#15979
+stopifnot(identical(options(list()), options(NULL)))
+## options(list()) failed in R <= 3.1.1
+
+
+## merge.dendrogram(), PR#15648
+mkDend <- function(n, lab, method = "complete",
+ ## gives *ties* often:
+ rGen = function(n) 1+round(16*abs(rnorm(n)))) {
+ stopifnot(is.numeric(n), length(n) == 1, n >= 1, is.character(lab))
+ a <- matrix(rGen(n*n), n, n)
+ colnames(a) <- rownames(a) <- paste0(lab, 1:n)
+ .HC. <<- hclust(as.dist(a + t(a)), method=method)
+ as.dendrogram(.HC.)
+}
+set.seed(7)
+da <- mkDend(4, "A")
+db <- mkDend(3, "B")
+d.ab <- merge(da, db)
+hcab <- as.hclust(d.ab)
+stopifnot(hcab$order == c(2, 4, 1, 3, 7, 5, 6),
+ hcab$labels == c(paste0("A", 1:4), paste0("B", 1:3)))
+## was wrong in R <= 3.1.1
+set.seed(1) ; h1 <- as.hclust(mkDend(5, "S", method="single")); hc1 <- .HC.
+set.seed(5) ; h5 <- as.hclust(mkDend(5, "S", method="single")); hc5 <- .HC.
+set.seed(42); h3 <- as.hclust(mkDend(5, "A", method="single")); hc3 <- .HC.
+## all failed (differently!) because of ties in R <= 3.2.3
+stopifnot(all.equal(h1[1:4], hc1[1:4], tol = 1e-12),
+ all.equal(h5[1:4], hc5[1:4], tol = 1e-12),
+ all.equal(h3[1:4], hc3[1:4], tol = 1e-12))
+
+
+## bw.SJ() and similar with NA,Inf values, PR#16024
+try(bw.SJ (c(NA,2,3)))
+try(bw.bcv(c(-Inf,2,3)))
+try(bw.ucv(c(1,NaN,3,4)))
+## seg.faulted in 3.0.0 <= R <= 3.1.1
+
+
+## as.dendrogram() with wrong input
+x <- rbind(c( -6, -9), c( 0, 13),
+ c(-15, 6), c(-14, 0), c(12,-10))
+dx <- dist(x,"manhattan")
+hx <- hclust(dx)
+hx$merge <- matrix(c(-3, 1, -2, 3,
+ -4, -5, 2, 3), 4,2)
+tools::assertError(as.dendrogram(hx))
+## 8 member dendrogram and memory explosion for larger examples in R <= 3.1.2
+
+
+## abs with named args failed, PR#16047
+abs(x=1i)
+## Complained that the arg should be named z
+
+
+## Big exponents overflowed, PR#15976
+x <- 0E4933
+y <- 0x0p100000
+stopifnot(x == 0, y == 0)
+##
+
+
+## drop.terms() dropped some attributes, PR#16029
+test <- model.frame(Employed ~ Year + poly(GNP,3) + Population, data=longley)
+mterm <- terms(test)
+mterm2 <- drop.terms(mterm, 3)
+predvars <- attr(mterm2, "predvars")
+dataClasses <- attr(mterm2, "dataClasses")
+factors <- attr(mterm2, "factors")
+stopifnot(is.language(predvars), length(predvars) == length(dataClasses)+1,
+ all(names(dataClasses) == rownames(factors)))
+## Previously dropped predvars and dataClasses
+
+
+## prompt() did not escape percent signs properly
+fn <- function(fmt = "%s") {}
+f <- tempfile(fileext = ".Rd")
+prompt(fn, filename = f)
+rd <- tools::parse_Rd(f)
+## Gave syntax errors because the percent sign in Usage
+## was taken as the start of a comment.
+
+
+## power.t.test() failure for very large n (etc): PR#15792
+(ptt <- power.t.test(delta = 1e-4, sd = .35, power = .8))
+(ppt <- power.prop.test(p1 = .5, p2 = .501, sig.level=.001, power=0.90, tol=1e-8))
+stopifnot(all.equal(ptt$n, 192297000, tol = 1e-5),
+ all.equal(ppt$n, 10451937, tol = 1e-7))
+## call to uniroot() did not allow n > 1e7
+
+
+## save(*, ascii=TRUE): PR#16137
+x0 <- x <- c(1, NA, NaN)
+save(x, file=(sf <- tempfile()), ascii = TRUE)
+load(sf)
+stopifnot(identical(x0, x))
+## x had 'NA' instead of 'NaN'
+
+
+## PR#16205
+stopifnot(length(glob2rx(character())) == 0L)
+## was "^$" in R < 3.1.3
+
+
+### Bugs fixed in R 3.2.0
+
+## Bugs reported by Radford Neal
+x <- pairlist(list(1, 2))
+x[[c(1, 2)]] <- NULL # wrongly gave an error, referring to misuse
+ # of the internal SET_VECTOR_ELT procedure
+stopifnot(identical(x, pairlist(list(1))))
+
+a <- pairlist(10, 20, 30, 40, 50, 60)
+dim(a) <- c(2, 3)
+dimnames(a) <- list(c("a", "b"), c("x", "y", "z"))
+# print(a) # doesn't print names, not fixed
+a[["a", "x"]] <- 0
+stopifnot(a[["a", "x"]] == 0)
+## First gave a spurious error, second caused a seg.fault
+
+
+## Radford (R-devel, June 24, 2014); M.Maechler
+m <- matrix(1:2, 1,2); v <- 1:3
+stopifnot(identical(crossprod(2, v), t(2) %*% v),
+ identical(crossprod(m, v), t(m) %*% v),
+ identical(5 %*% v, 5 %*% t(v)),
+ identical(tcrossprod(m, 1:2), m %*% 1:2) )
+## gave error "non-conformable arguments" in R <= 3.2.0
+proc.time() - .pt; .pt <- proc.time()
+
+
+## list <--> environment
+L0 <- list()
+stopifnot(identical(L0, as.list(as.environment(L0))))
+## as.env..() did not work, and as.list(..) gave non-NULL names in R 3.1.x
+
+
+### all.equal() refClass()es check moved to methods package
+
+
+## missing() did not propagate through '...', PR#15707
+check <- function(x,y,z) c(missing(x), missing(y), missing(z))
+check1 <- function(...) check(...)
+check2 <- function(...) check1(...)
+stopifnot(identical(check2(one, , three), c(FALSE, TRUE, FALSE)))
+## missing() was unable to handle recursive promises
+
+
+### envRefClass check moved to methods package
+
+
+## takes too long with JIT enabled:
+.jit.lev <- compiler::enableJIT(0)
+Sys.getenv("_R_CHECK_LENGTH_1_CONDITION_") -> oldV
+Sys.setenv("_R_CHECK_LENGTH_1_CONDITION_" = "false") # only *warn*
+## while did not protect its argument, which caused an error
+## under gctorture, PR#15990
+gctorture()
+suppressWarnings(while(c(FALSE, TRUE)) 1)
+gctorture(FALSE)
+## gave an error because the test got released when the warning was generated.
+compiler::enableJIT(.jit.lev)# revert
+Sys.setenv("_R_CHECK_LENGTH_1_CONDITION_" = oldV)
+
+
+## hist(x, breaks =) with too large bins, PR#15988
+set.seed(5); x <- runif(99)
+Hist <- function(x, b) hist(x, breaks = b, plot = FALSE)$counts
+for(k in 1:5) {
+ b0 <- seq_len(k-1)/k
+ H.ok <- Hist(x, c(-10, b0, 10))
+ for(In in c(1000, 1e9, Inf))
+ stopifnot(identical(Hist(x, c(-In, b0, In)), H.ok),
+ identical(Hist(x, c( 0, b0, In)), H.ok))
+}
+## "wrong" results for k in {2,3,4} in R 3.1.x
+
+
+## eigen(*, symmetric = <default>) with asymmetric dimnames, PR#16151
+m <- matrix(c(83,41), 5, 4,
+ dimnames=list(paste0("R",1:5), paste0("C",1:4)))[-5,] + 3*diag(4)
+stopifnot( all.equal(eigen(m, only.values=TRUE) $ values,
+ c(251, 87, 3, 3), tol=1e-14) )
+## failed, using symmetric=FALSE and complex because of the asymmetric dimnames()
+
+
+## match.call() re-matching '...'
+test <- function(x, ...) test2(x, 2, ...)
+test2 <- function(x, ...) match.call(test2, sys.call())
+stopifnot(identical(test(1, 3), quote(test2(x=x, 2, 3))))
+## wrongly gave test2(x=x, 2, 2, 3) in R <= 3.1.2
+
+
+## callGeneric not forwarding dots in call (PR#16141)
+setGeneric("foo", function(x, ...) standardGeneric("foo"))
+setMethod("foo", "character",
+ function(x, capitalize = FALSE) if (capitalize) toupper(x) else x)
+setMethod("foo", "factor",
+ function(x, capitalize = FALSE) { x <- as.character(x); callGeneric() })
+toto1 <- function(x, ...) foo(x, ...)
+stopifnot(identical(toto1(factor("a"), capitalize = TRUE), "A"))
+## wrongly did not capitalize in R <= 3.1.2
+
+
+## Accessing non existing objects must be an error
+tools::assertError(base :: foobar)
+tools::assertError(base :::foobar)
+tools::assertError(stats:::foobar)
+tools::assertError(stats:: foobar)
+## lazy data only via '::', not ':::' :
+stopifnot( nrow(datasets:: swiss) == 47)
+tools::assertError(datasets:::swiss)
+## The ::: versions gave NULL in certain development versions of R
+stopifnot(identical(stats4::show -> s4s,
+ get("show", asNamespace("stats4") -> ns4)),
+ s4s@package == "methods",
+ is.null(ns4[["show"]]) # not directly in stats4 ns
+ )
+## stats4::show was NULL for 4 hours in R-devel
+
+
+## mode<- did too much evaluation (PR#16215)
+x <- y <- quote(-2^2)
+x <- as.list(x)
+mode(y) <- "list"
+stopifnot(identical(x, y))
+## y ended up containing -4, not -2^2
+
+
+## besselJ()/besselY() with too large order
+besselJ(1, 2^64) ## NaN with a warning
+besselY(1, c(2^(60:70), Inf))
+## seg.faulted in R <= 3.1.2
+
+
+## besselJ()/besselY() with nu = k + 1/2; k in {-1,-2,..}
+besselJ(1, -1750.5) ## Inf, with only one warning...
+stopifnot(is.finite(besselY(1, .5 - (1500 + 0:10))))
+## last gave NaNs; both: more warnings in R <= 3.1.x
+
+
+## BIC() for arima(), also with NA's
+lho <- lh; lho[c(3,7,13,17)] <- NA
+alh300 <- arima(lh, order = c(3,0,0))
+alh311 <- arima(lh, order = c(3,1,1))
+ao300 <- arima(lho, order = c(3,0,0))
+ao301 <- arima(lho, order = c(3,0,1))
+## AIC/BIC for *different* data rarely makes sense ... want warning:
+tools::assertWarning(AA <- AIC(alh300,alh311, ao300,ao301))
+tools::assertWarning(BB <- BIC(alh300,alh311, ao300,ao301))
+fmLst <- list(alh300,alh311, ao300,ao301)
+## nobs() did not "work" in R < 3.2.0:
+stopifnot(sapply(fmLst, nobs) == c(48,47, 44,44))
+lls <- lapply(fmLst, logLik)
+str(lapply(lls, unclass))# -> 'df' and 'nobs'
+## 'manual BIC' via generalized AIC:
+stopifnot(all.equal(BB[,"BIC"],
+ sapply(fmLst, function(fm) AIC(fm, k = log(nobs(fm))))))
+## BIC() was NA unnecessarily in R < 3.2.0; nobs() was not available eiher
+
+
+## as.integer() close and beyond maximal integer
+MI <- .Machine$integer.max
+stopifnot(identical( MI, as.integer( MI + 0.99)),
+ identical(-MI, as.integer(-MI - 0.99)),
+ is.na(as.integer(as.character( 100*MI))),
+ is.na(as.integer(as.character(-100*MI))))
+## The two cases with positive numbers failed in R <= 3.2.0
+
+
+## Ensure that sort() works with a numeric vector "which is an object":
+stopifnot(is.object(y <- freeny$y))
+stopifnot(diff(sort(y)) > 0)
+## order() and hence sort() failed here badly for a while around 2015-04-16
+
+
+## NAs in data frame names:
+dn <- list(c("r1", NA), c("V", NA))
+d11 <- as.data.frame(matrix(c(1, 1, 1, 1), ncol = 2, dimnames = dn))
+stopifnot(identical(names(d11), dn[[2]]),
+ identical(row.names(d11), dn[[1]]))
+## as.data.frame() failed in R-devel for a couple of hours ..
+## note that format(d11) does fail currently, and hence print(), too
+
+
+## Ensure R -e .. works on Unix
+if(.Platform$OS.type == "unix" &&
+ file.exists(Rc <- file.path(R.home("bin"), "R")) &&
+ file.access(Rc, mode = 1) == 0) { # 1: executable
+ cmd <- paste(Rc, "-q --vanilla -e 1:3")
+ ans <- system(cmd, intern=TRUE)
+ stopifnot(length(ans) >= 3,
+ identical(ans[1:2], c("> 1:3",
+ "[1] 1 2 3")))
+}
+## (failed for < 1 hr, in R-devel only)
+proc.time() - .pt; .pt <- proc.time()
+
+
+## Parsing large exponents of floating point numbers, PR#16358
+set.seed(12)
+lrg <- sprintf("%.0f", round(exp(10*(2+abs(rnorm(2^10))))))
+head(huge <- paste0("1e", lrg))
+ micro <- paste0("1e-", lrg)
+stopifnot(as.numeric(huge) == Inf,
+ as.numeric(micro) == 0)
+## Both failed in R <= 3.2.0
+
+
+## vcov() failed on manova() results, PR#16380
+tear <- c(6.5, 6.2, 5.8, 6.5, 6.5, 6.9, 7.2, 6.9, 6.1, 6.3, 6.7, 6.6, 7.2, 7.1, 6.8, 7.1, 7.0, 7.2, 7.5, 7.6)
+gloss <- c(9.5, 9.9, 9.6, 9.6, 9.2, 9.1, 10.0, 9.9, 9.5, 9.4, 9.1, 9.3, 8.3, 8.4, 8.5, 9.2, 8.8, 9.7, 10.1, 9.2)
+opacity <- c(4.4, 6.4, 3.0, 4.1, 0.8, 5.7, 2.0, 3.9, 1.9, 5.7, 2.8, 4.1, 3.8,1.6, 3.4, 8.4, 5.2, 6.9, 2.7, 1.9)
+Y <- cbind(tear, gloss, opacity)
+rate <- factor(gl(2,10), labels = c("Low", "High"))
+fit <- manova(Y ~ rate)
+vcov(fit)
+## Gave error because coef.aov() turned matrix of coefficients into a vector
+
+
+## Unary / Binary uses of logic operations, PR#16385
+tools::assertError(`&`(FALSE))
+tools::assertError(`|`(TRUE))
+## Did not give errors in R <= 3.2.0
+E <- tryCatch(`!`(), error = function(e)e)
+stopifnot(grepl("0 arguments .*\\<1", conditionMessage(E)))
+## Gave wrong error message in R <= 3.2.0
+stopifnot(identical(!matrix(TRUE), matrix(FALSE)),
+ identical(!matrix(FALSE), matrix(TRUE)))
+## was wrong for while in R 3.2.0 patched
+
+
+## cummax(<integer>)
+iNA <- NA_integer_
+x <- c(iNA, 1L)
+stopifnot(identical(cummin(x), c(iNA, iNA)),
+ identical(cummax(x), c(iNA, iNA)))
+## an initial NA was not propagated in R <= 3.2.0
+
+
+## summaryRprof failed for very short profile, PR#16395
+profile <- tempfile()
+writeLines(c(
+'memory profiling: sample.interval=20000',
+':145341:345360:13726384:0:"stdout"',
+':208272:345360:19600000:0:"stdout"'), profile)
+summaryRprof(filename = profile, memory = "both")
+unlink(profile)
+## failed when a matrix was downgraded to a vector
+
+
+## option(OutDec = *) -- now gives a warning when not 1 character
+op <- options(OutDec = ".", digits = 7, # <- default
+ warn = 2)# <- (unexpected) warnings become errors
+stopifnot(identical("3.141593", fpi <- format(pi)))
+options(OutDec = ",")
+stopifnot(identical("3,141593", cpi <- format(pi)))
+## warnings, but it "works" (for now):
+tools::assertWarning(options(OutDec = ".1."))
+stopifnot(identical("3.1.141593", format(pi)))
+tools::assertWarning(options(OutDec = ""))
+tools::assertWarning(stopifnot(identical("3141593", format(pi))))
+options(op)# back to sanity
+## No warnings in R versions <= 3.2.1
+
+
+## format(*, decimal.mark=".") when OutDec != "." (PR#16411)
+op <- options(OutDec = ",")
+stopifnot(identical(fpi, format(pi, decimal.mark=".")))
+options(op)
+## failed in R <= 3.2.1
+
+
+## model.frame() removed ts attributes on original data (PR#16436)
+orig <- class(EuStockMarkets)
+mf <- model.frame(EuStockMarkets ~ 1, na.action=na.fail)
+stopifnot(identical(orig, class(EuStockMarkets)))
+## ts class lost in R <= 3.2.1
+
+
+##
+foo <- as.expression(1:3)
+matrix(foo, 3, 3) # always worked
+matrix(foo, 3, 3, byrow = TRUE)
+## failed in R <= 3.1.2
+
+
+## labels.dendrogram(), dendrapply(), etc -- see comment #15 of PR#15215 :
+(D <- as.dendrogram(hclust(dist(cbind(setNames(c(0,1,4), LETTERS[1:3]))))))
+stopifnot(
+ identical(labels(D), c("C", "A", "B")),
+ ## has been used in "CRAN package space"
+ identical(suppressWarnings(dendrapply(D, labels)),
+ list("C", list("A", "B"), "C")))
+## dendrapply(D, labels) failed in R-devel for a day or two
+
+
+## poly() / polym() predict()ion
+library(datasets)
+alm <- lm(stack.loss ~ poly(Air.Flow, Water.Temp, degree=3), stackloss)
+f20 <- fitted(alm)[1:20] # "correct" prediction values [1:20]
+stopifnot(all.equal(unname(f20[1:4]), c(39.7703378, 39.7703378, 35.8251359, 21.5661761)),
+ all.equal(f20, predict(alm, stackloss) [1:20] , tolerance = 1e-14),
+ all.equal(f20, predict(alm, stackloss[1:20, ]), tolerance = 1e-14))
+## the second prediction went off in R <= 3.2.1
+
+
+## PR#16478
+kkk <- c("a\tb", "3.14\tx")
+z1 <- read.table(textConnection(kkk), sep = "\t", header = TRUE,
+ colClasses = c("numeric", "character"))
+z2 <- read.table(textConnection(kkk), sep = "\t", header = TRUE,
+ colClasses = c(b = "character", a = "numeric"))
+stopifnot(identical(z1, z2))
+z3 <- read.table(textConnection(kkk), sep = "\t", header = TRUE,
+ colClasses = c(b = "character"))
+stopifnot(identical(z1, z3))
+z4 <- read.table(textConnection(kkk), sep = "\t", header = TRUE,
+ colClasses = c(c = "integer", b = "character", a = "numeric"))
+stopifnot(identical(z1, z4))
+## z2 and z4 used positional matching (and failed) in R < 3.3.0.
+
+
+## PR#16484
+z <- regexpr("(.)", NA_character_, perl = TRUE)
+stopifnot(is.na(attr(z, "capture.start")), is.na(attr(z, "capture.length")))
+## Result was random integers in R <= 3.2.2.
+
+
+## PR#14861
+if(.Platform$OS.type == "unix") { # no 'ls /' on Windows
+ con <- pipe("ls /", open = "rt")
+ data <- readLines(con)
+ z <- close(con)
+ print(z)
+ stopifnot(identical(z, 0L))
+}
+## was NULL in R <= 3.2.2
+
+
+## Sam Steingold: compiler::enableJIT(3) not working in ~/.Rprofile anymore
+stopifnot(identical(topenv(baseenv()),
+ baseenv()))
+## accidentally globalenv in R 3.2.[12] only
+
+
+## widths of unknown Unicode characters
+stopifnot(nchar("\u200b", "w") == 0)
+## was -1 in R 3.2.2
+
+
+## abbreviate dropped names in some cases
+x <- c("AA", "AB", "AA", "CBA") # also test handling of duplicates
+for(m in 2:0) {
+ print(y <- abbreviate(x, m))
+ stopifnot(identical(names(y), x))
+}
+## dropped for 0 in R <= 3.2.2
+
+
+## match(<NA>, <NA>)
+stopifnot(
+ isTRUE(NA %in% c(NA, TRUE)),
+ isTRUE(NA_integer_ %in% c(TRUE, NA)),
+ isTRUE(NA_real_ %in% c(NA, FALSE)),# !
+ isTRUE(!(NaN %in% c(NA, FALSE))),
+ isTRUE(NA %in% c(3L, NA)),
+ isTRUE(NA_integer_ %in% c(NA, 3L)),
+ isTRUE(NA_real_ %in% c(3L, NA)),# !
+ isTRUE(!(NaN %in% c(3L, NA))),
+ isTRUE(NA %in% c(2., NA)),# !
+ isTRUE(NA_integer_ %in% c(NA, 2.)),# !
+ isTRUE(NA_real_ %in% c(2., NA)),# !
+ isTRUE(!(NaN %in% c(2., NA))))
+## the "!" gave FALSE in R-devel (around 20.Sep.2015)
+
+
+## oversight in within.data.frame() [R-help, Sep 20 2015 14:23 -04]
+df <- data.frame(.id = 1:3 %% 3 == 2, a = 1:3)
+d2 <- within(df, {d = a + 2})
+stopifnot(identical(names(d2), c(".id", "a", "d")))
+## lost the '.id' column in R <= 3.2.2
+proc.time() - .pt; .pt <- proc.time()
+
+## system() truncating and splitting long lines of output, PR#16544
+## only works when platform has getline() in stdio.h, and Solaris does not.
+known.POSIX_2008 <- .Platform$OS.type == "unix" &&
+ (Sys.info()[["sysname"]] != "SunOS")
+## ^^^ explicitly exclude *non*-working platforms above
+if(known.POSIX_2008) {
+ cat("testing system(\"echo\", <large>) : "); op <- options(warn = 2)# no warnings allowed
+ cn <- paste(1:2222, collapse=" ")
+ rs <- system(paste("echo", cn), intern=TRUE)
+ stopifnot(identical(rs, cn))
+ cat("[Ok]\n"); options(op)
+}
+
+
+## tail.matrix()
+B <- 100001; op <- options(max.print = B + 99)
+mat.l <- list(m0 = matrix(, 0,2),
+ m0n = matrix(, 0,2, dimnames = list(NULL, paste0("c",1:2))),
+ m2 = matrix(1:2, 2,1),
+ m2n = matrix(1:2, 2,3, dimnames = list(NULL, paste0("c",1:3))),
+ m9n = matrix(1:9, 9,1, dimnames = list(paste0("r",1:9),"CC")),
+ m12 = matrix(1:12, 12,1),
+ mBB = matrix(1:B, B, 1))
+## tail() used to fail for 0-rows matrices m0*
+n.s <- -3:3
+hl <- lapply(mat.l, function(M) lapply(n.s, function(n) head(M, n)))
+tl <- lapply(mat.l, function(M) lapply(n.s, function(n) tail(M, n)))
+## Check dimensions of resulting matrices --------------
+## ncol:
+Mnc <- do.call(rbind, rep(list(vapply(mat.l, ncol, 1L)), length(n.s)))
+stopifnot(identical(Mnc, sapply(hl, function(L) vapply(L, ncol, 1L))),
+ identical(Mnc, sapply(tl, function(L) vapply(L, ncol, 1L))))
+## nrow:
+fNR <- function(L) vapply(L, nrow, 1L)
+tR <- sapply(tl, fNR)
+stopifnot(identical(tR, sapply(hl, fNR)), # head() & tail both
+ tR[match(0, n.s),] == 0, ## tail(*,0) has always 0 rows
+ identical(tR, outer(n.s, fNR(mat.l), function(x,y)
+ ifelse(x < 0, pmax(0L, y+x), pmin(y,x)))))
+for(j in c("m0", "m0n")) { ## 0-row matrices: tail() and head() look like identity
+ co <- capture.output(mat.l[[j]])
+ stopifnot(vapply(hl[[j]], function(.) identical(co, capture.output(.)), NA),
+ vapply(tl[[j]], function(.) identical(co, capture.output(.)), NA))
+}
+
+CO1 <- function(.) capture.output(.)[-1] # drop the printed column names
+## checking tail(.) rownames formatting
+nP <- n.s > 0
+for(nm in c("m9n", "m12", "mBB")) { ## rownames: rather [100000,] than [1e5,]
+ tf <- file(); capture.output(mat.l[[nm]], file=tf)
+ co <- readLines(tf); close(tf)
+ stopifnot(identical(# tail(.) of full output == output of tail(.) :
+ lapply(n.s[nP], function(n) tail(co, n)),
+ lapply(tl[[nm]][nP], CO1)))
+}
+
+identCO <- function(x,y, ...) identical(capture.output(x), capture.output(y), ...)
+headI <- function(M, n) M[head(seq_len(nrow(M)), n), , drop=FALSE]
+tailI <- function(M, n) M[tail(seq_len(nrow(M)), n), , drop=FALSE]
+for(mat in mat.l) {
+ ## do not capture.output for tail(<large>, <small negative>)
+ n.set <- if(nrow(mat) < 999) -3:3 else 0:3
+ stopifnot(
+ vapply(n.set, function(n) identCO (head(mat, n), headI(mat, n)), NA),
+ vapply(n.set, function(n) identCO (tail (mat, n, addrownums=FALSE),
+ tailI(mat, n)), NA),
+ vapply(n.set, function(n) all.equal(tail(mat, n), tailI(mat, n),
+ check.attributes=FALSE), NA))
+}
+options(op)
+## end{tail.matrix check} ------------------
+
+## format.data.frame() & as.data.frame.list() - PR#16580
+myL <- list(x=1:20, y=rnorm(20), stringsAsFactors = gl(4,5))
+names(myL)[1:2] <- lapply(1:2, function(i)
+ paste(sample(letters, 300, replace=TRUE), collapse=""))
+nD <- names(myD <- as.data.frame(myL))
+nD2 <- names(myD2 <- as.data.frame(myL, cut.names = 280))
+nD3 <- names(myD3 <- as.data.frame(myL, cut.names = TRUE))
+stopifnot(nchar(nD) == c(300,300,16), is.data.frame(myD), dim(myD) == c(20,3),
+ nchar(nD2)== c(278,278,16), is.data.frame(myD2), dim(myD2) == c(20,3),
+ nchar(nD3)== c(254,254,16), is.data.frame(myD3), dim(myD3) == c(20,3),
+ identical(nD[3], "stringsAsFactors"),
+ identical(nD[3], nD2[3]), identical(nD[3], nD3[3]))
+
+names(myD)[1:2] <- c("Variable.1", "")# 2nd col.name is "empty"
+## A data frame with a column that is an empty data frame:
+d20 <- structure(list(type = c("F", "G"), properties = data.frame(i=1:2)[,-1]),
+ class = "data.frame", row.names = c(NA, -2L))
+stopifnot(is.data.frame(d20), dim(d20) == c(2,2),
+ identical(colnames(d20), c("type", "properties")),
+ identical(capture.output(d20), c(" type", "1 F", "2 G")))
+## format(d20) failed in intermediate R versions
+stopifnot(identical(names(myD), names(format(head(myD)))),
+ identical(names(myD), c("Variable.1", "", "stringsAsFactors")),
+ identical(rbind.data.frame(2:1, 1:2), ## was wrong for some days
+ data.frame(c.2L..1L. = c(2L, 1L), X1.2 = 1:2)))
+## format.data.frame() did not show "stringsAsFactors" in R <= 3.2.2
+## Follow up: the new as.data.frame.list() must be careful with 'AsIs' columns:
+desc <- structure( c("a", NA, "z"), .Names = c("A", NA, "Z"))
+tools::assertError( data.frame(desc = desc, stringsAsFactors = FALSE) )
+## however
+dd <- data.frame(desc = structure(desc, class="AsIs"),
+ row.names = c("A","M","Z"), stringsAsFactors = FALSE)
+## is "legal" (because "AsIs" can be 'almost anything')
+dd ## <- did not format nor print correctly in R-devel early Nov.2015
+fdesc <- structure(c("a", "NA", "z"), .Names=names(desc), class="AsIs")
+stopifnot(identical(format(dd),
+ data.frame(desc = fdesc, row.names = c("A", "M", "Z"))),
+ identical(capture.output(dd),
+ c(" desc", "A a",
+ "M <NA>", "Z z")),
+ identical(dd, data.frame(list(dd))))# lost row.names for a while
+
+
+## var(x) and hence sd(x) with factor x, PR#16564
+tools::assertError(cov(1:6, f <- gl(2,3)))# was ok already
+tools::assertWarning(var(f))
+tools::assertWarning( sd(f))
+## var() "worked" in R <= 3.2.2 using the underlying integer codes
+proc.time() - .pt; .pt <- proc.time()
+
+
+## loess(*, .. weights) - PR#16587
+d.loess <-
+ do.call(expand.grid,
+ c(formals(loess.control)[1:3],
+ list(iterations = c(1, 10),
+ KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE)))
+d.loess $ iterTrace <- (d.loess$ iterations > 1)
+## apply(d.loes, 1L, ...) would coerce everything to atomic, i.e, "character":
+loess.c.list <- lapply(1:nrow(d.loess), function(i)
+ do.call(loess.control, as.list(d.loess[i,])))
+set.seed(123)
+for(n in 1:6) { if(n %% 10 == 0) cat(n,"\n")
+ wt <- runif(nrow(cars))
+ for(ctrl in loess.c.list) {
+ cars.wt <- loess(dist ~ speed, data = cars, weights = wt,
+ family = if(ctrl$iterations > 1) "symmetric" else "gaussian",
+ control = ctrl)
+ cPr <- predict(cars.wt)
+ cPrN <- predict(cars.wt, newdata=cars)
+ stopifnot(all.equal(cPr, cPrN, check.attributes = FALSE, tol=1e-14))
+ }
+}
+## gave (typically slightly) wrong predictions in R <= 3.2.2
+
+
+## aperm() for named dim()s:
+na <- list(A=LETTERS[1:2], B=letters[1:3], C=LETTERS[21:25], D=letters[11:17])
+da <- lengths(na)
+A <- array(1:210, dim=da, dimnames=na)
+aA <- aperm(A)
+a2 <- aperm(A, (pp <- c(3:1,4)))
+stopifnot(identical( dim(aA), rev(da)),# including names(.)
+ identical(dimnames(aA), rev(na)),
+ identical( dim(a2), da[pp]), # including names(.)
+ identical(dimnames(a2), na[pp]))
+## dim(aperm(..)) did lose names() in R <= 3.2.2
+
+
+## poly() / predict(poly()) with NAs -- PR#16597
+fm <- lm(y ~ poly(x, 3), data=data.frame(x=1:7, y=sin(1:7)))
+x <- c(1,NA,3:7)
+stopifnot(all.equal(c(predict(fm, newdata=list(x = 1:3)), `4`=NA),
+ predict(fm, newdata=list(x=c(1:3,NA))), tol=1e-15),
+ all.equal(unclass(poly(x, degree=2, raw=TRUE)),
+ cbind(x, x^2), check.attributes=FALSE))
+## both gave error about NA in R <= 3.2.2
+
+
+## data(package = *) on some platforms
+dd <- data(package="datasets")[["results"]]
+if(anyDuplicated(dd[,"Item"])) stop("data(package=*) has duplications")
+## sometimes returned the data sets *twice* in R <= 3.2.2
+
+
+## prettyNum(*, big.mark, decimal.mark)
+b.m <- c(".", ",", "'", "")
+d.m <- c(".", ",", ".,", "..")
+pa <- expand.grid(big.mark = b.m, decimal.mark = d.m,
+ x = c(1005.24, 100.22, 1000000.33), scientific=FALSE, digits=9,
+ stringsAsFactors=FALSE, KEEP.OUT.ATTRS=FALSE)
+r <- vapply(1:nrow(pa), function(i) do.call(prettyNum, pa[i,]), "")# with 6x2 warnings
+r
+b.m[b.m == ""] <- "0"
+## big.mark: only >= 1000; *and* because particular chosen numbers:
+r.2 <- substr(r[pa[,"x"] > 1000], 2, 2)
+## compute location of decimal point (which maybe more than one char)
+nd <- nchar(dm.s <- rep(d.m, each=length(b.m)))
+nr <- nchar(r) - 3 + (nd == 1)
+nr2 <- nr + (nd > 1)
+stopifnot(identical(r.2, rep_len(b.m, length(r.2))),
+ identical(substr(r, nr,nr2), rep_len(dm.s, length(r))))
+## several cases (1, 5, 9, 10,..) were wrong in R 3.2.2
+
+
+## kmeans with just one center -- PR#16623
+set.seed(23)
+x <- rbind(matrix(rnorm(100, sd = 0.3), ncol = 2),
+ matrix(rnorm(100, mean = 1, sd = 0.3), ncol = 2))
+k1 <- kmeans(x, 1)
+k2 <- kmeans(x, centers = k1$centers)
+stopifnot(all.equal(k1, k2), k1$cluster == 1)
+## the kmeans(*, centers=.) called failed in R <= 3.2.3
+
+
+## invalid dimnames for array()
+tools::assertError(array(1, 2:3, dimnames="foo"))
+## were silently disregarded in R <= 3.2.3
+
+
+## addmargins() - dimnames with (by default) "Sum"
+m <- rbind(1, 2:3)
+m2 <- addmargins(m, 2)
+am <- addmargins(m)
+stopifnot(
+ identical(dimnames(m2), list(NULL, c("", "", "Sum"))),
+ identical(am[,"Sum"], setNames(c(2, 5, 7), c("", "", "Sum"))))
+## the dimnames array() bug above hid the addmargins() not adding "Sum"
+
+
+## dim( x[,] ) -- should keep names(dim(.)) --
+## --- ----
+##_ 1 D _
+A1 <- array(1:6, (d <- c(nam=6L)))
+stopifnot(identical(dim(A1), d),
+ identical(dim(A1), dim(A1[])))
+##_ 2 D _
+A2 <- A[1,2,,]
+stopifnot(identical(names(dim(A2)), c("C", "D")),
+ identical(dim(A2), dim(A)[-(1:2)]),
+ identical(dim(A2[ ]), dim(A2)),
+ identical(dim(A2[,]), dim(A2)),
+ identical(dim(A2[1, , drop=FALSE]), c(C = 1L, D = 7L)),
+ identical(dim(A2[, 1, drop=FALSE]), c(C = 5L, D = 1L)))
+##_ higher D_
+A3 <- A[1, ,,]
+stopifnot(
+ identical(dim(A ), dim(A [,,,])),# was already wrong: [,,,] losing names(dim(.))
+ identical(dim(A[,-1,-1,-1]), dim(A) - c(0:1,1L,1L)),
+ identical(dim(A3), dim(A)[-1]),
+ identical(dim(A3), dim(A3[,, ])),
+ identical(dim(A3[,1,]), c(B = 3L, D = 7L)))
+## all subsetting of arrays lost names(dim(.)) in R < 3.3.0
+
+
+## NextMethod() dispatch for `$` and `$<-`
+`$.foo` <- function(x, fun) paste("foo:", NextMethod())
+x <- list(a = 1, b = 2)
+class(x) <- "foo"
+stopifnot(identical(x$b, "foo: 2")) # 'x$b' failed prior to R 3.3.0
+
+`$<-.foo` <- function(x, value, fun) {
+ attr(x, "modified") <- "yes"
+ NextMethod()
+}
+x$y <- 10 ## failed prior to R 3.3.0
+stopifnot(identical(attr(x, "modified"), "yes"))
+
+
+## illegal 'row.names' for as.data.frame(): -- for now just a warning --
+tools::assertWarning(
+ d3 <- as.data.frame(1:3, row.names = letters[1:2])
+)
+stopifnot(dim(d3) == c(3,1)) ## was (2, 1) in R <= 3.2.3
+## 'row.names' were not checked and produced a "corrupted" data frame in R <= 3.2.3
+
+
+## rbind.data.frame()'s smart row names construction
+mk1 <- function(x) data.frame(x=x)
+d4 <- rbind(mk1(1:4)[3:4,,drop=FALSE], mk1(1:2))
+stopifnot(identical(dimnames(d4),
+ list(c("3", "4", "1", "2"), "x")),
+## the rownames were "3" "4" "31" "41" in R <= 3.3.0
+ identical(attr(rbind(mk1(5:8), 7, mk1(6:3)), "row.names"), 1:9)
+ )
+
+## sort on integer() should drop NAs by default
+stopifnot(identical(1L, sort(c(NA, 1L))))
+## and other data types for method="radix"
+stopifnot(identical("a", sort(c(NA, "a"), method="radix")))
+stopifnot(identical(character(0L), sort(c(NA, NA_character_), method="radix")))
+stopifnot(identical(1, sort(c(NA, 1), method="radix")))
+
+
+## dummy.coef(.) in the case of "non-trivial terms" -- PR#16665
+op <- options(contrasts = c("contr.treatment", "contr.poly"))
+fm1 <- lm(Fertility ~ cut(Agriculture, breaks=4) + Infant.Mortality, data=swiss)
+(dc1 <- dummy.coef(fm1)) ## failed in R <= 3.3.0
+## (R-help, Alexandra Kuznetsova, 24 Oct 2013):
+set.seed(56)
+group <- gl(2, 10, 20, labels = c("Ctl","Trt"))
+weight <- c(rnorm(10, 4), rnorm(10, 5))
+x <- rnorm(20)
+lm9 <- lm(weight ~ group + x + I(x^2))
+dc9 <- dummy.coef(lm9)
+## failed in R <= 3.3.0
+stopifnot( # depends on contrasts:
+ all.equal(unname(coef(fm1)), unlist(dc1, use.names=FALSE)[-2], tol= 1e-14),
+ all.equal(unname(coef(lm9)), unlist(dc9, use.names=FALSE)[-2], tol= 1e-14))
+## a 'use.na=TRUE' example
+dd <- data.frame(x1 = rep(letters[1:2], each=3),
+ x2 = rep(LETTERS[1:3], 2),
+ y = rnorm(6))
+dd[6,2] <- "B" # => no (b,C) combination => that coef should be NA
+fm3 <- lm(y ~ x1*x2, dd)
+(d3F <- dummy.coef(fm3, use.na=FALSE))
+(d3T <- dummy.coef(fm3, use.na=TRUE))
+stopifnot(all.equal(d3F[-4], d3T[-4]),
+ all.equal(d3F[[4]][-6], d3T[[4]][-6]),
+ all.equal(drop(d3T$`x1:x2`),
+ c("a:A"= 0, "b:A"= 0, "a:B"= 0,
+ "b:B"= 0.4204843786, "a:C"=0, "b:C"=NA)))
+## in R <= 3.2.3, d3T$`x1:x2` was *all* NA
+##
+## dummy.coef() for "manova"
+## artificial data inspired by the summary.manova example
+rate <- gl(2,10, labels=c("Lo", "Hi"))
+additive <- gl(4, 1, length = 20, labels = paste("d", 1:4, sep="."))
+additive <- C(additive, "contr.sum")# => less trivial dummy.coef
+X <- model.matrix(~ rate*additive)
+E <- matrix(round(rnorm(20*3), 2), 20,3) %*% cbind(1, c(.5,-1,.5), -1:1)
+bet <- outer(1:8, c(tear = 2, gloss = 5, opacity = 20))
+Y <- X %*% bet + E
+
+fit <- manova(Y ~ rate * additive)
+## For consistency checking, one of the univariate models:
+flm <- lm(Y[,"tear"] ~ rate * additive)
+dclm <- lapply(dummy.coef(flm), drop); names(dclm[[1]]) <- "tear"
+
+op <- options(digits = 3, width = 88)
+(cf <- coef(fit))
+(dcf <- dummy.coef(fit))
+options(op)
+stopifnot(all.equal(coef(flm), cf[,"tear"]),
+ all.equal(dclm,
+ lapply(dcf, function(cc)
+ if(is.matrix(cc)) cc["tear",] else cc["tear"])),
+ identical(lengths(dcf),
+ c("(Intercept)" = 3L, "rate" = 6L,
+ "additive" = 12L, "rate:additive" = 24L)),
+ identical(sapply(dcf[-1], dim),
+ cbind(rate = 3:2, additive = 3:4,
+ `rate:additive` = c(3L, 8L))))
+## dummy.coef() were missing coefficients in R <= 3.2.3
+proc.time() - .pt; .pt <- proc.time()
+
+
+## format.POSIXlt() with modified 'zone' or length-2 format
+f0 <- "2016-01-28 01:23:45"; tz0 <- "Europe/Stockholm"
+d2 <- d1 <- rep(as.POSIXlt(f0, tz = tz0), 2)
+(f1 <- format(d1, usetz=TRUE))
+identical(f1, rep(paste(f0, "CET"), 2))# often TRUE (but too platform dependent)
+d2$zone <- d1$zone[1] # length 1 instead of 2
+f2 <- format(d2, usetz=TRUE)## -> segfault
+f1.2 <- format(as.POSIXlt("2016-01-28 01:23:45"), format=c("%d", "%y"))# segfault
+stopifnot(identical(f2, rep(paste(f0, tz0 ), 2)),
+ identical(f1.2, c("28", "16")))
+tims <- seq.POSIXt(as.POSIXct("2016-01-01"),
+ as.POSIXct("2017-11-11"), by = as.difftime(pi, units="weeks"))
+form <- c("%m/%d/%y %H:%M:%S", "", "%Y-%m-%d %H:%M:%S")
+op <- options(warn = 2)# no warnings allowed
+head(rf1 <- format(tims, form)) # recycling was wrong
+head(rf2 <- format(tims, form[c(2,1,3)]))
+stopifnot(identical(rf1[1:3], c("01/01/16 00:00:00", "2016-01-22 23:47:15",
+ "2016-02-13 23:34:30")),
+ identical(rf2[1:3], c("2016-01-01 00:00:00", "01/22/16 23:47:15",
+ rf1[3])),
+ nchar(rf1) == rep(c(17,19,19), length = length(rf1)),
+ nchar(rf2) == rep(c(19,17,19), length = length(rf2)))
+options(op)
+## Wrong-length 'zone' or short 'x' segfaulted -- PR#16685
+## Default 'format' setting sometimes failed for length(format) > 1
+
+
+## saveRDS(*, compress= .)
+opts <- setNames(,c("bzip2", "xz", "gzip"))
+fil <- tempfile(paste0("xx", 1:6, "_"), fileext = ".rds")
+names(fil) <- c("default", opts, FALSE,TRUE)
+xx <- 1:11
+saveRDS(xx, fil["default"])
+saveRDS(xx, fil[opts[1]], compress = opts[1])
+saveRDS(xx, fil[opts[2]], compress = opts[2])
+saveRDS(xx, fil[opts[3]], compress = opts[3])
+saveRDS(xx, fil["FALSE"], compress = FALSE)
+saveRDS(xx, fil["TRUE" ], compress = TRUE)
+f.raw <- lapply(fil, readBin, what = "raw", n = 100)
+lengths(f.raw) # 'gzip' is best in this case
+for(i in 1:6) stopifnot(identical(xx, readRDS(fil[i])))
+eMsg <- tryCatch(saveRDS(xx, tempfile(), compress = "Gzip"),
+ error = function(e) e$message)
+stopifnot(
+ grepl("'compress'.*Gzip", eMsg), # had ".. not interpretable as logical"
+ identical(f.raw[["default"]], f.raw[["TRUE"]]),
+ identical(f.raw[["default"]], f.raw[[opts["gzip"]]]))
+## compress = "gzip" failed (PR#16653), but compress = c(a = "xz") did too
+
+
+## recursive dendrogram methods and deeply nested dendrograms
+op <- options(expressions = 999)# , verbose = 2) # -> max. depth= 961
+set.seed(11); d <- mkDend(1500, "A", method="single")
+rd <- reorder(d, nobs(d):1)
+## Error: evaluation nested too deeply: infinite recursion .. in R <= 3.2.3
+stopifnot(is.leaf(r1 <- rd[[1]]), is.leaf(r2 <- rd[[2:1]]),
+ attr(r1, "label") == "A1458", attr(r2, "label") == "A1317")
+options(op)# revert
+
+
+## cor.test() with extremely small p values
+b <- 1:10; set.seed(1)
+for(n in 1:256) {
+ a <- round(jitter(b, f = 1/8), 3)
+ p1 <- cor.test(a, b)$ p.value
+ p2 <- cor.test(a,-b)$ p.value
+ stopifnot(abs(p1 - p2) < 8e-16 * (p1+p2))
+ ## on two different Linuxen, they actually are always equal
+}
+## were slightly off in R <= 3.2.3. PR#16704
+
+
+## smooth(*, do.ends=TRUE)
+y <- c(4,2,2,3,10,5:7,7:6)
+stopifnot(
+ identical(c(smooth(y, "3RSR" , do.ends=TRUE, endrule="copy")),
+ c(4, 2, 2, 3, 5, 6, 6, 7, 7, 6) -> sy.c),
+ identical(c(smooth(y, "3RSS" , do.ends=TRUE, endrule="copy")), sy.c),
+ identical(c(smooth(y, "3RS3R", do.ends=TRUE, endrule="copy")), sy.c),
+ identical(c(smooth(y, "3RSR" , do.ends=FALSE, endrule="copy")),
+ c(4, 4, 4, 4, 5, 6, 6, 6, 6, 6)),
+ identical(c(smooth(y, "3RSS" , do.ends=FALSE, endrule="copy")),
+ c(4, 4, 2, 3, 5, 6, 6, 6, 6, 6)),
+ identical(c(smooth(y, "3RS3R", do.ends=FALSE, endrule="copy")),
+ c(4, 4, 3, 3, 5, 6, 6, 6, 6, 6)))
+## do.ends=TRUE was not obeyed for the "3RS*" kinds, for 3.0.0 <= R <= 3.2.3
+proc.time() - .pt; .pt <- proc.time()
+
+
+## prettyDate() for subsecond ranges
+##' checking pretty():
+chkPretty <- function(x, n = 5, min.n = NULL, ..., max.D = 1) {
+ if(is.null(min.n)) {
+ ## work with both pretty.default() and greDevices::prettyDate()
+ ## *AND* these have a different default for 'min.n' we must be "extra smart":
+ min.n <-
+ if(inherits(x, "Date") || inherits(x, "POSIXt"))
+ n %/% 2 # grDevices:::prettyDate
+ else
+ n %/% 3 # pretty.default
+ }
+ pr <- pretty(x, n=n, min.n=min.n, ...)
+ ## if debugging: pr <- grDevices:::prettyDate(x, n=n, min.n=min.n, ...)
+ stopifnot(length(pr) >= (min.n+1),
+ ## pretty(x, *) must cover range of x:
+ min(pr) <= min(x), max(x) <= max(pr))
+ if((D <- abs(length(pr) - (n+1))) > max.D)
+ stop("| |pretty(.)| - (n+1) | = ", D, " > max.D = ", max.D)
+ ## is it equidistant [may need fuzz, i.e., signif(.) ?]:
+ eqD <- length(pr) == 1 || length(udp <- unique(dp <- diff(pr))) == 1
+ ## may well FALSE (differing number days in months; leap years, leap seconds)
+ if(!eqD) {
+ if(inherits(dp, "difftime") && units(dp) %in% c("days")# <- more ??
+ )
+ attr(pr, "chkPr") <- "not equidistant"
+ else
+ stop("non equidistant: has ", length(udp)," unique differences")
+ }
+ invisible(pr)
+}
+sTime <- structure(1455056860.75, class = c("POSIXct", "POSIXt"))
+for(n in c(1:16, 30:32, 41, 50, 60)) # (not for much larger n, (TODO ?))
+ chkPretty(sTime, n=n)
+set.seed(7)
+for(n in c(1:7, 12)) replicate(32, chkPretty(sTime + .001*rlnorm(1) * 0:9, n = n))
+## failed in R <= 3.2.3
+seqD <- function(d1,d2) seq.Date(as.Date(d1), as.Date(d2), by = "1 day")
+seqDp <- function(d1,d2) { s <- seqD(d1,d2); structure(s, labels=format(s,"%b %d")) }
+time2d <- function(i) sprintf("%02d", i %% 60)
+MTbd <- as.Date("1960-02-10")
+(p1 <- chkPretty(MTbd))
+stopifnot(
+ identical(p1, seqDp("1960-02-08", "1960-02-13")) ,
+ identical(attr(p1, "labels"), paste("Feb", time2d(8:13))),
+ identical(chkPretty(MTbd + rep(0,2)), p1) ,
+ identical(chkPretty(MTbd + 0:1), p1) ,
+ identical(chkPretty(MTbd + -1:1), p1) ,
+ identical(chkPretty(MTbd + 0:3), seqDp("1960-02-09", "1960-02-14")) )
+## all pretty() above gave length >= 5 answer (with duplicated values!) in R <= 3.2.3!
+## and length 1 or 2 instead of about 6 in R 3.2.4
+(p2 <- chkPretty(as.POSIXct("2002-02-02 02:02", tz = "GMT-1"), n = 5, min.n = 5))
+stopifnot(length(p2) >= 5+1,
+ identical(p2, structure(1012611717 + (0:5), class = c("POSIXct", "POSIXt"),
+ tzone = "GMT-1", labels = time2d(57 + (0:5)))))
+## failed in R 3.2.4
+(T3 <- structure(1460019857.25, class = c("POSIXct", "POSIXt")))# typical Sys.date()
+chkPretty(T3, 1) # error in svn 70438
+## "Data" from example(pretty.Date) :
+steps <- setNames(,
+ c("10 secs", "1 min", "5 mins", "30 mins", "6 hours", "12 hours",
+ "1 DSTday", "2 weeks", "1 month", "6 months", "1 year",
+ "10 years", "50 years", "1000 years"))
+t02 <- as.POSIXct("2002-02-02 02:02")
+(at <- chkPretty(t02 + 0:1, n = 5, min.n = 3, max.D=2))
+xU <- as.POSIXct("2002-02-02 02:02", tz = "UTC")
+x5 <- as.POSIXct("2002-02-02 02:02", tz = "EST5EDT")
+atU <- chkPretty(seq(xU, by = "30 mins", length = 2), n = 5)
+at5 <- chkPretty(seq(x5, by = "30 mins", length = 2), n = 5)
+stopifnot(length(at) >= 4,
+ identical(sort(names(aat <- attributes(at))), c("class", "labels", "tzone")),
+ identical(aat$labels, time2d(59+ 0:3)),
+ identical(x5 - xU, structure(5, units = "hours", class = "difftime")),
+ identical(attr(at5, "labels"), attr(atU, "labels") -> lat),
+ identical(lat, paste("02", time2d(10* 0:4), sep=":"))
+)
+nns <- c(1:9, 15:17); names(nns) <- paste0("n=",nns)
+prSeq <- function(x, n, st, ...) pretty(seq(x, by = st, length = 2), n = n, ...)
+pps <- lapply(nns, function(n)
+ lapply(steps, function(st) prSeq(x=t02, n=n, st=st)))
+Ls.ok <- list(
+ `10 secs` = c("00", "02", "04", "06", "08", "10"),
+ `1 min` = sprintf("%02d", 10*((0:6) %% 6)),
+ `5 mins` = sprintf("02:%02d", 2:7),
+ `30 mins` = sprintf("02:%02d", (0:4)*10),
+ `6 hours` = sprintf("%02d:00", 2:9),
+ `12 hours` = sprintf("%02d:00", (0:5)*3),
+ `1 DSTday` = c("Feb 02 00:00", "Feb 02 06:00", "Feb 02 12:00",
+ "Feb 02 18:00", "Feb 03 00:00", "Feb 03 06:00"),
+ `2 weeks` = c("Jan 28", "Feb 04", "Feb 11", "Feb 18"),
+ `1 month` = c("Jan 28", "Feb 04", "Feb 11", "Feb 18", "Feb 25", "Mar 04"),
+ `6 months` = c("Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep"),
+ `1 year` = c("Jan", "Apr", "Jul", "Oct", "Jan", "Apr"),
+ `10 years` = as.character(2000 + 2*(1:7)),
+ `50 years` = as.character(2000 + 10*(0:6)),
+ `1000 years`= as.character(2000 + 200*(0:6)))
+stopifnot(identical(Ls.ok,
+ lapply(pps[["n=5"]], attr, "label")))
+##
+chkSeq <- function(st, x, n, max.D = if(n <= 4) 1 else if(n <= 10) 2 else 3, ...)
+ tryCatch(chkPretty(seq(x, by = st, length = 2), n = n, max.D=max.D, ...),
+ error = conditionMessage)
+prSeq.errs <- function(tt, nset, tSteps) {
+ stopifnot(length(tt) == 1)
+ c.ps <- lapply(nset, function(n) lapply(tSteps, chkSeq, x = tt, n = n))
+ ## ensure that all are ok *but* some which did not match 'n' well enough:
+ cc.ps <- unlist(c.ps, recursive=FALSE)
+ ok <- vapply(cc.ps, inherits, NA, what = "POSIXt")
+ errs <- unlist(cc.ps[!ok])
+ stopifnot(startsWith(errs, prefix = "| |pretty(.)| - (n+1) |"))
+ list(ok = ok,
+ Ds = as.numeric(sub(".*\\| = ([0-9]+) > max.*", "\\1", errs)))
+}
+r.t02 <- prSeq.errs(t02, nset = nns, tSteps = steps)
+table(r.t02 $ ok)
+table(r.t02 $ Ds -> Ds)
+## Currently [may improve]
+## 3 4 5 6 7 8
+## 4 14 6 3 2 1
+## ... and ensure we only improve:
+stopifnot(length(Ds) <= 30, max(Ds) <= 8, sum(Ds) <= 138)
+## A Daylight saving time -- halfmonth combo:
+(tOz <- structure(c(1456837200, 1460728800), class = c("POSIXct", "POSIXt"),
+ tzone = "Australia/Sydney"))
+(pz <- pretty(tOz)) # failed in R 3.3.0, PR#16923
+stopifnot(length(pz) <= 6, # is 5
+ attr(dpz <- diff(pz), "units") == "days", sd(dpz) < 1.6)
+if(FALSE) { # save 0.4 sec
+ print(system.time(
+ r.tOz <- prSeq.errs(tOz[1], nset = nns, tSteps = steps)
+ ))
+ stopifnot(sum(r.tOz $ ok) >= 132,
+ max(r.tOz $ Ds -> DOz) <= 8, mean(DOz) < 4.5)
+}
+nn <- c(1:33,10*(4:9),100*(1+unique(sort(rpois(20,4)))))
+pzn <- lengths(lapply(nn, pretty, x=tOz))
+stopifnot(0.5 <= min(pzn/(nn+1)), max(pzn/(nn+1)) <= 1.5)
+proc.time() - .pt; .pt <- proc.time()
+
+
+
+stopifnot(c("round.Date", "round.POSIXt") %in% as.character(methods(round)))
+## round.POSIXt suppressed in R <= 3.2.x
+
+
+## approxfun(*, method="constant")
+Fn <- ecdf(1:5)
+t <- c(NaN, NA, 1:5)
+stopifnot(all.equal(Fn(t), t/5))
+## In R <= 3.2.3, NaN values resulted in something like (n-1)/n.
+
+
+## tar() default (i.e. "no files") behaviour:
+dir.create(td <- tempfile("tar-experi"))
+setwd(td)
+dfil <- "base_Desc"
+file.copy(system.file("DESCRIPTION"), dfil)
+## tar w/o specified files
+tar("ex.tar")# all files, i.e. 'dfil'
+unlink(dfil)
+stopifnot(grepl(dfil, untar("ex.tar", list = TRUE)))
+untar("ex.tar")
+myF2 <- c(dfil, "ex.tar")
+stopifnot(identical(list.files(), myF2))
+unlink(myF2)
+## produced an empty tar file in R < 3.3.0, PR#16716
+
+
+## format.POSIXlt() of Jan.1 if 1941 or '42 is involved:
+tJan1 <- function(n1, n2)
+ strptime(paste0(n1:n2,"/01/01"), "%Y/%m/%d", tz="CET")
+wDSTJan1 <- function(n1, n2)
+ which("CEST" == sub(".* ", '', format(tJan1(n1,n2), usetz=TRUE)))
+(w8 <- wDSTJan1(1801, 2300))
+(w9 <- wDSTJan1(1901, 2300))
+stopifnot(identical(w8, 141:142),# exactly 1941:1942 had CEST on Jan.1
+ identical(w9, 41: 42))
+## for R-devel Jan.2016 to Mar.14 -- *AND* for R 3.2.4 -- the above gave
+## integer(0) and c(41:42, 99:100, ..., 389:390) respectively
+
+
+## tsp<- did not remove mts class
+z <- ts(cbind(1:5,1:5))
+tsp(z) <- NULL
+stopifnot(identical(class(z), "matrix"))
+## kept "mts" in 3.2.4, PR#16769
+
+
+## as.hclust() and str() for deeply nested dendrograms
+op <- options(expressions = 300) # so problem triggers early
+d500 <- mkDend(500, 'x', 'single')
+sink(tempfile()); str(d500) ; sink()
+hc2 <- as.hclust(d500)
+options(op)
+## gave .. nested too deeply / node stack overflow / "C stack usage ..."
+## for R <= 3.3.z
+
+
+
+## keep at end
+rbind(last = proc.time() - .pt,
+ total = proc.time())
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-1d.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-1d.R
new file mode 100644
index 0000000000000000000000000000000000000000..d460051fdcb07c27fd869d145f21ef9d45adf435
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-1d.R
@@ -0,0 +1,730 @@
+## Regression tests for R >= 3.4.0
+
+pdf("reg-tests-1d.pdf", encoding = "ISOLatin1.enc")
+.pt <- proc.time()
+
+## body() / formals() notably the replacement versions
+x <- NULL; tools::assertWarning( body(x) <- body(mean)) # to be error
+x <- NULL; tools::assertWarning(formals(x) <- formals(mean)) # to be error
+x <- NULL; tools::assertWarning(f <- body(x)); stopifnot(is.null(f))
+x <- NULL; tools::assertWarning(f <- formals(x)); stopifnot(is.null(f))
+## these all silently coerced NULL to a function in R <= 3.2.x
+
+
+## match(x, t): fast algorithm for length-1 'x' -- PR#16885
+## a) string 'x' when only encoding differs
+tmp <- "年付"
+tmp2 <- "\u5e74\u4ed8" ; Encoding(tmp2) <- "UTF-8"
+for(ex in list(c(tmp, tmp2), c("foo","foo"))) {
+ cat(sprintf("\n|%s|%s| :\n----------\n", ex[1], ex[2]))
+ for(enc in c("latin1", "UTF-8", "unknown")) { # , "MAC", "WINDOWS-1251"
+ cat(sprintf("%9s: ", enc))
+ tt <- ex[1]; Encoding(tt) <- enc; t2 <- ex[2]
+ if(identical(i1 <- ( tt %in% t2),
+ i2 <- (c(tt, "a") %in% t2)[1]))
+ cat(i1,"\n")
+ else
+ stop("differing: ", i1, ", ", i2)
+ }
+}
+##
+outerID <- function(x,y, ...) outer(x,y, Vectorize(identical,c("x","y")), ...)
+## b) complex 'x' with different kinds of NaN
+x0 <- c(0,1, NA_real_, NaN)
+z <- outer(x0,x0, complex, length.out=1L)
+z <- c(z[is.na(z)], # <- of length 4 * 4 - 2*2 = 12
+ as.complex(NaN), as.complex(0/0), # <- typically these two differ in bits
+ complex(real = NaN), complex(imaginary = NaN),
+ NA_complex_, complex(real = NA), complex(imaginary = NA))
+## 1..12 all differ, then
+symnum(outerID(z,z, FALSE,FALSE,FALSE,FALSE))# [14] differing from all on low level
+symnum(outerID(z,z)) # [14] matches 2, 13,15
+(mz <- match(z, z)) # (checked with m1z below)
+zRI <- rbind(Re=Re(z), Im=Im(z)) # and see the pattern :
+print(cbind(format = format(z), t(zRI), mz), quote=FALSE)
+stopifnot(apply(zRI, 2, anyNA)) # NA *or* NaN: all TRUE
+is.NA <- function(.) is.na(.) & !is.nan(.)
+(iNaN <- apply(zRI, 2, function(.) any(is.nan(.))))
+(iNA <- apply(zRI, 2, function(.) any(is.NA (.)))) # has non-NaN NA's
+## use iNA for consistency check once FIXME happened
+m1z <- sapply(z, match, table = z)
+stopifnot(identical(m1z, mz),
+ identical(m1z == 1L, iNA),
+ identical(match(z, NA, 0) == 1L, iNA),
+ identical(mz[mz != 1L], c(2L, 4L, 9L, 10L, 12L, 2L, 2L, 2L, 9L)))
+## m1z uses match(x, *) with length(x) == 1 and failed in R 3.3.0
+set.seed(17)
+for(. in 1:20) {
+ zz <- sample(z)
+ stopifnot(identical(match(zz,zz), vapply(zz, match, -1L, table = zz)))
+}
+##
+## PR#16909 - a consequence of the match() bug; check here too:
+dvn <- paste0("var\xe9", 1:2); Encoding(dvn) <- "latin1"
+dv <- data.frame(1:3, 3); names(dv) <- dvn; dv[,"var\u00e92"] <- 2
+stopifnot(ncol(dv) == 2, dv[,2] == 2, identical(names(dv), dvn))
+## in R 3.3.0, got a 3rd column
+
+
+## deparse(<complex>, "digits17")
+fz <- format(z <- c(outer(-1:2, 1i*(-1:1), `+`)))
+(fz0 <- sub("^ +","",z))
+r <- c(-1:1,100, 1e20); z2 <- c(outer(pi*r, 1i*r, `+`)); z2
+dz2 <- deparse(z2, control="digits17")
+stopifnot(identical(deparse(z, 200, control = "digits17"),
+ paste0("c(", paste(fz0, collapse=", "), ")")),
+ print((sum(nchar(dz2)) - 2) / length(z2)) < 22, # much larger in <= 3.3.0
+ ## deparse <-> parse equivalence, 17 digits should be perfect:
+ all.equal(z2, eval(parse(text = dz2)), tolerance = 3e-16)) # seen 2.2e-35 on 32b
+## deparse() for these was "ugly" in R <= 3.3.x
+
+
+## length(environment(.)) == #{objects}
+stopifnot(identical(length( baseenv()),
+ length(names(baseenv()))))
+## was 0 in R <= 3.3.0
+
+
+## "srcref"s of closures
+op <- options(keep.source = TRUE)# as in interactive use
+getOption("keep.source")
+stopifnot(identical(function(){}, function(){}),
+ identical(function(x){x+1},
+ function(x){x+1})); options(op)
+## where all FALSE in 2.14.0 <= R <= 3.3.x because of "srcref"s etc
+
+
+## PR#16925, radix sorting INT_MAX w/ decreasing=TRUE and na.last=TRUE
+## failed ASAN check and segfaulted on some systems.
+data <- c(2147483645L, 2147483646L, 2147483647L, 2147483644L)
+stopifnot(identical(sort(data, decreasing = TRUE, method = "radix"),
+ c(2147483647L, 2147483646L, 2147483645L, 2147483644L)))
+
+
+## as.factor(<named integer>)
+ni <- 1:2; Nni <- names(ni) <- c("A","B")
+stopifnot(identical(Nni, names(as.factor(ni))),
+ identical(Nni, names( factor(ni))),
+ identical(Nni, names( factor(ni+0))), # +0 : "double"
+ identical(Nni, names(as.factor(ni+0))))
+## The first one lost names in 3.1.0 <= R <= 3.3.0
+
+
+## strtrim(<empty>, *) should work as substr(<empty>, *) does
+c0 <- character(0)
+stopifnot(identical(c0, strtrim(c0, integer(0))))
+## failed in R <= 3.3.0
+
+
+## Factors with duplicated levels {created via low-level code}:
+set.seed(11)
+f0 <- factor(sample.int(9, 20, replace=TRUE))
+(f <- structure(f0, "levels" = as.character(c(2:7, 2:4))))
+tools::assertWarning(print(f))
+tools::assertError(validObject(f))
+## no warning in print() for R <= 3.3.x
+
+
+## R <= 3.3.0 returned integer(0L) from unlist() in this case:
+stopifnot(identical(levels(unlist(list(factor(levels="a")))), "a"))
+
+
+## diff(<difftime>)
+d <- as.POSIXct("2016-06-08 14:21", tz="UTC") + as.difftime(2^(-2:8), units="mins")
+dd <- diff(d)
+ddd <- diff(dd)
+d3d <- diff(ddd)
+d7d <- diff(d, differences = 7)
+(ldd <- list(dd=dd, ddd=ddd, d3d=d3d, d7d=d7d))
+stopifnot(identical(ddd, diff(d, differences = 2)),
+ identical(d3d, diff(d, differences = 3)))
+stopifnot(vapply(ldd, units, "") == "secs",
+ vapply(ldd, class, "") == "difftime",
+ lengths(c(list(d), ldd)) == c(11:8, 11-7))
+## was losing time units in R <= 3.3.0
+
+
+## sample(NA_real_) etc
+for(xx in list(NA, NA_integer_, NA_real_, NA_character_, NA_complex_, "NA", 1i))
+ stopifnot(identical(xx, sample(xx)))
+## error in R <= 3.3.1
+
+
+## merge.data.frame with names matching order()'s arguments (PR#17119)
+nf <- names(formals(order))
+nf <- nf[nf != "..."]
+v1 <- c(1,3,2)
+v2 <- c(4,2,3)
+for(nm in nf) {
+ cat(nm,":\n")
+ mdf <- merge(
+ as.data.frame(setNames(list(v1), nm=nm)),
+ as.data.frame(setNames(list(v2), nm=nm)), all = TRUE)
+ stopifnot(identical(mdf,
+ as.data.frame(setNames(list(0+ 1:4), nm=nm))))
+}
+## some were wrong, others gave an error in R <= 3.3.1
+
+
+## PR#16936: table() dropping "NaN" level & 'exclude' sometimes failing
+op <- options(warn = 2)# no warnings allowed
+(fN1 <- factor(c("NA", NA, "NbN", "NaN")))
+(tN1 <- table(fN1)) ##--> was missing 'NaN'
+(fN <- factor(c(rep(c("A","B"), 2), NA), exclude = NULL))
+(tN <- table(fN, exclude = "B")) ## had extraneous "B"
+(tN. <- table(fN, exclude = c("B",NA))) ## had extraneous "B" and NA
+stopifnot(identical(c(tN1), c(`NA`=1L, `NaN`=1L, NbN=1L))
+ , identical(c(tN), structure(2:1, .Names = c("A", NA)))
+ , identical(c(tN.), structure(2L, .Names = "A"))
+)
+## both failed in R <= 3.3.1
+stopifnot(identical(names(dimnames(table(data.frame(Titanic[2,2,,])))),
+ c("Age", "Survived", "Freq"))) # was wrong for ~ 32 hours
+##
+## Part II:
+x <- factor(c(1, 2, NA, NA), exclude = NULL) ; is.na(x)[2] <- TRUE
+x # << two "different" NA's (in codes | w/ level) looking the same in print()
+stopifnot(identical(x, structure(as.integer(c(1, NA, 3, 3)),
+ .Label = c("1", "2", NA), class = "factor")))
+(txx <- table(x, exclude = NULL))
+stopifnot(identical(txx, table(x, useNA = "ifany")),
+ identical(as.vector(txx), c(1:0, 3L)))
+## wrongly gave 1 0 2 for R versions 2.8.0 <= Rver <= 3.3.1
+u.opt <- list(no="no", ifa = "ifany", alw = "always")
+l0 <- c(list(`_` = table(x)),
+ lapply(u.opt, function(use) table(x, useNA=use)))
+xcl <- list(NULL=NULL, none=""[0], "NA"=NA, NANaN = c(NA,NaN))
+options(op) # warnings ok:
+lt <- lapply(xcl, function(X)
+ c(list(`_` = table(x, exclude=X)), #--> 4 warnings from (exclude, useNA):
+ lapply(u.opt, function(use) table(x, exclude=X, useNA=use))))
+(y <- factor(c(4,5,6:5)))
+ly <- lapply(xcl, function(X)
+ c(list(`_` = table(y, exclude=X)), #--> 4 warnings ...
+ lapply(u.opt, function(use) table(y, exclude=X, useNA=use))))
+lxy <- lapply(xcl, function(X)
+ c(list(`_` = table(x, y, exclude=X)), #--> 4 warnings ...
+ lapply(u.opt, function(use) table(x, y, exclude=X, useNA=use))))
+op <- options(warn = 2)# no warnings allowed
+
+stopifnot(
+ vapply(lt, function(i) all(vapply(i, class, "") == "table"), NA),
+ vapply(ly, function(i) all(vapply(i, class, "") == "table"), NA),
+ vapply(lxy,function(i) all(vapply(i, class, "") == "table"), NA)
+ , identical((ltNA <- lt [["NA" ]]), lt [["NANaN"]])
+ , identical((ltNl <- lt [["NULL"]]), lt [["none" ]])
+ , identical((lyNA <- ly [["NA" ]]), ly [["NANaN"]])
+ , identical((lyNl <- ly [["NULL"]]), ly [["none" ]])
+ , identical((lxyNA <- lxy[["NA" ]]), lxy[["NANaN"]])
+ , identical((lxyNl <- lxy[["NULL"]]), lxy[["none" ]])
+)
+## 'NULL' behaved special (2.8.0 <= R <= 3.3.1) and
+## *all* tables in l0 and lt were == (1 0 2) !
+ltN1 <- ltNA[[1]]; lyN1 <- lyNA[[1]]; lxyN1 <- lxyNA[[1]]
+lNl1 <- ltNl[[1]]; lyl1 <- lyNl[[1]]; lxyl1 <- lxyNl[[1]]
+
+stopifnot(
+ vapply(names(ltNA) [-1], function(n) identical(ltNA [[n]], ltN1 ), NA),
+ vapply(names(lyNA) [-1], function(n) identical(lyNA [[n]], lyN1 ), NA),
+ vapply(names(lxyNA)[-1], function(n) identical(lxyNA[[n]], lxyN1), NA),
+ identical(lyN1, lyl1),
+ identical(2L, dim(ltN1)), identical(3L, dim(lyN1)),
+ identical(3L, dim(lNl1)),
+ identical(dimnames(ltN1), list(x = c("1","2"))),
+ identical(dimnames(lNl1), list(x = c("1","2", NA))),
+ identical(dimnames(lyN1), list(y = paste(4:6))),
+ identical( 1:0 , as.vector(ltN1)),
+ identical(c(1:0,3L), as.vector(lNl1)),
+ identical(c(1:2,1L), as.vector(lyN1))
+ , identical(c(1L, rep(0L, 5)), as.vector(lxyN1))
+ , identical(dimnames(lxyN1), c(dimnames(ltN1), dimnames(lyN1)))
+ , identical(c(1L,1:0), as.vector(table(3:1, exclude=1, useNA = "always")))
+ , identical(c(1L,1L ), as.vector(table(3:1, exclude=1)))
+)
+
+x3N <- c(1:3,NA)
+(tt <- table(x3N, exclude=NaN))
+stopifnot(tt == 1, length(nt <- names(tt)) == 4, is.na(nt[4])
+ , identical(tt, table(x3N, useNA = "ifany"))
+ , identical(tt, table(x3N, exclude = integer(0)))
+ , identical(t3N <- table(x3N), table(x3N, useNA="no"))
+ , identical(c(t3N), setNames(rep(1L, 3), as.character(1:3)))
+ ##
+ , identical(c("2" = 1L), c(table(1:2, exclude=1) -> t12.1))
+ , identical(t12.1, table(1:2, exclude=1, useNA= "no"))
+ , identical(t12.1, table(1:2, exclude=1, useNA= "ifany"))
+ , identical(structure(1:0, .Names = c("2", NA)),
+ c( table(1:2, exclude=1, useNA= "always")))
+)
+options(op) # (revert to default)
+
+
+## contour() did not check args sufficiently
+tryCatch(contour(matrix(rnorm(100), 10, 10), levels = 0, labels = numeric()),
+ error = function(e) e$message)
+## caused segfault in R 3.3.1 and earlier
+
+
+## unique.warnings() needs better duplicated():
+.tmp <- lapply(list(0, 1, 0:1, 1:2, c(1,1), -1:1), function(x) wilcox.test(x))
+stopifnot(length(uw <- unique(warnings())) == 2)
+## unique() gave only one warning in R <= 3.3.1
+
+
+op <- options(warn = 2)# no warnings allowed
+
+## findInterval(x, vec) when 'vec' is of length zero
+n0 <- numeric(); TF <- c(TRUE, FALSE)
+stopifnot(0 == unlist(lapply(TF, function(L1)
+ lapply(TF, function(L2) lapply(TF, function(L3)
+ findInterval(x=8:9, vec=n0, L1, L2, L3))))))
+## did return -1's for all.inside=TRUE in R <= 3.3.1
+
+
+## droplevels(<factor with NA-level>)
+L3 <- c("A","B","C")
+f <- d <- factor(rep(L3, 2), levels = c(L3, "XX")); is.na(d) <- 3:4
+(dn <- addNA(d)) ## levels: A B C XX <NA>
+stopifnot(identical(levels(print(droplevels(dn))), c(L3, NA))
+ ## only XX must be dropped; R <= 3.3.1 also dropped <NA>
+ , identical(levels(droplevels(f)), L3)
+ , identical(levels(droplevels(d)), L3) # do *not* add <NA> here
+ , identical(droplevels(d ), d [, drop=TRUE])
+ , identical(droplevels(f ), f [, drop=TRUE])
+ , identical(droplevels(dn), dn[, drop=TRUE])
+ )
+
+
+## summary.default() no longer rounds (just its print() method does):
+set.seed(0)
+replicate(256, { x <- rnorm(1); stopifnot(summary(x) == x)}) -> .t
+replicate(256, { x <- rnorm(2+rpois(1,pi))
+ stopifnot(min(x) <= (sx <- summary(x)), sx <= max(x))}) -> .t
+## was almost always wrong in R <= 3.3.x
+
+
+## NULL in integer arithmetic
+i0 <- integer(0)
+stopifnot(identical(1L + NULL, 1L + integer()),
+ identical(2L * NULL, i0),
+ identical(3L - NULL, i0))
+## gave double() in R <= 3.3.x
+
+
+## factor(x, exclude) when 'x' or 'exclude' are character -------
+stopifnot(identical(factor(c(1:2, NA), exclude = ""),
+ factor(c(1:2, NA), exclude = NULL) -> f12N))
+fab <- factor(factor(c("a","b","c")), exclude = "c")
+stopifnot(identical(levels(fab), c("a","b")))
+faN <- factor(c("a", NA), exclude=NULL)
+stopifnot(identical(faN, factor(faN, exclude="c")))
+## differently with NA coercion warnings in R <= 3.3.x
+
+## factor(x, exclude = X) - coercing 'exclude' or not
+## From r-help/2005-April/069053.html :
+fNA <- factor(as.integer(c(1,2,3,3,NA)), exclude = NaN)
+stopifnot(identical(levels(fNA), c("1", "2", "3", NA)))
+## did exclude NA wrongly in R <= 3.3.x
+## Now when 'exclude' is a factor,
+cc <- c("x", "y", "NA")
+ff <- factor(cc)
+f2 <- factor(ff, exclude = ff[3]) # it *is* used
+stopifnot(identical(levels(f2), cc[1:2]))
+## levels(f2) still contained NA in R <= 3.3.x
+
+
+## arithmetic, logic, and comparison (relop) for 0-extent arrays
+(m <- cbind(a=1[0], b=2[0]))
+Lm <- m; storage.mode(Lm) <- "logical"
+Im <- m; storage.mode(Im) <- "integer"
+stopifnot(
+ identical( m, m + 1 ), identical( m, m + 1 [0]), identical( m, m + NULL),
+ identical(Im, Im+ 1L), identical(Im, Im + 1L[0]), identical(Im, Im + NULL),
+ identical(m, m + 2:3), identical(Im, Im + 2:3),
+ identical(Lm, m & 1), identical(Lm, m | 2:3),
+ identical(Lm, m & TRUE[0]), identical(Lm, Lm | FALSE[0]),
+ identical(Lm, m & NULL), # gave Error (*only* place where NULL was not allowed)
+ identical(Lm, m > 1), identical(Lm, m > .1[0]), identical(Lm, m > NULL),
+ identical(Lm, m <= 2:3)
+)
+mm <- m[,c(1:2,2:1,2)]
+tools::assertError(m + mm) # ... non-conformable arrays
+tools::assertError(m | mm) # ... non-conformable arrays
+tools::assertError(m == mm)# ... non-conformable arrays
+## in R <= 3.3.x, relop returned logical(0) and m + 2:3 returned numeric(0)
+
+## arithmetic, logic, and comparison (relop) -- inconsistency for 1x1 array o <vector >= 2>:
+(m1 <- matrix(1,1,1, dimnames=list("Ro","col")))
+(m2 <- matrix(1,2,1, dimnames=list(c("A","B"),"col")))
+if(FALSE) { # in the future (~ 2018):
+tools::assertError(m1 + 1:2) ## was [1] 2 3 even w/o warning in R <= 3.3.x
+} else tools::assertWarning(m1v <- m1 + 1:2); stopifnot(identical(m1v, 1+1:2))
+tools::assertError(m1 & 1:2) # ERR: dims [product 1] do not match the length of object [2]
+tools::assertError(m1 <= 1:2) # ERR: (ditto)
+##
+## non-0-length arrays combined with {NULL or double() or ...} *fail*
+n0 <- numeric(0)
+l0 <- logical(0)
+stopifnot(identical(m1 + NULL, n0), # as "always"
+ identical(m1 + n0 , n0), # as "always"
+ identical(m1 & NULL, l0), # ERROR in R <= 3.3.x
+ identical(m1 & l0, l0), # ERROR in R <= 3.3.x
+ identical(m1 > NULL, l0), # as "always"
+ identical(m1 > n0 , l0)) # as "always"
+## m2 was slightly different:
+stopifnot(identical(m2 + NULL, n0), # ERROR in R <= 3.3.x
+ identical(m2 + n0 , n0), # ERROR in R <= 3.3.x
+ identical(m2 & NULL, l0), # ERROR in R <= 3.3.x
+ identical(m2 & l0 , l0), # ERROR in R <= 3.3.x
+ identical(m2 == NULL, l0), # as "always"
+ identical(m2 == n0 , l0)) # as "always"
+
+
+## strcapture()
+stopifnot(identical(strcapture("(.+) (.+)",
+ c("One 1", "noSpaceInLine", "Three 3"),
+ proto=data.frame(Name="", Number=0)),
+ data.frame(Name=c("One", NA, "Three"),
+ Number=c(1, NA, 3))))
+
+
+## PR#17160: min() / max() arg.list starting with empty character
+TFT <- 1:3 %% 2 == 1
+stopifnot(
+ identical(min(character(), TFT), "0"),
+ identical(max(character(), TFT), "1"),
+ identical(max(character(), 3:2, 5:7, 3:0), "7"),
+ identical(min(character(), 3:2, 5:7), "2"),
+ identical(min(character(), 3.3, -1:2), "-1"),
+ identical(max(character(), 3.3, 4:0), "4"))
+## all gave NA in R <= 3.3.0
+
+
+## PR#17147: xtabs(~ exclude) fails in R <= 3.3.1
+exc <- exclude <- c(TRUE, FALSE)
+xt1 <- xtabs(~ exclude) # failed : The name 'exclude' was special
+xt2 <- xtabs(~ exc)
+xt3 <- xtabs(rep(1, length(exclude)) ~ exclude)
+noCall <- function(x) structure(x, call = NULL)
+stripXT <- function(x) structure(x, call = NULL, dimnames = unname(dimnames(x)))
+stopifnot(
+ identical(dimnames(xt1), list(exclude = c("FALSE", "TRUE"))),
+ identical(names(dimnames(xt2)), "exc"),
+ all.equal(stripXT(xt1), stripXT(xt2)),
+ all.equal(noCall (xt1), noCall (xt3)))
+## [fix was to call table() directly instead of via do.call(.)]
+
+
+## str(xtabs( ~ <var>)):
+stopifnot(grepl("'xtabs' int", capture.output(str(xt2))[1]))
+## did not mention "xtabs" in R <= 3.3.1
+
+
+## findInterval(x_with_ties, vec, left.open=TRUE)
+stopifnot(identical(
+ findInterval(c(6,1,1), c(0,1,3,5,7), left.open=TRUE), c(4L, 1L, 1L)))
+set.seed(4)
+invisible(replicate(100, {
+ vec <- cumsum(1 + rpois(6, 2))
+ x <- rpois(50, 3) + 0.5 * rbinom(50, 1, 1/4)
+ i <- findInterval(x, vec, left.open = TRUE)
+ .v. <- c(-Inf, vec, Inf)
+ isIn <- .v.[i+1] < x & x <= .v.[i+2]
+ if(! all(isIn)) {
+ dump(c("x", "vec"), file=stdout())
+ stop("not ok at ", paste(which(!isIn), collapse=", "))
+ }
+}))
+## failed in R <= 3.3.1
+
+
+## PR#17132 -- grepRaw(*, fixed = TRUE)
+stopifnot(
+ identical(1L, grepRaw("abcd", "abcd", fixed = TRUE)),
+ identical(integer(), grepRaw("abcdefghi", "a", all = TRUE, fixed = TRUE)))
+## length 0 and seg.faulted in R <= 3.3.2
+
+
+## PR#17186 - Sys.timezone() on some Debian-derived platforms
+(S.t <- Sys.timezone())
+if(is.na(S.t) || !nzchar(S.t)) stop("could not get timezone")
+## has been NA_character_ in Ubuntu 14.04.5 LTS
+
+
+## format()ing invalid hand-constructed POSIXlt objects
+d <- as.POSIXlt("2016-12-06"); d$zone <- 1
+tools::assertError(format(d))
+d$zone <- NULL
+stopifnot(identical(format(d),"2016-12-06"))
+d$zone <- "CET" # = previous, but 'zone' now is last
+tools::assertError(format(d))
+dlt <- structure(
+ list(sec = 52, min = 59L, hour = 18L, mday = 6L, mon = 11L, year = 116L,
+ wday = 2L, yday = 340L, isdst = 0L, zone = "CET", gmtoff = 3600L),
+ class = c("POSIXlt", "POSIXt"), tzone = c("", "CET", "CEST"))
+dlt$sec <- 10000 + 1:10 # almost three hours & uses re-cycling ..
+fd <- format(dlt)
+stopifnot(length(fd) == 10, identical(fd, format(dct <- as.POSIXct(dlt))))
+dlt2 <- as.POSIXlt(dct)
+stopifnot(identical(format(dlt2), fd))
+## The two assertError()s gave a seg.fault in R <= 3.3.2
+
+
+stopifnot(inherits(methods("("), "MethodsFunction"),
+ inherits(methods("{"), "MethodsFunction"))
+## methods("(") and ..("{") failed in R <= 3.3.2
+
+
+## moved after commit in r71778
+f <- eval(parse(text = "function() { x <- 1 ; for(i in 1:10) { i <- i }}",
+ keep.source = TRUE))
+g <- removeSource(f)
+stopifnot(is.null(attributes(body(g)[[3L]][[4L]])))
+
+## pmin/pmax of ordered factors -- broken in R 3.3.2 [PR #17195]
+of <- ordered(c(1,5,6))
+set.seed(7); rof <- sample(of, 12, replace=TRUE)
+stopifnot(identical(pmax(rof, of), ordered(pmax(c(rof), c(of)), labels=levels(rof)) -> pmar),
+ identical(pmax(of, rof), pmar),
+ identical(pmin(rof, of), ordered(pmin(c(rof), c(of)), labels=levels(rof)) -> pmir),
+ identical(pmin(of, rof), pmir),
+ identical(pmin(rof, 5), ordered(pmin(c(rof), 2), levels=1:3, labels=levels(rof))),
+ identical(pmax(rof, 6), ordered(pmax(c(rof), 3), levels=1:3, labels=levels(rof))),
+ identical(pmax(rof, 1), rof),
+ identical(pmin(rof, 6), rof),
+ identical(pmax(of, 5, rof), ordered(pmax(c(of),2L,c(rof)), levels=1:3,
+ labels=levels(of)))
+ )
+## these were "always" true .. but may change (FIXME ?)
+stopifnot(
+ identical(of, pmin(of, 3)) # what? error? at least warning?
+ ,
+ identical(pmar, pmax(of, 3, rof))
+)
+## pmin/pmax() of 0-length S3 classed [PR #17200]
+for(ob0 in list(I(character()), I(0[0]), I(0L[0]),
+ structure(logical(), class="L"),
+ structure(character(), class="CH"))) {
+ stopifnot(identical(ob0, pmax(ob0, ob0)),
+ identical(ob0, pmin(ob0, ob0)),
+ identical(ob0, pmin(ob0, "")),
+ identical(ob0, pmax(ob0, "")))
+}
+## pmin()/pmax() of matching numeric data frames
+mUSJ <- data.matrix(dUSJ <- USJudgeRatings)
+stopifnot(
+ identical( pmin(dUSJ, 10 - dUSJ),
+ as.data.frame(pmin(mUSJ, 10 - mUSJ))),
+ identical( pmax(dUSJ, 10 - dUSJ),
+ as.data.frame(pmax(mUSJ, 10 - mUSJ))))
+## had failed for a while. Note however :
+d1 <- data.frame(y0 = 0:3 +1/2) ; (d1.2 <- d1[1:2, , drop=FALSE])
+stopifnot(## FIXME: The 'NA's really are wrong
+ identical(pmax(d1,2), data.frame(y0 = c(2, NA, 2.5, 3.5)))
+ ,
+ identical(pmax(d1, 3-d1), data.frame(y0 = .5+c(2, 1:3)))
+ ,
+ identical(pmax(d1.2, 2), data.frame(y0 = c(2, NA)))
+ ,
+ identical(pmax(d1.2, 2-d1.2),data.frame(y0=c(1.5,1.5)))
+ ,
+ identical(pmin(d1, 2), data.frame(y0 = c(.5+0:1, NA,NA)))
+ ,
+ identical(pmin(d1, 3-d1), data.frame(y0 = .5+c(0, 1:-1)))
+ ,
+ identical(pmin(d1.2, 2), data.frame(y0 = c(.5, 1.5)))
+ ,
+ identical(pmin(d1.2, 2-d1.2),data.frame(y0 = c(.5,.5)))
+)
+## some CRAN pkgs have been relying that these at least "worked somehow"
+
+
+## quantile(x, prob) monotonicity in prob[] - PR#16672
+sortedQ <- function(x, prob, ...)
+ vapply(1:9, function(type)
+ !is.unsorted(quantile(x, prob, type=type, names=FALSE, ...)), NA)
+xN <- c(NA, 10.5999999999999996, NA, NA, NA, 10.5999999999999996,
+ NA, NA, NA, NA, NA, 11.3000000000000007, NA, NA,
+ NA, NA, NA, NA, NA, 5.2000000000000002)
+sQ.xN <- sortedQ(xN, probs = seq(0,1,1/10), na.rm = TRUE)
+x2 <- rep(-0.00090419678460984, 602)
+stopifnot(sQ.xN, sortedQ(x2, (0:5)/5))
+## both not fulfilled in R < 3.4.0
+
+
+## seq.int() anomalies in border cases, partly from Mick Jordan (on R-devel):
+stopifnot(
+ identical(1, seq.int(to=1, by=1 )),
+ identical(1:2, seq.int(to=2L, by=1L)),
+ identical(c(1L, 3L), seq.int(1L, 3L, length.out=2))
+)
+## the first was missing(.), the others "double" in R < 3.4.0
+tools::assertError(seq(1,7, by = 1:2))# gave warnings in R < 3.4.0
+## seq() for <complex> / <integer>
+stopifnot(all.equal(seq(1+1i, 9+2i, length.out = 9) -> sCplx,
+ 1:9 + 1i*seq(1,2, by=1/8)),
+ identical(seq(1+1i, 9+2i, along.with = 1:9), sCplx),
+ identical(seq(1L, 3L, by=1L), 1:3)
+)
+## had failed in R-devel for a few days
+D1 <- as.Date("2017-01-06")
+D2 <- as.Date("2017-01-12")
+seqD1 <- seq.Date(D1, D2, by = "1 day")
+stopifnot(identical(seqD1, seq(D1, D2, by = "1 days")),
+## These two work "accidentally" via seq -> seq.default + "Date"-arithmetic
+ identical(seqD1, seq(by = 1, from = D1, length.out = 7)),
+ identical(seqD1, seq(by = 1, to = D2, length.out = 7))
+## swap order of (by, to) ==> *FAILS* because directly calls seq.Date() - FIXME?
+ , TRUE ||
+ identical(seqD1, seq(to = D2, by = 1, length.out = 7))
+ )
+## had failed in R-devel for a couple of days
+stopifnot(identical(seq(9L, by = -1L, length.out = 4L), 9:6),
+ identical(seq(9L, by = -1L, length.out = 4 ), 9:6))
+## for consistency, new in R >= 3.4.0
+
+
+## Underflow happened when parsing small hex constants PR#17199
+stopifnot(
+ as.double("0x1.00000000d0000p-987") > 0, # should be 7.645296e-298
+ as.double("0x1.0000000000000p-1022") > 0, # should be 2.225074e-308
+ as.double("0x1.f89fc1a6f6613p-974") > 0 # should be 1.23456e-293
+)
+##
+
+
+## format.POSIX[cl]t() after print.POSIXct()
+dt <- "2012-12-12 12:12:12"
+x <- as.POSIXct(dt, tz = "GMT")
+stopifnot(identical(format(x), dt))
+(Sys.t <- Sys.timezone())
+someCET <- paste("Europe", c("Berlin", "Brussels", "Copenhagen", "Madrid",
+ "Paris", "Rome", "Vienna", "Zurich"), sep="/")
+if(Sys.t %in% someCET)
+ stopifnot(print(TRUE), identical(format(x, tz = ""), "2012-12-12 13:12:12"))
+## had failed for almost a month in R-devel & R-patched
+
+
+## xtabs() , notably with NA's :
+asArr <- function(x) {
+ attributes(x) <- list(dim=dim(x), dimnames=dimnames(x)); x }
+as_A <- function(x, A) array(x, dim=dim(A), dimnames=dimnames(A))
+eq_A <- function(a,b) ## equality of arrays, notably sparseMatrix vs dense
+ identical(dim(a),dim(b)) && identical(dimnames(a),dimnames(b)) &&
+ identical(as.vector(a), as.vector(b))
+esoph2 <- droplevels(subset(esoph, subset = tobgp > "10-19" & alcgp >= "40-79"))
+(xt <- xtabs(~ agegp + alcgp + tobgp, esoph2))
+stopifnot(identical(dim(xt), c(6L, 3L, 2L)), # of the 6 x 3 x 2 = 36 entries,
+ identical(which(xt == 0), c(7L, 12L, 18L, 23L, 30L, 32L, 36L)),
+ ## the above 8 are zeros and the rest is 1 :
+ all(xt[xt != 0] == 1))
+xtC <- xtabs(ncontrols ~ agegp + alcgp + tobgp, data = esoph2)
+stopifnot(# no NA's in data, hence result should have none, just 0's:
+ identical(asArr(unname(xtC)),
+ array(c(4, 14, 15, 17, 9, 3, 0, 2, 5, 6, 3, 0, 1, 4, 3, 3, 1, 0,
+ 7, 8, 7, 6, 0, 1, 2, 1, 4, 4, 1, 0, 2, 0, 4, 6, 1, 0),
+ dim = dim(xt))))
+
+DF <- as.data.frame(UCBAdmissions)
+xt <- xtabs(Freq ~ Gender + Admit, DF)
+stopifnot(identical(asArr(xt),
+ array(c(1198, 557, 1493, 1278), dim = c(2L, 2L),
+ dimnames = list(Gender = c("Male", "Female"),
+ Admit = c("Admitted", "Rejected")))))
+options(na.action = "na.omit")
+DN <- DF; DN[cbind(6:9, c(1:2,4,1))] <- NA; DN
+
+tools::assertError(# 'na.fail' should fail :
+ xtabs(Freq ~ Gender + Admit, DN, na.action = na.fail))
+xt. <- xtabs(Freq ~ Gender + Admit, DN)
+xtp <- xtabs(Freq ~ Gender + Admit, DN, na.action = na.pass)
+xtN <- xtabs(Freq ~ Gender + Admit, DN, addNA = TRUE)
+stopifnot(
+ identical(asArr(xt - xt.), as_A(c(120,17, 207, 8 ), xt)),
+ identical(asArr(xt - xtp), as_A(c(120,17, 207, NA), xt)), # not ok in R <= 3.3.2
+ identical(asArr(-xtN + rbind(cbind(xt, 0), 0)),
+ as_A(c(120, 17, -17, 207, NA, 0, -327, 0, 0), xtN))
+)
+## 'sparse = TRUE requires recommended package Matrix
+if(requireNamespace('Matrix')) {
+ xtS <- xtabs(Freq ~ Gender + Admit, DN, na.action = na.pass, sparse = TRUE)# error in R <= 3.3.2
+ xtNS <- xtabs(Freq ~ Gender + Admit, DN, addNA = TRUE, sparse = TRUE)
+ stopifnot(
+ eq_A(xt., xtabs(Freq ~ Gender + Admit, DN, sparse = TRUE)),
+ eq_A(xtp, xtS),
+ eq_A(xtN, xtNS)
+ )
+}
+## NA treatment partly wrong in R < 3.4.0; new option 'addNA'
+ee <- esoph[esoph[,"ncases"] > 0, c(1:2,4)]
+ee[,"ncases"] <- as.integer(ee[,"ncases"])
+(tt <- xtabs(ncases ~ ., ee))
+stopifnot(identical(as.vector(tt[1:2,]), # *integer* + first value
+ c(0L, 1L, 0L, 4L, 0L, 0L, 1L, 4L)))
+## keeping integer in sum()mation of integers
+
+
+## tapply() with FUN returning raw | with factor -> returning integer
+stopifnot(identical(tapply(1:3, 1:3, as.raw),
+ array(as.raw(1:3), 3L, dimnames=list(1:3))), ## failed in R < 3.4.0
+ identical(3:1, as.vector(tapply(1:3, 1:3, factor, levels=3:1))))
+
+
+## str(<list of list>, max.level = 1)
+LoL <- function(lenC, FUN = identity)
+ lapply(seq_along(lenC), function(i) lapply(seq_len(lenC[i]), FUN))
+xx <- LoL(c(7,3,17,798,3))
+str(xx, list.len = 7, max.level = 1)
+str2 <- capture.output(
+ str(xx, list.len = 7, max.level = 2))
+stopifnot(
+ grepl("List of ", capture.output(str(xx, list.len = 7, max.level = 1))),
+ length(str2) == 35, sum(grepl("list output truncated", str2)) == 2,
+ vapply(paste("List of", lengths(xx)), function(pat) any(grepl(pat, str2)), NA)
+)
+## wrongly showed '[list output truncated]' in R < 3.4.0
+
+
+## stopifnot(all.equal(.)) message abbreviation
+msg <- tryCatch(stopifnot(all.equal(rep(list(pi),4), list(3.1, 3.14, 3.141, 3.1415))),
+ error = conditionMessage)
+writeLines(msg)
+stopifnot(length(strsplit(msg,"\n")[[1]]) == 1+3+1)
+## was wrong for months in R-devel only
+
+
+## available.packages() (not) caching in case of errors
+tools::assertWarning(ap1 <- available.packages(repos = "http://foo.bar"))
+tools::assertWarning(ap2 <- available.packages(repos = "http://foo.bar"))
+stopifnot(nrow(ap1) == 0, identical(ap1, ap2))
+## had failed for a while in R-devel (left empty *.rds file)
+
+
+## rep()/rep.int() : when 'times' is a list
+stopifnot(identical(rep (4, list(3)), c(4,4,4)),
+ identical(rep.int(4, list(3)), c(4,4,4)),
+ identical(rep.int(4:5, list(2,1)), c(4L,4:5)),
+ identical(rep (4:5, list(2,1)), c(4L,4:5)))
+## partly failed in R 3.3.{2,3}
+
+
+## quantile(ordered(.)) - error message more directly useful
+OL <- ordered(sample(LETTERS, 20, replace=TRUE))
+(e <- tryCatch(quantile(OL), error = conditionMessage))
+stopifnot(grepl("type.*1.*3", e),# typically works in several locales
+ is.ordered(quantile(OL, type = 1)),
+ is.ordered(quantile(OL, type = 3)))
+## gave "factors are not allowed" in R <= 3.3.x
+
+## terms() ignored arg names (PR#17235)
+a1 <- attr(terms(y ~ f(x, a = z) + f(x, a = z)),
+ "term.labels")
+a2 <- attr(terms(y ~ f(x, a = z) + f(x, b = z)),
+ "term.labels")
+stopifnot(length(a1) == 1, length(a2) == 2)
+## both gave length 1
+
+
+## keep at end
+rbind(last = proc.time() - .pt,
+ total = proc.time())
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-2.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-2.R
new file mode 100644
index 0000000000000000000000000000000000000000..cf09fd49224dc8b49783b29d1b5de741d93084a9
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-2.R
@@ -0,0 +1,3048 @@
+## Regression tests for which the printed output is the issue
+### _and_ must work (no Recommended packages, please)
+
+pdf("reg-tests-2.pdf", encoding = "ISOLatin1.enc")
+
+## force standard handling for data frames
+options(stringsAsFactors=TRUE)
+options(useFancyQuotes=FALSE)
+
+### moved from various .Rd files
+## abbreviate
+for(m in 1:5) {
+ cat("\n",m,":\n")
+ print(as.vector(abbreviate(state.name, minl=m)))
+}
+
+## apply
+x <- cbind(x1 = 3, x2 = c(4:1, 2:5))
+dimnames(x)[[1]] <- letters[1:8]
+apply(x, 2, summary) # 6 x n matrix
+apply(x, 1, quantile)# 5 x n matrix
+
+d.arr <- 2:5
+arr <- array(1:prod(d.arr), d.arr,
+ list(NULL,letters[1:d.arr[2]],NULL,paste("V",4+1:d.arr[4],sep="")))
+aa <- array(1:20,c(2,2,5))
+str(apply(aa[FALSE,,,drop=FALSE], 1, dim))# empty integer, `incorrect' dim.
+stopifnot(
+ apply(arr, 1:2, sum) == t(apply(arr, 2:1, sum)),
+ aa == apply(aa,2:3,function(x) x),
+ all.equal(apply(apply(aa,2:3, sum),2,sum),
+ 10+16*0:4, tolerance = 4*.Machine$double.eps)
+)
+marg <- list(1:2, 2:3, c(2,4), c(1,3), 2:4, 1:3, 1:4)
+for(m in marg) print(apply(arr, print(m), sum))
+for(m in marg) ## 75% of the time here was spent on the names
+ print(dim(apply(arr, print(m), quantile, names=FALSE)) == c(5,d.arr[m]))
+
+## Bessel
+nus <- c(0:5,10,20)
+
+x0 <- 2^(-20:10)
+plot(x0,x0, log='xy', ylab="", ylim=c(.1,1e60),type='n',
+ main = "Bessel Functions -Y_nu(x) near 0\n log - log scale")
+for(nu in sort(c(nus,nus+.5))) lines(x0, -besselY(x0,nu=nu), col = nu+2)
+legend(3,1e50, leg=paste("nu=", paste(nus,nus+.5, sep=",")), col=nus+2, lwd=1)
+
+x <- seq(3,500);yl <- c(-.3, .2)
+plot(x,x, ylim = yl, ylab="",type='n', main = "Bessel Functions Y_nu(x)")
+for(nu in nus){xx <- x[x > .6*nu]; lines(xx,besselY(xx,nu=nu), col = nu+2)}
+legend(300,-.08, leg=paste("nu=",nus), col = nus+2, lwd=1)
+
+x <- seq(10,50000,by=10);yl <- c(-.1, .1)
+plot(x,x, ylim = yl, ylab="",type='n', main = "Bessel Functions Y_nu(x)")
+for(nu in nus){xx <- x[x > .6*nu]; lines(xx,besselY(xx,nu=nu), col = nu+2)}
+summary(bY <- besselY(2,nu = nu <- seq(0,100,len=501)))
+which(bY >= 0)
+summary(bY <- besselY(2,nu = nu <- seq(3,300,len=51)))
+summary(bI <- besselI(x = x <- 10:700, 1))
+## end of moved from Bessel.Rd
+
+## data.frame
+set.seed(123)
+L3 <- LETTERS[1:3]
+d <- data.frame(cbind(x=1, y=1:10), fac = sample(L3, 10, replace=TRUE))
+str(d)
+(d0 <- d[, FALSE]) # NULL dataframe with 10 rows
+(d.0 <- d[FALSE, ]) # <0 rows> dataframe (3 cols)
+(d00 <- d0[FALSE,]) # NULL dataframe with 0 rows
+stopifnot(identical(d, cbind(d, d0)),
+ identical(d, cbind(d0, d)))
+stopifnot(identical(d, rbind(d,d.0)),
+ identical(d, rbind(d.0,d)),
+ identical(d, rbind(d00,d)),
+ identical(d, rbind(d,d00)))
+## Comments: failed before ver. 1.4.0
+
+## diag
+diag(array(1:4, dim=5))
+## test behaviour with 0 rows or columns
+diag(0)
+z <- matrix(0, 0, 4)
+diag(z)
+diag(z) <- numeric(0)
+z
+## end of moved from diag.Rd
+
+## format
+## handling of quotes
+zz <- data.frame(a=I("abc"), b=I("def\"gh"))
+format(zz)
+## " (E fontification)
+
+## printing more than 16 is platform-dependent
+for(i in c(1:5,10,15,16)) cat(i,":\t",format(pi,digits=i),"\n")
+
+p <- c(47,13,2,.1,.023,.0045, 1e-100)/1000
+format.pval(p)
+format.pval(p / 0.9)
+format.pval(p / 0.9, dig=3)
+## end of moved from format.Rd
+
+
+## is.finite
+x <- c(100,-1e-13,Inf,-Inf, NaN, pi, NA)
+x # 1.000000 -3.000000 Inf -Inf NA 3.141593 NA
+names(x) <- formatC(x, dig=3)
+is.finite(x)
+##- 100 -1e-13 Inf -Inf NaN 3.14 NA
+##- T T . . . T .
+is.na(x)
+##- 100 -1e-13 Inf -Inf NaN 3.14 NA
+##- . . . . T . T
+which(is.na(x) & !is.nan(x))# only 'NA': 7
+
+is.na(x) | is.finite(x)
+##- 100 -1e-13 Inf -Inf NaN 3.14 NA
+##- T T . . T T T
+is.infinite(x)
+##- 100 -1e-13 Inf -Inf NaN 3.14 NA
+##- . . T T . . .
+
+##-- either finite or infinite or NA:
+all(is.na(x) != is.finite(x) | is.infinite(x)) # TRUE
+all(is.nan(x) != is.finite(x) | is.infinite(x)) # FALSE: have 'real' NA
+
+##--- Integer
+(ix <- structure(as.integer(x),names= names(x)))
+##- 100 -1e-13 Inf -Inf NaN 3.14 NA
+##- 100 0 NA NA NA 3 NA
+all(is.na(ix) != is.finite(ix) | is.infinite(ix)) # TRUE (still)
+
+storage.mode(ii <- -3:5)
+storage.mode(zm <- outer(ii,ii, FUN="*"))# integer
+storage.mode(zd <- outer(ii,ii, FUN="/"))# double
+range(zd, na.rm=TRUE)# -Inf Inf
+zd[,ii==0]
+
+(storage.mode(print(1:1 / 0:0)))# Inf "double"
+(storage.mode(print(1:1 / 1:1)))# 1 "double"
+(storage.mode(print(1:1 + 1:1)))# 2 "integer"
+(storage.mode(print(2:2 * 2:2)))# 4 "integer"
+## end of moved from is.finite.Rd
+
+
+## kronecker
+fred <- matrix(1:12, 3, 4, dimnames=list(LETTERS[1:3], LETTERS[4:7]))
+bill <- c("happy" = 100, "sad" = 1000)
+kronecker(fred, bill, make.dimnames = TRUE)
+
+bill <- outer(bill, c("cat"=3, "dog"=4))
+kronecker(fred, bill, make.dimnames = TRUE)
+
+# dimnames are hard work: let's test them thoroughly
+
+dimnames(bill) <- NULL
+kronecker(fred, bill, make=TRUE)
+kronecker(bill, fred, make=TRUE)
+
+dim(bill) <- c(2, 2, 1)
+dimnames(bill) <- list(c("happy", "sad"), NULL, "")
+kronecker(fred, bill, make=TRUE)
+
+bill <- array(1:24, c(3, 4, 2))
+dimnames(bill) <- list(NULL, NULL, c("happy", "sad"))
+kronecker(bill, fred, make=TRUE)
+kronecker(fred, bill, make=TRUE)
+
+fred <- outer(fred, c("frequentist"=4, "bayesian"=4000))
+kronecker(fred, bill, make=TRUE)
+## end of moved from kronecker.Rd
+
+## merge
+authors <- data.frame(
+ surname = c("Tukey", "Venables", "Tierney", "Ripley", "McNeil"),
+ nationality = c("US", "Australia", "US", "UK", "Australia"),
+ deceased = c("yes", rep("no", 4)))
+books <- data.frame(
+ name = c("Tukey", "Venables", "Tierney",
+ "Ripley", "Ripley", "McNeil", "R Core"),
+ title = c("Exploratory Data Analysis",
+ "Modern Applied Statistics ...",
+ "LISP-STAT",
+ "Spatial Statistics", "Stochastic Simulation",
+ "Interactive Data Analysis",
+ "An Introduction to R"),
+ other.author = c(NA, "Ripley", NA, NA, NA, NA,
+ "Venables & Smith"))
+b2 <- books; names(b2)[1] <- names(authors)[1]
+
+merge(authors, b2, all.x = TRUE)
+merge(authors, b2, all.y = TRUE)
+
+## empty d.f. :
+merge(authors, b2[7,])
+
+merge(authors, b2[7,], all.y = TRUE)
+merge(authors, b2[7,], all.x = TRUE)
+## end of moved from merge.Rd
+
+## NA
+is.na(c(1,NA))
+is.na(paste(c(1,NA)))
+is.na(list())# logical(0)
+ll <- list(pi,"C",NaN,Inf, 1:3, c(0,NA), NA)
+is.na (ll)
+lapply(ll, is.nan) # is.nan no longer works on lists
+## end of moved from NA.Rd
+
+## is.na was returning unset values on nested lists
+ll <- list(list(1))
+for (i in 1:5) print(as.integer(is.na(ll)))
+
+## scale
+## test out NA handling
+tm <- matrix(c(2,1,0,1,0,NA,NA,NA,0), nrow=3)
+scale(tm, , FALSE)
+scale(tm)
+## end of moved from scale.Rd
+
+## tabulate
+tabulate(numeric(0))
+## end of moved from tabulate.Rd
+
+## ts
+# Ensure working arithmetic for `ts' objects :
+stopifnot(z == z)
+stopifnot(z-z == 0)
+
+ts(1:5, start=2, end=4) # truncate
+ts(1:5, start=3, end=17)# repeat
+## end of moved from ts.Rd
+
+### end of moved
+
+
+## PR 715 (Printing list elements w/attributes)
+##
+l <- list(a=10)
+attr(l$a, "xx") <- 23
+l
+## Comments:
+## should print as
+# $a:
+# [1] 10
+# attr($a, "xx"):
+# [1] 23
+
+## On the other hand
+m <- matrix(c(1, 2, 3, 0, 10, NA), 3, 2)
+na.omit(m)
+## should print as
+# [,1] [,2]
+# [1,] 1 0
+# [2,] 2 10
+# attr(,"na.action")
+# [1] 3
+# attr(,"na.action")
+# [1] "omit"
+
+## and
+x <- 1
+attr(x, "foo") <- list(a="a")
+x
+## should print as
+# [1] 1
+# attr(,"foo")
+# attr(,"foo")$a
+# [1] "a"
+
+
+## PR 746 (printing of lists)
+##
+test.list <- list(A = list(formula=Y~X, subset=TRUE),
+ B = list(formula=Y~X, subset=TRUE))
+
+test.list
+## Comments:
+## should print as
+# $A
+# $A$formula
+# Y ~ X
+#
+# $A$subset
+# [1] TRUE
+#
+#
+# $B
+# $B$formula
+# Y ~ X
+#
+# $B$subset
+# [1] TRUE
+
+## Marc Feldesman 2001-Feb-01. Precision in summary.data.frame & *.matrix
+summary(attenu)
+summary(attenu, digits = 5)
+summary(data.matrix(attenu), digits = 5)# the same for matrix
+## Comments:
+## No difference between these in 1.2.1 and earlier
+set.seed(1)
+x <- c(round(runif(10), 2), 10000)
+summary(x)
+summary(data.frame(x))
+## Comments:
+## All entries show all 3 digits after the decimal point now.
+
+## Chong Gu 2001-Feb-16. step on binomials
+detg1 <-
+structure(list(Temp = structure(c(2L, 1L, 2L, 1L, 2L, 1L, 2L,
+ 1L, 2L, 1L, 2L, 1L), .Label = c("High", "Low"), class = "factor"),
+ M.user = structure(c(1L, 1L, 2L, 2L, 1L, 1L, 2L, 2L, 1L,
+ 1L, 2L, 2L), .Label = c("N", "Y"), class = "factor"),
+ Soft = structure(c(1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L),
+ .Label = c("Hard", "Medium", "Soft"), class = "factor"),
+ M = c(42, 30, 52, 43,
+ 50, 23, 55, 47, 53, 27, 49, 29), X = c(68, 42, 37, 24, 66,
+ 33, 47, 23, 63, 29, 57, 19)), .Names = c("Temp", "M.user",
+"Soft", "M", "X"), class = "data.frame", row.names = c("1", "3",
+"5", "7", "9", "11", "13", "15", "17", "19", "21", "23"))
+detg1.m0 <- glm(cbind(X,M)~1,binomial,detg1)
+detg1.m0
+step(detg1.m0,scope=list(upper=~M.user*Temp*Soft))
+
+## PR 829 (empty values in all.vars)
+## This example by Uwe Ligges <ligges@statistik.uni-dortmund.de>
+
+temp <- matrix(1:4, 2)
+all.vars(temp ~ 3) # OK
+all.vars(temp[1, ] ~ 3) # wrong in 1.2.1
+
+## 2001-Feb-22 from David Scott.
+## rank-deficient residuals in a manova model.
+gofX.df<-
+ structure(list(A = c(0.696706709347165, 0.362357754476673,
+-0.0291995223012888,
+0.696706709347165, 0.696706709347165, -0.0291995223012888, 0.696706709347165,
+-0.0291995223012888, 0.362357754476673, 0.696706709347165, -0.0291995223012888,
+0.362357754476673, -0.416146836547142, 0.362357754476673, 0.696706709347165,
+0.696706709347165, 0.362357754476673, -0.416146836547142, -0.0291995223012888,
+-0.416146836547142, 0.696706709347165, -0.416146836547142, 0.362357754476673,
+-0.0291995223012888), B = c(0.717356090899523, 0.932039085967226,
+0.999573603041505, 0.717356090899523, 0.717356090899523, 0.999573603041505,
+0.717356090899523, 0.999573603041505, 0.932039085967226, 0.717356090899523,
+0.999573603041505, 0.932039085967226, 0.909297426825682, 0.932039085967226,
+0.717356090899523, 0.717356090899523, 0.932039085967226, 0.909297426825682,
+0.999573603041505, 0.909297426825682, 0.717356090899523, 0.909297426825682,
+0.932039085967226, 0.999573603041505), C = c(-0.0291995223012888,
+-0.737393715541246, -0.998294775794753, -0.0291995223012888,
+-0.0291995223012888, -0.998294775794753, -0.0291995223012888,
+-0.998294775794753, -0.737393715541246, -0.0291995223012888,
+-0.998294775794753, -0.737393715541246, -0.653643620863612, -0.737393715541246,
+-0.0291995223012888, -0.0291995223012888, -0.737393715541246,
+-0.653643620863612, -0.998294775794753, -0.653643620863612,
+-0.0291995223012888,
+-0.653643620863612, -0.737393715541246, -0.998294775794753),
+ D = c(0.999573603041505, 0.67546318055115, -0.0583741434275801,
+ 0.999573603041505, 0.999573603041505, -0.0583741434275801,
+ 0.999573603041505, -0.0583741434275801, 0.67546318055115,
+ 0.999573603041505, -0.0583741434275801, 0.67546318055115,
+ -0.756802495307928, 0.67546318055115, 0.999573603041505,
+ 0.999573603041505, 0.67546318055115, -0.756802495307928,
+ -0.0583741434275801, -0.756802495307928, 0.999573603041505,
+ -0.756802495307928, 0.67546318055115, -0.0583741434275801
+ ), groups = 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), class = "factor", .Label = c("1",
+ "2", "3"))), .Names = c("A", "B", "C", "D", "groups"), row.names = 1:24,
+ class = "data.frame")
+
+gofX.manova <- manova(formula = cbind(A, B, C, D) ~ groups, data = gofX.df)
+try(summary(gofX.manova))
+## should fail with an error message `residuals have rank 3 < 4'
+
+## Prior to 1.3.0 dist did not handle missing values, and the
+## internal C code was incorrectly scaling for missing values.
+z <- as.matrix(t(trees))
+z[1,1] <- z[2,2] <- z[3,3] <- z[2,4] <- NA
+dist(z, method="euclidean")
+dist(z, method="maximum")
+dist(z, method="manhattan")
+dist(z, method="canberra")
+
+## F. Tusell 2001-03-07. printing kernels.
+kernel("daniell", m=5)
+kernel("modified.daniell", m=5)
+kernel("daniell", m=c(3,5,7))
+## fixed by patch from Adrian Trapletti 2001-03-08
+
+## Start new year (i.e. line) at Jan:
+(tt <- ts(1:10, start = c(1920,7), end = c(1921,4), freq = 12))
+cbind(tt, tt + 1)
+
+
+## PR 883 (cor(x,y) when is.null(y))
+try(cov(rnorm(10), NULL))
+try(cor(rnorm(10), NULL))
+## gave the variance and 1 respectively in 1.2.2.
+
+
+## PR 960 (format() of a character matrix converts to vector)
+## example from <John.Peters@tip.csiro.au>
+a <- matrix(c("axx","b","c","d","e","f","g","h"), nrow=2)
+format(a)
+format(a, justify="right")
+## lost dimensions in 1.2.3
+
+
+## PR 963
+res <- svd(rbind(1:7))## $v lost dimensions in 1.2.3
+if(res$u[1,1] < 0) {res$u <- -res$u; res$v <- -res$v}
+res
+
+
+## Make sure on.exit() keeps being evaluated in the proper env [from PD]:
+## A more complete example:
+g1 <- function(fitted) { on.exit(remove(fitted)); return(function(foo) foo) }
+g2 <- function(fitted) { on.exit(remove(fitted)); function(foo) foo }
+f <- function(g) { fitted <- 1; h <- g(fitted); print(fitted)
+ ls(envir=environment(h)) }
+f(g1)
+f(g2)
+
+f2 <- function()
+{
+ g.foo <- g1
+ g.bar <- g2
+ g <- function(x,...) UseMethod("g")
+ fitted <- 1; class(fitted) <- "foo"
+ h <- g(fitted); print(fitted); print(ls(envir=environment(h)))
+ fitted <- 1; class(fitted) <- "bar"
+ h <- g(fitted); print(fitted); print(ls(envir=environment(h)))
+ invisible(NULL)
+}
+f2()
+## The first case in f2() is broken in 1.3.0(-patched).
+
+## on.exit() consistency check from Luke:
+g <- function() as.environment(-1)
+f <- function(x) UseMethod("f")
+f.foo <- function(x) { on.exit(e <<- g()); NULL }
+f.bar <- function(x) { on.exit(e <<- g()); return(NULL) }
+f(structure(1,class = "foo"))
+ls(env = e)# only "x", i.e. *not* the GlobalEnv
+f(structure(1,class = "bar"))
+stopifnot("x" == ls(env = e))# as above; wrongly was .GlobalEnv in R 1.3.x
+
+
+## some tests that R supports logical variables in formulae
+## it coerced them to numeric prior to 1.4.0
+## they should appear like 2-level factors, following S
+
+oldCon <- options("contrasts")
+y <- rnorm(10)
+x <- rep(c(TRUE, FALSE), 5)
+model.matrix(y ~ x)
+lm(y ~ x)
+DF <- data.frame(x, y)
+lm(y ~ x, data=DF)
+options(contrasts=c("contr.helmert", "contr.poly"))
+model.matrix(y ~ x)
+lm(y ~ x, data=DF)
+z <- 1:10
+lm(y ~ x*z)
+lm(y ~ x*z - 1)
+options(oldCon)
+
+## diffinv, Adrian Trapletti, 2001-08-27
+x <- ts(1:10)
+diffinv(diff(x),xi=x[1])
+diffinv(diff(x,lag=1,differences=2),lag=1,differences=2,xi=x[1:2])
+## last had wrong start and end
+
+## PR#1072 (Reading Inf and NaN values)
+as.numeric(as.character(NaN))
+as.numeric(as.character(Inf))
+## were NA on Windows at least under 1.3.0.
+
+## PR#1092 (rowsum dimnames)
+rowsum(matrix(1:12, 3,4), c("Y","X","Y"))
+## rownames were 1,2 in <= 1.3.1.
+
+## PR#1115 (saving strings with ascii=TRUE)
+x <- y <- unlist(as.list(
+ parse(text=paste("\"\\", as.character(as.octmode(1:255)), "\"",sep=""))))
+save(x, ascii=TRUE, file=(fn <- tempfile()))
+load(fn)
+all(x==y)
+unlink(fn)
+## 1.3.1 had trouble with \
+
+
+## Some tests of sink() and connections()
+## capture all the output to a file.
+zz <- file("all.Rout", open="wt")
+sink(zz)
+sink(zz, type="message")
+try(log("a"))
+## back to the console
+sink(type="message")
+sink()
+try(log("a"))
+
+## capture all the output to a file.
+zz <- file("all.Rout", open="wt")
+sink(zz)
+sink(zz, type="message")
+try(log("a"))
+
+## bail out
+closeAllConnections()
+(foo <- showConnections())
+stopifnot(nrow(foo) == 0)
+try(log("a"))
+unlink("all.Rout")
+## many of these were untested before 1.4.0.
+
+
+## test mean() works on logical but not factor
+x <- c(TRUE, FALSE, TRUE, TRUE)
+mean(x)
+mean(as.factor(x))
+## last had confusing error message in 1.3.1.
+
+
+## Kurt Hornik 2001-Nov-13
+z <- table(x = 1:2, y = 1:2)
+z - 1
+unclass(z - 1)
+## lost object bit prior to 1.4.0, so printed class attribute.
+
+
+## PR#1226 (predict.mlm ignored newdata)
+ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14)
+trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69)
+group <- gl(2,10,20, labels = c("Ctl","Trt"))
+weight <- c(ctl, trt)
+data <- data.frame(weight, group)
+fit <- lm(cbind(w=weight, w2=weight^2) ~ group, data=data)
+predict(fit, newdata=data[1:2, ])
+## was 20 rows in R <= 1.4.0
+
+
+## Chong Gu 2002-Feb-8: `.' not expanded in drop1
+lab <- dimnames(HairEyeColor)
+HairEye <- cbind(expand.grid(Hair=lab$Hair, Eye=lab$Eye, Sex=lab$Sex,
+ stringsAsFactors = TRUE),
+ Fr = as.vector(HairEyeColor))
+HairEye.fit <- glm(Fr ~ . ^2, poisson, HairEye)
+drop1(HairEye.fit)
+## broken around 1.2.1 it seems.
+
+
+## PR#1329 (subscripting matrix lists)
+m <- list(a1=1:3, a2=4:6, a3=pi, a4=c("a","b","c"))
+dim(m) <- c(2,2)
+m
+m[,2]
+m[2,2]
+## 1.4.1 returned null components: the case was missing from a switch.
+
+m <- list(a1=1:3, a2=4:6, a3=pi, a4=c("a","b","c"))
+matrix(m, 2, 2)
+## 1.4.1 gave `Unimplemented feature in copyVector'
+
+x <- vector("list",6)
+dim(x) <- c(2,3)
+x[1,2] <- list(letters[10:11])
+x
+## 1.4.1 gave `incompatible types in subset assignment'
+
+
+## printing of matrix lists
+m <- list(as.integer(1), pi, 3+5i, "testit", TRUE, factor("foo"))
+dim(m) <- c(1, 6)
+m
+## prior to 1.5.0 had quotes for 2D case (but not kD, k > 2),
+## gave "numeric,1" etc, (even "numeric,1" for integers and factors)
+
+
+## ensure RNG is unaltered.
+for(type in c("Wichmann-Hill", "Marsaglia-Multicarry", "Super-Duper",
+ "Mersenne-Twister", "Knuth-TAOCP", "Knuth-TAOCP-2002"))
+{
+ set.seed(123, type)
+ print(RNGkind())
+ runif(100); print(runif(4))
+ set.seed(1000, type)
+ runif(100); print(runif(4))
+ set.seed(77, type)
+ runif(100); print(runif(4))
+}
+RNGkind(normal.kind = "Kinderman-Ramage")
+set.seed(123)
+RNGkind()
+rnorm(4)
+RNGkind(normal.kind = "Ahrens-Dieter")
+set.seed(123)
+RNGkind()
+rnorm(4)
+RNGkind(normal.kind = "Box-Muller")
+set.seed(123)
+RNGkind()
+rnorm(4)
+set.seed(123)
+runif(4)
+set.seed(123, "default")
+set.seed(123, "Marsaglia-Multicarry") ## Careful, not the default anymore
+runif(4)
+## last set.seed failed < 1.5.0.
+
+
+## merging, ggrothendieck@yifan.net, 2002-03-16
+d.df <- data.frame(x = 1:3, y = c("A","D","E"), z = c(6,9,10))
+merge(d.df[1,], d.df)
+## 1.4.1 got confused by inconsistencies in as.character
+
+
+## PR#1394 (levels<-.factor)
+f <- factor(c("a","b"))
+levels(f) <- list(C="C", A="a", B="b")
+f
+## was [1] C A; Levels: C A in 1.4.1
+
+
+## PR#1408 Inconsistencies in sum()
+x <- as.integer(2^30)
+sum(x, x) # did not warn in 1.4.1
+sum(c(x, x)) # did warn
+(z <- sum(x, x, 0.0)) # was NA in 1.4.1
+typeof(z)
+
+
+## NA levels in factors
+(x <- factor(c("a", "NA", "b"), exclude=NULL))
+## 1.4.1 had wrong order for levels
+is.na(x)[3] <- TRUE
+x
+## missing entry prints as <NA>
+
+
+## printing/formatting NA strings
+(x <- c("a", "NA", NA, "b"))
+print(x, quote = FALSE)
+paste(x)
+format(x)
+format(x, justify = "right")
+format(x, justify = "none")
+## not ideal.
+
+
+## print.ts problems ggrothendieck@yifan.net on R-help, 2002-04-01
+x <- 1:20
+tt1 <- ts(x,start=c(1960,2), freq=12)
+tt2 <- ts(10+x,start=c(1960,2), freq=12)
+cbind(tt1, tt2)
+## 1.4.1 had `Jan 1961' as `NA 1961'
+## ...and 1.9.1 had it as `Jan 1960'!!
+
+## glm boundary bugs (related to PR#1331)
+x <- c(0.35, 0.64, 0.12, 1.66, 1.52, 0.23, -1.99, 0.42, 1.86, -0.02,
+ -1.64, -0.46, -0.1, 1.25, 0.37, 0.31, 1.11, 1.65, 0.33, 0.89,
+ -0.25, -0.87, -0.22, 0.71, -2.26, 0.77, -0.05, 0.32, -0.64, 0.39,
+ 0.19, -1.62, 0.37, 0.02, 0.97, -2.62, 0.15, 1.55, -1.41, -2.35,
+ -0.43, 0.57, -0.66, -0.08, 0.02, 0.24, -0.33, -0.03, -1.13, 0.32,
+ 1.55, 2.13, -0.1, -0.32, -0.67, 1.44, 0.04, -1.1, -0.95, -0.19,
+ -0.68, -0.43, -0.84, 0.69, -0.65, 0.71, 0.19, 0.45, 0.45, -1.19,
+ 1.3, 0.14, -0.36, -0.5, -0.47, -1.31, -1.02, 1.17, 1.51, -0.33,
+ -0.01, -0.59, -0.28, -0.18, -1.07, 0.66, -0.71, 1.88, -0.14,
+ -0.19, 0.84, 0.44, 1.33, -0.2, -0.45, 1.46, 1, -1.02, 0.68, 0.84)
+y <- c(1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 0, 1, 1, 1, 0, 0, 1, 1, 1, 0,
+ 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 1, 0, 0, 1, 0, 1, 1,
+ 1, 0, 1, 1, 0, 1, 0, 0, 0, 1, 1, 0, 1, 0, 1, 1, 0, 1, 0, 0, 1,
+ 0, 1, 0, 1, 1, 0, 0, 0, 1, 1, 0, 1, 1, 0, 0, 1, 1, 1, 0, 0, 1,
+ 1, 0, 0, 1, 1, 1, 0, 1, 0, 1, 0, 1, 1, 1, 1, 0, 0)
+try(glm(y ~ x, family = poisson(identity)))
+## failed because start = NULL in 1.4.1
+## now gives useful error message
+glm(y ~ x, family = poisson(identity), start = c(1,0))
+## step reduction failed in 1.4.1
+set.seed(123)
+y <- rpois(100, pmax(3*x, 0))
+glm(y ~ x, family = poisson(identity), start = c(1,0))
+warnings()
+
+
+## extending char arrrays
+x <- y <- LETTERS[1:2]
+x[5] <- "C"
+length(y) <- 5
+x
+y
+## x was filled with "", y with NA in 1.5.0
+
+
+## formula with no intercept, 2002-07-22
+oldcon <- options(contrasts = c("contr.helmert", "contr.poly"))
+U <- gl(3, 6, 18, labels=letters[1:3])
+V <- gl(3, 2, 18, labels=letters[1:3])
+A <- rep(c(0, 1), 9)
+B <- rep(c(1, 0), 9)
+set.seed(1); y <- rnorm(18)
+terms(y ~ A:U + A:V - 1)
+lm(y ~ A:U + A:V - 1)$coefficients # 1.5.1 used dummies coding for V
+lm(y ~ (A + B) : (U + V) - 1) # 1.5.1 used dummies coding for A:V but not B:V
+options(oldcon)
+## 1.5.1 miscomputed the first factor in the formula.
+
+
+## quantile extremes, MM 13 Apr 2000 and PR#1852
+(qq <- sapply(0:5, function(k) {
+ x <- c(rep(-Inf,k+1), 0:k, rep(Inf, k))
+ sapply(1:9, function(typ)
+ quantile(x, pr=(2:10)/10, type=typ))
+}, simplify="array"))
+x <- c(-Inf, -Inf, Inf, Inf)
+median(x)
+quantile(x)
+## 1.5.1 had -Inf not NaN in several places
+
+
+## NAs in matrix dimnames
+z <- matrix(1:9, 3, 3)
+dimnames(z) <- list(c("x", "y", NA), c(1, NA, 3))
+z
+## NAs in dimnames misaligned when printing in 1.5.1
+
+
+## weighted aov (PR#1930)
+r <- c(10,23,23,26,17,5,53,55,32,46,10,8,10,8,23,0,3,22,15,32,3)
+n <- c(39,62,81,51,39,6,74,72,51,79,13,16,30,28,45,4,12,41,30,51,7)
+trt <- factor(rep(1:4,c(5,6,5,5)))
+Y <- r/n
+z <- aov(Y ~ trt, weights=n)
+## 1.5.1 gave unweighted RSS
+
+
+## rbind (PR#2266)
+test <- as.data.frame(matrix(1:25, 5, 5))
+test1 <- matrix(-(1:10), 2, 5)
+rbind(test, test1)
+rbind(test1, test)
+## 1.6.1 treated matrix as a vector.
+
+
+## escapes in non-quoted printing
+x <- "\\abc\\"
+names(x) <- 1
+x
+print(x, quote=FALSE)
+## 1.6.2 had label misaligned
+
+
+## summary on data frames containing data frames (PR#1891)
+x <- data.frame(1:10)
+x$z <- data.frame(x=1:10,yyy=11:20)
+summary(x)
+## 1.6.2 had NULL labels on output with z columns stacked.
+
+
+## re-orderings in terms.formula (PR#2206)
+form <- formula(y ~ a + b:c + d + e + e:d)
+(tt <- terms(form))
+(tt2 <- terms(formula(tt)))
+stopifnot(identical(tt, tt2))
+terms(delete.response(tt))
+## both tt and tt2 re-ordered the formula < 1.7.0
+## now try with a dot
+terms(breaks ~ ., data = warpbreaks)
+terms(breaks ~ . - tension, data = warpbreaks)
+terms(breaks ~ . - tension, data = warpbreaks, simplify = TRUE)
+terms(breaks ~ . ^2, data = warpbreaks)
+terms(breaks ~ . ^2, data = warpbreaks, simplify = TRUE)
+## 1.6.2 expanded these formulae out as in simplify = TRUE
+
+
+## printing attributes (PR#2506)
+(x <- structure(1:4, other=as.factor(LETTERS[1:3])))
+## < 1.7.0 printed the codes of the factor attribute
+
+
+## add logical matrix replacement indexing for data frames
+TEMP <- data.frame(VAR1=c(1,2,3,4,5), VAR2=c(5,4,3,2,1), VAR3=c(1,1,1,1,NA))
+TEMP[,c(1,3)][TEMP[,c(1,3)]==1 & !is.na(TEMP[,c(1,3)])] < -10
+TEMP
+##
+
+## moved from reg-plot.R as exact output depends on rounding error
+## PR 390 (axis for small ranges)
+
+relrange <- function(x) {
+ ## The relative range in EPS units
+ r <- range(x)
+ diff(r)/max(abs(r))/.Machine$double.eps
+}
+
+x <- c(0.12345678912345678,
+ 0.12345678912345679,
+ 0.12345678912345676)
+# relrange(x) ## 1.0125, but depends on strtod
+plot(x) # `extra horizontal' ; +- ok on Solaris; label off on Linux
+
+y <- c(0.9999563255363383973418,
+ 0.9999563255363389524533,
+ 0.9999563255363382863194)
+## The relative range number:
+# relrange(y) ## 3.000131, but depends on strtod
+plot(y)# once gave infinite loop on Solaris [TL]; y-axis too long
+
+## Comments: The whole issue was finally deferred to main/graphics.c l.1944
+## error("relative range of values is too small to compute accurately");
+## which is not okay.
+
+set.seed(101)
+par(mfrow = c(3,3))
+for(j.fac in 1e-12* c(10, 1, .7, .3, .2, .1, .05, .03, .01)) {
+## ====
+ #set.seed(101) # or don't
+ x <- pi + jitter(numeric(101), f = j.fac)
+ rrtxt <- paste("rel.range =", formatC(relrange(x), dig = 4),"* EPS")
+ cat("j.f = ", format(j.fac)," ; ", rrtxt,"\n",sep="")
+ plot(x, type = "l", main = rrtxt)
+ cat("par(\"usr\")[3:4]:", formatC(par("usr")[3:4], wid = 10),"\n",
+ "par(\"yaxp\") : ", formatC(par("yaxp"), wid = 10),"\n\n", sep="")
+}
+par(mfrow = c(1,1))
+## The warnings from inside GScale() will differ in their relrange() ...
+## >> do sloppy testing
+## 2003-02-03 hopefully no more. BDR
+## end of PR 390
+
+
+## scoping rules calling step inside a function
+"cement" <-
+ structure(list(x1 = c(7, 1, 11, 11, 7, 11, 3, 1, 2, 21, 1, 11, 10),
+ x2 = c(26, 29, 56, 31, 52, 55, 71, 31, 54, 47, 40, 66, 68),
+ x3 = c(6, 15, 8, 8, 6, 9, 17, 22, 18, 4, 23, 9, 8),
+ x4 = c(60, 52, 20, 47, 33, 22, 6, 44, 22, 26, 34, 12, 12),
+ y = c(78.5, 74.3, 104.3, 87.6, 95.9, 109.2, 102.7, 72.5,
+ 93.1, 115.9, 83.8, 113.3, 109.4)),
+ .Names = c("x1", "x2", "x3", "x4", "y"), class = "data.frame",
+ row.names = 1:13)
+teststep <- function(formula, data)
+{
+ d2 <- data
+ fit <- lm(formula, data=d2)
+ step(fit)
+}
+teststep(formula(y ~ .), cement)
+## failed in 1.6.2
+
+str(array(1))# not a scalar
+
+
+## na.print="" shouldn't apply to (dim)names!
+(tf <- table(ff <- factor(c(1:2,NA,2), exclude=NULL)))
+identical(levels(ff), dimnames(tf)[[1]])
+str(levels(ff))
+## not quite ok previous to 1.7.0
+
+
+## PR#3058 printing with na.print and right=TRUE
+a <- matrix( c(NA, "a", "b", "10",
+ NA, NA, "d", "12",
+ NA, NA, NA, "14"),
+ byrow=T, ncol=4 )
+print(a, right=TRUE, na.print=" ")
+print(a, right=TRUE, na.print="----")
+## misaligned in 1.7.0
+
+
+## assigning factors to dimnames
+A <- matrix(1:4, 2)
+aa <- factor(letters[1:2])
+dimnames(A) <- list(aa, NULL)
+A
+dimnames(A)
+## 1.7.0 gave internal codes as display and dimnames()
+## 1.7.1beta gave NAs via dimnames()
+## 1.8.0 converts factors to character
+
+
+## wishlist PR#2776: aliased coefs in lm/glm
+set.seed(123)
+x2 <- x1 <- 1:10
+x3 <- 0.1*(1:10)^2
+y <- x1 + rnorm(10)
+(fit <- lm(y ~ x1 + x2 + x3))
+summary(fit, cor = TRUE)
+(fit <- glm(y ~ x1 + x2 + x3))
+summary(fit, cor = TRUE)
+## omitted silently in summary.glm < 1.8.0
+
+
+## list-like indexing of data frames with drop specified
+women["height"]
+women["height", drop = FALSE] # same with a warning
+women["height", drop = TRUE] # ditto
+women[,"height", drop = FALSE] # no warning
+women[,"height", drop = TRUE] # a vector
+## second and third were interpreted as women["height", , drop] in 1.7.x
+
+
+## make.names
+make.names("")
+make.names(".aa")
+## was "X.aa" in 1.7.1
+make.names(".2")
+make.names(".2a") # not valid in R
+make.names(as.character(NA))
+##
+
+
+## strange names in data frames
+as.data.frame(list(row.names=17)) # 0 rows in 1.7.1
+aa <- data.frame(aa=1:3)
+aa[["row.names"]] <- 4:6
+aa # fine in 1.7.1
+A <- matrix(4:9, 3, 2)
+colnames(A) <- letters[1:2]
+aa[["row.names"]] <- A
+aa
+## wrong printed names in 1.7.1
+
+## assigning to NULL
+a <- NULL
+a[["a"]] <- 1
+a
+a <- NULL
+a[["a"]] <- "something"
+a
+a <- NULL
+a[["a"]] <- 1:3
+a
+## Last was an error in 1.7.1
+
+
+## examples of 0-rank models, some empty, some rank-deficient
+y <- rnorm(10)
+x <- rep(0, 10)
+(fit <- lm(y ~ 0))
+summary(fit)
+anova(fit)
+predict(fit)
+predict(fit, data.frame(x=x), se=TRUE)
+predict(fit, type="terms", se=TRUE)
+variable.names(fit) #should be empty
+model.matrix(fit)
+
+(fit <- lm(y ~ x + 0))
+summary(fit)
+anova(fit)
+predict(fit)
+predict(fit, data.frame(x=x), se=TRUE)
+predict(fit, type="terms", se=TRUE)
+variable.names(fit) #should be empty
+model.matrix(fit)
+
+(fit <- glm(y ~ 0))
+summary(fit)
+anova(fit)
+predict(fit)
+predict(fit, data.frame(x=x), se=TRUE)
+predict(fit, type="terms", se=TRUE)
+
+(fit <- glm(y ~ x + 0))
+summary(fit)
+anova(fit)
+predict(fit)
+predict(fit, data.frame(x=x), se=TRUE)
+predict(fit, type="terms", se=TRUE)
+## Lots of problems in 1.7.x
+
+
+## lm.influence on deficient lm models
+dat <- data.frame(y=rnorm(10), x1=1:10, x2=1:10, x3 = 0, wt=c(0,rep(1, 9)),
+ row.names=letters[1:10])
+dat[3, 1] <- dat[4, 2] <- NA
+lm.influence(lm(y ~ x1 + x2, data=dat, weights=wt, na.action=na.omit))
+lm.influence(lm(y ~ x1 + x2, data=dat, weights=wt, na.action=na.exclude))
+lm.influence(lm(y ~ 0, data=dat, weights=wt, na.action=na.omit))
+lm.influence(lm(y ~ 0, data=dat, weights=wt, na.action=na.exclude))
+lm.influence(lm(y ~ 0 + x3, data=dat, weights=wt, na.action=na.omit))
+lm.influence(lm(y ~ 0 + x3, data=dat, weights=wt, na.action=na.exclude))
+lm.influence(lm(y ~ 0, data=dat, na.action=na.exclude))
+## last three misbehaved in 1.7.x, none had proper names.
+
+
+## length of results in ARMAacf when lag.max is used
+ARMAacf(ar=c(1.3,-0.6, -0.2, 0.1),lag.max=1) # was 4 in 1.7.1
+ARMAacf(ar=c(1.3,-0.6, -0.2, 0.1),lag.max=2)
+ARMAacf(ar=c(1.3,-0.6, -0.2, 0.1),lag.max=3)
+ARMAacf(ar=c(1.3,-0.6, -0.2, 0.1),lag.max=4)
+ARMAacf(ar=c(1.3,-0.6, -0.2, 0.1),lag.max=5) # failed in 1.7.1
+ARMAacf(ar=c(1.3,-0.6, -0.2, 0.1),lag.max=6)
+ARMAacf(ar=c(1.3,-0.6, -0.2, 0.1),lag.max=10)
+##
+
+
+## Indexing non-existent columns in a data frame
+x <- data.frame(a = 1, b = 2)
+try(x[c("a", "c")])
+try(x[, c("a", "c")])
+try(x[1, c("a", "c")])
+## Second succeeded, third gave uniformative error message in 1.7.x.
+
+
+## methods(class = ) with namespaces, .Primitives etc (many missing in 1.7.x):
+meth2gen <- function(cl)
+ noquote(sub(paste("\\.",cl,"$",sep=""),"", c(.S3methods(class = cl))))
+meth2gen("data.frame")
+meth2gen("dendrogram")
+## --> the output may need somewhat frequent updating..
+
+
+## subsetting a 1D array lost the dimensions
+x <- array(1:5, dim=c(5))
+dim(x)
+dim(x[, drop=TRUE])
+dim(x[2:3])
+dim(x[2])
+dim(x[2, drop=FALSE])
+dimnames(x) <- list(some=letters[1:5])
+x[]
+x[2:3]
+x[2]
+x[2, drop=FALSE]
+## both dim and dimnames lost in 1.8.0
+
+
+## print.dist() didn't show NA's prior to 1.8.1
+x <- cbind(c(1,NA,2,3), c(NA,2,NA,1))
+(d <- dist(x))
+print(d, diag = TRUE)
+##
+
+
+## offsets in model terms where sometimes not deleted correctly
+attributes(terms(~ a + b + a:b + offset(c)))[c("offset", "term.labels")]
+attributes(terms(y ~ a + b + a:b + offset(c)))[c("offset", "term.labels")]
+attributes(terms(~ offset(c) + a + b + a:b))[c("offset", "term.labels")]
+attributes(terms(y ~ offset(c) + a + b + a:b))[c("offset", "term.labels")]
+## errors prior to 1.8.1
+
+
+## 0-level factors gave nonsensical answers in model.matrix
+m <- model.frame(~x, data.frame(x=NA), na.action=na.pass)
+model.matrix(~x, m)
+lm.fit <- lm(y ~ x, data.frame(x=1:10, y=1:10))
+try(predict(lm.fit, data.frame(x=NA)))
+## wrong answers in 1.8.0, refused to run in 1.8.1
+
+
+
+## failure to print data frame containing arrays
+## raised by John Fox on R-devel on 2004-01-08
+y1 <- array(1:10, dim=10)
+y2 <- array(1:30, dim=c(10,3), dimnames=list(NULL, letters[1:3]))
+y3 <- array(1:40, dim=c(10,2,2),
+ dimnames=list(NULL, letters[1:2], NULL))
+data.frame(y=y1)
+data.frame(y=y2)
+data.frame(y=y3)
+
+as.data.frame(y1)
+as.data.frame(y2)
+as.data.frame(y3)
+
+X <- data.frame(x=1:10)
+X$y <- y1
+X
+sapply(X, dim)
+
+X$y <- y2
+X
+sapply(X, dim)
+
+X$y <- y3
+X
+sapply(X, dim)
+## The last one fails in S.
+
+## test of user hooks
+for(id in c("A", "B")) {
+ eval(substitute(
+ {
+setHook(packageEvent("stats4", "onLoad"),
+ function(pkgname, ...) cat("onLoad", sQuote(pkgname), id, "\n"));
+setHook(packageEvent("stats4", "attach"),
+ function(pkgname, ...) cat("attach", sQuote(pkgname), id, "\n"));
+setHook(packageEvent("stats4", "detach"),
+ function(pkgname, ...) cat("detach", sQuote(pkgname), id, "\n"));
+setHook(packageEvent("stats4", "onUnload"),
+ function(pkgname, ...) cat("onUnload", sQuote(pkgname), id, "\n"))
+ },
+ list(id=id)))
+}
+loadNamespace("stats4")
+library("stats4")
+detach("package:stats4")
+unloadNamespace("stats4")
+## Just tests
+
+
+## rep(0-length-vector, length.out > 0)
+rep(integer(0), length.out=0)
+rep(integer(0), length.out=10)
+typeof(.Last.value)
+rep(logical(0), length.out=0)
+rep(logical(0), length.out=10)
+typeof(.Last.value)
+rep(numeric(0), length.out=0)
+rep(numeric(0), length.out=10)
+typeof(.Last.value)
+rep(character(0), length.out=0)
+rep(character(0), length.out=10)
+typeof(.Last.value)
+rep(complex(0), length.out=0)
+rep(complex(0), length.out=10)
+typeof(.Last.value)
+rep(list(), length.out=0)
+rep(list(), length.out=10)
+## always 0-length before 1.9.0
+
+
+## supplying 0-length data to array and matrix
+array(numeric(0), c(2, 2))
+array(list(), c(2,2))
+# worked < 1.8.0, error in 1.8.x
+matrix(character(0), 1, 2)
+matrix(integer(0), 1, 2)
+matrix(logical(0), 1, 2)
+matrix(numeric(0), 1, 2)
+matrix(complex(0), 1, 2)
+matrix(list(), 1, 2)
+## did not work < 1.9.0
+
+
+## S compatibility change in 1.9.0
+rep(1:2, each=3, length=12)
+## used to pad with NAs.
+
+
+## PR#6510: aov() with error and -1
+set.seed(1)
+test.df <- data.frame (y=rnorm(8), a=gl(2,1,8), b=gl(2,3,8),c=gl(2,4,8))
+aov(y ~ a + b + Error(c), data=test.df)
+aov(y ~ a + b - 1 + Error(c), data=test.df)
+## wrong assignment to strata labels < 1.9.0
+## Note this is unbalanced and not a good example
+
+binom.test(c(800,10))# p-value < epsilon
+
+
+## aov with a singular error model
+rd <- c(16.53, 12.12, 10.04, 15.32, 12.33, 10.1, 17.09, 11.69, 11.81, 14.75,
+ 10.72, 8.79, 13.14, 9.79, 8.36, 15.62, 9.64, 8.72, 15.32,
+ 11.35, 8.52, 13.27, 9.74, 8.78, 13.16, 10.16, 8.4, 13.08, 9.66,
+ 8.16, 12.17, 9.13, 7.43, 13.28, 9.16, 7.92, 118.77, 78.83, 62.2,
+ 107.29, 73.79, 58.59, 118.9, 66.35, 53.12, 372.62, 245.39, 223.72,
+ 326.03, 232.67, 209.44, 297.55, 239.71, 223.8)
+sample.df <- data.frame(dep.variable=rd,
+ subject=factor(rep(paste("subj",1:6, sep=""),each=9)),
+ f1=factor(rep(rep(c("f1","f2","f3"),each=6),3)),
+ f2=factor(rep(c("g1","g2","g3"),each=18))
+)
+sample.aov <- aov(dep.variable ~ f1 * f2 + Error(subject/(f1+f2)), data=sample.df)
+sample.aov
+summary(sample.aov)
+sample.aov <- aov(dep.variable ~ f1 * f2 + Error(subject/(f2+f1)), data=sample.df)
+sample.aov
+summary(sample.aov)
+## failed in 1.8.1
+
+
+## PR#6645 stem() with near-constant values
+stem(rep(1, 100))
+stem(rep(0.1, 10))
+stem(c(rep(1, 10), 1+1.e-8))
+stem(c(rep(1, 10), 1+1.e-9))
+stem(c(rep(1, 10), 1+1.e-10), atom=0) # integer-overflow is avoided.
+## had integer overflows in 1.8.1, and silly shifts of decimal point
+
+
+## PR#6633 warnings with vector op matrix, and more
+set.seed(1)
+x1 <- rnorm(3)
+y1 <- rnorm(4)
+x1 * y1
+x1 * as.matrix(y1) # no warning in 1.8.1
+x1 * matrix(y1,2,2)# ditto
+z1 <- x1 > 0
+z2 <- y1 > 0
+z1 & z2
+z1 & as.matrix(z2) # no warning in 1.8.1
+x1 < y1 # no warning in 1.8.1
+x1 < as.matrix(y1) # ditto
+##
+
+
+## summary method for mle
+library(stats4)
+N <- c(rep(3:6, 3), 7,7, rep(8,6), 9,9, 10,12)# sample from Pois(lam = 7)
+summary(mle(function(Lam = 1) -sum(dpois(N, Lam))))
+## "Coefficients" was "NULL" in 1.9.0's "devel"
+
+
+## PR#6656 terms.formula(simplify = TRUE) was losing offset terms
+## successive offsets caused problems
+df <- data.frame(x=1:4, y=sqrt( 1:4), z=c(2:4,1))
+fit1 <- glm(y ~ offset(x) + z, data=df)
+update(fit1, ". ~.")$call
+## lost offset in 1.7.0 to 1.8.1
+terms(y ~ offset(x) + offset(log(x)) + z, data=df)
+## failed to remove second offset from formula in 1.8.1
+terms(y ~ offset(x) + z - z, data=df, simplify = TRUE)
+## first fix failed for models with no non-offset terms.
+
+
+## only the first two were wrong up to 1.8.1:
+3:4 * 1e-100
+8:11* 1e-100
+1:2 * 1e-99
+1:2 * 1e+99
+8:11* 1e+99
+3:4 * 1e+100
+##
+
+
+## negative subscripts could be mixed with NAs
+x <- 1:3
+try(x[-c(1, NA)])
+## worked on some platforms, segfaulted on others in 1.8.1
+
+
+## vector 'border' (and no 'pch', 'cex' nor 'bg'):
+boxplot(count ~ spray, data = InsectSprays, border=2:7)
+## gave warnings in 1.9.0
+
+summary(as.Date(paste("2002-12", 26:31, sep="-")))
+## printed all "2002.-12-29" in 1.9.1 {because digits was too small}
+as.matrix(data.frame(d = as.POSIXct("2004-07-20")))
+## gave a warning in 1.9.1
+
+
+## Dump should quote when necessary (PR#6857)
+x <- quote(b)
+dump("x", "")
+## doesn't quote b in 1.9.0
+
+
+## some checks of indexing by character, used to test hashing code
+x <- 1:26
+names(x) <- letters
+x[c("a", "aa", "aa")] <- 100:102
+x
+
+x <- 1:26
+names(x) <- rep("", 26)
+x[c("a", "aa", "aa")] <- 100:102
+x
+##
+
+
+## tests of raw type
+# tests of logic operators
+x <- "A test string"
+(y <- charToRaw(x))
+(xx <- c(y, as.raw(0), charToRaw("more")))
+
+!y
+y & as.raw(15)
+y | as.raw(128)
+
+# tests of binary read/write
+zz <- file("testbin", "wb")
+writeBin(xx, zz)
+close(zz)
+zz <- file("testbin", "rb")
+(yy <- readBin(zz, "raw", 100))
+seek(zz, 0, "start")
+readBin(zz, "integer", n=100, size = 1) # read as small integers
+seek(zz, 0, "start")
+readBin(zz, "character", 100) # is confused by embedded nul.
+seek(zz, 0, "start")
+readChar(zz, length(xx)) # truncates at embedded nul
+seek(zz) # make sure current position is reported properly
+close(zz)
+unlink("testbin")
+
+# tests of ASCII read/write.
+cat(xx, file="testascii")
+scan("testascii", what=raw(0))
+unlink("testascii")
+##
+
+
+## Example of prediction not from newdata as intended.
+set.seed(1)
+y <- rnorm(10)
+x <- cbind(1:10, sample(1:10)) # matrix
+xt <- cbind(1:2, 3:4)
+(lm1 <- lm(y ~ x))
+predict(lm1, newdata = data.frame(x= xt))
+## warns as from 2.0.0
+
+
+## eval could alter a data.frame/list second argument
+data(trees)
+a <- trees
+eval(quote({Girth[1]<-NA;Girth}),a)
+a[1, ]
+trees[1, ]
+## both a and trees got altered in 1.9.1
+
+
+## write.table did not apply qmethod to col.names (PR#7171)
+x <- data.frame("test string with \"" = c("a \" and a '"), check.names=FALSE)
+write.table(x)
+write.table(x, qmethod = "double")
+## Quote in col name was unescaped in 1.9.1.
+
+
+## extensions to read.table
+Mat <- matrix(c(1:3, letters[1:3], 1:3, LETTERS[1:3],
+ c("2004-01-01", "2004-02-01", "2004-03-01"),
+ c("2004-01-01 12:00", "2004-02-01 12:00", "2004-03-01 12:00")),
+ 3, 6)
+foo <- tempfile()
+write.table(Mat, foo, col.names = FALSE, row.names = FALSE)
+read.table(foo, colClasses = c(NA, NA, "NULL", "character", "Date", "POSIXct"))
+unlist(sapply(.Last.value, class))
+read.table(foo, colClasses = c("factor",NA,"NULL","factor","Date","POSIXct"))
+unlist(sapply(.Last.value, class))
+read.table(foo, colClasses = c(V4="character"))
+unlist(sapply(.Last.value, class))
+unlink(foo)
+## added in 2.0.0
+
+
+## write.table with complex columns (PR#7260, in part)
+write.table(data.frame(x = 0.5+1:4, y = 1:4 + 1.5i), file = "")
+# printed all as complex in 2.0.0.
+write.table(data.frame(x = 0.5+1:4, y = 1:4 + 1.5i), file = "", dec=",")
+## used '.' not ',' in 2.0.0
+
+## splinefun() value test
+(x <- seq(0,6, length=25))
+mx <- sapply(c("fmm", "nat", "per"),
+ function(m) splinefun(1:5, c(1,2,4,3,1), method = m)(x))
+cbind(x,mx)
+
+
+## infinite loop in read.fwf (PR#7350)
+cat(file="test.txt", sep = "\n", "# comment 1", "1234567 # comment 2",
+ "1 234567 # comment 3", "12345 67 # comment 4", "# comment 5")
+read.fwf("test.txt", width=c(2,2,3), skip=1, n=4) # looped
+read.fwf("test.txt", width=c(2,2,3), skip=1) # 1 line short
+read.fwf("test.txt", width=c(2,2,3), skip=0)
+unlink("test.txt")
+##
+
+
+## split was not handling lists and raws
+split(as.list(1:3), c(1,1,2))
+(y <- charToRaw("A test string"))
+(z <- split(y, rep(1:5, times=c(1,1,4,1,6))))
+sapply(z, rawToChar)
+## wrong results in 2.0.0
+
+
+## tests of changed S3 implicit classes in 2.1.0
+foo <- function(x, ...) UseMethod("foo")
+foo.numeric <- function(x) cat("numeric arg\n")
+foo(1:10)
+foo(pi)
+foo(matrix(1:10, 2, 5))
+foo.integer <- function(x) cat("integer arg\n")
+foo.double <- function(x) cat("double arg\n")
+foo(1:10)
+foo(pi)
+foo(matrix(1:10, 2, 5))
+##
+
+
+## str() interpreted escape sequences prior to 2.1.0
+x <- "ab\bc\ndef"
+str(x)
+str(x, vec.len=0)# failed in rev 32244
+str(factor(x))
+
+x <- c("a", NA, "b")
+factor(x)
+factor(x, exclude="")
+str(x)
+str(factor(x))
+str(factor(x, exclude=""))
+##
+
+
+## print.factor(quote=TRUE) was not quoting levels
+x <- c("a", NA, "b", 'a " test') #" (comment for fontification)
+factor(x)
+factor(x, exclude="")
+print(factor(x), quote=TRUE)
+print(factor(x, exclude=""), quote=TRUE)
+## last two printed levels differently from values in 2.0.1
+
+
+## write.table in marginal cases
+x <- matrix(, 3, 0)
+write.table(x) # 3 rows
+write.table(x, row.names=FALSE)
+# note: scan and read.table won't read this as they take empty fields as NA
+## was 1 row in 2.0.1
+
+
+## More tests of write.table
+x <- list(a=1, b=1:2, c=3:4, d=5)
+dim(x) <- c(2,2)
+x
+write.table(x)
+
+x1 <- data.frame(a=1:2, b=I(matrix(LETTERS[1:4], 2, 2)), c = c("(i)", "(ii)"))
+x1
+write.table(x1) # In 2.0.1 had 3 headers, 4 cols
+write.table(x1, quote=c(2,3,4))
+
+x2 <- data.frame(a=1:2, b=I(list(a=1, b=2)))
+x2
+write.table(x2)
+
+x3 <- seq(as.Date("2005-01-01"), len=6, by="day")
+x4 <- data.frame(x=1:6, y=x3)
+dim(x3) <- c(2,3)
+x3
+write.table(x3) # matrix, so loses class
+x4
+write.table(x4) # preserves class, does not quote
+##
+
+
+## Problem with earlier regexp code spotted by KH
+grep("(.*s){2}", "Arkansas", v = TRUE)
+grep("(.*s){3}", "Arkansas", v = TRUE)
+grep("(.*s){3}", state.name, v = TRUE)
+## Thought Arkansas had 3 s's.
+
+
+## Replacing part of a non-existent column could create a short column.
+xx<- data.frame(a=1:4, b=letters[1:4])
+xx[2:3, "c"] <- 2:3
+## gave short column in R < 2.1.0.
+
+
+## add1/drop1 could give misleading results if missing values were involved
+y <- rnorm(1:20)
+x <- 1:20; x[10] <- NA
+x2 <- runif(20); x2[20] <- NA
+fit <- lm(y ~ x)
+drop1(fit)
+res <- try(stats:::drop1.default(fit))
+stopifnot(inherits(res, "try-error"))
+add1(fit, ~ . +x2)
+res <- try(stats:::add1.default(fit, ~ . +x2))
+stopifnot(inherits(res, "try-error"))
+## 2.0.1 ran and gave incorrect answers.
+
+
+## (PR#7789) escaped quotes in the first five lines for read.table
+tf <- tempfile()
+x <- c("6 'TV2 Shortland Street'",
+ "2 'I don\\\'t watch TV at 7'",
+ "1 'I\\\'m not bothered, whatever that looks good'",
+ "2 'I channel surf'")
+writeLines(x, tf)
+read.table(tf)
+x <- c("6 'TV2 Shortland Street'",
+ "2 'I don''t watch TV at 7'",
+ "1 'I''m not bothered, whatever that looks good'",
+ "2 'I channel surf'")
+writeLines(x, tf)
+read.table(tf, sep=" ")
+unlink(tf)
+## mangled in 2.0.1
+
+
+## (PR#7802) printCoefmat(signif.legend =FALSE) failed
+set.seed(123)
+cmat <- cbind(rnorm(3, 10), sqrt(rchisq(3, 12)))
+cmat <- cbind(cmat, cmat[,1]/cmat[,2])
+cmat <- cbind(cmat, 2*pnorm(-cmat[,3]))
+colnames(cmat) <- c("Estimate", "Std.Err", "Z value", "Pr(>z)")
+printCoefmat(cmat, signif.stars = TRUE)
+printCoefmat(cmat, signif.stars = TRUE, signif.legend = FALSE)
+# no stars, so no legend
+printCoefmat(cmat, signif.stars = FALSE)
+printCoefmat(cmat, signif.stars = TRUE, signif.legend = TRUE)
+## did not work in 2.1.0
+
+
+## PR#7824 subscripting an array by a matrix
+x <- matrix(1:6, ncol=2)
+x[rbind(c(1,1), c(2,2))]
+x[rbind(c(1,1), c(2,2), c(0,1))]
+x[rbind(c(1,1), c(2,2), c(0,0))]
+x[rbind(c(1,1), c(2,2), c(0,2))]
+x[rbind(c(1,1), c(2,2), c(0,3))]
+x[rbind(c(1,1), c(2,2), c(1,0))]
+x[rbind(c(1,1), c(2,2), c(2,0))]
+x[rbind(c(1,1), c(2,2), c(3,0))]
+x[rbind(c(1,0), c(0,2), c(3,0))]
+x[rbind(c(1,0), c(0,0), c(3,0))]
+x[rbind(c(1,1), c(2,2), c(1,2))]
+x[rbind(c(1,1), c(2,NA), c(1,2))]
+x[rbind(c(1,0), c(2,NA), c(1,2))]
+try(x[rbind(c(1,1), c(2,2), c(-1,2))])
+try(x[rbind(c(1,1), c(2,2), c(-2,2))])
+try(x[rbind(c(1,1), c(2,2), c(-3,2))])
+try(x[rbind(c(1,1), c(2,2), c(-4,2))])
+try(x[rbind(c(1,1), c(2,2), c(-1,-1))])
+try(x[rbind(c(1,1,1), c(2,2,2))])
+
+# verify that range checks are applied to negative indices
+x <- matrix(1:6, ncol=3)
+try(x[rbind(c(1,1), c(2,2), c(-3,3))])
+try(x[rbind(c(1,1), c(2,2), c(-4,3))])
+## generally allowed in 2.1.0.
+
+
+## printing RAW matrices/arrays was not implemented
+s <- sapply(0:7, function(i) rawShift(charToRaw("my text"),i))
+s
+dim(s) <- c(7,4,2)
+s
+## empty < 2.1.1
+
+
+## interpretation of '.' directly by model.matrix
+dd <- data.frame(a = gl(3,4), b = gl(4,1,12))
+model.matrix(~ .^2, data = dd)
+## lost ^2 in 2.1.1
+
+
+## add1.lm and drop.lm did not know about offsets (PR#8049)
+set.seed(2)
+y <- rnorm(10)
+z <- 1:10
+lm0 <- lm(y ~ 1)
+lm1 <- lm(y ~ 1, offset = 1:10)
+lm2 <- lm(y ~ z, offset = 1:10)
+
+add1(lm0, scope = ~ z)
+anova(lm1, lm2)
+add1(lm1, scope = ~ z)
+drop1(lm2)
+## Last two ignored the offset in 2.1.1
+
+
+## tests of raw conversion
+as.raw(1234)
+as.raw(list(a=1234))
+## 2.1.1: spurious and missing messages, wrong result for second.
+
+
+### end of tests added in 2.1.1 patched ###
+
+
+## Tests of logical matrix indexing with NAs
+df1 <- data.frame(a = c(NA, 0, 3, 4)); m1 <- as.matrix(df1)
+df2 <- data.frame(a = c(NA, 0, 0, 4)); m2 <- as.matrix(df2)
+df1[df1 == 0] <- 2; df1
+m1[m1 == 0] <- 2; m1
+df2[df2 == 0] <- 2; df2 # not allowed in 2.{0,1}.z
+m2[m2 == 0] <- 2; m2
+df1[df1 == 2] # this is first coerced to a matrix, and drops to a vector
+df3 <- data.frame(a=1:2, b=2:3)
+df3[df3 == 2] # had spurious names
+# but not allowed
+## (modified to make printed result the same whether numeric() is
+## compiled or interpreted)
+## try(df2[df2 == 2] <- 1:2)
+## try(m2[m2 == 2] <- 1:2)
+tryCatch(df2[df2 == 2] <- 1:2,
+ error = function(e) paste("Error:", conditionMessage(e)))
+tryCatch(m2[m2 == 2] <- 1:2,
+ error = function(e) paste("Error:", conditionMessage(e)))
+##
+
+
+## vector indexing of matrices: issue is when rownames are used
+# 1D array
+m1 <- c(0,1,2,0)
+dim(m1) <- 4
+dimnames(m1) <- list(1:4)
+m1[m1 == 0] # has rownames
+m1[which(m1 == 0)] # has rownames
+m1[which(m1 == 0, arr.ind = TRUE)] # no names < 2.2.0 (side effect of PR#937)
+
+# 2D array with 2 cols
+m2 <- as.matrix(data.frame(a=c(0,1,2,0), b=0:3))
+m2[m2 == 0] # a vector, had names < 2.2.0
+m2[which(m2 == 0)] # a vector, had names < 2.2.0
+m2[which(m2 == 0, arr.ind = TRUE)] # no names (PR#937)
+
+# 2D array with one col: could use rownames but do not.
+m21 <- m2[, 1, drop = FALSE]
+m21[m21 == 0]
+m21[which(m21 == 0)]
+m21[which(m21 == 0, arr.ind = TRUE)]
+## not consistent < 2.2.0: S never gives names
+
+
+## tests of indexing as quoted in Extract.Rd
+x <- NULL
+x$foo <- 2
+x # length-1 vector
+x <- NULL
+x[[2]] <- pi
+x # numeric vector
+x <- NULL
+x[[1]] <- 1:3
+x # list
+##
+
+
+## printing of a kernel:
+kernel(1)
+## printed wrongly in R <= 2.1.1
+
+
+## using NULL as a replacement value
+DF <- data.frame(A=1:2, B=3:4)
+try(DF[2, 1:3] <- NULL)
+## wrong error message in R < 2.2.0
+
+
+## tests of signif
+ob <- 0:9 * 2000
+print(signif(ob, 3), digits=17) # had rounding error in 2.1.1
+signif(1.2347e-305, 4)
+signif(1.2347e-306, 4) # only 3 digits in 2.1.1
+signif(1.2347e-307, 4)
+##
+
+### end of tests added in 2.2.0 patched ###
+
+
+## printing lists with NA names
+A <- list(1, 2)
+names(A) <- c("NA", NA)
+A
+## both printed as "NA" in 2.2.0
+
+
+## subscripting with both NA and "NA" names
+x <- 1:4
+names(x) <- c(NA, "NA", "a", "")
+x[names(x)]
+## 2.2.0 had the second matching the first.
+lx <- as.list(x)
+lx[[as.character(NA)]]
+lx[as.character(NA)]
+## 2.2.0 had both matching element 1
+
+
+## data frame replacement subscripting
+# Charles C. Berry, R-devel, 2005-10-26
+a.frame <- data.frame( x=letters[1:5] )
+a.frame[ 2:5, "y" ] <- letters[2:5]
+a.frame # added rows 1:4
+# and adding and replacing matrices failed
+a.frame[ ,"y" ] <- matrix(1:10, 5, 2)
+a.frame
+a.frame[3:5 ,"y" ] <- matrix(1:6, 3, 2)
+a.frame
+a.frame <- data.frame( x=letters[1:5] )
+a.frame[3:5 ,"y" ] <- matrix(1:6, 3, 2)
+a.frame
+## failed/wrong ans in 2.2.0
+
+
+### end of tests added in 2.2.0 patched ###
+
+
+## test of fix of trivial warning PR#8252
+pairs(iris[1:4], oma=rep(3,4))
+## warned in 2.2.0 only
+
+
+## str(<dendrogram>)
+dend <- as.dendrogram(hclust(dist(USArrests), "ave")) # "print()" method
+dend2 <- cut(dend, h=70)
+str(dend2$upper)
+## {{for Emacs: `}} gave much too many spaces in 2.2.[01]
+
+
+## formatC on Windows (PR#8337)
+xx <- pi * 10^(-5:4)
+cbind(formatC(xx, wid = 9))
+cbind(formatC(xx, wid = 9, flag = "-"))
+cbind(formatC(xx, wid = 9, flag = "0"))
+## extra space on 2.2.1
+
+
+## an impossible glm fit
+success <- c(13,12,11,14,14,11,13,11,12)
+failure <- c(0,0,0,0,0,0,0,2,2)
+predictor <- c(0, 5^(0:7))
+try(glm(cbind(success,failure) ~ 0+predictor, family = binomial(link="log")))
+# no coefficient is possible as the first case will have mu = 1
+## 2.2.1 gave a subscript out of range warning instead.
+
+
+## error message from solve (PR#8494)
+temp <- diag(1, 5)[, 1:4]
+rownames(temp) <- as.character(1:5)
+colnames(temp) <- as.character(1:4)
+try(solve(temp))
+# also complex
+try(solve(temp+0i))
+# and non-comformant systems
+try(solve(temp, diag(3)))
+## gave errors from rownames<- in 2.2.1
+
+
+## PR#8462 terms.formula(simplify = TRUE) needs parentheses.
+update.formula (Reaction ~ Days + (Days | Subject), . ~ . + I(Days^2))
+## < 2.3.0 dropped parens on second term.
+
+
+## PR#8528: errors in the post-2.1.0 pgamma
+pgamma(seq(0.75, 1.25, by=0.05)*1e100, shape = 1e100, log=TRUE)
+pgamma(seq(0.75, 1.25, by=0.05)*1e100, shape = 1e100, log=TRUE, lower=FALSE)
+pgamma(c(1-1e-10, 1+1e-10)*1e100, shape = 1e100)
+pgamma(0.9*1e25, 1e25, log=TRUE)
+## were NaN, -Inf etc in 2.2.1.
+
+
+## + for POSIXt objects was non-commutative
+# SPSS-style dates
+c(10485849600,10477641600,10561104000,10562745600)+ISOdate(1582,10,14)
+## was in the local time zone in 2.2.1.
+
+
+## Limiting lines on deparse (wishlist PR#8638)
+op <- options(deparse.max.lines = 3)
+f <- function(...) browser()
+do.call(f, mtcars)
+c
+
+options(error = expression(NULL))
+f <- function(...) stop()
+do.call(f, mtcars)
+traceback()
+
+## Debugger can handle a function that has a single function call as its body
+g <- function(fun) fun(1)
+debug(g)
+g(function(x) x+1)
+
+options(op)
+## unlimited < 2.3.0
+
+
+## row names in as.table (PR#8652)
+as.table(matrix(1:60, ncol=2))
+## rows past 26 had NA row names
+
+
+## summary on a glm with zero weights and estimated dispersion (PR#8720)
+y <- rnorm(10)
+x <- 1:10
+w <- c(rep(1,9), 0)
+summary(glm(y ~ x, weights = w))
+summary(glm(y ~ x, subset = w > 0))
+## has NA dispersion in 2.2.1
+
+
+## substitute was losing "..." after r37269
+yaa <- function(...) substitute(list(...))
+yaa(foo(...))
+## and wasn't substituting after "..."
+substitute(list(..., x), list(x=1))
+## fixed for 2.3.0
+
+
+## uniroot never warned (PR#8750)
+ff <- function(x) (x-pi)^3
+uniroot(ff, c(-10,10), maxiter=10)
+## should warn, did not < 2.3.0
+
+
+### end of tests added in 2.3.0 ###
+
+
+## prod etc on empty lists and raw vectors
+try(min(list()))
+try(max(list()))
+try(sum(list()))
+try(prod(list()))
+try(min(raw()))
+try(max(raw()))
+try(sum(raw()))
+try(prod(raw()))
+## Inf, -Inf, list(NULL) etc in 2.2.1
+
+r <- hist(rnorm(100), plot = FALSE, breaks = 12,
+ ## arguments which don't make sense for plot=FALSE - give a warning:
+ xlab = "N(0,1)", col = "blue")
+## gave no warning in 2.3.0 and earlier
+
+
+## rbind.data.frame on permuted cols (PR#8868)
+d1 <- data.frame(x=1:10, y=letters[1:10], z=1:10)
+d2 <- data.frame(y=LETTERS[1:5], z=5:1, x=7:11)
+rbind(d1, d2)
+# got factor y wrong in 2.3.0
+# and failed with duplicated col names.
+d1 <- data.frame(x=1:2, y=5:6, x=8:9, check.names=FALSE)
+d2 <- data.frame(x=3:4, x=-(1:2), y=8:9, check.names=FALSE)
+rbind(d1, d2)
+## corrupt in 2.3.0
+
+
+## sort.list on complex vectors was unimplemented prior to 2.4.0
+x <- rep(2:1, c(2, 2)) + 1i*c(4, 1, 2, 3)
+(o <- sort.list(x))
+x[o]
+sort(x) # for a cross-check
+##
+
+
+## PR#9044 write.table(quote=TRUE, row.names=FALSE) did not quote column names
+m <- matrix(1:9, nrow=3, dimnames=list(c("A","B","C"), c("I","II","III")))
+write.table(m)
+write.table(m, col.names=FALSE)
+write.table(m, row.names=FALSE)
+# wrong < 2.3.1 patched.
+write.table(m, quote=FALSE)
+write.table(m, col.names=FALSE, quote=FALSE)
+write.table(m, row.names=FALSE, quote=FALSE)
+d <- as.data.frame(m)
+write.table(d)
+write.table(d, col.names=FALSE)
+write.table(d, row.names=FALSE)
+write.table(d, quote=FALSE)
+write.table(d, col.names=FALSE, quote=FALSE)
+write.table(d, row.names=FALSE, quote=FALSE)
+write.table(m, quote=numeric(0)) # not the same as FALSE
+##
+
+
+## removing variable from baseenv
+try(remove("ls", envir=baseenv()))
+try(remove("ls", envir=asNamespace("base")))
+## no message in 2.3.1
+
+
+## tests of behaviour of factors
+(x <- factor(LETTERS[1:5])[2:4])
+x[2]
+x[[2]]
+stopifnot(identical(x[2], x[[2]]))
+as.list(x)
+(xx <- unlist(as.list(x)))
+stopifnot(identical(x, xx))
+as.vector(x, "list")
+(sx <- sapply(x, function(.).))
+stopifnot(identical(x, sx))
+## changed in 2.4.0
+
+
+## as.character on a factor with "NA" level
+as.character(as.factor(c("AB", "CD", NA)))
+as.character(as.factor(c("NA", "CD", NA))) # use <NA> is 2.3.x
+as.vector(as.factor(c("NA", "CD", NA))) # but this did not
+## used <NA> before
+
+
+## [ on a zero-column data frame, names of such
+data.frame()[FALSE]
+names(data.frame())
+# gave NULL names and hence spurious warning.
+
+
+## residuals from zero-weight glm fits
+d.AD <- data.frame(treatment = gl(3,3), outcome = gl(3,1,9),
+ counts = c(18,17,15,20,10,20,25,13,12))
+fit <- glm(counts ~ outcome + treatment, family = poisson,
+ data = d.AD, weights = c(0, rep(1,8)))
+residuals(fit, type="working") # first was NA < 2.4.0
+## working residuals were NA for zero-weight cases.
+fit2 <- glm(counts ~ outcome + treatment, family = poisson,
+ data = d.AD, weights = c(0, rep(1,8)), y = FALSE)
+for(z in c("response", "working", "deviance", "pearson"))
+ stopifnot(all.equal(residuals(fit, type=z), residuals(fit2, type=z),
+ scale = 1, tolerance = 1e-10))
+
+## apply on arrays with zero extents
+## Robin Hankin, R-help, 2006-02-13
+A <- array(0, c(3, 0, 4))
+dimnames(A) <- list(D1 = letters[1:3], D2 = NULL, D3 = LETTERS[1:4])
+f <- function(x) 5
+apply(A, 1:2, f)
+apply(A, 1, f)
+apply(A, 2, f)
+## dropped dims in 2.3.1
+
+
+## print a factor with names
+structure(factor(1:4), names = letters[1:4])
+## dropped names < 2.4.0
+
+
+## some tests of factor matrices
+A <- factor(7:12)
+dim(A) <- c(2, 3)
+A
+str(A)
+A[, 1:2]
+A[, 1:2, drop=TRUE]
+A[1,1] <- "9"
+A
+## misbehaved < 2.4.0
+
+
+## [dpqr]t with vector ncp
+nc <- c(0, 0.0001, 1)
+dt(1.8, 10, nc)
+pt(1.8, 10, nc)
+qt(0.95, 10, nc)
+## gave warnings in 2.3.1, short answer for qt.
+dt(1.8, 10, -nc[-1])
+pt(1.8, 10, -nc[-1])
+qt(0.95, 10, -nc[-1])
+## qt in 2.3.1 did not allow negative ncp.
+
+
+## merge() used to insert row names as factor, not character, so
+## sorting was unexpected.
+A <- data.frame(a = 1:4)
+row.names(A) <- c("2002-11-15", "2002-12-15", "2003-01-15", "2003-02-15")
+B <- data.frame(b = 1:4)
+row.names(B) <- c("2002-09-15", "2002-10-15", "2002-11-15", "2002-12-15")
+merge(A, B, by=0, all=TRUE)
+
+
+## assigning to a list loop index could alter the index (PR#9216)
+L <- list(a = list(txt = "original value"))
+f <- function(LL) {
+ for (ll in LL) ll$txt <- "changed in f"
+ LL
+}
+f(L)
+L
+## both were changed < 2.4.0
+
+
+## summary.mlm misbehaved with na.action = na.exclude
+n <- 50
+x <- runif(n=n)
+y1 <- 2 * x + rnorm(n=n)
+y2 <- 5 * x + rnorm(n=n)
+y2[sample(1:n, size=5)] <- NA
+y <- cbind(y1, y2)
+fit <- lm(y ~ 1, na.action="na.exclude")
+summary(fit)
+## failed < 2.4.0
+
+RNGkind("default","default")## reset to default - ease R core
+
+## prettyNum lost attributes (PR#8695)
+format(matrix(1:16, 4), big.mark = ",")
+## was a vector < 2.4.0
+
+
+## printing of complex numbers of very different magnitudes
+1e100 + 1e44i
+1e100 + pi*1i*10^(c(-100,0,1,40,100))
+## first was silly, second not rounded correctly in 2.2.0 - 2.3.1
+## We don't get them lining up, but that is a printf issue
+## that only happens for very large complex nos.
+
+
+### end of tests added in 2.4.0 ###
+
+
+## Platform-specific behaviour in lowess reported to R-help
+## 2006-10-12 by Frank Harrell
+x <- c(0,7,8,14,15,120,242)
+y <- c(122,128,130,158,110,110,92)
+lowess(x, y, iter=0)
+lowess(x, y)
+## MAD of iterated residuals was zero, and result depended on the platform.
+
+
+## PR#9263: problems with R_Visible
+a <- list(b=5)
+a[[(t<-'b')]]
+x <- matrix(5:-6, 3)
+x[2, invisible(3)]
+## both invisible in 2.4.0
+
+
+### end of tests added in 2.4.1 ###
+
+
+## tests of deparsing
+x <-list(a = NA, b = as.integer(NA), c=0+NA, d=0i+NA,
+ e = 1, f = 1:1, g = 1:3, h = c(NA, 1:3),
+ i = as.character(NA), j = c("foo", NA, "bar")
+ )
+dput(x, control=NULL)
+dput(x, control="keepInteger")
+dput(x, control="keepNA")
+dput(x)
+dput(x, control="all")
+dput(x, control=c("all", "S_compatible"))
+tmp <- tempfile()
+dput(x, tmp, control="all")
+stopifnot(identical(dget(tmp), x))
+dput(x, tmp, control=c("all", "S_compatible"))
+stopifnot(identical(dget(tmp), x))
+unlink(tmp)
+## changes in 2.5.0
+
+
+## give better error message for nls with no parameters
+## Ivo Welch, R-help, 2006-12-23.
+d <- data.frame(y= runif(10), x=runif(10))
+try(nls(y ~ 1/(1+x), data = d, start=list(x=0.5,y=0.5), trace=TRUE))
+## changed in 2.4.1 patched
+
+
+## cut(breaks="years"), in part PR#9433
+cut(as.Date(c("2000-01-17","2001-01-13","2001-01-20")), breaks="years")
+cut(as.POSIXct(c("2000-01-17","2001-01-13","2001-01-20")), breaks="years")
+## did not get day 01 < 2.4.1 patched
+
+
+## manipulating rownames: problems in pre-2.5.0
+A <- data.frame(a=character(0))
+try(row.names(A) <- 1:10) # succeeded in Dec 2006
+A <- list(a=1:3)
+class(A) <- "data.frame"
+row.names(A) <- letters[24:26] # failed at one point in Dec 2006
+A
+##
+
+
+## extreme cases for subsetting of data frames
+w <- women[1, ]
+w[]
+w[,drop = TRUE]
+w[1,]
+w[,]
+w[1, , drop = FALSE]
+w[, , drop = FALSE]
+w[1, , drop = TRUE]
+w[, , drop = TRUE]
+## regression test: code changed for 2.5.0
+
+
+## data.frame() with zero columns ignored 'row.names'
+(x <- data.frame(row.names=1:4))
+nrow(x)
+row.names(x)
+attr(x, "row.names")
+## ignored prior to 2.5.0.
+
+
+## identical on data.frames
+d0 <- d1 <- data.frame(1:4, row.names=1:4)
+row.names(d0) <- NULL
+dput(d0)
+dput(d1)
+identical(d0, d1)
+all.equal(d0, d1)
+row.names(d1) <- as.character(1:4)
+dput(d1)
+identical(d0, d1)
+all.equal(d0, d1)
+## identical used internal representation prior to 2.5.0
+
+
+## all.equal
+# ignored check.attributes in 2.4.1
+all.equal(data.frame(x=1:5, row.names=letters[1:5]),
+ data.frame(x=1:5,row.names=LETTERS[1:5]),
+ check.attributes=FALSE)
+# treated logicals as numeric
+all.equal(c(T, F, F), c(T, T, F))
+all.equal(c(T, T, F), c(T, F, F))
+# ignored raw:
+all.equal(as.raw(1:3), as.raw(1:3))
+all.equal(as.raw(1:3), as.raw(3:1))
+##
+
+
+## tests of deparsing
+# if we run this from stdin, we will have no source, so fake it
+f <- function(x, xm = max(1L, x)) {xx <- 0L; yy <- NA_real_}
+attr(f, "srcref") <- srcref(srcfilecopy("",
+ "function(x, xm = max(1L, x)) {xx <- 0L; yy <- NA_real_}"),
+ c(1L, 1L, 1L, 56L))
+f # uses the source
+dput(f) # not source
+dput(f, control="all") # uses the source
+cat(deparse(f), sep="\n")
+dump("f", file="")
+# remove the source
+attr(f, "srcref") <- NULL
+f
+dput(f, control="all")
+dump("f", file="")
+
+expression(bin <- bin + 1L)
+## did not preserve e.g. 1L at some point in pre-2.5.0
+
+
+## NAs in substr were handled as large negative numbers
+x <- "abcde"
+substr(x, 1, 3)
+substr(x, NA, 1)
+substr(x, 1, NA)
+substr(x, NA, 3) <- "abc"; x
+substr(x, 1, NA) <- "AA"; x
+substr(x, 1, 2) <- NA_character_; x
+## "" or no change in 2.4.1, except last
+
+
+## regression tests for pmin/pmax, rewritten in C for 2.5.0
+# NULL == integer(0)
+pmin(NULL, integer(0))
+pmax(integer(0), NULL)
+pmin(NULL, 1:3)# now ok
+pmax(pi, NULL, 2:4)
+
+x <- c(1, NA, NA, 4, 5)
+y <- c(2, NA, 4, NA, 3)
+pmin(x, y)
+stopifnot(identical(pmin(x, y), pmin(y, x)))
+pmin(x, y, na.rm=TRUE)
+stopifnot(identical(pmin(x, y, na.rm=TRUE), pmin(y, x, na.rm=TRUE)))
+pmax(x, y)
+stopifnot(identical(pmax(x, y), pmax(y, x)))
+pmax(x, y, na.rm=TRUE)
+stopifnot(identical(pmax(x, y, na.rm=TRUE), pmax(y, x, na.rm=TRUE)))
+
+x <- as.integer(x); y <- as.integer(y)
+pmin(x, y)
+stopifnot(identical(pmin(x, y), pmin(y, x)))
+pmin(x, y, na.rm=TRUE)
+stopifnot(identical(pmin(x, y, na.rm=TRUE), pmin(y, x, na.rm=TRUE)))
+pmax(x, y)
+stopifnot(identical(pmax(x, y), pmax(y, x)))
+pmax(x, y, na.rm=TRUE)
+stopifnot(identical(pmax(x, y, na.rm=TRUE), pmax(y, x, na.rm=TRUE)))
+
+x <- as.character(x); y <- as.character(y)
+pmin(x, y)
+stopifnot(identical(pmin(x, y), pmin(y, x)))
+pmin(x, y, na.rm=TRUE)
+stopifnot(identical(pmin(x, y, na.rm=TRUE), pmin(y, x, na.rm=TRUE)))
+pmax(x, y)
+stopifnot(identical(pmax(x, y), pmax(y, x)))
+pmax(x, y, na.rm=TRUE)
+stopifnot(identical(pmax(x, y, na.rm=TRUE), pmax(y, x, na.rm=TRUE)))
+
+# tests of classed quantities
+x <- .leap.seconds[1:23]; y <- rev(x)
+x[2] <- y[2] <- x[3] <- y[4] <- NA
+format(pmin(x, y), tz="GMT") # TZ names differ by platform
+class(pmin(x, y))
+stopifnot(identical(pmin(x, y), pmin(y, x)))
+format(pmin(x, y, na.rm=TRUE), tz="GMT")
+stopifnot(identical(pmin(x, y, na.rm=TRUE), pmin(y, x, na.rm=TRUE)))
+format(pmax(x, y), tz="GMT")
+stopifnot(identical(pmax(x, y), pmax(y, x)))
+format(pmax(x, y, na.rm=TRUE), tz="GMT")
+stopifnot(identical(pmax(x, y, na.rm=TRUE), pmax(y, x, na.rm=TRUE)))
+
+x <- as.POSIXlt(x, tz="GMT"); y <- as.POSIXlt(y, tz="GMT")
+format(pmin(x, y), tz="GMT")
+class(pmin(x, y))
+stopifnot(identical(pmin(x, y), pmin(y, x)))
+format(pmin(x, y, na.rm=TRUE), tz="GMT")
+stopifnot(identical(pmin(x, y, na.rm=TRUE), pmin(y, x, na.rm=TRUE)))
+format(pmax(x, y), tz="GMT")
+stopifnot(identical(pmax(x, y), pmax(y, x)))
+format(pmax(x, y, na.rm=TRUE), tz="GMT")
+stopifnot(identical(pmax(x, y, na.rm=TRUE), pmax(y, x, na.rm=TRUE)))
+## regresion tests
+
+
+## regression tests on names of 1D arrays
+x <- as.array(1:3)
+names(x) <- letters[x] # sets dimnames, really
+names(x)
+dimnames(x)
+attributes(x)
+names(x) <- NULL
+attr(x, "names") <- LETTERS[x] # sets dimnames, really
+names(x)
+dimnames(x)
+attributes(x)
+## regression tests
+
+
+## regression tests on NA attribute names
+x <- 1:3
+attr(x, "NA") <- 4
+attributes(x)
+attr(x, "NA")
+attr(x, NA_character_)
+try(attr(x, NA_character_) <- 5)
+## prior to 2.5.0 NA was treated as "NA"
+
+
+## qr with pivoting (PR#9623)
+A <- matrix(c(0,0,0, 1,1,1), nrow = 3,
+ dimnames = list(letters[1:3], c("zero","one")))
+y <- matrix(c(6,7,8), nrow = 3, dimnames = list(LETTERS[1:3], "y"))
+qr.coef(qr(A), y)
+qr.fitted(qr(A), y)
+
+qr.coef(qr(matrix(0:1, 1, dimnames=list(NULL, c("zero","one")))), 5)
+## coef names were returned unpivoted <= 2.5.0
+
+## readChar read extra items, terminated on zeros
+x <- as.raw(65:74)
+readChar(x, nchar=c(3,3,0,3,3,3))
+f <- tempfile()
+writeChar("ABCDEFGHIJ", con=f, eos=NULL)
+readChar(f, nchar=c(3,3,0,3,3,3))
+unlink(f)
+##
+
+
+## corner cases for cor
+set.seed(1)
+X <- cbind(NA, 1:3, rnorm(3))
+try(cor(X, use = "complete"))
+try(cor(X, use = "complete", method="spearman"))
+try(cor(X, use = "complete", method="kendall"))
+cor(X, use = "pair")
+cor(X, use = "pair", method="spearman")
+cor(X, use = "pair", method="kendall")
+
+X[1,1] <- 1
+cor(X, use = "complete")
+cor(X, use = "complete", method="spearman")
+cor(X, use = "complete", method="kendall")
+cor(X, use = "pair")
+cor(X, use = "pair", method="spearman")
+cor(X, use = "pair", method="kendall")
+## not consistent in 2.6.x
+
+
+## confint on rank-deficient models (in part, PR#10494)
+junk <- data.frame(x = rep(1, 10L),
+ u = factor(sample(c("Y", "N"), 10, replace=TRUE)),
+ ans = rnorm(10))
+fit <- lm(ans ~ x + u, data = junk)
+confint(fit)
+confint.default(fit)
+## Mismatch gave NA for 'u' in 2.6.1
+
+
+## corrupt data frame produced by subsetting (PR#10574)
+x <- data.frame(a=1:3, b=2:4)
+x[,3] <- x
+x
+## warning during printing < 2.7.0
+
+
+## format.factor used to lose dim[names] and names (PR#11512)
+x <- factor(c("aa", letters[-1]))
+dim(x) <- c(13,2)
+format(x, justify="right")
+##
+
+
+## removing columns in within (PR#1131)
+abc <- data.frame(a=1:5, b=2:6, c=3:7)
+within(abc, b<-NULL)
+within(abc,{d<-a+7;b<-NULL})
+within(abc,{a<-a+7;b<-NULL})
+## Second produced corrupt data frame in 2.7.1
+
+
+## aggregate on an empty data frame (PR#13167)
+z <- data.frame(a=integer(0), b=numeric(0))
+try(aggregate(z, by=z[1], FUN=sum))
+## failed in unlist in 2.8.0, now gives explicit message.
+aggregate(data.frame(a=1:10)[F], list(rep(1:2, each=5)), sum)
+## used to fail obscurely.
+
+
+## subsetting data frames with duplicate rows
+z <- data.frame(a=1, a=2, b=3, check.names=FALSE)
+z[] # OK
+z[1, ]
+## had row names a, a.1, b in 2.8.0.
+
+
+## incorrect warning due to lack of fuzz.
+TS <- ts(co2[1:192], freq=24)
+tmp2 <- window(TS, start(TS), end(TS))
+## warned in 2.8.0
+
+## failed to add tag
+Call <- call("foo", 1)
+Call[["bar"]] <- 2
+Call
+## unnamed call in 2.8.1
+
+options(keep.source = TRUE)
+## $<- on pairlists failed to duplicate (from Felix Andrews,
+## https://stat.ethz.ch/pipermail/r-devel/2009-January/051698.html)
+foo <- function(given = NULL) {
+ callObj <- quote(callFunc())
+ if(!is.null(given)) callObj$given <- given
+ if (is.null(given)) callObj$default <- TRUE
+ callObj
+}
+
+foo()
+foo(given = TRUE)
+foo("blah blah")
+foo(given = TRUE)
+foo()
+## altered foo() in 2.8.1.
+
+## Using '#' flag in sprintf():
+forms <- c("%#7.5g","%#5.f", "%#7x", "%#5d", "%#9.0e")
+nums <- list(-3.145, -31, 0xabc, -123L, 123456)
+rbind(mapply(sprintf, forms, nums),
+ mapply(sprintf, sub("#", '', forms), nums))
+## gave an error in pre-release versions of 2.9.0
+
+## (auto)printing of functions {with / without source attribute},
+## including primitives
+sink(con <- textConnection("of", "w")) ; c ; sink(NULL); close(con)
+of2 <- capture.output(print(c))
+stopifnot(identical(of2, of),
+ identical(of2, "function (...) .Primitive(\"c\")"))
+## ^^ would have failed up to R 2.9.x
+foo
+print(foo, useSource = FALSE)
+attr(foo, "srcref") <- NULL
+foo
+(f <- structure(function(){}, note = "just a note",
+ yada = function() "not the same"))
+print(f, useSource = FALSE) # must print attributes
+print.function <- function(x, ...) { str(x,...); invisible(x) }
+print.function
+f
+rm(print.function)
+## auto-printing and printing differed up to R 2.9.x
+
+printCoefmat(cbind(0,1))
+## would print NaN up to R 2.9.0
+
+
+## continuity correction for Kendall's tau. Improves this example.
+cor.test(c(1, 2, 3, 4, 5), c(8, 6, 7, 5, 3), method = "kendall",
+ exact = TRUE)
+cor.test(c(1, 2, 3, 4, 5), c(8, 6, 7, 5, 3), method = "kendall",
+ exact = FALSE)
+cor.test(c(1, 2, 3, 4, 5), c(8, 6, 7, 5, 3), method = "kendall",
+ exact = FALSE, continuity = TRUE)
+# and a little for Spearman's
+cor.test(c(1, 2, 3, 4, 5), c(8, 6, 7, 5, 3), method = "spearman",
+ exact = TRUE)
+cor.test(c(1, 2, 3, 4, 5), c(8, 6, 7, 5, 3), method = "spearman",
+ exact = FALSE)
+cor.test(c(1, 2, 3, 4, 5), c(8, 6, 7, 5, 3), method = "spearman",
+ exact = FALSE, continuity = TRUE)
+## Kendall case is wish of PR#13691
+
+
+## corrupt data frame, PR#13724
+foo <- matrix(1:12, nrow = 3)
+bar <- as.data.frame(foo)
+val <- integer(0)
+try(bar$NewCol <- val)
+# similar, not in the report
+try(bar[["NewCol"]] <- val)
+# [ ] is tricker, so just check the result is reasonable and prints
+bar["NewCol"] <- val
+bar[, "NewCol2"] <- val
+bar[FALSE, "NewCol3"] <- val
+bar
+## Succeeded but gave corrupt result in 2.9.0
+
+
+## Printing NA_complex_
+m22 <- matrix(list(NA_complex_, 3, "A string", NA_complex_), 2,2)
+print(m22)
+print(m22, na.print="<missing value>")
+## used uninitialized variable in C, noticably Windows, for R <= 2.9.0
+
+
+## non-standard variable names in update etc
+## never guaranteed to work, requested by Sundar Dorai-Raj in
+## https://stat.ethz.ch/pipermail/r-devel/2009-July/054184.html
+update(`a: b` ~ x, ~ . + y)
+## 2.9.1 dropped backticks
+
+
+## print(ls.str(.)) did evaluate calls
+E <- new.env(); E$cl <- call("print", "Boo !")
+ls.str(E)
+## 2.10.0 did print..
+
+
+## complete.cases with no input
+try(complete.cases())
+try(complete.cases(list(), list()))
+## gave unhelpful messages in 2.10.0, silly results in pre-2.10.1
+
+
+## error messages from (C-level) evalList
+tst <- function(y) { stopifnot(is.numeric(y)); y+ 1 }
+try(tst())
+try(c(1,,2))
+## change in 2.8.0 made these less clear
+
+
+## empty levels from cut.Date (cosmetic, PR#14162)
+x <- as.Date(c("2009-03-21","2009-03-31"))
+cut(x, breaks= "quarter") # had two levels in 2.10.1
+cut(as.POSIXlt(x), breaks= "quarter")
+## remove empty final level
+
+
+## tests of error conditions in switch()
+switch("a", a=, b=, c=, 4)
+switch("a", a=, b=, c=, )
+.Last.value
+switch("a", a=, b=, c=, invisible(4))
+.Last.value
+## visiblilty changed in 2.11.0
+
+
+## rounding error in aggregate.ts
+## https://stat.ethz.ch/pipermail/r-devel/2010-April/057225.html
+x <- rep(6:10, 1:5)
+aggregate(as.ts(x), FUN = mean, ndeltat = 5)
+x <- rep(6:10, 1:5)
+aggregate(as.ts(x), FUN = mean, nfrequency = 0.2)
+## platform-dependent in 2.10.1
+
+
+## wish of PR#9574
+a <- c(0.1, 0.3, 0.4, 0.5, 0.3, 0.0001)
+format.pval(a, eps=0.01)
+format.pval(a, eps=0.01, nsmall =2)
+## granted in 2.12.0
+
+
+## printing fractional dates
+as.Date(0.5, origin="1969-12-31")
+## changed to round down in 2.12.1
+
+
+## printing data frames with "" colnames
+dfr <- data.frame(x=1:6, CC=11:16, f = gl(3,2)); colnames(dfr)[2] <- ""
+dfr
+## now prints the same as data.matrix(dfr) does here
+
+
+## format(., zero.print) --> prettyNum()
+set.seed(9); m <- matrix(local({x <- rnorm(40)
+ sign(x)*round(exp(2*x))/10}), 8,5)
+noquote(format(m, zero.print= "."))
+## used to print ". 0" instead of ". "
+
+
+## tests of NA having precedence over NaN -- all must print "NA"
+min(c(NaN, NA))
+min(c(NA, NaN)) # NaN in 2.12.2
+min(NaN, NA_real_) # NaN in 2.12.2
+min(NA_real_, NaN)
+max(c(NaN, NA))
+max(c(NA, NaN)) # NaN in 2.12.2
+max(NaN, NA_real_) # NaN in 2.12.2
+max(NA_real_, NaN)
+## might depend on compiler < 2.13.0
+
+
+## PR#14514
+# Data are from Conover, "Nonparametric Statistics", 3rd Ed, p. 197,
+# re-arranged to make a lower-tail test the issue of relevance: we
+# want to see if pregnant nurses exposed to nitrous oxide have higher
+# rates of miscarriage, stratifying on the type of nurse.
+Nitrous <- array(c(32,210,8,26,18,21,3,3,7,75,0,10), dim = c(2,2,3),
+ dimnames = list(c("Exposed","NotExposed"),
+ c("FullTerm","Miscarriage"),
+ c("DentalAsst","OperRoomNurse","OutpatientNurse")))
+mantelhaen.test(Nitrous, exact=TRUE, alternative="less")
+mantelhaen.test(Nitrous, exact=FALSE, alternative="less")
+## exact = FALSE gave the wrong tail in 2.12.2.
+
+
+## scan(strip.white=TRUE) could strip trailing (but not leading) space
+## inside quoted strings.
+writeLines(' " A "; "B" ;"C";" D ";"E "; F ;G ', "foo")
+cat(readLines("foo"), sep = "\n")
+scan('foo', list(""), sep=";")[[1]]
+scan('foo', "", sep=";")
+scan('foo', list(""), sep=";", strip.white = TRUE)[[1]]
+scan('foo', "", sep=";", strip.white = TRUE)
+unlink('foo')
+
+writeLines(' " A "\n "B" \n"C"\n" D "\n"E "\n F \nG ', "foo2")
+scan('foo2', "")
+scan('foo2', "", strip.white=TRUE) # documented to be ignored ...
+unlink('foo2')
+## Changed for 2.13.0, found when investigating non-bug PR#14522.
+
+
+## PR#14488: missing values in rank correlations
+set.seed(1)
+x <- runif(10)
+y <- runif(10)
+x[3] <- NA; y[5] <- NA
+xy <- cbind(x, y)
+
+cor(x, y, method = "spearman", use = "complete.obs")
+cor(x, y, method = "spearman", use = "pairwise.complete.obs")
+cor(na.omit(xy), method = "spearman", use = "complete.obs")
+cor(xy, method = "spearman", use = "complete.obs")
+cor(xy, method = "spearman", use = "pairwise.complete.obs")
+## inconsistent in R < 2.13.0
+
+
+## integer overflow in rowsum() went undetected
+# https://stat.ethz.ch/pipermail/r-devel/2011-March/060304.html
+x <- 2e9L
+rowsum(c(x, x), c("a", "a"))
+rowsum(data.frame(z = c(x, x)), c("a", "a"))
+## overflow in R < 2.13.0.
+
+
+## method dispatch in [[.data.frame:
+## https://stat.ethz.ch/pipermail/r-devel/2011-April/060409.html
+d <- data.frame(num = 1:4,
+ fac = factor(letters[11:14], levels = letters[1:15]),
+ date = as.Date("2011-04-01") + (0:3),
+ pv = package_version(c("1.2-3", "4.5", "6.7", "8.9-10")))
+for (i in seq_along(d)) print(d[[1, i]])
+## did not dispatch in R < 2.14.0
+
+
+## some tests of 24:00 as midnight
+as.POSIXlt("2011-05-16 24:00:00", tz = "GMT")
+as.POSIXlt("2010-01-31 24:00:00", tz = "GMT")
+as.POSIXlt("2011-02-28 24:00:00", tz = "GMT")
+as.POSIXlt("2008-02-28 24:00:00", tz = "GMT")
+as.POSIXlt("2008-02-29 24:00:00", tz = "GMT")
+as.POSIXlt("2010-12-31 24:00:00", tz = "GMT")
+## new in 2.14.0
+
+
+## Unwarranted conversion of logical values
+try(double(FALSE))
+x <- 1:3
+try(length(x) <- TRUE)
+## coerced to integer in 2.13.x
+
+
+## filter(recursive = TRUE) on input with NAs
+# https://stat.ethz.ch/pipermail/r-devel/2011-July/061547.html
+x <- c(1:4, NA, 6:9)
+cbind(x, "1"=filter(x, 0.5, method="recursive"),
+ "2"=filter(x, c(0.5, 0.0), method="recursive"),
+ "3"=filter(x, c(0.5, 0.0, 0.0), method="recursive"))
+## NAs in wrong place in R <= 2.13.1.
+
+
+## PR#14679. Format depends if TZ is set.
+x <- as.POSIXlt(c("2010-02-27 22:30:33", "2009-08-09 06:01:03",
+ "2010-07-23 17:29:59"))
+stopifnot(!is.na(trunc(x, units = "days")[1:3]))
+## gave NAs after the first in R < 2.13.2
+
+
+## explicit error message for silly input (tol = 0)
+aa <- c(1, 2, 3, 8, 8, 8, 8, 8, 8, 8, 8, 8, 12, 13, 14)
+try(smooth.spline(aa, seq_along(aa)))
+fit <- smooth.spline(aa, seq_along(aa), tol = 0.1)
+# actual output is too unstable to diff.
+## Better message from R 2.14.2
+
+
+## PR#14840
+d <- data.frame(x = 1:9,
+ y = 1:9 + 0.1*c(1, 2, -1, 0, 1, 1000, 0, 1, -1),
+ w = c(1, 0.5, 2, 1, 2, 0, 1, 2, 1))
+fit <- lm(y ~ x, data=d, weights=w)
+summary(fit)
+## issue is how the 5-number summary is labelled
+## (also seen in example(case.names))
+
+
+## is.unsorted got it backwards for dataframes of more than one column
+## it is supposed to look for violations of x[2] > x[1], x[3] > x[2], etc.
+is.unsorted(data.frame(x=2:1))
+is.unsorted(data.frame(x=1:2, y=3:4))
+is.unsorted(data.frame(x=3:4, y=1:2))
+## R < 2.15.1 got these as FALSE, TRUE, FALSE.
+
+
+library("methods")# (not needed here)
+assertError <- tools::assertError
+assertError( getMethod(ls, "bar", fdef=ls), verbose=TRUE)
+assertError( getMethod(show, "bar"), verbose=TRUE)
+## R < 2.15.1 gave
+## cannot coerce type 'closure' to vector of type 'character'
+
+
+## corner cases for array
+# allowed, gave non-array in 2.15.x
+try(array(1, integer()))
+# if no dims, an error to supply dimnames
+try(array(1, integer(), list(1, 2)))
+##
+
+
+## is.na() on an empty dataframe (PR#14059)
+DF <- data.frame(row.names=1:3)
+is.na(DF); str(.Last.value)
+is.na(DF[FALSE, ]); str(.Last.value)
+## first failed in R 2.15.1, second gave NULL
+
+
+## split() with dots in levels
+df <- data.frame(x = rep(c("a", "a.b"), 3L), y = rep(c("b.c", "c"), 3L),
+ z = 1:6)
+df
+split(df, df[, 1:2]) # default is sep = "."
+split(df, df[, 1:2], sep = ":")
+##
+
+
+## The difference between sort.list and order
+z <- c(4L, NA, 2L, 3L, NA, 1L)
+order(z, na.last = NA)
+sort.list(z, na.last = NA)
+sort.list(z, na.last = NA, method = "shell")
+sort.list(z, na.last = NA, method = "quick")
+sort.list(z, na.last = NA, method = "radix")
+## Differences first documented in R 2.15.2
+
+
+## PR#15028: names longer than cutoff NB (= 1000)
+NB <- 1000
+lns <- capture.output(
+ setNames(c(255, 1000, 30000),
+ c(paste(rep.int("a", NB+2), collapse=""),
+ paste(rep.int("b", NB+2), collapse=""),
+ paste(rep.int("c", NB+2), collapse=""))))
+sub("^ +", '', lns[2* 1:3])
+## *values* were cutoff when printed
+
+
+## allows deparse limits to be set
+form <- reallylongnamey ~ reallylongnamex0 + reallylongnamex1 + reallylongnamex2 + reallylongnamex3
+form
+op <- options(deparse.cutoff=80)
+form
+options(deparse.cutoff=50)
+form
+options(op)
+## fixed to 60 in R 2.15.x
+
+
+## PR#15179: user defined binary ops were not deparsed properly
+quote( `%^%`(x, `%^%`(y,z)) )
+quote( `%^%`(x) )
+##
+
+
+## Anonymous function calls were not deparsed properly
+substitute(f(x), list(f = function(x) x + 1))
+substitute(f(x), list(f = quote(function(x) x + 1)))
+substitute(f(x), list(f = quote(f+g)))
+substitute(f(x), list(f = quote(base::mean)))
+substitute(f(x), list(f = quote(a[n])))
+substitute(f(x), list(f = quote(g(y))))
+## The first three need parens, the last three don't.
+
+
+## PR#15247 : str() on invalid data frame names (where print() works):
+d <- data.frame(1:3, "B", 4); names(d) <- c("A", "B\xba","C\xabcd")
+str(d)
+## gave an error in R <= 3.0.0
+
+
+## PR#15299 : adding a simple vector to a classed object produced a bad result:
+1:2 + table(1:2)
+## Printed the class attribute in R <= 3.0.0
+
+
+## PR#15311 : regmatches<- mishandled regexpr results.
+ x <- c('1', 'B', '3')
+ m <- regexpr('\\d', x)
+ regmatches(x, m) <- c('A', 'C')
+ print(x)
+## Gave a warning and a wrong result up to 3.0.1
+
+
+## Bad warning found by Radford Neal
+ saveopt <- options(warnPartialMatchDollar=TRUE)
+ pl <- pairlist(abc=1, def=2)
+ pl$ab
+ if (!is.null(saveopt[["warnPartialMatchDollar"]])) options(saveopt)
+## 'abc' was just ''
+
+
+## seq() with NaN etc inputs now gives explicit error messages
+try(seq(NaN))
+try(seq(to = NaN))
+try(seq(NaN, NaN))
+try(seq.int(NaN))
+try(seq.int(to = NaN))
+try(seq.int(NaN, NaN))
+## R 3.0.1 gave messages from ':' or about negative-length vectors.
+
+
+## Some dimnames were lost from 1D arrays: PR#15301
+x <- array(0:2, dim=3, dimnames=list(d1=LETTERS[1:3]))
+x
+x[]
+x[3:1]
+x <- array(0, dimnames=list(d1="A"))
+x
+x[]
+x[drop = FALSE]
+## lost dimnames in 3.0.1
+
+
+## PR#15396
+load(file.path(Sys.getenv('SRCDIR'), 'arima.rda'))
+(f1 <- arima(x, xreg = xreg, order = c(1,1,1), seasonal = c(1,0,1)))
+(f2 <- arima(diff(x), xreg = diff(xreg), order = c(1,0,1), seasonal = c(1,0,1),
+ include.mean = FALSE))
+stopifnot(all.equal(coef(f1), coef(f2), tolerance = 1e-3, check.names = FALSE))
+## first gave local optim in 3.0.1
+
+## all.equal always checked the names
+x <- c(a=1, b=2)
+y <- c(a=1, d=2)
+all.equal(x, y, check.names = FALSE)
+## failed on mismatched attributes
+
+
+## PR#15411, plus digits change
+format(9992, digits = 3)
+format(9996, digits = 3)
+format(0.0002, digits = 0, nsmall = 2)
+format(pi*10, digits = 0, nsmall = 1)
+## second added an extra space; 3rd and 4th were not allowed.
+
+## and one branch of this was wrong:
+xx <- c(-86870268, 107833358, 302536985, 481015309, 675718935, 854197259,
+ 1016450281, 1178703303, 1324731023, 1454533441)
+xx
+## dropped spaces without long doubles
+
+## and rounding was being detected improperly (PR#15583)
+1000* ((10^(1/4)) ^ c(0:4))
+7/0.07
+## Spacing was incorrect
+
+
+## PR#15468
+M <- matrix(11:14, ncol=2, dimnames=list(paste0("Row", 1:2), paste0("Col",
+1:2)))
+L <- list(elem1=1, elem2=2)
+rbind(M, L)
+rbind(L, M)
+cbind(M, L)
+cbind(L, M)
+## lost the dim of M, so returned NULL entries
+
+
+## NA_character_ was not handled properly in min and max (reported by Magnus Thor Torfason)
+str(min(NA, "bla"))
+str(min("bla", NA))
+str(min(NA_character_, "bla"))
+str(max(NA, "bla"))
+str(max("bla", NA))
+str(max(NA_character_, "bla"))
+## NA_character_ could be treated as "NA"; depending on the locale, it would not necessarily
+## be the min or max.
+
+
+## When two entries needed to be cut to width, str() mixed up
+## the values (reported by Gerrit Eichner)
+oldopts <- options(width=70, stringsAsFactors=TRUE)
+n <- 11 # number of rows of data frame
+M <- 10000 # order of magnitude of numerical values
+longer.char.string <- "zjtvorkmoydsepnxkabmeondrjaanutjmfxlgzmrbjp"
+X <- data.frame( A = 1:n * M,
+ B = rep( longer.char.string, n))
+str( X, strict.width = "cut")
+options(oldopts)
+## The first row of the str() result was duplicated.
+
+
+## PR15624: rounding in extreme cases
+dpois(2^52,1,1)
+dpois(2^52+1,1,1)
+## second warned in R 3.0.2.
+
+
+## Example from PR15625
+f <- file.path(Sys.getenv('SRCDIR'), 'EmbeddedNuls.csv')
+## This is a file with a UTF-8 BOM and some fields which are a single nul.
+## The output does rely on this being run in a non-UTF-8 locale (C in tests).
+read.csv(f) # warns
+read.csv(f, skipNul = TRUE, fileEncoding = "UTF-8-BOM")
+## 'skipNul' is new in 3.1.0. Should not warn on BOM, ignore in second.
+
+
+## all.equal datetime method
+x <- Sys.time()
+all.equal(x,x)
+all.equal(x, as.POSIXlt(x))
+all.equal(x, as.POSIXlt(x, tz = "EST5EDT"))
+all.equal(x, x+1e-4)
+isTRUE(all.equal(x, x+0.002)) # message will depend on representation error
+## as.POSIXt method is new in 3.1.0.
+
+
+
+## Misuse of PR#15633
+try(bartlett.test(yield ~ block*N, data = npk))
+try(fligner.test (yield ~ block*N, data = npk))
+## used the first factor with an incorrect description in R < 3.0.3
+
+
+## Misguided expectation of PR#15687
+xx <- window(AirPassengers, start = 1960)
+cbind(xx, xx)
+op <- options(digits = 2)
+cbind(xx, xx)
+options(op)
+## 'digits' was applied to the time.
+
+
+## Related to PR#15190
+difftime(
+ as.POSIXct(c("1970-01-01 00:00:00", "1970-01-01 12:00:00"), tz="EST5EDT"),
+ as.POSIXct(c("1970-01-01 00:00:00", "1970-01-01 00:00:00"), tz="UTC"))
+## kept tzone from first arg.
+
+
+## PR#15706
+x1 <- as.dendrogram(hclust(dist(c(i=1,ii=2,iii=3,v=5,vi=6,vii=7))))
+attr(cophenetic(x1), "Labels")
+## gave a matrix in 3.0.3
+
+
+## PR#15708
+aa <- anova( lm(sr ~ ., data = LifeCycleSavings) )
+op <- options(width = 50)
+aa
+options(width = 40)
+aa ; options(op)
+## did not line wrap "Signif. codes" previously
+
+
+## PR#15718
+d <- data.frame(a=1)
+d[integer(), "a"] <- 2
+## warned in 3.0.3.
+
+
+## PR#15781
+options(foo = 1)
+print(options(foo = NULL))
+## printed wrong value in 3.1.0
+
+
+## getParseData bug reported by Andrew Redd
+raw <- "
+function( a # parameter 1
+ , b=2 # parameter 2
+ ){a+b}"
+p <- parse(text = raw)
+getParseData(p)
+## Got some parents wrong
+
+
+## wish of PR#15819
+set.seed(123); x <- runif(10); y <- rnorm(10)
+op <- options(OutDec = ",")
+fit <- lm(y ~ x)
+summary(fit)
+options(op)
+## those parts using formatC still used a decimal point.
+
+
+## Printing a list with "bad" component names
+L <- list(`a\\b` = 1, `a\\c` = 2, `a\bc` = "backspace")
+setClass("foo", representation(`\\C` = "numeric"))
+## the next three all print correctly:
+names(L)
+unlist(L)
+as.pairlist(L)
+cat(names(L), "\n")# yes, backspace is backspace here
+L
+new("foo")
+## the last two lines printed wrongly in R <= 3.1.1
+
+
+## Printing of arrays where last dim(.) == 0 :
+r <- matrix(,0,4, dimnames=list(Row=NULL, Col=paste0("c",1:4)))
+r
+t(r) # did not print "Row", "Col"
+A <- array(dim=3:0, dimnames=list(D1=c("a","b","c"), D2=c("X","Y"), D3="I", D4=NULL))
+A ## did not print *anything*
+A[,,"I",] # ditto
+A[,,0,] # ditto
+aperm(A, c(3:1,4)) # ditto
+aperm(A, c(1:2, 4:3))# ditto
+unname(A) # ditto
+format(A[,,1,]) # ditto
+aperm(A, 4:1) # was ok, is unchanged
+## sometimes not printing anything in R <= 3.1.1
+
+
+## Printing objects with very long names cut off literal values (PR#15999)
+make_long_name <- function(n)
+{
+ paste0(rep("a", n), collapse = "")
+}
+setNames(TRUE, make_long_name(1000)) # value printed as TRU
+setNames(TRUE, make_long_name(1002)) # value printed as T
+setNames(TRUE, make_long_name(1003)) # value not printed
+##
+
+
+## PR#16437
+dd <- data.frame(F = factor(rep(c("A","B","C"), each = 3)), num = 1:9)
+cs <- list(F = contr.sum(3, contrasts = FALSE))
+a1 <- aov(num ~ F, data = dd, contrasts = cs)
+model.tables(a1, "means")
+t1 <- TukeyHSD(a1) ## don't print to avoid precision issues.
+a2 <- aov(num ~ 0+F, data = dd, contrasts = cs)
+model.tables(a2, "means")
+t2 <- TukeyHSD(a2)
+attr(t1, "orig.call") <- attr(t2, "orig.call")
+stopifnot(all.equal(t1, t2))
+## functions both failed on a2 in R <= 3.2.2.
+
+
+## deparse() did not add parens before [
+substitute(a[1], list(a = quote(x * y)))
+## should be (x * y)[1], was x * y[1]
+# Check all levels of precedence
+# (Comment out illegal ones)
+quote(`$`(a :: b, c))
+# quote(`::`(a $ b, c $ d))
+quote(`[`(a $ b, c $ d))
+quote(`$`(a[b], c))
+quote(`^`(a[b], c[d]))
+quote(`[`(a ^ b, c ^ d))
+quote(`-`(a ^ b))
+quote(`^`(-b, -d))
+quote(`:`(-b, -d))
+quote(`-`(a : b))
+quote(`%in%`(a : b, c : d))
+quote(`:`(a %in% b, c %in% d))
+quote(`*`(a %in% b, c %in% d))
+quote(`%in%`(a * b, c * d))
+quote(`+`(a * b, c * d))
+quote(`*`(a + b, c + d))
+quote(`<`(a + b, c + d))
+quote(`+`(a < b, c < d))
+quote(`!`(a < b))
+quote(`<`(!b, !d))
+quote(`&`(!b, !d))
+quote(`!`(a & b))
+quote(`|`(a & b, c & d))
+quote(`&`(a | b, c | d))
+quote(`~`(a | b, c | d))
+quote(`|`(a ~ b, c ~ d))
+quote(`->`(a ~ b, d))
+quote(`~`(a -> b, c -> d))
+quote(`<-`(a, c -> d))
+quote(`->`(a <- b, c))
+quote(`=`(a, c <- d))
+quote(`<-`(a, `=`(c, d)))
+quote(`?`(`=`(a, b), `=`(c, d)))
+quote(`=`(a, c ? d))
+quote(`?`(a = b))
+quote(`=`(b, ?d))
+
+## dput() quoted the empty symbol (PR#16686)
+a <- alist(one = 1, two = )
+dput(a)
+## deparsed two to quote()
+
+
+## summary.data.frame() with NAs in columns of class "Date" -- PR#16709
+x <- c(18000000, 18810924, 19091227, 19027233, 19310526, 19691228, NA)
+x.Date <- as.Date(as.character(x), format = "%Y%m%d")
+summary(x.Date)
+DF.Dates <- data.frame(c1 = x.Date)
+summary(DF.Dates) ## NA's missing from output :
+DF.Dates$x1 <- 1:7
+summary(DF.Dates) ## NA's still missing
+DF.Dates$x2 <- c(1:6, NA)
+## now, NA's show fine:
+summary(DF.Dates)
+## 2 of 4 summary(.) above did not show NA's in R <= 3.2.3
+
+
+## Printing complex matrix
+matrix(1i,2,13)
+## Spacing was wrong in R <= 3.2.4
+
+
+E <- expression(poly = x^3 - 3 * x^2)
+str(E)
+## no longer shows "structure(...., .Names = ..)"
+
+
+## summary(<logical>) working via table():
+logi <- c(NA, logical(3), NA, !logical(2), NA)
+summary(logi)
+summary(logi[!is.na(logi)])
+summary(TRUE)
+## was always showing counts for NA's even when 0 in 2.8.0 <= R <= 3.3.1
+ii <- as.integer(logi)
+summary(ii)
+summary(ii[!is.na(ii)])
+summary(1L)
+
+
+## str.default() for "AsIs" arrays
+str(I(m <- matrix(pi*1:4, 2)))
+## did look ugly (because of toString() for numbers) in R <= 3.3.1
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-3.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-3.R
new file mode 100644
index 0000000000000000000000000000000000000000..79468bb06f35f675a77bf1cceea7214dba9ab5ee
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-tests-3.R
@@ -0,0 +1,233 @@
+### Regression tests for which the printed output is the issue
+### May fail.
+### Skipped on a Unix-alike without Recommended packages
+
+pdf("reg-tests-3.pdf", encoding = "ISOLatin1.enc")
+
+## str() for character & factors with NA (levels), and for Surv objects:
+ff <- factor(c(2:1, NA), exclude = NULL)
+str(levels(ff))
+str(ff)
+str(ordered(ff, exclude=NULL))
+if(require(survival)) {
+ (sa <- Surv(aml$time, aml$status))
+ str(sa)
+ detach("package:survival", unload = TRUE)
+}
+## were different, the last one failed in 1.6.2 (at least)
+
+
+## lm.influence where hat[1] == 1
+if(require(MASS)) {
+ fit <- lm(formula = 1000/MPG.city ~ Weight + Cylinders + Type + EngineSize + DriveTrain, data = Cars93)
+ print(lm.influence(fit))
+ ## row 57 should have hat = 1 and resid=0.
+ summary(influence.measures(fit))
+}
+## only last two cols in row 57 should be influential
+
+
+## PR#6640 Zero weights in plot.lm
+if(require(MASS)) {
+ fm1 <- lm(time~dist, data=hills, weights=c(0,0,rep(1,33)))
+ plot(fm1)
+}
+## gave warnings in 1.8.1
+
+
+## PR#7829 model.tables & replications
+if(require(MASS)) {
+ oats.aov <- aov(Y ~ B + V + N + V:N, data=oats[-1,])
+ model.tables(oats.aov, "means", cterms=c("N", "V:N"))
+}
+## wrong printed output in 2.1.0
+
+
+## drop1 on weighted lm() fits
+if(require(MASS)) {
+ hills.lm <- lm(time ~ 0 + dist + climb, data=hills, weights=1/dist^2)
+ print(drop1(hills.lm))
+ print(stats:::drop1.default(hills.lm))
+ hills.lm2 <- lm(time/dist ~ 1 + I(climb/dist), data=hills)
+ drop1(hills.lm2)
+}
+## quoted unweighted RSS etc in 2.2.1
+
+
+## tests of ISO C99 compliance (Windows fails without a workaround)
+sprintf("%g", 123456789)
+sprintf("%8g", 123456789)
+sprintf("%9.7g", 123456789)
+sprintf("%10.9g", 123456789)
+sprintf("%g", 12345.6789)
+sprintf("%10.9g", 12345.6789)
+sprintf("%10.7g", 12345.6789)
+sprintf("%.7g", 12345.6789)
+sprintf("%.5g", 12345.6789)
+sprintf("%.4g", 12345.6789)
+sprintf("%9.4g", 12345.6789)
+sprintf("%10.4g", 12345.6789)
+## Windows used e+008 etc prior to 2.3.0
+
+
+## weighted glm() fits
+if(require(MASS)) {
+ hills.glm <- glm(time ~ 0 + dist + climb, data=hills, weights=1/dist^2)
+ print(AIC(hills.glm))
+ print(extractAIC(hills.glm))
+ print(drop1(hills.glm))
+ stats:::drop1.default(hills.glm)
+}
+## wrong AIC() and drop1 prior to 2.3.0.
+
+## calculating no of signif digits
+print(1.001, digits=16)
+## 2.4.1 gave 1.001000000000000
+## 2.5.0 errs on the side of caution.
+
+
+## as.matrix.data.frame with coercion
+if(require("survival")) {
+ soa <- Surv(1:5, c(0, 0, 1, 0, 1))
+ df.soa <- data.frame(soa)
+ print(as.matrix(df.soa)) # numeric result
+ df.soac <- data.frame(soa, letters[1:5])
+ print(as.matrix(df.soac)) # character result
+ detach("package:survival", unload = TRUE)
+}
+## failed in 2.8.1
+
+## wish of PR#13505
+npk.aov <- aov(yield ~ block + N * P + K, npk)
+foo <- proj(npk.aov)
+cbind(npk, foo)
+## failed in R < 2.10.0
+
+
+if(suppressMessages(require("Matrix"))) {
+ print(cS. <- contr.SAS(5, sparse = TRUE))
+ stopifnot(all(contr.SAS(5) == cS.),
+ all(contr.helmert(5, sparse = TRUE) == contr.helmert(5)))
+
+ x1 <- x2 <- c('a','b','a','b','c')
+ x3 <- x2; x3[4:5] <- x2[5:4]
+ print(xtabs(~ x1 + x2, sparse= TRUE, exclude = 'c'))
+ print(xtabs(~ x1 + x3, sparse= TRUE, exclude = 'c'))
+ detach("package:Matrix")
+ ## failed in R <= 2.13.1
+}
+
+## regression tests for dimnames (broken on 2009-07-31)
+contr.sum(4)
+contr.helmert(4)
+contr.sum(2) # needed drop=FALSE at one point.
+
+## xtabs did not exclude levels from factors
+x1 <- c('a','b','a','b','c', NA)
+x2 <- factor(x1, exclude=NULL)
+print(xtabs(~ x1 + x2, na.action = na.pass))
+print(xtabs(~ x1 + x2, exclude = 'c', na.action = na.pass))
+
+
+## median should work by default for a suitable S4 class.
+## adapted from adaptsmoFMRI
+if(suppressMessages(require("Matrix"))) {
+ x <- matrix(c(1,2,3,4))
+ print(median(x))
+ print(median(as(x, "dgeMatrix")))
+ detach("package:Matrix")
+}
+
+## Various arguments were not duplicated: PR#15352 to 15354
+x <- 5
+y <- 2
+f <- function (y) x
+numericDeriv(f(y),"y")
+x
+
+a<-list(1,2)
+b<-rep.int(a,c(2,2))
+b[[1]][1]<-9
+a[[1]]
+
+a <- numeric(1)
+x <- mget("a",as.environment(1))
+x
+a[1] <- 9
+x
+
+
+## needs MASS installed
+## PR#2586 labelling in alias()
+if(require("MASS")) {
+ Y <- c(0,1,2)
+ X1 <- c(0,1,0)
+ X2 <- c(0,1,0)
+ X3 <- c(0,0,1)
+ print(res <- alias(lm(Y ~ X1 + X2 + X3)))
+ stopifnot(identical(rownames(res[[2]]), "X2"))
+}
+## the error was in lm.(w)fit
+
+if(require("Matrix")) {
+ m1 <- m2 <- m <- matrix(1:12, 3,4)
+ dimnames(m2) <- list(LETTERS[1:3],
+ letters[1:4])
+ dimnames(m1) <- list(NULL,letters[1:4])
+ M <- Matrix(m)
+ M1 <- Matrix(m1)
+ M2 <- Matrix(m2)
+ ## Now, with a new ideal cbind(), rbind():
+ print(cbind(M, M1))
+ stopifnot(identical(cbind (M, M1),
+ cbind2(M, M1)))
+ rm(M,M1,M2)
+ detach("package:Matrix", unload=TRUE)
+}##{Matrix}
+
+
+## Invalid UTF-8 strings
+x <- c("Jetz", "no", "chli", "z\xc3\xbcrit\xc3\xbc\xc3\xbctsch:",
+ "(noch", "ein", "bi\xc3\x9fchen", "Z\xc3\xbc", "deutsch)",
+ "\xfa\xb4\xbf\xbf\x9f")
+lapply(x, utf8ToInt)
+Encoding(x) <- "UTF-8"
+nchar(x, "b")
+try(nchar(x, "c"))
+try(nchar(x, "w"))
+nchar(x, "c", allowNA = TRUE)
+nchar(x, "w", allowNA = TRUE)
+## Results differed by platform, but some gave incorrect results on string 10.
+
+
+## str() on large strings (in multibyte locales; changing locale may not work everywhere
+oloc <- Sys.getlocale("LC_CTYPE")
+mbyte.lc <- if(.Platform$OS.type == "windows")
+ "English_United States.28605" else "en_GB.UTF-8"
+stopifnot(identical(Sys.setlocale("LC_CTYPE", mbyte.lc), mbyte.lc))
+cc <- "J\xf6reskog" # valid in "latin-1"; invalid multibyte string in UTF-8
+.tmp <- capture.output(
+str(cc) # failed in some R-devel versions
+)
+stopifnot(grepl("chr \"J.*reskog\"", .tmp))
+nchar(L <- strrep(paste(LETTERS, collapse="."), 100000), type="b")# 5.1 M
+stopifnot(system.time( str(L) )[[1L]] < 0.10) # Sparc Solaris needed 0.052
+Sys.setlocale("LC_CTYPE", oloc)
+## needed 1.6 sec in (some) R <= 3.3.0 in a multibyte locale
+
+if(require("Matrix", .Library)) {
+ M <- Matrix(diag(1:10), sparse=TRUE) # a "dsCMatrix"
+ setClass("TestM", slots = c(M='numeric'))
+ setMethod("+", c("TestM","TestM"), function(e1,e2) {
+ e1@M + e2@M
+ })
+ M+M # works the first time
+ M+M # was error "object '.Generic' not found"
+ ##
+ stopifnot(
+ identical(pmin(2,M), pmin(2, as.matrix(M))),
+ identical(as.matrix(pmax(M, 7)), pmax(as.matrix(M), 7))
+ )
+ rm(M)
+ detach("package:Matrix", unload=TRUE)
+}##{Matrix}
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/reg-win.R b/com.oracle.truffle.r.native/gnur/tests/src/reg-win.R
new file mode 100644
index 0000000000000000000000000000000000000000..cf3d9c782b8af030f8471f8a3ed1733a3558547b
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/reg-win.R
@@ -0,0 +1,23 @@
+### Windows-only regression tests
+
+## closing a graphics window could segfault in Windows
+windows(record = TRUE)
+plot(1)
+dev.off()
+gc()
+## segfaulted in 2.0.0
+
+
+## Using a closed progress bar (PR#13709)
+bar = winProgressBar(min = 0, max = 100, width = 300)
+setWinProgressBar(bar, 25)
+close(bar)
+try(setWinProgressBar(bar, 50))
+## segfaulted in 2.9.0
+
+
+## trio peculiarity with %a, and incorrect fix
+x <- sprintf("%a", 1:8)
+y <- c("0x1p+0", "0x1p+1", "0x1.8p+1", "0x1p+2", "0x1.4p+2", "0x1.8p+2",
+ "0x1.cp+2", "0x1p+3")
+stopifnot(identical(x, y))
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/simple-true.R b/com.oracle.truffle.r.native/gnur/tests/src/simple-true.R
new file mode 100644
index 0000000000000000000000000000000000000000..10c93ef7acab10655722e6245eedfccd062eec65
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/simple-true.R
@@ -0,0 +1,190 @@
+###---- ALL tests here should return TRUE !
+###
+###---- "Real" Arithmetic; Numerics etc --> ./arith-true.R
+
+### mode checking, etc.
+is.recursive(expression(1+3, 2/sqrt(pi)))# fix PR#9
+
+## sum():
+all(1:12 == cumsum(rep(1,12)))
+x <- rnorm(127); sx <- sum(x); abs((sum(rev(x)) -sx)) < 1e-12 * abs(sx)
+
+## seq():
+typeof(1:4) == "integer" #-- fails for 0.2, 0.3,.., 0.9
+
+## Check parsing with L suffix for integer literals.
+typeof(1L) == "integer"
+typeof(1000L) == "integer"
+typeof(1e3L) == "integer"
+typeof(1e-3L) == "double" # gives warning
+1.L # gives warning
+try(parse(text = "12iL")) # gives syntax error
+
+
+all((0:6) == pi + ((-pi):pi))
+all((0:7) == (pi+seq(-pi,pi, length=8))*7/(2*pi))
+
+1 == as.integer(is.na(c(pi,NA)[2]))
+1 == as.integer(is.nan(0/0))
+
+## rev():
+cc <- c(1:10,10:1) ; all(cc == rev(cc))
+
+## dim[names]():
+all(names(c(a=pi, b=1, d=1:4)) == c("a","b", paste("d", 1:4, sep="")))
+##P names(c(a=pi, b=1, d=1:4))
+ncb <- dimnames(cbind(a=1, yy=1:3))[[2]]
+(!is.null(ncb)) && all(ncb == c("a","yy"))
+
+all(cbind(a=1:2, b=1:3, c=1:6) == t(rbind(a=1:2, b=1:3, c=1:6)))
+##P rbind(a=1:2, b=1:3, c=1:6)
+all(dim(cbind(cbind(I=1,x=1:4), c(a=pi))) == 4:3)# fails in S+
+
+a <- b <- 1:3
+all(dimnames(cbind(a, b))[[2]] == c("a","b"))
+
+## rbind PR#338
+all(dim(m <- rbind(1:2, diag(2))) == 3:2)
+all(m == c(1,1,0, 2,0,1))
+
+## factor():
+is.factor(factor(integer()))
+all(levels(ordered(rev(gl(3,4)))) == 1:3)# coercion to char
+all(levels(factor(factor(9:1)[3:5])) == 5:7)
+## crossing bug PR#40
+is.factor(ff <- gl(2,3) : gl(3,2)) && length(ff) == 6
+all(levels(ff) == t(outer(1:2, 1:3, paste, sep=":")))
+## from PR#5
+ll <- c("A","B"); ff <- factor(ll); f0 <- ff[, drop=TRUE]
+all(f0 == ff) && all(levels(ff) == ll) && is.factor(ff) && is.factor(f0)
+
+### data.frame s :
+
+## from lists [bug PR#100]
+x <- NULL
+x$x1 <- 1:10
+x$x2 <- 0:9
+all(dim(dx <- as.data.frame(x)) == c(10,2))
+
+## Logicals: (S is wrong)
+l1 <- c(TRUE,FALSE,TRUE)
+(! as.logical(as.data.frame(FALSE)[,1]))
+all(l1 == as.logical(as.data.frame(l1)[,1]))
+
+## empty data.frames :
+x <- data.frame(a=1:3)
+x30 <- {
+ if(is.R()) x[, -1]# not even possible in S+
+ else structure(list(), row.names = paste(1:3), class = "data.frame")
+}
+all(dim(x30) == c(3,0))
+x01 <- x[-(1:3), , drop = FALSE]
+x00 <- x01[,-1]
+all(dim(x01) == 0:1)
+all(dim(x00) == 0)
+all(dim(x) == dim(rbind(x, x01)))
+## bugs up to 1.2.3 :
+all(dim(x30) == dim(m30 <- as.matrix(x30)))
+all(dim(x01) == dim(m01 <- as.matrix(x01)))
+all(dim(x30) == dim(as.data.frame(m30)))
+all(dim(x01) == dim(as.data.frame(m01)))
+all(dim(x01) == dim( data.frame(m01)))
+all(dim(x30) == dim( data.frame(m30)))
+all(dim(x) == dim(cbind(x, x30)))
+## up to 1.4.0 :
+all(dim(x30) == dim( data.matrix(x30)))
+all(dim(x00) == dim( data.matrix(x00)))
+
+m0 <- matrix(pi, 0,3)
+a302 <- array("", dim=c(3,0,2))
+identical(apply(m0, 1, dim), NULL)
+identical(apply(m0, 2, dim), NULL)
+identical(apply(m0, 1,length), integer(0))
+identical(apply(m0, 2,length), integer(3))
+identical(apply(a302, 1, mode), rep("character",3))
+## NO (maybe later?):
+## identical(apply(a302, 2, mode), rep("character",0))
+is.character(aa <- apply(a302, 2, mode)) && length(aa) == 0
+identical(apply(a302, 3, mode), rep("character",2))
+identical(apply(a302, 3, length),integer(2))
+identical(apply(a302, 3, dim), matrix(as.integer(c(3,0)), 2 ,2))
+identical(apply(a302, 1, dim), matrix(as.integer(c(0,2)), 2 ,3))
+identical(apply(array(dim=3), 1,length), rep(1:1, 3))
+identical(apply(array(dim=0), 1,length), rep(1:1, 0))# = integer(0)
+
+
+### Subsetting
+
+## bug PR#425
+x <- matrix(1:4, 2, 2, dimnames=list(c("abc","ab"), c("cde","cd")))
+y <- as.data.frame(x)
+all(x["ab",] == c(2,4))
+all(y["ab",] == c(2,4))
+
+## from bug PR#447
+x <- 1:2 ; x[c("2","2")] <- 4
+all.equal(x, c(1:2, "2" = 4))
+
+## stretching
+l2 <- list(a=1, b=2)
+l2["cc"] <- pi
+l2[["d"]] <- 4
+l2 $ e <- 55
+all.equal(l2, list(a = 1, b = 2, cc = pi, d = 4, e = 55), tolerance = 0)
+all.equal(l2["d"], list(d = 4))
+l2$d == 4 && l2$d == l2[["d"]]
+
+## bug in R <= 1.1
+f1 <- y1 ~ x1
+f2 <- y2 ~ x2
+f2[2] <- f1[2]
+deparse(f2) == "y1 ~ x2"
+
+m <- cbind(a=1:2,b=c(R=10,S=11))
+all(sapply(dimnames(m), length) == c(2,2))
+## [[ for matrix:
+m[[1,2]] == m[[3]] && m[[3]] == m[3] && m[3] == m[1,2]
+
+## bug in R <= 1.1.1 : unclass(*) didn't drop the class!
+## to be robust to S4 methods DON'T test for null class
+## The test for attr(,"class") is valid, if essentially useless
+d1 <- rbind(data.frame(a=1, b = I(TRUE)), new = c(7, "N"))
+is.null(attr(unclass(d1$b), "class"))
+
+## bugs in R 1.2.0
+format(as.POSIXct(relR120 <- "2000-12-15 11:24:40")) == relR120
+format(as.POSIXct(substr(relR120,1,10))) == substr(relR120,1,10)
+
+## rank() with NAs (and ties)
+x <- c(3:1,6,4,3,NA,5,0,NA)
+rx <- rank(x)
+all(rx == c(4.5, 3:2, 8, 6, 4.5, 9, 7, 1, 10))
+rxK <- rank(x, na.last = "keep")
+all(rx [rx <= 8] == na.omit(rxK))
+all(rank(x, na.last = NA) == na.omit(rxK))
+
+## as.list.function() instead of *.default():
+identical(as.list(as.list),
+ alist(x = , ... = , UseMethod("as.list")))
+
+## startsWith() / endsWith() assertions
+t1 <- c("Foobar", "bla bla", "something", "another", "blu", "brown",
+ "blau blüht der Enzian")# non-ASCII
+t2 <- c("some text", "any text")
+t3 <- c("Martin", "Zürich", "Mächler")
+
+all(endsWith(t1, "")); all(startsWith(t1, ""))
+all(endsWith(t2, "")); all(startsWith(t2, ""))
+all(endsWith(t3, "")); all(startsWith(t3, ""))
+all(endsWith(t2, "text"))
+all(endsWith(t2, " text"))
+identical(startsWith(t1, "b" ), c(FALSE, TRUE, FALSE, FALSE, TRUE, TRUE, TRUE))
+identical(startsWith(t1, "bl"), c(FALSE, TRUE, FALSE, FALSE, TRUE, FALSE, TRUE))
+identical(startsWith(t1, "bla"),c(FALSE, TRUE, FALSE, FALSE,FALSE, FALSE, TRUE))
+identical( endsWith(t1, "n"), c(FALSE,FALSE, FALSE, FALSE,FALSE, TRUE, TRUE))
+identical( endsWith(t1, "an"), c(FALSE,FALSE, FALSE, FALSE,FALSE, FALSE, TRUE))
+##
+identical(startsWith(t3, "M" ), c( TRUE, FALSE, TRUE))
+identical(startsWith(t3, "Ma"), c( TRUE, FALSE, FALSE))
+identical(startsWith(t3, "Mä"), c(FALSE, FALSE, TRUE))
+
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/test-system.R b/com.oracle.truffle.r.native/gnur/tests/src/test-system.R
new file mode 100644
index 0000000000000000000000000000000000000000..c8b28d860acb4c9877754c3a1cb4e880e13c4d9d
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/test-system.R
@@ -0,0 +1,60 @@
+## tests of options in system() and system2.
+
+options(warn = 1)
+
+opts <- list("", NULL, FALSE, TRUE, "o1.txt", "o2.txt")
+outs <- c("o1.txt", "o2.txt")
+
+process <- function(res)
+{
+ unlink(outs)
+ if(is.character(res)) {
+ cat("value:\n")
+ writeLines(res)
+ }
+ for(f in outs)
+ if(file.exists(f)) {
+ cat(f, ":\n", sep = "")
+ writeLines(readLines(f))
+ }
+}
+
+for(out in opts)
+ for(err in opts) {
+ ## skip this for the sake of Unix-alikes
+ if(identical(err, TRUE) && !identical(out,TRUE)) next
+ cat(sprintf("\ntesting stdout = %s, stderr = %s\n",
+ deparse(out), deparse(err)))
+ process(system2("test-system2", stdout = out, stderr = err))
+ }
+
+
+process(system("test-system2"))
+process(system("test-system2", ignore.stdout = TRUE))
+process(system("test-system2", ignore.stderr = TRUE))
+process(system("test-system2", ignore.stdout = TRUE, ignore.stderr = TRUE))
+
+process(system("test-system2", TRUE))
+process(system("test-system2", TRUE, ignore.stdout = TRUE))
+process(system("test-system2", TRUE, ignore.stdout = TRUE, ignore.stderr = TRUE))
+
+process(system2("test-system2", "1", input=letters[1:4]))
+process(system2("test-system2", "1", input=letters[1:4], stdout = TRUE))
+
+process(system("test-system2 1", input=letters[1:4]))
+process(system("test-system2 1", input=letters[1:4], intern = TRUE))
+
+tmp <- tempfile()
+writeLines(letters[5:7], tmp)
+process(system2("test-system2", "1", stdin = tmp))
+process(system2("test-system2", "1", stdin = tmp, stdout = TRUE))
+process(system2("test-system2", "1", stdin = tmp, stdout = TRUE, stderr = TRUE))
+process(system2("test-system2", "1", stdin = tmp, stdout = "o1.txt", stderr = "o1.txt"))
+process(system2("test-system2", "1", stdin = tmp, stdout = "o1.txt", stderr = "o2.txt"))
+
+unlink(c(tmp, outs))
+
+print(system("test-system2 5"))
+system("test-system2 6", intern = TRUE)
+print(system2("test-system2", "7"))
+system2("test-system2", "8", stdout=TRUE)
diff --git a/com.oracle.truffle.r.native/gnur/tests/src/utf8-regex.R b/com.oracle.truffle.r.native/gnur/tests/src/utf8-regex.R
new file mode 100644
index 0000000000000000000000000000000000000000..6b4a1a245eecc278a9d82068dff74683e5cfef21
--- /dev/null
+++ b/com.oracle.truffle.r.native/gnur/tests/src/utf8-regex.R
@@ -0,0 +1,177 @@
+## This can only be done in a locale that extends Latin-1
+(inf <- l10n_info())
+if(!(inf$`UTF-8` || inf$`Latin-1`)) {
+ warning("this test must be done in a Latin-1 or UTF-8 locale")
+ q()
+}
+
+inp <- readLines(n = 2)
+«Latin-1 accented chars»: éè øØ å<Å æ<Æ é éè
+éè
+
+inp
+(txt <- iconv(inp[1], "latin1", ""))
+(pat <- iconv(inp[2], "latin1", ""))
+if(any(is.na(c(txt, pat)))) {
+ ## backup test
+ warning("this test must be done in a Latin-1 or UTF-8 locale")
+ q()
+}
+
+testit <- function(x) {print(x); stopifnot(identical(x, 1L))}
+testit(grep(pat, txt))
+testit(grep(pat, txt, ignore.case = TRUE))
+testit(grep(pat, txt, useBytes = TRUE))
+testit(grep(pat, txt, ignore.case = TRUE, useBytes = TRUE))
+testit(grep(pat, txt, fixed = TRUE))
+testit(grep(pat, txt, fixed = TRUE, useBytes = TRUE))
+testit(grep(pat, txt, perl = TRUE))
+testit(grep(pat, txt, ignore.case = TRUE, perl = TRUE))
+testit(grep(pat, txt, perl = TRUE, useBytes = TRUE))
+testit(grep(pat, txt, ignore.case = TRUE, perl = TRUE, useBytes = TRUE))
+testit(grep(toupper(pat), txt, ignore.case = TRUE))
+testit(grep(toupper(pat), txt, ignore.case = TRUE, perl = TRUE))
+## matches in Latin-1 but not in UTF-8
+grep(toupper(pat), txt, ignore.case = TRUE, perl = TRUE, useBytes = TRUE)
+
+(r1 <- regexpr("en", txt, fixed=TRUE))
+(r2 <- regexpr("en", txt, fixed=TRUE, useBytes=TRUE))
+stopifnot(identical(r1, regexpr("en", txt)))
+stopifnot(identical(r2, regexpr("en", txt, useBytes = TRUE)))
+stopifnot(identical(r1, regexpr("en", txt, perl=TRUE)))
+stopifnot(identical(r2, regexpr("en", txt, perl=TRUE, useBytes=TRUE)))
+stopifnot(identical(r1, regexpr("EN", txt, ignore.case=TRUE)))
+stopifnot(identical(r2, regexpr("EN", txt, ignore.case=TRUE, useBytes=TRUE)))
+stopifnot(identical(r1, regexpr("EN", txt, ignore.case=TRUE, perl=TRUE)))
+stopifnot(identical(r2, regexpr("EN", txt, ignore.case=TRUE, perl=TRUE,
+ useBytes=TRUE)))
+
+(r1 <- regexpr(pat, txt, fixed=TRUE))
+(r2 <- regexpr(pat, txt, fixed=TRUE, useBytes=TRUE))
+stopifnot(identical(r1, regexpr(pat, txt)))
+stopifnot(identical(r2, regexpr(pat, txt, useBytes=TRUE)))
+stopifnot(identical(r1, regexpr(pat, txt, perl=TRUE)))
+stopifnot(identical(r2, regexpr(pat, txt, perl=TRUE, useBytes=TRUE)))
+stopifnot(identical(r1, regexpr(pat, txt, ignore.case=TRUE)))
+stopifnot(identical(r2, regexpr(pat, txt, ignore.case=TRUE, useBytes=TRUE)))
+stopifnot(identical(r1, regexpr(pat, txt, ignore.case=TRUE, perl=TRUE)))
+stopifnot(identical(r2, regexpr(pat, txt, ignore.case=TRUE, perl=TRUE,
+ useBytes=TRUE)))
+pat2 <- toupper(pat)
+stopifnot(identical(r1, regexpr(pat2, txt, ignore.case=TRUE)))
+stopifnot(identical(r1, regexpr(pat2, txt, ignore.case=TRUE, perl=TRUE)))
+## will not match in a UTF-8 locale
+regexpr(pat2, txt, ignore.case=TRUE, perl=TRUE, useBytes=TRUE)
+
+
+(r1 <- gregexpr(pat, txt, fixed=TRUE))
+(r2 <- gregexpr(pat, txt, fixed=TRUE, useBytes=TRUE))
+stopifnot(identical(r1, gregexpr(pat, txt)))
+stopifnot(identical(r2, gregexpr(pat, txt, useBytes=TRUE)))
+stopifnot(identical(r1, gregexpr(pat, txt, perl=TRUE)))
+stopifnot(identical(r2, gregexpr(pat, txt, perl=TRUE, useBytes=TRUE)))
+stopifnot(identical(r1, gregexpr(pat, txt, ignore.case=TRUE)))
+stopifnot(identical(r2, gregexpr(pat, txt, ignore.case=TRUE, useByte=TRUE)))
+stopifnot(identical(r1, gregexpr(pat, txt, ignore.case=TRUE, perl=TRUE)))
+stopifnot(identical(r2, gregexpr(pat, txt, ignore.case=TRUE, perl=TRUE,
+ useBytes=TRUE)))
+
+txt2 <- c("The", "licenses", "for", "most", "software", "are",
+ "designed", "to", "take", "away", "your", "freedom",
+ "to", "share", "and", "change", "it.",
+ "", "By", "contrast,", "the", "GNU", "General", "Public", "License",
+ "is", "intended", "to", "guarantee", "your", "freedom", "to",
+ "share", "and", "change", "free", "software", "--",
+ "to", "make", "sure", "the", "software", "is",
+ "free", "for", "all", "its", "users")
+( i <- grep("[gu]", txt2, perl = TRUE) )
+stopifnot(identical(i, grep("[gu]", txt2)))
+## results depend on the locale
+(ot <- sub("[b-e]",".", txt2, perl = TRUE))
+txt2[ot != sub("[b-e]",".", txt2)]
+(ot <- sub("[b-e]",".", txt2, ignore.case = TRUE, perl = TRUE))
+txt2[ot != sub("[b-e]",".", txt2, ignore.case = TRUE)]
+
+
+## These may end up with different encodings: == copes, identical does not
+
+eq <- function(a, b) a == b
+(r1 <- gsub(pat, "ef", txt))
+stopifnot(eq(r1, gsub(pat, "ef", txt, useBytes = TRUE)))
+stopifnot(eq(r1, gsub(pat, "ef", txt, fixed = TRUE)))
+stopifnot(eq(r1, gsub(pat, "ef", txt, fixed = TRUE, useBytes = TRUE)))
+stopifnot(eq(r1, gsub(pat, "ef", txt, perl = TRUE)))
+stopifnot(eq(r1, gsub(pat, "ef", txt, perl = TRUE, useBytes = TRUE)))
+
+pat <- substr(pat, 1, 1)
+(r1 <- gsub(pat, "gh", txt))
+stopifnot(eq(r1, gsub(pat, "gh", txt, useBytes = TRUE)))
+stopifnot(eq(r1, gsub(pat, "gh", txt, fixed = TRUE)))
+stopifnot(eq(r1, gsub(pat, "gh", txt, fixed = TRUE, useBytes = TRUE)))
+stopifnot(eq(r1, gsub(pat, "gh", txt, perl = TRUE)))
+stopifnot(eq(r1, gsub(pat, "gh", txt, perl = TRUE, useBytes = TRUE)))
+
+
+stopifnot(identical(gsub("a*", "x", "baaac"), "xbxcx"))
+stopifnot(identical(gsub("a*", "x", "baaac"), "xbxcx"), perl = TRUE)
+stopifnot(identical(gsub("a*", "x", "baaac"), "xbxcx"), useBytes = TRUE)
+stopifnot(identical(gsub("a*", "x", "baaac"), "xbxcx"), perl = TRUE, useBytes = TRUE)
+
+## this one seems system-dependent
+(x <- gsub("\\b", "|", "The quick brown \ue8\ue9", perl = TRUE))
+# stopifnot(identical(x, "|The| |quick| |brown| |\ue8\ue9|"))
+(x <- gsub("\\b", "|", "The quick brown fox", perl = TRUE))
+stopifnot(identical(x, "|The| |quick| |brown| |fox|"))
+## The following is warned against in the help page, but worked in some versions
+gsub("\\b", "|", "The quick brown fox")
+
+(z <- strsplit(txt, pat)[[1]])
+stopifnot(eq(z, strsplit(txt, pat, useBytes = TRUE)[[1]]))
+stopifnot(eq(z, strsplit(txt, pat, fixed = TRUE)[[1]]))
+stopifnot(eq(z, strsplit(txt, pat, fixed = TRUE, useBytes = TRUE)[[1]]))
+stopifnot(eq(z, strsplit(txt, pat, perl = TRUE)[[1]]))
+stopifnot(eq(z, strsplit(txt, pat, perl = TRUE, useBytes = TRUE)[[1]]))
+
+(z <- strsplit(txt, "[a-c]")[[1]])
+stopifnot(eq(z, strsplit(txt, "[a-c]", useBytes = TRUE)[[1]]))
+stopifnot(eq(z, strsplit(txt, "[a-c]", perl = TRUE)[[1]]))
+stopifnot(eq(z, strsplit(txt, "[a-c]", perl = TRUE, useBytes = TRUE)[[1]]))
+
+## from strsplit.Rd
+z <- strsplit("A text I want to display with spaces", NULL)[[1]]
+stopifnot(identical(z,
+ strsplit("A text I want to display with spaces", "")[[1]]))
+
+x <- c(as = "asfef", qu = "qwerty", "yuiop[", "b", "stuff.blah.yech")
+(z <- strsplit(x, "e"))
+stopifnot(identical(z, strsplit(x, "e", useBytes = TRUE)))
+stopifnot(identical(z, strsplit(x, "e", fixed = TRUE)))
+stopifnot(identical(z, strsplit(x, "e", fixed = TRUE, useBytes = TRUE)))
+stopifnot(identical(z, strsplit(x, "e", perl = TRUE)))
+stopifnot(identical(z, strsplit(x, "e", perl = TRUE, useBytes = TRUE)))
+
+## moved from reg-tests-1b.R.
+## fails to match on Cygwin, Mar 2011
+## regexpr(fixed = TRUE) with a single-byte pattern matching to a MBCS string
+x <- iconv("fa\xE7ile a ", "latin1", "UTF-8")
+stopifnot(identical(regexpr(" ", x), regexpr(" ", x, fixed=TRUE)))
+# fixed=TRUE reported match position in bytes in R <= 2.10.0
+stopifnot(identical(regexpr(" a", x), regexpr(" a", x, fixed=TRUE)))
+## always worked.
+
+## this broke and segfaulted in 2.13.1 and earlier (PR#14627)
+x <- paste(rep("a ", 600), collapse="")
+testit(agrep(x, x))
+testit(agrep(x, x, max.distance=0.5))
+
+## this is used in QC to check dependencies and was broken intermittently by TRE changes
+stopifnot(isTRUE(grepl('^[[:space:]]*(R|[[:alpha:]][[:alnum:].]*[[:alnum:]])([[:space:]]*\\(([^) ]+)[[:space:]]+([^) ]+)\\))?[[:space:]]*$', ' R (>= 2.13.0) ')))
+
+## Bad sub() and gsub() with some regexprs PR#16009
+x <- c(NA, " abc", "a b c ", "a b c")
+(y <- gsub("\\s{2,}", " ", x))
+stopifnot(y[-1] == c(" abc", "a b c ", "a b c"))
+x <- c("\ue4", " abc", "a b c ", "a b c")
+(y <- gsub("\\s{2,}", " ", x))
+stopifnot(y == c(x[1], " abc", "a b c ", "a b c"))
+## results were c(x[1], " ", " ", " ") in both cases in R 3.1.1
diff --git a/mx.fastr/mx_fastr.py b/mx.fastr/mx_fastr.py
index f256c80b71fc49e6ac0e051d92392274c11462aa..4697dc4692c31be457944eb40835db13a5385c61 100644
--- a/mx.fastr/mx_fastr.py
+++ b/mx.fastr/mx_fastr.py
@@ -34,6 +34,7 @@ import mx_fastr_edinclude
import mx_unittest
import os
+import shutil
'''
This is the launchpad for all the functions available for building/running/testing/analyzing
@@ -457,6 +458,46 @@ def gnu_rscript(args, env=None):
cmd = [join(_gnur_path(), 'Rscript')] + args
return mx.run(cmd, nonZeroIsFatal=False, env=env)
+def gnu_rtests(args, env=None):
+ '''
+ run tests of the internally built GNU R under tests subdirectory
+ '''
+ os.chdir(_fastr_suite.dir) # Packages install fails otherwise
+ # mx_fastr_pkgs.installpkgs(['--pkg-pattern', '^MASS$']) # required by tests/Examples/base-Ex.R
+ np = mx.project('com.oracle.truffle.r.native')
+ tst = join(np.dir, 'gnur', 'tests')
+ tstsrc = join(tst, 'src')
+ tstlog = join(tst, 'log')
+ shutil.rmtree(tstlog, True)
+ os.mkdir(tstlog)
+ diffname = join(tstlog, 'all.diff')
+ diff = open(diffname, 'a')
+ for subd in ['Examples', '']:
+ logd = join(tstlog, subd)
+ if subd != '':
+ os.mkdir(logd)
+ os.chdir(logd)
+ srcd = join(tstsrc, subd)
+ for f in sorted(os.listdir(srcd)):
+ if f.endswith('.R'):
+ print 'Running {} explicitly by FastR CMD BATCH ...'.format(f)
+ mx.run([r_path(), '--vanilla', 'CMD', 'BATCH', join(srcd, f)] + args, nonZeroIsFatal=False, env=env, timeout=90)
+ outf = f + 'out'
+ if os.path.isfile(outf):
+ outff = outf + '.fastr'
+ os.rename(outf, outff)
+ print 'Running {} explicitly by GnuR CMD BATCH ...'.format(f)
+ mx.run([join(_gnur_path(), 'R'), '--vanilla', 'CMD', 'BATCH', join(srcd, f)] + args, nonZeroIsFatal=False, env=env, timeout=90)
+ if os.path.isfile(outf):
+ outfg = outf + '.gnur'
+ os.rename(outf, outfg)
+ diff.write('\nRdiff {} {}:\n'.format(outfg, outff))
+ diff.flush()
+ subprocess.Popen([r_path(), 'CMD', 'Rdiff', outfg, outff], stdout=diff, stderr=diff, shell=False)
+ diff.flush()
+ diff.close()
+ print 'FastR to GnuR diff was written to {}.'.format(diffname)
+
def nativebuild(args):
'''
force the build of part or all of the native project
@@ -510,6 +551,7 @@ _commands = {
'edinclude' : [mx_fastr_edinclude.edinclude, '[]'],
'gnu-r' : [gnu_r, '[]'],
'gnu-rscript' : [gnu_rscript, '[]'],
+ 'gnu-rtests' : [gnu_rtests, '[]'],
'nativebuild' : [nativebuild, '[]'],
}