[GR-128] Testing - include tests from GNUR (/tests/...).

PullRequest: fastr/1164

.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

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"}
 ]

com.oracle.truffle.r.native/gnur/Makefile

 #
-# 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:

com.oracle.truffle.r.native/gnur/tests/README

+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
+

com.oracle.truffle.r.native/gnur/tests/src/CRANtools.R

+### 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")

com.oracle.truffle.r.native/gnur/tests/src/Examples/Sweave-test-1.R

+### 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)
+
+

com.oracle.truffle.r.native/gnur/tests/src/Examples/example-1_def.R

+### 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)
+
+

com.oracle.truffle.r.native/gnur/tests/src/Examples/example-1_myA-noF.R

+### 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)
+
+

com.oracle.truffle.r.native/gnur/tests/src/Examples/example-1_myA.R

+### 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)
+
+

com.oracle.truffle.r.native/gnur/tests/src/PCRE.R

+.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")

com.oracle.truffle.r.native/gnur/tests/src/any-all.R

+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)

com.oracle.truffle.r.native/gnur/tests/src/arith-true.R

+####=== 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')

com.oracle.truffle.r.native/gnur/tests/src/arith.R

+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
+

com.oracle.truffle.r.native/gnur/tests/src/array-subset.R

+## 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"))