@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/tests/method-dispatch.Rout.save

@@ -0,0 +1,222 @@
+
+R Under development (unstable) (2023-03-26 r84067) -- "Unsuffered Consequences"
+Copyright (C) 2023 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.
+
+> #### Testing  UseMethod() and even more NextMethod()
+> #### -------------------- 
+> #### i.e.,  S3 methods *only*. For S4, see  reg-S4.R
+> ##                                          ~~~~~~~~
+> 
+> ###-- Group methods
+> 
+> ## previous versions used print() and hit an auto-printing bug.
+> 
+> ### Arithmetic "Ops" :
+> ">.bar" <- function(...) {cat("using >.bar\n"); FALSE}
+> ">.foo" <- function(...) {cat("using >.foo\n"); TRUE}
+> Ops.foo <- function(...) {
++     cat("using Ops.foo\n")
++     NextMethod()
++ }
+> Ops.bar <- function(...) {
++     cat("using Ops.bar\n")
++     TRUE
++ }
+> 
+> x <- 2:4 ; class(x) <- c("foo", "bar")
+> y <- 4:2 ; class(y) <- c("bar", "foo")
+> 
+> ## The next 4 give a warning each about incompatible methods:
+> x > y
+[1] FALSE FALSE  TRUE
+Warning message:
+Incompatible methods (">.foo", ">.bar") for ">" 
+> y < x # should be the same (warning msg not, however)
+[1] FALSE FALSE  TRUE
+Warning message:
+Incompatible methods ("Ops.bar", "Ops.foo") for "<" 
+> x == y
+[1] FALSE  TRUE FALSE
+Warning message:
+Incompatible methods ("Ops.foo", "Ops.bar") for "==" 
+> x <= y
+[1]  TRUE  TRUE FALSE
+Warning message:
+Incompatible methods ("Ops.foo", "Ops.bar") for "<=" 
+> 
+> x > 3 ##[1] ">.foo"
+using >.foo
+[1] TRUE
+> 
+> rm(list=">.foo")
+> x > 3 #-> "Ops.foo" and ">.bar"
+using Ops.foo
+using >.bar
+[1] FALSE
+> 
+> 
+> 
+> ### ------------  was ./mode-methods.R till R ver. 1.0.x ----------------
+> 
+> ###-- Using Method Dispatch on "mode" etc :
+> ## Tests S3 dispatch with the class attr forced to be data.class
+> ## Not very relevant when S4 methods are around, but kept for historical interest
+> abc <- function(x, ...) {
++     cat("abc: Before dispatching; x has class `", class(x), "':", sep="")
++     str(x)
++     UseMethod("abc", x) ## UseMethod("abc") (as in S) fails
++ }
+> 
+> abc.default <- function(x, ...) sys.call()
+> 
+> "abc.(" <- function(x)
++     cat("'(' method of abc:", deparse(sys.call(sys.parent())),"\n")
+> abc.expression <- function(x)
++     cat("'expression' method of abc:", deparse(sys.call(sys.parent())),"\n")
+> 
+> abc(1)
+abc: Before dispatching; x has class `numeric': num 1
+abc.default(1)
+> e0 <- expression((x))
+> e1 <- expression(sin(x))
+> abc(e0)
+abc: Before dispatching; x has class `expression':  expression((x))
+'expression' method of abc: abc.expression(e0) 
+> abc(e1)
+abc: Before dispatching; x has class `expression':  expression(sin(x))
+'expression' method of abc: abc.expression(e1) 
+> abc(e0[[1]])
+abc: Before dispatching; x has class `(': language, mode "(": (x)
+'(' method of abc: `abc.(`(e0[[1]]) 
+> abc(e1[[1]])
+abc: Before dispatching; x has class `call': language sin(x)
+abc.default(e1[[1]])
+> 
+> 
+> ## Some tests for `nameOfClass()`, called from inherits()
+> ClassX <- structure(list(), name = "ClassX",
++                     class = c("S3pp_class", "S3pp_object"))
+> 
+> classx_instance <- structure(list(), class = c("ClassX", "S3pp_object"))
+> 
+> nameOfClass.S3pp_class <- function(x) attr(x, "name", TRUE)
+> nameOfClass.foo <- function(x) "bar"
+> 
+> stopifnot(exprs = {
++     inherits(classx_instance, "ClassX")
++     inherits(classx_instance, ClassX)
++     ## ignore class on a character object
++     isTRUE(inherits(1, structure("numeric", class = "foo")))
++     ## make sure class is nor evaluated in calling nameOfClass
++     isFALSE(inherits(1, structure(quote(stop("should not be evaluated")),
++                                   class = "foo")))
++ })
+> 
+> 
+> ## Some tests for `@` dispatching
+> ## make sure that
+> ## - `@` evals the first args only once,
+> ## -  doesn't dispatch for S4
+> ## -  works on `.Data` even for nonS4 objects
+> 
+> x <- structure(list(), class = "foo", prop1 = 'prop1val')
+> registerS3method("@", "foo",
++     function(x, name) {
++         stopifnot(typeof(name) == "character", length(name) == 1L)
++         cat(sprintf("called `@.foo`(x = %s, name = '%s')\n",
++                      deparse1(substitute(x), "\n"), name))
++         attr(x, name, TRUE)
++     }
++ )
+> x@prop1
+called `@.foo`(x = x, name = 'prop1')
+[1] "prop1val"
+> 
+> abc <- x
+> abc@prop1
+called `@.foo`(x = abc, name = 'prop1')
+[1] "prop1val"
+> 
+> {
++     cat("new x\n")
++     structure(list(), class = "foo", prop1 = 'prop1val')
++ }@prop1
+new x
+called `@.foo`(x = {
+    cat("new x\n")
+    structure(list(), class = "foo", prop1 = "prop1val")
+}, name = 'prop1')
+[1] "prop1val"
+> 
+> makeActiveBinding("ax", function(x) {
++     cat("evaluating ax\n")
++     get("x", envir = parent.frame())
++ }, environment())
+> 
+> ax@prop1
+evaluating ax
+called `@.foo`(x = ax, name = 'prop1')
+[1] "prop1val"
+> 
+> stopifnot(exprs = {
++     identical( x@prop1, "prop1val")
++     identical(ax@prop1, "prop1val")
++ 
++     identical(letters@.Data, letters)
++ })
+called `@.foo`(x = x, name = 'prop1')
+evaluating ax
+called `@.foo`(x = ax, name = 'prop1')
+> 
+> try(letters@foo) # error
+Error in letters@foo : 
+  no applicable method for `@` applied to an object of class "character"
+> 
+> # doesn't dispatch for S4
+> setClass("Person",
++   slots = c(
++     name = "character",
++     age = "numeric"
++   )
++ )
+> 
+> `@.Person` <- function(x, name) {
++   stop("called @.Person()\n")
++ }
+> 
+> p <- new("Person", name = "Who", age = -1)
+> stopifnot(p@name == "Who")
+> 
+> 
+> ## Some tests for `chooseOpsMethod()`, called from C DispatchGroup() when
+> ## 2 methods are found
+> foo_obj <- structure(1, class = "foo")
+> bar_obj <- structure(1, class = "bar")
+> 
+> `+.foo` <- function(e1, e2) "foo"
+> `+.bar` <- function(e1, e2) "bar"
+> 
+> invisible(foo_obj + bar_obj)  # Warning: Incompatible methods
+Warning message:
+Incompatible methods ("+.foo", "+.bar") for "+" 
+> 
+> chooseOpsMethod.bar <- function(x, y, mx, my, cl, reverse) TRUE
+> 
+> stopifnot(exprs = {
++     identical(foo_obj + bar_obj, "bar")
++     identical(bar_obj + foo_obj, "bar")
++ })
+> 

package/dist/vfs/usr/lib/R/tests/no-segfault.Rin

@@ -0,0 +1,143 @@
+###-*- R -*-
+###--- This "foo.Rin" script is only used to create the real script "foo.R" :
+
+###--- We need to use such a long "real script" instead of a for loop,
+###--- because "error --> jump_to_toplevel", i.e., outside any loop.
+
+core.pkgs <- local({x <- installed.packages(.Library)
+    unname(x[x[,"Priority"] %in% "base", "Package"])})
+core.pkgs <-
+    core.pkgs[- match(c("methods", "parallel", "tcltk", "stats4"), core.pkgs, 0)]
+## move methods to the end because it has side effects (overrides primitives)
+## stats4 requires methods
+core.pkgs <- c(core.pkgs, "methods", "stats4")
+
+stop.list <- vector("list", length(core.pkgs))
+names(stop.list) <- core.pkgs
+
+## -- Stop List for base/graphics/utils:
+edit.int <- c("fix", "edit", "edit.data.frame", "edit.matrix",
+              "edit.default", "vi", "file.edit",
+              "emacs", "pico", "xemacs", "xedit", "RSiteSearch", "help.request")
+
+## warning: readLines will work, but read all the rest of the script
+## warning: trace will load methods.
+## warning: rm and remove zap c0, l0, m0, df0
+## warning: parent.env(NULL) <- NULL creates a loop
+## warning: browseVignettes launches many browser processes.
+## news, readNEWS, rtags are slow, and R-only code.
+misc.int <- c("browser", "browseVignettes", "bug.report", "checkCRAN",
+              "getCRANmirrors", "lazyLoad", "menu", "repeat",
+              "readLines", "package.skeleton", "trace", "recover",
+              "rm", "remove", "parent.env<-",
+              "builtins", "data", "help", "news", "rtags", "vignette",
+              "installed.packages")
+inet.list <- c(apropos("download\\."),
+               apropos("^url\\."), apropos("\\.url"),
+               apropos("packageStatus"),
+               paste(c("CRAN", "install", "update", "old"), "packages", sep="."))
+socket.fun <- apropos("socket")
+## "Interactive" ones:
+dev.int <- c("X11", "x11", "pdf", "postscript",
+             "xfig", "jpeg", "png", "pictex", "quartz",
+             "svg", "tiff", "cairo_pdf", "cairo_ps",
+             "getGraphicsEvent")
+misc.2 <- c("asS4", "help.start", "browseEnv", "make.packages.html",
+            "gctorture", "q", "quit", "restart", "try",
+            "read.fwf", "source",## << MM thinks "FIXME"
+            "data.entry", "dataentry", "de", apropos("^de\\."),
+            "chooseCRANmirror", "setRepositories", "select.list", "View")
+if(.Platform$OS.type == "windows") {
+    dev.int <- c(dev.int, "bmp", "windows", "win.graph", "win.print",
+                "win.metafile")
+    misc.2 <- c(misc.2, "file.choose", "choose.files", "choose.dir",
+    		"setWindowTitle", "loadRconsole",
+                "arrangeWindows", "getWindowsHandles")
+}
+
+stop.list[["base"]] <-
+    if(nchar(Sys.getenv("R_TESTLOTS"))) {## SEVERE TESTING, try almost ALL
+	c(edit.int, misc.int)
+    } else {
+	c(inet.list, socket.fun, edit.int, misc.int, misc.2)
+    }
+
+## S4 group generics should not be called directly
+## and doing so sometimes leads to infinite recursion
+s4.group.generics <- c("Arith", "Compare", "Ops", "Logic", "Math", "Math2", "Summary", "Complex")
+
+## warning: browseAll will tend to read all the script and/or loop forever
+stop.list[["methods"]] <- c("browseAll", "recover", s4.group.generics)
+stop.list[["tools"]] <- c("write_PACKAGES", # problems with Packages/PACKAGES
+                          "update_PACKAGES",
+                          "dependsOnPkgs", # call to installed.packages() slow w/ large library
+                          "testInstalledBasic",
+                          "testInstalledPackages", # runs whole suite
+                          "readNEWS",              # slow, pure R code
+                          "findHTMLlinks", "pskill",
+                          "texi2dvi", "texi2pdf",  # hang on Windows
+                          "getVignetteInfo",       # very slow on large installation
+                          "CRAN_package_db",       # slow, pure R code
+                          "CRAN_check_results",
+                          "CRAN_check_details",
+                          "CRAN_memtest_notes",
+                          "summarize_CRAN_check_status",
+                          "startDynamicHelp"       # makes R hang on exit
+                                                   # on Windows
+                          )
+stop.list[["grDevices"]] <- dev.int
+stop.list[["utils"]] <- c("Rprof", "aspell", # hangs on Windows
+                          "winProgressBar",
+                          "chooseBioCmirror",# too slow, R code 
+                          inet.list, socket.fun, edit.int, misc.int, misc.2)
+
+sink("no-segfault.R")
+
+if(.Platform$OS.type == "unix") cat('options(pager = "cat")\n')
+if(.Platform$OS.type == "windows") cat('options(pager = "console")\n')
+cat('options(error=expression(NULL))',
+    "# don't stop on error in batch\n##~~~~~~~~~~~~~~\n")
+
+cat(".libPaths(tail(.libPaths(), 1), include.site=FALSE) # no extra libraries (w/ many pkgs)\n")
+
+cat(".proctime00 <- proc.time()\n")
+
+for (pkg in core.pkgs) {
+  cat("### Package ", pkg, "\n",
+      "###         ", rep("~",nchar(pkg)), "\n", collapse="", sep="")
+  pkgname <- paste("package", pkg, sep=":")
+  this.pos <- match(paste("package", pkg, sep=":"), search())
+  lib.not.loaded <- is.na(this.pos)
+  if(lib.not.loaded) {
+      library(pkg, character = TRUE, warn.conflicts = FALSE)
+      cat("library(", pkg, ")\n")
+  }
+  this.pos <- match(paste("package", pkg, sep=":"), search())
+
+  for(nm in ls(pkgname)) { # <==>  no '.<name>' functions are tested here
+      if(!(nm %in% stop.list[[pkg]]) &&
+	 is.function(f <- get(nm, pos = pkgname))) {
+	  cat("\n## ", nm, " :\n")
+
+	  cat("c0 <- character(0)\n",
+	      "l0 <- logical(0)\n",
+	      "m0 <- matrix(1,0,0)\n",
+	      "df0 <- as.data.frame(c0)\n", sep="")
+
+	  cat("f <- get(\"",nm,"\", pos = '", pkgname, "')\n", sep="")
+	  cat("f()\nf(NULL)\nf(,NULL)\nf(NULL,NULL)\n",
+	      "f(list())\nf(l0)\nf(c0)\nf(m0)\nf(df0)\nf(FALSE)\n",
+	      "f(list(),list())\nf(l0,l0)\nf(c0,c0)\n",
+              "f(df0,df0)\nf(FALSE,FALSE)\n",
+	      sep="")
+      }
+  }
+  if(lib.not.loaded) {
+      detach(pos=this.pos)
+      cat("detach(pos=", this.pos, ")\n", sep="")
+  }
+
+  cat("\n##__________\n\n")
+}
+
+cat("proc.time() - .proctime00\n")

package/dist/vfs/usr/lib/R/tests/ok-errors.R

@@ -0,0 +1,24 @@
+#### STRICT test suite in the spirit of no-segfaults,
+#### but with explicit statements.
+
+options(error=expression(NULL))
+stop("test of `options(error=expression(NULL))'")
+
+if(FALSE) {
+## these ought to work on machines with enough memory
+## These segfaulted in 1.3.x ,  give "could not allocate" errors now
+  integer(2^30+1)
+   double(2^30+1)
+  complex(2^30+1)
+character(2^30+1)
+vector("list", 2^30+2)
+}
+
+## bad infinite recursion / on.exit / ... interactions
+##   catch the error to permit different error messages emitted
+##   (handling of infinite recursion is different in the AST interpreter
+##   and the byte-code interpreter)
+
+bar <- function() 1+1
+foo <- function() { on.exit(bar()); foo() }
+tryCatch(foo(), error=function(x) TRUE) # now simple "infinite recursion"

package/dist/vfs/usr/lib/R/tests/ok-errors.Rout.save

@@ -0,0 +1,44 @@
+
+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.
+
+> #### STRICT test suite in the spirit of no-segfaults,
+> #### but with explicit statements.
+> 
+> options(error=expression(NULL))
+> stop("test of `options(error=expression(NULL))'")
+Error: test of `options(error=expression(NULL))'
+> 
+> if(FALSE) {
++ ## these ought to work on machines with enough memory
++ ## These segfaulted in 1.3.x ,  give "could not allocate" errors now
++   integer(2^30+1)
++    double(2^30+1)
++   complex(2^30+1)
++ character(2^30+1)
++ vector("list", 2^30+2)
++ }
+> 
+> ## bad infinite recursion / on.exit / ... interactions
+> ##   catch the error to permit different error messages emitted
+> ##   (handling of infinite recursion is different in the AST interpreter
+> ##   and the byte-code interpreter)
+> 
+> bar <- function() 1+1
+> foo <- function() { on.exit(bar()); foo() }
+> tryCatch(foo(), error=function(x) TRUE) # now simple "infinite recursion"
+[1] TRUE
+>