@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/library/utils/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/utils/misc/exDIF.csv

@@ -0,0 +1,5 @@
+Var1,Var2
+2.7,A
+3.14,B
+10,A
+-7,A

package/dist/vfs/usr/lib/R/library/utils/misc/exDIF.dif

@@ -0,0 +1,44 @@
+TABLE
+0,1
+"EXCEL"
+VECTORS
+0,5
+""
+TUPLES
+0,2
+""
+DATA
+0,0
+""
+-1,0
+BOT
+1,0
+"Var1"
+1,0
+"Var2"
+-1,0
+BOT
+0,2.7
+V
+1,0
+"A"
+-1,0
+BOT
+0,3.14
+V
+1,0
+"B"
+-1,0
+BOT
+0,10
+V
+1,0
+"A"
+-1,0
+BOT
+0,-7
+V
+1,0
+"A"
+-1,0
+EOD

package/dist/vfs/usr/lib/R/library/utils/tests/Sexpr-verb-ex.Rnw

@@ -0,0 +1,44 @@
+\documentclass[11pt,a4paper]{article}
+
+%% *** automatically switched by 'make' ( ./Makefile ) --- CARE!! in changing
+\SweaveOpts{echo=FALSE,eval=FALSE,results=hide}   % Exercise mode
+%\SweaveOpts{echo=TRUE,eval=TRUE,results=verbatim} % Solution mode
+%% other Sweave options
+\SweaveOpts{engine=R, keep.source=TRUE, strip.white=true}
+
+\newif\ifSolution
+\Solutiontrue% if solution
+\Solutionfalse%if exercise
+%
+\ifSolution\newcommand{\commentSol}[1]{#1}
+\else      \newcommand{\commentSol}[1]{}
+\fi
+\newcommand{\T}[1]{\texttt{#1}}
+
+\begin{document}
+
+<<preliminaries,echo=FALSE,results=hide>>=
+options(width = 75, digits = 5, str=list(vec.len=2))
+@
+
+We work with the data set \T{airquality} which is part of R....
+You can address it simply by \T{airquality}. Use \T{?airquality} to read about the
+meaning of the variables contained in the dataset.
+
+Get a summary of the data,
+<<s-air-2,echo=TRUE,eval=TRUE>>=
+summary(airquality)
+@
+
+\commentSol{The data set contains \Sexpr{nrow(airquality)} observations. The data is
+complete for all but the first two variables \T{Ozone}, \T{Solar.R},
+which contain \Sexpr{sum(is.na(airquality[,1]))} and
+\Sexpr{sum(is.na(airquality[,2]))} missing values, respectively.
+}
+
+The above works in solution mode,
+but in exercise mode, the $\backslash$Sexpr results are put out verbatim,
+unfortunately using $\backslash$\verb|verb{bla bla{|  and the left brace
+\emph{really} messes up the $\backslash$commentSol\verb|{..}| command...
+
+\end{document}

package/dist/vfs/usr/lib/R/library/utils/tests/Sweave-tst.R

@@ -0,0 +1,85 @@
+#  File src/library/utils/tests/Sweave-tst.R
+#  Part of the R package, https://www.R-project.org
+#
+#  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/
+
+## Testing Sweave
+if (FALSE) { # Sweave fails under emscripten (throws a syscall error)
+.proctime00 <- proc.time()
+library(utils)
+options(digits = 5) # to avoid trivial printed differences
+options(show.signif.stars = FALSE) # avoid fancy quotes in o/p
+
+SweaveTeX <- function(file, ...) {
+    if(!file.exists(file))
+        stop("File", file, "does not exist in", getwd())
+    texF <- sub("\\.[RSrs]nw$", ".tex", file)
+    Sweave(file, ...)
+    if(!file.exists(texF))
+        stop("File", texF, "does not exist in", getwd())
+    readLines(texF)
+}
+
+p0 <- paste0
+latexEnv <- function(lines, name) {
+    stopifnot(is.character(lines), is.character(name),
+	      length(lines) >= 2, length(name) == 1)
+    beg <- p0("\\begin{",name,"}")
+    end <- p0("\\end{",name,"}")
+    i <- grep(beg, lines, fixed=TRUE)
+    j <- grep(end, lines, fixed=TRUE)
+    if((n <- length(i)) != length(j))
+	stop(sprintf("different number of %s / %s", beg,end))
+    if(any(j-1 < i+1))
+	stop(sprintf("positionally mismatched %s / %s", beg,end))
+    lapply(mapply(seq, i+1,j-1, SIMPLIFY=FALSE),
+	   function(ind) lines[ind])
+}
+
+## now, Sweave() and check  *.Rnw  examples :
+
+### ------------------------------------ 1 ----------------------------------
+t1 <- SweaveTeX("swv-keepSrc-1.Rnw")
+if(FALSE)## look at it
+writeLines(t1)
+
+inp <- latexEnv(t1, "Sinput")
+out <- latexEnv(t1, "Soutput")
+## This may have to be updated when the *.Rnw changes:
+stopifnot(length(inp) == 5,
+	  grepl("#", inp[[2]]), length(inp[[3]]) == 1,
+	  length(out) == 1,
+	  any(grepl("\\includegraphics", t1)))
+
+### ------------------------------------ 2 ----------------------------------
+## Sweave() comments with  keep.source=TRUE
+t2 <- SweaveTeX("keepsource.Rnw")
+comml <- grep("##", t2, value=TRUE)
+stopifnot(length(comml) == 2,
+	  grepl("initial comment line", comml[1]),
+	  grepl("last comment", comml[2]))
+## the first was lost in 2.12.0;  the last in most/all previous versions of R
+
+### ------------------------------------ 3 ----------------------------------
+## custom graphics devices
+Sweave("customgraphics.Rnw")
+
+### ------------------------------------ 4 ----------------------------------
+## SweaveOpts + \Sexpr --> \verb... output
+Sweave(f <- "Sexpr-verb-ex.Rnw")
+tools::texi2pdf(sub("Rnw$","tex", f))# used to fail
+
+
+cat('Time elapsed: ', proc.time() - .proctime00,'\n')
+}

package/dist/vfs/usr/lib/R/library/utils/tests/charclass.R

@@ -0,0 +1,97 @@
+{
+    codepointsToString <- function(x)
+        parse(keep.source=FALSE, text=dQuote(q="\"\"", paste0(collapse="",
+              sprintf("\\u%04x", as.integer(x)))))[[1]]
+
+    testCharClass <- function(codepoints, class, expected = NULL) {
+        stopifnot(is.numeric(codepoints))
+        codepoints <- as.integer(codepoints)
+        stopifnot(!anyNA(codepoints), all(codepoints > 0))
+        if (!is.null(expected))
+          stopifnot(length(codepoints) == length(expected),
+                    is.logical(expected))
+
+        result <- list()
+        result$`charClass(int vs char)` <-
+            all.equal(charClass(codepoints, class),
+                      charClass(codepointsToString(codepoints), class))
+        if (!is.null(expected))
+            result$`expected` <- all.equal(expected,
+                                           charClass(codepoints, class))
+        result <- Filter(Negate(isTRUE), result)
+        if (length(result)==0) TRUE else result
+    }
+
+    charClasses <- c("alnum", "alpha", "blank", "cntrl", "digit", "graph",
+                     "lower", "print", "punct", "space", "upper", "xdigit")
+    testCodepoints <- list(
+        # "\tAB, ab:3", all ASCII
+        ASCII = c(0x0009, 0x0041, 0x0042, 0x002c, 0x0020, 0x0061, 0x0062,
+                  0x003a, 0x0033),
+
+        # "Ivan IV", with Ivan in Cyrillic
+        Cyrillic = c(0x0418, 0x0432, 0x0430, 0x043d, 0x0020, 0x0049, 0x0056),
+
+        # "Shalom", letters are U+05d0 through U+05ea
+        # the others (at 2, 3 and 6) are diacritical marks
+        Hebrew = c(0x05E9, 0x05C1, 0x05B8, 0x05DC, 0x05D5, 0x05B9, 0x05DD)) 
+                                                                             
+    # check for consistency between integer and string inputs
+    stopifnot(all(unlist((outer(testCodepoints, charClasses,
+        function(x,y) lapply(seq_along(x),
+                             function(i) testCharClass(x[[i]],y[i])))))))
+}
+
+# spot check return values
+{
+    stopifnot(all.equal(
+        c(TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE),
+        charClass(testCodepoints[["ASCII"]], "blank")))
+}
+{
+    stopifnot(all.equal(
+        c(FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, FALSE),
+        charClass(testCodepoints[["ASCII"]], "punct")))
+}
+{
+    stopifnot(all.equal(
+        c(FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE),
+        charClass(testCodepoints[["ASCII"]], "digit")))
+}
+{
+    stopifnot(all.equal(
+        c(FALSE, TRUE, TRUE, FALSE, FALSE, TRUE, TRUE, FALSE, TRUE),
+        charClass(testCodepoints[["ASCII"]], "alnum")))
+}
+
+# In principle, this can be locale dependent.
+# Ubuntu in C locale (without internal iswxxxxx) gives different results. 
+
+if (Sys.getlocale("LC_CTYPE") != "C") {
+
+    stopifnot(all.equal(
+        c(TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE),
+        charClass(testCodepoints[["Cyrillic"]], "alpha")))
+
+    stopifnot(all.equal(
+        c(TRUE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE),
+        charClass(testCodepoints[["Cyrillic"]], "upper")))
+
+    stopifnot(all.equal(
+        c(FALSE, TRUE, TRUE, TRUE, FALSE, FALSE, FALSE),
+        charClass(testCodepoints[["Cyrillic"]], "lower")))
+
+    stopifnot(all.equal(
+        c(FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE),
+        charClass(testCodepoints[["Cyrillic"]], "space")))
+
+    # Ubuntu & Windows 10 disagree about diacritacals
+    stopifnot(all(
+        charClass(testCodepoints[["Hebrew"]], "alpha")[-c(2,3,6)]))
+
+    # no cases in Hebrew alphabet
+    stopifnot(!any(charClass(testCodepoints[["Hebrew"]], "lower")))
+
+    # no cases in Hebrew alphabet
+    stopifnot(!any(charClass(testCodepoints[["Hebrew"]], "upper")))
+}

package/dist/vfs/usr/lib/R/library/utils/tests/completion.R

@@ -0,0 +1,37 @@
+
+## test some typical completion attempts
+
+testLine <- function(line, cursor = nchar(line))
+{
+    str(utils:::.win32consoleCompletion(line, cursor))
+}
+
+testLine("")
+
+testLine("lib")
+testLine("data(")
+testLine("data(US")
+testLine("data(US", 3)
+
+testLine("?INS")
+
+testLine("utils::data")
+testLine("utils:::.show_help_on_topic_")
+testLine("utils::.show_help_on_topic_")
+
+testLine("update(")
+
+testLine("version$m")
+testLine("nchar(version[")
+
+
+
+testLine("method?coe")
+testLine("?coe")
+testLine("?\"coerce,AN")
+testLine("method?\"coerce,AN")
+
+
+## testLine("")
+## testLine("")
+## testLine("")

package/dist/vfs/usr/lib/R/library/utils/tests/customgraphics.Rnw

@@ -0,0 +1,20 @@
+Test file for custom graphics devices
+<<results=hide>>=
+my.Swd <- function(name, width, height, ...) {
+  cat("running my.Swd\n")
+  grDevices::png(filename = paste(name, "png", sep = "."),
+                 width = width, height = height, res = 100, units = "in",
+                 bg = "transparent")
+}
+my.Swd.off <- function() {
+    cat("shutting down my.Swd\n")
+    grDevices::dev.off()
+}
+<<fig=TRUE, grdevice=my.Swd>>=
+plot(1:2)
+<<fig=TRUE, pdf=TRUE, grdevice=my.Swd>>=
+plot(1:3)
+<<fig=TRUE, grdevice=my.Swd, pdf=TRUE>>=
+plot(1:4)
+@
+Done!

package/dist/vfs/usr/lib/R/library/utils/tests/download.file.R

@@ -0,0 +1,170 @@
+
+## Tests for HTTP headers -----------------------------------------------
+
+is_online <- function() {
+  tryCatch({
+    con <- suppressWarnings(socketConnection("8.8.8.8", port = 53))
+    close(con)
+    con <- url("http://eu.httpbin.org/headers")
+    lines <- readLines(con)
+    close(con)
+    stopifnot(any(grepl("Host.*eu.httpbin.org", lines)))
+    TRUE
+  }, error = function(e) FALSE)
+}
+
+get_headers <- function(path = "anything", quiet = TRUE, ...,
+                        protocol = "http") {
+  url <- get_path(path, protocol)
+  tmp <-  tempfile()
+  on.exit(try(unlink(tmp)), add = TRUE)
+  download.file(url, tmp, quiet = quiet, ...)
+  readLines(tmp)
+}
+
+get_headers_url <- function(path = "anything", ..., protocol = "http") {
+  con <- url(get_path(path, protocol), ...)
+  on.exit(try(close(con)), add = TRUE)
+  readLines(con)
+}
+
+get_path <- function(path = "anything", protocol = "http") {
+  paste0(protocol, "://", "eu.httpbin.org/", path)
+}
+
+with_options <- function(opts, expr) {
+  old <- do.call(options, as.list(opts))
+  on.exit(options(old), add = TRUE)
+  expr
+}
+
+tests <- function() {
+  cat("- User agent is still set\n")
+  with_options(list(HTTPUserAgent = "foobar"), {
+    h <- get_headers()
+    stopifnot(any(grepl("User-Agent.*foobar", h)))
+  })
+
+  with_options(list(HTTPUserAgent = "foobar"), {
+    h <- get_headers(headers = c(foo = "bar", zzzz = "bee"))
+    stopifnot(any(grepl("User-Agent.*foobar", h)))
+    stopifnot(any(grepl("Foo.*bar", h)))
+    stopifnot(any(grepl("Zzzz.*bee", h)))
+  })
+
+  cat("- Can supply headers\n")
+  h <- get_headers(headers = c(foo = "bar", zzzz = "bee"))
+  stopifnot(any(grepl("Foo.*bar", h)))
+  stopifnot(any(grepl("Zzzz.*bee", h)))
+
+  cat("- Basic auth\n")
+  ret <- tryCatch({
+    h <- suppressWarnings(get_headers(
+      "basic-auth/Aladdin/OpenSesame",
+      headers = c(Authorization = "Basic QWxhZGRpbjpPcGVuU2VzYW1l")))
+    TRUE
+  }, error = function(e) FALSE)
+  stopifnot(any(grepl("authenticated.*true", h)))
+
+  if (getOption("download.file.method") == "libcurl") {
+    cat("- Multiple urls (libcurl only)\n")
+    urls <- get_path(c("anything", "headers"))
+    tmp1 <- tempfile()
+    tmp2 <- tempfile()
+    on.exit(unlink(c(tmp1, tmp2)), add = TRUE)
+    status <- download.file(urls, c(tmp1, tmp2), quiet = TRUE,
+                            headers = c(foo = "bar", zzzz = "bee"))
+    if (status == 0L) {
+        h1 <- readLines(tmp1)
+        h2 <- readLines(tmp2)
+        stopifnot(any(grepl("Foo.*bar", h1)))
+        stopifnot(any(grepl("Zzzz.*bee", h1)))
+        stopifnot(any(grepl("Foo.*bar", h2)))
+        stopifnot(any(grepl("Zzzz.*bee", h2)))
+    }
+  }
+
+  cat("- HTTPS\n")
+  h <- get_headers(headers = c(foo = "bar", zzzz = "bee"), protocol = "https")
+  stopifnot(any(grepl("Foo.*bar", h)))
+  stopifnot(any(grepl("Zzzz.*bee", h)))
+
+  cat("- If headers not named, then error\n")
+  ret <- tryCatch(
+    download.file(get_path(), headers = c("foo", "xxx" = "bar")),
+    error = function(err) TRUE)
+  stopifnot(isTRUE(ret))
+  ret <- tryCatch(
+    download.file(get_path(), headers = "foobar"),
+    error = function(err) TRUE)
+  stopifnot(isTRUE(ret))
+
+  cat("- If headers are NA, then error\n")
+  ret <- tryCatch(
+    download.file(get_path(), headers = c("foo" = NA, "xxx" = "bar")),
+    error = function(err) TRUE)
+  stopifnot(isTRUE(ret))
+  ret <- tryCatch(
+    download.file(
+      get_path(), quiet = TRUE,
+      headers = structure(c("foo", "bar", names = c("foo", NA)))),
+    error = function(err) TRUE)
+  stopifnot(isTRUE(ret))
+
+  cat("- user agent is set in url()\n")
+  with_options(list(HTTPUserAgent = "foobar"), {
+    h <- get_headers_url()
+    stopifnot(any(grepl("User-Agent.*foobar", h)))
+  })
+
+  cat("- file() still works with URLs\n")
+  con <- file(get_path("anything", "http"))
+  on.exit(close(con), add = TRUE)
+  h <- readLines(con)
+  stopifnot(any(grepl("Host.*eu.httpbin.org", h)))
+
+  cat("- If headers not named, then url() errors\n")
+  ret <- tryCatch(
+    url(get_path(), headers = c("foo", "xxx" = "bar")),
+    error = function(err) TRUE)
+  stopifnot(isTRUE(ret))
+
+  cat("- If headers are NA, then url() errors\n")
+  ret <- tryCatch(
+    url(get_path(), headers = c("foo" = "bar", "xxx" = NA)),
+    error = function(err) TRUE)
+  stopifnot(isTRUE(ret))
+  ret <- tryCatch(
+    url(get_path(),
+        headers = structure(c("1", "2"), names = c("foo", NA))),
+    error = function(err) TRUE)
+  stopifnot(isTRUE(ret))
+
+  cat("- Can supply headers in url()\n")
+  h <- get_headers_url(headers = c(foo = "bar", zzzz = "bee"))
+  stopifnot(any(grepl("Foo.*bar", h)))
+  stopifnot(any(grepl("Zzzz.*bee", h)))
+
+  cat("- HTTPS with url()\n")
+  h <- get_headers_url(headers = c(foo = "bar", zzzz = "bee"),
+                       protocol = "https")
+  stopifnot(any(grepl("Foo.*bar", h)))
+  stopifnot(any(grepl("Zzzz.*bee", h)))
+}
+
+main <- function() {
+    if (capabilities("libcurl")) {
+        cat("\nlibcurl method\n")
+        with_options(c(download.file.method = "libcurl"), tests())
+    }
+
+    if (.Platform$OS.type == "windows")  {
+        ## This is deprecated and will give warnings.
+        cat("\nwininet method\n")
+        with_options(c(download.file.method = "wininet"), tests())
+    }
+}
+
+options(warn = 1)
+
+if (is_online()) main()

package/dist/vfs/usr/lib/R/library/utils/tests/keepsource.Rnw

@@ -0,0 +1,12 @@
+\SweaveOpts{keep.source=TRUE}
+
+Now a chunk starting with a comment, lost in R 2.12.0 patched:
+<<ex>>=
+## This is an initial comment line. Let's hope it's not being lost
+"Above there's a comment."
+1:10 # a comment here is preserved
+pi   # also, there's one the next (last) line - which used to get lost
+## and a last comment here ... lost also in earlier R versions
+@
+
+and some more text.

package/dist/vfs/usr/lib/R/library/utils/tests/relist.R

@@ -0,0 +1,24 @@
+## PR#15854
+local({
+    ## This always worked
+    x <- as.relistable(list(integer(), 1:2, double(), 3))
+    vec <- unlist(x)
+    vec[[2]] <- 10
+    stopifnot(identical(relist(vec),
+                        as.relistable(list(double(), c(1, 10), double(), 3))))
+    ## Used to fail, Error .. The 'flesh' argument does not contain a skeleton attribute. ...
+    x <- as.relistable(list(integer(), 1:2, NULL, 3))
+    vec <- unlist(x)
+    vec[[2]] <- 10
+    stopifnot(identical(relist(vec),
+                        as.relistable(list(double(), c(1, 10), double(), 3))))
+    ## ditto in PR#..:
+    x <- list(NULL, a=1:3, b=5:7)
+    y <- unlist(as.relistable(x))
+    stopifnot(identical(relist(y),
+                        as.relistable(list(`names<-`(integer(),character()),
+                                           a=1:3, b=5:7))))
+    ## relist(y) gave Error ... :
+    ##   The 'flesh' argument does not contain a skeleton attribute.
+    ##   Either ensure you unlist a relistable object, or specify the skeleton separately.
+})