@r-universe/webr 2023.6.11 → 2023.6.21

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

@@ -0,0 +1,252 @@
+
+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.
+
+> ## 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")
+[1] TRUE
+> try(read.table("foo1")) # fails
+Error in read.table("foo1") : no lines available in input
+> read.table("foo1", col.names=LETTERS[1:4])
+[1] A B C D
+<0 rows> (or 0-length row.names)
+> unlink("foo1")
+> 
+> # header only
+> cat("head\n", file = "foo2")
+> read.table("foo2")
+    V1
+1 head
+> try(read.table("foo2", header=TRUE)) # fails in 1.2.3
+[1] head
+<0 rows> (or 0-length row.names)
+> unlink("foo2")
+> # header detection
+> cat("head\n", 1:2, "\n", 3:4, "\n", file = "foo3")
+> read.table("foo3", header=TRUE)
+  head
+1    2
+3    4
+> read.table("foo3", header=TRUE, col.names="V1")
+  V1
+1  2
+3  4
+> read.table("foo3", header=TRUE, row.names=1)
+  head
+1    2
+3    4
+> read.table("foo3", header=TRUE, row.names="row.names")
+  head
+1    2
+3    4
+> read.table("foo3", header=TRUE, row.names="head") # fails in 1.2.3
+  row.names
+2         1
+4         3
+> 
+> # wrong col.names
+> try(read.table("foo3", header=TRUE, col.names=letters[1:4]))
+Error in scan(file = file, what = what, sep = sep, quote = quote, dec = dec,  : 
+  line 1 did not have 4 elements
+In addition: Warning message:
+In read.table("foo3", header = TRUE, col.names = letters[1:4]) :
+  header and 'col.names' are of different lengths
+> unlink("foo3")
+> 
+> # incomplete last line
+> cat("head\n", 1:2, "\n", 3:4, file = "foo4")
+> read.table("foo4", header=TRUE)
+  head
+1    2
+3    4
+Warning message:
+In read.table("foo4", header = TRUE) :
+  incomplete final line found by readTableHeader on 'foo4'
+> unlink("foo4")
+> 
+> # blank last line
+> cat("head\n\n", 1:2, "\n", 3:4, "\n\n", file = "foo5")
+> read.table("foo5", header=TRUE)
+  head
+1    2
+3    4
+> 
+> # test of fill
+> read.table("foo5", header=FALSE, fill=TRUE, blank.lines.skip=FALSE) # fails in 1.2.3
+    V1 V2
+1 head NA
+2      NA
+3    1  2
+4    3  4
+5      NA
+> unlink("foo5")
+> 
+> cat("head\n", 1:2, "\n", 3:5, "\n", 6:9, "\n", file = "foo6")
+> try(read.table("foo6", header=TRUE))
+Error in read.table("foo6", header = TRUE) : 
+  more columns than column names
+> try(read.table("foo6", header=TRUE, fill=TRUE))
+Error in read.table("foo6", header = TRUE, fill = TRUE) : 
+  more columns than column names
+> read.table("foo6", header=FALSE, fill=TRUE)
+    V1 V2 V3 V4
+1 head NA NA NA
+2    1  2 NA NA
+3    3  4  5 NA
+4    6  7  8  9
+> 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))
+   A   B      C  D     E    F
+1  1 1.1 1.1+0i NA FALSE  abc
+2 NA  NA     NA NA    NA <NA>
+3  1 2.0 3.0+0i NA  TRUE  def
+> sapply(res, typeof)
+        A         B         C         D         E         F 
+"integer"  "double" "complex" "logical" "logical" "integer" 
+> sapply(res, class)
+        A         B         C         D         E         F 
+"integer" "numeric" "complex" "logical" "logical"  "factor" 
+> (res2 <- read.table("foo7",
++                     colClasses = c("character", rep("numeric", 2),
++                     "complex", "integer", "logical", "character")))
+   A   B      C  D     E    F
+1  1 1.1 1.1+0i NA FALSE  abc
+2 NA  NA     NA NA    NA <NA>
+3  1 2.0 3.0+0i NA  TRUE  def
+> sapply(res2, typeof)
+          A           B           C           D           E           F 
+   "double"    "double"   "complex"   "integer"   "logical" "character" 
+> sapply(res2, class)
+          A           B           C           D           E           F 
+  "numeric"   "numeric"   "complex"   "integer"   "logical" "character" 
+> unlink("foo7")
+> 
+> # should be logical
+> type.convert(character(0), as.is=FALSE)
+logical(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)
+  a b c
+1 1 2 3
+2 4 5 6
+3 7 8 9
+> 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="")
+  x1 x.2 x3
+1  1   2  2
+2  2   3  3
+> 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")
+     V1            V2          V3
+1    C1            C2          C3
+2 Panel Area Examined # Blemishes
+3     1           0.8           3
+4     2           0.6           2
+5     3           0.8           3
+> 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 = "%")
+     V1            V2          V3
+1    C1            C2          C3
+2 Panel Area Examined % Blemishes
+3     1           0.8           3
+4     2           0.6           2
+5     3           0.8           3
+> 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)
+[1] 1 2 3 4 5 6 7 8
+> close(con)
+> 
+> ## tests of allowEscape
+> x <- "1 2 3 \\ab\\c"
+> writeLines(x, "test.dat")
+> readLines("test.dat")
+[1] "1 2 3 \\ab\\c"
+> scan("test.dat", "", allowEscapes=TRUE)
+Read 4 items
+[1] "1"    "2"    "3"    "\abc"
+> scan("test.dat", "", allowEscapes=FALSE)
+Read 4 items
+[1] "1"       "2"       "3"       "\\ab\\c"
+> read.table("test.dat", header=FALSE, allowEscapes=TRUE)
+  V1 V2 V3   V4
+1  1  2  3 \abc
+> read.table("test.dat", header=FALSE, allowEscapes=FALSE)
+  V1 V2 V3      V4
+1  1  2  3 \\ab\\c
+> 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)
+                 TEST
+1                   1
+2                   2
+3                 \\b
+4                   4
+5                   5
+6               \\040
+7               \\x20
+8  c:\\spencer\\tests
+9                 \\t
+10                \\n
+11                \\r
+> unlink("test.dat")
+> ## end of tests
+> 

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