@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/tests/print-tests.R

@@ -0,0 +1,343 @@
+#### Testing print(), format()	and the like --- mainly with numeric()
+####
+#### to be run as
+####
+####	R < print-tests.R  >&  print-tests.out-__version__
+####			   == (csh)
+opt.conformance <- 0
+
+DIG <- function(d)
+    if(missing(d)) getOption("digits") else options(digits=as.integer(d))
+
+DIG(7)#-- the default; just to make sure ...
+options(width = 200)
+
+n1 <- 2^(4*1:7)
+i1 <- as.integer(n1)
+
+v1 <- 2^c(-12, 2*(-4:-2),3,6,9)
+v2 <- v1^(63/64)
+## avoid ending in `5' as printing then depends on rounding of
+## the run-time (and not all round to even).
+v1[1:4] <-c(2.44140624e-04, 3.90624e-03, 1.5624e-02, 6.24e-02)
+
+
+v3 <- pi*100^(-1:3)
+v4 <- (0:2)/1000 + 1e-10 #-- tougher one
+
+digs1 <- c(1,2*(1:5),11:15)		# 16: platform dependent
+					# 30 gives ERROR : options(digits=30)
+digs2 <- c(1:20)#,30) gives 'error' in R: ``print.default(): invalid digits..''
+
+all(i1 == n1)# TRUE
+i1# prints nicely
+n1# did not; does now (same as 'i1')
+
+round (v3, 3)#S+ & R 0.49:
+##[1]	0.031	    3.142     314.159	 31415.927 3141592.654
+signif(v3, 3)
+##R.49: [1] 0.0314	3.1400	   314.0000   31400.0000 3140000.0000
+##S+	[1] 3.14e-02 3.14e+00 3.14e+02 3.14e+04 3.14e+06
+
+###----------------------------------------------------------------
+##- Date: Tue, 20 May 97 17:11:18 +0200
+
+##- From: Martin Maechler <maechler@stat.math.ethz.ch>
+##- To: R-devel@stat.math.ethz.ch
+##- Subject: R-alpha: print 'problems': print(2^30, digits=12); comments at start of function()
+##-
+##- Both of these bugs are not a real harm,
+##- however, they have been annoying me for too long ... ;-)
+##-
+##- 1)
+print  (2^30, digits = 12) #-  WAS exponential form, unnecessarily -- now ok
+formatC(2^30, digits = 12) #- shows you what you'd want above
+
+## S and R are now the same here;  note that the problem also affects
+##	paste(.)  & format(.) :
+
+DIG(10); paste(n1); DIG(7)
+
+
+## Assignment to .Options$digits: Does NOT work for  print() nor cat()
+for(i in digs1) { .Options$digits <- i; cat(i,":"); print (v1[-1]) }
+
+## using options()  *does* things
+for(i in digs1) { DIG(i); cat(i,":"); print (v3) }
+for(i in digs1) { DIG(i); cat(i,":", formatC(v3, digits=i, width=8),"\n") }
+
+
+## R-0.50: switches to NON-exp at 14, but should only at 15...
+## R-0.61++: doesn' switch at all (or at 20 only)
+## S-plus: does not switch at all..
+for(i in digs1) { cat(i,":");  print(v1, digits=i) }
+
+## R 0.50-a1: switches at 10 inst. 11
+for(i in digs1) { cat(i,":");  print(v1[-1], digits=i) }
+
+for(i in digs1) { DIG(i); cat(i,":", formatC(v2, digits=i, width=8),"\n") }
+
+for(i in digs1) { cat(i,":");  print(v2, digits=i) } #-- exponential all thru
+##	 ^^^^^ digs2 (>= 18: PLATFORM dependent !!
+for(i in digs1) { cat(i,":", formatC(v2, digits=i, width=8),"\n") }
+
+DIG(7)#-- the default; just to make sure ...
+
+N1 <- 10; N2 <- 7; n <- 8
+x <- 0:N1
+Mhyp <- rbind(phyper(x, N1, N2, n), dhyper(x, N1, N2, n))
+Mhyp
+##-	 [,1]	      [,2]	 [,3]	  [,4]	    [,5]      [,6]	[,7]
+##- [1,]    0 0.0004113534 0.01336898 0.117030 0.4193747 0.7821884 0.9635952
+##- [2,]    0 0.0004113534 0.01295763 0.103661 0.3023447 0.3628137 0.1814068
+##-	       [,8]	  [,9] [,10] [,11]
+##- [1,] 0.99814891 1.00000000	   1	 1
+##- [2,] 0.03455368 0.00185109	   0	 0
+
+m11 <- c(-1,1)
+Mm <- pi*outer(m11, 10^(-5:5))
+Mm <- cbind(Mm, outer(m11, 10^-(5:1)))
+Mm
+do.p <- TRUE
+do.p <- FALSE
+for(di in 1:10) {
+    options(digits=di)
+    cat(if(do.p)"\n",formatC(di,w=2),":", format.info(Mm),"\n")
+    if(do.p)print(Mm)
+}
+##-- R-0.49 (4/1997)	 R-0.50-a1 (7.7.97)
+##-  1 : 13 5 0		 1 :  6 0 1
+##-  2 :  8 1 1	=	 2 :  8 1 1
+##-  3 :  9 2 1	=	 3 :  9 2 1
+##-  4 : 10 3 1	=	 4 : 10 3 1
+##-  5 : 11 4 1	=	 5 : 11 4 1
+##-  6 : 12 5 1	=	 6 : 12 5 1
+##-  7 : 13 6 1	=	 7 : 13 6 1
+##-  8 : 14 7 1	=	 8 : 14 7 1
+##-  9 : 15 8 1	=	 9 : 15 8 1
+##- 10 : 16 9 1	=	10 : 16 9 1
+nonFin <- list(c(Inf,-Inf), c(NaN,NA), NA_real_, Inf)
+mm <- sapply(nonFin, format.info)
+fm <- lapply(nonFin, format)
+w <- c(4,3,2,3)
+stopifnot(sapply(lapply(fm, nchar), max) == w,
+	  mm == rbind(w, 0, 0))# m[2,] was 2147483647; m[3,] was 1
+cnF <- c(lapply(nonFin, function(x) complex(re=x, im=x))[-3],
+         complex(re=NaN, im=-Inf))
+cmm <- sapply(cnF, format.info)
+cfm <- lapply(cnF, format)
+cw <- sapply(lapply(cfm, nchar), max)
+stopifnot(cw == cmm[1,]+1 +cmm[4,]+1,
+	  nchar(format(c(NA, 1 + 2i))) == 4)# wrongly was (5,4)
+
+
+##-- Ok now, everywhere
+for(d in 1:9) {cat(d,":"); print(v4, digits=d) }
+DIG(7)
+
+
+###------------ Very big and very small
+umach <- unlist(.Machine)[paste("double.x", c("min","max"), sep='')]
+xmin <- umach[1]
+xmax <- umach[2]
+tx <- unique(c(outer(-1:1,c(.1,1e-3,1e-7))))# 7 values  (out of 9)
+tx <- unique(sort(c(outer(umach,1+tx))))# 11 values (+ 1 Inf)
+length(tx <- tx[is.finite(tx)]) # 11
+(txp <- tx[tx >= 1])#-- Positive exponent -- 4 values
+(txn <- tx[tx <	 1])#-- Negative exponent -- 7 values
+
+x2 <- c(0.099999994, 0.2)
+x2 # digits=7: show all seven "9"s
+print(x2, digits=6) # 0.1 0.2 , not 0.10 0.20
+v <- 6:8; names(v) <- v; sapply(v, format.info, x=x2)
+
+(z <- sort(c(outer(range(txn), 8^c(0,2:3)))))
+outer(z, 0:6, signif) # had NaN's till 1.1.1
+
+olddig <- options(digits=14) # RH6.0 fails at 15
+z <- 1.234567891234567e27
+for(dig in 1:14) cat(formatC(dig,w=2),
+                     format(z, digits=dig), signif(z, digits=dig), "\n")
+options(olddig)
+# The following are tests of printf inside formatC
+##------ Use  Emacs screen width 134 ;	Courier 12 ----
+# cat("dig|  formatC(txp, d=dig)\n")
+# for(dig in 1:17)# about >= 18 is platform dependent [libc's printf()..].
+#     cat(formatC(dig,w=2), formatC(txp,		      dig=dig, wid=-29),"\n")
+# cat("signif() behavior\n~~~~~~~~\n",
+#     "dig|  formatC(signif(txp, dig=dig), dig = dig\n")
+# for(dig in 1:15)#
+#     cat(formatC(dig,w=2), formatC(signif(txp, d=dig), dig=dig, wid=-26),"\n")
+
+# if(opt.conformance >= 1) {
+#     noquote(cbind(formatC(txp, dig = 22)))
+# }
+
+# cat("dig|  formatC(signif(txn, d = dig), dig=dig\n")
+# for(dig in 1:15)#
+#     cat(formatC(dig,w=2), formatC(signif(txn, d=dig), dig=dig, wid=-20),"\n")
+
+# ##-- Testing  'print' / digits :
+# for(dig in 1:13) { ## 12:13: libc-2.0.7 diff; 14:18 --- PLATFORM-dependent !!!
+#     cat("dig=",formatC(dig,w=2),": "); print(signif(txp, d=dig),dig=dig+1)
+# }
+
+##-- Wrong alignment when printing character matrices with  quote = FALSE
+m1 <- matrix(letters[1:24],6,4)
+m1
+noquote(m1)
+
+##--- Complex matrices and named vectors :
+
+x0 <- x <- c(1+1i, 1.2 + 10i)
+names(x) <- c("a","b")
+x
+(xx <-	rbind(x,  2*x))
+	rbind(x0, 2*x0)
+x[4:6] <- c(Inf,Inf*c(-1,1i))
+x  + pi
+matrix(x + pi, 2)
+matrix(x + 1i*pi, 3)
+xx + pi
+t(cbind(xx, xx+ 1i*c(1,pi)))
+
+#--- format checks after incorrect changes in Nov 2000
+zz <- data.frame("(row names)" = c("aaaaa", "b"), check.names = FALSE)
+format(zz)
+format(zz, justify = "left")
+zz <- data.frame(a = I("abc"), b = I("def\"gh"))
+format(zz)
+# " (font-locking: closing the string above)
+
+# test format.data.frame on former AsIs's.
+set.seed(321)
+dd <- data.frame(x = 1:5, y = rnorm(5), z = c(1, 2, NA, 4, 5))
+model <- glm(y ~ x, data = dd, subset = 1:4, na.action = na.omit)
+expand.model.frame(model, "z", na.expand = FALSE)
+expand.model.frame(model, "z", na.expand = TRUE)
+
+## print.table() changes affecting summary.data.frame
+options(width=82)
+summary(attenu) # ``one line''
+lst <- levels(attenu$station)
+levels(attenu$station)[lst == "117"] <- paste(rep(letters,3),collapse="")
+summary(attenu) # {2 + one long + 2 } variables
+## in 1.7.0, things were split to more lines
+
+## format.default(*, nsmall > 0)  -- for real and complex
+
+sf <- function(x, N=14) sapply(0:N, function(i) format(x,nsmall=i))
+sf(2)
+sf(3.141)
+sf(-1.25, 20)
+
+oDig <- options(digits= 3)
+sf(pi)
+sf(1.2e7)
+sf(1.23e7)
+s <- -0.01234
+sf(s)
+
+sf(pi + 2.2i)
+sf(s + pi*1i)
+
+options(oDig)
+
+e1 <- tryCatch(options(max.print=Inf), error=function(e)e)
+e2 <- tryCatch(options(max.print= 0),  error=function(e)e)
+stopifnot(inherits(e1, "error"))
+
+
+## Printing of "Date"s
+options(width = 80)
+op <- options(max.print = 500)
+dd <- as.Date("2012-03-12") + -10000:100
+writeLines(t1 <- tail(capture.output(dd)))
+l6 <- length(capture.output(print(dd, max = 600)))
+options(op)
+t2 <- tail(capture.output(print(dd, max = 500)))
+stopifnot(identical(t1, t2), l6 == 121)
+## not quite consistent in R <= 2.14.x
+
+
+## Calls with S3 class are not evaluated when (auto)-printed
+obj <- structure(quote(stop("should not be evaluated")), class = "foo")
+#--
+a <- list(obj)
+b <- pairlist(obj)
+c <- structure(list(), attr = obj)
+d <- list(list(obj, pairlist(obj, structure(list(obj), attr = obj)), NULL))
+# Now auto-print, and explicit print(.) :
+a
+b
+c
+d
+print(a)
+print(b)
+print(c)
+print(d)
+# Now with a method defined (again "auto" + explicit print()):
+print.foo <- function(x, ...) cat("dispatched\n")
+a ; print(a)
+b ; print(b)
+c ; print(c)
+d ; print(d)
+
+
+## tagbuf is preserved after print dispatch in pairlists
+obj <- structure(list(), class = "foo")
+pairlist(a = list(A = obj, B = obj))
+list(list(pairlist(obj), NULL)) ## should print [[1]][[2]] \n NULL
+LLo <- list(list(obj,
+                 pairlist(a=obj, b=structure(list(C=obj), attr=obj)),
+                 NULL))
+LLo ## tags (names and [[<n>]]) were lost in R <= 3.5.0
+
+## show() is preferred over print() when printing recursively
+print.callS4Class <- function(x, ...) stop("should not be dispatched")
+.CallS4Class <- setClass("callS4Class", slots = c(x = "numeric"))
+setMethod("show", "callS4Class", function(object) cat("S4 show!\n"))
+x <- .CallS4Class(x = 1)
+## these should all say 'S4 show!'
+list(x) ; pairlist(x) # these 2 failed in R <= 3.5.0
+structure(list(), attr = x)
+rm(x, .CallS4Class)
+
+
+## Print dispatch does not reset parameters
+local({
+    num <- 0.123456789
+    print(list(num, obj, num), digits = 2) # should print 2 x '0.12'
+})
+
+
+## User-supplied arguments are forwarded on print-dispatch
+print.foo <- function(x, other = FALSE, digits = 0L, ...) {
+    cat("digits: ", digits, "\n")
+    stopifnot(other, digits == 4, !...length())
+}
+a <- list(obj)
+b <- pairlist(obj)
+c <- LLo[[1]][[2]]$b
+d <- LLo
+print(a, digits = 4, other = TRUE)
+print(b, digits = 4, other = TRUE)
+print(c, digits = 4, other = TRUE)
+print(d, digits = 4, other = TRUE)
+#
+## Deparsing should not reset parameters
+print(list(a, expression(foo), b, quote(foo), c, base::list, d),
+      digits = 4, other = TRUE)
+
+## max.print fully obeyed by print and format
+## These failed briefly due to bug in r76734
+o <- options(max.print = 5)
+1:10
+as.numeric(1:10)
+as.character(1:10)
+as.complex(1:10)
+as.raw(1:10)
+options(o)
+
+## Cleanup
+rm(print.foo, obj, a, b, c, d, o)