1#### Testing print(), format() and the like --- mainly with numeric() 2#### 3#### to be run as 4#### 5#### R < print-tests.R >& print-tests.out-__version__ 6#### == (csh) 7opt.conformance <- 0 8 9DIG <- function(d) 10 if(missing(d)) getOption("digits") else options(digits=as.integer(d)) 11 12DIG(7)#-- the default; just to make sure ... 13options(width = 200) 14 15n1 <- 2^(4*1:7) 16i1 <- as.integer(n1) 17 18v1 <- 2^c(-12, 2*(-4:-2),3,6,9) 19v2 <- v1^(63/64) 20## avoid ending in `5' as printing then depends on rounding of 21## the run-time (and not all round to even). 22v1[1:4] <-c(2.44140624e-04, 3.90624e-03, 1.5624e-02, 6.24e-02) 23 24 25v3 <- pi*100^(-1:3) 26v4 <- (0:2)/1000 + 1e-10 #-- tougher one 27 28digs1 <- c(1,2*(1:5),11:15) # 16: platform dependent 29 # 30 gives ERROR : options(digits=30) 30digs2 <- c(1:20)#,30) gives 'error' in R: ``print.default(): invalid digits..'' 31 32all(i1 == n1)# TRUE 33i1# prints nicely 34n1# did not; does now (same as 'i1') 35 36round (v3, 3)#S+ & R 0.49: 37##[1] 0.031 3.142 314.159 31415.927 3141592.654 38signif(v3, 3) 39##R.49: [1] 0.0314 3.1400 314.0000 31400.0000 3140000.0000 40##S+ [1] 3.14e-02 3.14e+00 3.14e+02 3.14e+04 3.14e+06 41 42###---------------------------------------------------------------- 43##- Date: Tue, 20 May 97 17:11:18 +0200 44 45##- From: Martin Maechler <maechler@stat.math.ethz.ch> 46##- To: R-devel@stat.math.ethz.ch 47##- Subject: R-alpha: print 'problems': print(2^30, digits=12); comments at start of function() 48##- 49##- Both of these bugs are not a real harm, 50##- however, they have been annoying me for too long ... ;-) 51##- 52##- 1) 53print (2^30, digits = 12) #- WAS exponential form, unnecessarily -- now ok 54formatC(2^30, digits = 12) #- shows you what you'd want above 55 56## S and R are now the same here; note that the problem also affects 57## paste(.) & format(.) : 58 59DIG(10); paste(n1); DIG(7) 60 61 62## Assignment to .Options$digits: Does NOT work for print() nor cat() 63for(i in digs1) { .Options$digits <- i; cat(i,":"); print (v1[-1]) } 64 65## using options() *does* things 66for(i in digs1) { DIG(i); cat(i,":"); print (v3) } 67for(i in digs1) { DIG(i); cat(i,":", formatC(v3, digits=i, width=8),"\n") } 68 69 70## R-0.50: switches to NON-exp at 14, but should only at 15... 71## R-0.61++: doesn' switch at all (or at 20 only) 72## S-plus: does not switch at all.. 73for(i in digs1) { cat(i,":"); print(v1, digits=i) } 74 75## R 0.50-a1: switches at 10 inst. 11 76for(i in digs1) { cat(i,":"); print(v1[-1], digits=i) } 77 78for(i in digs1) { DIG(i); cat(i,":", formatC(v2, digits=i, width=8),"\n") } 79 80for(i in digs1) { cat(i,":"); print(v2, digits=i) } #-- exponential all thru 81## ^^^^^ digs2 (>= 18: PLATFORM dependent !! 82for(i in digs1) { cat(i,":", formatC(v2, digits=i, width=8),"\n") } 83 84DIG(7)#-- the default; just to make sure ... 85 86N1 <- 10; N2 <- 7; n <- 8 87x <- 0:N1 88Mhyp <- rbind(phyper(x, N1, N2, n), dhyper(x, N1, N2, n)) 89Mhyp 90##- [,1] [,2] [,3] [,4] [,5] [,6] [,7] 91##- [1,] 0 0.0004113534 0.01336898 0.117030 0.4193747 0.7821884 0.9635952 92##- [2,] 0 0.0004113534 0.01295763 0.103661 0.3023447 0.3628137 0.1814068 93##- [,8] [,9] [,10] [,11] 94##- [1,] 0.99814891 1.00000000 1 1 95##- [2,] 0.03455368 0.00185109 0 0 96 97m11 <- c(-1,1) 98Mm <- pi*outer(m11, 10^(-5:5)) 99Mm <- cbind(Mm, outer(m11, 10^-(5:1))) 100Mm 101do.p <- TRUE 102do.p <- FALSE 103for(di in 1:10) { 104 options(digits=di) 105 cat(if(do.p)"\n",formatC(di,w=2),":", format.info(Mm),"\n") 106 if(do.p)print(Mm) 107} 108##-- R-0.49 (4/1997) R-0.50-a1 (7.7.97) 109##- 1 : 13 5 0 1 : 6 0 1 110##- 2 : 8 1 1 = 2 : 8 1 1 111##- 3 : 9 2 1 = 3 : 9 2 1 112##- 4 : 10 3 1 = 4 : 10 3 1 113##- 5 : 11 4 1 = 5 : 11 4 1 114##- 6 : 12 5 1 = 6 : 12 5 1 115##- 7 : 13 6 1 = 7 : 13 6 1 116##- 8 : 14 7 1 = 8 : 14 7 1 117##- 9 : 15 8 1 = 9 : 15 8 1 118##- 10 : 16 9 1 = 10 : 16 9 1 119nonFin <- list(c(Inf,-Inf), c(NaN,NA), NA_real_, Inf) 120mm <- sapply(nonFin, format.info) 121fm <- lapply(nonFin, format) 122w <- c(4,3,2,3) 123stopifnot(sapply(lapply(fm, nchar), max) == w, 124 mm == rbind(w, 0, 0))# m[2,] was 2147483647; m[3,] was 1 125cnF <- c(lapply(nonFin, function(x) complex(re=x, im=x))[-3], 126 complex(re=NaN, im=-Inf)) 127cmm <- sapply(cnF, format.info) 128cfm <- lapply(cnF, format) 129cw <- sapply(lapply(cfm, nchar), max) 130stopifnot(cw == cmm[1,]+1 +cmm[4,]+1, 131 nchar(format(c(NA, 1 + 2i))) == 4)# wrongly was (5,4) 132 133 134##-- Ok now, everywhere 135for(d in 1:9) {cat(d,":"); print(v4, digits=d) } 136DIG(7) 137 138 139###------------ Very big and very small 140umach <- unlist(.Machine)[paste("double.x", c("min","max"), sep='')] 141xmin <- umach[1] 142xmax <- umach[2] 143tx <- unique(c(outer(-1:1,c(.1,1e-3,1e-7))))# 7 values (out of 9) 144tx <- unique(sort(c(outer(umach,1+tx))))# 11 values (+ 1 Inf) 145length(tx <- tx[is.finite(tx)]) # 11 146(txp <- tx[tx >= 1])#-- Positive exponent -- 4 values 147(txn <- tx[tx < 1])#-- Negative exponent -- 7 values 148 149x2 <- c(0.099999994, 0.2) 150x2 # digits=7: show all seven "9"s 151print(x2, digits=6) # 0.1 0.2 , not 0.10 0.20 152v <- 6:8; names(v) <- v; sapply(v, format.info, x=x2) 153 154(z <- sort(c(outer(range(txn), 8^c(0,2:3))))) 155outer(z, 0:6, signif) # had NaN's till 1.1.1 156 157olddig <- options(digits=14) # RH6.0 fails at 15 158z <- 1.234567891234567e27 159for(dig in 1:14) cat(formatC(dig,w=2), 160 format(z, digits=dig), signif(z, digits=dig), "\n") 161options(olddig) 162# The following are tests of printf inside formatC 163##------ Use Emacs screen width 134 ; Courier 12 ---- 164# cat("dig| formatC(txp, d=dig)\n") 165# for(dig in 1:17)# about >= 18 is platform dependent [libc's printf()..]. 166# cat(formatC(dig,w=2), formatC(txp, dig=dig, wid=-29),"\n") 167# cat("signif() behavior\n~~~~~~~~\n", 168# "dig| formatC(signif(txp, dig=dig), dig = dig\n") 169# for(dig in 1:15)# 170# cat(formatC(dig,w=2), formatC(signif(txp, d=dig), dig=dig, wid=-26),"\n") 171 172# if(opt.conformance >= 1) { 173# noquote(cbind(formatC(txp, dig = 22))) 174# } 175 176# cat("dig| formatC(signif(txn, d = dig), dig=dig\n") 177# for(dig in 1:15)# 178# cat(formatC(dig,w=2), formatC(signif(txn, d=dig), dig=dig, wid=-20),"\n") 179 180# ##-- Testing 'print' / digits : 181# for(dig in 1:13) { ## 12:13: libc-2.0.7 diff; 14:18 --- PLATFORM-dependent !!! 182# cat("dig=",formatC(dig,w=2),": "); print(signif(txp, d=dig),dig=dig+1) 183# } 184 185##-- Wrong alignment when printing character matrices with quote = FALSE 186m1 <- matrix(letters[1:24],6,4) 187m1 188noquote(m1) 189 190##--- Complex matrices and named vectors : 191 192x0 <- x <- c(1+1i, 1.2 + 10i) 193names(x) <- c("a","b") 194x 195(xx <- rbind(x, 2*x)) 196 rbind(x0, 2*x0) 197x[4:6] <- c(Inf,Inf*c(-1,1i)) 198x + pi 199matrix(x + pi, 2) 200matrix(x + 1i*pi, 3) 201xx + pi 202t(cbind(xx, xx+ 1i*c(1,pi))) 203 204#--- format checks after incorrect changes in Nov 2000 205zz <- data.frame("(row names)" = c("aaaaa", "b"), check.names = FALSE) 206format(zz) 207format(zz, justify = "left") 208zz <- data.frame(a = I("abc"), b = I("def\"gh")) 209format(zz) 210# " (font-locking: closing the string above) 211 212# test format.data.frame on former AsIs's. 213set.seed(321) 214dd <- data.frame(x = 1:5, y = rnorm(5), z = c(1, 2, NA, 4, 5)) 215model <- glm(y ~ x, data = dd, subset = 1:4, na.action = na.omit) 216expand.model.frame(model, "z", na.expand = FALSE) 217expand.model.frame(model, "z", na.expand = TRUE) 218 219## print.table() changes affecting summary.data.frame 220options(width=82) 221summary(attenu) # ``one line'' 222lst <- levels(attenu$station) 223levels(attenu$station)[lst == "117"] <- paste(rep(letters,3),collapse="") 224summary(attenu) # {2 + one long + 2 } variables 225## in 1.7.0, things were split to more lines 226 227## format.default(*, nsmall > 0) -- for real and complex 228 229sf <- function(x, N=14) sapply(0:N, function(i) format(x,nsmall=i)) 230sf(2) 231sf(3.141) 232sf(-1.25, 20) 233 234oDig <- options(digits= 3) 235sf(pi) 236sf(1.2e7) 237sf(1.23e7) 238s <- -0.01234 239sf(s) 240 241sf(pi + 2.2i) 242sf(s + pi*1i) 243 244options(oDig) 245 246e1 <- tryCatch(options(max.print=Inf), error=function(e)e) 247e2 <- tryCatch(options(max.print= 0), error=function(e)e) 248stopifnot(inherits(e1, "error")) 249 250 251## Printing of "Date"s 252options(width = 80) 253op <- options(max.print = 500) 254dd <- as.Date("2012-03-12") + -10000:100 255writeLines(t1 <- tail(capture.output(dd))) 256l6 <- length(capture.output(print(dd, max = 600))) 257options(op) 258t2 <- tail(capture.output(print(dd, max = 500))) 259stopifnot(identical(t1, t2), l6 == 121) 260## not quite consistent in R <= 2.14.x 261 262 263## Calls with S3 class are not evaluated when (auto)-printed 264obj <- structure(quote(stop("should not be evaluated")), class = "foo") 265#-- 266a <- list(obj) 267b <- pairlist(obj) 268c <- structure(list(), attr = obj) 269d <- list(list(obj, pairlist(obj, structure(list(obj), attr = obj)), NULL)) 270# Now auto-print, and explicit print(.) : 271a 272b 273c 274d 275print(a) 276print(b) 277print(c) 278print(d) 279# Now with a method defined (again "auto" + explicit print()): 280print.foo <- function(x, ...) cat("dispatched\n") 281a ; print(a) 282b ; print(b) 283c ; print(c) 284d ; print(d) 285 286 287## tagbuf is preserved after print dispatch in pairlists 288obj <- structure(list(), class = "foo") 289pairlist(a = list(A = obj, B = obj)) 290list(list(pairlist(obj), NULL)) ## should print [[1]][[2]] \n NULL 291LLo <- list(list(obj, 292 pairlist(a=obj, b=structure(list(C=obj), attr=obj)), 293 NULL)) 294LLo ## tags (names and [[<n>]]) were lost in R <= 3.5.0 295 296## show() is preferred over print() when printing recursively 297print.callS4Class <- function(x, ...) stop("should not be dispatched") 298.CallS4Class <- setClass("callS4Class", slots = c(x = "numeric")) 299setMethod("show", "callS4Class", function(object) cat("S4 show!\n")) 300x <- .CallS4Class(x = 1) 301## these should all say 'S4 show!' 302list(x) ; pairlist(x) # these 2 failed in R <= 3.5.0 303structure(list(), attr = x) 304rm(x, .CallS4Class) 305 306 307## Print dispatch does not reset parameters 308local({ 309 num <- 0.123456789 310 print(list(num, obj, num), digits = 2) # should print 2 x '0.12' 311}) 312 313 314## User-supplied arguments are forwarded on print-dispatch 315print.foo <- function(x, other = FALSE, digits = 0L, ...) { 316 cat("digits: ", digits, "\n") 317 stopifnot(other, digits == 4, !...length()) 318} 319a <- list(obj) 320b <- pairlist(obj) 321c <- LLo[[1]][[2]]$b 322d <- LLo 323print(a, digits = 4, other = TRUE) 324print(b, digits = 4, other = TRUE) 325print(c, digits = 4, other = TRUE) 326print(d, digits = 4, other = TRUE) 327# 328## Deparsing should not reset parameters 329print(list(a, expression(foo), b, quote(foo), c, base::list, d), 330 digits = 4, other = TRUE) 331 332## max.print fully obeyed by print and format 333## These failed briefly due to bug in r76734 334o <- options(max.print = 5) 3351:10 336as.numeric(1:10) 337as.character(1:10) 338as.complex(1:10) 339as.raw(1:10) 340options(o) 341 342## Cleanup 343rm(print.foo, obj, a, b, c, d, o) 344