@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/tests/reg-translation.R

@@ -0,0 +1,125 @@
+#### Regression test of translation not working outside packages for R < 4.1.0.
+#### We try French (set in Makefile.common).
+
+### First off, message translation needs to be supported.
+if (!capabilities("NLS")) { ## e.g. when R was configured with --disable-nls
+    message("no natural language support")
+    q("no")
+}
+
+#### Report locale, LANG* and charset
+Sys.getlocale()
+Sys.getenv(c("LANGUAGE","LANG"))
+str(l10n_info())
+
+#### Skip locales that do not support French (especially C)
+OK <- l10n_info()[["UTF-8"]] || l10n_info()[["Latin-1"]]
+if (!OK) {
+    if(.Platform$OS.type == "windows") {
+        OK <- l10n_info()[["codepage"]] == 28605 ## Latin-9
+    } else {
+        z <- l10n_info()[["codeset"]]
+        ## macOS and Solaris have the first, Linux the second.
+        OK <- tolower(z) %in% c("iso8859-15", "iso-8859-15", "iso885915")
+    }
+}
+if( !OK ) {
+    message("The locale encoding is not known to support French")
+    q("no")
+}
+
+## Translation domain for a function not in a package: PR#17998
+tryCEmsg <- function(expr) tryCatch(expr, error   = conditionMessage)
+tryCWmsg <- function(expr) tryCatch(expr, warning = conditionMessage)
+chk0 <- function(x) stopifnot(x == 0)
+nsSt <- asNamespace("stats")
+(Sys.setLanguage("fr") -> oldLang) # print previous
+(m1 <- tryCEmsg(chk0(1))) # (not translated in R < 4.1.0)
+## switch back to English (if possible) for final report.
+Sys.setLanguage("en")
+m2 <- "x == 0 n'est pas TRUE"
+if(m1 != m2) stop("message was not translated to French")
+
+## More -- for PR#18902 (<--> PR#17998, part 2)
+enTxt <- "incompatible dimensions"
+deTxt <- "inkompatible Dimensionen"
+Sys.setLanguage("de")
+stopifnot(identical(deTxt, gettext(enTxt, domain="R-stats")))
+f <- function(...) stop(enTxt)
+environment(f) <- nsSt
+stopifnot(identical(deTxt, tryCEmsg(f()))) # failed in R <= 4.1.x
+## 2nd example (base vs stats):
+enTxt <- "namespace is already attached"
+deTxt <- "Namensraum ist bereits angehängt"
+Encoding(deTxt) <- "UTF-8" # e.g. on Windows where it was  "latin1"
+all.equal(gettext(enTxt, domain="R-stats"), enTxt)
+(trTxt <- gettext(enTxt, domain="R-base")); Encoding(trTxt) # unknown
+all.equal(trTxt, deTxt)
+f <- function(...) warning(enTxt)  # warning() returns the message
+environment(f) <- .BaseNamespaceEnv; trTxtB <- f(); (trTxtBt <- tryCWmsg(f()))
+environment(f) <- nsSt;              trTxtS <- f(); (trTxtSt <- tryCWmsg(f()))
+stopifnot(exprs = {
+    identical(trTxt, deTxt)
+    identical(gettext(enTxt, domain="R-stats"), enTxt)
+    identical({environment(f) <- .BaseNamespaceEnv; tryCWmsg(f())}, deTxt)
+    identical({environment(f) <- nsSt;              tryCWmsg(f())}, enTxt)# not in R <= 4.1.x
+    identical(trTxtB , trTxt)
+    identical(trTxtBt, trTxt) # (not in 4.0.5)
+    identical(trTxtS , enTxt) # (not in 4.1.x, but in 4.0.5)
+    identical(trTxtSt, enTxt) # (not in 4.1.x, but in 4.0.5)
+})# in all cases:  not present in stats  =>  not translated
+
+## gettextf
+chk <- function(tx) stopifnot(tx == sprintf("file '%s' not found", "/foo/bR"))
+f <- function() gettextf("file '%s' not found", "/foo/bR"); trTxt <- f()
+chk(trTxt) # failed in R 4.1.x
+trTxt <- gettextf("file '%s' not found", "/foo/bR"); chk(trTxt) # failed in R <= 4.1.x
+## gettext
+chk <- function(tx) stopifnot(tx == "file '%s' not found")
+     (trTxt <- gettext("file '%s' not found")); chk(trTxt) # failed in R 4.1.x
+print(trTxt <- gettext("file '%s' not found")); chk(trTxt) # failed in R <= 4.1.x
+
+
+## Functions not *from* package namespace, but "as if" (PR#17998, from Comment 35):
+enT <- "empty model supplied"
+(deT <- gettext(enT, domain="R-stats"))# "leeres Modell angegeben"
+isD <- function(tx) identical(deT, tx)
+stopifnot(exprs = {
+    ## 1-4: translated in R 4.0.z *and* 4.1.z
+    isD(evalq(function() gettext(enT), nsSt)())
+    isD(evalq(function() do.call(gettext, list(enT)), nsSt)())
+    isD(evalq(function() evalq(gettext(enT)), nsSt)())
+    isD(evalq(function() local(gettext(enT)), nsSt)())
+    ## 5-7: not translated in R 4.0.*; translated in R 4.1.* (incl. R-patched)
+    ##      ditto in R-devel *after* the Oct.20 (2021) patch:
+    isD(evalq(local(gettext(enT)), nsSt))
+    isD(evalq(gettext(enT), nsSt))
+    isD(do.call("gettext", list(enT), envir=nsSt))
+    ## 8-11: in comment #37, Suharto added  " Other cases: "
+    isD(evalq(function() (function() gettext(enT))(), nsSt)())
+    isD(evalq(function() function() gettext(enT), nsSt)()())
+    isD(evalq((function() function() gettext(enT))(), nsSt)())
+    isD(evalq(local(function() gettext(enT)), nsSt)())
+    require(compiler) ## and more cases with byte compiler consideration
+    isD(cmpfun(evalq(function() gettext(enT), nsSt))())
+    isD(cmpfun(evalq(function() do.call("gettext", list(enT)), nsSt))())
+    isD(cmpfun(evalq(function() evalq(gettext(enT)), nsSt))())
+    isD(cmpfun(evalq(function() local(gettext(enT)), nsSt))())
+    isD(eval(compile(quote(local(gettext(enT)))), nsSt))
+    isD(eval(compile(quote(gettext(enT))), nsSt))
+})
+
+## Getting messages with trailing \n : either via ngettext() or w/ new trim=FALSE:
+txtE <- "Execution halted\n"
+Sys.setLanguage("fr")
+(n <- ngettext(1, txtE, "", domain="R"))
+(t. <- gettext(txtE, domain="R"))# default: translation *not* found
+t.T <- gettext(txtE, domain="R", trim=TRUE)# == default
+t.F <- gettext(txtE, domain="R", trim=FALSE)
+cbind(t.F, n, t.T)
+stopifnot(exprs = {
+    identical(t. , txtE)
+    identical(t.T, txtE)
+    identical(t.F, n)
+    t.F != t.T
+})

package/dist/vfs/usr/lib/R/tests/simple-true.R

@@ -0,0 +1,190 @@
+###---- ALL tests here should return  TRUE !
+###
+###---- "Real" Arithmetic; Numerics etc  -->  ./arith-true.R
+
+### mode checking, etc.
+is.recursive(expression(1+3, 2/sqrt(pi)))# fix PR#9
+
+## sum():
+all(1:12 == cumsum(rep(1,12)))
+x <- rnorm(127); sx <- sum(x);	abs((sum(rev(x)) -sx)) < 1e-12 * abs(sx)
+
+## seq():
+typeof(1:4) == "integer" #-- fails for 0.2, 0.3,.., 0.9
+
+## Check parsing with L suffix for integer literals.
+typeof(1L) == "integer"
+typeof(1000L) == "integer"
+typeof(1e3L) == "integer"
+typeof(1e-3L) == "double" # gives warning
+1.L # gives warning
+inherits(try(parse(text = "12iL"), silent=TRUE), "try-error") # gives syntax error
+
+
+all((0:6) == pi + ((-pi):pi))
+all((0:7) == (pi+seq(-pi,pi, length=8))*7/(2*pi))
+
+1 == as.integer(is.na(c(pi,NA)[2]))
+1 == as.integer(is.nan(0/0))
+
+## rev():
+cc <- c(1:10,10:1) ;		all(cc == rev(cc))
+
+## dim[names]():
+all(names(c(a=pi, b=1, d=1:4)) == c("a","b", paste("d", 1:4, sep="")))
+##P names(c(a=pi, b=1, d=1:4))
+ncb <- dimnames(cbind(a=1, yy=1:3))[[2]]
+(!is.null(ncb)) && all(ncb == c("a","yy"))
+
+all(cbind(a=1:2, b=1:3, c=1:6) == t(rbind(a=1:2, b=1:3, c=1:6)))
+##P rbind(a=1:2, b=1:3, c=1:6)
+all(dim(cbind(cbind(I=1,x=1:4), c(a=pi))) == 4:3)# fails in S+
+
+a <- b <- 1:3
+all(dimnames(cbind(a, b))[[2]] == c("a","b"))
+
+## rbind PR#338
+all(dim(m <- rbind(1:2, diag(2))) == 3:2)
+all(m == c(1,1,0, 2,0,1))
+
+## factor():
+is.factor(factor(integer()))
+all(levels(ordered(rev(gl(3,4)))) == 1:3)# coercion to char
+all(levels(factor(factor(9:1)[3:5])) == 5:7)
+## crossing bug PR#40
+is.factor(ff <- gl(2,3) : gl(3,2)) && length(ff) == 6
+all(levels(ff) == t(outer(1:2, 1:3, paste, sep=":")))
+## from PR#5
+ll <- c("A","B"); ff <- factor(ll); f0 <- ff[, drop=TRUE]
+all(f0 == ff) && all(levels(ff) == ll) && is.factor(ff) && is.factor(f0)
+
+### data.frame s :
+
+## from lists [bug PR#100]
+x <- NULL
+x$x1 <- 1:10
+x$x2 <- 0:9
+all(dim(dx <- as.data.frame(x)) == c(10,2))
+
+## Logicals: (S is wrong)
+l1 <- c(TRUE,FALSE,TRUE)
+(! as.logical(as.data.frame(FALSE)[,1]))
+all(l1 == as.logical(as.data.frame(l1)[,1]))
+
+## empty data.frames :
+x <- data.frame(a=1:3)
+x30 <- {
+    if(is.R()) x[, -1]# not even possible in S+
+    else structure(list(), row.names = paste(1:3), class = "data.frame")
+}
+all(dim(x30) == c(3,0))
+x01 <- x[-(1:3), , drop = FALSE]
+x00 <- x01[,-1]
+all(dim(x01) == 0:1)
+all(dim(x00) == 0)
+all(dim(x) == dim(rbind(x, x01)))
+## bugs up to 1.2.3 :
+all(dim(x30) == dim(m30 <- as.matrix(x30)))
+all(dim(x01) == dim(m01 <- as.matrix(x01)))
+all(dim(x30) == dim(as.data.frame(m30)))
+all(dim(x01) == dim(as.data.frame(m01)))
+all(dim(x01) == dim(   data.frame(m01)))
+all(dim(x30) == dim(   data.frame(m30)))
+all(dim(x)   == dim(cbind(x, x30)))
+## up to 1.4.0 :
+all(dim(x30) == dim( data.matrix(x30)))
+all(dim(x00) == dim( data.matrix(x00)))
+
+m0 <- matrix(pi, 0,3)
+a302 <- array("", dim=c(3,0,2))
+identical(apply(m0, 1, dim), NULL)
+identical(apply(m0, 2, dim), NULL)
+identical(apply(m0, 1,length),  integer(0))
+identical(apply(m0, 2,length),  integer(3))
+identical(apply(a302, 1, mode), rep("character",3))
+## NO (maybe later?):
+## identical(apply(a302, 2, mode), rep("character",0))
+is.character(aa <- apply(a302, 2, mode)) && length(aa) == 0
+identical(apply(a302, 3, mode), rep("character",2))
+identical(apply(a302, 3, length),integer(2))
+identical(apply(a302, 3, dim), matrix(as.integer(c(3,0)), 2 ,2))
+identical(apply(a302, 1, dim), matrix(as.integer(c(0,2)), 2 ,3))
+identical(apply(array(dim=3), 1,length), rep(1:1, 3))
+identical(apply(array(dim=0), 1,length), rep(1:1, 0))# = integer(0)
+
+
+### Subsetting
+
+## bug PR#425
+x <- matrix(1:4, 2, 2, dimnames=list(c("abc","ab"), c("cde","cd")))
+y <- as.data.frame(x)
+all(x["ab",] == c(2,4))
+all(y["ab",] == c(2,4))
+
+## from bug PR#447
+x <- 1:2 ; x[c("2","2")] <- 4
+all.equal(x, c(1:2, "2" = 4))
+
+## stretching
+l2 <- list(a=1, b=2)
+l2["cc"] <- pi
+l2[["d"]] <- 4
+l2 $ e <- 55
+all.equal(l2, list(a = 1, b = 2, cc = pi, d = 4, e = 55), tolerance = 0)
+all.equal(l2["d"], list(d = 4))
+l2$d == 4 && l2$d == l2[["d"]]
+
+## bug in R <= 1.1
+f1 <- y1 ~ x1
+f2 <- y2 ~ x2
+f2[2] <- f1[2]
+deparse(f2) == "y1 ~ x2"
+
+m <- cbind(a=1:2,b=c(R=10,S=11))
+all(sapply(dimnames(m), length) == c(2,2))
+## [[ for matrix:
+m[[1,2]] == m[[3]] && m[[3]] == m[3] && m[3] == m[1,2]
+
+## bug in R <= 1.1.1 : unclass(*) didn't drop the class!
+## to be robust to S4 methods DON'T test for null class
+## The test for attr(,"class") is valid, if essentially useless
+d1 <- rbind(data.frame(a=1, b = I(TRUE)), new = c(7, "N"))
+is.null(attr(unclass(d1$b), "class"))
+
+## bugs in R 1.2.0
+format(as.POSIXct(relR120 <- "2000-12-15 11:24:40")) == relR120
+format(as.POSIXct(substr(relR120,1,10))) == substr(relR120,1,10)
+
+## rank() with NAs (and ties)
+x <- c(3:1,6,4,3,NA,5,0,NA)
+rx <-  rank(x)
+all(rx == c(4.5, 3:2, 8, 6, 4.5, 9, 7, 1, 10))
+rxK <- rank(x, na.last = "keep")
+all(rx [rx <= 8]    == na.omit(rxK))
+all(rank(x, na.last = NA) == na.omit(rxK))
+
+## as.list.function() instead of *.default():
+identical(as.list(as.list),
+	  alist(x = , ... = , UseMethod("as.list")))
+
+## startsWith() / endsWith()  assertions
+t1 <- c("Foobar", "bla bla", "something", "another", "blu", "brown",
+        "blau blüht der Enzian")# non-ASCII
+t2 <- c("some text", "any text")
+t3 <- c("Martin", "Zürich", "Mächler")
+
+all(endsWith(t1, "")); all(startsWith(t1, ""))
+all(endsWith(t2, "")); all(startsWith(t2, ""))
+all(endsWith(t3, "")); all(startsWith(t3, ""))
+all(endsWith(t2, "text"))
+all(endsWith(t2, " text"))
+identical(startsWith(t1, "b" ), c(FALSE, TRUE, FALSE, FALSE, TRUE,  TRUE, TRUE))
+identical(startsWith(t1, "bl"), c(FALSE, TRUE, FALSE, FALSE, TRUE, FALSE, TRUE))
+identical(startsWith(t1, "bla"),c(FALSE, TRUE, FALSE, FALSE,FALSE, FALSE, TRUE))
+identical(  endsWith(t1, "n"),  c(FALSE,FALSE, FALSE, FALSE,FALSE,  TRUE, TRUE))
+identical(  endsWith(t1, "an"), c(FALSE,FALSE, FALSE, FALSE,FALSE, FALSE, TRUE))
+##
+identical(startsWith(t3, "M" ), c( TRUE, FALSE, TRUE))
+identical(startsWith(t3, "Ma"), c( TRUE, FALSE, FALSE))
+identical(startsWith(t3, "Mä"), c(FALSE, FALSE, TRUE))
+

package/dist/vfs/usr/lib/R/tests/simple-true.Rout.save

@@ -0,0 +1,300 @@
+
+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.
+
+> ###---- ALL tests here should return  TRUE !
+> ###
+> ###---- "Real" Arithmetic; Numerics etc  -->  ./arith-true.R
+> 
+> ### mode checking, etc.
+> is.recursive(expression(1+3, 2/sqrt(pi)))# fix PR#9
+[1] TRUE
+> 
+> ## sum():
+> all(1:12 == cumsum(rep(1,12)))
+[1] TRUE
+> x <- rnorm(127); sx <- sum(x);	abs((sum(rev(x)) -sx)) < 1e-12 * abs(sx)
+[1] TRUE
+> 
+> ## seq():
+> typeof(1:4) == "integer" #-- fails for 0.2, 0.3,.., 0.9
+[1] TRUE
+> 
+> ## Check parsing with L suffix for integer literals.
+> typeof(1L) == "integer"
+[1] TRUE
+> typeof(1000L) == "integer"
+[1] TRUE
+> typeof(1e3L) == "integer"
+[1] TRUE
+> typeof(1e-3L) == "double" # gives warning
+[1] TRUE
+Warning message:
+non-integer value 1e-3L qualified with L; using numeric value 
+> 1.L # gives warning
+[1] 1
+Warning message:
+integer literal 1.L contains unnecessary decimal point 
+> inherits(try(parse(text = "12iL"), silent=TRUE), "try-error") # gives syntax error
+[1] TRUE
+> 
+> 
+> all((0:6) == pi + ((-pi):pi))
+[1] TRUE
+> all((0:7) == (pi+seq(-pi,pi, length=8))*7/(2*pi))
+[1] TRUE
+> 
+> 1 == as.integer(is.na(c(pi,NA)[2]))
+[1] TRUE
+> 1 == as.integer(is.nan(0/0))
+[1] TRUE
+> 
+> ## rev():
+> cc <- c(1:10,10:1) ;		all(cc == rev(cc))
+[1] TRUE
+> 
+> ## dim[names]():
+> all(names(c(a=pi, b=1, d=1:4)) == c("a","b", paste("d", 1:4, sep="")))
+[1] TRUE
+> ##P names(c(a=pi, b=1, d=1:4))
+> ncb <- dimnames(cbind(a=1, yy=1:3))[[2]]
+> (!is.null(ncb)) && all(ncb == c("a","yy"))
+[1] TRUE
+> 
+> all(cbind(a=1:2, b=1:3, c=1:6) == t(rbind(a=1:2, b=1:3, c=1:6)))
+[1] TRUE
+> ##P rbind(a=1:2, b=1:3, c=1:6)
+> all(dim(cbind(cbind(I=1,x=1:4), c(a=pi))) == 4:3)# fails in S+
+[1] TRUE
+> 
+> a <- b <- 1:3
+> all(dimnames(cbind(a, b))[[2]] == c("a","b"))
+[1] TRUE
+> 
+> ## rbind PR#338
+> all(dim(m <- rbind(1:2, diag(2))) == 3:2)
+[1] TRUE
+> all(m == c(1,1,0, 2,0,1))
+[1] TRUE
+> 
+> ## factor():
+> is.factor(factor(integer()))
+[1] TRUE
+> all(levels(ordered(rev(gl(3,4)))) == 1:3)# coercion to char
+[1] TRUE
+> all(levels(factor(factor(9:1)[3:5])) == 5:7)
+[1] TRUE
+> ## crossing bug PR#40
+> is.factor(ff <- gl(2,3) : gl(3,2)) && length(ff) == 6
+[1] TRUE
+> all(levels(ff) == t(outer(1:2, 1:3, paste, sep=":")))
+[1] TRUE
+> ## from PR#5
+> ll <- c("A","B"); ff <- factor(ll); f0 <- ff[, drop=TRUE]
+> all(f0 == ff) && all(levels(ff) == ll) && is.factor(ff) && is.factor(f0)
+[1] TRUE
+> 
+> ### data.frame s :
+> 
+> ## from lists [bug PR#100]
+> x <- NULL
+> x$x1 <- 1:10
+> x$x2 <- 0:9
+> all(dim(dx <- as.data.frame(x)) == c(10,2))
+[1] TRUE
+> 
+> ## Logicals: (S is wrong)
+> l1 <- c(TRUE,FALSE,TRUE)
+> (! as.logical(as.data.frame(FALSE)[,1]))
+[1] TRUE
+> all(l1 == as.logical(as.data.frame(l1)[,1]))
+[1] TRUE
+> 
+> ## empty data.frames :
+> x <- data.frame(a=1:3)
+> x30 <- {
++     if(is.R()) x[, -1]# not even possible in S+
++     else structure(list(), row.names = paste(1:3), class = "data.frame")
++ }
+> all(dim(x30) == c(3,0))
+[1] TRUE
+> x01 <- x[-(1:3), , drop = FALSE]
+> x00 <- x01[,-1]
+> all(dim(x01) == 0:1)
+[1] TRUE
+> all(dim(x00) == 0)
+[1] TRUE
+> all(dim(x) == dim(rbind(x, x01)))
+[1] TRUE
+> ## bugs up to 1.2.3 :
+> all(dim(x30) == dim(m30 <- as.matrix(x30)))
+[1] TRUE
+> all(dim(x01) == dim(m01 <- as.matrix(x01)))
+[1] TRUE
+> all(dim(x30) == dim(as.data.frame(m30)))
+[1] TRUE
+> all(dim(x01) == dim(as.data.frame(m01)))
+[1] TRUE
+> all(dim(x01) == dim(   data.frame(m01)))
+[1] TRUE
+> all(dim(x30) == dim(   data.frame(m30)))
+[1] TRUE
+> all(dim(x)   == dim(cbind(x, x30)))
+[1] TRUE
+> ## up to 1.4.0 :
+> all(dim(x30) == dim( data.matrix(x30)))
+[1] TRUE
+> all(dim(x00) == dim( data.matrix(x00)))
+[1] TRUE
+> 
+> m0 <- matrix(pi, 0,3)
+> a302 <- array("", dim=c(3,0,2))
+> identical(apply(m0, 1, dim), NULL)
+[1] TRUE
+> identical(apply(m0, 2, dim), NULL)
+[1] TRUE
+> identical(apply(m0, 1,length),  integer(0))
+[1] TRUE
+> identical(apply(m0, 2,length),  integer(3))
+[1] TRUE
+> identical(apply(a302, 1, mode), rep("character",3))
+[1] TRUE
+> ## NO (maybe later?):
+> ## identical(apply(a302, 2, mode), rep("character",0))
+> is.character(aa <- apply(a302, 2, mode)) && length(aa) == 0
+[1] TRUE
+> identical(apply(a302, 3, mode), rep("character",2))
+[1] TRUE
+> identical(apply(a302, 3, length),integer(2))
+[1] TRUE
+> identical(apply(a302, 3, dim), matrix(as.integer(c(3,0)), 2 ,2))
+[1] TRUE
+> identical(apply(a302, 1, dim), matrix(as.integer(c(0,2)), 2 ,3))
+[1] TRUE
+> identical(apply(array(dim=3), 1,length), rep(1:1, 3))
+[1] TRUE
+> identical(apply(array(dim=0), 1,length), rep(1:1, 0))# = integer(0)
+[1] TRUE
+> 
+> 
+> ### Subsetting
+> 
+> ## bug PR#425
+> x <- matrix(1:4, 2, 2, dimnames=list(c("abc","ab"), c("cde","cd")))
+> y <- as.data.frame(x)
+> all(x["ab",] == c(2,4))
+[1] TRUE
+> all(y["ab",] == c(2,4))
+[1] TRUE
+> 
+> ## from bug PR#447
+> x <- 1:2 ; x[c("2","2")] <- 4
+> all.equal(x, c(1:2, "2" = 4))
+[1] TRUE
+> 
+> ## stretching
+> l2 <- list(a=1, b=2)
+> l2["cc"] <- pi
+> l2[["d"]] <- 4
+> l2 $ e <- 55
+> all.equal(l2, list(a = 1, b = 2, cc = pi, d = 4, e = 55), tolerance = 0)
+[1] TRUE
+> all.equal(l2["d"], list(d = 4))
+[1] TRUE
+> l2$d == 4 && l2$d == l2[["d"]]
+[1] TRUE
+> 
+> ## bug in R <= 1.1
+> f1 <- y1 ~ x1
+> f2 <- y2 ~ x2
+> f2[2] <- f1[2]
+> deparse(f2) == "y1 ~ x2"
+[1] TRUE
+> 
+> m <- cbind(a=1:2,b=c(R=10,S=11))
+> all(sapply(dimnames(m), length) == c(2,2))
+[1] TRUE
+> ## [[ for matrix:
+> m[[1,2]] == m[[3]] && m[[3]] == m[3] && m[3] == m[1,2]
+[1] TRUE
+> 
+> ## bug in R <= 1.1.1 : unclass(*) didn't drop the class!
+> ## to be robust to S4 methods DON'T test for null class
+> ## The test for attr(,"class") is valid, if essentially useless
+> d1 <- rbind(data.frame(a=1, b = I(TRUE)), new = c(7, "N"))
+> is.null(attr(unclass(d1$b), "class"))
+[1] TRUE
+> 
+> ## bugs in R 1.2.0
+> format(as.POSIXct(relR120 <- "2000-12-15 11:24:40")) == relR120
+[1] TRUE
+> format(as.POSIXct(substr(relR120,1,10))) == substr(relR120,1,10)
+[1] TRUE
+> 
+> ## rank() with NAs (and ties)
+> x <- c(3:1,6,4,3,NA,5,0,NA)
+> rx <-  rank(x)
+> all(rx == c(4.5, 3:2, 8, 6, 4.5, 9, 7, 1, 10))
+[1] TRUE
+> rxK <- rank(x, na.last = "keep")
+> all(rx [rx <= 8]    == na.omit(rxK))
+[1] TRUE
+> all(rank(x, na.last = NA) == na.omit(rxK))
+[1] TRUE
+> 
+> ## as.list.function() instead of *.default():
+> identical(as.list(as.list),
++ 	  alist(x = , ... = , UseMethod("as.list")))
+[1] TRUE
+> 
+> ## startsWith() / endsWith()  assertions
+> t1 <- c("Foobar", "bla bla", "something", "another", "blu", "brown",
++         "blau blüht der Enzian")# non-ASCII
+> t2 <- c("some text", "any text")
+> t3 <- c("Martin", "Zürich", "Mächler")
+> 
+> all(endsWith(t1, "")); all(startsWith(t1, ""))
+[1] TRUE
+[1] TRUE
+> all(endsWith(t2, "")); all(startsWith(t2, ""))
+[1] TRUE
+[1] TRUE
+> all(endsWith(t3, "")); all(startsWith(t3, ""))
+[1] TRUE
+[1] TRUE
+> all(endsWith(t2, "text"))
+[1] TRUE
+> all(endsWith(t2, " text"))
+[1] TRUE
+> identical(startsWith(t1, "b" ), c(FALSE, TRUE, FALSE, FALSE, TRUE,  TRUE, TRUE))
+[1] TRUE
+> identical(startsWith(t1, "bl"), c(FALSE, TRUE, FALSE, FALSE, TRUE, FALSE, TRUE))
+[1] TRUE
+> identical(startsWith(t1, "bla"),c(FALSE, TRUE, FALSE, FALSE,FALSE, FALSE, TRUE))
+[1] TRUE
+> identical(  endsWith(t1, "n"),  c(FALSE,FALSE, FALSE, FALSE,FALSE,  TRUE, TRUE))
+[1] TRUE
+> identical(  endsWith(t1, "an"), c(FALSE,FALSE, FALSE, FALSE,FALSE, FALSE, TRUE))
+[1] TRUE
+> ##
+> identical(startsWith(t3, "M" ), c( TRUE, FALSE, TRUE))
+[1] TRUE
+> identical(startsWith(t3, "Ma"), c( TRUE, FALSE, FALSE))
+[1] TRUE
+> identical(startsWith(t3, "Mä"), c(FALSE, FALSE, TRUE))
+[1] TRUE
+> 
+> 

package/dist/vfs/usr/lib/R/tests/structure.R

@@ -0,0 +1,48 @@
+### Tests of structure() and deparsing.
+
+## deparsing has always treated some attributes specially (apparently
+## to allow inter-operability with S).
+## The mapping is
+## as printed: "dim", "dimnames", "names", "tsp", "levels"
+## deparsed: ".Dim", ".Dimnames", ".Names", ".Tsp", ".Label"
+## structure() remaps to the printed form.
+
+## The remapping in deparse will be removed in R 4.2.0.
+
+X <- matrix(1:4, 2, 2, dimnames=list(c("A", "B"), 1:2))
+names(attributes(X))
+cat(deparse(X), "\n")
+Y <- structure(1:4, .Dim = c(2L, 2L),
+               .Dimnames = list(c("A", "B"), c("1", "2")))
+identical(X, Y)
+
+z <- ts(1:10, frequency = 4, start = c(1959, 2))
+attributes(z)
+cat(deparse(z), "\n")
+z2 <- structure(1:10, .Tsp = c(1959.25, 1961.5, 4), class = "ts")
+identical(z, z2)
+
+## levels <-> .Label is most relevant to factors, but is always remapped.
+x <- 1:3
+attr(x, "levels") <- letters[x]
+cat(deparse(x), "\n")
+y <- structure(1:3, .Label = c("a", "b", "c"))
+identical(x, y)
+
+
+## Factors were long deparsed with double (rather than integer codes).
+## As from R 2.5.0 parsing such a deparse will given an error, so
+## structure() coerces the codes to an integer vector.
+## Example from an earlier version of Puromycin.R
+state <- structure(c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+                     2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2),
+                   .Label = c("treated", "untreated"), class = "factor")
+typeof(state)
+storage.mode(state)
+attributes(state)
+cat(deparse(state))
+
+state2 <- structure(c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
+                      2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L),
+                    levels = c("treated", "untreated"), class = "factor")
+identical(state,state2)