1## Regression tests for R >= 3.4.0 2 3pdf("reg-tests-1d.pdf", encoding = "ISOLatin1.enc") 4.pt <- proc.time() 5tryCid <- function(expr) tryCatch(expr, error = identity) 6tryCmsg<- function(expr) tryCatch(expr, error = conditionMessage) # typically == *$message 7identCO <- function(x,y, ...) identical(capture.output(x), capture.output(y), ...) 8assertErrV <- function(...) tools::assertError(..., verbose=TRUE) 9onWindows <- .Platform$OS.type == "windows" 10.M <- .Machine 11str(.M[grep("^sizeof", names(.M))]) ## also differentiate long-double.. 12b64 <- .M$sizeof.pointer == 8 13options(nwarnings = 10000) # (rather than just 50) 14 15 16## body() / formals() notably the replacement versions 17x <- NULL; tools::assertWarning( body(x) <- body(mean)) # to be error 18x <- NULL; tools::assertWarning(formals(x) <- formals(mean)) # to be error 19x <- NULL; tools::assertWarning(f <- body(x)); stopifnot(is.null(f)) 20x <- NULL; tools::assertWarning(f <- formals(x)); stopifnot(is.null(f)) 21## these all silently coerced NULL to a function in R <= 3.2.x 22 23## A good guess if we have _not_ translated error/warning/.. messages: 24## (should something like this be part of package tools ?) 25englishMsgs <- { 26 ## 1. LANGUAGE takes precedence over locale settings: 27 if(nzchar(lang <- Sys.getenv("LANGUAGE"))) 28 lang == "en" 29 else { ## 2. Query the locale 30 if(!onWindows) { 31 ## sub() : 32 lc.msgs <- sub("\\..*", "", print(Sys.getlocale("LC_MESSAGES"))) 33 lc.msgs == "C" || substr(lc.msgs, 1,2) == "en" 34 } else { ## Windows 35 lc.type <- sub("\\..*", "", sub("_.*", "", print(Sys.getlocale("LC_CTYPE")))) 36 lc.type == "English" || lc.type == "C" 37 } 38 } 39} 40cat(sprintf("English messages: %s\n", englishMsgs)) 41 42 43## match(x, t): fast algorithm for length-1 'x' -- PR#16885 44## a) string 'x' when only encoding differs 45tmp <- "年付" 46tmp2 <- "\u5e74\u4ed8" ; Encoding(tmp2) <- "UTF-8" 47for(ex in list(c(tmp, tmp2), c("foo","foo"))) { 48 cat(sprintf("\n|%s|%s| :\n----------\n", ex[1], ex[2])) 49 for(enc in c("latin1", "UTF-8", "unknown")) { # , "MAC", "WINDOWS-1251" 50 cat(sprintf("%9s: ", enc)) 51 tt <- ex[1]; Encoding(tt) <- enc; t2 <- ex[2] 52 if(identical(i1 <- ( tt %in% t2), 53 i2 <- (c(tt, "a") %in% t2)[1])) 54 cat(i1,"\n") 55 else 56 stop("differing: ", i1, ", ", i2) 57 } 58} 59## 60outerID <- function(x,y, ...) outer(x,y, Vectorize(identical,c("x","y")), ...) 61## b) complex 'x' with different kinds of NaN 62x0 <- c(0,1, NA_real_, NaN) 63z <- outer(x0,x0, complex, length.out=1L) 64z <- c(z[is.na(z)], # <- of length 4 * 4 - 2*2 = 12 65 as.complex(NaN), as.complex(0/0), # <- typically these two differ in bits 66 complex(real = NaN), complex(imaginary = NaN), 67 NA_complex_, complex(real = NA), complex(imaginary = NA)) 68## 1..12 all differ, then 69symnum(outerID(z,z, FALSE,FALSE,FALSE,FALSE))# [14] differing from all on low level 70symnum(outerID(z,z)) # [14] matches 2, 13,15 71(mz <- match(z, z)) # (checked with m1z below) 72zRI <- rbind(Re=Re(z), Im=Im(z)) # and see the pattern : 73print(cbind(format = format(z), t(zRI), mz), quote=FALSE) 74stopifnot(apply(zRI, 2, anyNA)) # NA *or* NaN: all TRUE 75is.NA <- function(.) is.na(.) & !is.nan(.) 76(iNaN <- apply(zRI, 2, function(.) any(is.nan(.)))) 77(iNA <- apply(zRI, 2, function(.) any(is.NA (.)))) # has non-NaN NA's 78## use iNA for consistency check once FIXME happened 79m1z <- sapply(z, match, table = z) 80stopifnot(exprs = { 81 identical(m1z, mz) 82 identical(m1z == 1L, iNA) 83 identical(match(z, NA, 0) == 1L, iNA) 84 identical(mz[mz != 1L], c(2L, 4L, 9L, 10L, 12L, 2L, 2L, 2L, 9L)) 85}) 86## m1z uses match(x, *) with length(x) == 1 and failed in R 3.3.0 87set.seed(17) 88for(. in 1:20) { 89 zz <- sample(z) 90 stopifnot(identical(match(zz,zz), vapply(zz, match, -1L, table = zz))) 91} 92## 93## PR#16909 - a consequence of the match() bug; check here too: 94dvn <- paste0("var\xe9", 1:2); Encoding(dvn) <- "latin1" 95dv <- data.frame(1:3, 3); names(dv) <- dvn; dv[,"var\u00e92"] <- 2 96stopifnot(ncol(dv) == 2, dv[,2] == 2, identical(names(dv), dvn)) 97## in R 3.3.0, got a 3rd column 98 99 100## deparse(<complex>, "digits17") 101fz <- format(z <- c(outer(-1:2, 1i*(-1:1), `+`))) 102(fz0 <- sub("^ +","",z)) 103r <- c(-1:1,100, 1e20); z2 <- c(outer(pi*r, 1i*r, `+`)); z2 104dz2 <- deparse(z2, control="digits17") 105stopifnot(exprs = { 106 identical(deparse(z, 200, control = "digits17"), 107 paste0("c(", paste(fz0, collapse=", "), ")")) 108 print((sum(nchar(dz2)) - 2) / length(z2)) < 22 # much larger in <= 3.3.0 109 ## deparse <-> parse equivalence, 17 digits should be perfect: 110 all.equal(z2, eval(parse(text = dz2)), tolerance = 3e-16) # seen 2.2e-35 on 32b 111}) 112## deparse() for these was "ugly" in R <= 3.3.x 113 114## deparse of formals of a function 115fun <- function(a=1,b){} 116frmls <- tryCid(eval(parse(text=deparse(formals(fun))))) 117stopifnot(identical(frmls, formals(fun))) 118 119 120## length(environment(.)) == #{objects} 121stopifnot(identical(length( baseenv()), 122 length(names(baseenv())))) 123## was 0 in R <= 3.3.0 124 125 126## "srcref"s of closures 127op <- options(keep.source = TRUE)# as in interactive use 128getOption("keep.source") 129stopifnot(exprs = { 130 identical(function(){}, function(){}) 131 identical(function(x){x+1}, 132 function(x){x+1}) 133}); options(op) 134## where all FALSE in 2.14.0 <= R <= 3.3.x because of "srcref"s etc 135 136 137## PR#16925, radix sorting INT_MAX w/ decreasing=TRUE and na.last=TRUE 138## failed ASAN check and segfaulted on some systems. 139data <- c(2147483645L, 2147483646L, 2147483647L, 2147483644L) 140stopifnot(identical(sort(data, decreasing = TRUE, method = "radix"), 141 c(2147483647L, 2147483646L, 2147483645L, 2147483644L))) 142 143 144## as.factor(<named integer>) 145ni <- 1:2; Nni <- names(ni) <- c("A","B") 146stopifnot(exprs = { 147 identical(Nni, names(as.factor(ni))) 148 identical(Nni, names( factor(ni))) 149 identical(Nni, names( factor(ni+0))) # +0 : "double" 150 identical(Nni, names(as.factor(ni+0))) 151}) 152## The first one lost names in 3.1.0 <= R <= 3.3.0 153 154 155## strtrim(<empty>, *) should work as substr(<empty>, *) does 156c0 <- character(0) 157stopifnot(identical(c0, strtrim(c0, integer(0)))) 158## failed in R <= 3.3.0 159 160 161## Factors with duplicated levels {created via low-level code}: 162set.seed(11) 163f0 <- factor(sample.int(9, 20, replace=TRUE)) 164(f <- structure(f0, "levels" = as.character(c(2:7, 2:4)))) 165tools::assertWarning(print(f)) 166tools::assertError(validObject(f)) 167## no warning in print() for R <= 3.3.x 168 169 170## R <= 3.3.0 returned integer(0L) from unlist() in this case: 171stopifnot(identical(levels(unlist(list(factor(levels="a")))), "a")) 172 173 174## diff(<difftime>) 175d <- as.POSIXct("2016-06-08 14:21", tz="UTC") + as.difftime(2^(-2:8), units="mins") 176dd <- diff(d) 177ddd <- diff(dd) 178d3d <- diff(ddd) 179d7d <- diff(d, differences = 7) 180(ldd <- list(dd=dd, ddd=ddd, d3d=d3d, d7d=d7d)) 181stopifnot(exprs = { 182 identical(ddd, diff(d, differences = 2)) 183 identical(d3d, diff(d, differences = 3)) 184 vapply(ldd, units, "") == "secs" 185 vapply(ldd, class, "") == "difftime" 186 lengths(c(list(d), ldd)) == c(11:8, 11-7) 187}) 188## was losing time units in R <= 3.3.0 189 190 191## sample(NA_real_) etc 192for(xx in list(NA, NA_integer_, NA_real_, NA_character_, NA_complex_, "NA", 1i)) 193 stopifnot(identical(xx, sample(xx))) 194## error in R <= 3.3.1 195 196 197## merge.data.frame with names matching order()'s arguments (PR#17119) 198nf <- names(formals(order)) 199nf <- nf[nf != "..."] 200v1 <- c(1,3,2) 201v2 <- c(4,2,3) 202for(nm in nf) { 203 cat(nm,":\n") 204 mdf <- merge( 205 as.data.frame(setNames(list(v1), nm=nm)), 206 as.data.frame(setNames(list(v2), nm=nm)), all = TRUE) 207 stopifnot(identical(mdf, 208 as.data.frame(setNames(list(0+ 1:4), nm=nm)))) 209} 210## some were wrong, others gave an error in R <= 3.3.1 211 212 213## PR#16936: table() dropping "NaN" level & 'exclude' sometimes failing 214op <- options(warn = 2)# no warnings allowed 215(fN1 <- factor(c("NA", NA, "NbN", "NaN"))) 216(tN1 <- table(fN1)) ##--> was missing 'NaN' 217(fN <- factor(c(rep(c("A","B"), 2), NA), exclude = NULL)) 218(tN <- table(fN, exclude = "B")) ## had extraneous "B" 219(tN. <- table(fN, exclude = c("B",NA))) ## had extraneous "B" and NA 220stopifnot(exprs = { 221 identical(c(tN1), c(`NA`=1L, `NaN`=1L, NbN=1L)) 222 identical(c(tN), structure(2:1, .Names = c("A", NA))) 223 identical(c(tN.), structure(2L, .Names = "A")) 224}) 225## both failed in R <= 3.3.1 226stopifnot(identical(names(dimnames(table(data.frame(Titanic[2,2,,])))), 227 c("Age", "Survived", "Freq"))) # was wrong for ~ 32 hours 228## 229## Part II: 230x <- factor(c(1, 2, NA, NA), exclude = NULL) ; is.na(x)[2] <- TRUE 231x # << two "different" NA's (in codes | w/ level) looking the same in print() 232stopifnot(identical(x, structure(as.integer(c(1, NA, 3, 3)), 233 .Label = c("1", "2", NA), class = "factor"))) 234(txx <- table(x, exclude = NULL)) 235stopifnot(identical(txx, table(x, useNA = "ifany")), 236 identical(as.vector(txx), c(1:0, 3L))) 237## wrongly gave 1 0 2 for R versions 2.8.0 <= Rver <= 3.3.1 238u.opt <- list(no="no", ifa = "ifany", alw = "always") 239l0 <- c(list(`_` = table(x)), 240 lapply(u.opt, function(use) table(x, useNA=use))) 241xcl <- list(NULL=NULL, none=""[0], "NA"=NA, NANaN = c(NA,NaN)) 242options(op) # warnings ok: 243lt <- lapply(xcl, function(X) 244 c(list(`_` = table(x, exclude=X)), #--> 4 warnings from (exclude, useNA): 245 lapply(u.opt, function(use) table(x, exclude=X, useNA=use)))) 246(y <- factor(c(4,5,6:5))) 247ly <- lapply(xcl, function(X) 248 c(list(`_` = table(y, exclude=X)), #--> 4 warnings ... 249 lapply(u.opt, function(use) table(y, exclude=X, useNA=use)))) 250lxy <- lapply(xcl, function(X) 251 c(list(`_` = table(x, y, exclude=X)), #--> 4 warnings ... 252 lapply(u.opt, function(use) table(x, y, exclude=X, useNA=use)))) 253op <- options(warn = 2)# no warnings allowed 254 255stopifnot(exprs = { 256 vapply(lt, function(i) all(vapply(i, class, "") == "table"), NA) 257 vapply(ly, function(i) all(vapply(i, class, "") == "table"), NA) 258 vapply(lxy,function(i) all(vapply(i, class, "") == "table"), NA) 259 identical((ltNA <- lt [["NA" ]]), lt [["NANaN"]]) 260 identical((ltNl <- lt [["NULL"]]), lt [["none" ]]) 261 identical((lyNA <- ly [["NA" ]]), ly [["NANaN"]]) 262 identical((lyNl <- ly [["NULL"]]), ly [["none" ]]) 263 identical((lxyNA <- lxy[["NA" ]]), lxy[["NANaN"]]) 264 identical((lxyNl <- lxy[["NULL"]]), lxy[["none" ]]) 265}) 266## 'NULL' behaved special (2.8.0 <= R <= 3.3.1) and 267## *all* tables in l0 and lt were == (1 0 2) ! 268ltN1 <- ltNA[[1]]; lyN1 <- lyNA[[1]]; lxyN1 <- lxyNA[[1]] 269lNl1 <- ltNl[[1]]; lyl1 <- lyNl[[1]]; lxyl1 <- lxyNl[[1]] 270 271stopifnot(exprs = { 272 vapply(names(ltNA) [-1], function(n) identical(ltNA [[n]], ltN1 ), NA) 273 vapply(names(lyNA) [-1], function(n) identical(lyNA [[n]], lyN1 ), NA) 274 vapply(names(lxyNA)[-1], function(n) identical(lxyNA[[n]], lxyN1), NA) 275 identical(lyN1, lyl1) 276 identical(2L, dim(ltN1)); identical(3L, dim(lyN1)) 277 identical(3L, dim(lNl1)) 278 identical(dimnames(ltN1), list(x = c("1","2"))) 279 identical(dimnames(lNl1), list(x = c("1","2", NA))) 280 identical(dimnames(lyN1), list(y = paste(4:6))) 281 identical( 1:0 , as.vector(ltN1)) 282 identical(c(1:0,3L), as.vector(lNl1)) 283 identical(c(1:2,1L), as.vector(lyN1)) 284 identical(c(1L, rep(0L, 5)), as.vector(lxyN1)) 285 identical(dimnames(lxyN1), c(dimnames(ltN1), dimnames(lyN1))) 286 identical(c(1L,1:0), as.vector(table(3:1, exclude=1, useNA = "always"))) 287 identical(c(1L,1L ), as.vector(table(3:1, exclude=1))) 288}) 289 290x3N <- c(1:3,NA) 291(tt <- table(x3N, exclude=NaN)) 292stopifnot(exprs = { 293 tt == 1 294 length(nt <- names(tt)) == 4 295 is.na(nt[4]) 296 identical(tt, table(x3N, useNA = "ifany")) 297 identical(tt, table(x3N, exclude = integer(0))) 298 identical(t3N <- table(x3N), table(x3N, useNA="no")) 299 identical(c(t3N), setNames(rep(1L, 3), as.character(1:3))) 300 ## 301 identical(c("2" = 1L), c(table(1:2, exclude=1) -> t12.1)) 302 identical(t12.1, table(1:2, exclude=1, useNA= "no")) 303 identical(t12.1, table(1:2, exclude=1, useNA= "ifany")) 304 identical(structure(1:0, .Names = c("2", NA)), 305 c( table(1:2, exclude=1, useNA= "always"))) 306}) 307options(op) # (revert to default) 308 309 310## contour() did not check args sufficiently 311tryCmsg(contour(matrix(rnorm(100), 10, 10), levels = 0, labels = numeric())) 312## caused segfault in R 3.3.1 and earlier 313 314 315## unique.warnings() needs better duplicated(): 316invisible(warnings()) 317.tmp <- lapply(list(0, 1, 0:1, 1:2, c(1,1), -1:1), function(x) wilcox.test(x)) 318if(!interactive()) 319stopifnot(length(print(uw <- unique(warnings()))) == 2) 320## unique() gave only one warning in R <= 3.3.1 321 322 323options(warn = 2)# no warnings allowed 324 325## findInterval(x, vec) when 'vec' is of length zero 326n0 <- numeric(); TF <- c(TRUE, FALSE) 327stopifnot(0 == unlist(lapply(TF, function(L1) 328 lapply(TF, function(L2) lapply(TF, function(L3) 329 findInterval(x=8:9, vec=n0, L1, L2, L3)))))) 330## did return -1's for all.inside=TRUE in R <= 3.3.1 331 332 333## droplevels(<factor with NA-level>) 334L3 <- c("A","B","C") 335f <- d <- factor(rep(L3, 2), levels = c(L3, "XX")); is.na(d) <- 3:4 336(dn <- addNA(d)) ## levels: A B C XX <NA> 337stopifnot(exprs = { 338 identical(levels(print(droplevels(dn))), c(L3, NA)) 339 ## only XX must be dropped; R <= 3.3.1 also dropped <NA> 340 identical(levels(droplevels(f)), L3) 341 identical(levels(droplevels(d)), L3) # do *not* add <NA> here 342 identical(droplevels(d ), d [, drop=TRUE]) 343 identical(droplevels(f ), f [, drop=TRUE]) 344 identical(droplevels(dn), dn[, drop=TRUE]) 345}) 346 347 348## summary.default() no longer rounds (just its print() method does): 349set.seed(0) 350replicate(256, { x <- rnorm(1); stopifnot(summary(x) == x)}) -> .t 351replicate(256, { x <- rnorm(2+rpois(1,pi)) 352 stopifnot(min(x) <= (sx <- summary(x)), sx <= max(x))}) -> .t 353## was almost always wrong in R <= 3.3.x 354 355 356## NULL in integer arithmetic 357i0 <- integer(0) 358stopifnot(exprs = { 359 identical(1L + NULL, 1L + integer()) 360 identical(2L * NULL, i0) 361 identical(3L - NULL, i0) 362}) 363## gave double() in R <= 3.3.x 364 365 366## factor(x, exclude) when 'x' or 'exclude' are character ------- 367stopifnot(identical(factor(c(1:2, NA), exclude = ""), 368 factor(c(1:2, NA), exclude = NULL) -> f12N)) 369fab <- factor(factor(c("a","b","c")), exclude = "c") 370stopifnot(identical(levels(fab), c("a","b"))) 371faN <- factor(c("a", NA), exclude=NULL) 372stopifnot(identical(faN, factor(faN, exclude="c"))) 373## differently with NA coercion warnings in R <= 3.3.x 374 375## factor(x, exclude = X) - coercing 'exclude' or not 376## From r-help/2005-April/069053.html : 377fNA <- factor(as.integer(c(1,2,3,3,NA)), exclude = NaN) 378stopifnot(identical(levels(fNA), c("1", "2", "3", NA))) 379## did exclude NA wrongly in R <= 3.3.x 380## Now when 'exclude' is a factor, 381cc <- c("x", "y", "NA") 382ff <- factor(cc) 383f2 <- factor(ff, exclude = ff[3]) # it *is* used 384stopifnot(identical(levels(f2), cc[1:2])) 385## levels(f2) still contained NA in R <= 3.3.x 386 387 388## arithmetic, logic, and comparison (relop) for 0-extent arrays 389(m <- cbind(a=1[0], b=2[0])) 390Lm <- m; storage.mode(Lm) <- "logical" 391Im <- m; storage.mode(Im) <- "integer" 392stopifnot(exprs = { 393 identical( m, m + 1 ); identical( m, m + 1 [0]); identical( m, m + NULL) 394 identical(Im, Im+ 1L); identical(Im, Im + 1L[0]); identical(Im, Im + NULL) 395 identical(m, m + 2:3); identical(Im, Im + 2:3) 396 identical(Lm, m & 1); identical(Lm, m | 2:3) 397 identical(Lm, m & TRUE [0]) 398 identical(Lm, Lm | FALSE[0]) 399 identical(Lm, m & NULL) # gave Error (*only* place where NULL was not allowed) 400 identical(Lm, m > 1) 401 identical(Lm, m > .1[0]); identical(Lm, m > NULL) 402 identical(Lm, m <= 2:3) 403}) 404mm <- m[,c(1:2,2:1,2)] 405tools::assertError(m + mm) # ... non-conformable arrays 406tools::assertError(m | mm) # ... non-conformable arrays 407tools::assertError(m == mm)# ... non-conformable arrays 408## in R <= 3.3.x, relop returned logical(0) and m + 2:3 returned numeric(0) 409 410## arithmetic, logic, and comparison (relop) -- inconsistency for 1x1 array o <vector >= 2>: 411(m1 <- matrix(1,1,1, dimnames=list("Ro","col"))) 412(m2 <- matrix(1,2,1, dimnames=list(c("A","B"),"col"))) 413if(FALSE) { # in the future (~ 2018): 414tools::assertError(m1 + 1:2) ## was [1] 2 3 even w/o warning in R <= 3.3.x 415} else tools::assertWarning(m1v <- m1 + 1:2); stopifnot(identical(m1v, 1+1:2)) 416tools::assertError(m1 & 1:2) # ERR: dims [product 1] do not match the length of object [2] 417tools::assertError(m1 <= 1:2) # ERR: (ditto) 418## 419## non-0-length arrays combined with {NULL or double() or ...} *fail* 420n0 <- numeric(0) 421l0 <- logical(0) 422stopifnot(exprs = { 423 identical(m1 + NULL, n0) # as "always" 424 identical(m1 + n0 , n0) # as "always" 425 identical(m1 & NULL, l0) # ERROR in R <= 3.3.x 426 identical(m1 & l0, l0) # ERROR in R <= 3.3.x 427 identical(m1 > NULL, l0) # as "always" 428 identical(m1 > n0 , l0) # as "always" 429 ## m2 was slightly different: 430 identical(m2 + NULL, n0) # ERROR in R <= 3.3.x 431 identical(m2 + n0 , n0) # ERROR in R <= 3.3.x 432 identical(m2 & NULL, l0) # ERROR in R <= 3.3.x 433 identical(m2 & l0 , l0) # ERROR in R <= 3.3.x 434 identical(m2 == NULL, l0) # as "always" 435 identical(m2 == n0 , l0) # as "always" 436}) 437 438## strcapture() 439stopifnot(identical(strcapture("(.+) (.+)", 440 c("One 1", "noSpaceInLine", "Three 3"), 441 proto=data.frame(Name="", Number=0)), 442 data.frame(Name=c("One", NA, "Three"), 443 Number=c(1, NA, 3)))) 444 445 446## PR#17160: min() / max() arg.list starting with empty character 447TFT <- 1:3 %% 2 == 1 448stopifnot(exprs = { 449 identical(min(character(), TFT), "0") 450 identical(max(character(), TFT), "1") 451 identical(max(character(), 3:2, 5:7, 3:0), "7") 452 identical(min(character(), 3:2, 5:7), "2") 453 identical(min(character(), 3.3, -1:2), "-1") 454 identical(max(character(), 3.3, 4:0), "4") 455}) 456## all gave NA in R <= 3.3.0 457 458 459## PR#17147: xtabs(~ exclude) fails in R <= 3.3.1 460exc <- exclude <- c(TRUE, FALSE) 461xt1 <- xtabs(~ exclude) # failed : The name 'exclude' was special 462xt2 <- xtabs(~ exc) 463xt3 <- xtabs(rep(1, length(exclude)) ~ exclude) 464noCall <- function(x) structure(x, call = NULL) 465stripXT <- function(x) structure(x, call = NULL, dimnames = unname(dimnames(x))) 466stopifnot(exprs = { 467 identical(dimnames(xt1), list(exclude = c("FALSE", "TRUE"))) 468 identical(names(dimnames(xt2)), "exc") 469 all.equal(stripXT(xt1), stripXT(xt2)) 470 all.equal(noCall (xt1), noCall (xt3)) 471}) 472## [fix was to call table() directly instead of via do.call(.)] 473 474 475## str(xtabs( ~ <var>)): 476stopifnot(grepl("'xtabs' int", capture.output(str(xt2))[1])) 477## did not mention "xtabs" in R <= 3.3.1 478 479 480## findInterval(x_with_ties, vec, left.open=TRUE) 481stopifnot(identical( 482 findInterval(c(6,1,1), c(0,1,3,5,7), left.open=TRUE), c(4L, 1L, 1L))) 483set.seed(4) 484invisible(replicate(100, { 485 vec <- cumsum(1 + rpois(6, 2)) 486 x <- rpois(50, 3) + 0.5 * rbinom(50, 1, 1/4) 487 i <- findInterval(x, vec, left.open = TRUE) 488 .v. <- c(-Inf, vec, Inf) 489 isIn <- .v.[i+1] < x & x <= .v.[i+2] 490 if(! all(isIn)) { 491 dump(c("x", "vec"), file=stdout()) 492 stop("not ok at ", paste(which(!isIn), collapse=", ")) 493 } 494})) 495## failed in R <= 3.3.1 496 497 498## PR#17132 -- grepRaw(*, fixed = TRUE) 499stopifnot( 500 identical(1L, grepRaw("abcd", "abcd", fixed = TRUE)), 501 identical(integer(), grepRaw("abcdefghi", "a", all = TRUE, fixed = TRUE))) 502## length 0 and seg.faulted in R <= 3.3.2 503 504 505## format()ing invalid hand-constructed POSIXlt objects 506if(hasTZ <- nzchar(.TZ <- Sys.getenv("TZ"))) cat(sprintf("env.var. TZ='%s'\n",.TZ)) 507d <- as.POSIXlt("2016-12-06", tz = "Europe/Vienna") 508hasGMTOFF <- !is.null(d$gmtoff) 509op <- options(warn = 1)# ==> assert*() will match behavior 510if(is.null(d$zone)) cat("Skipping timezone-dependent POSIXlt formatting\n") else 511for(EX in expression({}, Sys.setenv(TZ = "UTC"), Sys.unsetenv("TZ"))) { 512 cat(format(EX),":\n---------\n") 513 eval(EX) 514 dz <- d$zone 515 d$zone <- 1 516 tools::assertError(format(d)) 517 if (hasGMTOFF) { 518 d$zone <- NULL # now has 'gmtoff' but no 'zone' --> warning: 519 tools::assertWarning(stopifnot(identical(format(d),"2016-12-06"))) 520 d$zone <- dz # = previous, but 'zone' now is last 521 tools::assertError(format(d)) 522 } else 523 cat("Skipping timezone amd gmtoff dependent POSIXlt formatting\n") 524} 525if(hasTZ) Sys.setenv(TZ = .TZ); options(op)# revert 526 527dlt <- structure( 528 list(sec = 52, min = 59L, hour = 18L, mday = 6L, mon = 11L, year = 116L, 529 wday = 2L, yday = 340L, isdst = 0L, zone = "CET", gmtoff = 3600L), 530 class = c("POSIXlt", "POSIXt"), tzone = "CET") 531dlt$sec <- 10000 + 1:10 # almost three hours & uses re-cycling .. 532fd <- format(dlt) 533stopifnot(length(fd) == 10, identical(fd, format(dct <- as.POSIXct(dlt)))) 534dlt2 <- as.POSIXlt(dct) 535stopifnot(identical(format(dlt2), fd)) 536## The two assertError()s gave a seg.fault in R <= 3.3.2 537 538 539stopifnot(inherits(methods("("), "MethodsFunction"), 540 inherits(methods("{"), "MethodsFunction")) 541## methods("(") and ..("{") failed in R <= 3.3.2 542 543 544## moved after commit in r71778 545f <- eval(parse(text = "function() { x <- 1 ; for(i in 1:10) { i <- i }}", 546 keep.source = TRUE)) 547g <- removeSource(f) 548stopifnot(is.null(attributes(body(g)[[3L]][[4L]]))) 549 550## pmin/pmax of ordered factors -- broken in R 3.3.2 [PR #17195] 551of <- ordered(c(1,5,6)) 552asI <- as.integer # < shorter code 553set.seed(6); rof <- sample(of, 12, replace=TRUE) 554stopifnot(exprs = { 555 identical(pmax(rof, of), ordered(pmax(asI(rof), asI(of)), labels=levels(rof)) -> pmar) 556 identical(pmax(of, rof), pmar) 557 identical(pmin(rof, of), ordered(pmin(asI(rof), asI(of)), labels=levels(rof)) -> pmir) 558 identical(pmin(of, rof), pmir) 559 identical(pmin(rof, 5), ordered(pmin(asI(rof), 2), levels=1:3, labels=levels(rof))) 560 identical(pmax(rof, 6), ordered(pmax(asI(rof), 3), levels=1:3, labels=levels(rof))) 561 identical(pmax(rof, 1), rof) 562 identical(pmin(rof, 6), rof) 563 identical(pmax(of, 5, rof), ordered(pmax(asI(of),2L,asI(rof)), levels=1:3, 564 labels=levels(of))) 565}) 566## these were "always" true .. but may change (FIXME ?) 567stopifnot(exprs = { 568 identical(of, pmin(of, 3)) # what? error? at least warning? 569 identical(pmar, pmax(of, 3, rof)) 570}) 571## pmin/pmax() of 0-length S3 classed [PR #17200] 572for(ob0 in list(I(character()), I(0[0]), I(0L[0]), 573 structure(logical(), class="L"), 574 structure(character(), class="CH"))) { 575 stopifnot(exprs = { 576 identical(ob0, pmax(ob0, ob0)) 577 identical(ob0, pmin(ob0, ob0)) 578 identical(ob0, pmin(ob0, FALSE)) 579 identical(ob0, pmax(ob0, FALSE)) 580 }) 581} 582## pmin()/pmax() of matching numeric data frames 583mUSJ <- data.matrix(dUSJ <- USJudgeRatings) 584stopifnot(exprs = { 585 identical( pmin(dUSJ, 10 - dUSJ), 586 as.data.frame(pmin(mUSJ, 10 - mUSJ))) 587 identical( pmax(dUSJ, 10 - dUSJ), 588 as.data.frame(pmax(mUSJ, 10 - mUSJ))) 589}) 590## had failed for a while. Note however : 591d1 <- data.frame(y0 = 0:3 +1/2) ; (d1.2 <- d1[1:2, , drop=FALSE]) 592stopifnot(exprs = { ## FIXME: The 'NA's really are wrong 593 identical(pmax(d1,2), data.frame(y0 = c(2, NA, 2.5, 3.5))) 594 identical(pmax(d1, 3-d1), data.frame(y0 = .5+c(2, 1:3))) 595 identical(pmax(d1.2, 2), data.frame(y0 = c(2, NA))) 596 identical(pmax(d1.2, 2-d1.2),data.frame(y0=c(1.5,1.5))) 597 identical(pmin(d1, 2), data.frame(y0 = c(.5+0:1, NA,NA))) 598 identical(pmin(d1, 3-d1), data.frame(y0 = .5+c(0, 1:-1))) 599 identical(pmin(d1.2, 2), data.frame(y0 = c(.5, 1.5))) 600 identical(pmin(d1.2, 2-d1.2),data.frame(y0 = c(.5,.5))) 601}) 602## some CRAN pkgs have been relying that these at least "worked somehow" 603 604 605## quantile(x, prob) monotonicity in prob[] - PR#16672 606sortedQ <- function(x, prob, ...) 607 vapply(1:9, function(type) 608 !is.unsorted(quantile(x, prob, type=type, names=FALSE, ...)), NA) 609xN <- c(NA, 10.5999999999999996, NA, NA, NA, 10.5999999999999996, 610 NA, NA, NA, NA, NA, 11.3000000000000007, NA, NA, 611 NA, NA, NA, NA, NA, 5.2000000000000002) 612sQ.xN <- sortedQ(xN, probs = seq(0,1,1/10), na.rm = TRUE) 613x2 <- rep(-0.00090419678460984, 602) 614stopifnot(sQ.xN, sortedQ(x2, (0:5)/5)) 615## both not fulfilled in R < 3.4.0 616 617 618## seq.int() anomalies in border cases, partly from Mick Jordan (on R-devel): 619stopifnot(exprs = { 620 identical(1, seq.int(to=1, by=1 )) 621 identical(1:2, seq.int(to=2L, by=1L)) 622 identical(c(1L, 3L), seq.int(1L, 3L, length.out=2)) 623}) 624## the first was missing(.), the others "double" in R < 3.4.0 625assertErrV(seq(1,7, by = 1:2))# gave warnings in R < 3.4.0 626## seq() for <complex> / <integer> 627stopifnot(exprs = { 628 all.equal(seq(1+1i, 9+2i, length.out = 9) -> sCplx, 629 1:9 + 1i*seq(1,2, by=1/8)) 630 identical(seq(1+1i, 9+2i, along.with = 1:9), sCplx) 631 identical(seq(1L, 3L, by=1L), 1:3) 632}) 633## had failed in R-devel for a few days 634D1 <- as.Date("2017-01-06") 635D2 <- as.Date("2017-01-12") 636seqD1 <- seq.Date(D1, D2, by = "1 day") 637stopifnot(exprs = { 638 identical(seqD1, seq(D1, D2, by = "1 days")) 639 ## These two work "accidentally" via seq -> seq.default + "Date"-arithmetic 640 identical(seqD1, seq(by = 1, from = D1, length.out = 7)) 641 identical(seqD1, seq(by = 1, to = D2, length.out = 7)) 642 ## swap order of (by, to) ==> *FAILS* because directly calls seq.Date() - FIXME? 643 TRUE || 644 identical(seqD1, seq(to = D2, by = 1, length.out = 7)) 645 ## above had failed in R-devel for a couple of days 646 identical(seq(9L, by = -1L, length.out = 4L), 9:6) 647 identical(seq(9L, by = -1L, length.out = 4 ), 9:6) 648}) 649## for consistency, new in R >= 3.4.0 650 651 652## Underflow happened when parsing small hex constants PR#17199 653stopifnot(exprs = { 654 as.double("0x1.00000000d0000p-987") > 0 # should be 7.645296e-298 655 as.double("0x1.0000000000000p-1022") > 0 # should be 2.225074e-308 656 as.double("0x1.f89fc1a6f6613p-974") > 0 # should be 1.23456e-293 657}) 658## 659 660 661## format.POSIX[cl]t() after print.POSIXct() 662dt <- "2012-12-12 12:12:12" 663x <- as.POSIXct(dt, tz = "GMT") 664stopifnot(identical(format(x), dt)) 665op <- options(warn=1)# allow 666(Sys.t <- Sys.timezone()) # may occasionally warn (and work) 667options(op) 668someCET <- paste("Europe", c("Berlin", "Brussels", "Copenhagen", "Madrid", 669 "Paris", "Rome", "Vienna", "Zurich"), sep="/") 670if(Sys.t %in% someCET) 671 stopifnot(print(TRUE), identical(format(x, tz = ""), "2012-12-12 13:12:12")) 672## had failed for almost a month in R-devel & R-patched 673 674 675## xtabs() , notably with NA's : 676asArr <- function(x) { 677 attributes(x) <- list(dim=dim(x), dimnames=dimnames(x)); x } 678as_A <- function(x, A) array(x, dim=dim(A), dimnames=dimnames(A)) 679eq_A <- function(a,b) ## equality of arrays, notably sparseMatrix vs dense 680 identical(dim(a),dim(b)) && identical(dimnames(a),dimnames(b)) && 681 identical(as.vector(a), as.vector(b)) 682esoph2 <- droplevels(subset(esoph, subset = tobgp > "10-19" & alcgp >= "40-79")) 683(xt <- xtabs(~ agegp + alcgp + tobgp, esoph2)) 684stopifnot(identical(dim(xt), c(6L, 3L, 2L)), # of the 6 x 3 x 2 = 36 entries, 685 identical(which(xt == 0), c(7L, 12L, 18L, 23L, 30L, 32L, 36L)), 686 ## the above 8 are zeros and the rest is 1 : 687 all(xt[xt != 0] == 1)) 688xtC <- xtabs(ncontrols ~ agegp + alcgp + tobgp, data = esoph2) 689stopifnot(# no NA's in data, hence result should have none, just 0's: 690 identical(asArr(unname(xtC)), 691 array(c(4, 13, 10, 13, 4, 3, 0, 2, 4, 3, 1, 0, 1, 2, 1, 1, 0, 0, 692 7, 8, 2, 3, 0, 0, 2, 1, 2, 0, 0, 0, 2, 0, 0, 1, 0, 0), 693 dim = dim(xt)))) 694 695DF <- as.data.frame(UCBAdmissions) 696xt <- xtabs(Freq ~ Gender + Admit, DF) 697stopifnot(identical(asArr(xt), 698 array(c(1198, 557, 1493, 1278), dim = c(2L, 2L), 699 dimnames = list(Gender = c("Male", "Female"), 700 Admit = c("Admitted", "Rejected"))))) 701op <- options(na.action = "na.omit") 702DN <- DF; DN[cbind(6:9, c(1:2,4,1))] <- NA; DN 703 704tools::assertError(# 'na.fail' should fail : 705 xtabs(Freq ~ Gender + Admit, DN, na.action = na.fail)) 706xt. <- xtabs(Freq ~ Gender + Admit, DN) 707xtp <- xtabs(Freq ~ Gender + Admit, DN, na.action = na.pass) 708xtN <- xtabs(Freq ~ Gender + Admit, DN, addNA = TRUE) 709stopifnot(exprs = { 710 identical(asArr(xt - xt.), as_A(c(120,17, 207, 8 ), xt)) 711 identical(asArr(xt - xtp), as_A(c(120,17, 207, NA), xt)) # not ok in R <= 3.3.2 712 identical(asArr(-xtN + rbind(cbind(xt, 0), 0)), 713 as_A(c(120, 17, -17, 207, NA, 0, -327, 0, 0), xtN)) 714}) 715## 'sparse = TRUE requires recommended package Matrix 716if(requireNamespace('Matrix', lib.loc=.Library, quietly = TRUE)) { 717 xtS <- xtabs(Freq ~ Gender + Admit, DN, na.action = na.pass, sparse = TRUE)# error in R <= 3.3.2 718 xtNS <- xtabs(Freq ~ Gender + Admit, DN, addNA = TRUE, sparse = TRUE) 719 stopifnot( 720 eq_A(xt., xtabs(Freq ~ Gender + Admit, DN, sparse = TRUE)), 721 eq_A(xtp, xtS), 722 eq_A(xtN, xtNS) 723 ) 724} 725## NA treatment partly wrong in R < 3.4.0; new option 'addNA' 726ee <- esoph[esoph[,"ncases"] > 0, c(1:2,4)] 727ee[,"ncases"] <- as.integer(ee[,"ncases"]) 728(tt <- xtabs(ncases ~ ., ee)); options(op) 729stopifnot(identical(as.vector(tt[1:2,]), # *integer* + first value 730 c(0L, 1L, 0L, 4L, 0L, 0L, 1L, 4L))) 731## keeping integer in sum()mation of integers 732 733 734## tapply() with FUN returning raw | with factor -> returning integer 735stopifnot(identical(tapply(1:3, 1:3, as.raw), 736 array(as.raw(1:3), 3L, dimnames=list(1:3))), ## failed in R < 3.4.0 737 identical(3:1, as.vector(tapply(1:3, 1:3, factor, levels=3:1)))) 738x <- 1:2 ; (txx <- tapply(x, list(x, x), function(x) "a")) 739## 1 2 740## 1 "a" NA 741## 2 NA "a" 742stopifnot(identical(txx, 743 matrix(c("a", NA, NA, "a"), 2, dimnames = rep(list(as.character(x)),2L)))) 744## Failed in R 3.4.[01] 745 746 747## str(<list of list>, max.level = 1) 748LoL <- function(lenC, FUN = identity) 749 lapply(seq_along(lenC), function(i) lapply(seq_len(lenC[i]), FUN)) 750xx <- LoL(c(7,3,17,798,3)) 751str(xx, list.len = 7, max.level = 1) 752str2 <- capture.output( 753 str(xx, list.len = 7, max.level = 2)) 754stopifnot(exprs = { 755 grepl("List of ", capture.output(str(xx, list.len = 7, max.level = 1))) 756 length(str2) == 35 757 sum(grepl("list output truncated", str2)) == 2 758 vapply(paste("List of", lengths(xx)), function(pat) any(grepl(pat, str2)), NA) 759}) 760## wrongly showed '[list output truncated]' in R < 3.4.0 761 762 763## stopifnot(all.equal(.)) message abbreviation 764msg <- tryCmsg(stopifnot(all.equal(rep(list(pi),4), list(3.1, 3.14, 3.141, 3.1415)))) 765writeLines(msg) 766stopifnot(length(strsplit(msg,"\n")[[1]]) == 1+3+1) 767## was wrong for months in R-devel only 768 769 770## available.packages() (not) caching in case of errors 771tools::assertWarning(ap1 <- available.packages(repos = "http://foo.bar")) 772tools::assertWarning(ap2 <- available.packages(repos = "http://foo.bar")) 773stopifnot(nrow(ap1) == 0, identical(ap1, ap2)) 774## had failed for a while in R-devel (left empty *.rds file) 775 776 777## rep()/rep.int() : when 'times' is a list 778stopifnot(exprs = { 779 identical(rep (4, list(3)), c(4,4,4)) 780 identical(rep.int(4, list(3)), c(4,4,4)) 781 identical(rep.int(4:5, list(2,1)), c(4L,4:5)) 782 identical(rep (4:5, list(2,1)), c(4L,4:5)) 783}) 784## partly failed in R 3.3.{2,3} 785 786 787## quantile(ordered(.)) - error message more directly useful 788OL <- ordered(sample(LETTERS, 20, replace=TRUE)) 789(e <- tryCmsg(quantile(OL))) 790stopifnot(exprs = { 791 grepl("type.*1.*3", e) # typically works in several locales 792 is.ordered(quantile(OL, type = 1)) 793 is.ordered(quantile(OL, type = 3)) 794}) 795## gave "factors are not allowed" in R <= 3.3.x 796 797## terms() ignored arg names (PR#17235) 798a1 <- attr(terms(y ~ f(x, a = z) + f(x, a = z)), 799 "term.labels") 800a2 <- attr(terms(y ~ f(x, a = z) + f(x, b = z)), 801 "term.labels") 802stopifnot(length(a1) == 1, length(a2) == 2) 803## both gave length 1 804 805 806## by.data.frame() called not from toplevel w different arg names 807dby <- function(dat, ind, F) by(dat, ind, FUN=F) 808dby(warpbreaks, warpbreaks[,"tension"], summary) 809if(!interactive()) 810stopifnot(is.list(r <- .Last.value), inherits(r, "by")) 811## failed after r72531 812 813 814## status returned by 'R CMD Sweave' 815fil <- "Sweave-test-1.Rnw" 816file.copy(system.file("Sweave", fil, package="utils"), tempdir()) 817owd <- setwd(tempdir()) 818(o <- capture.output(utils:::.Sweave(fil, no.q = TRUE), type = "message")) 819stopifnot(grepl("exit status 0", tail(o, 1))) 820setwd(owd) 821## R CMD Sweave gave status 1 and hence an error in R 3.4.0 (only) 822 823 824## print.noquote(*, right = *) 825nq <- noquote(LETTERS[1:9]); stopifnot(identical(nq, print(nq, right = TRUE))) 826## print() failed a few days end in R-devel ca. May 1, 2017; non-identical for longer 827tt <- table(c(rep(1, 7), 2,2,2)) 828stopifnot(identical(tt, print.noquote(tt))) 829## print.noquote(<table>) failed for 6 weeks after r72638 830 831 832## accessing ..1 when ... is empty and using ..0, etc. 833t0 <- function(...) ..0 834t1 <- function(...) ..1 835t2 <- function(...) ..2 836stopifnot(identical(t1(pi, 2), pi), identical(t1(t1), t1), 837 identical(t2(pi, 2), 2)) 838et1 <- tryCid(t1()) 839if(englishMsgs) 840 stopifnot(identical("the ... list contains fewer than 1 element", 841 conditionMessage(et1))) 842## previously gave "'nthcdr' needs a list to CDR down" 843et0 <- tryCid(t0()) ; (mt0 <- conditionMessage(et0)) 844et2.0 <- tryCid(t2()) ; (mt2.0 <- conditionMessage(et2.0)) 845et2.1 <- tryCid(t2(1)); (mt2.1 <- conditionMessage(et2.1)) 846if(englishMsgs) 847 stopifnot(grepl("indexing '...' with .* index 0", mt0), 848 identical("the ... list contains fewer than 2 elements", mt2.0), 849 identical(mt2.0, mt2.1)) 850assertErrV(t0(1)) 851assertErrV(t0(1, 2)) 852## the first gave a different error msg, the next gave no error in R < 3.5.0 853 854 855## stopifnot(e1, e2, ...) .. evaluating expressions sequentially 856one <- 1 857try(stopifnot(3 < 4:5, 5:6 >= 5, 6:8 <= 7, one <<- 2)) 858stopifnot(identical(one, 1)) # i.e., 'one <<- 2' was *not* evaluated 859## all the expressions were evaluated in R <= 3.4.x 860(et <- tryCid(stopifnot(0 < 1:10, is.numeric(..vaporware..), stop("FOO!")))) 861stopifnot(exprs = { 862 inherits(et, "simpleError") 863 ## condition call now *does* contain 'stopifnot': 864 ## !grepl("^stopifnot", deparse(conditionCall(et), width.cutoff=500)) 865 grepl("'..vaporware..'", conditionMessage(et)) 866}) 867## call was the full 'stopifnot(..)' in R < 3.5.0 .. and again in R > 3.6.x 868## (don't afford tryCatch()ing everything) 869 870 871## path.expand shouldn't translate to local encoding PR#17120 872## This has been fixed on Windows, but not yet on Unix non-UTF8 systems 873if(onWindows) { 874 filename <- "\U9b3c.R" 875 stopifnot(identical(path.expand(paste0("~/", filename)), 876 paste0(path.expand("~/"), filename))) 877} 878## Chinese character was changed to hex code 879 880 881## aggregate.data.frame(*, drop=FALSE) {new feature in R 3.3.0} 882## PR#16918 : problem with near-eq. factor() levels "not quite matching" 883group <- c(2 + 2^-51, 2) 884d1 <- data.frame(n = seq(group)) 885b1 <- list(group = group) 886stopifnot( 887 identical(aggregate(d1, b1, length, drop = TRUE), 888 aggregate(d1, b1, length, drop = FALSE))) 889## drop=FALSE gave two rows + deprec. warning in R 3.3.x, and an error in 3.4.0 890 891 892## line() [Tukey's resistant line] 893cfs <- t(sapply(2:50, function(k) {x <- 1:k; line(x, 2+x)$coefficients })) 894set.seed(7) 895cf2 <- t(sapply(2:50, function(k) { 896 x <- sample.int(k) 897 line(x, 1-2*x)$coefficients })) 898stopifnot(all.equal(cfs, matrix(c(2, 1), 49, 2, byrow=TRUE), tol = 1e-14), # typically exact 899 all.equal(cf2, matrix(c(1, -2), 49, 2, byrow=TRUE), tol = 1e-14)) 900## had incorrect medians of the left/right third of the data (x_L, x_R), in R < 3.5.0 901 902 903## 0-length Date and POSIX[cl]t: PR#71290 904D <- structure(17337, class = "Date") # Sys.Date() of "now" 905D; D[0]; D[c(1,2,1)] # test printing of NA too 906stopifnot(identical(capture.output(D[0]), "Date of length 0")) 907D <- structure(1497973313.62798, class = c("POSIXct", "POSIXt")) # Sys.time() 908D; D[0]; D[c(1,2,1)] # test printing of NA too 909stopifnot(identical(capture.output(D[0]), "POSIXct of length 0")) 910D <- as.POSIXlt(D) 911D; D[0]; D[c(1,2,1)] # test printing of NA too 912stopifnot(identical(capture.output(D[0]), "POSIXlt of length 0")) 913## They printed as '[1] "Date of length 0"' etc in R < 3.5.0 914 915 916## aggregate.data.frame() producing spurious names PR#17283 917dP <- state.x77[,"Population", drop=FALSE] 918by <- list(Region = state.region, Cold = state.x77[,"Frost"] > 130) 919a1 <- aggregate(dP, by=by, FUN=mean, simplify=TRUE) 920a2 <- aggregate(dP, by=by, FUN=mean, simplify=FALSE) 921stopifnot(exprs = { 922 is.null(names(a1$Population)) 923 is.null(names(a2$Population)) 924 identical(unlist(a2$Population), a1$Population) 925 all.equal(unlist(a2$Population), 926 c(8802.8, 4208.12, 7233.83, 4582.57, 1360.5, 2372.17, 970.167), 927 tol = 1e-6) 928}) 929## in R <= 3.4.x, a2$Population had spurious names 930 931 932## factor() with duplicated labels allowing to "merge levels" 933x <- c("Male", "Man", "male", "Man", "Female") 934## The pre-3.5.0 way {two function calls, nicely aligned}: 935xf1 <- factor(x, levels = c("Male", "Man", "male", "Female")) 936 levels(xf1) <- c("Male", "Male", "Male", "Female") 937## the new "direct" way: 938xf <- factor(x, levels = c("Male", "Man", "male", "Female"), 939 labels = c("Male", "Male", "Male", "Female")) 940stopifnot(identical(xf1, xf), 941 identical(xf, factor(c(rep(1,4),2), labels = c("Male", "Female")))) 942## Before R 3.5.0, the 2nd factor() call gave an error 943aN <- c("a",NA) 944stopifnot(identical(levels(factor(1:2, labels = aN)), aN)) 945## the NA-level had been dropped for a few days in R-devel(3.5.0) 946## 947 948## Factor behavior -- these have been unchanged, also in R >= 3.5.0 : 949ff <- factor(c(NA,2,3), levels = c(2, NA), labels = c("my", NA), exclude = NULL) 950stopifnot(exprs = { ## all these have been TRUE "forever" : 951 identical(as.vector(ff), as.character(ff)) 952 identical(as.vector(ff), c(NA, "my", NA)) 953 identical(capture.output(ff), c("[1] <NA> my <NA>", 954 "Levels: my <NA>")) 955 identical(factor(ff), 956 structure(c(NA, 1L, NA), .Label = "my", class = "factor")) 957 identical(factor(ff, exclude=NULL), 958 structure(c(2L, 1L, 2L), .Label = c("my", NA), class = "factor")) 959 identical(as.integer( ff), c(2:1,NA)) 960 identical(as.integer(factor(ff, exclude=NULL)), c(2:1,2L)) 961}) 962 963 964## within.list({ .. rm( >=2 entries ) }) : 965L <- list(x = 1, y = 2, z = 3) 966stopifnot(identical(within(L, rm(x,y)), list(z = 3))) 967## has failed since R 2.7.2 patched (Aug. 2008) without any noticeable effect 968sortN <- function(x) x[sort(names(x))] 969LN <- list(y = 2, N = NULL, z = 5) 970stopifnot(exprs = { 971 identical(within(LN, { z2 <- z^2 ; rm(y,z,N) }), 972 list(z2 = 5^2)) ## failed since Aug. 2008 973 identical(within(LN, { z2 <- z^2 ; rm(y,z) }), 974 list(N = NULL, z2 = 5^2)) ## failed for a few days in R-devel 975 ## within.list() fast version 976 identical(sortN(within(LN, { z2 <- z^2 ; rm(y,z) }, keepAttrs=FALSE)), 977 sortN(list(N = NULL, z2 = 5^2))) 978}) 979 980 981## write.csv did not signal an error if the disk was full PR#17243 982if (file.access("/dev/full", mode = 2) == 0) { # Not on all systems... 983 cat("Using /dev/full checking write errors... ") 984 # Large writes should fail mid-write 985 tools::assertError(write.table(data.frame(x=1:1000000), file = "/dev/full")) 986 # Small writes should fail on closing 987 tools::assertWarning(write.table(data.frame(x=1), file = "/dev/full")) 988 cat("[Ok]\n") 989} 990## Silently failed up to 3.4.1 991 992 993## model.matrix() with "empty RHS" -- PR#14992 re-opened 994row.names(trees) <- 42 + seq_len(nrow(trees)) 995.RN <- row.names(mf <- model.frame(log(Volume) ~ log(Height) + log(Girth), trees)) 996stopifnot(identical(.RN, row.names(model.matrix(~ 1, mf))), 997 identical(.RN, row.names(model.matrix(~ 0, mf)))) 998## had 1:nrow() up to 3.4.x 999 1000 1001## "\n" etc in calls and function definitions 1002(qq <- quote(-"\n")) 1003stopifnot(exprs = { 1004 identical('-"\\n"', cq <- capture.output(qq)) 1005 identical(5L, nchar(cq)) 1006 identical(6L, nchar(capture.output(quote(("\t"))))) 1007}) 1008## backslashes in language objects accidentally duplicated in R 3.4.1 1009 1010 1011## length(<pairlist>) <- N 1012pl <- pairlist(a=1, b=2); length(pl) <- 1 1013al <- formals(ls); length(al) <- 2 1014stopifnot(identical(pl, pairlist(a = 1)), 1015 identical(al, as.pairlist(alist(name = , pos = -1L)))) 1016## both `length<-` failed in R <= 3.4.1; the 2nd one for the wrong reason 1017 1018 1019## dist(*, "canberra") : 1020x <- cbind(c(-1,-5,10), c(-2,7,8)); (dc <- dist(x, method="canberra")) 1021## 1 2 1022## 2 1.666667 1023## 3 2.000000 1.066667 1024stopifnot(all.equal(as.vector(dc), c(25, 30, 16)/15)) 1025## R's definition wrongly assumed x[] entries all of the same sign 1026 1027 1028## sigma( <rank-deficient model> ), PR#17313 1029dd <- data.frame(x1 = LETTERS[c(1,2,3, 1,2,3, 1,2,3)], 1030 x2 = letters[c(1,2,1, 2,1,1, 1,2,1)], y = 1:9) 1031(sf <- summary(fit <- lm(y ~ x1*x2, data = dd))) ## last coef is NA 1032stopifnot(all.equal(sigma(fit)^2, 27/2, tol = 1e-14), 1033 all.equal(sigma(fit), sf$sigma, tol = 1e-14)) 1034## was too large because of wrong denom. d.f. in R <= 3.4.1 1035 1036 1037## nclass.FD() and nclass.scott() for "extreme" data, PR#17274 1038NC <- function(x) c(Sturges = nclass.Sturges(x), 1039 Scott = nclass.scott(x), FD = nclass.FD(x)) 1040xE <- function(eps, n = 5) { 1041 stopifnot(n >= 2, is.numeric(eps), eps >= 0) 1042 c(rep.int(1, n-2), 1+eps, 2) 1043} 1044ncE <- c(Sturges = 4, Scott = 2, FD = 3) 1045stopifnot(exprs = { 1046 sapply(-5:-16, function(E) identical(NC(xE(10^E)), ncE)) 1047 identical(NC(xE(1e-4)), c(Sturges = 4, Scott = 2, FD = 8550)) 1048 identical(NC(xE(1e-3)), c(Sturges = 4, Scott = 2, FD = 855)) 1049}) 1050## for these, nclass.FD() had "exploded" in R <= 3.4.1 1051## Extremely large diff(range(.)) : NB: this gives a UBSAN warning 1052XXL <- c(1:9, c(-1,1)*1e300) 1053stopifnot(nclass.scott(XXL) == 1) 1054## gave 0 in R <= 3.4.1 1055tools::assertWarning(hh <- hist(XXL, "FD", plot=FALSE)) 1056stopifnot(sum(hh$counts) == length(XXL)) 1057## gave error from pretty.default + NA coercion warning in R <= 3.4.1 1058 1059 1060## methods:::rbind / cbind no longer deeply recursive also fixes bug: 1061library(methods) 1062myM <- setClass("myMatrix", contains="matrix") 1063T <- rbind(1:2, c=2, "a+"=10, myM(4:1,2), deparse.level=0) 1064stopifnot(identical(rownames(T), c("", "c", "a+", "", ""))) 1065## rownames(.) wrongly were NULL in R <= 3.4.1 1066proc.time() - .pt; .pt <- proc.time() 1067 1068 1069## qr.coef(qr(X, LAPACK=TRUE)) when X has column names, etc 1070X <- cbind(int = 1, 1071 c2 = c(2, 8, 3, 10), 1072 c3 = c(2, 5, 2, 2)); rownames(X) <- paste0("r", 1:4) 1073y <- c(2,3,5,7); yc <- as.complex(y) 1074q.Li <- qr(X); cfLi <- qr.coef(q.Li, y) 1075q.LA <- qr(X, LAPACK=TRUE); cfLA <- qr.coef(q.LA, y) 1076q.Cx <- qr(X + 0i); cfCx <- qr.coef(q.Cx, y) 1077e1 <- tryCid(qr.coef(q.Li, y[-4])); e1 1078e2 <- tryCid(qr.coef(q.LA, y[-4])) 1079stopifnot(exprs = { 1080 all.equal(cfLi, cfLA , tol = 1e-14)# 6.376e-16 (64b Lx) 1081 all.equal(cfLi, Re(cfCx), tol = 1e-14)# (ditto) 1082 identical(conditionMessage(e1), conditionMessage(e2)) 1083}) 1084## 1) cfLA & cfCx had no names in R <= 3.4.1 1085## 2) error messages were not consistent 1086 1087 1088## invalid user device function options(device = *) -- PR#15883 1089graphics.off() # just in case 1090op <- options(device=function(...){}) # non-sense device 1091assertErrV(plot.new()) 1092if(no.grid <- !("grid" %in% loadedNamespaces())) requireNamespace("grid") 1093assertErrV(grid::grid.newpage()) 1094if(no.grid) unloadNamespace("grid") ; options(op) 1095## both errors gave segfaults in R <= 3.4.1 1096 1097 1098## readRDS(textConnection()) 1099abc <- c("a", "b", "c"); tmpC <- "" 1100zz <- textConnection('tmpC', 'wb') 1101saveRDS(abc, zz, ascii = TRUE) 1102sObj <- paste(textConnectionValue(zz), collapse='\n') 1103close(zz); rm(zz) 1104stopifnot(exprs = { 1105 identical(abc, readRDS(textConnection(tmpC))) 1106 identical(abc, readRDS(textConnection(sObj))) 1107}) 1108## failed in R 3.4.1 only 1109 1110 1111## Ops (including arithmetic) with 0-column data frames: 1112d0 <- USArrests[, FALSE] 1113stopifnot(exprs = { 1114 identical(d0, sin(d0)) 1115 identical(d0, d0 + 1); identical(d0, 2 / d0) # failed 1116 all.equal(sqrt(USArrests), USArrests ^ (1/2)) # now both data frames 1117 is.matrix(m0 <- 0 < d0) 1118 identical(dim(m0), dim(d0)) 1119 identical(dimnames(m0)[1], dimnames(d0)[1]) 1120 identical(d0 & d0, m0) 1121}) 1122## all but the first failed in R < 3.5.0 1123 1124 1125## pretty(x, n) for n = <large> or large diff(range(x)) gave overflow in C code 1126(fLrg <- Filter(function(.) . < 9e307, c(outer(1:8, 10^(0:2))*1e306))) 1127pL <- vapply(fLrg, function(f)length(pretty(c(-f,f), n = 100, min.n = 1)), 1L) 1128pL 1129pL3 <- vapply(fLrg, function(f)length(pretty(c(-f,f), n = 10^3, min.n = 1)), 1L) 1130pL3 1131stopifnot(71 <= pL, pL <= 141, # 81 <= pL[-7], # not on Win-64: pL[-15] <= 121, 1132 701 <= pL3, pL3 <= 1401) # <= 1201 usually 1133## in R < 3.5.0, both had values as low as 17 1134## without long doubles, min(pl[-7]) is 71. 1135 1136 1137### Several returnValue() fixes (r 73111) -------------------------- 1138## ============= 1139## returnValue() corner case 1: return 'default' on error 1140hret <- NULL 1141fret <- NULL 1142h <- function() { 1143 on.exit(hret <<- returnValue(27)) 1144 stop("h fails") 1145} 1146f <- function() { 1147 on.exit(fret <<- returnValue(27)) 1148 h() 1149 1 1150} 1151res <- tryCatch(f(), error=function(e) 21) 1152stopifnot(exprs = { 1153 identical(fret, 27) 1154 identical(hret, 27) 1155 identical(res, 21) 1156}) 1157## 1158## returnValue corner case 2: return 'default' on non-local return 1159fret <- NULL 1160gret <- NULL 1161f <- function(expr) { 1162 on.exit(fret <<- returnValue(28)) 1163 expr 1164 1 1165} 1166g <- function() { 1167 on.exit(gret <<- returnValue(28)) 1168 f(return(2)) 1169 3 1170} 1171res <- g() 1172stopifnot(exprs = { 1173 identical(fret, 28) 1174 identical(gret, 2) 1175 identical(res, 2) 1176}) 1177## 1178## returnValue corner case 3: return 'default' on restart 1179mret <- NULL 1180hret <- NULL 1181lret <- NULL 1182uvarg <- NULL 1183uvret <- NULL 1184h <- function(x) { 1185 on.exit(hret <<- returnValue(29)) 1186 withCallingHandlers( 1187 myerror = function(e) invokeRestart("use_value", 1), 1188 m(x) 1189 ) 1190} 1191m <- function(x) { 1192 on.exit(mret <<- returnValue(29)) 1193 res <- withRestarts( 1194 l(x), 1195 use_value = function(x) { 1196 on.exit(uvret <<- returnValue(29)) 1197 uvarg <<- x 1198 3 1199 } 1200 ) 1201 res 1202} 1203l <- function(x) { 1204 on.exit(lret <<- returnValue(29)) 1205 if (x > 1) { 1206 res <- x+1 1207 return(res) 1208 } 1209 cond <- structure( 1210 class = c("myerror", "error", "condition"), 1211 list(message = c("This is not an error", call = sys.call())) 1212 ) 1213 stop(cond) 1214} 1215res <- h(1) 1216stopifnot(exprs = { 1217 identical(res, 3) 1218 identical(mret, 3) 1219 identical(hret, 3) 1220 identical(lret, 29) 1221 identical(uvarg, 1) 1222 identical(uvret, 3) 1223}) 1224## 1225## returnValue: callCC 1226fret <- NULL 1227f <- function(exitfun) { 1228 on.exit(fret <<- returnValue(30)) 1229 exitfun(3) 1230 4 1231} 1232res <- callCC(f) 1233stopifnot(identical(res, 3), identical(fret, 30)) 1234## 1235## returnValue: instrumented callCC 1236fret <- NULL 1237mycallCCret <- NULL 1238funret <- NULL 1239mycallCC <- function(fun) { 1240 value <- NULL 1241 on.exit(mycallCCret <<- returnValue(31)) 1242 delayedAssign("throw", return(value)) 1243 fun(function(v) { 1244 on.exit(funret <<- returnValue(31)) 1245 value <<- v 1246 throw 1247 }) 1248} 1249f <- function(exitfun) { 1250 on.exit(fret <<- returnValue(31)) 1251 exitfun(3) 1252 4 1253} 1254res <- mycallCC(f) 1255stopifnot(exprs = { 1256 identical(res, 3) 1257 identical(fret, 31) 1258 identical(mycallCCret, 3) 1259 identical(funret, 31) 1260}) 1261## end{ returnValue() section} 1262 1263 1264## array(<empty>, *) should create (corresponding) NAs for non-raw atomic: 1265a <- array(character(), 1:2) 1266stopifnot(identical(a, matrix(character(), 1,2)), is.na(a)) 1267## had "" instead of NA in R < 3.5.0 1268 1269 1270## chaining on.exit handlers with return statements 1271x <- 0 1272fret1 <- NULL 1273fret2 <- NULL 1274f <- function() { 1275 on.exit(return(4)) 1276 on.exit({fret1 <<- returnValue(); return(5)}, add = T) 1277 on.exit({fret2 <<- returnValue(); x <<- 2}, add = T) 1278 3 1279} 1280res <- f() 1281stopifnot(exprs = { 1282 identical(res, 5) 1283 identical(x, 2) 1284 identical(fret1, 4) 1285 identical(fret2, 5) 1286}) 1287 1288 1289## splineDesign(*, derivs = <too large>): 1290if(no.splines <- !("splines" %in% loadedNamespaces())) requireNamespace("splines") 1291x <- (0:8)/8 1292aKnots <- c(rep(0, 4), c(0.3, 0.5, 0.6), rep(1, 4)) 1293assertErrV(splines::splineDesign(aKnots, x, derivs = 4)) 1294## gave seg.fault in R <= 3.4.1 1295 1296 1297## allow on.exit handlers to be added in LIFO order 1298x <- character(0) 1299f <- function() { 1300 on.exit(x <<- c(x, "first")) 1301 on.exit(x <<- c(x, "last"), add = TRUE, after = FALSE) 1302} 1303f() 1304stopifnot(identical(x, c("last", "first"))) 1305## 1306x <- character(0) 1307f <- function() { 1308 on.exit(x <<- c(x, "last"), add = TRUE, after = FALSE) 1309} 1310f() 1311stopifnot(identical(x, "last")) 1312 1313 1314## deparse(<symbol>) 1315##_reverted_for_now 1316##_ brc <- quote(`{`) 1317##_ stopifnot(identical(brc, eval(parse(text = deparse(brc, control="all"))))) 1318## default was to set backtick=FALSE so parse() failed in R <= 3.4.x 1319 1320 1321## sys.on.exit() is called in the correct frame 1322fn <- function() { 1323 on.exit("foo") 1324 identity(sys.on.exit()) 1325} 1326stopifnot(identical(fn(), "foo")) 1327 1328 1329## rep.POSIXt(*, by="n DSTdays") - PR#17342 1330x <- seq(as.POSIXct("1982-04-15 05:00", tz="US/Central"), 1331 as.POSIXct("1994-10-15", tz="US/Central"), by="360 DSTdays") 1332stopifnot(length(x) == 13, diff((as.numeric(x) - 39600)/86400) == 360) 1333## length(x) was 1802 and ended in many NA's in R <= 3.4.2 1334 1335 1336## 0-length logic with raw() 1337r0 <- raw(0) 1338stopifnot(exprs = { 1339 identical(r0 & r0, r0) 1340 identical(r0 | r0, r0) 1341}) 1342## gave logical(0) in R 3.4.[012] 1343 1344 1345## `[[` and `[[<-` indexing with <symbol> 1346x <- c(a=2, b=3) 1347x[[quote(b)]] <- pi 1348stopifnot(exprs = { 1349 identical(2, x[[quote(a)]]) 1350 identical(x, c(a=2, b=pi)) 1351}) 1352## `[[` only worked after fixing PR#17314, i.e., not in R <= 3.4.x 1353 1354 1355## range(<non-numeric>, finite = TRUE) 1356stopifnot(identical(0:1, range(c(NA,TRUE,FALSE), finite=TRUE))) 1357## gave NA's in R <= 3.4.2 1358 1359 1360## `[<-` : coercion should happen also in 0-length case: 1361x1 <- x0 <- x <- n0 <- numeric(); x0[] <- character(); x1[1[0]] <- character() 1362x[] <- numeric() 1363stopifnot(identical(x0, character()), identical(x1, x0), identical(x, n0)) 1364## x0, x1 had remained 'numeric()' in R <= 3.4.x 1365x[1] <- numeric(); stopifnot(identical(x, n0)) 1366## had always worked; just checking 1367NUL <- NULL 1368NUL[3] <- integer(0); NUL[,2] <- character() ; NUL[3,4,5] <- list() 1369stopifnot(is.null(NUL)) 1370## above had failed for one day in R-devel; next one always worked 1371NUL <- NULL; NUL[character()] <- "A" 1372stopifnot(identical(NUL, character())) 1373## 0-0-length subassignment should not change atomic to list: 1374ec <- e0 <- matrix(, 0, 4) # a 0 x 4 matrix 1375ec[,1:2] <- list() 1376x <- 1[0]; x[1:2] <- list() 1377a <- a0 <- array("", 0:2); a[,1,] <- expression() 1378stopifnot(exprs = { 1379 identical(ec, e0) 1380 identical(x, 1[0]) 1381 identical(a, a0) 1382})## failed for a couple of days in R-devel 1383 1384 1385## as.character(<list>) should keep names in some nested cases 1386cl <- 'list(list(a = 1, "B", ch = "CH", L = list(f = 7)))' 1387E <- expression(list(a = 1, "B", ch = "CH", L = list(f = 7))) 1388str(ll <- eval(parse(text = cl))) 1389stopifnot(exprs = { 1390 identical(eval(E), ll[[1]]) 1391 identical(as.character(E), as.character(ll) -> cll) 1392 grepl(cll, cl, fixed=TRUE) # currently, cl == paste0("list(", cll, ")") 1393 ## the last two have failed in R-devel for a while 1394 identical(as.character(list(list(one = 1))), "list(one = 1)") 1395 identical(as.character(list( c (one = 1))), "c(one = 1)") 1396})## the last gave "1" in all previous versions of R 1397 1398 1399## as.matrix( <data.frame in d.fr.> ) -- prompted by Patrick Perry, R-devel 2017-11-30 1400dm <- dd <- d1 <- data.frame(n = 1:3) 1401dd[[1]] <- d1 # -> 'dd' has "n" twice 1402dm[[1]] <- as.matrix(d1) # (ditto) 1403d. <- structure(list(d1), class = "data.frame", row.names = c(NA, -3L)) 1404d2. <- data.frame(ch = c("A","b"), m = 10:11) 1405d2 <- data.frame(V = 1:2); d2$V <- d2.; d2 1406d3 <- structure(list(A = 1:2, HH = cbind(c(.5, 1))), 1407 class = "data.frame", row.names=c(NA,-2L)) 1408d3.2 <- d3; d3.2 $HH <- diag(2) 1409d3.2.<- d3; d3.2.$HH <- matrix(1:4, 2,2, dimnames=list(NULL,c("x","y"))) 1410d0 <- as.data.frame(m0 <- matrix(,2,0)) 1411d3.0 <- d3; d3.0 $HH <- m0 1412d3.d0<- d3; d3.d0$HH <- d0 1413stopifnot(exprs = { 1414 identical(unname(as.matrix(d0)), m0) 1415 identCO (dd, d.) 1416 identical(as.matrix(d3.0 ), array(1:2, dim = 2:1, dimnames = list(NULL, "A")) -> m21) 1417 identical(as.matrix(d3.d0), m21) 1418 identical(as.matrix(dd), (cbind(n = 1:3) -> m.)) 1419 identical(as.matrix(d.), m.) 1420 identical(as.matrix(d2), array(c("A", "b", "10", "11"), c(2L, 2L), 1421 dimnames = list(NULL, c("V.ch", "V.m")))) 1422 identical(as.matrix(dm), m.) 1423 identical(as.matrix(d1), m.) 1424 identical(colnames(m2 <- as.matrix(d2)), c("V.ch", "V.m")) 1425 identical(colnames(as.matrix(d3 )), colnames(d3 )) # failed a few days 1426 identical(colnames(as.matrix(d3.2 )), colnames(format(d3.2 ))) 1427 identical(colnames(as.matrix(d3.2 )), c("A", paste("HH",1:2,sep="."))) 1428 identical(colnames(as.matrix(d3.2.)), colnames(format(d3.2.))) 1429 identical(colnames(as.matrix(d3.2.)), c("A", "HH.x", "HH.y")) 1430}) 1431## the first 5 as.matrix() have failed at least since R-1.9.1, 2004 1432 1433 1434## Impossible conditions should at least give a warning - PR#17345 1435tools::assertWarning( 1436 power.prop.test(n=30, p1=0.90, p2=NULL, power=0.8) 1437 ) ## may give error in future 1438## silently gave p2 = 1.03 > 1 in R versions v, 3.1.3 <= v <= 3.4.3 1439 1440 1441## 1) removeSource() [for a function w/ body containing NULL]: 1442op <- options(keep.source=TRUE) 1443bod <- quote( foo(x, NULL) ) 1444testf <- function(x) { }; body(testf)[[2]] <- bod 1445testf 1446testfN <- removeSource(testf) 1447stopifnot(identical(body(testf )[[2]], bod) 1448 , identical(body(testfN)[[2]], bod) 1449) 1450## erronously changed '(x, NULL)' to '(x)' in R version <= 3.4.3 1451## 1452## 2) source *should* be kept: 1453f <- function(x=1) { # 'x' not really needed 1454 x+x + 2*x+1 # (note spaces) 1455} 1456stopifnot(exprs = { 1457 identical(capture.output(f) -> fsrc, 1458 capture.output(print(f))) 1459 length(fsrc) == 3 1460 grepl("(x=1)", fsrc[1], fixed=TRUE) 1461 grepl("really needed", fsrc[1], fixed=TRUE) 1462 grepl("x + 2*x+1 # (note", fsrc[2], fixed=TRUE) 1463}) 1464options(op) 1465## (was fine, but not tested in R <= 3.5.0) 1466 1467 1468## ar.yw(x) with missing values in x, PR#17366 1469which(is.na(presidents)) # in 6 places 1470arp <- ar(presidents, na.action = na.pass) 1471## check "some" consistency with cheap imputation: 1472prF <- presidents 1473prF[is.na(presidents)] <- c(90, 37, 40, 32, 63, 66) # phantasy 1474arF <- ar(prF) 1475stopifnot(exprs = { 1476 all.equal(arp[c("order", "ar", "var.pred", "x.mean")], 1477 list(order = 3, ar = c(0.6665119, 0.2800927, -0.1716641), 1478 var.pred = 96.69082, x.mean = 56.30702), tol = 7e-7) 1479 all.equal(arp$ar, arF$ar, tol = 0.14) 1480 all.equal(arp$var.pred, arF$var.pred, tol = 0.005) 1481 all.equal(arp$asy.var.coef, arF$asy.var.coef, tol = 0.09) 1482}) 1483## Multivariate 1484set.seed(42) 1485n <- 1e5 1486(i <- sample(n, 12)) 1487u <- matrix(rnorm(2*n), n, 2) 1488y <- filter(u, filter=0.8, "recursive") 1489y. <- y; y.[i,] <- NA 1490est <- ar( y , aic = FALSE, order.max = 2) ## Estimate VAR(2) 1491es. <- ar( y. , aic = FALSE, order.max = 2, na.action=na.pass) 1492## checking ar.yw.default() multivariate case 1493estd <- ar(unclass(y) , aic = FALSE, order.max = 2) ## Estimate VAR(2) 1494es.d <- ar(unclass(y.), aic = FALSE, order.max = 2, na.action=na.pass) 1495stopifnot(exprs = { 1496 all.equal(est$ar[1,,], diag(0.8, 2), tol = 0.08)# seen 0.0038 1497 all.equal(est[1:6], es.[1:6], tol = 5e-3) 1498 all.equal(estd$x.mean, es.d$x.mean, tol = 0.01) # seen 0.0023 1499 all.equal(estd[c(1:3,5:6)], 1500 es.d[c(1:3,5:6)], tol = 1e-3)## seen {1,3,8}e-4 1501 all.equal(lapply(estd[1:6],unname), 1502 lapply(est [1:6],unname), tol = 2e-12)# almost identical 1503 all.equal(lapply(es.d[1:6],unname), 1504 lapply(es. [1:6],unname), tol = 1e-11) 1505}) 1506## NA's in x gave an error, in R versions <= 3.4.3 1507 1508 1509## as.list(<Date>) method: 1510toD <- Sys.Date(); stopifnot(identical(as.list(toD)[[1]], toD)) 1511## was wrong for 20 hours 1512 1513options(warn = 2)# no warnings allowed 1514 1515## PR#17372: sum(<ints whose sum overflows>, <higher type>) 1516iL <- rep(1073741824L, 2) # 2^30 + 2^30 = 2^31 integer overflows to NA 1517r1 <- tryCmsg(sum("foo", iL)) 1518r2 <- tryCmsg(sum(iL, "foo")) 1519stopifnot(exprs = { 1520 identical(r1, r2) 1521 grepl("invalid 'type' (character) ", r1, fixed=TRUE) 1522 ## each _gave_ an overflow warning + NA 1523 identical(sum(3.14, iL), sum(iL, 3.14)) 1524 identical(sum(1+2i, iL), sum(iL, 1+2i)) 1525 if(identical(.Machine$sizeof.longlong, 8L)) 1526 TRUE # no longer overflows early when we have LONG_INT : 1527 else { # no LONG_INT [very rare in 2018-02 !] 1528 identical(sum(3.14, iL), NA_real_) && 1529 identical(sum(1+2i, iL), NA_complex_) 1530 } 1531}) 1532## r2 was no error and sum(iL, 1+2i) gave NA_real_ in R <= 3.4.x 1533## Was PR#1408 Inconsistencies in sum() {in ./reg-tests-2.R} 1534x <- as.integer(2^31 - 1)## = 2147483647L = .Machine$integer.max ("everywhere") 1535x24 <- rep.int(x, 2^24) # sum = 2^55 - 2^24 1536stopifnot(exprs = { 1537 sum(x, x) == 2^32-2 # did not warn in 1.4.1 -- no longer overflows in 3.5.0 1538 sum(c(x,x)) ==(2^32-2 -> sx2) # did warn -- no longer overflows 1539 (z <- sum(x, x, 0.0)) == sx2 # was NA in 1.4.1 1540 typeof(z) == "double" 1541 is.integer(x24) 1542 sum(x24) == 2^55 - 2^24 # was NA (+ warning) in R <= 3.4.x 1543}) 1544 1545 1546## aggregate.data.frame(*, drop=FALSE) wishlist PR#17280 1547## [continued from above] 1548aF <- aggregate(dP, by=by, FUN=mean, drop=FALSE) 1549lF <- aggregate(dP, by=by, FUN=length, drop=FALSE) 1550stopifnot(exprs = { 1551 identical(dim(aF), c(8L, 3L)) 1552 identical(aF[6,3], NA_real_) 1553 identical(lF[6,3], NA_integer_) 1554}) 1555DF <- data.frame(a=rep(1:3,4), b=factor(rep(1:2,6), levels=1:3)) 1556aT <- aggregate(DF["a"], DF["b"], length)# drop=TRUE 1557aF <- aggregate(DF["a"], DF["b"], length, drop=FALSE) 1558stopifnot(exprs = { 1559 identical(dim(aT), c(2L,2L)) 1560 identical(dim(aF), c(3L,2L)) 1561 identical(aT, aF[1:2,]) 1562 identical(aF[3,"a"], NA_integer_) 1563 }) 1564## In R <= 3.4.x, the function (FUN) was called on empty sets, above, 1565## giving NaN (and 0) or <nothing>; now the result is NA. 1566 1567 1568## PR#16107 is.na(NULL) throws warning (contrary to all other such calls) 1569stopifnot(identical(is.na(NULL), logical(0))) 1570## gave a warning in R <= 3.4.x 1571 1572 1573## subtle [[<- , e.g., <nestedList>[[ c(i,j,k) ]] <- val : 1574xx0 <- 1575xx <- list(id = 1L, 1576 split = list(varid = 1L, breaks = NULL, 1577 index = 1:3, right = TRUE, info = "s"), 1578 kids = list(id = 2L, 1579 split = list(varid = 3L, breaks = 75, 1580 right = TRUE, info = "KS"), 1581 kids = list(list(id = 3L, info = "yes"), 1582 list(id = 4L, info = "no")), 1583 info = NULL), 1584 list(id = 5L, 1585 split = list(varid = 3L, breaks = 20, 1586 right = TRUE, info = "4s"), 1587 kids = list(list(id = 6L, info = "no"), 1588 list(id = 7L, info = "yes")), 1589 info = NULL), 1590 info = NULL) 1591 1592## no-ops: 1593xx[[1]] <- xx0[[1]] 1594xx[["kids"]] <- xx0[["kids"]] 1595xx[[2:1]] <- xx0[[2:1]] ; stopifnot(identical(xx, xx0)) 1596xx[[3:1]] <- xx0[[3:1]] ; stopifnot(identical(xx, xx0)) # (err) 1597## replacements 1598 xx[[c(2,3)]] <- 5:3 1599 xx[[c(4,2,4)]] <- c(4,2,c=4) # (err: wrong xx) 1600 xx[[c(4,2,3)]] <- c(ch="423")# (err) 1601 xx[[c(3,2,2)]] <- 47 # (err) 1602stopifnot(exprs = { 1603 identical(xx[[c(2,3)]], 5:3) 1604 identical(xx[[c(4,2,4)]], c(4,2,c=4)) 1605 identical(xx[[c(4,2,3)]], c(ch="423")) 1606 identical(xx[[c(3,2,2)]], 47) 1607 identical(lengths(xx), lengths(xx0)) 1608 identical( names(xx), names(xx0)) 1609 identical(lapply(xx, lengths), 1610 lapply(xx0,lengths)) 1611 identical(lapply(xx, names), 1612 lapply(xx0,names)) 1613}) 1614## several of these failed for a bit more than a day in R-devel 1615 1616 1617## PR#17369 and PR#17381 -- duplicated() & unique() data frame methods: 1618d22 <- data.frame(x = c(.3 + .6, .9), y = 1) 1619d21 <- d22[,"x", drop=FALSE] 1620dRT <- data.frame(x = c("\r", "\r\r"), y = c("\r\r", "\r")) 1621stopifnot(exprs = { 1622 identical(unique(d22), d22) # err 1623 is.data.frame(d21) 1624 identical(dim(d21), 2:1) 1625 identical(unique(d21), d21) 1626 identical(unique(dRT), dRT) # err 1627 }) 1628## with a POSIXct column (with tz during Daylight Saving change): 1629Sys.setenv("TZ" = "Australia/Melbourne") # <== crucial (for most)! 1630x <- as.POSIXct(paste0("2013-04-06 ", 13:17, ":00:00"), tz = "UTC") 1631attr(x, "tzone") <- "" 1632(xMelb <- as.POSIXct(x, tz = "Australia/Melbourne"))# shows both AEDT & AEST 1633dMb <- data.frame(x = xMelb, y = 1) 1634stopifnot(exprs = { 1635 identical(unique(dMb), dMb) 1636 identical(anyDuplicated(dMb), 0L) 1637}) # both differing in R <= 3.4.x 1638 1639 1640## when sep is given, an opening quote may be preceded by non-space 1641stopifnot( ncol(read.table( text="=\"Total\t\"\t1\n",sep="\t")) == 2) 1642stopifnot(length(scan(what=list("foo",1), text="=\"Total\t\"\t1\n",sep="\t")) == 2) 1643## 1644## in 3.4.x, read.table failed on this 1645stopifnot( ncol(read.table( text="=\"CJ01 \"\t550\n",sep="\t")) == 2) 1646stopifnot(length(scan(what=list("foo",1), text="=\"CJ01 \"\t550\n",sep="\t")) == 2) 1647## 1648## when no sep is given, quotes preceded by non-space have no special 1649## meaning and are retained (related to PR#15245) 1650stopifnot(read.table( text="HO5\'\'\tH")[1,1] == "HO5\'\'") 1651stopifnot(read.table( text="HO5\'\tH")[1,1] == "HO5\'") 1652stopifnot(scan(what=list("foo","foo"),text="HO5\'\'\tH")[[1]] == "HO5\'\'") 1653stopifnot(scan(what=list("foo","foo"),text="HO5\'\tH")[[1]] == "HO5\'") 1654## 1655## when no sep is given, there does not have to be a separator between 1656## quoted entries; testing here to ensure read.table and scan agree, 1657## but without claiming this particular behavior is needed 1658stopifnot(read.table( text="\"A\"\" B \"")$V2 == " B ") 1659stopifnot(scan(what=list("foo","foo"),text="\"A\"\" B \"")[[2]] == " B ") 1660 1661 1662## merge() names when by.y 1663parents <- data.frame(name = c("Sarah", "Max", "Qin", "Lex"), 1664 sex = c("F", "M", "F", "M"), age = c(41, 43, 36, 51)) 1665children <- data.frame(parent = c("Sarah", "Max", "Qin"), 1666 name = c("Oliver", "Sebastian", "Kai-lee"), 1667 sex = c("M", "M", "F"), age = c(5,8,7)) 1668# merge.data.frame() no longer creating a duplicated col.names 1669(m <- merge(parents, children, by.x = "name", by.y = "parent")) 1670 m._ <- merge(parents, children, by.x = "name", by.y = "parent", all.x=TRUE) 1671(m_. <- merge(parents, children, by.x = "name", by.y = "parent", all.y=TRUE)) 1672 m__ <- merge(parents, children, by.x = "name", by.y = "parent", all = TRUE) 1673## all four gave duplicate column 'name' with a warning in R <= 3.4.x 1674stopifnot(exprs = { 1675 identical(m, m_.) 1676 identical(m._, m__) 1677 ## not identical(m, m__[-1,]) : row.names differ 1678 identical(names(m), names(m__)) 1679 all(m == m__[-1,]) 1680 identical(dim(m), c(3L, 6L)) 1681 identical(dim(m__), c(4L, 6L)) 1682}) 1683 1684 1685## scale(*, <non-numeric>) 1686if(requireNamespace('Matrix', lib.loc=.Library, quietly = TRUE)) { 1687 de <- data.frame(Type = structure(c(1L, 1L, 4L, 1L, 4L, 2L, 2L, 2L, 4L, 1L), 1688 .Label = paste0("T", 1:4), class = "factor"), 1689 Subj = structure(c(9L, 5L, 8L, 3L, 3L, 4L, 3L, 6L, 6L, 1L), 1690 .Label = as.character(1:9), class = "factor")) 1691 show(SM <- xtabs(~ Type + Subj, data = de, sparse=TRUE)) 1692 stopifnot(exprs = { 1693 inherits(SM, "sparseMatrix") 1694 all.equal(scale(SM, Matrix::colMeans(SM)), 1695 scale(SM, Matrix::colMeans(SM, sparse=TRUE)), 1696 check.attributes=FALSE) 1697 }) 1698} 1699## 2nd scale() gave wrong error "length of 'center' must equal [..] columns of 'x'" 1700## in R <= 3.4.x 1701 1702 1703## as.data.frame.matrix() method not eliminating duplicated rownames 1704(m <- rbind(x = 1:3, x = 2:4, z = 0)) # matrix with duplicated rownams 1705rownames(d <- as.data.frame(m)) # --> fixed up to "x" "x.1" "z" 1706## new feature -- 'make.names = *' with '*' in non-defaults : 1707dN <- as.data.frame(m, make.names=NA) 1708tools::assertError( dF <- as.data.frame(m, make.names=FALSE) ) 1709stopifnot(exprs = { 1710 !anyDuplicated(rownames(d)) 1711 identical(colnames(d), paste0("V", 1:3)) 1712 ## dN has correct automatic row names: 1713 identical(.row_names_info(dN, 0), .set_row_names(3L)) 1714}) 1715## as.data.frame(m) kept the duplicated row names in R 3.4.x 1716 1717 1718## check that sorting preserves names and no other attributes 1719v <- sort(c(1,2,3)) 1720names(v) <- letters[1:3] 1721stopifnot(identical(sort(v), v)) 1722vv <- sort(c(1,2,3)) 1723names(vv) <- names(v) 1724attr(vv, "foo") <- "bar" 1725stopifnot(identical(sort(vv), v)) 1726## failed initially in ALTREP 1727 1728 1729## check that "TRUE", "FALSE" work in order, sort.int 1730order(1:3, decreasing = "TRUE") 1731order(1:3, decreasing = "FALSE") 1732sort.int(1:3, decreasing = "TRUE") 1733sort.int(1:3, decreasing = "FALSE") 1734## failed initially in ALTREP 1735 1736## this failed until 3.5.x 1737c1 <- c(1,1,2,2) 1738c2 <- as.Date(c("2010-1-1", "2011-1-1", "2013-1-1", "2012-1-1")) 1739order(c1, c2, decreasing = c(TRUE, FALSE), method="radix") 1740 1741 1742## check sort argument combinations 1743sort(1:3, decreasing = TRUE, na.last = NA) 1744sort(1:3, decreasing = TRUE, na.last = TRUE) 1745sort(1:3, decreasing = TRUE, na.last = FALSE) 1746sort(1:3, decreasing = FALSE, na.last = NA) 1747sort(1:3, decreasing = FALSE, na.last = TRUE) 1748sort(1:3, decreasing = FALSE, na.last = FALSE) 1749 1750## match.arg()s 'choices' evaluation, PR#17401 1751f <- function(x = y) { 1752 y <- c("a", "b") 1753 match.arg(x) 1754} 1755stopifnot(identical(f(), "a")) 1756## failed in R <= 3.4.x 1757 1758 1759## getOption(op, def) -- where 'def' is missing (passed down): 1760getO <- function(op, def) getOption(op, def) 1761stopifnot(is.null(getO("foobar"))) 1762## failed for a few days in R-devel, when using MD's proposal of PR#17394, 1763## notably "killing" parallelMap::getParallelOptions() 1764 1765 1766## Mantel-Haenszel test in "large" case, PR#17383: 1767set.seed(101); n <- 500000 1768aTab <- table( 1769 educ = factor(sample(1:3, replace=TRUE, size=n)), 1770 score= factor(sample(1:5, replace=TRUE, size=n)), 1771 sex = sample(c("M","F"), replace=TRUE, size=n)) 1772(MT <- mantelhaen.test(aTab)) 1773stopifnot(all.equal( 1774 lapply(MT[1:3], unname), 1775 list(statistic = 9.285642, parameter = 8, p.value = 0.3187756), tol = 6e-6)) 1776## gave integer overflow and error in R <= 3.4.x 1777 1778 1779## check for incorect inlining of named logicals 1780foo <- compiler::cmpfun(function() c("bar" = TRUE), 1781 options = list(optimize = 3)) 1782stopifnot(identical(names(foo()), "bar")) 1783foo <- compiler::cmpfun(function() c("bar" = FALSE), 1784 options = list(optimize = 3)) 1785stopifnot(identical(names(foo()), "bar")) 1786## Failed after changes to use isTRUE/isFALSE instead of identical in r74403. 1787 1788 1789## check that reverse sort is stable 1790x <- sort(c(1, 1, 3)) 1791stopifnot(identical(sort.list(x, decreasing=TRUE), as.integer(c(3, 1, 2)))) 1792stopifnot(identical(order(x, decreasing=TRUE), as.integer(c(3, 1, 2)))) 1793## was incorrect with wrapper optimization (reported by Suharto Anggono) 1794 1795 1796## dump() & dput() where influenced by "deparse.max.lines" option 1797op <- options(deparse.max.lines=NULL) # here 1798oNam <- "simplify2array" # (base function which is not very small) 1799fn <- get(oNam) 1800ffn <- format(fn) 1801dp.1 <- capture.output(dput(fn)) 1802dump(oNam, textConnection("du.1", "w")) 1803stopifnot(length(ffn) > 3, identical(dp.1, ffn), identical(du.1[-1], dp.1)) 1804options(deparse.max.lines = 2) ## "truncate heavily" 1805dp.2 <- capture.output(dput(fn)) 1806dump(oNam, textConnection("du.2", "w")) 1807stopifnot(identical(dp.2, dp.1), 1808 identical(du.2, du.1)) 1809options(op); rm(du.1, du.2) # connections 1810writeLines(tail(dp.2)) 1811## dp.2 and du.2 where heavily truncated in R <= 3.4.4, ending " ..." 1812 1813 1814## optim() with "trivial bounds" 1815flb <- function(x) { p <- length(x); sum(c(1, rep(4, p-1)) * (x - c(1, x[-p])^2)^2) } 1816o1 <- optim(rep(3, 5), flb) 1817o2 <- optim(rep(3, 5), flb, lower = rep(-Inf, 5)) 1818stopifnot(all.equal(o1,o2)) 1819## the 2nd optim() call gave a warning and switched to "L-BFGS-B" in R <= 3.5.0 1820 1821 1822## Check that call matching doesn't mutate input 1823cl <- as.call(list(quote(x[0]))) 1824cl[[1]][[3]] <- 1 1825v <- .Internal(match.call(function(x) NULL, cl, TRUE, .GlobalEnv)) 1826cl[[1]][[3]] <- 2 1827stopifnot(v[[1]][[3]] == 1) 1828## initial patch proposal to reduce duplicating failed on this 1829 1830 1831## simulate.lm(<glm gaussian, non-default-link>), PR#17415 1832set.seed(7); y <- rnorm(n = 1000, mean = 10, sd = sqrt(10)) 1833fmglm <- glm(y ~ 1, family = gaussian(link = "log")) 1834dv <- apply(s <- simulate(fmglm, 99, seed=1), 2, var) - var(y) 1835stopifnot(abs(dv) < 1.14, abs(mean(dv)) < .07) 1836## failed in R <= 3.5.0 (had simulated variances ~ 0.1) 1837 1838 1839## unlist() failed for nested lists of empty lists: 1840isLF <- function(x) .Internal(islistfactor(x, recursive=TRUE)) 1841ex <- list(x0 = list() 1842 , x1 = list(list()) 1843 , x12 = list(list(), list()) 1844 , x12. = list(list(), expression(list())) 1845 , x2 = list(list(list(), list())) # <-- Steven Nydick's example 1846 , x212 = list(list(list(), list(list()))) 1847 , x222 = list(list(list(list()), list(list()))) 1848) 1849(exis <- vapply(ex, isLF, NA)) 1850ue <- lapply(ex, unlist)# gave errors in R <= 3.3.x but not 3.{4.x,5.0} 1851stopifnot(exprs = { 1852 !any(exis) 1853 identical(names(ue), names(ex)) 1854 vapply(ue[names(ue) != "x12."], is.null, NA) 1855}) 1856 1857 1858## qr.coef(qr(<all 0, w/ colnames>)) 1859qx <- qr(x <- matrix(0, 10, 2, dimnames = list(NULL, paste0("x", 1:2)))) 1860qc <- qr.coef(qx, x[,1]) 1861stopifnot(identical(qc, c(x1 = NA_real_, x2 = NA_real_))) 1862## qr.coef() gave Error ...: object 'pivotted' not found | in R <= 3.5.0 1863 1864 1865## unlist(<factor-leaves>) 1866x <- list(list(v=factor("a"))) 1867y <- list(data.frame(v=factor("a"))) 1868x. <- list(list(factor("a")), list(factor(LETTERS[2:4])), factor("lol")) 1869fN <- factor(LETTERS[c(2:4,30)]) 1870xN <- list(list(factor("a")), list(list(fN)), L=factor("lol")) 1871stopifnot(exprs = { 1872 .valid.factor(ux <- unlist(x)) 1873 identical(ux, unlist(y)) 1874 identical(ux, as.factor(c(v="a"))) 1875 .valid.factor(ux. <- unlist(x.)) 1876 .valid.factor(uxN <- unlist(xN)) 1877 identical(levels(ux.), c("a", "B", "C", "D", "lol")) 1878 identical(levels (uxN), levels(ux.)) 1879 identical(as.character(uxN), levels(ux.)[c(1:4,11L,5L)]) 1880}) 1881## gave invalid factor()s [if at all] 1882 1883 1884## printCoefMat() w/ unusual arguments 1885cm <- matrix(c(9.2, 2.5, 3.6, 0.00031), 1, 4, 1886 dimnames = list("beta", c("Estimate", "Std.Err", "Z value", "Pr(>z)"))) 1887cc <- capture.output(printCoefmat(cm)) 1888stopifnot(grepl(" [*]{3}$", cc[2]), 1889 identical(cc, capture.output( 1890 printCoefmat(cm, right=TRUE)))) 1891## gave Error: 'formal argument "right" matched by multiple actual arguments' 1892 1893 1894## print.noquote() w/ unusual argument -- inspite of user error, be forgiving: 1895print(structure("foo bar", class="noquote"), quote=FALSE) 1896## gave Error: 'formal argument "quote" matched by multiple actual arguments' 1897 1898 1899## agrep(".|.", ch, fixed=FALSE) 1900chvec <- c(".BCD", "yz", "AB", "wyz") 1901patt <- "ABC|xyz" 1902stopifnot(identical(c(list(0L[0]), rep(list(1:4), 2)), 1903 lapply(0:2, function(m) agrep(patt, chvec, max.distance=m, fixed=FALSE)) 1904)) 1905## all three were empty in R <= 3.5.0 1906 1907 1908## str(<invalid>) 1909typeof(nn <- c(0xc4, 0x88, 0xa9, 0x02)) 1910cc <- ch <- rawToChar(as.raw(nn)) 1911str(ch)# worked already 1912nchar(cc, type="bytes")# 4, but nchar(cc) gives "invalid multibyte string" 1913Encoding(cc) <- "UTF-8" # << makes it invalid for strtrim(.)! 1914as.octmode(as.integer(nn)) 1915str(cc) 1916## In R <= 3.5.0, [strtrim() & nchar()] gave invalid multibyte string at '<a9>\002"' 1917 1918 1919## multivariate <empty model> lm(): 1920y <- matrix(cos(1:(7*5)), 7,5) # <- multivariate y 1921lms <- list(m0 = lm(y ~ 0), m1 = lm(y ~ 1), m2 = lm(y ~ exp(y[,1]^2))) 1922dcf <- sapply(lms, function(fm) dim(coef(fm))) 1923stopifnot(dcf[1,] == 0:2, dcf[2,] == 5) 1924## coef(lm(y ~ 0)) had 3 instead of 5 columns in R <= 3.5.1 1925proc.time() - .pt; .pt <- proc.time() 1926 1927 1928## confint(<mlm>) 1929n <- 20 1930set.seed(1234) 1931datf <- local({ 1932 x1 <- rnorm(n) 1933 x2 <- x1^2 + rnorm(n) 1934 y1 <- 100*x1 + 20*x2 + rnorm(n) 1935 data.frame(x1=x1, x2=x2, y1=y1, y2 = y1 + 10*x1 + 50*x2 + rnorm(n)) 1936}) 1937fitm <- lm(cbind(y1,y2) ~ x1 + x2, data=datf) 1938zapsmall(CI <- confint(fitm)) 1939ciT <- cbind(c(-0.98031, 99.2304, 19.6859, -0.72741, 109.354, 69.4632), 1940 c( 0.00984, 100.179, 20.1709, 0.60374, 110.63, 70.1152)) 1941dimnames(ciT) <- dimnames(CI) 1942## also checking confint(*, parm=*) : 1943pL <- list(c(1,3:4), rownames(CI)[c(6,2)], 1) 1944ciL <- lapply(pL, function(ii) confint(fitm, parm=ii)) 1945ciTL <- lapply(pL, function(ii) ciT[ii, , drop=FALSE]) 1946stopifnot(exprs = { 1947 all.equal(ciT, CI, tolerance = 4e-6) 1948 all.equal(ciL, ciTL,tolerance = 8e-6) 1949}) 1950## confint(<mlm>) gave an empty matrix in R <= 3.5.1 1951## For an *empty* mlm : 1952mlm0 <- lm(cbind(y1,y2) ~ 0, datf) 1953stopifnot(identical(confint(mlm0), 1954 matrix(numeric(0), 0L, 2L, dimnames = list(NULL, c("2.5 %", "97.5 %"))))) 1955## failed inside vcov.mlm() because summary.lm()$cov.unscaled was NULL 1956 1957## cooks.distance.(<mlm>), rstandard(<mlm>) : 1958fm1 <- lm(y1 ~ x1 + x2, data=datf) 1959fm2 <- lm(y2 ~ x1 + x2, data=datf) 1960stopifnot(exprs = { 1961 all.equal(cooks.distance(fitm), 1962 cbind(y1 = cooks.distance(fm1), 1963 y2 = cooks.distance(fm2))) 1964 all.equal(rstandard(fitm), 1965 cbind(y1 = rstandard(fm1), 1966 y2 = rstandard(fm2))) 1967 all.equal(rstudent(fitm), 1968 cbind(y1 = rstudent(fm1), 1969 y2 = rstudent(fm2))) 1970}) 1971## were silently wrong in R <= 3.5.1 1972 1973 1974## kruskal.test(<non-numeric g>), PR#16719 1975data(mtcars) 1976mtcars$type <- rep(letters[1:2], c(16, 16)) 1977kruskal.test(mpg ~ type, mtcars) 1978## gave 'Error: all group levels must be finite' 1979 1980 1981## Multivariate lm() with matrix offset, PR#17407 1982ss <- list(s1 = summary(fm1 <- lm(cbind(mpg,qsec) ~ 1, data=mtcars, offset=cbind(wt,wt*2))), 1983 s2 = summary(fm2 <- lm(cbind(mpg,qsec) ~ offset(cbind(wt,wt*2)), data=mtcars))) 1984## drop "call" and "terms" parts which differ; rest must match: 1985ss[] <- lapply(ss, function(s) lapply(s, function(R) R[setdiff(names(R), c("call","terms"))])) 1986stopifnot(all.equal(ss[["s1"]], ss[["s2"]], tolerance = 1e-15)) 1987## lm() calls gave error 'number of offsets is 64, should equal 32 ...' in R <= 3.5.1 1988 1989 1990## print.data.frame(<non-small>) 1991USJ <- USJudgeRatings 1992USJe6 <- USJudgeRatings[rep_len(seq_len(nrow(USJ)), 1e6),] 1993op <- options(max.print=500) 1994system.time(r1 <- print(USJ)) 1995system.time(r2 <- print(USJe6))# was > 12 sec in R <= 3.5.1, now typically 0.01 1996 # because the whole data frame was formatted. 1997## Now the timing ratio between r1 & r2 print()ing is typically in [1,2] 1998system.time(r3 <- print(USJe6, row.names=FALSE)) 1999out <- capture.output(print(USJe6, max = 600)) # max > getOption("max.print") 2000stopifnot(exprs = { 2001 identical(r1, USJ )# print() must return its arg 2002 identical(r2, USJe6) 2003 identical(r3, USJe6) 2004 length(out) == 52 2005 grepl("CALLAHAN", out[51], fixed=TRUE) 2006 identical(2L, grep("omitted", out[51:52], fixed=TRUE)) 2007}) 2008options(op); rm(USJe6)# reset 2009 2010 2011## hist.default() in rare cases 2012hh <- hist(seq(1e6, 2e6, by=20), plot=FALSE) 2013hd <- hh$density*1e6 2014stopifnot(0.999 <= hd, hd <= 1.001) 2015## in R <= 3.5.1: warning 'In n * h : NAs produced by integer overflow' and then NA's 2016 2017 2018## some things broken by sort.int optimization for sorted integer vectors 2019sort.int(integer(0)) ## would segfault with barrier testing 2020stopifnot(identical(sort.int(NA_integer_), integer(0))) 2021 2022 2023## attribute handling in the fastpass was not quite right 2024x <- sort.int(c(1,2)) 2025dim(x) <- 2 2026dimnames(x) <- list(c("a", "b")) 2027stopifnot(! is.null(names(sort.int(x)))) 2028 2029## is.unsorted fastpass incorrectly returned TRUE when constant-valued x was sorted descending 2030x <- c(1, 1, 1) 2031xs <- sort(x, decreasing = TRUE) 2032stopifnot(!is.unsorted(xs, strictly = FALSE)) ## is.unsorted should be FALSE 2033y <- as.integer(x) 2034ys <- sort(x, decreasing = TRUE) 2035stopifnot(!is.unsorted(ys, strictly = FALSE)) 2036 2037## match() with length one x and POSIXlt table (PR#17459): 2038d <- as.POSIXlt("2018-01-01") 2039match(0, d) 2040## Gave a segfault in R < 3.6.0. 2041proc.time() - .pt; .pt <- proc.time() 2042 2043 2044## as(1L, "double") - PR#17457 2045stopifnot(exprs = { 2046 identical(as(1L, "double"), 1.) # new 2047 identical(new("double"), double()) 2048 ## 1. "double" is quite the same as "numeric" : 2049 local({ 2050 i1 <- 1L; as(i1, "numeric") <- pi 2051 i2 <- 1L; as(i2, "double" ) <- pi 2052 identical(i1, i2) 2053 }) 2054 validObject(Dbl <- getClass("double")) 2055 validObject(Num <- getClass("numeric")) 2056 c("double", "numeric") %in% extends(Dbl) 2057 setdiff(names(Num@subclasses), 2058 names(Dbl@subclasses) -> dblSub) == "double" 2059 "integer" %in% dblSub 2060 ## 2. These all remain as they were in R <= 3.5.x , the first one important for back-compatibility: 2061 identical(1:2, local({ 2062 myN <- setClass("myN", contains="numeric", slots = c(truly = "numeric")) 2063 myN(log(1:2), truly = 1:2) })@truly) 2064 removeClass("myN") 2065 identical(as(1L, "numeric"), 1L) # << disputable, but hard to change w/o changing myN() behavior 2066 identical(as(TRUE, "double"), 1.) 2067 identical(as(TRUE,"numeric"), 1.) 2068 !is(TRUE, "numeric") # "logical" should _not_ be a subclass of "numeric" 2069 ## We agree these should not change : 2070 typeof(1.0) == "double" & typeof(1L) == "integer" 2071 class (1.0) == "numeric" & class (1L) == "integer" 2072 mode (1.0) == "numeric" & mode (1L) == "numeric" 2073}) 2074## as(*, "double") now gives what was promised 2075 2076 2077## next(n) for largish n 2078stopifnot(exprs = { 2079 nextn(214e7 ) == 2^31 2080 nextn(2^32+1) == 4299816960 2081 identical(nextn(NULL), integer()) 2082}) 2083## nextn(214e7) hang in infinite loop; nextn(<large>) gave NA in R <= 3.5.1 2084 2085 2086## More strictness in '&&' and '||' : 2087Sys.getenv("_R_CHECK_LENGTH_1_LOGIC2_", unset=NA) -> oEV 2088Sys.setenv("_R_CHECK_LENGTH_1_LOGIC2_" = "warn") # only warn 2089tools::assertWarning(1 && 0:1) 2090Sys.setenv("_R_CHECK_LENGTH_1_LOGIC2_" = TRUE) # => error (when triggered) 2091tools::assertError(0 || 0:1) 2092if(is.na(oEV)) { # (by default) 2093 Sys.unsetenv ("_R_CHECK_LENGTH_1_LOGIC2_") 2094 2 && 0:1 # should not even warn 2095} else Sys.setenv("_R_CHECK_LENGTH_1_LOGIC2_" = oEV) 2096 2097 2098## polym() in "vector" case PR#17474 2099fm <- lm(Petal.Length ~ poly(cbind(Petal.Width, Sepal.Length), 2), 2100 data = iris) 2101p1 <- predict(fm, newdata = data.frame(Petal.Width = 1, Sepal.Length = 1)) 2102stopifnot(all.equal(p1, c("1" = 4.70107678))) 2103## predict() calling polym() failed in R <= 3.5.1 2104 2105 2106## sample.int(<fractional>, k, replace=TRUE) : 2107(tt <- table(sample.int(2.9, 1e6, replace=TRUE))) 2108stopifnot(length(tt) == 2) 2109## did "fractionally" sample '3' as well in 3.0.0 <= R <= 3.5.1 2110 2111 2112## lm.influence() for simple regression through 0: 2113x <- 1:7 2114y <- c(1.1, 1.9, 2.8, 4, 4.9, 6.1, 7) 2115f0 <- lm(y ~ 0+x) 2116mi <- lm.influence(f0) 2117stopifnot(identical(dim(cf <- mi$coefficients), c(7L, 1L)), 2118 all.equal(range(cf), c(-0.0042857143, 0.0072527473))) 2119## gave an error for a few days in R-devel 2120 2121 2122## cut(<constant 0>), PR#16802 2123c0 <- cut(rep(0L, 7), breaks = 3) 2124stopifnot(is.factor(c0), length(c0) == 7, length(unique(c0)) == 1) 2125## cut() gave error _'breaks' are not unique_ in R <= 3.5.1 2126 2127 2128## need to record OutDec in deferred string conversions (reported by 2129## Michael Sannella). 2130op <- options(scipen=-5, OutDec=",") 2131xx <- as.character(123.456) 2132options(op) 2133stopifnot(identical(xx, "1,23456e+02")) 2134 2135 2136## parseRd() and Rd2HTML() with some \Sexpr{} in *.Rd: 2137x <- tools::Rd_db("base") 2138## Now check that \Sexpr{} "installed" correctly: 2139of <- textConnection("DThtml", "w") 2140tools::Rd2HTML(x$DateTimeClasses.Rd, out = of, stages = "install"); close(of) 2141(iLeap <- grep("leap seconds", DThtml)[[1]]) 2142stopifnot(exprs = { 2143 grepl("[0-9]+ days", DThtml[iLeap+ 1]) 2144 any(grepl("20[1-9][0-9]-01", DThtml[iLeap+ 2:4])) 2145}) 2146 2147 2148 2149## if( "length > 1" ) buglet in plot.data.frame() 2150Sys.getenv("_R_CHECK_LENGTH_1_CONDITION_", unset=NA) -> oEV 2151Sys.setenv("_R_CHECK_LENGTH_1_CONDITION_" = "true") 2152plot(data.frame(.leap.seconds)) 2153if(!is.na(oEV)) Sys.setenv("_R_CHECK_LENGTH_1_CONDITION_" = oEV) 2154## gave Error in ... the condition has length > 1, in R <= 3.5.1 2155 2156 2157## duplicated(<dataframe with 'f' col>) -- PR#17485 2158d <- data.frame(f=gl(3,5), i=1:3) 2159stopifnot(exprs = { 2160 identical(which(duplicated(d)), c(4:5, 9:10, 14:15)) 2161 identical(anyDuplicated(d), 4L) 2162 identical(anyDuplicated(d[1:3,]), 0L) 2163}) 2164## gave error from do.call(Map, ..) as Map()'s first arg. is 'f' 2165 2166 2167## print.POSIX[cl]t() - not correctly obeying "max.print" option 2168op <- options(max.print = 50, width = 85) 2169cc <- capture.output(print(dt <- .POSIXct(154e7 + (0:200)*60))) 2170c2 <- capture.output(print(dt, max = 6)) 2171writeLines(tail(cc, 4)) 2172writeLines(c2) 2173stopifnot(expr = { 2174 grepl("omitted 151 entries", tail(cc, 1)) 2175 !anyDuplicated(tail(cc, 2)) 2176 grepl("omitted 195 entries", tail(c2, 1)) 2177}); options(op) 2178## the omission had been reported twice because of a typo in R <= 3.5.1 2179 2180 2181## <data.frame>[ <empty>, ] <- v should be a no-op and 2182## <data.frame>[ <empty>, <existing column>] <- v a no-op, too 2183df <- d0 <- data.frame(i=1:6, p=pi) 2184n <- nrow(df) 2185as1NA <- function(x) `is.na<-`(rep_len(unlist(x), 1L), TRUE) 2186for(i in list(FALSE, integer(), -seq_len(n))) 2187 for(value in list(numeric(), 7, "foo", list(1))) { 2188 df[i , ] <- value 2189 df[i , 1] <- value # had failed after svn c75474 2190 stopifnot(identical(df, d0)) 2191 ## "expand": new column created even for empty <i>; some packages rely on this 2192 df[i, "new"] <- value ## -> produces new column of .. NA 2193 stopifnot(identical(df[,"new"], rep(as1NA(value), n))) 2194 df <- d0 2195 } 2196## gave error in R <= 3.5.1 2197df[7:12,] <- d0 + 1L 2198stopifnot(exprs = { 2199 is.data.frame(df) 2200 identical(dim(df), c(12L, 2L)) 2201 identical(df[1:6,], d0) 2202}) 2203## had failed after svn c75474 2204 2205 2206## Check that active binding uses primitive quote() and doesn't pick 2207## up `quote` binding on the search path 2208quote <- function(...) stop("shouldn't be called") 2209if (exists("foo", inherits = FALSE)) rm(foo) 2210makeActiveBinding("foo", identity, environment()) 2211x <- (foo <- "foo") 2212stopifnot(identical(x, "foo")) 2213rm(quote, foo, x) 2214 2215 2216## .format.zeros() when zero.print is "wide": 2217x <- c(outer(c(1,3,6),10^(-5:0))) 2218(fx <- formatC(x)) 2219stopifnot(identical(nchar(fx), rep(c(5L, 6:3, 1L), each=3))) 2220x3 <- round(x, 3) 2221tools::assertWarning( 2222 fz1. <- formatC(x3, zero.print="< 0.001", replace.zero=FALSE))# old default 2223 (fz1 <- formatC(x3, zero.print="< 0.001"))#,replace.zero=TRUE : new default 2224 (fzw7 <- formatC(x3, width=7, zero.print="< 0.001")) 2225for(fz in list(fz1, fz1., fzw7)) stopifnot(identical(grepl("<", fz), x3 == 0)) 2226## fz1, fzw7 gave error (for 2 bugs) in R <= 3.5.x 2227 2228 2229## Attempting to modify an object in a locked binding could succeed 2230## before signaling an error: 2231foo <- function() { 2232 zero <- 0 ## to fool constant folding 2233 x <- 1 + zero ## value of 'x' has one reference 2234 lockBinding("x", environment()) 2235 tryCatch(x[1] <- 2, ## would modify the value, then signal an error 2236 error = function(e) NULL) 2237 stopifnot(identical(x, 1)) 2238} 2239foo() 2240 2241 2242## formalArgs() should conform to names(formals()) also in looking up fun: PR#17499 2243by <- function(a, b, c) "Bye!" # Overwrites base::by, as an example 2244foo <- function() { 2245 f1 <- function(a, ...) {} 2246 list(nf = names(formals("f1")), 2247 fA = formalArgs ("f1")) 2248} 2249stopifnot(exprs = { 2250 identical(names(formals("by")), letters[1:3]) 2251 identical(formalArgs ("by") , letters[1:3]) 2252 { r <- foo(); identical(r$nf, r$fA) } 2253}) 2254## gave "wrong" result and error in R <= 3.5.x 2255 2256 2257 2258## Subassigning multiple new data.frame columns (with specified row), PR#15362, 17504 2259z0 <- z1 <- data.frame(a=1, s=1) 2260z0[2, c("a","r","e")] <- data.frame(a=1, r=8, e=9) 2261z1[2, "r"] <- data.frame(r=8) 2262x <- x0 <- data.frame(a=1:3, s=1:3) 2263x[2, 3:4] <- data.frame(r=8, e=9) 2264stopifnot(exprs = { 2265 identical(z0, data.frame(a = c(1, 1), s = c(1, NA), r = c(NA, 8), e = c(NA, 9))) 2266 identical(z1, data.frame(a = c(1,NA), s = c(1, NA), r = c(NA, 8))) 2267 identical(x, cbind(x0, 2268 data.frame(r = c(NA, 8, NA), e = c(NA, 9, NA)))) 2269}) 2270d0 <- d1 <- d2 <- d3 <- d4 <- d5 <- d6 <- d7 <- data.frame(n=1:4) 2271## 2272d0[, 2] <- c2 <- 5:8 2273d0[, 3] <- c3 <- 9:12 2274d1[, 2:3] <- list(c2, c3) 2275d2[ 2:3] <- list(c2, c3) 2276d3[TRUE, 2] <- c2 ; d3[TRUE, 3] <- c3 2277d4[TRUE, 2:3] <- list(c2, c3) 2278d5[1:4, 2:3] <- list(c2, c3) 2279d6[TRUE, 1:2] <- list(c2, c3) 2280d7[ , 1:2] <- list(c2, c3) 2281stopifnot(exprs = { 2282 identical(d0, d1) 2283 identical(d0, d2) 2284 identical(d0, d3) 2285 identical(d0, d4) 2286 identical(d0, d5) 2287 ## 2288 identical(d6, d7) 2289 identical(d6, structure(list(n = c2, V2 = c3), 2290 row.names = c(NA, -4L), class = "data.frame")) 2291}) 2292## d4, d5 --> 'Error in `*tmp*`[[j]] : subscript out of bounds' 2293## d6 --> 'Error in x[[j]] <- `*vtmp*` : 2294## more elements supplied than there are to replace 2295## in R <= 3.5.1 2296 2297 2298## str() now even works with invalid S4 objects: 2299## this needs Matrix loaded to be an S4 generic 2300if(requireNamespace('Matrix', lib.loc = .Library, quietly = TRUE)) { 2301moS <- mo <- findMethods("isSymmetric") 2302attr(mo, "arguments") <- NULL 2303print(validObject(mo, TRUE)) # shows what's wrong 2304tools::assertError(capture.output( mo )) 2305op <- options(warn = 1)# warning: 2306str(mo, max.level = 2) 2307options(op)# revert 2308## in R <= 3.5.x, str() gave error instead of the warning 2309} 2310 2311 2312## seq.default() w/ integer overflow in border cases: -- PR#17497, Suharto Anggono 2313stopifnot(is.integer(iMax <- .Machine$integer.max), iMax == 2^31-1, 2314 is.integer(iM2 <- iMax-1L), # = 2^31 - 2 2315 (t30 <- 1073741824L) == 2^30 , 2316 is.integer(i3t30 <- c(-t30, 0L, t30))) 2317for(seq in c(seq, seq.int)) # seq() -> seq.default() to behave as seq.int() : 2318 stopifnot(exprs = { 2319 seq(iM2, length=2L) == iM2:(iM2+1L) # overflow warning and NA 2320 seq(iM2, length=3L) == iM2:(iM2+2 ) # Error in if (from == to) .... 2321 seq(-t30, t30, length=3) == i3t30 # overflow warning and NA 2322 ## Next two ok for the "seq.cumsum-patch" (for "seq.double-patch", give "double"): 2323 identical(seq(-t30, t30, length=3L), i3t30)# Error in if(is.integer(del <- to - from) 2324 identical(seq(-t30, t30, t30) , i3t30)# Error .. invalid '(to-from)/by'+NA warn. 2325 }) 2326## each of these gave integer overflows errors or NA's + warning in R <= 3.5.x 2327stopifnot(identical(7:10, seq.default(7L, along.with = 4:1) )) 2328## errored for almost a day after r76062 2329 2330 2331## seq.int(*, by=<int.>, length = n) for non-integer 'from' or 'to' 2332stopifnot(exprs = { 2333 identical(seq.int(from = 1.5, by = 2, length = 3), 2334 s <- seq(from = 1.5, by = 2, length = 3)) 2335 s == c(1.5, 3.5, 5.5) 2336 identical(seq.int(to = -0.1, by = -2, length = 2), 2337 s <- seq(to = -0.1, by = -2, length = 2)) 2338 all.equal(s, c(1.9, -0.1)) 2339 identical(seq.int(to = pi, by = 0, length = 1), pi) 2340}) 2341## returned integer sequences in all R versions <= 3.5.1 2342 2343 2344## Check for modififation of arguments 2345## Issue originally reported by Lukas Stadler 2346x <- 1+0 2347stopifnot(x + (x[] <- 2) == 3) 2348f <- compiler::cmpfun(function(x) { x <- x + 0; x + (x[] <- 2) }) 2349stopifnot(f(1) == 3) 2350 2351x <- 1+0 2352stopifnot(log(x, x[] <- 2) == 0) 2353f <- compiler::cmpfun(function(x) { x <- x + 0; log(x, x[] <- 2)}) 2354stopifnot(f(1) == 0) 2355 2356f <- function() x + (x[] <<- 2) 2357x <- 1 + 0; stopifnot(f() == 3) 2358fc <- compiler::cmpfun(f) 2359x <- 1 + 0; stopifnot(fc() == 3) 2360 2361f <- function() x[{x[2] <<- 3; 1}] <<- 2 2362fc <- compiler::cmpfun(f) 2363x <- c(1,2); f(); stopifnot(x[2] == 2) 2364x <- c(1,2); fc(); stopifnot(x[2] == 2) 2365 2366x <- 1+0 2367stopifnot(c(x, x[] <- 2)[[1]] == 1) 2368f <- compiler::cmpfun(function(x) { x <- x + 0; c(x, x[] <- 2)}) 2369stopifnot(f(1)[[1]] == 1) 2370 2371x <- c(1,2) 2372x[{x[2] <- 3; 1}] <- 2 2373stopifnot(x[2] == 2) 2374f <- compiler::cmpfun(function(a,b) { x <- c(a, b); x[{x[2] <- 3; 1}] <- 2; x}) 2375f(1, 2) 2376stopifnot(f(1, 2) == 2) 2377 2378m <- matrix(1:4, 2) 2379i <- (1:2) + 0 2380stopifnot(m[i, {i[] <- 2; 1}][1] == 1) 2381f <- compiler::cmpfun(function(i) { i <- i + 0; m[i, {i[] <- 2; 1}]}) 2382stopifnot(f(1:2)[1] == 1) 2383 2384m <- matrix(1:4, 2) 2385eval(compiler::compile(quote(m[1,1]))) 2386stopifnot(max(.Internal(named(m)), .Internal(refcnt(m))) == 1) 2387 2388ma <- .Internal(address(m)) 2389eval(compiler::compile(quote(m[1,1] <- 2L))) 2390stopifnot(identical(.Internal(address(m)), ma)) 2391 2392a <- array(1:8, rep(2, 3)) 2393eval(compiler::compile(quote(a[1,1,1]))) 2394stopifnot(max(.Internal(named(a)), .Internal(refcnt(a))) == 1) 2395 2396aa <- .Internal(address(a)) 2397eval(compiler::compile(quote(a[1,1,1] <- 2L))) 2398stopifnot(identical(.Internal(address(a)), aa)) 2399 2400m <- matrix(1:4, 2) 2401i <- (1:2) + 0 2402stopifnot(m[i, {i[] <- 2; 1}][1] == 1) 2403f <- compiler::cmpfun(function(i) { i <- i + 0; m[i, {i[] <- 2; 1}]}) 2404stopifnot(f(1:2)[1] == 1) 2405 2406a <- array(1:8, rep(2, 3)) 2407i <- (1:2) + 0 2408stopifnot(a[i, {i[] <- 2; 1}, 1][1] == 1) 2409f <- compiler::cmpfun(function(i) { i <- i + 0; a[i, {i[] <- 2; 1}, 1]}) 2410stopifnot(f(1:2)[1] == 1) 2411 2412i <- (1:2) + 0 2413stopifnot(a[i, {i[] <- 2; 1}, 1][1] == 1) 2414f <- compiler::cmpfun(function(i) { i <- i + 0; a[1, i, {i[] <- 2; 1}]}) 2415stopifnot(f(1:2)[1] == 1) 2416 2417x <- 1 + 0 2418stopifnot(identical(rep(x, {x[] <- 2; 2}), rep(1, 2))) 2419x <- 1 + 0 2420v <- eval(compiler::compile(quote(rep(x, {x[] <- 2; 2})))) 2421stopifnot(identical(v, rep(1, 2))) 2422 2423x <- 1 + 0 2424stopifnot(round(x, {x[] <- 2; 0}) == 1) 2425x <- 1 + 0 2426v <- eval(compiler::compile(quote(round(x, {x[] <- 2; 0})))) 2427stopifnot(v == 1) 2428 2429f <- function() { 2430 x <- numeric(1) 2431 y <- 0 2432 rm("y") 2433 makeActiveBinding("y", function() { x[] <<- 1; 0}, environment()) 2434 x + y 2435} 2436stopifnot(f() == 0) 2437stopifnot(compiler::cmpfun(f)() == 0) 2438 2439f <- function(y = {x[] <- 1; 0}) { x <- numeric(1); x + y } 2440stopifnot(f() == 0) 2441stopifnot(compiler::cmpfun(f)() == 0) 2442 2443 2444## This failed under REFCNT: 2445for (i in 1:2) { if (i == 1) { x <- i; rm(i) }} 2446stopifnot(x == 1) 2447 2448 2449## gamma & lgamma should not warn for correct limit cases: 2450stopifnot(exprs = { 2451 lgamma(0:-10) == Inf 2452 gamma(-180.5) == 0 2453 gamma(c(200,Inf)) == Inf 2454 lgamma(c(10^(306:310), Inf)) == Inf 2455}) 2456## had "Warning message: value out of range in 'lgamma' " for ever 2457 2458 2459## sub() with non-ASCII replacement failed to set encodings (PR#17509): 2460x <- c("a", "b") 2461x <- sub("a", "\u00e4", x) 2462stopifnot(Encoding(x)[1L] == "UTF-8") 2463x <- sub("b", "\u00f6", x) 2464stopifnot(Encoding(x)[2L] == "UTF-8") 2465## [1] has been "unknown" in R <= 3.5.x 2466 2467 2468## formula(model.frame()) -- R-devel report by Bill Dunlap 2469d <- data.frame(A = log(1:6), B = LETTERS[1:6], C = 1/(1:6), D = letters[6:1], Y = 1:6) 2470m0 <- model.frame(Y ~ A*B, data=d) 2471stopifnot(exprs = { 2472 DF2formula(m0) == (Y ~ A+B) # the previous formula(.) behavior 2473 formula(m0) == (Y ~ A*B) 2474}) 2475## formula(.) gave Y ~ A + B in R <= 3.5.x 2476 2477 2478## These used to fail (PR17514) in a NAMED build but not with REFCNT: 2479L <- matrix(list( c(0) ), 2, 1) 2480L[[2]][1] <- 11 2481stopifnot(L[[1]] == 0) 2482L <- matrix(list( c(0) ), 2, 1, byrow = TRUE) 2483L[[2]][1] <- 11 2484stopifnot(L[[1]] == 0) 2485 2486 2487## ar.ols() - PR#17517 2488ar_ols <- ar.ols(lynx) 2489stopifnot(exprs = { 2490 is.list(pa <- predict(ar_ols, n.ahead = 2))# must *not* warn 2491 all.equal(ar_ols$var.pred, 592392.12774) # not a matrix 2492}) 2493## .$var.pred had been a 1x1 matrix in R <= 3.5.2 2494 2495 2496## check that parse lines are properly initialized in the parser 2497d <- getParseData(parse(text="{;}", keep.source=TRUE)) 2498l <- d[ d[,"token"] == "exprlist", "line1" ] 2499stopifnot(identical(l, 1L)) 2500## failed in 3.5 and earlier 2501 2502 2503## check that NA is treated as non-existent file (not file named "NA") 2504tools::assertError (normalizePath(c(NA_character_,getwd()), mustWork=TRUE)) 2505tools::assertWarning(normalizePath(c(NA_character_,getwd()), mustWork=NA)) 2506stopifnot(identical (normalizePath(c(NA_character_,getwd()), mustWork=FALSE)[1], 2507 NA_character_)) 2508stopifnot(identical(unname(file.access(NA_character_)), -1L)) 2509## NA treated as error 2510tools::assertError(file.edit(NA_character_)) 2511tools::assertError(file(NA_character_)) 2512 2513 2514## strtoi("") : 2515stopifnot(is.na(strtoi("")), 2516 is.na(strtoi("", 2L))) 2517## was platform dependent [libC strtol()] in R <= 3.5.x 2518 2519 2520## formula.data.frame() thinko at modularization [r75911]: 2521f <- function(df) { 2522 stopifnot(is.data.frame(df)) 2523 d <- 4 2524 f2(formula(df)) 2525} 2526f2 <- function(form) eval(quote(d), envir = environment(form)) 2527rf <- f(data.frame(x=1, f="b")) ## gave error inside f2() in R-devel 2528stopifnot(identical(rf, 4)) 2529## as after 75911 a wrong parent.frame() was used. 2530 2531 2532## format(.) when there's no method gives better message: 2533ee <- tryCid(format(.Internal(bodyCode(ls)))) 2534stopifnot(exprs = { 2535 conditionCall(ee)[[1]] == quote(format.default) 2536 grepl("no format() method", conditionMessage(ee), fixed=TRUE) 2537}) 2538## signalled from long .Internal(...) call + "must be atomic" in R <= 3.5.x 2539 2540 2541## writeLines(readLines(F), F) -- PR#17528 2542tf <- tempfile("writeL_test") 2543writeLines("1\n2\n3", tf) 2544c123 <- paste(1:3) 2545stopifnot(identical(readLines(tf), c123)) 2546writeLines(readLines(tf), tf) 2547stopifnot(identical(readLines(tf), c123)) 2548## writeLines had opened the output for writing before readLines() read it 2549 2550 2551## max.col(<empty>) 2552stopifnot(identical(NA_integer_, max.col(matrix(,1,0)))) 2553## gave 1 in R <= 3.5.x 2554 2555 2556## model.matrix() should warn on invalid 'contrasts.arg' 2557## suggested by Ben Bolker on R-devel list, Feb 20, 2019 2558data(warpbreaks) 2559 mf1 <- model.matrix(~tension, data=warpbreaks) # default 2560tools::assertWarning( 2561 mf2 <- model.matrix(~tension, data=warpbreaks, contrasts.arg = "contr.sum") )# wrong 2562tools::assertWarning( 2563 mf3 <- model.matrix(~tension, data=warpbreaks, contrasts.arg = contr.sum) ) # wrong 2564 mf4 <- model.matrix(~tension, data=warpbreaks, contrasts.arg = list(tension=contr.sum)) 2565stopifnot(exprs = { 2566 identical(mf1, mf2) 2567 identical(mf1, mf3) 2568 ## and mf4 has sum contrasts : 2569 is.matrix(C <- attr(mf4, "contrasts")$tension) 2570 identical(dim(C), 3:2) 2571 all.equal(unname(C), rbind(diag(2), -1)) 2572}) 2573## gave no warnings but same results in R <= 3.5.0 2574 2575 2576## axTicks() should zap "almost zero" to zero, PR#17534 2577## (caused by non-exact floating point arithmetic -- (platform dependently!) 2578plot(c(-0.1, 0.2), axes=FALSE, ann=FALSE) 2579(a2 <- axTicks(2)) # -0.10 -0.05 0.00 0.05 0.10 0.15 0.20 2580axis(2, at = a2) # was ugly 2581stopifnot(exprs = { 2582 a2[3] == 0 # exactly 2583 all.equal(a2, (-2:4)/20, tol=1e-14) # closely 2584}) 2585## a2[3] was 1.38778e-17 on typical platforms in R <= 3.5.x 2586 2587 2588## isSymmetric(<1x1-matrix>) and <0x0 matrix> with dimnames 2589stopifnot(exprs = { 2590 ! isSymmetric(matrix(0, dimnames = list("A","b"))) # *non*-symmetric dimnames 2591 isSymmetric(matrix(0, dimnames = list("A","b")), check.attributes=FALSE) # dimn. not checked 2592 ## isSymmetric() gave TRUE wrongly in R versions 3.4.0 -- 3.5.x 2593 ! isSymmetric(matrix(1, dimnames = list("A", NULL))) 2594 ! isSymmetric(matrix(1, dimnames = list(NULL, "A"))) 2595 isSymmetric(matrix(1, dimnames = list(NULL, "A")), check.attributes=FALSE) 2596 isSymmetric(matrix(1)) 2597 isSymmetric(matrix(1, dimnames = list("a", "a"))) 2598 isSymmetric(matrix(1, dimnames = list(NULL, NULL))) 2599 isSymmetric(matrix(,0,0, dimnames=list(NULL, NULL))) 2600 isSymmetric(matrix(,0,0)) 2601}) 2602 2603 2604## bxp() did not signal anything about duplicate actual arguments: 2605set.seed(3); bx.p <- boxplot(split(rt(100, 4), gl(5, 20)), plot=FALSE) 2606tools::assertWarning(bxp(bx.p, ylab = "Y LAB", ylab = "two"), verbose=TRUE) 2607w <- tryCatch(bxp(bx.p, ylab = "Y LAB", ylab = "two", xlab = "i", xlab = "INDEX"), 2608 warning = conditionMessage) 2609stopifnot(is.character(w), grepl('ylab = "two"', w), grepl('xlab = "INDEX"', w)) 2610 2611 2612## reformulate() bug PR#17359 2613(form <- reformulate(c("u", "log(x)"), response = "log(y)")) 2614stopifnot(identical(form, log(y) ~ u + log(x))) 2615## had *symbol* `log(y)` instead of call in R <= 3.5.1 2616newf <- function(terms, resp) 2617 list(e = environment(), 2618 form= reformulate(terms, resp)) 2619ef <- newf("x", "log(y)") 2620stopifnot( identical(ef$e, environment(ef$form)), 2621 !identical(ef$e, .GlobalEnv), 2622 identical(format(ef$form), "log(y) ~ x")) 2623## Back compatibility + deprecation warning: 2624notC <- "Model[no 4]" 2625form <- `Model[no 4]` ~ . 2626f1 <- function(p) reformulate(".", notC) 2627f2 <- function(e) f1(e) 2628stopifnot(exprs = { 2629 identical(form, suppressWarnings(reformulate(".", notC))) # << will STOP working! 2630 identical(form, reformulate(".", as.name(notC))) 2631 identical(form, reformulate(".", paste0("`", notC, "`"))) 2632 inherits(tt <- tryCatch(reformulate(".", notC), warning=identity), 2633 "deprecatedWarning") 2634 inherits(tt, "warning") 2635 conditionCall(tt)[[1]] == quote(reformulate) 2636 inherits(t1 <- tryCatch(f1(pi), warning=identity), "deprecatedWarning") 2637 inherits(t2 <- tryCatch(f2(27), warning=identity), "deprecatedWarning") 2638 all.equal(t1, tt) # including call 'reformulate(..)' 2639 all.equal(t2, tt) 2640}) 2641writeLines(conditionMessage(tt)) 2642 2643 2644## stopifnot() now works *nicely* with expression object (with 'exprs' name): 2645ee <- expression(xpr=all.equal(pi, 3.1415927), 2 < 2, stop("foo!")) 2646te <- tryCid(stopifnot(exprObject = ee)) 2647stopifnot(conditionMessage(te) == "2 < 2 is not TRUE") 2648## conditionMessage(te) was "ee are not all TRUE" in R 3.5.x 2649t2 <- tryCid(stopifnot(exprs = { T }, exprObject = ee)) 2650t3 <- tryCid(stopifnot(TRUE, 2 < 3, exprObject = ee)) 2651f <- function(ex) stopifnot(exprObject = ex) 2652t4 <- tryCid(f(ee)) 2653stopifnot(grepl("one of 'exprs', 'exprObject' ", conditionMessage(t2)), 2654 conditionMessage(t2) == conditionMessage(t3), 2655 conditionMessage(t4) == conditionMessage(te) 2656 ) 2657(function(e) stopifnot(exprObject = e))(expression(1 < 2, 2 <= 2:4)) 2658## the latter (with 'exprs = e') gave Error in eval(exprs) : object 'e' not found 2659 2660 2661## 2662## Empty 'exprs' should work in almost all cases: 2663stopifnot() 2664stopifnot(exprs = {}) 2665e0 <- expression() 2666stopifnot(exprObject = e0) 2667do.call(stopifnot, list(exprObject = expression())) 2668do.call(stopifnot, list(exprObject = e0)) 2669## the last three (w 'exprs = ') failed in R 3.5.x 2670 2671 2672## as.matrix.data.frame() w/ character result and logical column, PR#17548 2673cx <- as.character(x <- c(TRUE, NA, FALSE)) 2674stopifnot(exprs = { 2675 identical(cx, as.matrix(data.frame(x, y="chr"))[,"x"]) 2676 identical(x, as.logical(cx)) 2677}) 2678 2679 2680## Failed to work after r76382--8: 2681assertErrV(formula("3")) 2682stopifnot(exprs = { 2683 ## New formula(<character>) specs: 2684 ## These give deprecation warnings: 2685 is.list(op <- options(warn = 1)) 2686 identical(formula("ran = ~ 1|G"), ~ 1 | G) 2687 identical(formula(c("~", "foo")), ~ foo ) 2688 identical(formula("({y ~ x})"), y ~ x) 2689 identical(formula("{ ~ x }"), ~ x) 2690 TRUE || { ## all these "bugs" not yet in R <= 3.6.0 2691 identical(formula(c("y", "~", "x + (1 | G)")), y ~ x + (1 | G)) 2692 identical(formula(c("y", "~", "x +", "(1 | G)")), y ~ x + (1 | G)) 2693 }## not yet 2694 identical(formula(c("~", "x","+ (1 | G)")), ~x) ## NOT YET: ~ x + (1 | G)) 2695 is.list(options(op)) 2696}) 2697tools::assertWarning(formula("ran= ~ 1|G"),"deprecatedWarning", verbose=TRUE) 2698tools::assertWarning(formula(c("~", "x")), "deprecatedWarning", verbose=TRUE) 2699tools::assertWarning(formula("({y ~ x})"), "deprecatedWarning", verbose=TRUE) 2700tools::assertWarning(formula("{ ~ x }"), "deprecatedWarning", verbose=TRUE) 2701 2702 2703## str2expression(<empty>) : 2704stopifnot(identical(str2expression(character()), expression())) 2705 2706 2707## quasi(*, variance = list()) - should not deparse(); PR#17560 2708## like quasipoisson() : 2709devRes <- function(y, mu, wt) { 2 * wt * (y * log(ifelse(y == 0, 1, y/mu)) - (y-mu)) } 2710init <- expression({ 2711 if(any(y < 0)) stop("y < 0") 2712 n <- rep.int(1, nobs) 2713 mustart <- y + 0.1 2714}) 2715myquasi <- quasi(link = "log", 2716 variance = list(name = "my quasi Poisson", 2717 varfun = function(mu) mu, 2718 validmu = function(mu) all(is.finite(mu)) && all(mu > 0), 2719 dev.resids = devRes, 2720 initialize = init)) 2721x <- runif(100, min=0, max=1) 2722y <- rpois(100, lambda=1) 2723fq1 <- glm(y ~ x, family = myquasi) 2724fqP <- glm(y ~ x, family = quasipoisson) 2725str(keep <- setdiff(names(fq1), c("family", "call"))) 2726identNoE <- function(x,y, ...) identical(x,y, ignore.environment=TRUE, ...) 2727stopifnot(exprs = { 2728 all.equal(fq1[keep], fqP[keep]) 2729 ## quasi() failed badly "switch(vtemp, ... EXPR must be a length 1 vector" in R <= 3.6.0 2730 identNoE(quasi(var = mu), quasi(variance = "mu")) 2731 identNoE(quasi(var = mu(1-mu)), quasi(variance = "mu(1- mu)"))# both failed in R <= 3.6.0 2732 identNoE(quasi(var = mu^3), quasi(variance = "mu ^ 3")) # 2nd failed in R <= 3.6.0 2733 is.character(msg <- tryCmsg(quasi(variance = "log(mu)"))) && 2734 grepl("variance.*log\\(mu\\).* invalid", msg) ## R <= 3.6.0: 'variance' "NA" is invalid 2735}) 2736 2737 2738## rbind.data.frame() should *not* drop NA level of factors -- PR#17562 2739fcts <- function(N=8, k=3) addNA(factor(sample.int(k, N, replace=TRUE), levels=1:k)) 2740set.seed(7) # <- leads to some "0 counts" [more interesting: they are kept] 2741dfa <- data.frame(x=fcts()) 2742dfb <- data.frame(x=fcts()) ; rbind(table(dfa), table(dfb)) 2743dfy <- data.frame(y=fcts()) 2744yN <- c(1:3, NA_character_, 5:8) 2745dfay <- cbind(dfa, dfy) 2746dfby <- cbind(dfa, data.frame(y = yN, stringsAsFactors = TRUE)) 2747dfcy <- dfa; dfcy$y <- yN # y: a <char> column 2748## dNay := drop unused levels from dfay incl NA 2749dNay <- dfay; dNay[] <- lapply(dfay, factor) 2750str(dfay) # both (x, y) have NA level 2751str(dfby) # (x: yes / y: no) NA level 2752str(dNay) # both: no NA level 2753stopifnot(exprs = { ## "trivial" (non rbind-related) assertions : 2754 identical(levels(dfa$x), c(1:3, NA_character_) -> full_lev) 2755 identical(levels(dfb$x), full_lev) 2756 identical(levels(dfay$x), full_lev) # cbind() does work 2757 identical(levels(dfay$y), full_lev) 2758 identical(levels(dfby$x), full_lev) 2759 is.character(dfcy$y) 2760 anyNA(dfcy$y) 2761 identical(levels(dfby$y), as.character((1:8)[-4]) -> levN) # no NA levels 2762 identical(lapply(dNay, levels), 2763 list(x = c("2","3"), y = levN[1:3])) # no NA levels 2764}) 2765dfaby <- rbind(dfay, dfby) 2766dNaby <- rbind(dNay, dfby) 2767dfacy <- rbind(dfay, dfcy) 2768dfcay <- rbind(dfcy, dfay) # 1st arg col. is char => rbind() keeps char 2769stopifnot(exprs = { 2770 identical(levels(rbind(dfa, dfb)$x), full_lev) # <== not in R <= 3.6.0 2771 identical(levels(dfaby$x), full_lev) 2772 identical(levels(dfaby$y), yN) # failed a while 2773 identical(levels(dNaby$y), levN) # (ditto) 2774 identical(dfacy, dfaby) 2775 is.character(dfcay$y) 2776 anyNA(dfcay$y) 2777 identical(dfacy$x, dfcay$x) 2778 identical(lapply(rbind(dfby, dfay), levels), 2779 list(x = full_lev, y = c(levN, NA))) 2780 identical(lapply(rbind(dfay, dfby, factor.exclude = NA), levels), 2781 list(x = as.character(1:3), y = levN)) 2782 identical(lapply(rbind(dfay, dfby, factor.exclude=NULL), levels), 2783 list(x = full_lev, y = yN)) 2784}) 2785 2786## rbind.data.frame() should work in all cases with "matrix-columns": 2787m <- matrix(1:12, 3) ## m.N := [m]atrix with (row)[N]ames : 2788m.N <- m ; rownames(m.N) <- letters [1:3] 2789## data frames with these matrices as *column*s: 2790dfm <- data.frame(c = 1:3, m = I(m)) 2791dfm.N <- data.frame(c = 1:3, m = I(m.N)) 2792(mNm <- rbind(m.N, m)) 2793dfmmN <- rbind(dfm, dfm.N) 2794dfmNm <- rbind(dfm.N, dfm) 2795stopifnot(exprs = { 2796 identical( dim(dfmNm), c(6L, 2L)) 2797 identical(dimnames(dfmNm), list(c(letters[1:3],1:3), c("c","m"))) 2798 is.matrix(m. <- dfmNm[,"m"]) 2799 identical(dim(m.), c(6L, 4L)) 2800 identical(dfmNm, dfmmN[c(4:6, 1:3), ]) 2801 identical(unname(mNm), unname(m.)) 2802}) 2803## The last rbind() had failed since at least R 2.0.0 2804 2805 2806## as.data.frame.array(<1D array>) -- PR#17570 2807str(x2 <- as.data.frame(array(1:2))) 2808stopifnot(identical(x2[[1]], 1:2)) 2809## still was "array" in R <= 3.6.0 2810 2811 2812## vcov(<quasi>, dispersion = *) -- PR#17571 2813counts <- c(18,17,15,20,10,20,25,13,12) 2814treatment <- gl(3,3) 2815outcome <- gl(3,1,9) 2816## Poisson and Quasipoisson 2817 poisfit <- glm(counts ~ outcome + treatment, family = poisson()) 2818qpoisfit <- glm(counts ~ outcome + treatment, family = quasipoisson()) 2819spois <- summary( poisfit) 2820sqpois <- summary(qpoisfit) 2821sqpois.d1 <- summary(qpoisfit, dispersion=1) 2822SE1 <- sqrt(diag(V <- vcov(poisfit))) 2823(noLdbl <- (.Machine$sizeof.longdouble <= 8)) ## TRUE when --disable-long-double 2824stopifnot(exprs = { ## Same variances and same as V 2825 all.equal(vcov(spois), V) 2826 all.equal(vcov(qpoisfit, dispersion=1), V) ## << was wrong 2827 all.equal(vcov(sqpois.d1), V) 2828 all.equal(spois $coefficients[,"Std. Error"], SE1) 2829 all.equal(sqpois.d1$coefficients[,"Std. Error"], SE1) 2830 all.equal(sqpois $coefficients[,"Std. Error"], 2831 sqrt(sqpois$dispersion) * SE1) 2832}) 2833## vcov(. , dispersion=*) was wrong on R versions 3.5.0 -- 3.6.0 2834proc.time() - .pt; .pt <- proc.time() 2835 2836 2837## runmed(<x_with_NA>, "Turlach") still seg.faults in 3.6.0 {reported by Hilmar Berger} 2838dd1 <- c(rep(NaN,82), rep(-1, 144), rep(1, 74)) 2839xT1 <- runmed(dd1, 21, algorithm="T", print.level=1)# gave seg.fault 2840xS1 <- runmed(dd1, 21, algorithm="S", print.level=1) 2841if(FALSE) 2842cbind(dd1, xT1, xS1) 2843nN <- !is.na(xT1) 2844stopifnot(xT1[nN] == c(rep(-1, 154), rep(1, 74))) 2845dd2 <- c(rep(-1, 144), rep(1, 74), rep(NaN,82)) 2846xS2 <- runmed(dd2, 21, algorithm = "Stuetzle", print.level=1) 2847xT2 <- runmed(dd2, 21, algorithm = "Turlach" , print.level=1) 2848if(FALSE) 2849cbind(dd2, xS2, xT2) # here, "St" and "Tu" are "the same" 2850nN <- !is.na(xT2) 2851stopifnot(exprs = { ## both NA|NaN and non-NA are the same: 2852 identical(xT2[nN], xS2[nN]) 2853 identical(is.na(xS2) , !nN) 2854 { i <- 1:(144+74); xT2[i] == dd2[i] } 2855}) 2856## close to *minimal* repr.example: 2857x5 <- c(NA,NA, 1:3/4) 2858rS <- runmed(x5, k= 3, algorithm = "St", print.level=3) 2859rT <- runmed(x5, k= 3, algorithm = "Tu", print.level=3) 2860stopifnot(exprs = { 2861 identical(rS, rT) 2862 rT == c(1,1,1:3)/4 2863}) 2864## a bit larger: 2865x14 <- c(NA,NA,NA,NA, 1:10/4) 2866rS14 <- runmed(x14, k = 7, algorithm="S", print.level=2) 2867rT14 <- runmed(x14, k = 7, algorithm="T", print.level=2) 2868## cbind(x14, rT14, rS14) 2869(naActs <- eval(formals(runmed)$na.action)); names(naActs) <- naActs 2870allT14 <- lapply(naActs, function(naA) 2871 tryCatch(runmed(x14, k = 7, algorithm="T", na.action=naA, print.level=2), 2872 error=identity, warning=identity)) 2873rTo14 <- runmed(na.omit(x14), k=7, algorithm="T") 2874stopifnot(exprs = { 2875 identical( rT14, rS14) 2876 identical(c(rT14), c(NaN,NaN, .5, .5, .5, .75, x14[-(1:6)])) 2877 identical( rT14, allT14$"+Big_alternate") 2878 (allT14$"-Big_alternate" >= rT14)[-(1:2)] # slightly surprisingly 2879 identical(allT14$na.omit[-(1:4)], c(rTo14)) 2880 inherits(Tfail <- allT14$fail, "error") 2881 !englishMsgs || grepl("^runmed\\(.*: .*NA.*x\\[1\\]", Tfail$message) 2882}) 2883 2884 2885## conformMethod() "&& logic" bug, by Henrik Bengtsson on R-devel list, 2019-06-22 2886setClass("tilingFSet", slots = c(x = "numeric")) 2887if(!is.null(getGeneric("oligoFn"))) removeGeneric("oligoFn") 2888setGeneric("oligoFn", 2889 function(object, subset, target, value) { standardGeneric("oligoFn") }) 2890Sys.setenv("_R_CHECK_LENGTH_1_LOGIC2_" = "true") 2891if(getRversion() <= "3.6")## to run this with R 3.6.0, 3.5.3, .. 2892 Sys.unsetenv("_R_CHECK_LENGTH_1_LOGIC2_") 2893setMethod("oligoFn", signature(object = "tilingFSet", value="array"), ## Method _1_ 2894 function(object, value) { list(object=object, value=value) }) 2895setMethod("oligoFn", signature(object = "matrix", target="array"), ## Method _2_ 2896 function(object, target) list(object=object, target=target)) 2897setMethod("oligoFn", signature(object = "matrix", subset="integer"), ## Method _3_ 2898 function(object, subset) list(object=object, subset=subset)) # *no* Note 2899setMethod("oligoFn", signature(object = "matrix"), ## Method _4_ 2900 function(object) list(object=object)) # *no* Note 2901setMethod("oligoFn", signature(subset = "integer"), ## Method _5_ 2902 function(subset) list(subset=subset)) 2903setMethod("oligoFn", signature(target = "matrix"), ## Method _6_ 2904 function(target) list(target=target)) 2905setMethod("oligoFn", signature(value = "array"), ## Method _7_ 2906 function(value) list(value=value)) 2907setMethod("oligoFn", signature(subset = "integer", target = "matrix"), ## Method _8_ 2908 function(subset, target) list(subset=subset, target=target)) 2909setMethod("oligoFn", signature(subset = "integer", value = "array"), ## Method _9_ 2910 function(subset, value) list(subset=subset, value=value)) 2911setMethod("oligoFn", signature(target = "matrix", value = "array"), ## Method _10_ 2912 function(target, value) list(target=target, value=value)) 2913## 2914showMethods("oligoFn", include=TRUE) # F.Y.I.: in R 3.6.0 and earlier: contains "ANY" everywhere 2915##========= ------------ 2916stopifnot(exprs = { 2917 is.function(mm <- getMethod("oligoFn", 2918 signature(object="tilingFSet", 2919 subset="missing", target="missing", 2920 value="array"))) 2921 inherits(mm, "MethodDefinition") 2922 identical( 2923 sort(names(getMethodsForDispatch(oligoFn))) # sort(.) the same for "all" locales 2924 ## Now, "ANY" only appear "at the end" .. otherwise have "missing" 2925 , c("matrix#ANY#ANY#ANY", 2926 "matrix#integer#ANY#ANY", 2927 "matrix#missing#array#ANY", 2928 "missing#integer#ANY#ANY", 2929 "missing#integer#matrix#ANY", 2930 "missing#integer#missing#array", 2931 "missing#missing#matrix#ANY", 2932 "missing#missing#matrix#array", 2933 "missing#missing#missing#array", 2934 "tilingFSet#missing#missing#array")) 2935}) 2936## Testing all 10 methods: 2937r1 <- oligoFn(object=new("tilingFSet"), value=array(2)) 2938r2 <- oligoFn(object=diag(2), target=array(42)) 2939## These 2 work fine in all versions of R: Here the "ANY" remain at the end: 2940r3 <- oligoFn(object=diag(2), subset=1:3) 2941r4 <- oligoFn(object=diag(2)) 2942## All these do *not* specify 'object' --> Error in R <= 3.6.x {argument ... is missing} 2943r5 <- oligoFn(subset = 1:5) 2944r6 <- oligoFn(target = cbind(7)) 2945r7 <- oligoFn(value = array(47)) 2946r8 <- oligoFn(subset = -1:1, target = diag(3)) 2947r9 <- oligoFn(subset = 2:6, value = array(7)) 2948r10<- oligoFn(target = cbind(1,2), value = array(1,1:3)) 2949## in R <= 3.6.0, e.g., the first setMethod(..) gave 2950## Error in omittedSig && (signature[omittedSig] != "missing") : 2951## 'length(x) = 4 > 1' in coercion to 'logical(1)' 2952 2953 2954## apply(., MARGIN) when MARGIN is outside length(dim(.)): 2955a <- tryCid(apply(diag(3), 2:3, mean)) 2956stopifnot(exprs = { 2957 inherits(a, "error") 2958 conditionCall(a)[[1]] == quote(`apply`) 2959 !englishMsgs || !grepl("missing", (Msg <- conditionMessage(a)), fixed=TRUE) 2960 !englishMsgs || grepl("MARGIN", Msg, fixed=TRUE) 2961}) 2962 2963 2964## cbind() of data frames with no columns lost names -- PR#17584 2965stopifnot(identical(names(cbind(data.frame())), 2966 character())) 2967stopifnot(identical(names(cbind(data.frame(), data.frame())), 2968 character())) 2969## names() came out as NULL instead of character(). 2970 2971 2972## NUL inserted incorrectly in adist trafos attribute -- PR#17579 2973s <- c("kitten", "sitting", "hi") 2974ad <- adist(s, counts = TRUE) 2975adc <- attr(ad, "counts") 2976adt <- attr(ad, "trafos") 2977## Follow analysis in the bug report: in the diagonal, we should have 2978## only matches for each character in the given string. 2979stopifnot(exprs = { 2980 nchar(diag(adt)) == nchar(s) 2981 ## The del/ins/sub counts should agree with the numbers of D/I/S 2982 ## occurrences in the trafos. 2983 nchar(gsub("[^D]", "", adt)) == adc[, , "del"] 2984 nchar(gsub("[^I]", "", adt)) == adc[, , "ins"] 2985 nchar(gsub("[^S]", "", adt)) == adc[, , "sub"] 2986}) 2987 2988## list2env preserves values semantics 2989v <- list(x=c(1)) # << subtlety! 2990e <- list2env(v) 2991with(e, x[[1]] <- 42) 2992v 2993stopifnot(identical(v$x,1)) 2994 2995 2996## misleading error message when coercing language object to atomic, etc: 2997e <- tryCid(as.double(quote(foo(1)))) 2998stopifnot(inherits(e, "error"), grepl("'language'", e$message, fixed=TRUE)) 2999## had 'pairlist' in R <= 3.6.1 3000 3001 3002## print(ls.str(<environment with error object with "missing" in message text>)) 3003msg <- "arguments in the signature are missing" 3004e1 <- new.env(hash=FALSE) 3005e1$Err <- structure(list(message = msg, call = quote(foo(bar))), 3006 class = c("simpleError", "error", "condition")) 3007writeLines(prE <- capture.output(ls.str(e1))) 3008## was "Err: <missing>" in R <= 3.6.1 3009stopifnot(exprs = { length(prE) >= 3 3010 grepl("List of 2", prE[[1]], fixed=TRUE) 3011 grepl(msg, prE[[2]], fixed=TRUE) 3012 grepl("call.* foo\\(bar\\)", prE[[3]]) 3013}) 3014 3015 3016## format(x, scientific = FALSE) for large x 3017xMAX <- .Machine$double.xmax 3018ch <- format(xMAX, scientific = 400) # << scientific as 'scipen' 3019op <- options(digits=1, scipen = 303) 3020co <- capture.output(cat(xMAX)) 3021options(op)# back to normal 3022stopifnot(exprs = { 3023 nchar(ch) == 309 3024 identical(ch, co) 3025 ch == format(xMAX, scientific=FALSE) 3026})## format(*, scientific=FALSE) was "not obeyed" in R < 4.0.0 3027 3028 3029## format(<symbol>) aka format(<name>) : 3030for(ch in c("foo", "bar", "1", "a:b", "B space A", "`ABC", "'CBA")) 3031 stopifnot(identical(ch, format(as.symbol(ch)))) 3032## gave 'Found no format() method for class "name"' in R <= 3.6.x 3033 3034 3035## x %% +- Inf -- PR#17611 // also %/% for "large" args 3036for(x in list(0:3, c(0, 0.5+0:2))) { 3037 xp <- x[x != 0] # x "positive" 3038 for(L in c(2^(2:9), 1000^(1:7), Inf)) 3039 stopifnot(exprs = { 3040 ## ----------------- %% ------------- 3041 ## same signs : 3042 x %% L == x 3043 (-x) %% -L == -x 3044 ## opposite signs, x > 0 : 3045 (-xp) %% L == L-xp 3046 xp %% -L == xp-L 3047 ## ----------------- %/% ------------ 3048 x %/% L == pmin(0, sign(x)) 3049 (-x) %/% -L == x %/% L 3050 (-x) %/% L == pmin(0, sign(-x)) 3051 x %/% -L == (-x) %/% L 3052 ## L . x : 3053 L %/% xp == (-L) %/% -xp 3054 L %/% -xp == (-L) %/% xp 3055 }) 3056 stopifnot(exprs = { 3057 Inf %/% x == sign( x+(x==0))*Inf 3058 Inf %/% -xp == -Inf 3059 }) 3060} 3061## these all returned NaN when L == Inf in R <= 3.6.1 3062## 3063## Further - very basics and some large (working "since ever"): 3064L <- 1e111 * c(-1,1) 3065stopifnot(exprs = { 3066 L %% L == 0 # failed for a few days in R-devel 3067 L %% -L == 0 3068 -6:17 %% 3L == 0:2 3069 -5:15 %% -3L == -2:0 3070 is.finite(x <- 2^(1:1022)) 3071 x %% (x.2 <- x/2) == 0 3072 x %/% 2 == x.2 3073 x[1:52] %% 3 == 2:1 3074 -x[1:52] %% 3 == 1:2 3075}) # larger x suffer from cancellation (well, warning too early now): 3076(iCrit <- ## depends on the presence and version of "long double": 3077 if(noLdbl) 3078 50:55 3079 else if(is.integer(digLd <- .Machine$longdouble.digits) && digLd == 64) 3080 60:68 3081 else if(is.integer(digLd) && digLd == 113) ## aarch64 {PR#17718} 3082 110:118 3083 else 250:258 # "wild guess" should always work 3084) 3085tools::assertWarning(x[iCrit] %% 3, verbose=TRUE) 3086 3087 3088## Hilmar Berger's on R-devel list: 'data.frame() == NULL' etc 3089d0. <- data.frame(a = numeric(0)) # zero length data.frame [ 0 x 1 ] 3090d0 <- unname(d0.) # zero length data.frame __without names__ 3091d3 <- data.frame(a=1:3) # non-empty data.frame 3092d30. <- d3[,FALSE] # <3 x 0> 3093d30 <- unname(d30.) 3094for(DF in list(d0., d0, d30., d30)) 3095 for(R in list(1, NULL, logical(0))) 3096 stopifnot(exprs = { 3097 is.logical(r <- DF == R) 3098 is.matrix(r) ## ~~~~~~~ 3099 length(r) == 0 3100 dim(r) <= dim(DF) # sometimes r is <0 x 0> when DF is not 3101 }) 3102## many of these '==' calls failed in R <= 3.6.x 3103 3104 3105## Can selectively suppress warnings 3106w <- function(class) { 3107 w <- simpleWarning("warned") 3108 w <- structure(w, class = c(class, class(w))) 3109 warning(w) 3110} 3111catch <- function(expr) tryCatch({ expr; FALSE }, warning = function(...) TRUE) 3112stopifnot(! catch(suppressWarnings(w("foo")))) 3113stopifnot(! catch(suppressWarnings(w("foo"), classes = c("bar", "foo")))) 3114stopifnot( catch(suppressWarnings(w("foo"), classes = c("bar", "baz")))) 3115rm(w, catch) 3116 3117 3118## Can selectively suppress messages 3119m <- function(class) { 3120 m <- simpleMessage("notified") 3121 m <- structure(m, class = c(class, class(m))) 3122 message(m) 3123} 3124catch <- function(expr) tryCatch({ expr; FALSE }, message = function(...) TRUE) 3125stopifnot(! catch(suppressMessages(m("foo")))) 3126stopifnot(! catch(suppressMessages(m("foo"), classes = c("bar", "foo")))) 3127stopifnot( catch(suppressMessages(m("foo"), classes = c("bar", "baz")))) 3128rm(m, catch) 3129 3130 3131## grepl(<NA>, ...) 3132N <- grepl(NA_character_, "something") 3133stopifnot(is.na(N), is.logical(N)) 3134## gave integer instead of logical in R <= 3.6.1 3135 3136 3137## options(warn=1e11) leading to infinite loop -> "C Stack ..." error 3138tools::assertError(options(warn = 1+.Machine$integer.max)) 3139## "worked" and gave problems later in R <= 3.6.1 3140 3141 3142## PR#17628 3143df <- data.frame(x = 1, y = 2); class(df$y) <- "object_size" 3144df ## --> print.data.frame(*, digits=NULL)' -- error in R <= 3.6.1 3145format(object.size(pi), digits=NULL) 3146## error in R <= 3.6.1 3147 3148## PR#15522 3149pos <- barplot(1:2, space=c(9, 1), 3150 ylim=c(0, 21), xlim=c(0, 11), horiz=TRUE, 3151 plot=FALSE) 3152stopifnot(all.equal(pos, cbind(c(9.5, 11.5)))) 3153## bar spacing was wrong in R <= 3.6.1 3154 3155## methods(class = <{length > 1}>) giving many non-helpful warnings 3156tools::assertWarning(mc <- methods(class = class(ordered(4:1))), verbose=TRUE) 3157 # class = ".S3methods", 3158stopifnot(is.character(mc), inherits(mc, "MethodsFunction"), 3159 is.data.frame(attr(mc,"info"))) 3160## warns once only, in R >= 3.6.2 3161 3162 3163## PR#17580 -- using max.lines, "truncated" 3164op <- options(error = expression(NULL)) # {careful! : errors do *NOT* stop} 3165is.t.back <- function(x) is.pairlist(x) && all(vapply(x, is.character, NA)) 3166f <- function(...) stop(deparse(substitute(...))) 3167g <- function(...) f(...) 3168do.call(g, mtcars) 3169tb. <- .traceback() 3170traceback(tb1 <- .traceback(max.lines=1))# prints with '...' as it's truncated 3171stopifnot(exprs = { 3172 is.t.back(tb.) 3173 is.t.back(tb1) 3174 length(tb.) == length(tb1) 3175 vapply(tb1, length, 0L) == 1 3176 length(tb.[[3]]) > 20 3177}) 3178f <- function() options(warn = 1+.Machine$integer.max) 3179do.call(g, mtcars) 3180tb0 <- .traceback() 3181traceback(tb3 <- .traceback(max.lines = 3)) 3182traceback(tb00 <- .traceback(max.lines = 0)) 3183options(op)# revert to normal 3184stopifnot(exprs = { 3185 is.t.back(tb0) 3186 is.t.back(tb3) 3187 is.t.back(tb00) 3188 vapply(tb0, function(.) is.null(attributes(.)), NA) 3189 length(tb0) == length(tb3) 3190 vapply(tb3 , length, 0L) <= 3 3191 vapply(tb00, length, 0L) == 0L 3192 identical(lapply(tb3, attributes), 3193 list(list(truncated = TRUE), NULL)) 3194 identical(lapply(tb00, attributes), 3195 rep(list(list(truncated = TRUE)), 2)) 3196}) 3197f <- function(...) .traceback(2, max.lines=1) 3198g( 3199 'hello hello hello hello hello hello hello hello hello hello hello', 3200 'world world world world world world world world world world world' 3201) -> tb2n1 3202stopifnot(is.character(t1 <- tb2n1[[1]]), length(t1) == 1L, attr(t1, "truncated")) 3203## partly not possible in R < 4.0.0; always deparsed in full 3204 3205 3206## PR#13624 : get_all_vars(*, <matrix>): 3207ok_get_all_vars <- function(form,d) { ## get_all_vars() :<=> model_frame() apart from "terms" 3208 mf <- if(missing(d)) model.frame(form) else model.frame(form,d) 3209 attr(mf, "terms") <- NULL 3210 identical(mf, 3211 if(missing(d)) get_all_vars(form) else get_all_vars(form,d)) 3212} 3213M <- .Date(matrix(1:15, 5,3)) # has class to be kept 3214n <- 26:30 3215T <- TRUE 3216m <- 2:7 3217stopifnot(exprs = { is.matrix(M) ; dim(M) == c(5,3) 3218 ok_get_all_vars(~ M) 3219 ok_get_all_vars(~M+n) 3220 ok_get_all_vars(~ X , list(X= M)) 3221 ok_get_all_vars(~z+X, list(X= M, z=n)) 3222 ok_get_all_vars(~z+X, list(X=I(M), z=n)) 3223 ok_get_all_vars(~z+X, data.frame( X=I(M), z=n)) 3224 ok_get_all_vars(~z+X, data.frame(list(X=I(M), z=n))) 3225 ok_get_all_vars(~z+X, as.data.frame(list(X=I(M), z=n))) 3226 lengths(d <- get_all_vars(~ n + T, "2n" = 2*n)) == 5L 3227 identical(d[,"T"], rep.int(TRUE, 5)) 3228 ## recycling works when commensurate: 3229 lengths(d6 <- get_all_vars(~ m + T, one=1, "2 s"=1:2, "3's"=3:1, `f 3` = gl(3,2))) == 6 3230 identical(colnames(d6), c("m", "T", "one", "2 s", "3's", "f 3")) 3231}) 3232## all but the first 4 cases worked already in R <= 3.6.1 3233 3234 3235## two-arg Rd macros (PR#17627) 3236parse_Rd_txt <- function(ch) tools::parse_Rd(textConnection(ch), fragment = TRUE) 3237rd1 <- parse_Rd_txt(t1 <- "\\if{html}{\\out{<hr>}}") 3238rd2 <- parse_Rd_txt(t2 <- "\\href{https://www.r-project.org}{some text}") 3239(tx1 <- paste(as.character(rd1), collapse = "")) 3240(tx2 <- paste(as.character(rd2), collapse = "")) 3241stopifnot(exprs = { 3242 identical(paste0(t1,"\n"), tx1) 3243 identical(paste0(t2,"\n"), tx2) 3244}) 3245## had duplicated braces in R < 4.0.0 3246 3247 3248## power.t.test() failure for very small (unreasonable) n; R-devel m.list Oct.4, 2019 3249(ptt0 <- power.t.test(delta=10, sd=1, power=0.9 , sig.level=0.05, tol = 1e-8)) 3250(ptt1 <- power.t.test(delta=0.6, sd=0.00001, power=0.9 , sig.level=0.05)) 3251(ptt2 <- power.t.test(delta=2, sd = 1e-8, power=0.99, sig.level=0.01)) 3252stopifnot(exprs = { 3253 all.equal(0.9, power.t.test(delta=10, sd=1, n = ptt0 $ n)$power) 3254 all.equal(ptt1$n, 1.00428, tol = 1e-5) 3255 all.equal(ptt2$n, 1.1215733, tol = 1e-5) 3256}) 3257## when uniroot() was trying n < 1, the code failed previously (in 2nd and 3rd case) 3258 3259 3260## improved error message from contour(): 3261tt <- tryCid(contour(volcano, levels = c(20*c(4:6, -Inf, 8:10)))) 3262print(tt) 3263## The rest of this message is OS-dependent: gcc 5.x on Solaris has '= -Inf' 3264## others have " = -inf" 3265stopifnot(inherits(tt, "error"), grepl("non-finite level.*\\[4\\]", tt$message)) 3266## had "invalid NA contour values" 3267 3268 3269## get_all_vars() when some variables are data frames - PR#14905 3270x <- (1:10)/10 3271Y <- data.frame(A = 2^x, B = pi*x) 3272gav <- get_all_vars(Y[,1] ~ x) 3273stopifnot(exprs = { 3274 is.data.frame(gav) 3275 ncol(gav) == 3 3276 identical(gav, cbind(Y, x)) 3277 identical(get_all_vars(x ~ Y), cbind(x, Y)) 3278}) 3279## the last were wrong in R <= 3.6.1 3280 3281 3282## get all arguments from matched argument list; failed in R <= 4.0.0 3283y <- list() 3284stopifnot(identical(attr(`attr<-`(y, value = 1, "A"), "A"), 1)) 3285y <- structure(list(), AA = 1) 3286stopifnot(is.null(attr(y, exact = TRUE, "A"))) 3287 3288 3289## 1) A matrix is an array, too: 3290stopifnot( vapply(1:9, function(N) inherits(array(pi, dim = 1:N), "array"), NA) ) 3291## was false for N=2 in R < 4.0.0 3292## 3293## 2) Matrix must dispatch for array methods, too : 3294foo <- function(x) UseMethod("foo") 3295foo.array <- function(x) "made in foo.array()" 3296stopifnot( 3297 vapply(1:9, function(N) foo(array(pi, dim = 1:N)), "chr") == foo.array()) 3298## foo(array(*)) gave error for N=2 in R < 4.0.0 3299 3300 3301## PR#17659: Some *.colors() producers have appended (alpha=1) info even by default 3302fnms <- c(apropos("[.]colors$"), "rainbow") # 8 x "<foo>.colors" + rainbow 3303for(fn in fnms) { 3304 Fn <- get(fn, mode="function") 3305 cat(sprintf("%14s(n), n = 1,2,3 : ", fn)) 3306 for(n in 1:3) 3307 stopifnot(length(cc <- Fn(n)) == n, 3308 nchar(cc) == 1L+6L, # just RGB, no alpha 3309 identical(cc, Fn(n, alpha=NULL))) 3310 cat("[Ok]\n") 3311} 3312## in R <= 3.6.x, four of these functions gave extra alpha=1 info (appended "FF") 3313 3314 3315## Generalized head(x, n) and tail() methods - for length(n) > 1 and arbitrary array x 3316## PR#17652 3317## -------- pkg glmmTMB uses head(.) on calls quite a bit 3318cForm <- quote(some ~ really + quite + longish + but:still:not:very:long * 3319 (formula | reality / extreme:cases:you:never:think:of)) 3320fL <- eval(cForm) 3321length(fRHS <- fL[[3]]) 3322cLong <- quote(fun_with_many_args(1,2,3, 4,5,6, 7,8,9)) 3323a1 <- structure(array(1:7, 7 ), class = "foo") 3324a3 <- structure(array(1:24, 2:4), class = "foo") 3325stopifnot(exprs = { 3326 ## these all work as previously 3327 head(cForm,1) == `~`() 3328 head(cForm,2) == ~some 3329 head(cForm) == cForm 3330 is.call(cl <- quote((Days|Subject))) 3331 is.call(fL) 3332 inherits(fL, "formula") 3333 head(fL) == fL 3334 ## == tail === 3335 identical(tail(cForm,1), cForm[3]) 3336 tail(cForm,2) == cForm[2:3] 3337 tail(cForm) == cForm 3338 tail(fL) == fL 3339 ## 3340 ## -------------failed from here ----------------------- 3341 identical(head(cl), cl) ## for a few days, gave Error in do.call(..): object 'Days' not found 3342 identical( head(fRHS), fRHS) 3343 identical(head(cLong), cLong[1:6]) 3344 identical(head(cLong, 2), cLong[1:2]) 3345 identical(head(cLong, 1), quote(fun_with_many_args())) 3346 ## == tail === 3347 identical(tail(cl), cl) ## for a few days, gave Error ...: object 'Days' not found 3348 identical( tail(fRHS), fRHS) 3349 identical(tail(cLong), cLong[tail(seq_along(cLong))]) 3350 identical(tail(cLong, 2), cLong[9:10]) 3351 identical(tail(cLong, 1), cLong[10]) 3352 ## funny arrays 3353 identical(head(a1,1), a1[1, drop=FALSE]) 3354 identical(head(a3,1), a3[1, ,, drop=FALSE]) 3355 identical(tail(a3,1), a3[2, ,, drop=FALSE]) 3356}) 3357## 3358## Ensure that the code does not access dimensions it does not need (pkg TraMineR): 3359`[.noCol` <- function(x, i, j, drop = FALSE) { 3360 if(!missing(j)) stop(" [!] Column subscripts not allowed", call. = FALSE) 3361 NextMethod("[") 3362} 3363noC <- structure(datasets::trees, class = c("noCol", "data.frame")) 3364assertErrV( noC[1,2]) # fails indeed 3365stopifnot(exprs = { 3366 identical(head(noC), noC[1:6,]) 3367 identical(head(noC, 1), noC[1, ]) 3368 identical(tail(noC, 1), noC[31,]) 3369}) 3370## 3371## For all arrays 'a', head(a, 1) should correspond to a[1, {,}* , drop = FALSE] 3372## length(n) > length(dim(x)) (or 1L if dim(x) is NULL) is an error 3373str(Alis <- lapply(1:4, function(n) {d <- 1+(1:n); array(seq_len(prod(d)), d) })) 3374h2 <- lapply(Alis, head, 2) 3375t2 <- lapply(Alis, head, 2) 3376assertErrV( head(Alis[[1]], c(1, NA))) 3377assertErrV( tail(1:5, c(1, NA))) 3378h1 <- lapply(Alis, head, 1) 3379t1 <- lapply(Alis, tail, 1) 3380dh1 <- lapply(h1, dim) 3381## n =1L and n=c(1, NA) equivalent (only ones with 2+ dimensions) 3382Alis2p <- Alis[-1] 3383h1N <- lapply(Alis2p, head, c(1, NA)) 3384t1N <- lapply(Alis2p, tail, c(1, NA)) 3385Foolis <- lapply(Alis, `class<-`, "foo") 3386assertErrV( head(Foolis[[1]], c(1, NA))) 3387h1F <- lapply(Foolis, head, 1) 3388h2F <- lapply(Foolis, head, 2) 3389t1F <- lapply(Foolis, tail, 1) 3390t2F <- lapply(Foolis, tail, 2) 3391Foolis2p <- Foolis[-1] 3392h1FN <- lapply(Foolis2p, head, c(1, NA)) 3393t1FN <- lapply(Foolis2p, tail, c(1, NA)) 3394stopifnot(exprs = { 3395 identical(h2, Alis) 3396 identical(t2, Alis) 3397 vapply(h1, is.array, NA) 3398 vapply(t1, is.array, NA) 3399 identical(dh1, lapply(1:4, function(n) seq_len(n+1L)[-2L])) 3400 identical(dh1, lapply(t1, dim)) 3401 identical(h1, c(list(Alis [[1]][1, drop=FALSE]), h1N)) 3402 identical(t1, c(list(Alis [[1]][2, drop=FALSE]), t1N)) 3403 identical(h1F, c(list(Foolis[[1]][1, drop=FALSE]), h1FN)) 3404 identical(t1F, c(list(Foolis[[1]][2, drop=FALSE]), t1FN)) 3405}) 3406## This was *not the case for 1d arrays in R <= 3.6.x 3407## 3408tools::assertWarning(t3 <- tail(iris3[,1,], addrownums = FALSE), verbose=TRUE) 3409stopifnot( identical(t3, tail(iris3[,1,], keepnums = FALSE)) ) 3410## 3411## 4-dim array 3412## 4th dimension failed transiently when I using switch() in keepnums logic 3413adims <- c(11, 12, 4, 3) 3414arr <- array(seq_len(prod(adims)), adims) 3415headI4 <- function(M, n) { 3416 d <- dim(M) 3417 M[head(seq_len(d[1]), n[1]), 3418 head(seq_len(d[2]), n[2]), 3419 head(seq_len(d[3]), n[3]), 3420 head(seq_len(d[4]), n[4]), 3421 drop = FALSE] 3422} 3423tailI4 <- function(M, n) { 3424 d <- dim(M) 3425 M[tail(seq_len(d[1]), n[1]), 3426 tail(seq_len(d[2]), n[2]), 3427 tail(seq_len(d[3]), n[3]), 3428 tail(seq_len(d[4]), n[4]), 3429 drop = FALSE] 3430} 3431 3432n.set2 <- lapply(-2:2, rep, times = 4) 3433stopifnot( 3434 vapply(n.set2, function(n) identCO (head(arr, n), headI4(arr, n)), NA), 3435 vapply(n.set2, function(n) identCO (tail (arr, n, keepnums=FALSE), 3436 tailI4(arr, n)), NA), 3437 vapply(n.set2, function(n) all.equal(tail(arr, n), tailI4(arr, n), 3438 check.attributes=FALSE), NA)) 3439 3440## full output 3441aco <- capture.output(arr) 3442## extract all dimnames from full output 3443## assumes no spaces in names 3444## assumes NO WRAPPING when printing rows! 3445getnames <- function(txt, ndim = 4) { 3446 el <- which(!nzchar(txt)) 3447 ## first handled elsewhere, last is just trailing line 3448 el <- el[-c(1L, length(el))] 3449 hdln <- c(1L, el[seq(2, length(el), by = 2)] - 1L) 3450 hdraw <- lapply(txt[hdln], function(tx) strsplit(tx, ", ")[[1L]]) 3451 3452 ## line 1 is higher indices, 2 is blank, 3 is columns 3453 cnms <- strsplit(trimws(txt[3], which = "left"), split = "[[:space:]]+")[[1]] 3454 cnms <- cnms[nzchar(cnms)] 3455 matln <- 4:(el[1] - 1L) 3456 rnms <- gsub("^([[:space:]]*[^[:space:]]+)[[:space:]].*", "\\1", txt[matln]) 3457 hdnms <- lapply(3:ndim, ## blank ones are left in so this is ok 3458 function(i) unique(sapply(hdraw, `[`, i ))) 3459 c(list(rnms, cnms), 3460 hdnms) 3461} 3462fpnms <- getnames(aco, length(adims)) 3463## ensure all dimnames correct for keepnums = TRUE 3464stopifnot( 3465 vapply(n.set2, function(n) identical(dimnames(tail(arr, n)), 3466 mapply(function(x, ni) if(ni != 0) tail(x, ni), 3467 x = fpnms, ni = n, SIMPLIFY = FALSE)), 3468 NA) 3469) 3470## mix named and non-named dimensions to catch bug in initial keepnums patch 3471arr2 <- arr 3472adnms <- lapply(seq_along(adims), 3473 function(i) paste0("dim_", i, "_", seq(1L, adims[i]))) 3474adnms[3L] <- list(NULL) 3475dimnames(arr2) <- adnms 3476ii <- seq_along(adnms) 3477stopifnot( 3478 vapply(n.set2, function(n) 3479 identical(dimnames(tail(arr2, n)), 3480 mapply(function(i, ni) { 3481 x <- adnms[[i]] 3482 if(is.null(x)) 3483 x <- as.character(seq_len(adims[i])) 3484 if(ni != 0L) 3485 tail(x, ni) 3486 }, 3487 i = ii, ni = n, SIMPLIFY = FALSE)), 3488 NA) 3489) 3490## 3491## matrix of "language" -- with expression() 3492is.arr.expr <- function(x) is.array(x) && is.expression(x) 3493e <- matrix(expression(foo(2), bar(x), r(foobar), foo(rbar)), 2) 3494str(h1 <- head(e, 1)) 3495str(t1 <- tail(e, 1)) 3496stopifnot(exprs = { 3497 is.arr.expr(e) && identical(dim(e), c(2L, 2L)) 3498 is.arr.expr(h1) && identical(dim(h1), c(1L, 2L)) 3499 is.arr.expr(t1) && identical(dim(t1), c(1L, 2L)) 3500 is.arr.expr(ee <- e[rep(1:2, 3), rep(1:2, 2)]) && identical(dim(ee), c(6L, 4L)) 3501 is.arr.expr(hee <- head(ee, n=c(2,-1))) && identical(dim(hee), 2:3) 3502 is.arr.expr(tee <- tail(ee, n=c(-3,1))) && identical(dim(tee), c(3L, 1L)) 3503}) 3504## (for length(n) == 1, has worked the same "always") 3505 3506 3507## Forgotten 'drop=FALSE' in plot.formula() 3508df <- data.frame(x=1:3, grp=c("A","A","B"), stringsAsFactors = TRUE) 3509plot( ~grp, data=df, subset = x > 1) 3510## failed in R <= 3.6.1 3511 3512 3513## dnorm() etc border cases, notably sigma = -Inf 3514tools::assertWarning(v0Neg <- dnorm(0:1, sd = -Inf)) 3515tools::assertWarning(dlInf0 <- dlnorm(Inf,Inf, sd = 0)) 3516stopifnot(is.nan(v0Neg), is.nan(dlInf0)) 3517## in R <= 3.6.2, v0Neg was 0 w/o any warning; dlnorm(...) was +Inf 3518 3519 3520## Unusual frequency and start not supported by ts() and window() 3521x <- ts(x, start = 2.5, end = 107.5, frequency = 0.2) 3522(wx <- window(x, start = 20, end = 30, extend = TRUE)) 3523stopifnot(exprs = { 3524 all.equal(attributes(x), list(tsp = c(2.5, 107.5, 0.2), class = "ts")) 3525 all.equal(wx, structure(c(0.5, 0.6), .Tsp = c(22.5, 27.5, 0.2), class = "ts")) 3526}) 3527assertErrV(cbind(ts(1:2, start = 0.5, end = 1.5), 3528 ts(1:2, start = 0 , end = 1))) 3529## Wrong results in R < 4.0.0 3530## New checks needed tweaks : 3531## -- 1 -- 3532frYr <- 365.25 3533tt <- (0:3652)/frYr 3534timeO <- structure(tt, .Tsp = c(1981, 1990.998631, frYr), class = "ts") 3535ttt <- time(timeO) # Error "'end' must be a whole number of cycles after 'start'" 3536## -- 2 -- 3537set.seed(7); tt <- ts(rnorm(60), frequency=12) 3538dt2 <- diff(tt, differences = 2) # Error in .cbind.ts(..): not all series have the same phase 3539tsD <- ts(1:49, start=as.Date("2019-12-12"), frequency=12) 3540stopifnot(exprs = { 3541 all.equal(timeO, ttt - 1981, tol = 1e-8) 3542 inherits(ttt, "ts") 3543 inherits(dt2, "ts") 3544 length(dt2) == length(tt) - 2L 3545 all.equal(6*tsp(dt2), c(7, 35.5, 72)) 3546 all.equal(dt2[1:2], c(3.986498, -0.22047961)) 3547 all.equal(tsD, structure(1:49, .Tsp = c(18242, 18246, 12), class = "ts")) 3548}) 3549## failed for a while in R-devel 2019-12-* 3550 3551 3552 3553## Using deparse1() fixing potential naming problems in many places, PR#17671 3554(acl <- do.call(acf, list(lynx, plot=FALSE))) 3555set.seed(7); t44 <- table(sample(LETTERS[1:4], size = 50, replace=TRUE), 3556 sample(letters[1:4], size = 50, replace=TRUE)) 3557ft44 <- do.call(fisher.test, list(t44)) 3558stopifnot(length(acl$series) == 1, 3559 length(do.call(pacf, list(lynx, plot=FALSE))$series) == 1, 3560 identical(t44, eval(str2lang(ft44$data.name)))) 3561## funny data names in R < 4.0.0 3562 3563 3564## wilcox.test(x,{y,} ..): when 'x' and/or 'y' contain +/- Inf 3565dfn <- c(shifted = function(L) 1/8 + c(9:4, L), # <- without, and 3566 ties = function(L) c(9:4, L)) # <- with ties 3567oWarn <- getOption("warn") 3568for(nm in names(dfn)) { 3569 y7 <- dfn[[nm]] 3570 options(warn = if(nm == "ties") 1 else 2) ## "ties" : ==> 2 x 3 (different) warnings 3571 w2 <- lapply(c(1000, Inf), function(L) wilcox.test(1:7, y7(L))) 3572 w1 <- lapply(c(1000, Inf), function(L) wilcox.test( y7(L) )) 3573 w2p <- lapply(c(1000, Inf), function(L) wilcox.test(1:7, y7(L), paired= TRUE)) 3574 w2n <- lapply(c(1000, Inf), function(L) wilcox.test(1:7, y7(L), exact = FALSE)) 3575 w2pn<- lapply(c(1000, Inf), function(L) wilcox.test(1:7, y7(L), exact = FALSE, paired=TRUE)) 3576 stopifnot(exprs = { 3577 identical(w2 [[1]], w2 [[2]]) # was FALSE in R <= 3.6.x 3578 identical(w1 [[1]], w1 [[2]]) # was FALSE .. 3579 identical(w2p [[1]], w2p [[2]]) 3580 identical(w2n [[1]], w2n [[2]]) # was FALSE .. 3581 identical(w2pn[[1]], w2pn[[2]]) 3582 }) 3583}; options(warn = oWarn) 3584## non-paired cases treated 'Inf' non-robustly in R <= 3.6.x 3585wII <- wilcox.test(c(-Inf, 1:5, Inf), c(-Inf, 4*(0:4), Inf), paired=TRUE) # error in R <= 3.6.x 3586 w1 <- wilcox.test(c( 1:5, Inf), c( 4*(0:4), Inf), paired=TRUE) # ditto 3587(w0 <- wilcox.test( 1:5, 4*(0:4), paired=TRUE)) 3588sel <- names(w0) != "data.name" 3589stopifnot(identical(w0[sel], w1[sel]), identical(w0[sel], wII[sel])) 3590## Inf-Inf etc broken in paired case in R <= 3.6.x 3591 3592 3593if(FALSE){ ## pro tem 3594## round(x, n) "to even" failed in some cases -- PR#17668 3595dd <- 0:12 3596x55 <- 55 + as.numeric(vapply(dd+1, function(k) paste0(".", strrep("5",k)), "")) 3597 3598rnd.x <- vapply(dd+1L, function(k) round(x55[k], dd[k]), 1.1) 3599noquote(formatC(cbind(x55, dd, rnd.x), w=1, digits=15)) 3600signif (rnd.x - x55, 3) # look at .. but don't test (yet) 3601stopifnot(exprs = { 3602 all.equal(abs(rnd.x - x55), 5 * 10^-(dd+1), tol = 1e-11) # see diff. of 6e-13 3603}) 3604## more than half of the above were rounded *down* in R <= 3.6.x 3605## Some "wrong" test cases from CRAN packages (partly relying on wrong R <= 3.6.x behavior) 3606stopifnot(exprs = { 3607 all.equal(round(10.7775, digits=3), 10.778, tolerance = 1e-12) # even tol=0, was 10.777 3608 all.equal(round(12345 / 1000, 2), 12.35 , tolerance = 1e-12) # even tol=0, was 12.34 in Rd 3609 all.equal(round(9.18665, 4), 9.1866, tolerance = 1e-12) # even tol=0, was 9.1867 3610}) 3611## This must work, too, the range of 'e' depending on 'd' 3612EE <- c(-307, -300, -250, -200,-100,-50, -20, -10, -2:2, 3613 10, 20, 50, 100, 200, 250, 290:307) 3614for(d in 0:16) { cat("digits 'd' = ", d, ": ") 3615 for(e in EE[EE+d <= 308]) { 3616 f <- 10^e 3617 cat(".") 3618 stopifnot(all.equal(tolerance = if(d < 14) 1e-15 3619 else if(d == 14) 1e-14 else 1e-13, 3620 round(pi/f, e + d) * f, 3621 round(pi, d))) 3622 };cat("\n") 3623} 3624## (2nd part: continued working) 3625i <- c(-2^(33:10), -10:10, 2^(10:33)) 3626for(digi in c(0:10, 500L, 1000L, 100000L, .Machine$integer.max)) 3627 stopifnot(identical(i, round(i, digi)), 3628 identical(i+round(1/4, digi), round(i+1/4, digi))) 3629x <- 7e-304; rx <- round(x, digits=307:322); xx <- rep(x, length(rx)) 3630print(cbind(rx), digits=16) # not really what ideally round() should do; but "ok" 3631 all.equal(rx, xx, tol = 0)# show "average relative difference" ("5.6856 e -16") 3632stopifnot(all.equal(rx, xx, tol = 1e-4)) # tol may change in future 3633## the round(i, *) failed, for ~ 2 days, in R-devel 3634e <- 5.555555555555555555555e-308 3635(e10 <- e * 1e298) # 5.555556e-10 -- much less extreme, for comparison 3636ds <- 20:1 ; s.e <- signif(e, ds) ; names(s.e) <- paste0("d", ds) 3637 3638## currently, for round, digits := pmin(308, digits) -- not going further than 310 3639d <- 310:305; r.e <- round (e, d) ; names(r.e) <- paste0("d", d) 3640d <- d - 298; r.e10 <- round (e10, d) ; names(r.e10) <- paste0("d", d) 3641op <- options(digits=18) 3642cbind(signif = c(e, s.e)) ##-- this always rounds up (= to even) 3643cbind( round = c(e, r.e), round.10 = c(e10, r.e10)) 3644iSub <- 6 : (18 + capabilities("long.double")) 3645stopifnot(exprs = { 3646 ## the regularity of signif()'s result is amazing: 3647 is.integer(d <- ds[iSub] - 1L) 3648 all.equal(log10(abs(1 - diff(unname(s.e))[iSub] * 1e308*10^d / 4)), 3649 d - 16, tol = 0.08) # tol: seen 0.0294 / 0.02988 (Win 32b) 3650 all.equal(r.e * 1e298, r.e10, 3651 check.attributes = FALSE, countEQ=TRUE, tol=1e-14) 3652}) 3653## was not true for digits = 309, 310 in R <= 3.6.x 3654## 3655## round(*, digits < 0) 3656M <- .Machine$double.xmax 3657rM <- round(M, -(1:400)) 3658stopifnot(exprs = { 3659 rM[(1:400) > 308] == 0 3660### platform (compiler configuration) dependent: 3661 ## identical(which(rM == Inf), 3662 ## c(if(!b64) 294L, 298L, 299L, 304:308) -> II) 3663 ## is.finite(rM[-II]) 3664}) 3665## had many Inf and NaN; now looks optimal: 'Inf' are "correct" rounding up 3666## 3667(mm <- 2^-(1022+52)) # denormalized smallest number 3668mm == 1.49*mm # yes, that's "denormal" 3669dr <- diff(rmm <- round(mm, 301:500)) 3670(inz <- which(dr != 0)) 3671stopifnot(length(inz) == 1, dr[inz] == mm, dr[-inz] == 0, 3672 rmm[-(1:23)] == mm) 3673options(op) ## in R <= 3.6.x, all(rmm == 0) 3674} 3675 3676## update.formula() triggering terms.formula() bug -- PR#16326 3677mkF <- function(nw) as.formula(paste("y ~ x + x1", 3678 paste0("- w", seq_len(nw), collapse="")), 3679 env = .GlobalEnv) 3680fterms <- function(n, simplify=TRUE) formula(terms.formula(mkF(n), simplify=simplify)) 3681if(interactive()) 3682 for(n in 1:20) print(fterms(66)) # always correct now: y ~ x + x1 3683## used to have a '-1' (and much more, see below) in R <= 3.6.2 3684## NB: had memory / random behavior -- and sometimes ended in 3685## malloc(): corrupted top size 3686## Process R... aborted (core dumped) 3687set.seed(17) 3688N <- 1024 3689Ns <- sort(1 + rpois(N, 3)+ 16*rpois(N, 3)) 3690FN <- lapply(Ns, fterms) 3691(UFN <- unique(FN)) 3692stopifnot(identical(y ~ x + x1, UFN[[1]])) 3693## Ended in this error [which really comes from C code trying to set dimnames !] : 3694## Error in terms.formula(mkF(n), simplify = simplify) : 3695## 'dimnames' applied to non-array 3696## 3697##--TODO: less severe now (no seg.fault / corrupt memory crashes), but still really bad ! --- 3698 3699 3700## Corner cases in choose(), 3701## misbehaved when n was _nearly_ int, and n - k < k 3702stopifnot(choose(4 - 1e-7, 4) == 1) 3703stopifnot(choose(4 + 1e-7, 4) == 1) 3704## These gave 0 and 4 in R <= 3.6.x 3705 3706 3707## correct error message: 3708tt <- tryCid(strptime(100, pi)) 3709stopifnot(inherits(tt, "error"), grepl("'format'", tt$message)) 3710## had 'x' instead of 'format' 3711 3712 3713## r<integer-RV>() now return double if integer would overflow: 3714set.seed(47) 3715Npi <- rpois(100, 0.9999 *2^31) 3716Npd <- rpois(100, 0.99999*2^31)# had 33 NA's 3717Nbi <- rbinom(100, 2^31, 1/2) 3718Nbd <- rbinom(100, 2^32, 1/2)# 51 NA's 3719Ngi <- rgeom(999, 1e-8) 3720Ngd <- rgeom(999, 1e-9) # 106 NA's 3721stopifnot(is.integer(Npi), is.double(Npd), !anyNA(Npi), !anyNA(Npd), 3722 is.integer(Nbi), is.double(Nbd), !anyNA(Nbi), !anyNA(Nbd), 3723 is.integer(Ngi), is.double(Ngd), !anyNA(Ngi), !anyNA(Ngd), 3724 TRUE) 3725## had many NA's in 3.0.0 <= R <= 3.6.x 3726 3727 3728## rhyper() for some large arguments, PR#17694 3729n <- 2e9 # => .Machine$integer.max ~= 1.07 * N 3730set.seed(6860); N <- rhyper(1, n,n,n) 3731x <- 1.99e9; Nhi <- rhyper(256, x,x,x) 3732stopifnot(#identical(N, 999994112L), # (wrong) implementation detail 3733 is.integer(Nhi), 3734 all.equal(mean(Nhi), x/2, tol = 6e-6)) # ==> also: no NAs 3735## NA's and warnings, incl "SHOULD NOT HAPPEN!" in R <= 3.6.2 3736 3737 3738## assertCondition(*, "error") etc triggered errors *twice* (accidentally) 3739stopifnot(identical(tools::assertError(sqrt("a")), 3740 list( tryCid(sqrt("a"))))) 3741## The former contained the error object twice in R <= 3.6.2 3742 3743 3744## Overriding encoding in parse() 3745if (l10n_info()$"UTF-8" || l10n_info()$"Latin-1") { 3746 x8 <- "'\uf6'" 3747 x8.2 <- substr(x8, 2, 2) 3748 stopifnot(identical(Encoding(x8), "UTF-8")) 3749 f8 <- tempfile() 3750 writeLines(x8, f8, useBytes=TRUE) # save in UTF-8 3751 ## 3752 chk_x82 <- function(x) stopifnot(identical(Encoding(x), "UTF-8"), 3753 identical(x, x8.2)) 3754 ## parse(*, encoding = "UTF-8", ..) : 3755 for(FF in c(function(.) parse(text=., encoding="UTF-8", keep.source=TRUE), 3756 function(.) parse(text=., encoding="UTF-8", keep.source=FALSE) 3757 )) { 3758 x <- eval(FF(x8)) 3759 chk_x82(x) 3760 } 3761 for(K.S in c(TRUE, FALSE)) { 3762 x <- eval(parse(file=f8, encoding="UTF-8", keep.source = K.S)) 3763 chk_x82(x) 3764 } 3765 ## latin1 <--> UTF-8 3766 xl <- iconv(x8, from="UTF-8", to="latin1") 3767 stopifnot(identical(Encoding(xl), "latin1")) 3768 stopifnot(identical(x8, iconv(xl, from="latin1", to="UTF-8"))) 3769 unlist(l10n_info()) # to see .. 3770} 3771if (l10n_info()$"UTF-8") { 3772 for(x in c(eval(parse(text=x8)), 3773 eval(parse(text=xl, keep.source=TRUE)), 3774 eval(parse(text=xl, keep.source=FALSE)), 3775 eval(parse(file=f8)), 3776 str2lang(x8), 3777 str2expression(x8))) 3778 stopifnot(identical(x, x8.2)) 3779} 3780if (l10n_info()$"Latin-1") { 3781 for(x in c(eval(parse(text=xl)), 3782 eval(parse(text=x8, keep.source=TRUE)), 3783 eval(parse(text=x8, keep.source=FALSE)), 3784 str2lang(x8), 3785 str2expression(x8))) 3786 stopifnot(identical(x, x8.2)) 3787} 3788## parse(text=xl) had failed w/ "EOF whilst reading MBCS char at line 2" 3789 3790 3791## smoothEnds(<integer>, .) - PR#17693 3792y1 <- as.integer(c(8,5,4,1,1,1,1)) 3793y2 <- y1; y2[3] <- 6L 3794s1 <- smoothEnds(y1); s1.5 <- smoothEnds(y1, 5) 3795s2 <- smoothEnds(y2); s2.5 <- smoothEnds(y2, 5) 3796stopifnot(is.integer(y1), is.integer(y2), y1[-3] == y2[-3], 3797 is.integer(s1), is.integer(s2), 3798 is.integer(s1.5), is.integer(s2.5), 3799 s1[1] == 7L, s1[-1] == y1[-1], identical(s1.5, s1), 3800 s2[1] == 5L, s2[-1] == y2[-1], identical(s2.5, rep(c(6L, 1L), 3:4))) 3801## s1, s1.5 were double in R <= 3.6.x 3802 3803 3804## stopifnot() custom message now via <named> args: 3805e <- assertErrV(stopifnot("ehmm, you must be kidding!" = 1 == 0)) 3806stopifnot(grepl("must be kidding!", e[[1]]$message)) 3807e2 <- assertErrV(stopifnot("2 is not approximately 2.1" = all.equal(2, 2.1))) 3808stopifnot(grepl("not approximately", e2[[1]]$message)) 3809## did not work in original stopifnot(<named>) patch 3810CHK <- function(...) stopifnot(...) 3811e <- tryCid(CHK(1 == 1, 1 == 0)) 3812e2 <- tryCid(CHK(1 == 1, "not possible" = 1 == 0)) 3813stopifnot(inherits(e , "error"), grepl("is not TRUE", e$message), 3814 inherits(e2, "error"), identical("not possible", e2$message)) 3815## wrapping stopifnot() in this way did not work in some unreleased R-devel 3816 3817 3818## norm(<matrix-w-NA>, "2") 3819stopifnot(is.na( norm(diag(c(1, NA)), "2") )) 3820## gave error from svd() in R <= 3.6.x 3821 3822 3823## norm(<matrix-w-NA>, "F") 3824(m <- cbind(0, c(NA, 0), 0:-1)) 3825nTypes <- eval(formals(base::norm)$type) # "O" "I" "F" "M" "2" 3826print( # stopifnot( -- for now, as Lapack is still broken in some OpenBLAS -- FIXME 3827 is.na( print(vapply(nTypes, norm, 0., x = m)) )) # print(): show NA *or* NaN 3828## "F" gave non-NA with LAPACK 3.9.0, before our patch in R-devel and R-patched 3829 3830 3831## dimnames(<matrix>)[[.]] <- v -- inconsistency when length(v) == 1 : PR#17719 3832aa <- matrix(1:2); dimnames(aa)[[1]] <- c("a", "b") # OK (always) 3833 a <- matrix(1) ; dimnames(a )[[1]] <- "a" # gave error: 'dimnames' must be a list 3834stopifnot(exprs = { 3835 identical(dimnames(a ), list( "a", NULL)) 3836 identical(dimnames(aa), list(c("a","b"), NULL)) 3837}) 3838## The above works, because now, `[[<-` is consistently returning a list: 3839N <- NULL; N[["a"]] <- 1:2; stopifnot(identical(N, list(a = 1:2))) 3840N <- NULL; N[["a"]] <- 1 ; stopifnot(identical(N, list(a = 1))) 3841## the latter gave c(a = 1) in earlier versions of R 3842 3843 3844## deparse(), dput(), etc : "all" now includes "digits17"; new "exact" 3845x <- 1 - 2^-51 ; dput(x, , "all") 3846stopifnot(exprs = { 3847 identical(deparse(x), as.character(x)) 3848 identical(deparse(x), "1") # default only uses 15 (= DBL_DIG) digits 3849 if(!capabilities("long.double")) TRUE else 3850 identical(x, as.numeric(deparse(x, control="all"))) 3851 identical(x, as.numeric(deparse(x, control="exact") -> dx.x)) 3852 identical(print(dx.x), deparse(x, control="hexNumeric")) 3853 TRUE || ## maybe not on all platforms ? 3854 identical(dx.x, "0x1.ffffffffffffcp-1") # on 32-bit, too 3855}) 3856## "all" gave "1" in R <= 3.6.z 3857 3858 3859## Can suppress warnings with missing restarts 3860cnd <- simpleWarning("foo") 3861out <- tryCatch(suppressWarnings(stop(cnd)), warning = identity) 3862stopifnot(identical(out, cnd)) 3863## Can suppress messages with missing restarts 3864cnd <- simpleMessage("foo") 3865out <- tryCatch(suppressMessages(stop(cnd)), message = identity) 3866stopifnot(identical(out, cnd)) 3867 3868 3869## PR#17730 -- data() should no longer "lie" and warn {already have getOption("warn") == 2 3870for(p in c("base", "stats")) { 3871 dd <- data(package=p) 3872 stopifnot(inherits(dd, "packageIQR"), is.list(dd), 3873 nrow(dd$results) == 0) 3874} 3875## gave all data from pkg 'datasets' *and* warned in R <= 3.6.3 3876 3877 3878## PR#17756: x[[Inf]] and also x[[ -i ]] , for i in (Inf, 1,2,...): 3879obj <- list( 3880 a = 1:3 3881 , L3 = as.list(1:3) 3882 , L = list(a = 1:2) 3883 , L2 = list(a = 1:2, b = 3:5) 3884 , LL2 = list(a = list(a1=1:3, a2=letters[1:4]), 3885 b = list(b1=10, b2=-(1:3))) 3886 ) 3887obj$ LL3 <- c(obj$ LL2, list(c = list(c1= 7, c2= -11))) 3888stopifnot( print(vapply(obj[-1], function(x) is.null(x[[Inf]]), NA)) ) 3889t_mInf <- lapply(obj, function(x) tryCid(x[[-Inf]])) 3890getMsg <- function(tryClist) vapply(tryClist, conditionMessage, "..") 3891stopifnot(length(print(table(msg_Inf <- getMsg(t_mInf)))) == 1) 3892## in R <= 3.6.3: 3893## attempt to select less than one element in get1index <real> : 1 x 3894## attempt to select more than one element in get1index <real> : 5 x 3895 3896umInf <- unique(msg_Inf) 3897str(t_m1 <- lapply(obj, function(x) tryCid(x[[-1]]))) # L2, LL2 "work" - why? 3898 t_m2 <- lapply(obj, function(x) tryCid(x[[-2]])) # L2, LL2 "work" - why? 3899 t_m3 <- lapply(obj, function(x) tryCid(x[[-3]])) 3900nonL2 <- grep("L2$", names(t_m1), value=TRUE, invert=TRUE) 3901stopifnot(exprs = { 3902 identical(getMsg(t_m3), msg_Inf) 3903 identical(t_m2$L2, 1:2) 3904 identical(t_m2$LL2, obj$LL2[[1]]) 3905 identical(getMsg(t_m1[nonL2]), msg_Inf[nonL2]) 3906 identical(getMsg(t_m2[nonL2]), msg_Inf[nonL2]) 3907}) 3908if(englishMsgs) { cat("checking (default = ) English error messages\n") 3909 stopifnot(grepl("negative subscript", umInf)) 3910} 3911## 3912 3913 3914## paste(..., recycle0=TRUE) uses the "normal" 0-length recycling rule: 3915## "if one argument has length zero, the result has too." 3916ch0 <- character(0) 3917stopifnot(exprs = { 3918 ## a) when paste() has 0 '...' arguments : 3919 identical(paste (), ch0) ## collapse = NULL ----------- 3920 identical(paste0(), ch0) 3921 identical(paste (collapse= "A" ), "") 3922 identical(paste0(collapse="foof"), "") 3923 identical(paste (collapse= "A" , recycle0 = TRUE), "") # new! 3924 identical(paste0(collapse="foof", recycle0 = TRUE), "") # new! 3925 ## 3926 ## b) when all '...' arguments have length 0 : 3927 ## ---- collapse = NULL ------------- 3928 identical(paste({}), ch0) 3929 identical(paste({}, recycle0 = TRUE), ch0) 3930 identical(paste({}, NULL, ch0), ch0) 3931 identical(paste({}, NULL, ch0, recycle0 = TRUE), ch0) 3932 ## ---- collapse not NULL --------- 3933 identical(paste({}, collapse=""), "") 3934 identical(paste({}, collapse="", recycle0 = TRUE), "") # new! 3935 identical(paste({}, NULL, ch0, collapse=""), "") 3936 identical(paste({}, NULL, ch0, collapse="", recycle0 = TRUE), "") # new! 3937 ## 3938 ## c) when *one* of the ...-args has length 0 : 3939 identical(paste ("foo", character(0), "bar", recycle0 = FALSE), "foo bar") 3940 identical(paste0("foo", character(0), "bar", recycle0 = FALSE), "foobar") 3941 identical(paste ("foo", character(0), "bar", recycle0 = TRUE), ch0) 3942 identical(paste0("foo", character(0), "bar", recycle0 = TRUE), ch0) 3943 identical(paste ("foo", character(0), "bar", recycle0 = TRUE, collapse="A"), "") 3944 identical(paste0("foo", character(0), "bar", recycle0 = TRUE, collapse="A"), "") 3945}) 3946## 0-length recycling with default recycle0 = FALSE has always been "unusual" 3947## ----------------- with recycle0 = TRUE returns 0-length i.e. character(0) 3948 3949 3950## aov() formula deparsing {Jan Hauffa, Apr 11, 2020, on R-devel} 3951mkAov <- function(nms, n = 50) { 3952 dflong <- as.data.frame(matrix(pi, n, length(nms), 3953 dimnames = list(NULL, nms))) 3954 forml <- as.formula(paste0("cbind(", paste(nms, collapse = ","), ") ~ 1 + Error(1)")) 3955 aov(forml, data=dflong) 3956} 3957nLng <- paste0("someReallyLongVariableName", 1:20) 3958cf1 <- coef(fm1 <- mkAov(vnms <- paste0("v", 1:20))) 3959cfL <- coef(fmL <- mkAov(nLng)); colnames(cfL[[1]]) <- vnms 3960stopifnot(all.equal(cf1, cfL)) 3961## mkAov(nLng) failed in R <= 4.0.0 3962 3963 3964## UTF8 validity checking internal in R (from PCRE, PR#17755) 3965## This is the byte representation of U+D800 (a part of a surrogate 3966## pair) in UTF-8, but do not rely on parser (which on some platforms 3967## has mis-parsed that) 3968stopifnot(identical(validUTF8("\xed\xa0\x80"), FALSE)) 3969 3970## summary.warnings() -- reported by Allison Meisner, jhmi.edu 3971testf <- function(x) { 3972 if(x > 30) 3973 warning("A big problem (should be 20 of these)") 3974 else 3975 warning("Bigger problem (should be 30 of these)") 3976} 3977op <- options(warn=0) 3978for(i in 1:50) testf(i) # -> 50 warnings .. 3979options(op)# reset 3980(sw <- summary(warnings())) 3981stopifnot(identical(unlist(lapply(names(sw), substr, 1, 6)), c("Bigger", "A big ")), 3982 identical(attr(sw, "counts"), c(30L, 20L))) 3983## was wrong (mis-sorted counts) in R <= 4.0.0 3984 3985 3986## plot.formula(.., ylab = <call>) 3987dd <- list(x = -4:4, w = 1/(1+(-4:4)^2)) 3988plot(w ~ x, data=dd, type = "h", xlab = quote(x[j])) # worked before 3989plot(w ~ x, data=dd, type = "h", xlab = quote(x[j]), ylab = quote(y[j]))# *now* works 3990## main, sub, xlab worked (PR#10525) but ylab did not in R <= 4.0.0 3991 3992 3993## ...names() 3994F <- function(x, ...) ...names() 3995F(a, b="bla"/0, c=c, D=d, ..) # << does *not* evaluate arguments 3996# |-> c("b", "c", "D", NA) 3997stopifnot(exprs = { 3998 identical(F(pi), character(0)) 3999 F(foo = "bar") == "foo" 4000 identical(F(., .., .not.ok. = "a"-b, 2, 3, last = LAST), 4001 c( NA, ".not.ok.", NA, NA,"last")) 4002}) 4003# .. was wrong for a few days 4004 4005 4006## check raw string parse data 4007p <- parse(text = 'r"-(hello)-"', keep.source = TRUE) 4008stopifnot(identical(getParseData(p)$text, c("r\"-(hello)-\"", ""))) 4009rm(p) 4010# (wrong in R 4.0.0; reported by Gabor Csardi) 4011 4012## check 0x...L parse data 4013p <- parse(text = '0x2L', keep.source = TRUE) 4014stopifnot(identical(getParseData(p)$text, c("0x2L", ""))) 4015rm(p) 4016# (wrong in R 4.0.0; reported by Gabor Csardi) 4017 4018 4019## make sure there is n aliasing in assignments with partial matching 4020v <- list(misc = c(1)) 4021v$mi[[1]] <- 2 4022stopifnot(v$misc == 1) 4023rm(v) 4024# defensive reference counts needed; missing in R 4.0.0 4025 4026 4027## round() & signif() with one / wrong (named) argument(s): 4028cat("Case 1 : round(1.12345): ", round( 1.12345),"\n") 4029cat("Case 2 : round(x=1.12345,2): ", round(x=1.12345, 2),"\n") 4030cat("Case 3 : round(x=1.12345,digits=2): ", round(x=1.12345, digits=2),"\n") 4031cat("Case 4 : round(digits=2,x=1.12345): ", round(digits=2, x=1.12345),"\n") 4032cat("Case 4b: round(digits=2,1.12345): ", round(digits=2,1.12345),"\n") 4033## R <= 4.0.0 does not produce error in cases 5,6 but should : 4034cat("Case 5: round(digits=x): \n") 4035assertErrV(cat("round(digits=99.23456): ", round(digits=99.23456))) 4036cat("Case 6: round(banana=x): \n") 4037assertErrV(cat("round(banana=99.23456): ", round(banana=99.23456))) 4038## Cases 7,8 have been given an error already: 4039cat("Case 7: round(x=1.12345, digits=2, banana=3):\n") 4040assertErrV( round(x=1.12345, digits=2, banana=3)) 4041cat("Case 8 : round(x=1.12345, banana=3):\n") 4042assertErrV( round(x=1.12345, banana=3)) 4043## (by Shane Mueller, to the R-devel m.list) 4044 4045 4046## source(*, echo=TRUE) with srcref's and empty lines; PR# 4047exP <- parse(text=c("1;2+", "", "3"), keep.source=TRUE) 4048r <- source(exprs=exP, echo=TRUE) 4049stopifnot(identical(r, list(value = 5, visible = TRUE))) 4050## failed in R <= 4.0.1 4051 4052 4053## boxplot() with call (instead of expression) in labels; Marius Hofert on R-devel 4054rm(x,y,X,f) 4055boxplot(cbind(x = 1:10, y = c(16,9:1)), xlab = quote(x^{y[2]}), ylab = quote(X[t]), 4056 sub = quote(f^2 == f %*% f), main = quote(e^{-x^2/2})) 4057## failed in R <= 4.0.1 4058 4059 4060## on.exit() argument matching -- PR#17815 4061f <- function() { on.exit(add=FALSE, expr=cat('bar\n')) ; 'foo' } 4062stopifnot(identical(f(), 'foo')) # and write 'bar' line 4063g <- function() { on.exit(add=stop('boom'), expr={cat('bar\n'); FALSE}) ; "foo" } 4064assertErrV(g()) 4065## f() :> "Error in on.exit(....): invalid 'add' argument" and no error for g() in R <= 4.0.1 4066 4067 4068## multi-encodings in vector-case for duplicated/match -- PR#17809 4069c_latin1 <- "\xe4" 4070Encoding(c_latin1) <- "latin1" 4071c_utf8 <- enc2utf8(c_latin1) 4072x <- list(c_latin1, c_utf8, letters) 4073stopifnot(identical(duplicated(x)[2], TRUE)) 4074## failed in R <= 4.0.1 4075 4076 4077## str(<S4 w/ extra attributes>) 4078mixW <- setClass("mixW", contains = "numeric") 4079Summ <- setClass("Summ", representation(call = "language", wts = "mixW")) 4080S <- Summ(call = quote(foo(x)), wts = structure(mixW(pi), CA="sunny")) 4081stopifnot(length(c.str <- capture.output(str(S))) >= 5, 4082 grepl(r"(\$ CA: chr "sunny")", c.str[5])) 4083deparse(S)# FIXME: is still wrong (no trace of "CA") 4084## "CA" was not shown in R <= 4.0.2 4085 4086 4087## sort(), order(), rank() for "raw - object": 4088int8 <- function(x) structure(x, class = c("int8", oldClass(x))) 4089`[.int8` <- function(x, ...) structure(NextMethod("["), class=class(x)) 4090set.seed(2); si <- sample.int(37) 4091rI <- int8(as.raw(si)) 4092stopifnot(exprs = { 4093 identical(rank (rI), rank (si)) 4094 identical(order(rI), order(si)) 4095 identical(sort (rI), int8(as.raw(1:37))) 4096}) 4097## failed in R <= 4.0.2 4098 4099 4100## PR#16814: r2dtable() and chisq.test(*, simulate.p.value=TRUE) for large numbers 4101rc <- c(63194L, 4787074L) 4102cc <- c(34677L, 4815591L) 4103set.seed(28); system.time(R2 <- simplify2array(r2dtable(1000, rc, cc))) 4104(c.t <- chisq.test(R2[,,1], simulate.p.value = TRUE)) 4105set.seed(2*3); R2x3 <- r2dtable(5000, c(3,13), c(4,4,8)) 4106stopifnot(exprs = { 4107 sum(!(dupR2 <- duplicated.array(R2, MARGIN=3))) == 109 4108 all.equal(c.t$p.value, 1929/2001) 4109 ## From here, true also in previous R versions: 4110 is.matrix(cR2 <- colSums(R2)) 4111 cR2[1,] == cc[1] 4112 cR2[2,] == cc[2] 4113 identical(c(table(vapply(R2x3, function(m) 10*m[2,1]+m[2,3], 1))), 4114 c(`18` = 42L, `27` = 405L, `28` = 217L, `36` = 1021L, `37` = 1159L, 4115 `38` = 192L, `45` = 491L, `46` = 967L, `47` = 464L, `48` = 42L)) 4116}) 4117## The large tables and p-values were completely wrong in R <= 4.0.2 4118 4119 4120## PR#16877: glm()-internal refitting for the null deviance 4121y <- c(1, 1, 0, 0) 4122x <- c(5, 3, 2, 4) 4123fit <- glm(y ~ 1 + x + offset(log(x)), family = gaussian("log"), start = c(0,0)) 4124## failed in R < 4.1.0 due to missing starting values for glm-internal 'fit2' 4125fit0 <- glm.fit(x = rep(1, length(y)), y = y, offset = log(x), 4126 family = gaussian("log"), start = 0) 4127stopifnot(all.equal(fit$null.deviance, fit0$deviance)) 4128proc.time() - .pt; .pt <- proc.time() 4129 4130 4131## UTF-8 truncation tests 4132if (l10n_info()$"UTF-8") { 4133 ## These tests fail on R < 4.0 4134 4135 ## Use .Internal(seterrmessage(old.err)) to trigger truncation via 4136 ## Rsnprintf (mbcsTruncateToValid). 4137 trunc_string <- function(x) { 4138 old.err <- geterrmessage() 4139 on.exit(.Internal(seterrmessage(old.err))) 4140 unname( 4141 vapply( 4142 x, 4143 function(y) { 4144 .Internal(seterrmessage(y)) 4145 geterrmessage() 4146 }, 4147 "" 4148 ) 4149 ) 4150 } 4151 ## limits to detect the internal buffer size for truncation (now 8192) 4152 buff.min <- 8 4153 buff.max <- 7e4 # > buff.min 4154 buff.size <- nchar( 4155 trunc_string(paste0(rep(0:9, length.out = buff.max), collapse="")), 4156 type='bytes' 4157 ) 4158 stopifnot(buff.size >= buff.min + 1) 4159 if(buff.size == buff.max) 4160 ## possibly, the buffer is no longer fixed size? 4161 warning('BUFSIZE too large for UTF-8 truncation test?') 4162 else { 4163 string.base <- paste0( 4164 rep(0:9, length.out = buff.size), 4165 collapse="" 4166 ) 4167 ## Append UTF-8 sequences at the end of strings that are just 4168 ## a bit shorter than the buffer, each one byte longer than the 4169 ## previous. 4170 string.starts <- substr( 4171 rep(string.base, 6), 1, 4172 nchar(string.base) - seq(buff.min, 3, -1) 4173 ) 4174 ## For each of the increasing length string, append 2, 3, and 4 byte 4175 ## (valid) UTF-8 characters. 4176 string.ends <- rep( 4177 c( 4178 '\u00A2', # <C2><A2> (cent symbol) 4179 '\u20AC', # <E2><82><AC> (euro symbol) 4180 '\U00010348', # <F0><90><8D><88> (circle with dot) 4181 NULL 4182 ), 4183 each=length(string.starts) 4184 ) 4185 strings <- paste0( 4186 string.starts, 4187 '\U0001F600', # 4 byte grinning face, extra padding char 4188 string.ends 4189 ) 4190 output <- trunc_string(strings) 4191 stopifnot(validUTF8(strings)) # sanity check 4192 stopifnot(validUTF8(output)) 4193 } 4194 ## These tests fail on R < 4.1 4195 ## 4196 ## Checking that truncation and `...` concatenation are working 4197 ## correctly in verrorcall_dflt. Prior to 4.1 truncation detection did 4198 ## not work with call set, and multibyte characters could be mangled by 4199 ## the `...`. 4200 ## 4201 ## We assume getttext strings are not translated (or are translated 4202 ## to the same byte-length as the ones in source). 4203 4204 ## We cannot use `tryCatch` as we're testing the C-level error construction 4205 ## and that is not invoked when signalled errors are caught, hence: 4206 capt_err_msg <- function(expr) { 4207 tmp <- tempfile() 4208 on.exit(unlink(tmp)) 4209 err.con <- getConnection(sink.number(type='message')) 4210 sink(file(tmp, 'w'), type='message') 4211 withRestarts(expr, abort=function() sink(err.con, type='message')) 4212 ## add back newlines consumed by readlines; we assume a trailing one 4213 ## exists, if it doesn't readLines will issue a warning 4214 paste0(c(readLines(tmp), ""), collapse="\n") 4215 } 4216 ## Generate errors with long messages (length buff.size + overflow), ending 4217 ## in `x`, to test truncation. Will need to be updated if buff.size is 4218 ## increased. Function names / etc. are all carefully counted. 4219 long_error <- function(x, overflow=0, buff.size=8192) { 4220 overflow <- as.integer(overflow) 4221 x <- paste0(as.character(x), collapse="") 4222 4223 ## Compute how many chars needed to fill buffer 4224 call.len <- 51 # nchar of a_really...(stop(x)) - see below 4225 extra.len <- 12 # "Error in : " 4226 extra.ws <- 3 # +2 spaces +1 \n from `tail` 4227 chars.left <- buff.size - call.len - extra.len - extra.ws 4228 chars <- nchar(x, type = 'bytes') 4229 pad.chars <- chars.left - chars + as.integer(overflow) 4230 stopifnot(pad.chars >= 0) 4231 err.msg <- paste0(paste0(rev(rep_len(rev(LETTERS), pad.chars)), 4232 collapse = ""), x) 4233 ## force truncation despite 8170 warn length limit 4234 old.opt <- options(warning.length = 8170, warn=2) 4235 on.exit(options(old.opt)) 4236 a_really_long_function_to_cause_truncation <- function(x) x 4237 f <- function(x) 4238 a_really_long_function_to_cause_truncation(stop(x)) 4239 ## trigger error and capture std.err 4240 capt_err_msg(f(err.msg)) 4241 } 4242 buff.size.2 <- buff.size + 1 # .Internal(seterrmessage) drops 1 byte 4243 4244 ## 2 byte and 4 byte utf-8 encoded chars, avoid code points between \u00a0 4245 ## and \u0100 as some iconv implementations will translate them into char 4246 ## values in those ranges instead of into "<U+...>" in C locales. 4247 utf8.test <- '\u0238\U00010348' 4248 4249 if(buff.size.2 != 8192) { 4250 warning('These tests assume BUFSIZE = 8192') 4251 } else { 4252 ## Mangled multibyte in R < 4.1 4253 stopifnot(validUTF8(long_error(utf8.test, overflow=-1))) 4254 4255 ## Truncation detection fails in R < 4.1, so newline isn't appended, so 4256 ## we get a "incomplete final line" warning (converted to error) 4257 long_error(utf8.test, overflow=0) 4258 4259 overflow <- c( 4260 -6, # Buffer unambiguosly unfilled for MB_CUR_MAX=6 4261 -5, # Buffer maybe filled for MB_CUR_MAX=6 4262 -4, # Buffer full with '...\n\0' 4263 -3, # Lose 4 byte UTF-8 char 4264 -2, 4265 -1, 4266 0, # 4 byte UTF-8 char exactly replaced by '...\n', buffer full 4267 1, # Lose 2 byte UTF-8 char 4268 2, 4269 3, # Lose first non UTF-8 4270 # These will need to change if R_ConciseTraceback changes 4271 -87, # Room for traceback; options(showErrorCalls=TRUE) 4272 -86 # No room for traceback. 4273 ) 4274 le.res <- vapply(overflow, long_error, character(1), 4275 buff.size = buff.size.2, x = utf8.test) 4276 stopifnot(validUTF8(utf8.test)) # sanity check 4277 stopifnot(validUTF8(le.res)) 4278 4279 ## # For first one, before truncation test, we've used 8186 bytes, so we 4280 ## # know there was no truncation. Code adds a trailing newline, which 4281 ## # is why we get 8187. For the second, we add one byte to the 4282 ## # message, which puts us in maybe-truncated state, which adds 3 more 4283 ## # bytes via with "...", so total of 8187 + 1 + 3 == 8191. 4284 ## le.res.nc <- nchar(le.res) 4285 ## data.frame(overflow, 4286 ## bytes=nchar(le.res, type='bytes'), 4287 ## snippet=substr(le.res, le.res.nc - 5, le.res.nc)) 4288 ## 4289 ## overflow bytes snippet 4290 ## 1 -6 8187 XYZȸ��\n 4291 ## 2 -5 8191 ȸ��...\n 4292 ## 3 -4 8192 ȸ��...\n 4293 ## 4 -3 8189 Zȸ...\n 4294 ## 5 -2 8190 Zȸ...\n 4295 ## 6 -1 8191 Zȸ...\n 4296 ## 7 0 8192 Zȸ...\n 4297 ## 8 1 8191 YZ...\n 4298 ## 9 2 8192 YZ...\n 4299 ## 10 3 8192 XY...\n 4300 ## 11 -87 8192 ation\n 4301 ## 12 -86 8107 XYZȸ��\n 4302 ## test recursive errors in handler, Fails R < 4.0 4303 4304 handler_error <- function(x, overflow=0, buff.size=8192) { 4305 overflow <- as.integer(overflow) 4306 x <- paste0(as.character(x), collapse="") 4307 pad.chars <- buff.size - nchar(x, type='bytes') + overflow 4308 err.msg <- paste0( 4309 paste0(rev(rep_len(rev(LETTERS), pad.chars)), collapse=""), x 4310 ) 4311 old.opt <- options( 4312 error=function(...) { 4313 options(error=old.opt[['error']]) 4314 stop(err.msg) 4315 } 4316 ) 4317 capt_err_msg(stop('initial error')) 4318 } 4319 handler.error.trunc <- vapply( 4320 c(0, 1, 5), handler_error, x=utf8.test, "", buff.size=buff.size.2 4321 ) 4322 stopifnot(validUTF8(handler.error.trunc)) 4323 4324 ## Test when warning.length is limiting 4325 4326 short_error <- function(call.=TRUE) { 4327 old.opt <- options(warning.length=100) 4328 on.exit(old.opt) 4329 f <- function() 4330 stop(paste0(rep_len(0:9, 110), collapse=""), call.=call.) 4331 capt_err_msg(f()) 4332 } 4333 ## trailing newline adds 1 4334 stopifnot(nchar(short_error(call.=FALSE)) == 101L) 4335 } 4336 ## PrintGenericVector truncations 4337 ## 4338 ## New printing in r78508 needs to account for UTF-8 truncation 4339 grin <- "\U0001F600" 4340 lc1 <- paste0(c(rep(LETTERS, length.out=110), grin), collapse="") 4341 lc2 <- paste0(c(rep(LETTERS, length.out=111), grin), collapse="") 4342 list.mats <- list(matrix(list(structure(1:2, class=lc1))), 4343 matrix(list(structure(1:2, class=lc2)))) 4344 4345 ## Allowed UTF-8 truncation in R < 4.1 4346 ls1 <- paste0(c(rep(0:9, length.out=95), "\U0001F600"), collapse="") 4347 ls2 <- paste0(c(rep(0:9, length.out=96), "\U0001F600"), collapse="") 4348 long.strings <- list(matrix(list(ls1)), matrix(list(ls2))) 4349 4350 ## Invalid UTF-8 output as "\xf0\x9f..." so needs to be parsed to un-escape 4351 capt_parse <- function(x) { 4352 out <- capture.output(print(x)) 4353 eval(parse(text=paste0(c('c(', sprintf("'%s',", out), 'NULL)'), 4354 collapse=""))[[1]]) 4355 } 4356 capt.parsed <- unlist(lapply(c(list.mats, long.strings), capt_parse)) 4357 stopifnot(validUTF8(capt.parsed)) 4358 4359 ## Allowed MBCS truncation in R < 4.1 4360 fmt <- paste0(c(rep_len("a", 253), "\U0001f600"), collapse="") 4361 stopifnot(validUTF8(format(as.POSIXlt('2020-01-01'), fmt))) 4362 4363 f <- file(paste0(c(rep_len("a", 992), "\U0001F600"), collapse="")) 4364 suppressWarnings(g <- gzcon(f)) 4365 stopifnot(!grepl("xf0", capture.output(g)[2])) 4366} 4367 4368## c() generic removes all NULL elements --- *but* the first --- before dispatch 4369c.foobar <- function(...) list("ok", ...) 4370foobar <- structure(list(), class = "foobar") 4371stopifnot(exprs = { 4372 identical(c(foobar, NULL, one=1,NULL), list("ok", foobar, one=1)) 4373 identical(c(a = foobar, pi, NULL, b="B",NULL), list("ok", a = foobar, pi, b="B")) 4374 identical(c(a = foobar, b = NULL), list("ok", a = foobar)) 4375 identical(c(foobar, b = foobar), list("ok", foobar, b=foobar)) 4376 ## Back compatibly, w/ initial NULL, using c()'s default method: 4377 ## ==> result has list() for foobar 4378 identical(c(NULL, foobar, NULL, NULL, 1), c( list(), 1)) 4379 identical(c(NULL, b = foobar, NULL, NULL, 1), c(b=list(), 1)) 4380 identical(c(a = NULL, b = foobar), list()) 4381 identical(c(a = NULL, b = foobar, c = NULL), list()) 4382 identical(c(NULL, a = NULL, b = foobar, c = NULL), list()) 4383}) 4384## the first three cases failed in R <= 4.0.x 4385 4386 4387## quantile(*, pr) allows pr values very slightly outside [0,1] -- PR#17891 4388stopifnot( identical(quantile(0:1, 1+1e-14), c("100%" = 1)) ) 4389## failed in R <= 4.0.2 4390 4391 4392## quantile(*, pr, names=FALSE) with NA's in 'pr' -- PR#17892 4393x <- (0:99)/64 4394prN <- c(0.1, 0.5, 1, 2, 5, 10, 50, NA)/100 4395qxN <- quantile(x, probs = prN) 4396qxNN <- quantile(x, probs = prN, names = FALSE) 4397stopifnot(exprs = { 4398 is.null(names(qxNN)) 4399 identical(qxNN, unname(qxN)) 4400 identical(NA_real_, quantile(x, probs = NA, names = FALSE)) 4401}) 4402## qxNN gave "Error in names(o.pr)[p.ok] <- names(qs) : ..." in R <= 4.0.2 4403 4404 4405## Vectorize() no longer keeps "garbage": 4406vrep <- Vectorize(rep.int, "times") 4407stopifnot(identical(sort(names(environment(vrep))), 4408 c("FUN", "SIMPLIFY", "USE.NAMES", "vectorize.args"))) 4409## names(..) was of length 7 in R <= 4.0.2 4410 4411 4412## as.Date( "" ) -- PR#17909 4413dd <- c("", "2001-09-11") 4414(D1 <- as.Date( dd)) # failed in R <= 4.0.2 4415(D2 <- as.Date(rev(dd))) 4416stopifnot(is.na(D1[1]), identical(D1, rev(D2))) 4417## "" was not treated correctly when at [1] in R <= 4.0.2 4418 4419 4420## ..elt() propagates visibility consistently with ..n and other args, PR#17905 4421local({ 4422 fn <- function(...) list(withVisible(...elt(1)), withVisible(..2)) 4423 stopifnot(identical( 4424 fn(invisible(NULL), invisible(NULL)), 4425 rep(list(withVisible(invisible(NULL))), 2) 4426 )) 4427}) 4428 4429 4430## PR#17913 -- numToBits() accidentally was destructive 4431n0 <- c(-7.7, 2.34e55) 4432b0 <- numToBits(n0) 4433stopifnot(sum(l0 <- as.logical(b0)) == 62L, 4434 identical(which(head(l0, 10)), c(1L, 3:4, 7:8)), 4435 identical(n0, c(-7.7, 2.34e55))) 4436## was '0 0' for almost a month in R-devel 4437 4438 4439## No longer assuming integer length() 4440if(.Machine$sizeof.pointer >= 8) { 4441 .Internal(inspect(-199900000:2e9)) 4442} 4443## gave an error in R <= 4.0.2 4444 4445 4446## PR#17907 -- capture.output() now using standard evaluation (SE) : 4447## parent.frame() returns the correct environment in capture.output() 4448local({ 4449 fn <- function(env = parent.frame()) { 4450 capture.output(env) 4451 list( 4452 env, 4453 parent.frame() 4454 ) 4455 } 4456 env <- environment() 4457 out <- fn() 4458 stopifnot( 4459 identical(out[[1]], out[[2]]), 4460 identical(out[[1]], env) 4461 ) 4462}) 4463## capture.output() works with forwarded dots 4464local({ 4465 wrapper <- function(...) { 4466 capture.output(..., type = "output") 4467 } 4468 out <- local({ 4469 foo <- 1 4470 wrapper(foo) 4471 }) 4472 stopifnot(identical(out, capture.output(1))) 4473}) 4474## Failed when capture.output() was using NSE 4475 4476 4477## Inverse of numToBits() via 4478stopifnot(identical(packBits(b0, "double"), n0)) 4479r <- c(pi, 1+ (0:8)/4); head(b <- numToBits(r), 25) 4480stopifnot(identical(packBits(b, "double"), r)) 4481## thanks to PR#17914 by Bill Dunlap 4482 4483 4484## quantile(x, probs) when probs has NA's, PR#17899 4485stopifnot(identical(quantile(NULL), quantile(numeric())), # back-compatibility 4486 identical(quantile(structure(numeric(), names = character()), names = FALSE), 4487 rep(NA_real_, 5))) 4488L <- list(ordered(letters[1:11]), # class "ordered" "factor" 4489 seq(as.Date("2000-01-07"), as.Date("1997-12-17"), by="-1 month")) 4490ct <- seq(as.POSIXct("2020-01-01 12:13:14", tz="UTC"), by="1 hour", length.out = 47) 4491LL <- c(L, list(o0 = L[[1]][FALSE], D0 = L[[2]][FALSE], 4492 ct = ct, lt = as.POSIXlt(ct), num= as.numeric(ct))) 4493prb <- seq(0, 1, by=2^-8) # includes 0.25, 0.5, etc 4494for(x in LL) { 4495 cat("x : "); str(x, vec.len=3) 4496 clx <- class(if(inherits(x, "POSIXlt")) as.POSIXct(x) else x) 4497 ## for "ordered" *and* "Date", type must be 1 or 3 4498 for(typ in if(any(clx %in% c("ordered", "Date"))) c(1,3) else 1:7) { 4499 cat(typ, ": ") 4500 stopifnot(exprs = { 4501 identical(clx, class(q1 <- quantile(x, probs= prb, type=typ))) 4502 identical(clx, class(qN <- quantile(x, probs=c(prb,NA), type=typ))) # failed 4503 ## for "POSIXct", here q1 is integer, qN "double": 4504 { if(inherits(q1, "POSIXct")) storage.mode(qN) <- storage.mode(q1); TRUE } 4505 identical(qN[seq_along(q1)], q1) 4506 is.na( qN[length(qN)]) 4507 }) 4508 }; cat("\n") 4509} 4510## qN often lost class() e.g. for "ordered" and "Date" in R <= 4.0.2 4511 4512 4513## isS3stdGeneric() traced function: 4514trace(print) 4515stopifnot( isS3stdGeneric(print) ) 4516untrace(print) 4517## was FALSE in R <= 4.0.2 4518 4519 4520## PR#17897: all.equal.factor() did not distinguish the two different NA in factors 4521labs <- c("a", "b", NA) 4522x <- factor( 3:1, labels = labs) 4523y <- factor(c(NA, 2:1), levels = 1:3, labels = labs) 4524x 4525dput(x) ; dput(y) ## --> they are clearly different, but print the same: 4526stopifnot(exprs = { 4527 identCO(x,y) 4528 is.character(print(ae <- all.equal(x,y))) 4529 !englishMsgs || grepl("NA mismatch", ae, fixed=TRUE) 4530}) 4531## all.equal() gave TRUE wrongly, from 2012 till R <= 4.0.2 4532 4533 4534## PR#17935: `[.formula` for formulas with NULL: 4535forms <- list(f0 = (~ NULL) 4536 , f1 = (z ~ NULL) 4537 , f2 = (NULL ~ x) 4538 , f3 = (NULL ~ NULL) 4539 ) 4540rr <- lapply(forms, function(f) 4541 lapply(seq_along(f), function(ii) f[ii])) 4542cN <- quote(NULL()) 4543stopifnot(exprs = { 4544 identical( unique(lapply(rr , `[[`, 1)), list(`~`())) 4545 identical( lapply(unname(rr), `[[`, 2), list(cN, quote(z()), cN,cN) ) 4546}) 4547## subsetting failed for all 4 formulas in R <= 4.0.3 4548(tm1 <- (~ "~")[-1]) 4549(tq1 <- (~ `~`)[-1]) 4550stopifnot(exprs = { 4551 identical((~ NA)[-1], quote(NA())) ## subsetting (~ NA) failed in R <= 4.0.3 4552 identical(tm1, `[[<-`(call("T"), 1L, "~")) ; is.call(tm1) 4553 identical(tq1, structure(call("~"), class="formula", ".Environment" = globalenv())) 4554}) 4555## zero-length formulas from subsetting are now equal to formula(NULL) 4556exps <- expression( 4557 (~ x)[FALSE] 4558 , (~ x)[rep(FALSE, 2)] 4559 , (y ~ x)[FALSE]) 4560formL <- lapply(exps, eval) 4561stopifnot( length(unique(formL)) == 1, 4562 all.equal(formL[[1]], formula(NULL)) ) 4563## Gave error "attempt to set an attribute on NULL" in R <= 4,0.3 4564 4565 4566## Regression in .traceback() PR#17930 4567op <- options(keep.source=TRUE) 4568f <- function() .traceback(1) 4569g <- function() f() 4570x <- g() 4571stopifnot(inherits(attr(x[[1]], 'srcref'), "srcref")) 4572options(op) 4573## had worked up to R 3.6.3, but not from 4.0.0 to 4.0.3 4574 4575 4576## Summary() and Math() data.frame methods with *logical* columns 4577a <- na.omit(airquality) 4578aF <- a[FALSE,] # 0-row version of it 4579dL0 <- data.frame(x=numeric(), L=logical()) # logical column 4580stopifnot(exprs = { 4581 ## "Summary" : 4582 sum(aF) == 0 # gave Error "only defined on a data frame with all numeric variables" 4583 sum(subset(a, Ozone > 200)) == 0 # (ditto) 4584 suppressWarnings(range(dL0) == c(Inf, -Inf)) # (2 warnings) 4585 ## "Math" , gave Error..: non-numeric variable(s) in data frame : 4586 identical(exp(data.frame(L=TRUE)), data.frame(L=exp(TRUE))) 4587 identical(sinL0 <- sin(dL0), data.frame(x=numeric(), L=numeric())) 4588 identical(sinL0, log1p(dL0)) 4589 identical(cumsum(dL0), data.frame(x=numeric(), L=integer())) 4590}) 4591## probably never worked in any R <= 4.0.3 4592 4593 4594## unlist(<pairlist w/ list>, recursive=FALSE), PR#17950 4595l.ex <- list(a = list(1:5, LETTERS[1:5]), b = "Z", c = NA) 4596stopifnot(identical( 4597 unlist(as.pairlist(l.ex), recursive = FALSE), 4598 unlist( l.ex , recursive = FALSE))) 4599## 4600l2 <- list(a = "a", b = quote(b), c = pi+2i)# no list-entries 4601stopifnot( 4602 identical( 4603 unlist(as.pairlist(l2), recursive = FALSE) -> ul2, 4604 unlist(as.pairlist(l2))), 4605 identical(ul2, unlist(l2, recursive = FALSE))) 4606## lost content in R <= 4.0.3 ('FIXME' in source went lost in 2006) 4607 4608 4609## `class<-` was mutating outside of an assignment context 4610x <- c(1) 4611xx <- `class<-`(x, "foo") 4612stopifnot(identical(class(x), "numeric")) 4613 4614 4615## Can splice expression vectors with attributes -- PR#17869 4616local({ 4617 exprs <- structure(expression(1, 2, 3), attr = TRUE) 4618 exprsSrcrefs <- parse(text = "1;2;3", keep.source = TRUE) 4619 stopifnot( 4620 identical( 4621 bquote({ ..(exprs) }, splice = TRUE), 4622 call("{", 1, 2, 3) 4623 ), 4624 identical( 4625 bquote({ ..(exprsSrcrefs) }, splice = TRUE), 4626 call("{", 1, 2, 3) 4627 ) 4628 ) 4629}) 4630 4631 4632## some issues with task callbacks: 4633## avoid adding a reference to the value: 4634x <- c(1) 4635old_xr <- .Internal(refcnt(x)) 4636TCB <- addTaskCallback(function(...) TRUE) 4637x 4638stopifnot(.Internal(refcnt(x)) == old_xr) 4639removeTaskCallback(TCB) 4640 4641## these used to fail with "object 'foo' not found": 4642TCB <- addTaskCallback(function(e, v, ...) { v; TRUE}) 4643quote(foo) 4644removeTaskCallback(TCB) 4645TCB <- addTaskCallback(function(...) { length(list(...)); TRUE}, 4646 data = quote(foo)) 4647removeTaskCallback(TCB) 4648 4649 4650## all.equal(<functions>) should check.environment (Kevin Van Horn, R-devel) 4651f <- function(x) function(y) x+y 4652dif <- all.equal(f(5), f(0)) 4653stopifnot(is.function(f(5)), 4654 is.character(dif), grepl("difference", dif)) 4655## all.equal() gave TRUE in R <= 4.0.x 4656 4657 4658## p.adjust(<empty>, n=0) - PR#18002 4659## (1st fix-proposal computed wrongly w/ NAs: 4660pp <- 2^-(40:1); pp[17:19] <- NA 4661ppa <- p.adjust(pp, "holm") # worked always but was not strictly tested 4662stopifnot(all.equal(c(3.365e-11, 6.548e-11, 1.273e-10, 2.474e-10, 4.802e-10, 4663 9.313e-10, 1.804e-09), ppa[1:7])) 4664n0 <- numeric() 4665stopifnot(identical(n0, p.adjust(n0, n = length(n0)))) 4666## errored in R <= 4.0.3 4667 4668 4669## show(<standardGeneric>) where it has package ".GlobalEnv" 4670f <- function(x) x 4671setGeneric("f") 4672f # failed for a while (in R-devel only) 4673 4674 4675## all.equal.function() in case the env contains '...' -- PR#18010 4676a <- (function(...) function() NULL)(1) 4677b <- (function(...) function() NULL)(1) # want "a .eq. b" 4678D <- (function(...) function() NULL)(1:2 < 3) # want "D .NE. b" 4679e.. <- (function(...) environment())(1) 4680##' General creator of "..." (DOTSXP) objects (short form by Suharto Anggono): 4681...maker <- function(...) get("...") ## fails if called without argument 4682...maker <- function(...) (function(...) environment())(...)[["..."]] 4683str( ddd <- ...maker(1) ) 4684str( Ddd <- environment(D)[["..."]] ) # length 1, mode "...": 4685str( D2 <- ...maker(TRUE,TRUE)) # length 2, mode "...": 4686str( D3n <- ...maker(ch = {cat("HOO!\n"); "arg1"}, 2, three=1+2) ) 4687## These all worked "accidentally" in R <= 4.0.x 4688assertErrV(lD2 <- D2[]) # type '...' is not subsettable 4689assertErrV(D3n[]) # (ditto) 4690assertErrV(D3n[][["three"]]) # (ditto) 4691assertErrV(D3n $ ch) # (ditto) 4692str( D3n <- ...maker(ch = {cat("HOO!\n"); "arg1"}, 2, three=1+2) ) 4693stopifnot(exprs = { 4694 identical(alist(a=)$a, ...maker())# "*the* missing", the empty symbol 4695 identical(ddd, ...maker(1)) 4696 identical(Ddd, ...maker(1:2 < 3)) 4697 is.character(aeLD <- all.equal(quote(x+1), ddd)) 4698 grepl("Mode", aeLD[1]) 4699 grepl("deparse", aeLD[2]) 4700 all.equal(a, b) # failed with "Component “...”: target is not list-like" since r79585 (2020-12-07) 4701 all.equal(e.., environment(a)) 4702 ## all.equal() dispatch for "..." objects ('ddd') directly: 4703 typeof(ddd) == "..." 4704 typeof(D2) == "..." 4705 length(D2) == 2 4706 is.character(aeD <- all.equal(a, D) ) 4707 grepl("same length", aeD) 4708 grepl("...", aeD, fixed=TRUE) 4709 grepl("not identical", aeD) 4710 ## 4711 ## names(<DOTSXP>): 4712 is.null(names(ddd)) 4713 identical(c("ch", "", "three"), names(D3n)) 4714}) 4715## for identical() ==> ./reg-tests-2.R -- as it's about "output" 4716op <- options(keep.source = FALSE) # don't keep "srcref" etc 4717## 4718Qlis <- list(NULL 4719## Next 4 now must work as identical(X,X) is true: 4720, ddd = ddd 4721, Ddd = Ddd 4722, D2 = D2 4723, D3n = D3n 4724, Qass = quote(x <- 1) 4725, Qbrc = quote({1}) 4726, Qparen = quote((1)) 4727, Qif = quote(if(1)2) 4728, Qif2 = quote(if(1)2 else 3) 4729, Qwhile = quote(while(1) 2) 4730) 4731## 4732sapply(Qlis, class) 4733stopifnot( sapply(Qlis, function(obj) all.equal(obj, obj)) ) 4734## only the first failed in R <= 4.0.3 4735 4736 4737## See PR#18012 -- may well change 4738aS <- (function(x) function() NULL)(stop('hello')) 4739bS <- (function(x) function() NULL)(stop('hello')) 4740try( all.equal(aS, bS) ) ## now (check.environment=TRUE) triggers the promise .. 4741## Now have a way *not* to evaluate aka force the promise: 4742(aeS <- all.equal(aS, bS, evaluate=FALSE)) # no promises forced 4743stopifnot(grepl("same names.* not identical", aeS)) 4744 4745 4746## PR#18032: identical(<DOTSXP>,*) 4747ddd <- ...maker(47) 4748DDD <- ...maker(ch = {cat("Hu hu!\n"); "arg1"}, two = 1+1, pi, ABC="A") 4749stopifnot(exprs = { 4750 identical(ddd,ddd) 4751 identical(DDD,DDD) 4752 identical (ddd, ...maker(47)) 4753 ! identical(ddd, ...maker(7 )) # these *are* different 4754 ! identical(ddd, DDD) 4755}) 4756options(op) 4757 4758 4759## PR#18034 : explicit and implicit row.names=NULL for as.data.frame.list() 4760data(mtcars, package="datasets") 4761lmtcars <- as.list(mtcars) 4762names(lmtcars[[3]]) <- RN <- c(letters[1:26], LETTERS[1:6]) 4763dfcars1 <- as.data.frame.list(lmtcars)# default: missing(row.names); uses RN 4764dfcarsN <- as.data.frame.list(lmtcars, row.names = NULL)# does *not* use RN 4765stopifnot(identical(RN, rownames (dfcars1)) , 4766 identical(-32L, .row_names_info(dfcarsN))) # now has "automatic" (integer) row names 4767## dfcarsN == dfcars1 in R <= 4.0.3 4768 4769 4770## str(x) when x has "unusal" length() semantics such that lapply() / vapply() fails: 4771length.Strange4 <- function(x) 4 4772`[[.Strange4` <- function(x, i) { 4773 stopifnot(length(i) == 1) 4774 if(i %in% 1:4) paste(sprintf("content of x[[%d]]", i)) 4775 else stop("invalid [[-index, partly out of 1..4") 4776} 4777`[.Strange4` <- function(x, i) { 4778 isM <- length(i) > 1 4779 if(all(i %in% 1:4)) paste(sprintf("content of x[%s]", 4780 if(isM) paste0("c(", i, collapse=", ", ")") 4781 else paste0(i, collapse=", "))) 4782 else stop("invalid indices, partly out of 1..4") 4783} 4784L <- structure(as.list(1:6), class="Strange4") 4785stopifnot(is.list(L), length(L) == 4, length(unclass(L)) == 6) 4786assertErrV(lapply(L, length)) 4787assertErrV(vapply(L, typeof, "")) 4788lns <- capture.output(str(L)) # no longer fails 4789stopifnot(length(lns) == 1+6, grepl("hidden list", lns[1])) 4790## str() failed for these and similar in R <= 4.0.x 4791 4792 4793## PR#18041: checkRdaFiles(<more-than-1>) $ version 4794save(pi, file = rda2 <- tempfile(fileext = ".rda"), version = 2) 4795save(pi, file = rda3 <- tempfile(fileext = ".rda"), version = 3) 4796stopifnot(identical(2:3, tools::checkRdaFiles(c(rda2, rda3))$version)) 4797## gave '3 3' in R <= 4.0.3 4798 4799 4800if (l10n_info()$"UTF-8") { 4801 x <- "d\xc3\xa9faut" # "défaut" flagged as native 4802 stopifnot(grepl("d.faut", x)) # incorrectly FALSE in in R < 4.1 4803} 4804 4805 4806## constructing the names() of quantile(): 4807str(L <- lapply(c(2,3,5,7), function(dig) { options(digits = dig) 4808 names(quantile(lynx, probs = 1 - 10^(-1:-5))) })) 4809stopifnot(length(unique(L)) == 1) 4810## in R <= 4.0.x, L contained 3 different results 4811 4812 4813## PR#18079: sub() & gsub(patt, repl, x) -- when patt is NA 4814(x <- c(a="abc", b="bd", d=NA, foo="babar")) 4815stopifnot(exprs = { 4816 identical(names(x1 <- sub("a", "_", x)), names(x)) ; x1[["foo"]] == "b_bar" 4817 identical(names(x2 <- gsub("a", "_", x)), names(x)) ; x2[["foo"]] == "b_b_r" 4818 identical(names(xN2 <- gsub(NA , "_", x)), names(x)) ; is.na(xN2) 4819 identical(names(xN1 <- sub(NA , "_", x)), names(x)) ; is.na(xN1) 4820}) 4821## NA-pattern did not keep any attributes in R <= 4.0 4822 4823 4824## svn c80082/80141's change to grep.R broke several of these -- the PR#18063 saga 4825check_regexetc <- function(txt, fx.ptn, s.ptn, gr.ptn, msg = stop) { 4826 stopifnot(is.character(txt)) 4827 chkString <- function(ch) { 4828 if(!is.character(ch)) { str(ch); stop("is not a character") } 4829 if(length(ch) != 1) { str(ch); stop("is not of length 1") } 4830 } 4831 chkString(fx.ptn) 4832 chkString( s.ptn) 4833 chkString(gr.ptn) 4834 ## ref: result using "character"; 4835 ## x : from as.character(.) w/ "lost" attributes 4836 identC <- function(x, ref) { 4837 attributes(ref) <- attributes(ref)[names(attributes(x))] 4838 identical(x, ref) 4839 } 4840 4841 a2_fns <- expression(grepl, regexpr, gregexpr, regexec) # plus possibly: 4842 if(getRversion() >= "4.1") a2_fns <- c(a2_fns, expression(gregexec)) 4843 4844 exclude <- NA # (the default, used in factor(.., exclude=*) 4845 ## 4846 for (txt_i in 1:3) { 4847 if (txt_i == 2) { # txt_i \in {2, 3} will have NA in 'txt' 4848 txt <- c(NA_character_, txt, NA_character_) 4849 } else if (txt_i == 3) { 4850 exclude <- NULL 4851 } 4852 txt_fkt <- factor(txt, exclude = exclude) 4853 cat("txt_i = ", txt_i,"; str(<factor>):\n", sep="") ; str(txt_fkt) 4854 if(chkpre <- !is.null(names(txt_fkt)) && length(levels(txt_fkt)) < length(txt_fkt)) { 4855 txt_fkt_pre <- txt_fkt[seq(levels(txt_fkt))] 4856 cat("str(txt_fkt_pre):\n") ; str(txt_fkt_pre) 4857 } 4858 4859 for (ptn in c(fx.ptn, s.ptn, gr.ptn, NA_character_)) { 4860 fixed <- (!is.na(ptn) && ptn == fx.ptn) 4861 perl <- (!is.na(ptn) && ptn == gr.ptn) 4862 ptn_ch <- if(is.na(ptn)) ptn else dQuote(ptn, q=NULL) 4863 cat(sprintf(" pattern=%16s, fixed=%s, perl=%s: ", ptn_ch, fixed, perl)) 4864 for (e_2 in a2_fns) { 4865 f_2 <- eval(e_2) 4866 f_2s <- as.character(e_2) 4867 ## when ptn == NA_character_ only test grep() & grepl() : 4868 if(is.na(ptn) && !(f_2s %in% c("grep", "grepl"))) next 4869 cat(f_2s,"") 4870 if(!identical( 4871 f_2(ptn, txt_fkt, fixed = fixed, perl = perl), 4872 f_2(ptn, txt, fixed = fixed, perl = perl) 4873 )) msg(sprintf( 4874 "not identical: %s(%s, txt*, fixed=%s, perl=%s)", 4875 f_2s, ptn_ch, fixed, perl)) 4876 } 4877 4878 cat("\n\t grep(*, invert=F/T, value = F/T): ") 4879 for(iv in list(c(FALSE,FALSE), c(TRUE,FALSE), c(FALSE,TRUE), c(TRUE,TRUE))) 4880 if(!identical( 4881 grep(ptn, txt_fkt, fixed = fixed, perl = perl, invert=iv[1], value = iv[2]), 4882 grep(ptn, txt, fixed = fixed, perl = perl, invert=iv[1], value = iv[2]) 4883 )) msg(sprintf( 4884 "not identical: grep(%s, txt*, fixed=%s, perl=%s, invert=%s, value=%s)", 4885 ptn_ch, fixed, perl, iv[1], iv[2])) 4886 cat("f_3, i.e. *sub() :") 4887 for (e_3 in expression(sub, gsub)) { 4888 ## --- ----- 4889 f_3 <- eval(e_3) 4890 f_3s <- as.character(e_3) 4891 cat(f_3s,"") 4892 if(!identC(##identical( 4893 res <- 4894 f_3(ptn, "@@", txt_fkt, fixed = fixed, perl = perl), 4895 f_3(ptn, "@@", txt, fixed = fixed, perl = perl) 4896 )) msg(sprintf( 4897 "not identical: %s(%s, \"@@\", txt*, fixed=%s, perl=%s)", 4898 f_3s, ptn_ch, fixed, perl)) 4899 if(chkpre && 4900 is.null(names(f_3(ptn, "@@", txt_fkt_pre, fixed = fixed, perl = perl))) != 4901 is.null(names(res)) 4902 ) msg(sprintf( 4903 "not identical pre: names(%s(%s, \"@@\", txt_fkt*, fixed=%s, perl=%s))", 4904 f_3s, ptn_ch, fixed, perl)) 4905 } 4906 cat("\n") 4907 } 4908 cat("--------- finished txt_i = ", txt_i,"\n") 4909 } 4910} ## end{ check_regexetc } 4911 4912if(requireNamespace("codetools", quietly = TRUE)) 4913 codetools::findGlobals(check_regexetc, merge=FALSE) 4914 4915## "default check" 4916txt <- c( 4917 "The", "licenses", "for", "most", "software", "are", "designed", "to", 4918 "take", "away", "your", "freedom", "to", "share", "and", "change", "it.", 4919 "", "By", "contrast,", "the", "GNU", "General", "Public", "License", 4920 "is", "intended", "to", "guarantee", "your", "freedom", "to", "share", 4921 "and", "change", "free", "software", "--", "to", "make", "sure", "the", 4922 "software", "is", "free", "for", "all", "its", "users") 4923names(txt) <- paste0("c", seq_along(txt)) 4924if(FALSE) 4925 system.time(check_regexetc(txt, fx.ptn = "e", s.ptn = "e.", gr.ptn = "(?<a>e)(?<b>.)", msg=warning)) 4926check_regexetc(txt, fx.ptn = "e", s.ptn = "e.", gr.ptn = "(?<a>e)(?<b>.)") 4927##============ 4928 4929 4930x <- c("e", "\xe7") 4931Encoding(x) <- "UTF-8" 4932x <- factor(c(1, 1, 2), c(1, 2), x) 4933tools::assertWarning(grep("e", x, fixed = TRUE)) 4934## broken by svn c80136 4935 4936 4937## "difftime" objects pmin() .. & modifications when "units" differ -- PR#18066 4938x_hr <- as.difftime(1:10, units = "hours") 4939y_hr <- as.difftime( 5, units = "hours") 4940y_mi <- `units<-`(y_hr, "mins") 4941x_na <- `[<-`(x_hr, 2L, NA_real_) 4942stopifnot(exprs = { ## these all are FALSE in R <= 4.0.* 4943 inherits(rep(y_hr, 5L), "difftime") 4944 identical(`[<-`(x_hr, 1L, y_hr), `[<-`(x_hr, 1L, y_mi)) 4945 identical(pmin(x_hr, y_hr), pmin(x_hr, y_mi)) 4946 identical(pmin(x_na, y_hr, na.rm = TRUE), 4947 pmin(x_na, y_mi, na.rm = TRUE)) 4948}) 4949## objects became wrong without warning in R <= 4.0.x 4950 4951## Bytes Enc may be unset directly to unknown (impossible R <= 4.0.x) 4952x <- "fa\xE7ile" 4953Encoding(x) <- "bytes" 4954xu <- x 4955Encoding(xu) <- "unknown" 4956stopifnot(identical(Encoding(c(x, xu)), c("bytes", "unknown"))) 4957 4958 4959## Correctness tests for sorted ALTREP handling of unique/duplicated (PR#17993) 4960 4961 4962altrep_dup_test <- function(vec, nalast, fromlast, s3class) { 4963 svec_ar <- sort(vec, na.last = nalast) 4964 svec_std <- svec_ar 4965 svec_std[1] <- svec_std[1] ## this clobbers ALTREP-ness 4966 if(!is.null(s3class)) { 4967 class(svec_ar) <- s3class 4968 class(svec_std) <- s3class 4969 } 4970 stopifnot(identical(duplicated(svec_ar, fromLast = fromlast), 4971 duplicated(svec_std, fromLast = fromlast)), 4972 identical(unique(svec_ar, fromLast = fromlast), 4973 unique(svec_std, fromLast = fromlast)), 4974 identical(anyDuplicated(svec_ar, fromLast = fromlast), 4975 anyDuplicated(svec_std, fromLast = fromlast)) 4976 ) 4977} 4978 4979altint_dup_check <- function(vec, numna, nalast, fromlast, s3class = NULL) { 4980 if(length(vec) > 0 && numna > 0) { 4981 vec[1:numna] = NA_integer_ 4982 } 4983 altrep_dup_test(vec, nalast = nalast, fromlast = fromlast, s3class = s3class) 4984} 4985 4986altint_dup_multicheck <- function(vec, numna, s3class = NULL) { 4987 altint_dup_check(ivec, numna, FALSE, FALSE, s3class = s3class) 4988 altint_dup_check(ivec, numna, FALSE, TRUE, s3class = s3class) 4989 altint_dup_check(ivec, numna, TRUE, FALSE, s3class = s3class) 4990 altint_dup_check(ivec, numna, TRUE, TRUE, s3class = s3class) 4991} 4992 4993altreal_dup_check <- function(vec, numna, numnan, numinf, nalast, fromlast, 4994 s3class = NULL) { 4995 if(length(vec) > 0) { 4996 ## on Intel adding 0 changes the NA_real_ NaN from signaling 4997 ## to non-signaling 4998 if(numna > 0) { 4999 vec[1:numna] <- rep(c(NA_real_, NA_real_ + 0), length.out = numna) 5000 } 5001 if(numnan > 0) { 5002 vec[seq(1 + numna, numna + numnan)] <- 5003 rep(c(NaN, NaN + 0), length.out = numnan) 5004 } 5005 if(numinf > 0) { 5006 infstrt <- 1 + numna + numnan 5007 vec[seq(infstrt, infstrt + numinf - 1)] <- 5008 rep(c(Inf, -Inf), length.out = numinf) 5009 } 5010 } ## end length(vec) > 0 5011 altrep_dup_test(vec, nalast = nalast, fromlast = fromlast, 5012 s3class = s3class) 5013} 5014 5015altreal_dup_multicheck <- function(vec, numna, numnan, numinf, s3class = NULL) { 5016 altreal_dup_check(ivec, numna, numnan, numinf, FALSE, FALSE, 5017 s3class = s3class) 5018 altreal_dup_check(ivec, numna, numnan, numinf, FALSE, TRUE, 5019 s3class = s3class) 5020 altreal_dup_check(ivec, numna, numnan, numinf, TRUE, FALSE, 5021 s3class = s3class) 5022 altreal_dup_check(ivec, numna, numnan, numinf, TRUE, TRUE, 5023 s3class = s3class) 5024} 5025 5026## NB buffer size used by ITERATE_BY_REGION macros is 512, so we need to test 5027## handling of NAs, NaNs, and Infs around/past that barrier. 5028 5029set.seed(83); dvec <- round(runif(2000, 1, 20), 1) 5030ivec <- ceiling(dvec) 5031 5032altint_dup_multicheck(ivec, 0) 5033## just before buffer break 5034altint_dup_multicheck(ivec, 512) 5035## just after buffer break 5036altint_dup_multicheck(ivec, 513) 5037## all nas 5038altint_dup_multicheck(ivec, 2000) 5039 5040altreal_dup_multicheck(dvec, 0, 0, 0) 5041## NA/NaN up to edge of 1 buffer 5042altreal_dup_multicheck(dvec, 256, 256, 0) 5043## NA/NaN crossing buffer barrier 5044altreal_dup_multicheck(dvec, 256, 257, 0) 5045## all NA/NaN 5046altreal_dup_multicheck(dvec, 1000, 1000, 0) 5047## non-finite filling exactly one buffer on each side 5048altreal_dup_multicheck(dvec, 0, 0, 1024) 5049## non-finite across more than one buffer on both sides 5050altreal_dup_multicheck(dvec, 0, 0, 1026) 5051## all non-finite 5052altreal_dup_multicheck(dvec, 0, 0, 2000) 5053 5054## sanity checks 5055## no breakage on length 0 vectors 5056altint_dup_multicheck(integer(0), 0) 5057altreal_dup_multicheck(numeric(0), 0, 0, 0) 5058## works on on length 1 vectors 5059altint_dup_multicheck(1L, 0) 5060altreal_dup_multicheck(1.0, 0, 0, 0) 5061 5062 5063## s3 methods take precedence over altrep methods 5064## these methods are (very) wrong on purpose so there can be 5065## no doubt they are hit rather than the altrep code even in the sorted case 5066duplicated.fake_class <- function(x, incomparables = FALSE, ...) { 5067 rep(c(TRUE, FALSE), length.out = length(x)) 5068} 5069 5070unique.fake_class <- function(x, incomparables = FALSE, ...) { 5071 x[c(1, 5, length(x))] 5072} 5073 5074altint_dup_multicheck(ivec, 0, s3class = "fake_class") 5075altreal_dup_multicheck(dvec, 0, 0, 0, s3class = "fake_class") 5076 5077 5078## Value stored in .Last.value needs to count at least one reference 5079c(1) 5080stopifnot(1 + .Last.value + .Last.value == 3) 5081 5082 5083## in 4.1.0, encodeString() below would return unflagged UTF-8 5084## representation of the string 5085if (l10n_info()$"Latin-1" && localeToCharset()=="ISO8859-1") { 5086 # checking localeToCharset() because on Windows, in C locale, 5087 # l10n_info() would report Latin-1 when that is the code page 5088 y <- "\xfc" 5089 stopifnot(y == encodeString(y)) 5090} 5091 5092 5093 5094## keep at end 5095rbind(last = proc.time() - .pt, 5096 total = proc.time()) 5097