@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/tests/r-strict-tst.R

@@ -0,0 +1,57 @@
+#### Strict "regression" (no output comparison) tests
+#### for  [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

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

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

package/dist/vfs/usr/lib/R/tests/reg-IO.Rout.save

@@ -0,0 +1,176 @@
+
+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.
+
+> ## 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)
+[1] 5
+> print(4+5)
+[1] 9
+> 
+> ## 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")
+[1] "# line 1"    "2+3"         "ls()"        "pi"          "# last line"
+> source("testIO.R", echo=TRUE)
+
+> # line 1
+> 2+3
+[1] 5
+
+> ls()
+[1] "z"
+
+> pi
+[1] 3.141593
+
+> # last line
+> 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")
+[1] "# line 1"    "2+3"         "ls()"        "pi"          "# last line"
+[6] "5+6"        
+Warning message:
+In readLines("testIO.R") : incomplete final line found on 'testIO.R'
+> source("testIO.R", echo=TRUE)
+
+> # line 1
+> 2+3
+[1] 5
+
+> ls()
+[1] "z"  "zz"
+
+> pi
+[1] 3.141593
+
+> # last line
+> 5+6
+[1] 11
+> unlink("testIO.R")
+> 
+> ## ======== CRLF file
+> cat(z, file="testIO.R", sep="\r\n")
+> source("testIO.R", echo=TRUE)
+
+> # line 1
+> 2+3
+[1] 5
+
+> ls()
+[1] "z"  "zz"
+
+> pi
+[1] 3.141593
+
+> # last line
+> readLines("testIO.R")
+[1] "# line 1"    "2+3"         "ls()"        "pi"          "# last line"
+> 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")
+[1] "# line 1"    "2+3"         "ls()"        "pi"          "# last line"
+[6] "5+6"        
+Warning message:
+In readLines("testIO.R") : incomplete final line found on 'testIO.R'
+> source("testIO.R", echo=TRUE)
+
+> # line 1
+> 2+3
+[1] 5
+
+> ls()
+[1] "z"  "zz"
+
+> pi
+[1] 3.141593
+
+> # last line
+> 5+6
+[1] 11
+> unlink("testIO.R")
+> 
+> ## ======== CR file
+> cat(z, file="testIO.R", sep="\r")
+> readLines("testIO.R")
+[1] "# line 1"    "2+3"         "ls()"        "pi"          "# last line"
+Warning message:
+In readLines("testIO.R") : incomplete final line found on 'testIO.R'
+> source("testIO.R", echo=TRUE)
+
+> # line 1
+> 2+3
+[1] 5
+
+> ls()
+[1] "z"  "zz"
+
+> pi
+[1] 3.141593
+
+> # last line
+> 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")
+[1] "# line 1"    "2+3"         "ls()"        "pi"          "# last line"
+[6] "5+6"        
+Warning message:
+In readLines("testIO.R") : incomplete final line found on 'testIO.R'
+> source("testIO.R", echo=TRUE)
+
+> # line 1
+> 2+3
+[1] 5
+
+> ls()
+[1] "z"  "zz"
+
+> pi
+[1] 3.141593
+
+> # last line
+> 5+6
+[1] 11
+> unlink("testIO.R")
+> 
+> ## end of reg-IO.R: the next line has no EOL chars
+> 2 + 2
+[1] 4
+> 

package/dist/vfs/usr/lib/R/tests/reg-IO2.R

@@ -0,0 +1,124 @@
+## tests of boundary cases in read.table()
+
+## force standard handling for character cols
+options(stringsAsFactors=FALSE) # R >= 4.0.0
+
+# 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", stringsAsFactors=TRUE))
+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), as.is=FALSE)
+
+# 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