@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/library/methods/html/R.css

@@ -0,0 +1,130 @@
+@media screen {
+    .container {
+	padding-right: 10px;
+	padding-left: 10px;
+	margin-right: auto;
+	margin-left: auto;
+	max-width: 900px;
+    }
+}
+
+.rimage img { /* from knitr - for examples and demos */
+    width: 96%;
+    margin-left: 2%;
+} 	
+
+.katex { font-size: 1.1em; }
+
+code {
+    color: inherit;
+    background: inherit;
+}
+
+body {
+    line-height: 1.4;
+    background: white;
+    color: black;
+}
+
+a:link {
+    background: white;
+    color: blue;
+}
+
+a:visited {
+    background: white;
+    color: rgb(50%, 0%, 50%);
+}
+
+h1 {
+    background: white;
+    color: rgb(55%, 55%, 55%);
+    font-family: monospace;
+    font-size: 1.4em; /* x-large; */
+    text-align: center;
+}
+
+h2 {
+    background: white;
+    color: rgb(40%, 40%, 40%);
+    font-family: monospace;
+    font-size: 1.2em; /* large; */
+    text-align: center;
+}
+
+h3 {
+    background: white;
+    color: rgb(40%, 40%, 40%);
+    font-family: monospace;
+    font-size: 1.2em; /* large; */
+}
+
+h4 {
+    background: white;
+    color: rgb(40%, 40%, 40%);
+    font-family: monospace;
+    font-style: italic;
+    font-size: 1.2em; /* large; */
+}
+
+h5 {
+    background: white;
+    color: rgb(40%, 40%, 40%);
+    font-family: monospace;
+}
+
+h6 {
+    background: white;
+    color: rgb(40%, 40%, 40%);
+    font-family: monospace;
+    font-style: italic;
+}
+
+img.toplogo {
+    width: 4em;
+    vertical-align: middle;
+}
+
+img.arrow {
+    width: 30px;
+    height: 30px;
+    border: 0;
+}
+
+span.acronym {
+    font-size: small;
+}
+
+span.env {
+    font-family: monospace;
+}
+
+span.file {
+    font-family: monospace;
+}
+
+span.option{
+    font-family: monospace;
+}
+
+span.pkg {
+    font-weight: bold;
+}
+
+span.samp{
+    font-family: monospace;
+}
+
+div.vignettes a:hover {
+    background: rgb(85%, 85%, 85%);
+}
+
+tr {
+    vertical-align: top;
+}
+
+span.rlang {
+    font-family: Courier New, Courier;
+    color: #666666;
+}
+

package/dist/vfs/usr/lib/R/library/methods/tests/S3.R

@@ -0,0 +1,29 @@
+## accumulate here tests of the relation between S4 and S3 classes
+
+## $<-.data.frame did stupid things with the class attribute
+## that clobbered S4 classes extending "data.frame"
+## Test that the S4 method (R 2.13.0) works transparently
+
+set.seed(864)
+
+xx <- data.frame(a=rnorm(10),
+                 b=as.factor(sample(c("T", "F"), 10, TRUE)),
+                 row.names = paste("R",1:10,sep=":"))
+
+setClass("myData", representation(extra = "character"),
+         contains = "data.frame")
+
+mx <- new("myData", xx, extra = "testing")
+
+## three kinds of $<-: replace, add, delete (NULL value)
+
+mx$a <- mx$a * 2
+xx$a <- xx$a * 2
+
+mx$c <- 1:10
+xx$c <- 1:10
+
+mx$b <- NULL
+xx$b <- NULL
+
+stopifnot(identical(mx, new("myData", xx, extra = "testing")))

package/dist/vfs/usr/lib/R/library/methods/tests/basicRefClass.R

@@ -0,0 +1,530 @@
+## simple call, only field names
+fg <- setRefClass("foo", c("bar", "flag"))
+f0 <- new("foo")  # deprecated, but should still work
+f1 <- fg(flag = "testing")
+f1$bar <- 1
+stopifnot(identical(f1$bar, 1))
+## add method
+fg$methods(showAll = function() c(bar, flag))
+stopifnot(all.equal(f1$showAll(), c(1, "testing")))
+str(f1)
+
+fg <- setRefClass("foo", list(bar = "numeric", flag = "character",
+                              tag = "ANY"),
+                  methods = list(addToBar = function(incr) {
+                      b <- bar + incr
+                      bar <<- b
+                      b
+                  } )
+                  )
+fg$lock("flag")
+stopifnot(identical(fg$lock(), "flag"))
+
+ff <- new("foo", bar = 1.5)
+stopifnot(identical(ff$bar, 1.5))
+ff$bar <- pi
+stopifnot(identical(ff$bar, pi))
+## flag has not yet been set
+ff$flag <- "flag test"
+stopifnot(identical(ff$flag, "flag test"))
+## but no second assign
+stopifnot(is(tryCatch(ff$flag <- "new", error = function(e)e), "error"))
+
+## test against generator
+
+f2 <- fg(bar = pi, flag = "flag test")
+## identical does not return TRUE if *contents* of env are identical
+stopifnot(identical(ff$bar, f2$bar), identical(ff$flag, f2$flag))
+## but flag was now assigned once
+stopifnot(is(tryCatch(f2$flag <- "new", error = function(e)e), "error"))
+
+str(f2)
+
+
+## add some accessor methods
+fg$accessors("bar")
+
+ff$setBar(1:3)
+stopifnot(identical(ff$getBar(), 1:3))
+
+ff$getBar()
+stopifnot(all.equal(ff$addToBar(1), 2:4))
+
+
+## Add a method
+fg$methods(barTimes = function(x) {
+    "This method multiples field bar by argument x
+and this string is self-documentation"
+    setBar(getBar() * x)})
+
+ffbar <- ff$getBar()
+ff$barTimes(10)
+stopifnot(all.equal(ffbar * 10, ff$getBar()))
+ff$barTimes(.1)
+
+## inheritance.  redefines flag so should fail:
+stopifnot(is(tryCatch(setRefClass("foo2", list(b2 = "numeric",
+					       flag = "complex"),
+            contains = "foo",
+            refMethods = list(addBoth = function(incr) {
+                addToBar(incr) #uses inherited class method
+                setB2(getB2() + incr)
+                })),
+          error = function(e)e), "error"))
+## but with flag as a subclass of "characters", should work
+## Also subclasses "tag" which had class "ANY before
+setClass("ratedChar", contains = "character",
+         representation(score = "numeric"))
+foo2 <- setRefClass("foo2", list(b2 = "numeric", flag = "ratedChar",
+				 tag = "numeric"),
+	    contains = "foo",
+	    methods = list(addBoth = function(incr) {
+                addToBar(incr) #uses inherited class method
+                b2 <<- b2 + incr
+                }))
+## now lock the flag field; should still allow one write
+foo2$lock("flag")
+f2 <- foo2(bar = -3, flag = as("ANY", "ratedChar"),
+               b2 = ff$bar, tag = 1.5)
+## but not a second one
+stopifnot(is(tryCatch(f2$flag <- "Try again",
+         error = function(e)e), "error"))
+str(f2)
+f22 <- foo2(bar = f2$bar)
+## same story if assignment follows the initialization
+f22$flag <- f2$flag
+stopifnot(is(tryCatch(f22$flag <- "Try again",
+         error = function(e)e), "error"))
+## Exporting superclass object
+f22 <- fg(bar = f2$bar, flag = f2$flag)
+f2e <- f2$export("foo")
+stopifnot(identical(f2e$bar, f22$bar), identical(f2e$flag, f22$flag),
+          identical(class(f2e), class(f22)))
+stopifnot(identical(f2$flag,  as("ANY", "ratedChar")),
+          identical(f2$bar, -3),
+          all.equal(f2$b2, 2:4+0))
+f2$addBoth(-1)
+stopifnot(all.equal(f2$bar, -4), all.equal(f2$b2, 1:3+0))
+
+## test callSuper()
+foo3 <- setRefClass("foo3", fields = list(flag2 = "ratedChar"),
+            contains = "foo2",
+	    methods = list(addBoth = function(incr) {
+		callSuper(incr)
+		flag2 <<- as(paste(flag, paste(incr, collapse = ", "),
+				   sep = "; "),
+                             "ratedChar")
+                incr
+            }))
+
+f2 <- foo2(bar = -3, flag = as("ANY", "ratedChar"), b2 =  1:3)
+f3 <- foo3()
+f3$import(f2)
+stopifnot(all.equal(f3$b2, f2$b2), all.equal(f3$bar, f2$bar),
+          all.equal(f3$flag, f2$flag))
+f3$addBoth(1)
+stopifnot(all.equal(f3$bar, -2), all.equal(f3$b2, 2:4+0),
+          all.equal(f3$flag2, as("ANY; 1", "ratedChar")))
+
+## but the import should have used up the one write for $flag
+stopifnot(is(tryCatch(f3$flag <- "Try again",
+         error = function(e)e), "error"))
+str(f3)
+
+## importing the same class (not very useful but documented to work)
+f3 <- foo3()
+f4 <- foo3(bar = -3, flag = as("More", "ratedChar"), b2 =  1:3, flag2 = f2$flag)
+f3$import(f4)
+stopifnot(identical(f3$bar, f4$bar),
+          identical(f3$flag, f4$flag),
+          identical(f3$b2, f4$b2),
+          identical(f3$flag2, f4$flag2))
+
+## similar to $import() but using superclass object in the generator call
+## The explicitly supplied flag= should override and be allowed
+## by the default $initialize()
+f3b <- foo3(f2, flag = as("Other", "ratedChar"),
+                flag2 = as("More", "ratedChar"))
+## check that inherited and direct field assignments worked
+stopifnot(identical(f3b$tag, f2$tag),
+          identical(f3b$flag, as("Other", "ratedChar")),
+          identical(f3b$flag2, as("More", "ratedChar")))
+## the $new() method should match the generator function
+f3b <- foo3$new(f2, flag = as("Other", "ratedChar"),
+                flag2 = as("More", "ratedChar"))
+stopifnot(identical(f3b$tag, f2$tag),
+          identical(f3b$flag, as("Other", "ratedChar")),
+          identical(f3b$flag2, as("More", "ratedChar")))
+## a class with an initialize method, and an extra slot (legal, not a good idea)
+setOldClass(c("simple.list", "list"))
+fg4 <- setRefClass("foo4",
+            contains = "foo2",
+            methods = list(
+              initialize = function(...) {
+                  .self$initFields(...)
+                  .self@made <<- R.version
+                  .self
+              }),
+            representation = list(made = "simple.list")
+            )
+
+f4 <- new("foo4", flag = as("another test", "ratedChar"), bar = 1:3)
+stopifnot(identical(f4@made, R.version))
+
+## a trivial class with no fields, using fields = list(), failed up to rev 56035
+foo5 <- setRefClass("foo5", fields = list(),
+                    methods = list(bar = function(test)
+                    paste("*",test,"*")))
+
+f5 <- foo5()
+stopifnot(identical( f5$bar("xxx"), paste("*","xxx", "*")))
+
+
+## simple active binding test
+abGen <- setRefClass("ab",
+                  fields = list(a = "ANY",
+                  b = function(x) if(missing(x)) a else {a <<- x; x}))
+
+ab1 <- abGen(a = 1)
+
+stopifnot(identical(ab1$a, 1), identical(ab1$b, 1))
+
+ab1$b <- 2
+
+stopifnot(identical(ab1$a, 2), identical(ab1$b, 2))
+
+## a simple editor for matrix objects.  Method  $edit() changes some
+## range of values; method $undo() undoes the last edit.
+mEditor <- setRefClass("matrixEditor",
+        fields = list(data = "matrix",
+		     edits = "list"),
+       methods = list(
+     edit = function(i, j, value) {
+       ## the following string documents the edit method
+       'Replaces the range [i, j] of the
+	object by value.
+        '
+         backup <-
+             list(i, j, data[i,j])
+         data[i,j] <<- value
+         edits <<- c(list(backup),
+                     edits)
+         invisible(value)
+     },
+     undo = function() {
+       'Undoes the last edit() operation
+        and update the edits field accordingly.
+        '
+         prev <- edits
+         if(length(prev)) prev <- prev[[1]]
+         else stop("No more edits to undo")
+         edit(prev[[1]], prev[[2]], prev[[3]])
+         ## trim the edits list
+         length(edits) <<- length(edits) - 2
+         invisible(prev)
+     }
+     ))
+xMat <- matrix(1:12,4,3)
+xx <- mEditor(data = xMat)
+xx$edit(2, 2, 0)
+xx$data
+xx$undo()
+mEditor$help("undo")
+stopifnot(all.equal(xx$data, xMat))
+
+## add a method to save the object
+mEditor$methods(
+     save = function(file) {
+       'Save the current object on the file
+ in R external object format.
+'
+         base::save(.self, file = file)
+     },
+     counter = function(i) {
+         'The number of items in the i-th edit.
+ (Used to test usingMethods())
+'
+         if(i > 0 && i <= length(edits))
+             length(edits[[i]][[3]])
+         else
+             0L
+     }
+)
+
+tf <- tempfile()
+xx$save(tf) #$
+load(tf)
+unlink(tf)
+stopifnot(identical(xx$data, .self$data))
+
+## tests of $trace() methods
+## debugging an object
+xx$trace(edit, quote(xxTrace <<- TRUE))
+
+## debugging all objects from class mEditor in method $undo()
+mEditor$trace(undo, quote(mETrace <<- TRUE))
+
+xxTrace <- mETrace <- FALSE
+xx$edit(2,3,100)
+xx$undo()
+
+## will not have changed the xx$undo() method (already used)
+stopifnot(identical(xxTrace, TRUE), identical(mETrace, FALSE))
+
+## but a new object works the other way around
+xxTrace <- mETrace <- FALSE
+xx <- mEditor(data = xMat)
+xx$edit(2,3,100)
+xx$undo()
+stopifnot(identical(xxTrace, FALSE), identical(mETrace, TRUE))
+
+
+
+markViewer <- ""
+setMarkViewer <- function(what)
+    markViewer <<- what
+
+## Inheriting a reference class:  a matrix viewer
+mv <- setRefClass("matrixViewer",
+    fields = c("viewerDevice", "viewerFile"),
+    contains = "matrixEditor",
+    methods = list( view = function() {
+        dd <- dev.cur(); dev.set(viewerDevice)
+        devAskNewPage(FALSE)
+        matplot(data, main = paste("After",length(edits),"edits"))
+        dev.set(dd)},
+        edit = # invoke previous method, then replot
+          function(i, j, value) {
+            callSuper(i, j, value)
+            view()
+          }))
+
+## initialize and finalize methods
+mv$methods( initialize = function(file = "./matrixView.pdf", ...) {
+    viewerFile <<- file
+    pdf(viewerFile)
+    viewerDevice <<- dev.cur()
+    message("Plotting to ", viewerFile)
+    dev.set(dev.prev())
+    setMarkViewer("ON")
+    initFields(...)
+  },
+  finalize = function() {
+    dev.off(viewerDevice)
+    setMarkViewer("OFF")
+  })
+
+## a counts method to test usingMethods()
+mv$methods( counts = function() {
+    usingMethods("counter")
+    sapply(seq_along(edits), "counter")
+})
+
+
+ff <- mv( data = xMat)
+stopifnot(identical(markViewer, "ON")) # check initialize
+ff$edit(2,2,0)
+ff$data
+if(methods:::.hasCodeTools())  # otherwise 'counter' is not visible
+    stopifnot(identical(ff$counts(), length(ff$edits[[1]][[3]])))
+ff$undo()
+stopifnot(all.equal(ff$data, xMat))
+rm(ff)
+gc()
+stopifnot(identical(markViewer, "OFF")) #check finalize
+
+## tests of copying
+viewerPlus <- setRefClass("viewerPlus",
+                   fields = list( text = "character",
+                      viewer = "matrixViewer"))
+ff <- mv( data = xMat)
+v1 <- viewerPlus(text = letters, viewer = ff)
+v2 <- v1$copy()
+v3 <- v1$copy(TRUE)
+v2$text <- "Hello, world"
+v2$viewer$data <- t(xMat) # change a field in v2$viewer
+v3$text <- LETTERS
+v3$viewer <- mv( data = matrix(nrow=1,ncol=1))
+## with a deep copy all is protected, with a shallow copy
+## the environment of a copied field remains the same,
+## but replacing the whole field should be local
+stopifnot(identical(v1$text, letters),
+          identical(v1$viewer, ff),
+          identical(v2$text, "Hello, world"))
+v3 <- v1$copy(TRUE)
+v3$viewer$data <- t(xMat) # should modify v1$viewer as well
+stopifnot(identical(v1$viewer$data, t(xMat)))
+
+## the field() method
+stopifnot(identical(v1$text, v1$field("text")))
+v1$field("text", "Now is the time")
+stopifnot(identical(v1$field("text"), "Now is the time"))
+
+## setting a non-existent field, or a method, should throw an error
+stopifnot(is(tryCatch(v1$field("foobar", 0), error = function(e)e), "error"),
+         is(tryCatch(v1$field("copy", 0), error = function(e)e), "error") )
+
+## the methods to extract class definition and generator
+stopifnot(identical(v3$getRefClass()$def, getRefClass("viewerPlus")$def),
+          identical(v3$getClass(), getClass("viewerPlus")))
+
+## deal correctly with inherited methods and overriding existing
+## methods from $methods(...)
+refClassA <- setRefClass("refClassA", methods=list(foo=function() "A"))
+refClassB <- setRefClass("refClassB", contains="refClassA")
+mnames <- objects(getClass("refClassB")@refMethods)
+refClassB$methods(foo=function() callSuper())
+stopifnot(identical(refClassB()$foo(), "A"))
+mnames2 <- objects(getClass("refClassB")@refMethods)
+stopifnot(identical(mnames2[is.na(match(mnames2,mnames))], "foo#refClassA"))
+refClassB$methods(foo=function() paste(callSuper(), "Version 2"))
+stopifnot(identical(refClassB()$foo(), "A Version 2"))
+stopifnot(identical(mnames2, objects(getClass("refClassB")@refMethods)))
+
+if(methods:::.hasCodeTools()) {
+    ## code warnings assigning locally to field names
+    stopifnot(is(tryCatch(mv$methods(test = function(x)
+                                 { data <- x[!is.na(x)]; mean(data)}),
+                          warning = function(e)e), "warning"))
+
+    ## warnings for nonlocal assignment that is not a field
+    stopifnot(is(tryCatch(mv$methods(test2 = function(x) {something <<- data[!is.na(x)]}), warning = function(e)e), "warning"))
+
+    ## error for trying to assign to a method name
+    stopifnot(is(tryCatch(mv$methods(test3 = function(x) {edit <<- data[!is.na(x)]}), error = function(e)e), "error"))
+} else
+    warning("Can't run some tests:  recommended package codetools is not available")
+
+## tests (fragmentary by necessity) of promptClass for reference class
+ccon <- textConnection("ctxt", "w")
+suppressMessages(promptClass("refClassB", filename = ccon))
+## look for a method, inheritance, inherited method
+stopifnot(length(c(grep("foo.*refClassA", ctxt),
+                   grep("code{foo()}", ctxt, fixed = TRUE),
+                   grep("linkS4class{refClassA", ctxt, fixed = TRUE))) >= 3)
+close(ccon)
+rm(ctxt)
+
+
+## tests related to subclassing environments.  These really test code in the core, viz. builtin.c
+a <- refClassA()
+ev <- new.env(parent = a) # parent= arg
+stopifnot(is.environment(ev))
+foo <- function()"A"; environment(foo) <- a # environment of function
+stopifnot(identical(as.environment(a), environment(foo)))
+xx <- 1:10; environment(xx) <- a # environment attribute
+stopifnot(identical(as.environment(a), environment(xx)))
+
+
+## tests of [[<- and $<- for subclasses of environment.  At one point
+## methods for these assignments were defined and caused
+## inf. recursion when the arguments to the [[<- case were changed in base.
+setClass("myEnv", contains = "environment")
+m <- new("myEnv", a="test")
+m2 <- new("myEnv"); m3 <- new("myEnv")
+## test that new.env() is called for each new object
+stopifnot(!identical(as.environment(m), as.environment(m2)),
+          !identical(as.environment(m3), as.environment(m2)))
+m[["x"]] <- 1; m$y <- 2
+stopifnot(identical(c(m[["x"]], m$y), c(1,2)), is(m, "myEnv"))
+rm(x, envir = m) # check rm() works, does not clobber class
+stopifnot(identical(sort(objects(m)), sort(c("a", "y"))),
+          is(m, "myEnv"))
+
+## tests of binding & environment tools with subclases of environment
+lockBinding("y", m)
+stopifnot(bindingIsLocked("y", m))
+unlockBinding("y", m)
+stopifnot(!bindingIsLocked("y", m))
+
+makeActiveBinding("z", function(value) {
+    if(missing(value))
+        "dummy"
+    else
+        "dummy assignment"
+}, m)
+stopifnot(identical(get("z", m),"dummy"))
+## assignment will return the value but do nothing
+stopifnot(identical(assign("z","other", m), "other"),
+          identical(get("z", m),"dummy"))
+
+
+## this has to be last--Seems no way to unlock an environment!
+lockEnvironment(m)
+stopifnot(environmentIsLocked(m))
+
+rm(m)
+m <- new("myEnv")
+stopifnot(length(ls(m)) == 0)
+## used to contain the previous content
+
+
+## test of callSuper() to a hidden default method for initialize() (== initFields)
+TestClass <- setRefClass ("TestClass",
+     fields = list (text = "character"),
+     methods = list(
+       print = function ()  {cat(text)},
+       initialize = function(text = "", ...) callSuper(text = paste(text, ":", sep=""),...)
+  ))
+tt <- TestClass("hello world")
+stopifnot(identical(tt$text, "hello world:"))
+## now a subclass with another field & another layer of callSuper()
+TestClass2 <- setRefClass("TestClass2",
+        contains = "TestClass",
+        fields = list( version = "integer"),
+        methods = list(
+          initialize = function(..., version = 0L)
+              callSuper(..., version = version+1L))
+  )
+tt <- TestClass2("test", version = 1L)
+stopifnot(identical(tt$text, "test:"), identical(tt$version, as.integer(2)))
+tt <- TestClass2(version=3L) # default text
+stopifnot(identical(tt$text, ":"), identical(tt$version, as.integer(4)))
+
+
+## test some capabilities but read-only for .self
+.changeAllFields <- function(replacement) {
+    fields <- names(.refClassDef@fieldClasses)
+    for(field in fields)
+        eval(substitute(.self$FIELD <- replacement$FIELD,
+                        list(FIELD = field)))
+}
+
+mEditor$methods(change = .changeAllFields)
+xx <- mEditor(data = xMat)
+xx$edit(2, 2, 0)
+
+yy <- mEditor(data = xMat+1)
+yy$change(xx)
+stopifnot(identical(yy$data, xx$data), identical(yy$edits, xx$edits))
+
+## but don't allow assigment
+if(methods:::.hasCodeTools())
+        stopifnot(is(tryCatch(yy$.self$data <- xMat, error = function(e)e), "error"))
+
+## the locked binding of refGeneratorSlot class should prevent modifying
+## methods, locking fields or setting accessor methods
+## Nothing special about refGeneratorSlot in this test -- the point is just
+## to use a standard reference class known to be defined in a package
+evr <- getRefClass("refGeneratorSlot") # in methods
+stopifnot(is(tryCatch(evr$methods(foo = function()"..."), error = function(e)e), "error"),
+         is(tryCatch(evr$lock("def"), error = function(e)e), "error"),
+         is(tryCatch(evr$accessors("def"), error = function(e)e), "error"))
+
+##getRefClass() method and function should work with either
+## a class name or a class representation (bug report 14600)
+tg <- setRefClass("tg", fields = "a")
+t1 <- tg(a=1)
+tgg <- t1$getRefClass()
+tggg <- getRefClass("tg")
+stopifnot(identical(tgg$def, tggg$def),
+          identical(tg$def, tgg$def))
+
+## this used to fail in initFieldArgs() from partial matching "self"
+selfClass <- setRefClass("selfClass",
+        fields=list(
+            self="character", super="character", sub="character"
+        )
+    )
+
+stopifnot(identical(selfClass(self="B", super="A", sub="C")$self, "B"))