#### Regression Tests that need "much" memory
#### (and / or are slow even with enough GBytes of memory)
print(si <- sessionInfo(), locale=FALSE)
Sys.info()
## Run (currently _only_) when inside tests/ by
'
time make test-large
' # giving ~ 35 min [R-devel 2019-01]
## From CRAN package 'sfsmisc':
Sys.memGB <- function (kind = "MemTotal")
{
mm <- drop(read.dcf("/proc/meminfo", fields = kind))
if (any(is.na(mm))) {
warning("Non-existing 'kind': ", names(mm)[is.na(mm)][1])
0
} else if (!all(grepl(" kB$", mm))) {
warning("Memory info ", dQuote(kind),
" is not returned in 'kB' aka kiloBytes")
0
} else
as.numeric(sub(" kB$", "", mm))/(1000 * 1024)
}
availableGB <-
if(file.exists("/proc/meminfo")) { # e.g. on Linux
Sys.memGB("MemAvailable")
} else {
0 # unless we add something better here
}
cat("Available (processor aka CPU) memory: ", round(availableGB, 1),
"GB (Giga Bytes)\n")
if(.Machine$sizeof.pointer < 8) {
cat(".Machine :\n"); str(.Machine)
cat("not a 64-bit system -- forget about these tests!\n")
q("no")
}
### Testing readLines() *large* file with embedded nul aka `\0'
##
## takes close to one minute and ~ 10 GB RAM
if(availableGB > 11) local(withAutoprint({
## File construction originally by Bill Dunlap, Cc: R-help,
## Subject: Re: [R] readLines without skipNul=TRUE causes crash
## Date: Mon, 17 Jul 2017 08:36:55 -0700
tf <- tempfile(); file <- file(tf, "wb")
txtLine <- c(rep(as.raw(32:127), 2^5), charToRaw("\n")) # <- want many lines
system.time({
for(i in 1:(2^15-1)) writeBin(rep_len(txtLine, 2^16), file)
for(i in 1:(2^15-1)) writeBin(rep_len(as.raw(0L), 2^16), file)
})
close(file)
log2(file.size(tf)) ## 31.99996
## now, this gave a segmentation fault, PR#17311 :
"FIXME: on 32-bit Linux (F 24), still see
Program received signal SIGSEGV, Segmentation fault.
... in do_readLines (call=0x8.., op=0x8.., ....)
at ../../../R/src/main/connections.c:3852
3852 if(c != '\n') buf[nbuf++] = (char) c; else break;
"
if(.Machine$sizeof.pointer > 4) withAutoprint({
system.time( x <- readLines(tf) ) # depending on disk,.. takes 15-50 seconds
## ---------
str(ncx <- nchar(x, "bytes"))
## int [1:688108] 3072 3072 3072 3072 3072 3072 3072 3072 ...
tail(ncx) # ... 3072 3072 3072 1003
table(ncx) # mostly 3072, then some 4075 and the last one
head(iL <- which(ncx == 4075))
stopifnot(diff(iL) == 21)
}) else cat("32-bit: still seg.faulting - FIXME\n")
}))
## + 2 warnings
### Testing PR#17992 c() / unlist() name creation for large vectors
## Part 1
if(availableGB > 21) system.time({
res <- c(a=raw(2), raw(2^31-1))
}) ## 36--44 sec elapsed (ada-16, ~ 120 GB available) after fix
## In R <= 3.4.1, took 51 sec elapsed, and gave Error .. :
## attempt to set index 18446744071562067968/2147483649 in SET_STRING_ELT
##
if(FALSE) { # object.size() itself is taking a lot of time!
os <- object.size(res)
} else {
os <- structure(19327353184, class = "object_size")
print(os, units = "GB") # 18
}
if(exists("res")) rm(res)
gc(reset = TRUE) # for the next step
### Testing PR#17992 c() / unlist() name creation for large vectors
## Part 2 (https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17292#c4):
if(availableGB > 37) system.time({
res <- c(a = list(rep(c(b=raw(1)), 2^31-2), raw(2)), recursive=TRUE)
})
## 437 sec elapsed (ada-16, ~ 120 GB available) after fix; then ada-20: 566 sec
## In R <= 3.4.1, took 475 sec elapsed, and gave Error .. :
## could not allocate memory (2048 Mb) in C function 'R_AllocStringBuffer'
## ((and that error msg is incorrect because of int overflow))
if(exists("res")) withAutoprint({
str(res) # is fast!
## Named raw [1:2147483648] 00 00 00 00 ...
## - attr(*, "names")= chr [1:2147483648] "a.b" "a.b" "a.b" "a.b" ...
gc() # back to ~ 18.4 GB
rm(res)
})
gc(reset = TRUE) # for the next step
## Large string's encodeString() -- PR#15885
if(availableGB > 4) system.time(local(withAutoprint({
txt <- strrep("test me:", 53687091); object.size(txt) # 429'496'824 bytes
nc <- nchar(txt) ## NB this is larger than maximal integer:
nc*5L+8L # NA + Warning 'NAs produced by integer overflow'
en <- encodeString(txt)
## encodeString() seg.faulted in R <= 3.4.1
stopifnot(identical(txt,en)) # encoding did not change simple ASCII
})))
## 52 sec elapsed [nb-mm4, 8 GB]; then 66.7 [ada-20; much more GB]
## pretty(x, n) for n = <large> or large diff(range(x) gave overflow in C code
if(availableGB > 6) system.time(withAutoprint({
r <- pretty(c(-1,1)*1e300, n = 449423288, min.n = 1)
head(r) ; length(r) # was only 21 in R < 3.5.0
stopifnot(all.equal(length(r), 400000001, tol = 0.1))
})) ## 4.8--5.5 sec.
rm(r)
gc()
n <- 4e4 # << for quick testing, comment next line
n <- 2.2e9
if(availableGB > 60) withAutoprint({
n/.Machine$integer.max # 1.024 ==> need long vectors!
ii <- seq_len(n) # user system elapsed [seq_len() fast: ALTREP "compact"]
system.time(ii <- ii + 0) # 6.726 17.558 24.450 (slow!, seen faster)
system.time(i2 <- ii[-n]) # 14.267 23.532 37.918 (slow!, seen slower: el.= 51)
##
## NB: keep n, i, i2 for "below"
})
## In R <= 3.4.1 :
## Program received signal SIGSEGV, Segmentation fault.
## 0x00000000005a0daf in realSubscript (call=0x3f01408, stretch=<optimized out>,
## nx=2200000000, ns=1, s=0x426db18) at ../../../R/src/main/subscript.c:691
## 691 LOGICAL(indx)[ix] = 0;
if(availableGB > 99) withAutoprint({
system.time( x <- ii/n ) # 5.45 user; 11.5--14.36 elapsed
system.time( y <- sin(pi*x) ) # 42 user; 48.9--.. elapsed
system.time(sorted <- !is.unsorted(x)) # ~ 4 elapsed
stopifnot(sorted)
## default n (= "nout") = 50:
system.time(ap1 <- approx(x,y, ties = "ordered"))# 15 user; 25 elapsed
stopifnot(exprs = {
is.list(ap1)
names(ap1) == c("x","y")
length(ap1$x) == 50
all.equal(ap1$y, sin(pi*ap1$x), tol= 1e-9)
})
rm(ap1) # keep x,y,n,i2
gc() # --> max used: 92322 Mb
})
## which() and ifelse() working for long vectors
if(availableGB > 165) withAutoprint({
system.time(iis <- which(isMl <- ii < 9999)) # 5.8 user, 8.8 elapsed
gc() # 59 GB max used
system.time(r <- ifelse(isMl, ii, ii*1.125)) # user system elapsed
stopifnot(exprs = { # in R 3.5.2 : 124.989 174.726 300.656
## GB's ifelse() + using which(<long>) 3.6.0 : 71.815 81.823 154.124
length(r) == n
iis == seq_len(9998)
})
rm(isMl, iis, r)
})
gc() # 159 GB max used
if(availableGB > 211) withAutoprint({ ## continuing from above
## both large (x,y) *and* large output (x,y):
system.time(xo <- x + 1/(2*n)) # ~ 9 elapsed
system.time(ap <- approx(x,y, ties = "ordered", xout = xo))
# 194 user, 214--500 elapsed
gc(reset = TRUE) # showing max.used ~ 1..... Mb
stopifnot(exprs = {
is.list(ap)
names(ap) == c("x","y")
length(ap$x) == n
is.na(ap$y[n]) # because ap$x[n] > 1, i.e., outside of [0,1]
all.equal(ap$y[i2], sin(pi*xo[i2]), tol= if(n < 1e7) 1e-8 else 1e-15)
})
rm(ap); gc() # showing used 83930 Mb | max.used 210356.6 Mb
## only large x,y :
system.time(apf <- approxfun(x,y, ties="ordered", rule = 2))# elapsed: ~26s
xi <- seq(0, 1, by = 2^-12) ## linear interpol. is less accurate than spline:
stopifnot(all.equal(apf(xi), sin(pi*xi), tol= if(n < 1e7) 1e-7 else 1e-11))
rm(apf); gc() # (~ unchanged)
system.time(ssf <- splinefun(x,y, ties = "ordered"))
# elapsed 120 s; using ~ 158 GB
system.time(ss <- spline (x,y, ties = "ordered", xout = xi))
# elapsed 126--265 s; using ~ 207 GB
gc()
stopifnot(exprs = {
is.list(ss)
names(ss) == c("x","y")
length(ss$y) == length(xi)
all.equal(ss$y , sin(pi*xi), tol= 1e-15)
all.equal(ssf(xi), ss$y, tol= 1e-15)
})
rm(x, y, xo, ss, ssf) # remove long vector objects
gc(reset=TRUE)
})
## sum(<Integer|Logical>) -- should no longer overflow: ----------------------------------------
## 1) sum(<long logical>) == counting
if(availableGB > 24) withAutoprint({
system.time(L <- rep.int((0:15) %% 7 == 2, 2^28))# -> length 2^32; ~ 22 sec
print(object.size(L), unit="GB") # 16 GB
system.time(sL <- sum(L)) # 8.4 sec
stopifnot(exprs = {
is.logical(L)
length(L) == 2^32
!is.integer(length(L))
is.integer(sL)
identical(sL, as.integer(2^29))
})
}) ## sL would be NA with an "integer overflow" warning in R <= 3.4.x
gc(reset=TRUE)
## 2) many (and relatively long and large) integers
L <- as.integer(2^31 - 1)## = 2147483647L = .Machine$integer.max ("everywhere")
## a "small" example with this is in ./reg-tests-1d.R (see 'x24')
if(availableGB > 12) withAutoprint({
system.time(x31 <- rep.int(L, 2^31+1)) # sum = 2^62 - 1 =.= 2^62 // ~ 5.5 sec
print(object.size(x31), unit = "GB") # 8 G
system.time(S <- sum(x31)) # ~ 2 sec
system.time(S.4 <- sum(x31, x31, x31, x31)) # 8 sec
stopifnot(is.integer(x31),
identical(S, 2^62),
identical(S.4, 2^64))
system.time(x32 <- c(x31, x31)) # 13 user | 20.8 elapsed (and 16 GB)
rm(x31)# now, sum vvv will switch to use irsum() [double accumulator]
system.time(S.2 <- sum(x32)) # 8 sec
stopifnot(S.2 == 2^63)
rm(x32)
})
## seq() remaining integer: (PR 17497, comment #9)
if(availableGB > 16) withAutoprint({
i <- as.integer(2^30)
system.time(i2.31 <- seq(-i, by=1L, length=2*i+1)) # 11.1 user | 19.2 elapsed
object.size(i2.31) # 8'589'934'648 bytes [ was 17.17 GB in R <= 3.5.x ]
stopifnot(is.integer(i2.31), i2.31[1] == -i, i2.31[length(i2.31)] == i)
## pmax(), pmin() with long vectors, PR 17533
if(availableGB > 24) withAutoprint({
system.time(i2.31 <- pmin(i2.31, 0L)) # 7.2 sec user | 11.2 elapsed
str(i2.31)
system.time(stopifnot(i2.31[(i+1):length(i2.31)] == 0)) # 16.7 user | 28.0 elapsed
})
})
## match(<long character>, *) PR#17552
if(availableGB > 44) withAutoprint({ ## seen 40 G ('RES')
system.time(m <- match(rep("a", 2^31), "a")) # 34.7 sec user (55 elapsed)
stopifnot(all(m == 1L))
rm(m)
system.time({x <- character(2^31); x[26:1] <- letters }) # 1.6 user | 9.4 elapsed
system.time(m <- match(x, "a"))# 18.2 user | 51.6 elapsed
head(m, 30)
system.time(stopifnot(m[26] == 1L, is.na(m[-26])))
rm(x, m)
})
## readBin() and writeBin() for long rawConnection s, PR#17665
## ------- -------- -------------
if(availableGB > 14) withAutoprint({ ## seen 11.6 G
vec <- rep(0, 3e8) # object.size(vec) > 2^31
raw_con <- rawConnection(serialize(vec, NULL)) # ~ 5 sec.
## Stepping through this connection gives an error after the 2^31st element:
repeat {
x <- readBin(raw_con, "raw", n = 1e+06)
if(length(x) == 0)
break
cat(".")
}; cat("\n")
## Error in readBin(raw_con, "raw", n = 1e+06) : too large a block specified
})
## writeBin() for long vectors
if(availableGB > 20) withAutoprint({ ## seen 20.9 G
x <- raw(2^31)
writeBin(x, con = nullfile())
con <- rawConnection(raw(0L), "w")
writeBin(x, con = con)
stopifnot(identical(x, rawConnectionValue(con)))
system.time(x <- pi*seq_len(2.1*2^30)) # 25 sec
zzfil <- tempfile("test-large-bin")
zz <- file(zzfil, "wb") ## file size will be 2.5 GB !!!
system.time(z <- writeBin(x, zz)) # 32 sec
stopifnot(is.null(z))
close(zz); zz <- file(zzfil, "rb")
system.time(r <- readBin(zz, double(), n = length(x) + 999)) # 32 sec
system.time(stopifnot(identical(x, r))) # 24 sec
close(zz); rm(r, zz)
})
## predict(loess(.), se=TRUE) for "large" sample size -- PR#17121
## No need for very much memory, but is slow and should do several ex.
mkDat <- function(n) {
x <- 5*(1:n)/(n+1)
data.frame(x = x, y = sin(pi*x^2) * exp(-x/2) + rnorm(n)/8)
}
set.seed(1); dat <- mkDat(n = 42000)
system.time( # 14.5 sec (on lynne ~ 2019)
fit <- loess(y~x, data=dat)
)
r <- tools::assertError(
predict(fit, newdata=data.frame(x=.5), se=TRUE)
, verbose=TRUE) #
## typically would not seg.fault but give Calloc(..) error (with *wrong* size)
stopifnot(grepl("^workspace .* is too large .* 'se = TRUE'", r[[1]]$message))
gc() # NB the "max used"
proc.time() # total [ ~ 40 minutes in full case, 2019-04-12]