@r-universe/webr 2023.6.11 → 2023.6.21

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

@@ -0,0 +1,35 @@
+## Tests for handling classes with same name & different package slots
+## First:  Can we define the classes and get the separate definitions
+## from the appropriate namespace or from the package slot in class(x)?
+if(!require(Matrix)) q()
+
+## from: example(chol)
+sy2 <- new("dsyMatrix", Dim = as.integer(c(2,2)), x = c(14, NA,32,77))
+c2 <- chol(sy2)
+
+clM <- getClass("Cholesky")
+
+setClass("Cholesky", contains = "numeric", representation(size = "integer"))
+
+clG <- getClass("Cholesky", where = .GlobalEnv)
+
+stopifnot(identical(getClass("Cholesky", where = asNamespace("Matrix")),
+                    clM))
+
+stopifnot(identical(getClass(class(c2)), clM))
+
+stopifnot(identical(evalq(getClass("Cholesky"), asNamespace("Matrix")),
+                    clM))
+stopifnot(identical(getClass("Cholesky"), clG))
+
+## Second:  tests of methods defined for the same generic
+## (NOT YET!)
+
+## Related: retaining package slots in methods signatures (reported by Martin Morgan)
+setClass("A")
+setGeneric("bar", function(x, y) standardGeneric("bar"))
+setMethod(bar, signature(x="A", y="A"), function(x, y) {})
+setMethod(bar, signature(x="A", y="ANY"), function(x, y) {})
+
+## tests one use of .matchSigLength
+stopifnot(all(nzchar(getMethod("bar", signature(x="A", y="ANY"))@target@package)))

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

@@ -0,0 +1,18 @@
+### Moved from reg-tests-1c.R
+
+## envRefClass prototypes are a bit special -- broke all.equal() for baseenv()
+rc <- getClass("refClass")
+rp <- rc@prototype
+str(rp) ## failed
+# rp ## show() failed .. # Throws an error - possibly due to interference from a previous test
+(ner <- new("envRefClass")) # show() failed
+stopifnot(all.equal(rp,rp), all.equal(ner,ner))
+be <- baseenv()
+system.time(stopifnot(all.equal(be,be)))## <- takes a few sec's
+stopifnot(
+    grepl("not identical.*character", print(all.equal(rp, ner))),
+    grepl("not identical.*character", print(all.equal(ner, rp))))
+system.time(stopifnot(all.equal(globalenv(), globalenv())))
+## Much of the above failed in  R <= 3.2.0
+
+proc.time()

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

@@ -0,0 +1,30 @@
+dt <- setRefClass("dt", fields = list(data = "environment", row.names = "character"))
+
+ev <- new.env()
+
+d1 <- dt$new(data = ev, row.names = letters)
+
+stopifnot(identical(d1$data, ev),
+          identical(d1$row.names, letters))
+
+# an invalid class should generate an error
+d2 <- tryCatch(dt$new(data = ev, row.names = 1:12), error = function(e)e)
+
+stopifnot(is(d2, "error"),
+          grepl("row.names", d2$message, fixed = TRUE),
+          grepl("character", d2$message, fixed = TRUE),
+          grepl("integer", d2$message, fixed = TRUE))
+
+# a simple subclass should be used, unchanged
+
+setClass("tagStrings", contains = "character",
+         representation(tag = "Date"))
+
+date1 <- as.Date("2010-01-15")
+
+t1 <- new("tagStrings", letters, tag = date1)
+
+d3 <- dt$new(data = ev, row.names = t1)
+
+stopifnot(identical(d3$row.names, t1))
+

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

@@ -0,0 +1,86 @@
+setClass("A", representation(a="numeric"))
+
+a1 <- new("A", a=1.5)
+m1 <- as.matrix(1)
+
+setClass("M", contains = "matrix", representation(fuzz = "numeric"))
+
+set.seed(113)
+f1 <- runif(3)
+
+stopifnot(identical(as(new("M", 1:12, nrow = 3, fuzz = f1), "matrix"),
+		    matrix(1:12, nrow=3)),
+	  identical(as(new("M", 1:12, 3, fuzz = f1), "matrix"),
+		    matrix(1:12, 3)),
+	  identical(as(new("M", 1:12, ncol = 3, fuzz = f1), "matrix"),
+		    matrix(1:12, ncol=3)))
+
+setClass("B", contains = c("matrix", "A"))
+
+stopifnot(## a new "B" element mixing two superclass objects
+	  identical(new("B", m1, a1)@a, a1@a),
+	  ## or not
+	  identical(as(new("B", m1),"matrix"), m1),
+	  ## or supplying a slot to override
+	  identical(new("B", matrix(m1, nrow = 2), a1, a=pi)@a, pi))
+
+## an extra level of inheritance
+setClass("C", contains = "B", representation(c = "character"))
+new("C", m1, c = "Testing")
+
+## verify that validity tests work (PR#14284)
+setValidity("B", function(object) {
+    if(all(is.na(object@a) | (object@a > 0)))
+      TRUE
+    else
+      "elements of slot \"a\" must be positive"
+})
+
+a2 <- new("A", a= c(NA,3, -1, 2))
+
+## from the SoDA package on CRAN
+muststop <- function(expr, silent = TRUE) {
+    tryExpr <- substitute(tryCatch(expr, error=function(cond)cond))
+    value <- eval.parent(tryExpr)
+    if(inherits(value, "error")) {
+        if(!silent)
+          message("muststop reports: ", value)
+        invisible(value)
+    }
+    else
+      stop(gettextf("The expression  %s should have thrown an error, but instead returned an object of class \"%s\"",
+           deparse(substitute(expr))[[1]], class(value)))
+}
+
+muststop(new("B", m1, a2))
+
+removeClass("B")
+removeClass("C")
+removeClass("M")
+
+## TODO:  make versions of above inheriting from "array" and "ts"
+
+removeClass("A")
+
+## removeClass() for a union where "matrix"/"array" is part:
+setClassUnion("mn", c("matrix","numeric")); removeClass("mn")# gave "node stack overflow",
+setClassUnion("an", c("array", "integer")); removeClass("an")#  (ditto)
+setClassUnion("AM", c("array", "matrix"));  removeClass("AM")#  (ditto)
+## as had "matrix" -> "array" -> "matrix" ... recursion
+
+## and we want this to *still* work:
+stopifnot(is(tryCatch(as(a3 <- array(1:24, 2:4), "matrix"), error=function(e)e),
+	     "error"),
+	  is(as(a2 <- array(1:12, 3:4), "matrix"),
+	     "matrix"),
+	  is(a2, "matrix"), is(a2, "array"), is(a3, "array"), !is(a3, "matrix"),
+	  ## and yes, "for now":
+	  identical(a2, matrix(1:12, 3)))
+
+## subclassing a class that did not allow new() w/o extra args failed
+## through version 3.1.1
+setClass("BAR", slots = c(y="integer"))
+
+setMethod("initialize", "BAR", function(.Object, Y) {.Object@y <- Y; .Object})
+
+setClass("BAR3", contains = "BAR")

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

@@ -0,0 +1,18 @@
+setClass("B", contains = "numeric")
+xx <- new("B", 1)
+names(xx) <- "A"
+stopifnot(identical(names(xx), "A"))
+setClass("A", representation(xx = "numeric"))
+a <- new("A", xx = 1)
+stopifnot(is(tryCatch(names(a) <- "A" , error = function(e)e), "error"))
+setClass("C", representation(xx = "numeric", names= "character"))
+c <- new("C", xx = 1, names = "A")
+c@names <- "B"
+stopifnot(is(tryCatch(names(c) <- "A" , error = function(e)e), "error"))
+setClass("D", contains = "numeric", representation(names = "character"))
+d <- new("D", 1)
+names(d) <- "A"
+stopifnot(identical(d@names, "A"))
+## test the checks on @<- primitive assignment
+stopifnot(is(tryCatch(a@yy <- 1 , error = function(e)e), "error"))
+stopifnot(is(tryCatch(a@xx <- "A" , error = function(e)e), "error"))

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

@@ -0,0 +1,21 @@
+setClass("A")
+ # Works OK but breaks another test later - renaming B to BB avoids the issue
+setClass("BB", contains = c("array", "A"))
+a = array(1:12, c(2,3,4))
+bb = new("BB", a)
+a2 = array(8:1, rep(2,3))
+stopifnot(identical(initialize(bb, a2), new("BB",a2)))
+
+withDots <- function(x, ...) names(list(...))
+
+setGeneric("withDots")
+
+setClass("C", representation(x="numeric", y="character"))
+
+setMethod("withDots", "C", function(x, ...)
+          callNextMethod()
+          )
+stopifnot(identical(withDots(1, a=1, b=2), withDots(new("C"), a=1, b=2)))
+removeClass("C"); removeClass("BB"); removeClass("A")
+removeGeneric("withDots")
+rm(a, bb, a2)

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

@@ -0,0 +1,51 @@
+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(edits, list(backup))
+         invisible(value)
+     },
+     undo = function() {
+       'Undoes the last edit() operation
+        and update the edits field accordingly.
+        '
+         prev <- edits
+         if(length(prev)) prev <- prev[[length(prev)]]
+         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 <- xEdited <- matrix(as.double(1:12),4,3)
+xEdited[[2,2]] <- 0
+xx <- mEditor$new(data = xMat)
+xx$edit(2, 2, 0)
+stopifnot(identical(xx$data, xEdited))
+xEdited[[1,3]] <- -1
+xx$edit(1,3, -1)
+stopifnot(identical(xx$data, xEdited))
+xx$undo()
+xEdited[[1,3]] <- xMat[[1,3]]
+stopifnot(identical(xx$data, xEdited))
+xx$undo()
+stopifnot(identical(xx$data, xMat))
+
+## the tracing method
+xx$trace(edit, quote(value <- 0))
+xx$edit(2,2, -1) # traced should assign 0
+stopifnot(identical(xx$data, xEdited))
+xx$untrace(edit)
+xx$edit(1, 3, -1) # now it should use -1
+xEdited[[1,3]] <- -1
+stopifnot(identical(xx$data, xEdited))

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

@@ -0,0 +1,38 @@
+setClass("maybe")
+
+setClass("A", representation(x = "numeric"))
+
+setIs("A", "maybe",
+      test = function(object)length(object@x) >= 1 && object@x[[1]] > 0,
+      coerce = function(from)from,
+      replace = function(from, value)
+      stop("meaningless to replace the \"maybe\" part of an object"))
+
+aa <- new("A", x=1)
+
+setGeneric("ff", function(x)"default ff")
+## test that the setGeneric() call created the generic & default
+stopifnot(is(ff, "standardGeneric"),
+          identical(body(getMethod("ff","ANY")), "default ff"))
+
+ffMaybe <- function(x) "ff maybe method"
+setMethod("ff", "maybe", ffMaybe)
+
+aa2 <- new("A", x = -1) # condition not TRUE
+stopifnot(identical(ff(aa),  "default ff"),
+	  identical(ff(aa2), "default ff"))# failed in R 2.11.0
+
+## a method to test the condition
+setMethod("ff", "A",
+	  function(x) {
+	      if(is(x, "maybe"))
+		  ffMaybe(x)
+	      else
+		  callNextMethod()
+	  })
+stopifnot(identical(ff(aa), "ff maybe method"),
+          identical(ff(aa2), "default ff"))
+
+removeClass("A")
+removeClass("maybe")
+removeGeneric("ff")

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

@@ -0,0 +1,83 @@
+## reset inherited methods of group members
+## (contributed by Martin Morgan, 2011-2-9)
+setClass("A", representation("numeric"))
+a <- new("A")
+
+setMethod("Logic", c("A", "A"), function(e1, e2) FALSE)
+res0 <- a & a                           # inherit &,A,A-method
+setMethod("Logic", c("A", "A"), function(e1, e2) TRUE)
+stopifnot(a & a)
+
+removeMethod("Logic", c("A", "A"))
+stopifnot(logical() == a & a)
+
+removeClass("A")
+
+### Find inherited group methods:
+if(require(Matrix)) { ## , lib.loc = .Library
+    sm <- selectMethod("-", c("dgCMatrix", "numeric"))# direct match with "Arith"
+    s2 <- selectMethod("-", c("dtCMatrix", "numeric"))# ambiguity match with "Arith"
+    stopifnot(sm@generic == "Arith", s2@generic == "Arith")
+}
+## was not ok in R 2.14.x
+
+## some tests of callGeneric().  It's reccommended for use with group generics
+setGeneric("f1", signature=c("a"),
+           function(..., a) standardGeneric("f1"))
+setMethod("f1", c(a="ANY"), function(..., a) list(a=a, ...))
+setMethod("f1", c(a="missing"), function(..., a) callGeneric(a=1, ...))
+f2 <- function(b,c,d, a) {
+    if (missing(a))
+        f1(b=b, c=c, d=d)
+    else
+        f1(a=a, b=b, c=c, d=d)
+}
+
+## use callGeneric both directly (f1) and indirectly (f2)
+## Latter failed pre rev. 66408; Bug ID 15937
+stopifnot(identical(c(1,2,3,4), as.vector(unlist(f1(2,3,4)))))
+stopifnot(identical(c(1,2,3,4), as.vector(unlist(f2(2,3,4)))))
+
+## test callGeneric() with no arguments.  This is rarely used
+## because nearly all applications use the groups Ops, etc.
+## whose members are primitives => must supply args to callGeneric
+
+Hide <- setClass("Hide", slots = c(data = "vector"), contains = "vector")
+
+unhide <- function(obj)
+    obj@data
+
+setGeneric("%p%", function(e1, e2) e1 + e2, group = "Ops2")
+setGeneric("%gt%", function(e1, e2) e1 > e2, group = "Ops2")
+
+setGroupGeneric("Ops2", function(e1,e2)NULL, knownMembers = c("%p%","%gt%"))
+
+setMethod("Ops2", c("Hide", "Hide"),
+          function(e1, e2) {
+              e1 <- unhide(e1)
+              e2 <- unhide(e2)
+              callGeneric()
+          })
+
+setMethod("Ops2", c("Hide", "vector"),
+          function(e1, e2) {
+              e1 <- unhide(e1)
+              callGeneric()
+          })
+setMethod("Ops2", c("vector", "Hide"),
+          function(e1, e2) {
+              e2 <- unhide(e2)
+              callGeneric()
+          })
+
+h1 <- Hide(data = 1:10)
+h2 <- Hide(data = (1:10)*.5+ 0.5)
+
+stopifnot(all.equal(h1%p%h2, h1@data + h2@data))
+stopifnot(all.equal(h1 %gt% h2, h1@data > h2@data))
+
+removeClass("Hide")
+for(g in c("f1", "%p%", "%gt%", "Ops2"))
+    removeGeneric(g)
+
+

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

@@ -0,0 +1,61 @@
+## test (non-conditional) explicit inheritance
+setClass("xy", representation(x="numeric", y="numeric"))
+
+setIs("xy", "complex",
+      coerce = function(from) complex(real = from@x, imaginary = from@y),
+      replace = function(from, value) {
+          from@x <- Re(value)
+          from@y <- Im(value)
+          from
+      })
+
+set.seed(124)
+x1 <- rnorm(10)
+y1 <- rnorm(10)
+cc <- complex(real = x1, imaginary=y1)
+xyc <- new("xy", x = x1, y = y1)
+stopifnot(identical(cc, as(xyc, "complex")))
+as(xyc, "complex") <- cc * 1i
+stopifnot(identical(xyc, new("xy", x = -y1, y = x1)))
+
+setGeneric("size", function(x)standardGeneric("size"))
+## check that generic for size() was created w/o a default method
+stopifnot(is(size, "standardGeneric"),
+          is.null(selectMethod("size", "ANY",optional=TRUE)))
+
+setMethod("size", "vector", function(x)length(x))
+
+## class "xy" should inherit the vector method through complex
+stopifnot(identical(size(xyc), length(x1)))
+removeClass("xy")
+removeGeneric("size")
+
+
+### Related to  numeric <-> double <-> integer  proposals, end of 2015, on R-devel
+myN   <- setClass("myN",   contains="numeric")
+myNid <- setClass("myNid", contains="numeric", representation(id="character"))
+NN <-    setClass("NN", representation(x="numeric"))
+
+(m1 <- myN  (1:3))
+(m2 <- myNid(1:3, id = "i3"))
+tools::assertError(NN (1:3))# in all R versions
+nn <- myN(2*pi)
+##                     # current R  |  (not existing)
+##                     # -----------|----------
+class(getDataPart(m1)) # integer    |  numeric
+class(getDataPart(m2)) # integer    |  numeric
+## check for now [[conceivably, these *could* change !]] :
+stopifnot(identical(getDataPart(m1), 1:3),
+	  identical(getDataPart(m2), 1:3),
+	  identical(S3Part(m1, strict=TRUE), 1:3),
+	  identical(S3Part(m2, strict=TRUE), 1:3),
+	  identical(2*pi, S3Part(nn, strict = TRUE)))
+
+if(FALSE) ## --- all these fail still:
+stopifnot(
+    identical(as(1L, "numeric"), as.numeric(1L))
+    ,
+    identical(as(1L, "numeric"), 1.0)
+    ,
+    is.double(as(1L, "double"))
+    )

package/dist/vfs/usr/lib/R/library/parallel/DESCRIPTION

@@ -0,0 +1,16 @@
+Package: parallel
+Version: 4.3.0
+Priority: base
+Title: Support for Parallel Computation in R
+Author: R Core Team
+Maintainer: R Core Team <do-use-Contact-address@r-project.org>
+Contact: R-help mailing list <r-help@r-project.org>
+Description: Support for parallel computation, including by forking
+   (taken from package multicore), by sockets (taken from package snow)
+   and random-number generation.
+License: Part of R 4.3.0
+Imports: tools, compiler
+Suggests: methods
+Enhances: snow, Rmpi
+NeedsCompilation: yes
+Built: R 4.3.0; x86_64-pc-linux-gnu; 2023-06-21 12:51:09 UTC; unix

package/dist/vfs/usr/lib/R/library/parallel/INDEX

@@ -0,0 +1,16 @@
+children                Low-level Functions for Management of Forked
+                        Processes
+clusterApply            Apply Operations using Clusters
+detectCores             Detect the Number of CPU Cores
+makeCluster             Create a Parallel Socket Cluster
+mcaffinity              Get or Set CPU Affinity Mask of the Current
+                        Process
+mcfork                  Fork a Copy of the Current R Process
+mclapply                Parallel Versions of 'lapply' and 'mapply'
+                        using Forking
+mcparallel              Evaluate an R Expression Asynchronously in a
+                        Separate Process
+nextRNGStream           Implementation of Pierre L'Ecuyer's RngStreams
+parallel-package        Support for Parallel Computation
+pvec                    Parallelize a Vector Map Function using Forking
+splitIndices            Divide Tasks for Distribution in a Cluster

package/dist/vfs/usr/lib/R/library/parallel/NAMESPACE

@@ -0,0 +1,42 @@
+## Namespace for package 'parallel'
+useDynLib("parallel", .registration = TRUE, .fixes = "C_")
+
+export(nextRNGStream, nextRNGSubStream, clusterSetRNGStream)
+
+if(tools:::.OStype() == "unix") {
+    export(mccollect, mcparallel, mc.reset.stream, mcaffinity)
+}
+
+export(clusterApply, clusterApplyLB, clusterCall, clusterEvalQ,
+       clusterExport, clusterMap, clusterSplit, detectCores,
+       getDefaultCluster,
+       makeCluster, makeForkCluster, makePSOCKcluster, mcMap,
+       mclapply, mcmapply, parApply, parCapply, parLapply,
+       parLapplyLB, parRapply, parSapply, parSapplyLB, pvec,
+       setDefaultCluster, splitIndices, stopCluster)
+
+S3method(print, SOCKcluster)
+S3method(print, SOCKnode)
+S3method(print, SOCK0node)
+S3method("[", cluster)
+S3method(closeNode, SOCKnode)
+S3method(closeNode, SOCK0node)
+S3method(closeNode, default)
+S3method(recvData, SOCKnode)
+S3method(recvData, SOCK0node)
+S3method(recvOneData, SOCKcluster)
+S3method(sendData, SOCKnode)
+S3method(sendData, SOCK0node)
+S3method(stopCluster, default)
+
+## To support snow clusters
+#S3method(closeNode, NWSnode)
+#S3method(recvData, NWSnode)
+#S3method(recvOneData, NWScluster)
+#S3method(sendData, NWSnode)
+#S3method(stopCluster, NWScluster)
+S3method(recvData, MPInode)
+S3method(recvOneData, MPIcluster)
+S3method(sendData, MPInode)
+S3method(stopCluster, MPIcluster)
+S3method(stopCluster, spawnedMPIcluster)

package/dist/vfs/usr/lib/R/library/parallel/R/parallel

@@ -0,0 +1,27 @@
+#  File share/R/nspackloader.R
+#  Part of the R package, https://www.R-project.org
+#
+#  Copyright (C) 1995-2012 The R Core Team
+#
+#  This program is free software; you can redistribute it and/or modify
+#  it under the terms of the GNU General Public License as published by
+#  the Free Software Foundation; either version 2 of the License, or
+#  (at your option) any later version.
+#
+#  This program is distributed in the hope that it will be useful,
+#  but WITHOUT ANY WARRANTY; without even the implied warranty of
+#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+#  GNU General Public License for more details.
+#
+#  A copy of the GNU General Public License is available at
+#  https://www.r-project.org/Licenses/
+
+local({
+    info <- loadingNamespaceInfo()
+    pkg <- info$pkgname
+    ns <- .getNamespace(as.name(pkg))
+    if (is.null(ns))
+        stop("cannot find namespace environment for ", pkg, domain = NA);
+    dbbase <- file.path(info$libname, pkg, "R", pkg)
+    lazyLoad(dbbase, ns, filter = function(n) n != ".__NAMESPACE__.")
+})

package/dist/vfs/usr/lib/R/library/parallel/help/AnIndex

@@ -0,0 +1,45 @@
+parallel-package	parallel-package
+children	children
+clusterApply	clusterApply
+clusterApplyLB	clusterApply
+clusterCall	clusterApply
+clusterEvalQ	clusterApply
+clusterExport	clusterApply
+clusterMap	clusterApply
+clusterSetRNGStream	RngStream
+clusterSplit	clusterApply
+detectCores	detectCores
+getDefaultCluster	makeCluster
+makeCluster	makeCluster
+makeForkCluster	makeCluster
+makePSOCKcluster	makeCluster
+mc.reset.stream	RngStream
+mcaffinity	mcaffinity
+mccollect	mcparallel
+mcexit	mcfork
+mcfork	mcfork
+mckill	children
+mclapply	mclapply
+mcMap	mclapply
+mcmapply	mclapply
+mcparallel	mcparallel
+nextRNGStream	RngStream
+nextRNGSubStream	RngStream
+parallel	parallel-package
+parApply	clusterApply
+parCapply	clusterApply
+parLapply	clusterApply
+parLapplyLB	clusterApply
+parRapply	clusterApply
+parSapply	clusterApply
+parSapplyLB	clusterApply
+pvec	pvec
+readChild	children
+readChildren	children
+R_PARALLEL_PORT	makeCluster
+selectChildren	children
+sendChildStdin	children
+sendMaster	children
+setDefaultCluster	makeCluster
+splitIndices	splitIndices
+stopCluster	makeCluster