@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/tests/arith-true.Rout.save

@@ -0,0 +1,327 @@
+
+R Under development (unstable) (2022-03-19 r81942) -- "Unsuffered Consequences"
+Copyright (C) 2022 The R Foundation for Statistical Computing
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit 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 & d-p-q-r-tst-2.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
+[1] TRUE
+> ##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)
+[1] TRUE
+> is.infinite( i1) & is.infinite( i2) &   i1 > 12   &   i2 > 12
+[1] TRUE
+> is.infinite(-i1) & is.infinite(-i2) & (-i1) < -12 & (-i2) < -12
+[1] TRUE
+> 
+> is.nan(n1 <- 0 / 0)
+[1] TRUE
+> is.nan( - n1)
+[1] TRUE
+> 
+> i1 ==  i1 + i1
+[1] TRUE
+> i1 ==  i1 * i1
+[1] TRUE
+> is.nan(i1 - i1)
+[1] TRUE
+> is.nan(i1 / i1)
+[1] TRUE
+> 
+> 1/0 == Inf & 0 ^ -1 == Inf
+[1] TRUE
+> 1/Inf == 0 & Inf ^ -1 == 0
+[1] TRUE
+> 
+> iNA <- as.integer(NA)
+> !is.na(Inf) & !is.nan(Inf) &   is.infinite(Inf) & !is.finite(Inf)
+[1] TRUE
+> !is.na(-Inf)& !is.nan(-Inf)&   is.infinite(-Inf)& !is.finite(-Inf)
+[1] TRUE
+>  is.na(NA)  & !is.nan(NA)  &  !is.infinite(NA)  & !is.finite(NA)
+[1] TRUE
+>  is.na(NaN) &  is.nan(NaN) &  !is.infinite(NaN) & !is.finite(NaN)
+[1] TRUE
+>  is.na(iNA) & !is.nan(iNA) &  !is.infinite(iNA) & !is.finite(iNA)
+[1] TRUE
+> 
+> ## These are "double"s:
+> all(!is.nan(c(1.,NA)))
+[1] TRUE
+> all(c(FALSE,TRUE,FALSE) == is.nan(c   (1.,NaN,NA)))
+[1] TRUE
+> ## 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
+[1] TRUE
+> is.nan(log(-1))# TRUE and warning
+[1] TRUE
+Warning message:
+In log(-1) : NaNs produced
+> 
+> rp <- c(1:2,Inf); rn <- rev(- rp)
+> r <- c(rn, 0, rp, NA, NaN)
+> all(r^0 == 1)
+[1] TRUE
+> ir <- suppressWarnings(as.integer(r))
+> all(ir^0  == 1)
+[1] TRUE
+> all(ir^0L == 1)# not in R <= 2.15.0
+[1] TRUE
+> all( 1^r  == 1)# not in R 0.64
+[1] TRUE
+> all(1L^r  == 1)
+[1] TRUE
+> all(1L^ir == 1)# not in R <= 2.15.0
+[1] TRUE
+> all((rn ^ -3) == -((-rn) ^ -3))
+[1] TRUE
+> #
+> all(c(1.1,2,Inf) ^ Inf == Inf)
+[1] TRUE
+> all(c(1.1,2,Inf) ^ -Inf == 0)
+[1] TRUE
+> .9 ^ Inf == 0
+[1] TRUE
+> .9 ^ -Inf == Inf
+[1] TRUE
+> ## Wasn't ok in 0.64:
+> all(is.nan(rn ^ .5))# in some C's : (-Inf) ^ .5 gives Inf, instead of NaN
+[1] TRUE
+> 
+> 
+> ## Real Trig.:
+> cos(0) == 1
+[1] TRUE
+> sin(3*pi/2) == cos(pi)
+[1] TRUE
+> x <- rnorm(99)
+> all( sin(-x) == - sin(x))
+[1] TRUE
+> all( cos(-x) == cos(x))
+[1] TRUE
+> 
+> x <- 1:99/100
+> all(abs(1 - x / asin(sin(x))) <= 2*Meps)# "== 2*" for HP-UX
+[1] TRUE
+> all(abs(1 - x / atan(tan(x))) <  2*Meps)
+[1] TRUE
+> 
+> ## 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
+[1] TRUE
+> r <- rlnorm(5000) # NB random, and next has failed for some seed
+> all(abs(rErr(gamma(r+1), r*gamma(r))) < 500 * Meps)
+[1] TRUE
+> ## 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
+[1] TRUE
+> n <-   50; all(abs(rErr( gamma(1:n), cumprod(c(1,1:(n-1))))) < 20*Meps)#Lnx: f=2
+[1] TRUE
+> n <-  120; all(abs(rErr( gamma(1:n), cumprod(c(1,1:(n-1))))) < 1000*Meps)
+[1] TRUE
+> n <- 10000;all(abs(rErr(lgamma(1:n),cumsum(log(c(1,1:(n-1)))))) < 100*Meps)
+[1] TRUE
+> 
+> n <-   10; all(		 gamma(1:n) == cumprod(c(1,1:(n-1))))
+[1] TRUE
+> n <-   20; all(abs(rErr( gamma(1:n), cumprod(c(1,1:(n-1))))) < 100*Meps)
+[1] TRUE
+> n <-  120; all(abs(rErr( gamma(1:n), cumprod(c(1,1:(n-1))))) < 1000*Meps)
+[1] TRUE
+> n <- 10000;all(abs(rErr(lgamma(1:n),cumsum(log(c(1,1:(n-1)))))) < 100*Meps)
+[1] TRUE
+> 
+> all(is.nan(gamma(0:-47))) # + warn.
+[1] TRUE
+Warning message:
+In gamma(0:-47) : NaNs produced
+> 
+> ## choose() {and lchoose}:
+> n51 <- c(196793068630200, 229591913401900, 247959266474052)
+> abs(c(n51, rev(n51))- choose(51, 23:28)) <= 2
+[1] TRUE TRUE TRUE TRUE TRUE TRUE
+> all(choose(0:4,2) == c(0,0,1,3,6))
+[1] TRUE
+> ## 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
+[1] TRUE
+> all.equal(digamma(1) - digamma(1/2), log(4), tolerance = 32*Meps)# Linux: < 1*Meps!
+[1] TRUE
+> n <- 1:12
+> all.equal(digamma(n),
++          - gEuler + c(0, cumsum(1/n)[-length(n)]),tolerance = 32*Meps)#i386 Lx: 1.3 Meps
+[1] TRUE
+> all.equal(digamma(n + 1/2),
++           - gEuler - log(4) + 2*cumsum(1/(2*n-1)),tolerance = 32*Meps)#i386 Lx: 1.8 Meps
+[1] TRUE
+> ## 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)
+[1] TRUE
+> 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)
+Warning messages:
+1: In digamma(x) : NaNs produced
+2: In psigamma(x, 0) : NaNs produced
+> ## 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
+[1] TRUE
+> 
+> ## 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
+[1] TRUE
+[1] TRUE
+[1] TRUE
+[1] TRUE
+[1] TRUE
+[1] TRUE
+[1] TRUE
+[1] TRUE
+[1] TRUE
+> 
+> ## 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))
+[1] TRUE
+> all( pmin(v1, 1:3) == pmin(1:3, v1) & pmin(1:3, v1) == c(1,2,2))
+[1] TRUE
+> 
+> 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))
+[1] TRUE
+>  all( pmin(m1, 1:7) == pmin(1:7, m1) & pmin(1:7, m1) == c(1:3,3,3,3,2))
+[1] TRUE
+>  all( pmax(m2, 1:7) == pmax(1:7, m2) & pmax(1:7, m2) == pmax(1:7, m1))
+[1] TRUE
+>  all( pmin(m2, 1:7) == pmin(1:7, m2) & pmin(1:7, m2) == c(1:3,2,2,2,2))
+[1] TRUE
+> 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))
+[1] TRUE
+> 
+> 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)
+[1] TRUE
+> is.na(match(c(1,pi,pi0), pi)[3])
+[1] TRUE
+> 
+> ## PR#749:
+> all(is.na(c(NA && TRUE, TRUE  && NA, NA && NA,
++             NA || FALSE,FALSE || NA, NA || NA)))
+[1] TRUE
+> 
+> all((c(NA || TRUE,  TRUE || NA,
++     !c(NA && FALSE,FALSE && NA))))
+[1] TRUE
+> 
+> 
+> ## 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))
+[1] NaN
+> is.na(z)
+[1] TRUE
+> 
+> ## Last Line:
+> cat('Time elapsed: ', proc.time() - .proctime00,'\n')
+Time elapsed:  0.677 0.028 0.714 0 0 
+> 

package/dist/vfs/usr/lib/R/tests/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
+

package/dist/vfs/usr/lib/R/tests/arith.Rout.save

@@ -0,0 +1,88 @@
+
+R Under development (unstable) (2022-03-19 r81942) -- "Unsuffered Consequences"
+Copyright (C) 2022 The R Foundation for Statistical Computing
+Platform: x86_64-pc-linux-gnu (64-bit)
+
+R is free software and comes with ABSOLUTELY NO WARRANTY.
+You are welcome to redistribute it under certain conditions.
+Type 'license()' or 'licence()' for distribution details.
+
+R is a collaborative project with many contributors.
+Type 'contributors()' for more information and
+'citation()' on how to cite R or R packages in publications.
+
+Type 'demo()' for some demos, 'help()' for on-line help, or
+'help.start()' for an HTML browser interface to help.
+Type 'q()' to quit R.
+
+> options(digits=7)
+> 
+> ## powers
+> outer(a <- -4:12,     -2:7, "^")
+             [,1]        [,2] [,3] [,4] [,5] [,6]  [,7]   [,8]    [,9]    [,10]
+ [1,] 0.062500000 -0.25000000    1   -4   16  -64   256  -1024    4096   -16384
+ [2,] 0.111111111 -0.33333333    1   -3    9  -27    81   -243     729    -2187
+ [3,] 0.250000000 -0.50000000    1   -2    4   -8    16    -32      64     -128
+ [4,] 1.000000000 -1.00000000    1   -1    1   -1     1     -1       1       -1
+ [5,]         Inf         Inf    1    0    0    0     0      0       0        0
+ [6,] 1.000000000  1.00000000    1    1    1    1     1      1       1        1
+ [7,] 0.250000000  0.50000000    1    2    4    8    16     32      64      128
+ [8,] 0.111111111  0.33333333    1    3    9   27    81    243     729     2187
+ [9,] 0.062500000  0.25000000    1    4   16   64   256   1024    4096    16384
+[10,] 0.040000000  0.20000000    1    5   25  125   625   3125   15625    78125
+[11,] 0.027777778  0.16666667    1    6   36  216  1296   7776   46656   279936
+[12,] 0.020408163  0.14285714    1    7   49  343  2401  16807  117649   823543
+[13,] 0.015625000  0.12500000    1    8   64  512  4096  32768  262144  2097152
+[14,] 0.012345679  0.11111111    1    9   81  729  6561  59049  531441  4782969
+[15,] 0.010000000  0.10000000    1   10  100 1000 10000 100000 1000000 10000000
+[16,] 0.008264463  0.09090909    1   11  121 1331 14641 161051 1771561 19487171
+[17,] 0.006944444  0.08333333    1   12  144 1728 20736 248832 2985984 35831808
+> 
+> for (n1 in 1:7)
++     print(zapsmall(polyroot(1:n1), digits = 10))
+complex(0)
+[1] -0.5+0i
+[1] -0.3333333+0.4714045i -0.3333333-0.4714045i
+[1] -0.0720852+0.6383267i -0.6058296+0.0000000i -0.0720852-0.6383267i
+[1]  0.1378323+0.6781544i -0.5378323+0.3582847i -0.5378323-0.3582847i
+[4]  0.1378323-0.6781544i
+[1]  0.2941946+0.6683671i -0.3756952+0.5701752i -0.3756952-0.5701752i
+[4]  0.2941946-0.6683671i -0.6703320+0.0000000i
+[1]  0.4106842+0.6398894i -0.6341119+0.2876550i -0.2051437-0.6837970i
+[4]  0.4106842-0.6398894i -0.2051437+0.6837970i -0.6341119-0.2876550i
+> 
+> ## lowess() {incl. sort, etc}:
+> options(digits = 5)
+> 
+> lowess(c(3,2,6,3,8,4))$y # this used to differ on Linux
+[1] 2.4259 3.4293 3.9896 5.2832 5.3386 4.9822
+> 
+> y1 <- c(3,1:2,5:2,4,1:3,3)
+> lowess(y1)$y
+ [1] 2.0723 2.4362 2.7508 3.0038 3.2036 3.2435 2.8485 2.4832 2.4197 2.5231
+[11] 2.6286 2.7813
+> lowess(y1, f = .4)$y
+ [1] 2.7030 1.9593 2.4351 3.4933 4.0000 3.0000 2.4651 1.8579 1.7357 2.0000
+[11] 2.7103 3.1184
+> 
+> lowess(c(y1,100), f = .4)$y
+ [1] 2.2135 2.2468 2.5459 3.7984 4.0000 3.0000 2.8427 2.4999 2.1512 2.0000
+[11] 2.7129 3.1195 3.4172
+> 
+> ## 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
+ [1] 13.6588 11.1446  8.7012  9.7220 10.0000 11.3000 11.3000 11.3000 11.3000
+[10] 11.3000 11.3000 11.3000 11.3000 11.3000 11.3000 13.0000  6.4399  5.5959
+[19]  5.4557 18.9982
+> lowess(x,y, f = .25, iter = 0, delta = 3)$y
+ [1] 13.6588 12.3466 11.0343  9.7220 10.5110 11.3000 11.3000 11.3000 11.3000
+[10] 11.3000 11.3000 11.3000 11.3000 11.3000 11.3000 13.0000  6.4399  5.5959
+[19]  5.4557 18.9982
+> lowess(x,y, f = .25, iter = 2, delta = 0)$y
+ [1] 14.8112 12.1154  8.9838  9.6757 10.0000 11.3460 11.3460 11.3460 11.3460
+[10] 11.3460 11.3460 11.3460 11.3460 11.3460 11.3460 13.0000  6.7345  5.7437
+[19]  5.4147 18.9981
+> 
+> 

package/dist/vfs/usr/lib/R/tests/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"))

package/dist/vfs/usr/lib/R/tests/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)