Rmpfr/0000755000176200001440000000000015077606366011360 5ustar liggesusersRmpfr/tests/0000755000176200001440000000000015075721240012505 5ustar liggesusersRmpfr/tests/lowlevel.R0000644000176200001440000002423214600265440014462 0ustar liggesusers#### Low level stuff - debugging etc #### ========= ========= require("Rmpfr") options(warn = 2)# warning -> error identical3 <- function(x,y,z) identical(x,y) && identical (y,z) identical4 <- function(a,b,c,d) identical(a,b) && identical3(b,c,d) ## sane state [when re-source()ing this file]: .mpfr_erange_set("Emin", -(2^30-1)) .mpfr_erange_set("Emax", +(2^30-1)) ###----- _1_ mpfr1 , import, xport etc ----------------------------------------- i8 <- mpfr(-2:5, 32) x4 <- mpfr(c(NA, NaN, -Inf, Inf), 32); x4 # NA -> NaN as well stopifnot(identical3(is.na(x4), is.nan(x4), c(T,T,F,F))) o1 <- as(x4[1], "mpfr1") stopifnot(is(o1, "mpfr1")) # failed previously validObject(o1) # ditto (failed on 64-bit only) stopifnot( getPrec("0xabc", base=16, doNumeric=FALSE) == 3*4, getPrec( "abc", base=16, doNumeric=FALSE) == 3*4, getPrec("0b1001", base=2, doNumeric=FALSE) == 4, getPrec( "1001", base=2, doNumeric=FALSE) == 4, identical3(mpfr("0b101", base= 2), mpfr( "101", base= 2), mpfr(5, precBits = 3)) , identical3(mpfr("0xabc", base=16), mpfr( "abc", base=16), mpfr(2748, base=16, precBits = 12)) ) ## save initial (Emin, Emax) eranges : erangesOrig <- .mpfr_erange() ###----- _2_ Debugging, changing MPFR defaults, .. ----------------------------- ## NB: Currently mostly *not* documented, not even .mpfr_erange() stopifnot(Rmpfr:::.mpfr_debug() == 0 # the default level ## Activate debugging level 1: , Rmpfr:::.mpfr_debug(1) == 0 # the previous level ## and check it : , Rmpfr:::.mpfr_debug() == 1 # the current level ) r <- mpfr(7, 100)^-1000 r ## (same as without debugging) ## where as this does print info: -- notably the very large values [3..6]: .eranges <- function() sapply(.mpfr_erange_kinds, .mpfr_erange, USE.NAMES=FALSE) ## now, mpfr_erange() works with a *vector* of args: .erange2 <- function() .mpfr_erange(.mpfr_erange_kinds) ## now returning *double* - which loses some precision [ending in '04' instead of '03']: formatC(.eranges(), format="fg") stopifnot(identical(.eranges(), .erange2())) .mpfr_minPrec() .mpfr_maxPrec()# debug printing shows the long integer (on 64 bit) ## Now, level 2 : stopifnot(Rmpfr:::.mpfr_debug(2) == 1) r ## with quite a bit of output if(FALSE) # on Winbuilder [2019-08-08, both 32 and 64 bit]: .mpfr_erange_set("Emax", 1073741823) r2 <- r^100 r2 L <- r^-100000 L3 <- L^3 str(L3, internal=TRUE) ## Class 'mpfr' [package "Rmpfr"] of length 1 and precision 100 ## internally @.Data: List of 1 ## $ :Formal class 'mpfr1' [package "Rmpfr"] with 4 slots ## .. ..@ prec: int 100 ## .. ..@ exp : int [1:2] 842206477 0 ## .. ..@ sign: int 1 ## .. ..@ d : int [1:4] 268435456 761715680 1492345294 -1000766770 str(L3) ## lots of debugging output, then ## 1.00989692356e+253529412 ## ^^~~~~~~~~~ 10 ^ 253'529'412 that is humongous if(!interactive()) # not seg.faulting, but printing a *huge* line [no longer!] show(L3) ## segmentation fault -- randomly; 2017-06: no longer see any problem, not even with if(FALSE) ## well, not really, definitely not interactively for now if(interactive()) for(i in 1:256) show(L3) ## ## quite platform dependent {valgrind ==> bug? even in mpfr/gmp/.. ?} str(.mpfr2list(x4)) ## slightly nicer ["uniformly not worse"] (still very similar) : str(x4, internal=TRUE) x4 ## "similar info" as .mpfr2list(.) ## Increase maximal exponent: tools:::assertWarning( .mpfr_erange_set("Emax", 5e18)) # too large {FIXME why only warning and not error ??} .mpfr_erange("Emax") # is unchanged if(4e18 < .mpfr_erange("max.emax")) { .mpfr_erange_set("Emax", 4e18) # now ok: stopifnot(.mpfr_erange("Emax") == 4e18) } ## revert to no debugging: stopifnot(Rmpfr:::.mpfr_debug(0) == 2) .mpfr_maxPrec() L / (r2^-1000)# 1.00000....448 (could be more accurate?) stopifnot(exprs = { all.equal(L, r2^-1000, tol= 1e-27) # why not more accurate? all.equal(log(L), -100000 * (-1000) * log(7), tol = 1e-15) }) ## Now, our experimental "transport vehicle": stopifnot(length(rv <- c(r, r2, L)) == 3) str(mpfrXport(rv)) str(mpfrXport(mpfr(2, 64)^(-3:3))) str(mpfrXport(Const("pi")* 2^(-3:3))) ## and a very large one mil <- mpfr(1025, 111) str(mm <- mpfrXport(xx <- mil^(2^25))) stopifnot(all.equal(log2(xx) * 2^-25, log2(mil), tol=1e-15)) ## even larger -- strictly needs extended erange: if(.mpfr_erange("min.emin") <= -2^40) { .mpfr_erange_set("Emin", - 2^40) show(xe <- 2^mpfr(-seq(1,70, by=3)*8e8, 64)) ## used to print wrongly {because of integer overflow in .mpfr2str()$exp}, ## with some exponents large positive stopifnot(exprs = { ! .mpfr_erange_is_int() # as 'exp's now are double (ee <- as.numeric(sub(".*e","", formatMpfr(xe)))) < -240e6 (diff(ee) + 722471990) %in% 0:1 }) } else { cat(sprintf( "Cannot set 'Emin' to -2^40 (= %g), as .mpfr_erange(\"min.emin\") is larger, namely %g.\n", - 2^40, .mpfr_erange("min.emin"))) } ## Bill Dunlap's example (with patch about convert S_alloc bug): ## (precision increases, then decreases) z <- c(mpfr(1,8)/19, mpfr(1,32)/19, mpfr(1,24)/19) cbind(fz <- format(z)) stopifnot(identical(fz, rev(format(rev(z))))) stopifnot(identical(fz, c("0.05273", "0.052631578947", "0.0526315793"))) # << smaller prec, again since 2019-08-09 e.xx. <- .mpfr2exp(xx) e.z. <- .mpfr2exp(z) ## revert to original 'erange' settings (which gives integer 'exp'): .mpfr_erange_set("Emax", erangesOrig[["Emax"]]) # typically 2^30 - 1 = 1073741823 .mpfr_erange_set("Emin", erangesOrig[["Emin"]]) e.xx <- .mpfr2exp(xx) e.z <- .mpfr2exp(z) stopifnot(exprs = { .mpfr_erange_is_int() e.xx == e.xx. e.xx == 335591572 e.z == e.z. e.z == -4 is.integer(e.xx) # but e.xx. is double is.integer(e.z) }) k1 <- mpfr( c(123, 1234, 12345, 123456), precBits=2) (N1 <- asNumeric(k1))# 128 1024 12288 131072 -- correct str(sk1 <- .mpfr2str(k1)) str(sk1. <- .mpfr2str(k1, maybe.full=TRUE)) str(sk1.2 <- .mpfr2str(k1, digits=2, base=2)) str(sk1.2F <- .mpfr2str(k1, maybe.full=TRUE, base=2)) stopifnot(exprs = { identical(sk1 [1:2], list(str = c("13", "10", "12", "13"), exp = 3:6)) identical(sk1.[1:2], list(str = c("128", "1024", "12288", "131072"), exp = 3:6)) identical(sk1.2, list(str = c("10", "10", "11", "10"), exp = c( 8L, 11L, 14L, 18L), finite = rep(TRUE, 4), is.0 = rep(FALSE, 4))) all.equal(sk1.2[2:4], .mpfr_formatinfo(k1), tol=0) # not identical(): int <-> double identical(formatMpfr(k1, base=2, digits=20, drop0trailing=TRUE), with(sk1.2, paste0(str, sapply(exp - nchar(str), strrep, x="0")))) identical(formatMpfr(k1, base=2, digits=2, exponent.plus=FALSE), c("1.0e7", "1.0e10", "1.1e13", "1.0e17")) }) ## MM: --> need_dig is fine but is not used in the string that is returned !! (fk1sF <- formatMpfr(k1, scientific=FALSE)) # "the bug" --- now fixed! ==> new "Bug" in new Rmpfr ???? ## was "128." "1024." "12288." "131072." , but now obeying internal precision gives ## "1.e2" "1.e3" "1.e4" "1.e5" (fk1 <- formatMpfr(k1, digits=6)) stopifnot(exprs = { N1 == as.numeric(fk1) ## FIXME: This should change again "1024" identical(format(k1, digits=3), c("128.", "1020.", "1.23e+4", "1.31e+5")) }) ## digs <- setNames(1:6, 1:6) ## Each of these are 4 x 6 matrices ffix <- sapply(digs, function(d) format(k1, digits = d, scientific = FALSE)) ## *not* good at all .. ## ==> need a maybe.full=TRUE even here ff <- sapply(digs, function(d) format(k1, digits = d))# sci..fic = NA -- digits=1 failing for '128' fsci <- sapply(digs, function(d) format(k1, digits = d, scientific = TRUE)) # perfect stopifnot(exprs = { length(dd <- dim(ff)) == 2 identical(dd, dim(ffix)) identical(dd, dim(fsci)) all.equal(asNumeric(fsci), asNumeric(ffix) -> dmat, tol=0) all.equal(asNumeric(ff), asNumeric(ffix), tol=0) }) rE <- 1 - dmat / asNumeric(k1) i <- 1:5 summary(fm <- lm(log10(colMeans(abs(rE)))[i] ~ i)) stopifnot(exprs = { rE[ cbind(FALSE, upper.tri(rE)[,-6]) ] == 0 abs(residuals(fm)) < 0.15 }) ## formatting / printing : tenth <- mpfr(-12:12, 52)/10 cents <- mpfr(-11:11, 64)/100 (kxi <- sort(c(k1, x4, i8, tenth, cents), na.last=FALSE)) mstr <- .mpfr2str (kxi) mfi <- .mpfr_formatinfo(kxi) es <- mstr$exp # base 10 ; with '0' when !is.finite or is0 ef <- mfi $exp # base 2 ; "undefined" when !is.finite or is0 j2 <- c("finite", "is.0") dxi <- cbind(x = asNumeric(kxi), prec = .getPrec(kxi), as.data.frame(mstr, stringsAsFactors = FALSE)) stopifnot(is.data.frame(dxi), identical(mstr$str, dxi[,"str"]), identical(mstr[j2], mfi[j2]), identical(ef, .mpfr2exp(kxi))) dxi ## 2019-08-09: again *varying* size of 'str' rather than only growing !! ## Show that *order* no longer matters: n <- length(ixk <- rev(kxi)) dix <- cbind(x = asNumeric(ixk), prec = .getPrec(ixk), as.data.frame(.mpfr2str(ixk), stringsAsFactors = FALSE))[n:1,] attr(dix, "row.names") <- .set_row_names(n) stopifnot(identical(dxi, dix)) ## somewhat (but not so much) revealing : cbind(prec = .getPrec(kxi), kxi = asNumeric(kxi), str = es, fi.10 = ceiling(ef/log2(10)), str.2 = as.integer(es*log2(10)), fi = ef) ## Bug example from RMH 2018-03-16 : (x <- mpfr(c(65, 650, 6500, 65000, 650000), precBits=6)) data.frame(fDec = formatDec(x), f = formatMpfr(x)) x. <- as.numeric(xDec <- formatDec(x)) stopifnot(abs(x - x.) <= c(0, 0, 2, 12, 360)) cat("Checking compatibility .mpfr_formatinfo() <--> .mpfr2str(*, base=2) :\n") for(nm in ls()) if(is(OO <- get(nm), "mpfr")) { cat(nm,": str(*) :\n"); str(OO); cat("compatibility: ") I <- .mpfr_formatinfo(OO) S <- .mpfr2str(OO, base = 2L) if(identical(I, S[-1])) cat("[Ok]\n") else { if(any(B <- !I$finite)) I$exp[B] <- S$exp[B] if(any(B <- I $ is.0)) I$exp[B] <- S$exp[B] if(identical(I, S[-1])) cat(" after fixup [Ok]\n") else stop(".mpfr_formatinfo(*) and .mpfr2str(*, base=2) do not match") } } stopifnot(identical(character(), format(mpfr())))# gave warning Rmpfr/tests/binomial-etc.R0000644000176200001440000000230214547462101015171 0ustar liggesusersstopifnot(require("Rmpfr")) n <- 10000 + 0:10 stopifnot(exprs = { chooseMpfr(1:10, 0) == 1 # failed earlier chooseMpfr(20, 0:20) == choose(20, 0:20) chooseMpfr(19, 0:20) == choose(19, 0:20) chooseMpfr (30, 4:30) * (-1)^(4:30) == chooseMpfr.all(30, k0=4, alternating=TRUE) chooseMpfr(mpfr(1111, 2^8), 1111) == 1 chooseMpfr(mpfr(n,256), n ) == 1 # was wrong in <= 2023 chooseMpfr(mpfr(n,256), n-1) == n # " " }) cat('Time elapsed: ', proc.time(),'\n') # "stats" ## sumBinomMpfr() ... had embarrasing bug for a while sBn <- Rmpfr:::sumBinomMpfr.v1 stopifnot( all.equal( sBn(10, sqrt), sumBinomMpfr(10, sqrt), tol=1e-77) , all.equal( sBn(10, log, n0=1, alternating=FALSE), sumBinomMpfr(10, log, n0=1, alternating=FALSE), tol=1e-77) ) fBin <- function(k) x^k * (1-x)^(n-k) ## \sum_{k=0}^n (n \\ k) x^k (1-x)^{n-k} == sum(dbinom(0:n, n, prob=x)) == 1 : for(x in runif(50)) { n <- 1 + rpois(1, lambda=10) cat(".") stopifnot(all.equal(1, sumBinomMpfr(n, fBin, alternating=FALSE), tol = 1e-15)) };cat("\n") cat('Time elapsed: ', proc.time(),'\n') # "stats" if(!interactive()) warnings() Rmpfr/tests/tstHexBin.R0000644000176200001440000001470014420454417014544 0ustar liggesusersrequire(Rmpfr) sessionInfo() nums <- c(0, .625, .1, .3, .3125, .5, .6, (.3+.6), .9, 1, 3.3125) nums9 <- mpfr(nums, precBits = 9) n5.b2 <- mpfr("101", base=2) stopifnot(identical(n5.b2, mpfr(5, precBits=3)), identical(n5.b2, mpfr("0b101", base=2))) if(FALSE)## 0b101 could also be a Hex number with no initial '0x' -- hence NOT true: identical(n5.b2, mpfr("0b101")) ## We *could* say that anything starting with '0b' is binary, anything with '0x' is hexadecimal ### mpfr_Bcharacter() {no longer method} [was 'mpfrBchar', was 'scanBin'] : ##' Check the inverse of formatBin(), i.e., mpfr() working correctly chkInv.fBin <- function(x, ...) { stopifnot(is(x, "mpfr")) nb <- formatBin(x, ...) xx <- mpfr(nb) ## Inverse should work {apart from 0: that is not uniquely represented in MPFR!} stopifnot(identical(mpfrIs0(x ) -> i0, mpfrIs0(xx)), identical(x[!i0], xx[!i0])) invisible(nb) } (nums9bc <- chkInv.fBin(nums9)) (nums9bF <- chkInv.fBin(nums9, scientific=FALSE)) # "F": Fixed format (as in Fortran) ## higher precision, 0,Inf, sign change: (i12 <- 1 / mpfr(c(-2:12, Inf), 64)) (i12.50 <- roundMpfr(i12, precBits=50)) # "same", with 50 (< 53) bits try({ ## FIXME -- formatBin() bug -- fails for 'Inf' ! (nI.12 <- chkInv.fBin(i12 )) (nI.12.50 <- chkInv.fBin(i12.50)) }) ii <- mpfr(c(-Inf, 17, Inf), 7) formatHex(ii) ## fine formatDec(ii) ## not 100% ok, as it has "." [FIXME ?] n9. <- Rmpfr:::mpfr.Ncharacter(nums9bc) n9_ <- mpfr(nums9bc) ## Inverse worked {apart from 0: it is not at all uniquely represented in MPFR!} stopifnot(identical(mpfrIs0(n9.), mpfrIs0(n9_)), all.equal(n9_, n9., tolerance=0), identical(nums9[-1], n9.[-1])) mpfr(nums9bc, precBits=5) (n9.5 <- mpfr(nums9bF, scientific=FALSE, precBits=5)) stopifnot(all.equal(n9.5, mpfr(nums9bF, precBits=5), tol=0)) stopifnot(all.equal(n9., n9.5, tol = 0.02), getPrec(n9.5) == 5) mpfr(nums9bF, scientific=FALSE) mpfr(nums9bF) ### mpfr() -> mpfrHchar (was 'scanHex') : nums9hc <- formatHex(nums9) stopifnot(all.equal(n9., mpfr(nums9hc), tol = 0), all.equal(n9.5, mpfr(nums9hc, precBits=5), tol = 0)) ### Rest from ../R/formatHex.R -- heavily modified (m32 <- matrix(0:31, 8, 4, dimnames = list(0:7, c(0,8,16,24)))) FourBits <- mpfr(m32, precBits=4) FiveBits <- mpfr(m32, precBits=5) stopifnot(all.equal(m32, asNumeric(FiveBits), tol=0), all.equal(m32, asNumeric(FourBits), tol= 0.05)) ## HH:::formatHexInternal(FourBits) formatHex(FourBits) formatHex(FourBits, precBits=5) formatHex(FourBits, precBits=6) formatBin(FourBits) formatBin(FourBits, precBits=5) formatBin(FourBits, scientific=FALSE) formatBin(FourBits, scientific=FALSE, precBits=5) formatDec(FourBits) formatDec(FourBits, precBits=5) formatDec(FourBits, precBits=7) ## HH:::formatHexInternal(FiveBits) formatHex(FiveBits) formatHex(FiveBits, precBits=5) formatHex(FiveBits, precBits=6) formatBin(FiveBits) formatBin(FiveBits, precBits=5) formatBin(FiveBits, precBits=6) formatBin(FiveBits, scientific=FALSE) formatBin(FiveBits, scientific=FALSE, precBits=6) formatDec(FiveBits) formatDec(FiveBits, precBits=5) formatDec(FiveBits, precBits=7) TenPowers <- mpfr(matrix(10^(-3:5)), precBits=53) row.names(TenPowers) <- -3:5 TenPowers options(width = 180) # for several "wide" displays below ## This indirectly "checks' as.data.frame.Ncharacter(): mkDF <- function(mv, displaydigits = 4, stringsAsFactors = FALSE) { stopifnot(is.numeric(mv) || inherits(mv, "mpfr")) data.frame(Hex = formatHex(mv), Bin = formatBin(mv), BinF= formatBin(mv, scientific=FALSE), Dec = formatDec(mv), Dec4= formatDec(mv, displaydigits=displaydigits), Dec.= formatDec(mv, scientific=TRUE), Dec.4=formatDec(mv, scientific=TRUE, displaydigits=displaydigits), stringsAsFactors = stringsAsFactors) } nmsMkDF <- c("Hex", "Bin", "BinF", "Dec", "Dec4", "Dec.", "Dec.4") d10p. <- mkDF(TenPowers) (d10p <- mkDF(as.vector(TenPowers))) TenFrac <- matrix((1:10)/10, dimnames=list(1:10, expression(1/x))) TenFrac stopifnot(exprs = { is.matrix(print(formatHex(TenFrac))) # stays a matrix is.matrix(print(formatBin(TenFrac))) is.matrix(print(formatBin(TenFrac, scientific=FALSE))) is.matrix(print(formatDec(TenFrac))) }) TenFrac9 <- mpfr(TenFrac, precBits=9) TenFrac9 data.frame(Hex = formatHex(TenFrac9), ## checking as.data.frame.Ncharacter as well Bin = formatBin(TenFrac9), BinF= formatBin(TenFrac9, scientific=FALSE), Dec = formatDec(TenFrac9)) -> d9 d9 ## Does not print the column names but the colnames of each 1-col. matrix ("1/x"). ## This is how R in general works { in format.data.frame() } ## now use vectors: tenfrac9 <- as.vector(TenFrac9) stopifnot(identical(tenfrac9, c(TenFrac9))) data.frame(Hex = formatHex(tenfrac9), Bin = formatBin(tenfrac9), BinF= formatBin(tenfrac9, scientific=FALSE), Dec = formatDec(tenfrac9)) -> dl9 dl9 # (now prints as d9 had printed in the past) stopifnot(exprs = { getPrec(TenFrac ) == 53 getPrec(TenFrac9) == 9 colnames(d9) == c("Hex", "Bin", "BinF", "Dec") inherits(d9, "data.frame") all.equal(dim(d9), c(10,4)) }) (Ten <- matrix(1:10 + 0.0, dimnames=list(1:10, "x"))) ## + 0.0 forces double precision dT <- mkDF(Ten) dt <- mkDF(as.vector(Ten)) dt # large (Ten4 <- mpfr(Ten, precBits=4)) ten4 <- as.vector(Ten4) D4 <- mkDF(Ten4) # would be printing "x" --- because we added one-column matrices !! (d4 <- mkDF(ten4)) # printing fine ! stopifnot(identical(names(d4), names(D4)), identical(names(d4), nmsMkDF)) Two8 <- matrix(2^seq(-8, 8)) Two8.3 <- mpfr(Two8, precBits=3) ## formatBin stopifnot( identical(sapply(as(Two8.3, "mpfr")[-c(1:3, 15:17)], function(t83) formatBin(t83, scientific=FALSE)), c("+0b.____100", "+0b.___100", "+0b.__100", "+0b._100", "+0b.100", "+0b1.00","+0b10.0","+0b100.","+0b100_.","+0b100__.","+0b100___."))) ## formatDec --- these must be perfectly aligned on the "." ! formatDec(Two8.3, digits = 3) formatDec(Two8.3, digits = 8) stopifnot( identical(capture.output(formatDec(Two8.3, digits = 3))[2:4], c(" [1,] 0.00391", " [2,] 0.00781", " [3,] 0.0156 ")) , identical(capture.output(formatDec(Two8.3, digits = 8))[c(2:3,8,13,16)], c(" [1,] 0.0039062500", " [2,] 0.0078125000", " [7,] 0.25000000 ", "[12,] 8.0000000 ", "[15,] 64.000000 ")) ) Rmpfr/tests/functionals.R0000644000176200001440000000724314274665772015204 0ustar liggesusers#### Tests for "Functionals": Root finding, Optimization, Integration, etc stopifnot(require("Rmpfr")) (f.chk <- system.file("check-tools.R", package="Rmpfr", mustWork=TRUE)) source(f.chk, keep.source=FALSE) ## -> assert.EQ.() showSys.time() options(warn = 1)# warnings *immediately* (doExtras <- Rmpfr:::doExtras()) ### 1. Integration ----------------------------------------------- ## Example from Lauren K, June 2014 (~/R/MM/Pkg-ex/Rmpfr/integrateR-LaurenK.R): beta0 <- 0.05 beta1 <- 0.05 (tau <- sqrt(0.01*0.05*0.95/0.99))# = 0.0219.. ## Z00 <- 9 Z01 <- 1 Z10 <- 18 Z11 <- 2 N <- Z00+Z01+Z10+Z11 integrand <- function(u) { ee.u <- exp(-u^2/2)/(sqrt(2*pi)*tau) b0u <- beta0 + tau*u b1u <- beta1 + b0u # == beta0+beta1+ tau*u ee.u ^ (Z00+Z01 + Z10+Z11) * (1-b0u)^Z00 * b0u ^ Z01 * (1-b1u)^Z10 * b1u ^ Z11 } ## MM: note how the integrand() function looks: op <- par(mfcol=c(3,1), mgp=c(1.5, .6, 0), mar=.1+c(3,3,0,0)) ax1 <- function(a,b) axis(1, at=c(a,b), col=2, col.axis=2, tcl= +3/4, mgp=c(3,0,0)) curve(integrand, -5,5, n=1000) cc <- adjustcolor(2, 1/4) ## look closer: ep <- .01; rect(-3, -ep, 0, +ep, col=cc, border=cc); ax1(-3,0) curve(integrand, -3,0, n=1000, ylim = c(-ep,ep)) ## but now look really closely : ep <- .001; rect(-3, -ep, -2, +ep, col=cc); ax1(-3,-2) curve(integrand, -3,-2, n=1000, ylim = c(-ep, ep)) par(op) (I1 <- integrate(integrand,lower = -100, upper = 100)) (I1. <- integrate(integrand,lower = -100, upper = 100, rel.tol = 1e-14)) showSys.time(I2 <- integrateR(integrand, lower = -100, upper = 100)) I2 ## ... Warning ‘no convergence up to order 13’ ## Solaris Sparc (2014-06, CRAN checks); thanks Brian: print(I2[1:2], digits=15) I2.Solaris <- list(value = 1.3963550396006e+33, abs.error = 1.79487857486724e+28) I.db <- list(value = 1.39635503960059e+33, abs.error = 1.79487857478077e+28) stopifnot( all.equal(I2[1:2], I.db, tol = 1e-10)# Solaris SPARC needs at least 4.8e-11 ) ## Now using high accuracy showSys.time(I3 <- integrateR(integrand, lower = mpfr(-100, precBits=256), upper = 100)) ## much slower but not better (and not worse) I3 assert.EQ.(sapply(I3[1:2], asNumeric), unlist(I.db)) ## Really get better when decreasing the integration interval ## from [-100, 100] to [-10, 10] ... which should give "the same" showSys.time(I4 <- integrateR(integrand, lower = mpfr(-10, precBits=256), upper = 10, ord = 15, verbose=TRUE)) ## ~ 6.6 sec [lynne 2013] I4 ## on the left side, there is "nothing" (and negative, as we know!): showSys.time(I0.1 <- integrateR(integrand, lower = mpfr(-1000, precBits=256), upper = -10, ord= 11, verbose=TRUE)) showSys.time(I0.2 <- integrateR(integrand, lower = mpfr(10, precBits=256), upper = 1000, ord= 11, verbose=TRUE)) I0.1 I0.2 I4 ## Integral [-1000, +1000 ] = Int[-1000, -10] + Int[-10, +10] + Int[+10, +1000]: I4 $value + I0.1 $value + I0.2 $value ## but this is really the same as just the middle: stopifnot(I4 $value + I0.1 $value + I0.2 $value == I4 $value) value <- I4$value; delta <- I4$abs.err nDig <- -asNumeric(log10(delta/value)) cat("Correct number of digits: ", round(nDig, 2),"\n", "Integral I = ", format(I4$value, digits = ceiling(nDig)), " (last change change= ", format(delta, digits = 7),")\n", "integrate(.) = ", format(I1 $value, digits = 22),"\n", "integrate(., rtol=1e-15)= ", format(I1.$value, digits = 22),"\n", sep="") ### 2. Root Finding ---------------------------------------------- ### 3. Optimization / Minimization, .. --------------------------- cat('Time elapsed: ', proc.time(),'\n') # "stats" Rmpfr/tests/arith-ex.R0000644000176200001440000002324414533333542014360 0ustar liggesusersrequire("Rmpfr") ## includes ("gmp")# want to check "mixed arithmetic" too __ TODO __ `%=N=%` <- function(x,y) (x == y) | (is.na(x) & is.na(y)) all.EQ <- function(x,y, tolerance = 2^-98, ...) # very small tol. for MPFR all.equal(x, y, tolerance=tolerance, ...) warningI <- function(...) warning(..., immediate. = TRUE) unlist(.Platform) ## Check that we got the "which.*" methods also from "bigq": bcl <- c("ANY", "bigq", "bigz", "mpfr") ##if(packageVersion("gmp") >= "0.5-8") { stopifnot(identical(bcl, sort(unlist(findMethods("which.max")@signatures))), identical(bcl, sort(unlist(findMethods("which.min")@signatures)))) ##} options(warn = 1)# warnings *immediately* (doExtras <- Rmpfr:::doExtras()) eps2 <- 2 * .Machine$double.eps eps8 <- 8 * .Machine$double.eps eps32 <- 32 * .Machine$double.eps ## must take the *larger* of the two precisions: stopifnot(substr(format(mpfr(1, 60)/mpfr(7, 160)), 1,51) == # format() may show more digits "0.1428571428571428571428571428571428571428571428571")# again has extra "2" at end (x <- mpfr(0:7, 100) / 7) ix <- x^-1000 iX <- asNumeric(ix) stopifnot( mpfrIs0(x - x), # badly failed on 64-bit identical(-x, 0-x),# testing "- x" all.equal(ix, (1/x)^1000, tol= 1e-25), is.numeric(iX), iX[1:4] == Inf, # failed previously as we used RNDD (downward rounding) all.equal(log(iX[5:8]), c(559.6157879, 336.4722366, 154.1506798, 0), tol = 1e-9)) ## checking hexadecimal input : stopifnot(mpfr("0xFFFFFFFFFFFFFFFFFFFF", base=16) + 1 == 2^80, ## sign(0) == 0: identical(sign(as(-1:1, "mpfr")), -1:1 + 0)) stopifnot(all.equal(as.numeric(x+ 1L), as.numeric(x)+1L, tol = eps2), as.integer( x [x < 1]) == 0,# was *wrong* {we round()ed; previously "down"!} as.integer((-x)[x < 1]) == 0,# (ditto) (3 * x)/3 <= x, all.equal(as.numeric(x * 2L), as.numeric(x + x), tol = 0)) u <- mpfr(0:17, 128)/17 two <- mpfr(2,100) stopifnot(all.EQ(u ^ two, u ^ 2), identical(u ^ 2, u ^ 2L), all.EQ(two ^ u, 2 ^ u), identical(2 ^ u, 2L ^ u), floor (3*u) == floor (3/17*(0:17)), ceiling(u*5) == ceiling(5/17*(0:17)) ) i7 <- mpfr(0:7, 200)/ 7 i17 <- mpfr(0:17, 300)/17 stopifnot(all.equal(as.numeric(x+1), as.numeric(x)+1), all.equal(round(x,2), round(asNumeric(x), 2), tol=1e-15), all.equal(round(mpfr(1.152, 80), 2), 1.15), # was wrong {as.integer() bug} all.equal(0:7, 7 * round ( i7, 25), tol = 2e-25), all.equal(0:7, 7 * round ( i7, 50), tol = 2e-50), all.equal(0:17, 17 * signif(i17,100), tol = 2e-100), all.equal(0:17, 17 * signif(i17, 20), tol = 2e-20) ) ## When we compute with 100 bits, ## we should compare relative errors with 2^-100 : del <- abs((x+pi)-pi - x) / 2^-100 stopifnot(del <= 4) ## <= 2 already (fd <- format(del, drop0 = TRUE)) stopifnot(all.equal(as.numeric(del), as.numeric(fd), tol = 1e-15)) if(print(Sys.info()[["machine"]]) == "x86_64") stopifnot(fd %in% as.character(c(0:2, c(2,7)/4))) checkPmin <- function(x, nx = as(x, "numeric")) { rx <- if(is(x,"mpfr")) round(x, 25) else x isZ <- is(x, "bigz") || is(nx, "bigz") M.X <- max(x, na.rm=TRUE) m.x <- min(x, na.rm=TRUE) stopifnot(all.equal(x, nx), pmin(x, x, M.X) %=N=% x, x %=N=% pmax(x, m.x, x), all.equal(x, pmin(x, nx, x, M.X)), all.equal(x, pmax(m.x, nx, x, rx, m.x)), if(isZ)TRUE else all.equal(pmin(x, 0.75), pmin(nx, 0.75)), if(isZ)TRUE else all.equal(pmax(x, 0.25), pmax(nx, 0.25))) } x <- mpfr(0:7, 100) / 7 checkPmin(x) nx <- (0:7)/7 (qx <- as.bigq(0:7, 7)) x[c(2,5)] <- NA nx[c(2,5)] <- NA qx[c(2,5)] <- NA Z <- as.bigz(1:7) mZ <- mpfr(Z, 64) stopifnot(Z == mZ, mZ == Z) checkPmin(x, nx) cat("checking pmin(. bigq ): ") ## FIXME checkPmin(x, qx); cat("[Ok]\n") ## print( base::pmin(Z, Z, max(Z)) )# via gmp:: rep.bigz(x, length.out = *) cat("checking pmin(. bigz ) [currently with lots of pmin() and pmax(...) warnings 'incompatible methods]:\n ") checkPmin(Z); cat("[Ok]\n") # via gmp:: all.equal.bigz() stopifnot(all.equal( round(x, 10), round(nx, 10)), all.equal(signif(x, 10), signif(nx, 10))) ## L & x , x & L failed in Rmpfr 0.2* and 0.4-2 stopifnot(identical(L <- x > 0.5, L & x), identical(L, x & L), identical(x > 0, x | L)) ## Summary() methods {including NA stopifnot(exprs = { is.na(min(x)) is.na(max(x)) is.na(range(x)) is.na(sum(x)) is.na(prod(x)) min(x, na.rm=TRUE) == 0 max(x, na.rm=TRUE) == 1 range(x, na.rm=TRUE) == 0:1 all.equal(sum (x, na.rm=TRUE)*7, 2+3+5+6+7, tolerance = 1e-28) # 1.0975e-30 prod(x, na.rm=TRUE) == 0 all.equal(180, prod(x[-1], na.rm=TRUE)*7^4, tol = 1e-15) # 1.579e-16 ## ## all(), any() had memory bug [PROTECT missing, but more, somehow] !all(x) is.na( all(x[-1]) ) any(x) is.na(any(x[c(2,5)])) ## do these *twice* {that triggered R-forge bug #6764 } ! all(x, na.rm=TRUE) any(x, na.rm=TRUE) ## ! all(x, na.rm=TRUE) any(x, na.rm=TRUE) }) ##-------------- Modulo and "integer division" ------------- ## R's ?Arithmetic : ## ## ‘%%’ indicates ‘x mod y’ and ‘%/%’ indicates integer division. It ## is guaranteed that ‘x == (x %% y) + y * ( x %/% y )’ (up to ## rounding error) unless ‘y == 0’ where the result of ‘%%’ is ## ‘NA_integer_’ or ‘NaN’ (depending on the ‘typeof’ of the ## arguments). ## ## and has 'details' about how non-integer 'y' works ## (N <- if(doExtras) 1000 else 200) (todays.seed <- eval(parse(text=Sys.Date())))# so this is reproducible # (and constant within one day) set.seed(todays.seed) mm <- c(-4:4, sample(50, N-9, replace=TRUE)) for(n in seq_len(N)) { cat("."); if(n %% 50 == 0) cat(n,"\n") m <- mm[n] prec <- sample(52:200, 1)# "high precision" ==> can use small tol x <- sample(100, 50) - 20 for(kind in c('int','real')) { if(kind == "real") { m <- jitter(m) x <- jitter(x) tol.1 <- eps32 * pmax(1, 1/abs(m)) EQ <- function(x,y, tol = tol.1) isTRUE(all.equal(x, as.numeric(y), tol=tol)) EQ2 <- function(x,y, tol = tol.1) { ## for the DIV - MOD identity, a small x leads to cancellation all((x %=N=% y) | abs(x - y) < tol*pmax(abs(x), 1)) || isTRUE(all.equal(x, as.numeric(y), tol=tol)) } } else { ## "integer" EQ2 <- EQ <- function(x,y, tol) all(x %=N=% y) } i.m <- mpfr(x, prec) %% mpfr(m, prec) if(!EQ2(x %% m, i.m)) { cat("\n -- m = ",m," (prec = ",prec,")\n") rE <- range(rel.E <- as.numeric(1 - (x %% m)/i.m)) print(cbind(x, 'R.%%' = x %% m, rel.E)) MSG <- if(max(abs(rE)) < 1e-10) warningI else stop MSG(sprintf("not all equal: range(rel.Err.) = [%g, %g]", rE[1],rE[2])) } ## if(m != 0) { ##---Check the x == (x %% m) + m * ( x %/% m ) assertion ------ ## if(EQ2(x, (x %% m) + m*( x %/% m ), tol = 1e-12)) { ## ok for R ## --> also ok for mpfr ? iDm <- mpfr(x, prec) %/% mpfr(m, prec) rhs <- i.m + m*iDm if(!EQ2(x, i.m + m*iDm)) { cat("\n -- m = ",m," (prec = ",prec,")\n") print(cbind(x,' MPFR[ x%%m + m(x %/% m) ]' = as.numeric(rhs), rel.E)) MSG <- if(max(abs(rE)) < 1e-10) warningI else stop MSG(sprintf("Identity(MOD - DIV) not all eq.: range(rel.Err.) = [%g, %g]", rE[1],rE[2])) } } else { cat("\n hmm.. the basic %% <-> %/% assertion 'fails' in *R* :\n") rhs <- (x %% m) + m * ( x %/% m ) rel.E <- (1 - rhs/x) print(cbind(x, 'x%%m + m(x %/% m)' = rhs, rel.E)) } } } } ## mpfr o now implemented, for '%%', too : r <- as.double(i <- -10:20) stopifnot( ## %% ------------------------------------- mpfr(i, prec=99) %% 7 == i %% 7 , ## mpfr(i, prec=99) %% 7 == mpfr(i, prec=99) %% 7L , ## i %% mpfr(27, prec=99) == i %% 27 , ## r %% mpfr(27, prec=99) == r %% 27 , ## %/% ------------------------------------- mpfr(i, prec=99) %/% 7 == i %/% 7 , ## mpfr(i, prec=99) %/% 7 == mpfr(i, prec=99) %/% 7L , ## mpfr(i, prec=99) %/% mpfr(27, prec=99) == i %/% 27 , ## i %/% mpfr(27, prec=99) == i %/% 27 , ## i %/% mpfr(27, prec=99) == r %/% mpfr(27, prec=99) , TRUE ## ) cat('Time elapsed: ', proc.time(),'\n') # "stats" ## Was reproducible BUG in Rmpfr-addition (on Linux, MPFR 4.x.y) -- ## but the bug was Rmpfr, ## in ../src/Ops.c, detecting if *integer*, i.e., long can be used dn <- 1e20 dOO <- 9223372036854775808; formatC(dOO) # "9.2...e18" (r <- dn / (dn + dOO)) # 0.915555 (double prec arithmetic) ## but *so* strange when switching to Rmpfr : addition accidentally *subtract*!! n <- mpfr(dn, precBits = 99) (rM <- n / (n + dOO)) # wrongly gave " 1 'mpfr' .... 99 bits; 1.101605140483951..... stopifnot(exprs = { all.equal(n + dOO, dn + dOO) all.equal(n / (n + dOO), r) }) ## log(., base) : (ten40 <- as.bigz(10)^40) ten40m <- mpfr(ten40) (lt40 <- log(ten40m, 10)) # gave Error in ... : base != exp(1) is not yet implemented ## 'mpfr' .. 133 bits \\ [1] 40 stopifnot(exprs = { grepl("^40[.]000+$", print(format(lt40, digits = 60))) identical(lt40, log10(ten40m)) identical(log(ten40m, 2), log2(ten40m)) inherits(Pi <- Const("pi", 140), "mpfr") all.equal(show(log(ten40m, Pi)), log(ten40m)/log(Pi), tol = 1e-40) }) ###------Standard Statistics Functions -------------------------------------------------------- x <- c(del, 1000) stopifnot(identical(mean(x), mean(x, trim=0))) for(tr in (0:8)/16) stopifnot(all.equal(mean( x, trim = tr), mean(asNumeric(x), trim = tr), tol=1e-15)) cat('Time elapsed: ', proc.time(),'\n') # "stats" Rmpfr/tests/matrix-ex.R0000644000176200001440000001506314274665772014574 0ustar liggesusersstopifnot(require("Rmpfr")) x <- mpfr(0:7, 64)/7 mx <- x dim(mx) <- c(4,2) (m. <- mx) # "print" m.[,2] <- Const("pi", 80) m.[,] <- exp(mpfr(1, 90)) stopifnot(is(mx, "mpfrMatrix"), dim(mx) == c(4,2), is(m., "mpfrMatrix"), dim(m.) == dim(mx), dim(is.finite(mx)) == dim(mx), dim(is.nan(mx)) == dim(mx), getPrec(m.) == 90) xx <- (0:7)/7 m.x <- matrix(xx, 4,2) m2 <- mpfr(xx, 64); dim(m2) <- dim(m.x) ## u <- 10*(1:4) y <- 7 * mpfr(1:12, 80) my <- y dim(my) <- 3:4 m.y <- asNumeric(my) stopifnot(all.equal(m2, mpfr(m.x, 64), tol=0), # not identical(..) my[2,2] == 35, my[,1] == 7*(1:3)) .N <- function(x) { if(!is.null(dim(x))) as(x,"array") else as(x,"numeric") } noDN <- function(.) { dimnames(.) <- NULL ; . } allEQ <- function(x,y) all.equal(x,y, tol=1e-15) ## FIXME write "functions" that take x -> {mx , m.x} and run the following as *function* ## ---- then use previous case *and* cases with NA's ! ## and use higher precision via fPrec = 2 etc ... stopifnot(allEQ(m.x, noDN(.N(mx))), allEQ(m.y, noDN(.N(my))), allEQ(noDN(.N(my %*% mx)), m.y %*% m.x), allEQ(noDN(.N(crossprod(mx, t(my)))), crossprod(m.x, t(m.y))), allEQ(noDN(.N(tcrossprod(my, t(mx)))), tcrossprod(m.y, t(m.x))), ## identical(mx, t(t(mx))), identical(my, t(t(my))), ## matrix o vector .. even vector o vector identical(noDN(.N(my %*% 1:4)), m.y %*% 1:4 ), identical(noDN(.N(my %*% my[2,])), m.y %*% .N(my[2,])), identical( crossprod(1:3, my), 1:3 %*% my), identical(tcrossprod(1:4, my), 1:4 %*% t(my)), identical(crossprod(y), t(y) %*% y), identical(tcrossprod(y), y %*% t(y)), identical(noDN(.N( crossprod(y))), crossprod(7 * 1:12)), identical(noDN(.N(tcrossprod(y))),tcrossprod(7 * 1:12)), identical(tcrossprod(1:3, u), noDN(.N(tcrossprod(1:3, as(u,"mpfr"))))) ) mx[3,1] <- Const("pi", 64) stopifnot(allEQ(sum(mx[,1]), pi + 4/7)) m2 <- mx[c(1,4),] stopifnot(dim(m2) == c(2,2), sum(m2) == 2) ## "mpfrArray" o "mpfr" : Tmx <- array(TRUE, dim(mx), dimnames=dimnames(mx)) stopifnot(identical(Tmx, mx == (mx - mpfr(0, 10))), identical(Tmx, mx - mpfr(1, 10) * mx == 0)) ## subassignment, many kinds mx[5] <- pi mx[6] <- Const("pi",100) stopifnot(validObject(mx), allEQ(mx[5], mx[6]), getPrec(mx) == c(rep(64,5), 100, 64,64)) ## %*% with vectors on LHS, ... y <- t(2:4) # 1 x 3 matrix m1 <- (0:10) %*% y m2 <- mpfr(0:10, 50) %*% y stopifnot((d <- m1 - m2) == 0, identical(dim(m1), dim(d)), m2 == m1, m1 == m2) r <- 10*(0:4) y <- t(2:6) m1 <- 1:3 %*% y %*% r y. <- t(mpfr(2:6, 20)) m2 <- 1:3 %*% y. %*% r stopifnot(m1 == m2, m1 - m2 == 0, identical(dim(m1), dim(m2))) ### Array (non-matrix) ---- indexing & sub-assignment : A <- mpfrArray(1:24, prec = 96, dim = 2:4) a <- array(1:24, dim = 2:4) a.1 <- as(A[,,1], "array") a1. <- as(A[1,,], "array") A1. <- as(A[1,,], "mpfr") stopifnot(all.equal(noDN(a.1), a[,,1], tol=0), identical(A1., as.vector(A[1,,])), ## arithmetic, subsetting etc: allEQ(noDN(.N(A / A1.)), a/c(a1.)), allEQ(noDN(.N(a / A1.)), a/c(a1.)), identical(noDN(A == 23), a == 23), identical(noDN(10 >= A), 10 >= a), identical(noDN(A <= 2), a <= 2), identical(noDN(A < 2.5), a < 2.5), identical(noDN(A != 5), a != 5), identical(A != 3, !(3 == A)), identical(-1 > A, A == 100), identical(noDN(A <= 0), a == pi) ) A[1,2,3] <- Const("pi") A[1, ,2] <- 1 / A[1,,2] A ## check that A is "==" a where a <- array(1:24, 2:4); a[1,2,3] <- pi; a[1,,2] <- 1/a[1,,2] stopifnot(allEQ(noDN(.N(A)), a), ## check aperm() methods : allEQ(noDN(.N(aperm(A))), aperm(a)), {p <- c(3,1:2); allEQ(noDN(.N(aperm(A,p))), aperm(a,p))}, {p <- c(2:1,3); allEQ(noDN(.N(aperm(A,p))), aperm(a,p))}) ## cbind() / rbind(): options(warn = 2)## no warnings here - ("exact recycling"): validObject(m0 <- cbind(pi=pi, i = 1:6)) validObject(m1 <- cbind(a=Const("pi",60),i = 1:6, "1/mp" = 1/mpfr(1:3,70))) validObject(m2 <- cbind(pi=pi, i = 1:2, 1/mpfr(1:6,70))) validObject(n2 <- rbind(pi=pi, i = 1:2, 1/mpfr(1:6,70))) stopifnot(is(m0,"matrix"), is(m1, "mpfrMatrix"), is(m2, "mpfrMatrix"), dim(m0) == c(6,2), dim(m1) == c(6,3), dim(m2) == c(6,3)) options(warn = 1) suppressWarnings(eval(ex <- quote(m3 <- cbind(I=10, 1:3, inv=1/mpfr(2:3,80))))) validObject(suppressWarnings( n3 <- rbind(I=10, 1:3, inv=1/mpfr(2:3,80)))) stopifnot(identical(t(n2), m2), identical(t(n3), m3), validObject(m3), is(tryCatch(eval(ex), warning=function(.).), "warning"), identical(cbind("A", "c"), matrix(c("A", "c"), 1,2)), identical(rbind("A", 2), matrix(c("A", "2"), 2,1)) ) ## head() / tail() : stopifnot(all.equal(c(21, 12), dim(mm3 <- m3[rep(1:3, each=7), rep(3:1, 4)])), all.equal(dim(t3 <- tail(mm3)), c(6, 12)), all.equal(head(mm3), mm3[1:6,])) ## matrix() works since 2015-02-28: x <- mpfr(pi,64)*mpfr(2,64)^(2^(0:19)) (mx <- matrix(x, 4,5)) stopifnot(is(mx, "mpfrMatrix"), all.equal(matrix(0:19, 4,5), asNumeric(log2(log2(mx) - log2(Const("pi")))), tol = 1e-15)) # 64b-lnx: see 8.1e-17 ## Ensure that apply() continues to work with 'bigz'/'bigq' A <- matrix(2^as.bigz(1:12), 3,4) Aq <- as.bigq(A) mA <- as(A, "mpfr") # failed {as dim(A) is "double", not "integer"} (Qm <- A / (A^2 - 1)) # big rational matrix MQ <- mpfr(Qm, precBits = 64) stopifnot(exprs = { mA == A mA == Aq is.bigq(Aq) mA == mpfr(A, precBits=16) mA == asNumeric(A) is.bigq(Qm) is(MQ, "mpfrMatrix") all.equal(Qm, MQ, tol = 1e-18) identical(dim(mA), dim(A)) identical(dim(mA), dim(Qm)) identical(asNumeric(apply(A, 1, min)), apply(asNumeric(A), 1, min)) identical(asNumeric(apply(A, 1, max)), apply(asNumeric(A), 1, max)) identical(asNumeric(apply(A, 2, max)), apply(asNumeric(A), 2, max)) identical(asNumeric(apply(A, 2, min)), apply(asNumeric(A), 2, min)) }) ## mA etc, failed up to Rmpfr 0.8-1; the apply() parts failed up to Rmpfr 0.6.0 if(FALSE) ## Bug in gmp : apply(*, range) does *not* return matrix stopifnot( identical(asNumeric(apply(A, 1, range)), apply(asNumeric(A), 1, range)) ) if(FALSE) ## Bug in gmp : --- no mean method for bigz, just mean.bigq stopifnot( all.equal(asNumeric(apply(A, 1, mean)), apply(asNumeric(A), 1, mean)) , all.equal(asNumeric(apply(A, 2, mean)), apply(asNumeric(A), 2, mean)) ) cat('Time elapsed: ', proc.time(),'\n') # "stats" if(!interactive()) warnings() Rmpfr/tests/special-fun-ex.R0000644000176200001440000003605215006632323015453 0ustar liggesusersstopifnot(require("Rmpfr")) (doExtras <- Rmpfr:::doExtras()) options(nwarnings = 50000, width = 99) (do.pdf <- !dev.interactive(orNone = TRUE)) if(do.pdf) { pdf.options(width = 8.5, height = 6) # for all pdf plots pdf("special-fun.pdf") } ## to enhance |rel.Err| plots: {also in ~/R/Pkgs/DPQ/tests/pow-tst.R } drawEps.h <- function(p2 = -(53:51), side = 4, lty=3, lwd=2, col=adjustcolor(2, 1/2)) { abline(h = 2^p2, lty=lty, lwd=lwd, col=col) axis(side, las=2, line=-1, at = 2^p2, labels = as.expression(lapply(p2, function(p) substitute(2^E, list(E=p)))), col.axis = col, col=NA, col.ticks=NA) } mtextVersion <- function(adj = 1, col = 1) { mtext(osVersion, line=1, col=col, adj=adj) mtext(sfsmisc::shortRversion(spaces=FALSE), col=col, adj=adj) } all.eq.finite <- function(x,y, ...) { ## x = 'target' y = 'current' if(any(is.finite(y[!(fx <- is.finite(x))]))) return("current has finite values where target has not") if(any(is.finite(x[!(fy <- is.finite(y))]))) return("target has finite values where current has not") ## now they have finite values at the same locations all.equal(x[fx], y[fy], ...) } n <- 1000 head(x <- mpfr(0:n, 100) / n) stopifnot(exprs = { range(x) == 0:1 all.equal(as.numeric(j0(x)), besselJ(as.numeric(x), 0), tol = 1e-14) all.equal(as.numeric(j1(x)), besselJ(as.numeric(x), 1), tol = 1e-14) all.equal(as.numeric(y0(x)), besselY(as.numeric(x), 0), tol = 1e-14) all.equal(as.numeric(y1(x)), besselY(as.numeric(x), 1), tol = 1e-14) }) ### pnorm() -> erf() : ---------------------------------------------------------- u <- 7*x - 2 stopifnot(all.equal(pnorm(as.numeric(u)), as.numeric(pnorm(u)), tol = 1e-14)) ## systematic random input testing: set.seed(101) if(doExtras) { nSim <- 50 n2 <- 100 } else { nSim <- 10 n2 <- 64 } for(n in 1:nSim) { N <- rpois(1, lambda=n2) N3 <- N %/% 3 x <- c(rnorm(N-N3), 10*rt(N3, df=1.25))# <- some large values m <- rnorm(N, sd = 1/32) s <- rlnorm(N, sd = 1/8) cEps <- .Machine$double.eps for(LOG in c(TRUE,FALSE)) for(L.T in c(TRUE,FALSE)) { p. <- pnorm( x, m=m,sd=s, log.p=LOG, lower.tail=L.T) stopifnot(all.equal(p., pnorm(mpfr(x, precBits= 48), m=m,sd=s, log.p=LOG, lower.tail=L.T), tol = 128 * cEps)) stopifnot(all.equal(p., pnorm(mpfr(x, precBits= 60), m=m,sd=s, log.p=LOG, lower.tail=L.T), tol = 2 * cEps)) } cat(".") };cat("\n") proc.time() ## Jerry Lewis - Aug 2, 2019 ## Contrast the results of pnorm with double and mpfr inputs x <- c(1:9, 5*(2:9), 10*(5:20)) ; x <- c(-rev(x), 0, x) pdL <- pnorm(x, log.p=TRUE) pdU <- pnorm(x, log.p=TRUE, lower.tail=FALSE) stopifnot(exprs = { !is.unsorted(x) 35 %in% x x == -rev(x) # exactly pdL == rev(pdU) # even exactly, currently }) mx <- mpfr(x, precBits = 128) pmL <- pnorm(mx, log.p=TRUE) pmU <- pnorm(mx, log.p=TRUE, lower.tail=FALSE) stopifnot(exprs = { pmL < 0 # not true for 'pdL' which underflows pmL == rev(pmU) # even exactly, currently all.equal(pmL, pdL, tol=4e-16) # 'tol=0' shows 4.46e-17 }) ## some explorations : dlp <- diff(log(-pmL))/diff(x) n <- length(x) x.1 <- (x[-1] + x[-n])/2 plot(x.1, dlp, type="b", ylab = "d/dx log(-pnorm(., log=TRUE))"); mtextVersion() plot(x.1[-1], diff(dlp)/diff(x.1), type="b", ylab = "d^2/dx^2 log(-pnorm(., log=TRUE))") stopifnot(exprs = { -1 < (d2 <- diff(dlp)/diff(x.1)) d2 < 0 diff(d2) < 0 }) x.3 <- x.1[-c(1L,n-1L)] plot(x.3, -diff(d2)/ diff(x.1)[-1], type="o", log="y") ### Riemann's Zeta function: ---------------------------------------------------- ## -- integer arguments -- stopifnot(all(mpfrIs0(zeta(-2*(1:100))))) k.neg <- 2*(-100:0) - 1 Z.neg <- zeta(k.neg) plot(k.neg, abs(as.numeric(Z.neg)), type = "l", log="y") Pi <- Const("pi", 128L) ## confirm published value of Euler's gamma to 100 digits pub.g <- paste("0.5772156649", "0153286060", "6512090082", "4024310421", "5933593992", "3598805767", "2348848677", "2677766467", "0936947063", "2917467495", sep="") ## almost = our.g <- Const("gamma", log2(10) * 100) # 100 digits (ff.g <- .mpfr2str(our.g)) M <- function(x) mpfr(x, 128L) stopifnot(all.equal(zeta( 0), -1/2, tol = 2^-100) , all.equal(zeta(-1), -1/M(12), tol = 2^-100) , all.equal(zeta(-3), 1/M(120), tol = 2^-100) ## positive ones : , all.equal(zeta(2), Pi^2/6, tol = 2^-100) , all.equal(zeta(4), Pi^4/90, tol = 2^-100) , all.equal(zeta(6), Pi^6/945, tol = 2^-100) ) ### Exponential Integral Ei(.) curve(Ei, 0,5, n=5001) if(mpfrVersion() >= "3") { ## only available since MPFR 3.0.0 ### Airy function Ai(.) curve(Ai, -10, 5, n=5001); abline(h=0,v=0, col="gray", lty=3) } ### Utilities hypot(), atan2() : -------------------------------------------------------------- ## ======= TODO! ======== ## beta(), lbeta() ## --------------- ## The simplistic "slow" versions: B <- function(a,b) { a <- as(a, "mpfr"); b <- as(b, "mpfr"); gamma(a)*gamma(b) / gamma(a+b) } lB <- function(a,b) { a <- as(a, "mpfr"); b <- as(b, "mpfr"); lgamma(a)+lgamma(b) - lgamma(a+b) } ## For partly *integer* arguments Bi1 <- function(a,b) 1/(a*chooseMpfr(a+b-1, a)) # a must be integer >= 0 Bi2 <- function(a,b) 1/(b*chooseMpfr(a+b-1, b)) # b must be integer >= 0 x <- 1:10 + 0 ; (b10 <- mpfr(x, 128L)) stopifnot(all.equal( B(1,b10), 1/x), all.equal( B(2,b10), 1/(x*(x+1))), all.equal( beta(1,b10), 1/x), all.equal( beta(2,b10), 1/(x*(x+1))), TRUE) if(do.pdf) { dev.off(); pdf("special-fun-beta.pdf") } x <- -10:10 + 0; X <- mpfr(x, 128L) stopifnot(exprs = { Bi1(1,X) == (B1x <- Bi2(X,1)) Bi1(2,X) == (B2x <- Bi2(X,2)) Bi1(3,X) == (B3x <- Bi2(X,3)) all.equal(B1x, 1/x, tol= 4e-16) all.equal(B2x, 1/(x*(x+1)), tol= 8e-16) all.equal(B3x, 2/(x*(x+1)*(x+2)), tol=16e-16) ## these the "poles" are all odd i.e. result in { +Inf / -Inf / NaN} ## are all "ok" {e.g. 1/(x*(x+1)) gives (-Inf, Inf) for x = -1:0 } all.eq.finite(beta(1,X), 1/x) all.eq.finite(beta(X,2), 1/(x*(x+1))) all.eq.finite(beta(3,X), 2/(x*(x+1)*(x+2)), tol=16e-16) }) ## (a,b) *both* integer, one negative: for(i in (-20):(-1)) { cat(i,":\n") a <- mpfr(i, 99) i1 <- i+1 b. <- seq_len(-i1) Bab <- beta(a, b.) stopifnot(is.nan(beta(a, (i1:0))), is.nan(lbeta(a, (i1:0))), all.equal(Bab, Bi2(a, b.), tol=1e-20), all.equal(lbeta(a, b.), log(abs(Bab)), tol=1e-20), allow.logical0 = TRUE) } ## (a,b) all positive c10 <- b10 + 0.25 for(a in c(0.1, 1, 1.5, 2, 20)) { stopifnot(all.equal( B(a,b10), (bb <- beta(a, b10))), all.equal(lB(a,b10), (lb <- lbeta(a, b10))), all.equal(lb, log(bb)), all.equal( B(a,c10), (bb <- beta(a, c10))), all.equal(lB(a,c10), (lb <- lbeta(a, c10))), all.equal(lb, log(bb)), TRUE) } ## However, the speedup is *not* much (50%) when applied to vectors: stopifnot(validObject(xx <- outer(b10, runif(20))), dim(xx) == c(length(b10), 20), validObject(vx <- as(xx, "mpfr")), class(vx) == "mpfr", is.null(dim(vx))) C1 <- replicate(10, system.time(bb <<- beta(vx, vx+2))) C2 <- replicate(10, system.time(b2 <<- B(vx, vx+2))) summary(1000*C1[1,]) ## 13 (lynne 2023) 80.3 {cmath-5, 2009} summary(1000*C2[1,]) ## 18 " 125.1 { " } stopifnot(all.equal(bb, b2)) ## and for a single number, the speedup is a factor 3: x1 <- vx[1]; x2 <- x1+2 system.time(for(i in 1:100) bb <- beta(x1, x2))# .056 was .27 system.time(for(i in 1:100) b2 <- B(x1, x2))# .129 was .83 ## a+b is integer <= 0, but a and b are not integer: a <- b <- .5 + -10:10 ab <- data.matrix(expand.grid(a=a, b=b, KEEP.OUT.ATTRS=FALSE)) ab <- mpfr(ab[rowSums(ab) <= 0, ], precBits = 128) stopifnot( beta(ab[,"a"], ab[,"b"]) == 0, lbeta(ab[,"a"], ab[,"b"]) == -Inf) ## was NaN in Rmpfr <= 0.5-2 stopifnot(all.equal(6 * beta(mpfr(1:3,99), -3.), c(-2,1,-2), tol=1e-20)) ## add more checks, notably for b (> 0) above and below the "large_b" in ## ../src/utils.c : bb <- beta(mpfr(1:23, 128), -23) stopifnot(all.equal(bb, Bi1(1:23, -23), tol=1e-7)) # Bi1() does not get high prec for small b ## can be written via rationals: N / D : bn <- c(330, -360, 468, -728, 1365, -3120, 8840, -31824, 151164, -1007760, 10581480, -232792560) bn <- c(rev(bn[-1]), bn) bd <- 24* as.bigz(2 * 3 * 5 * 7 * 11) * 13 * 17 * 19 * 23 stopifnot(all.equal(bb, as(bn/bd,"mpfr"), tol=0)) stopifnot(all.equal(6 * beta(mpfr(1:3, 99), -3.), c(-2,1,-2), tol=1e-20), all.equal( lbeta(mpfr(1:3, 128), -3.), log(mpfr(c( 2,1, 2), 128) / 6), tol=1e-20)) ## add more checks, notably for b (> 0) above and below the "large_b" in ## ../src/utils.c : bb <- beta(mpfr(1:23, 128), -23) stopifnot(all.equal(bb, Bi1(1:23, -23), tol=1e-7)) # Bi1() does not get high prec for small b ## can be written via rationals: N / D : bn <- c(330, -360, 468, -728, 1365, -3120, 8840, -31824, 151164, -1007760, 10581480, -232792560) bn <- c(rev(bn[-1]), bn) bd <- 24* as.bigz(2 * 3 * 5 * 7 * 11) * 13 * 17 * 19 * 23 stopifnot(all.equal(bb, as(bn/bd,"mpfr"), tol=0)) ## 2) add check for 'b' > maximal unsigned int {so C code uses different branch} two <- mpfr(2, 128) for(b in list(mpfr(9, 128), mpfr(5, 128)^10, two^25, two^26, two^100)) { a <- -(b+ (1:7)) stopifnot(a+b == -(1:7), # just ensuring that there was no cancellation is.finite( B <- beta(a,b)), ## was NaN .. is.finite(lB <- lbeta(a,b)), ## ditto all.equal(log(abs(B)), lB), TRUE) } ee <- c(10:145, 5*(30:59), 10*(30:39), 25*(16:30)) b <- mpfr(2, precBits = 10 + max(ee))^ee # enough precision {now "automatic"} stopifnot((b+4)-b == 4, # <==> enough precision above b == (b. <- as(as(b,"bigz"),"mpfr"))) (pp <- getPrec(b.))# shows why b. is not *identical* to b. system.time(Bb <- beta(-b-4, b))# 0.334 sec if(dev.interactive()) plot(ee, asNumeric(log(Bb)), type="o",col=2) lb <- asNumeric(log(Bb)) ## using coef(lm(lb ~ ee)) stopifnot(all.equal(lb, 3.175933 -3.46571851*ee, tol = 1e-5))# 4.254666 e-6 bb <- beta( 1:4, mpfr(2,99)) stopifnot(identical(bb, beta(mpfr(2,99), 1:4)), all.equal((2*bb)*cumsum(1:4), rep(1, 4), tol=1e-20), getPrec(bb) == 128) ##-- The d*() density functions from ../R/special-fun.R | ../man/distr-etc.Rd --- if(do.pdf) { dev.off(); pdf("special-fun-density.pdf") } dx <- 1400+ 0:10 mx <- mpfr(dx, 120) nx <- sort(c(c(-32:32)/2, 50*(-8:8))) xL <- 2^(989+(0:139)/4) # "close" to double.xmax dnbD <- dnbinom(xL, prob=1-1/4096, size=1e307, log=TRUE)# R's own iF <- -(130:140) # index of finite dnbD[] dnbx8 <- dnbinom(xL, prob=1-mpfr(2, 2^ 8)^-12, size=1e307, log=TRUE) dnbx10 <- dnbinom(xL, prob=1-mpfr(2, 2^10)^-12, size=1e307, log=TRUE) dnbx13 <- dnbinom(xL, prob=1-mpfr(2, 2^13)^-12, size=1e307, log=TRUE) stopifnot(exprs = { all.equal(dpois(dx, 1000), dpois(mx, 1000), tol = 3e-13) # 64b Lnx: 7.369e-14 all.equal(dbinom(0:16, 16, pr = 4 / 5), dbinom(0:16, 16, pr = 4/mpfr(5, 128)) -> db, tol = 5e-15)# 64b Lnx: 4.3e-16 all.equal(dnorm( -3:3, m=10, s=1/4), dnorm(mpfr(-3:3, 128), m=10, s=1/4), tol = 1e-15) # 64b Lnx: 6.45e-17 all.equal(dnorm(nx), dnorm(mpfr(nx, 99)), tol = 1e-15) all.equal(dnorm( nx, m = 4, s = 1/4), dnorm(mpfr(nx, 99), m = 4, s = 1/4), tol = 1e-15) all.equal(dnorm( nx, m = -10, s = 1/4, log=TRUE), dnorm(mpfr(nx, 99), m = -10, s = 1/4, log=TRUE), tol = 1e-15) ## t-distrib. : all.equal(dt(nx, df=3), dt(mpfr(nx, 99), df=3), tol = 1e-15) all.equal(dt( nx, df = 0.75), dt(mpfr(nx, 99), df = 0.75), tol = 1e-15) all.equal(dt( nx, df = 2.5, log=TRUE), dt(mpfr(nx, 99), df = 2.5, log=TRUE), tol = 1e-15) ## negative binomial dnbinom(): all.equal(dnbx13, dnbx10, tol = 2^-999) # see 2^-1007, but not 2^-1008 all.equal(dnbx13, dnbx8, tol = 2^-238) # see 2^-239, but not 2^-240 all.equal(dnbx10[iF], dnbD[iF], tol = 6e-16) # R's *is* accurate here (seen 2.9e-16) }) ## plot dt() "error" of R's implementation nx <- seq(-100, 100, by=1/8) dtd <- dt( nx, df= .75) dtM <- dt(mpfr(nx, 256), df= .75) if(doExtras) withAutoprint({ system.time( dtMx <- dt(mpfr(nx, 2048), df= .75) ) # 2.5 sec stopifnot(all.equal(dtMx, dtM, tol = 2^-254)) # almost all of dtM's 256 bits are correct }) relE <- asNumeric(dtd/dtM - 1) plot(relE ~ nx, type="l", col=2); mtextVersion() plot(abs(relE) ~ nx, type="l", col=2, log="y", ylim=c(5e-17, 1.5e-15)) ## ============== even smaller 'df' such that lgamma1p(df) is better than lgamma(1+df) ==== require(sfsmisc)# -> eaxis(); relErrV() u <- sort(outer(10^-(20:1), c(1,2,5))) # *not* "exact" on purpose ## .. unfinished .. exploring *when* dt() would suffer from inaccurate stirlerr() -- would it? nu <- 2^-(70:1) dt10 <- dt( 10, df=nu) dt10M <- dt(mpfr(10, 1024), df=nu) re10 <- asNumeric(relErrV(dt10M, dt10)) plot(re10 ~ nu, type="l", lwd=2, log="x", main = quote(rel.Err( dt(10, df==nu) )), xaxt="n"); eaxis(1, nintLog=20) mtextVersion() abline(h = (-1:1)*2^-53, lty=4, col=adjustcolor("blue", 1/2)) plot(abs(re10) ~ nu, type="l", lwd=2, log="xy", xlab = quote(df == nu), ylab = quote(abs(relE)), main = quote(abs(rel.Err( dt(10, df==nu) ))), xaxt="n", yaxt="n") eaxis(1, nintLog=20); eaxis(2); drawEps.h() x0 <- c(0, 10^(-5:10)) # only >= 0 should be sufficient; x0 <- c(-rev(x0),0,x0) stopifnot(!is.unsorted(nu), # just for plotting .. !is.unsorted(x0)) xnu <- expand.grid(x=x0, df=nu) dt2 <- with(xnu, dt( x, df=df)) dtM2 <- with(xnu, dt(mpfr(x, 512), df=df)) str(relE2 <- `attributes<-`(asNumeric(relErrV(dtM2, dt2)), attr(xnu, "out.attrs"))) ## consistency check that with() etc was fine: stopifnot(identical(re10, unname(relE2[which(x0 == 10), ]))) filled.contour(x=log10(1e-7+x0), y=log10(nu), z = relE2) filled.contour(x=log10(1e-7+x0), y=log10(nu), z = abs(relE2)) ## around nu = 10^-16 is the most critical place (pch <- c(1L:9L, 0L, letters, LETTERS)[1:ncol(relE2)]) matplot(x0+1e-7, relE2, type="b", log="x", main="rel.err{ dt(x, df=df) }") legend("topright", legend = paste0("df=",formatC(nu,wid=3)), ncol=7, bty="n", lwd=1, pch=pch, col=1:6, lty=1:5, cex = 0.8) abline(h = c(-4:4)*2^-53, lty=3, col="gray") matplot(nu, t(relE2), type="b", log="x", main="rel.err{ dt(x, df=df) }") legend("topright", legend = paste0("x=",formatC(x0,wid=3)), ncol=7, bty="n", lwd=1, pch=pch, col=1:6, lty=1:5, cex = 0.8) abline(h = c(-4:4)*2^-53, lty=3, col="gray") matplot(nu, pmax(abs(t(relE2)), 1e-19), type="b", log="xy", axes=FALSE, ylab = quote(abs("rel Err")), ylim = c(7e-17, max(abs(relE2))), main="|rel.err{ dt(x, df=df)}|") eaxis(1, nintLog=22) ; eaxis(2, line=-1/2); drawEps.h() legend("topright", legend = paste0("x=",formatC(x0,wid=3)), ncol=7, bty="n", lwd=1, pch=pch, col=1:6, lty=1:5, cex = 0.8) 1 ## dnbinom() -- has mode as expected, but with huge size, the scales are "off reality" .. ### ..... TODO ! ##--> >>>>>>>> ./special-fun-dgamma.R <<< (was here originally) cat('Time elapsed: ', proc.time(),'\n') # "stats" if(!interactive()) warnings() Rmpfr/tests/special-fun-dgamma.R0000644000176200001440000001645514605310267016276 0ustar liggesusers### dgamma(): ----------------------- was part of ./special-fun-ex.R ------------------- stopifnot(require("Rmpfr")) require(sfsmisc)# -> eaxis(); relErrV() (doExtras <- Rmpfr:::doExtras()) options(nwarnings = 50000, width = 99) ## vvvvvvvvvvvvvvvv ## to enhance |rel.Err| plots: from ./special-fun-ex.R, also in ~/R/Pkgs/DPQ/tests/pow-tst.R } drawEps.h <- function(p2 = -(53:51), side = 4, lty=3, lwd=2, col=adjustcolor(2, 1/2)) { abline(h = 2^p2, lty=lty, lwd=lwd, col=col) axis(side, las=2, line=-1, at = 2^p2, labels = as.expression(lapply(p2, function(p) substitute(2^E, list(E=p)))), col.axis = col, col=NA, col.ticks=NA) } (do.pdf <- !dev.interactive(orNone = TRUE)) if(do.pdf) pdf("special-fun-dgamma.pdf") xe <- c(-2e5, -1e5, -2e4, -1e4, -2000, -1000, -500, -200, -100, -50, -20, -10) (xe <- c(xe, -8:8, -rev(xe))) two <- mpfr(2, 256) ## For centering at E[.], will use xP(x, shp) : xP <- function(x, d) { ## cannot eliminate them, as for they are all finite .. ## x <- x[is.finite(x)] x - d*(x > d) } aEQformat <- function(xy, ...) format(xy, digits = 7, ...) allEQ_0 <- function (target, current, ...) all.equal(target, current, tolerance = 0, formatFUN = aEQformat, ...) stopIfNot <- if("allow.logical0" %in% names(formals(stopifnot))) { # experimental (MM only) stopifnot } else function(exprs, allow.logical0) stopifnot(exprs=exprs) abs19 <- function(r) pmax(abs(r), 1e-19) # cut |err| to positive {for log-plots} for(shp in 2^c(-20, -3, -1:1, 4, 10, 14, 20, 50)) { cat("shape = 2^", log2(shp), ":\n-------------\n") d.dg <- dgamma(xP(2 ^ xe, shp) -> x, shape=shp) m.dg <- dgamma(xP(two^xe, shp), shape=shp) m.ldg <- dgamma(xP(two^xe, shp), shape=shp, log=TRUE) relE <- asNumeric(relErrV(m.dg, d.dg)) ## Plots: do *not* observe any problems yet plot(x, relE, log="x", type="l", main = paste0("rel.Errors dgamma(., shape = 2^", log2(shp),")")) abline(h=0, col=adjustcolor("gray10", 1/2), lty=3, lwd=2) plot(x, abs19(relE), log="xy", type="l", ylim = pmax(4e-17, range(abs19(relE), finite=TRUE))) abline(h = 2^-(52:50), col=adjustcolor("red4",1/2), lty=3) ## stopIfNot(exprs = { !is.unsorted(xe) is.finite(m.dg) m.dg >= 0 shp > 1 || all(diff(m.dg) <= 0) shp > 100|| all((m.dg > 0) >= (d.dg > 0)) any(fin.d <- is.finite(d.dg)) m.dg[!fin.d] > 1e300 { cat("all.EQ(, ):", allEQ_0 (m.dg[fin.d], d.dg[fin.d]), "\n") shp > 100 || all.equal(m.dg[fin.d], d.dg[fin.d], tol = 1e-13) # 2.063241e-14 } ## compare with log scale : if(any(pos.d <- m.dg > 0)) { cat("For non-0 -values; all.EQ(log(d), d*(log)):", allEQ_0 (log(m.dg[pos.d]), m.ldg[pos.d]),"\n") ## all.equal(log(m.dg[pos.d]), m.ldg[pos.d], tol = 1e-14) } else TRUE })#, allow.logical0 = TRUE) } ## NB: dgamma(x, sh) sh >= 1 calls ## -- dpois_raw(sh-1, x) which then ## adds stirlerr(x.) to bd0(x., lambda) ; where x. <- sh-1; lambda <- x ## bd0(x,L) ~= 0 iff x ~= L <==> sh-1 ~= x <==> x+1 ~= sh sh2x_gamma <- function(sh, nx, k = 12, f1 = 0.5, f2 = 1.25) { stopifnot(is.numeric(sh), length(sh) == 1, sh >= 0, length(k) == 1, k >= 3, f1 < f2, length(f1) == length(f2), length(f2) == 1) p2 <- 2^-(k:3) 1 + sh* unique(sort(c(1-p2, 1, 1+p2, # <- values x very close to sh -- does *not* make any diff (????) seq(f1, f2, length=nx)))) } relEgamma <- function(sh, nx = 1001, k = 12, precBits = 256, x = sh2x_gamma(sh, nx=nx, k=k)) { dg <- dgamma(x, sh) dgM <- dgamma(mpfr(x, precBits), mpfr(sh, precBits)) structure(cbind(x, relE = asNumeric(relErrV(dgM, dg))), shape=sh) } shs <- 1/32 + seq(6, 16, by = 1/8) stopifnot(all(!is.whole(shs*2))) # shs are *not* half-integers system.time( LrelE <- lapply(shs, relEgamma) ) # 7.5 sec m.relE <- sapply(LrelE, function(m) m[,"relE"]) qrelE <- t(apply(abs(m.relE), 2, quantile, probs = c(.05, .25, .50, .75, .90, 1))) ## ^^^^^^^^^^^ ## Heureka! --- this shows quite a difference between R 4.3.3 and R-devel (R 4.4.0) !! iS <- sort.list(qrelE[,"50%"], decreasing = TRUE) cbind(shs, qrelE)[iS,] ## For R 4.3.3 : ## shs 5% 25% 50% 75% 90% 100% ## 14.53125 9.410630e-15 9.815160e-15 1.023178e-14 1.065722e-14 1.092232e-14 1.138372e-14 ## 15.03125 8.265317e-15 8.702900e-15 9.086072e-15 9.506915e-15 9.756106e-15 1.007928e-14 ## 15.90625 6.799207e-15 7.137733e-15 7.611360e-15 8.057580e-15 8.343992e-15 8.670817e-15 ## 13.53125 6.716182e-15 7.103502e-15 7.566360e-15 8.004966e-15 8.276645e-15 8.630780e-15 ## 15.65625 6.031124e-15 6.389848e-15 6.803347e-15 7.261310e-15 7.527491e-15 8.031559e-15 ## .......... ## .......... myRversion <- paste(R.version.string, "--", osVersion) if((mach <- Sys.info()[["machine"]]) != "x86_64") myRversion <- paste0(myRversion, "_", mach) if(!capabilities("long.double")) myRversion <- paste0(myRversion, "_no_LDbl") myRversion rngP <- function(y, M = 1e-14) { yr <- range(y); if(yr[2] < M) yr[2] <- M; yr } boxplot(abs19(m.relE), at = shs, log="y", ylim = c(7e-17, rngP(abs(m.relE))[2]), yaxt="n") eaxis(2); drawEps.h(); mtext(myRversion, adj=1, cex=3/4) matplot(shs, qrelE, type="l", log="y", yaxt="n", ylim = rngP(qrelE)) title("|relErr( dgamma(x, sh) | for x / sh in [.5, 1.25]") eaxis(2); drawEps.h(); mtext(myRversion, adj=1, cex=3/4) ## take *one* of these: plot(abs(m.relE[, shs == 14.53125]), type="l", log="y", ylim = c(1e-16, 1.5e-14)) drawEps.h() sh <- 14.53125 stopifnot(identical(sh, 465 / 32)) x14.5 <- sh2x_gamma(sh, nx = 21) # 21 points xM <- mpfr(x14.5, 512) dg1 <- stats::dgamma(x14.5, sh) dgM <- Rmpfr::dgamma(xM, sh) cbind(x14.5, relE = asNumeric(relErrV(dgM, dg1))) # very "constant" ~=~ - 1e-14 # in R-devel around 1e-16 !! ## try easier x: sh <- 14.53125 ; stopifnot(identical(sh, 465 / 32)) x0 <- 1/4 + 8:20 xM <- mpfr(x0, 512) dg1 <- stats::dgamma(x0, sh) dgM <- Rmpfr::dgamma(xM, sh) relE <- asNumeric(relErrV(dgM, dg1)) signif(cbind(x0, relE, abs(relE)), 4) # R <= 4.3.*: very "constant" ~=~ - 1e-14 ## R-devel: | no-long-double == *same* numbers ## x0 relE | relE ## 8.25 1.276e-16 1.276e-16 | 1.276e-16 1.276e-16 ## 9.25 1.294e-16 1.294e-16 | 1.294e-16 1.294e-16 ## 10.25 -1.408e-16 1.408e-16 | -1.408e-16 1.408e-16 ## 11.25 -2.108e-17 2.108e-17 | -2.108e-17 2.108e-17 ## 12.25 -1.306e-17 1.306e-17 | -1.306e-17 1.306e-17 ## 13.25 1.464e-16 1.464e-16 | 1.464e-16 1.464e-16 ## 14.25 -8.908e-17 8.908e-17 | -8.908e-17 8.908e-17 ## 15.25 -5.852e-18 5.852e-18 | -5.852e-18 5.852e-18 ## 16.25 -3.029e-17 3.029e-17 | -3.029e-17 3.029e-17 ## 17.25 1.900e-16 1.900e-16 | 1.900e-16 1.900e-16 ## 18.25 -1.511e-17 1.511e-17 | -1.511e-17 1.511e-17 ## 19.25 -5.779e-17 5.779e-17 | -5.779e-17 5.779e-17 ## 20.25 1.848e-16 1.848e-16 | 1.848e-16 1.848e-16 if(getRversion() >= "4.4.0") # *not* true for R <= 4.3.3 : stopifnot(abs(relE) < 4e-16) # seen max = 1.900e-16 cat('Time elapsed: ', proc.time(),'\n') # "stats" if(!interactive()) warnings() Rmpfr/tests/create.R0000644000176200001440000001273114552770112014100 0ustar liggesusersrequire("Rmpfr") ### Simple basic examples of creation of "mpfr" objects pi. <- Const("pi", prec = 260) pi. # nicely prints 80 digits [260 * log10(2) ~= 78.3 ~ 80] ## These both failed (in mpfr2str(.)) with a seg.fault: c(mpfr(1, prec=3), pi.) m0 <- mpfr(numeric(), prec=64) ## print()ing / str() of 0-length mpfr stopifnot( grepl("0 'mpfr' numbers", capture.output( m0)), grepl("0 'mpfr' numbers", capture.output(str(m0)))) c(m0,m0) # failed in Rmpfr <= 0.6-0 stopifnot(identical(c(m0,m0), m0), identical(c(m0,pi.), pi.), identical(c(pi.,m0), pi.)) ## This is TRUE for 0 and -0 : Zero <- mpfr(c(0,1/-Inf), 20) stopifnot(mpfrIs0(Zero), is.whole(Zero)) stopifnot(mpfr.is.0(Zero))# deprecated but must work stopifnot(mpfr.is.integer(Zero))# deprecated but must work Zero # the "-0" should print correctly stopifnot(.getSign(Zero) == c(1,-1), sign(Zero) == 0, identical(format(Zero, digits=1), c("0.", "-0."))) ## testing 'recycling' b <- c(20,120,80, 60) (x <- mpfr(2^-(5:7), precBits = b)) d.spec <- c(0,NA,NaN,Inf,-Inf) (spec <- mpfr(d.spec, 3)) stopifnot(length(x) == 4, x[1] == x[4], getPrec(x) == b, identical(is.na(spec), is.na(d.spec)), identical(is.finite(spec), is.finite(d.spec)), identical(is.infinite(spec), is.infinite(d.spec)), ## mpfr(, .) : identical(x, mpfr(x, getPrec(x))), identical(spec, mpfr(spec, getPrec(spec))), asNumeric(1/mpfr(x, 16)) == 2^c(5:7,5), identical(format(spec), c("0.", "NaN", "NaN", "Inf", "-Inf")), mpfr(0.2, prec = 5:15, rnd.mode = "D") < 0.2) B.set <- setNames(2:62, paste0("B=",2:62)) str(lapply(B.set, function(B) format(spec, base= B)))# "0.0" and "0.00" -- FIXME t2 <- mpfr(2^10,3) ## digits = 1 used to crash: MPFR assertion failed: m >= 2 || ((((b) & ((b) - 1)) == 0) == 0 && m >= 1) ## ---------- (+ seg.fault) for 'base = 2' (and others, not for default base = 10), ## digits = NULL should choose "enough" ... but does not str(r <- lapply(B.set, function(B) .mpfr2str(t2, digits=1, base = B))) str(r. <- lapply(B.set, function(B) .mpfr2str(t2, base = B))) ## FIXME: still too short x <- c(-12, 1:3 * pi) sss <- mpfr(x, 100) validObject(sss) sss sss2 <- sss * sss stopifnot(identical(sss2, sss * x), identical(sss2, x * sss), sss ^ 2 == sss2) ## and go back {not sure if identical() is guaranteed here, but it seems...}: stopifnot(identical(x, as(sss, "numeric"))) (cs <- as(sss, "character")) y <- c(0, 100,-10, 1.25, -2.5, x * c(1,100,1e5,1e20), x / 100^(1:4)) (Y <- mpfr(y, 100)) cbind(y, as.data.frame(.mpfr2str(Y, 20))[,c("exp","str")]) s <- mpfr(43208, 14)# low precision eps8 <- 8 * .Machine$double.eps ## checking mpfr -> character -> mpfr: i1..5f <- c("4.e+4", "4.3e+4", "4.32e+4", "43210.", "43208.") stopifnot(exprs = { all.equal(y, as.numeric(format(Y, digits=20)), tol= eps8) all.equal(Y, as(format(Y), "mpfr"), tol= eps8) identical(sapply(1:5, formatMpfr, x=s), i1..5f) identical(sapply(1:5, formatMpfr, x=s, exponent.plus=FALSE), sub("e[+]", "e", i1..5f)) }) ## More character -> mpfr checking : ## from echo 'scale=200; 4*a(1)' | bc -l : cpi <- "3.14159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196" pi. <- Const("pi", prec=667) stopifnot(cpi == format(mpfr(cpi, prec=667), digits=201), all.equal(pi., as(cpi, "mpfr")), all.equal(pi., as(cpi, "mpfr"), tol = 1e-200)) set.seed(17) ## Check double -> mpfr -> character -> double : ## Unfortunately, format(, .) -> .mpfr2str() triggers a memory bug ## that I think is an MPFR library "mis-feature" ## 2011-02-09 -- bug *no longer* triggered ! rSign <- function(n) sample(c(-1,1), size = n, replace=TRUE) N <- function(x) as.numeric(x) ntry <- if(Sys.getenv("USER") == "maechler") 150 else 5 for(n in 1:ntry) { cat(if(n %% 10)"." else n) x. <- rSign(100) * rlnorm(100) prec <- rpois(1, 110); digs <- floor(0.95*(prec / log2(10))) X. <- mpfr(x., precBits = prec) stopifnot(all.equal(x., N(format(X., digits=digs)), tol = eps8) , all.equal(x., N(log(exp(X.))), tol = 32*eps8) ) }; cat("\n") stopifnot(identical(mpfr.is.0(X.),# deprecated but must work mpfrIs0 (X.))) X. <- X.[!mpfrIs0(X.)] stopifnot(all( X./X. == 1)) # TRUE u <- mpfr(as.raw(0:100)) z <- mpfr(1:12, 200) z[z > 100] <- 100 # nothing done (but used to fail) z[] <- 0 stopifnot(0:100 == u, is(z,"mpfr"), mpfrIs0(z), all.equal(u, mpfr(0:100, prec = 8), tol = 0), 0:1 == mpfr(1:2 %% 2 == 0)) z[3] <- Const("pi",200) ## z has length 12 -- now extend it: z[15:17] <- 1/mpfr(10:12, 100) stopifnot(all.equal(z[1:4], c(0,0,pi,0), tol = 1e-15), validObject(z), all.equal(z[13:17], c(NaN,NaN, 1/(10:12)), tol = 1e-15)) ## These seg.faulted (each via different R -> C interface) in the past: assertError <- tools::assertError assertError( pp <- Const("pi", prec = 1e11) ) assertError( mpfr("123.456", precBits= 1e11) ) assertError( mpfr(as.bigz(3), precBits= 1e11) ) stopifnot(identical(mpfr(NULL), mpfr(logical()))) ## mpfr --> bigInteger "bigz" Pi <- Const("pi", prec = 300) twoP <- mpfr(2, 100)^(-2:80) m <- Pi * twoP L <- mpfr(2, 256)^1000 stopifnot(exprs = { .mpfr2bigz(Pi) == 3 .mpfr2bigz(twoP) == as.bigz(c(0,0, 2^(0:80))) .mpfr2bigz(m) == floor(m) .mpfr2bigz(m / L) == 0 .mpfr2bigz(m * L) == floor(m * L) ## used to fail .mpfr2bigz(m * L^8) == floor(m * L^8) ## (ditto) }) Rmpfr/tests/bit-repr.R0000644000176200001440000001031013220705115014340 0ustar liggesusersstopifnot(suppressPackageStartupMessages(require("Rmpfr"))) ## (checking that the 32 / 64 bit GMP message does *not* show here) ### Try to look at the internal bit-representation of the limbs .limbs <- function(x) { stopifnot(is(x, "mpfr")) lapply(x@.Data, slot, "d") # not sapply() each can have different prec. & #{limbs} } .expo <- function(x) { stopifnot(is(x, "mpfr")) sapply(x@.Data, slot, "exp") } Bits <- function(x) { L <- .limbs(x)# list(length n) each of "k(prec)" 32-bit ints ## NB: mpfr(2, .) and all mpfr(2^k, .) also have a 'd' ending in NA integer! ## [reason: after all, R's NA_integer_ is INT_MAX+1 = 2^31 ] ## and the mpfr(c(NA,NaN, Inf, -Inf), .) have *no* NA in 'd' (but all in 'exp'! ## see .mpfr2list() example below hasNA <- any(iNA <- sapply(lapply(L, is.na), any)) # iNA: TRUE if there's an NA ## need to catch them later CC <- function(ch) paste(ch, collapse="") hex <- sapply(L, function(.) CC(sprintf("%x", rev(.)))) if(hasNA) hex[iNA] <- NA_character_ hex <- strsplit(hex, NULL) db <- t(expand.grid(0:1,0:1,0:1,0:1, KEEP.OUT.ATTRS=FALSE)[,4:1]) storage.mode(db) <- "character" # "0" or "1" dimnames(db) <- list(NULL, c(paste(0:9), letters[1:6])) ## db is 4 x 16 matrix with col.names "0" "1" .. "9" "a" "b" ... "f" ex <- .expo(x) if(is.matrix(ex)) { ## 64-bit case: exponent is long == two ints ## ----------- the 2nd int is in {0, -1, NA} (NA : for 0) ex2 <- ex[2,] ex <- ex[1,] } pat <- paste("(", sapply(pmax(0, ex), function(n) CC(rep.int(".", n))), ")0+$", sep="") ## pat <- ifelse(iNA, NA_character_, pat) getbits <- function(ch) CC(as.vector(db[,ch])) ## drop trailing zeros (from r[[i]], via pat[i]), keeping correct number: drop0.r <- function(i) sub(pat[i], "\\1", r[[i]]) if(hasNA) { r <- as.list(iNA) r[!iNA] <- lapply(hex[!iNA], getbits) r[!iNA] <- lapply(which(!iNA), drop0.r) ## FIXME this is wrong -- really have powers of 2, and want their (easy) bits : r[iNA ] <- NA_character_ unlist(r) } else { r <- lapply(hex, getbits) sapply(seq_along(r), drop0.r) } } x <- mpfr(r <- c(NA,NaN, Inf, -Inf), 64) stopifnot(identical(asNumeric(x), # mpfr has no NA, just NaN's: c(NaN,NaN, Inf, -Inf)), identical(as.character(fDec <- formatDec(x)), as.character(asNumeric(x))) # of different nchar() for now ) formatDec(x) # should print fine (no quotes) if(FALSE) # platform dependent: ## The "non-finite" mpfr value internals (in 64-bit: 'exp' has NA): str(.mpfr2list(x)) ## bug in Bits(): all (exact) powers of 2 will show as NA: x <- mpfr(c(3:5,11:16, 59, 125:128, 1024:1025), 64) x data.frame(x= as.numeric(x), I(Bits(x))) x <- mpfr(c(-20:-1, 1:30),64)# w/o 0 - as its mantissa is "random" (in 64-bit) data.frame(x= as.numeric(x), I(Bits(x))) b0 <- Bits(mpfr(0, 64)) # not printing it here -- they are "random" for this special case! (half <- mpfr(0.5, 64)*(1 + mpfr(2, 64)^-16 * (-3:3))) Bits(half) ## pi, in varying number of bits : p. <- round(pi* 2^c(10,16,5*(4:8))) dput(p.)#-> the definition of p : p <- mpfr(c(3217, 205887, 3294199, 105414357, 3373259426, 107944301636, 3454217652358), 64) stopifnot(all.equal(p., p, tolerance = 1e-15)) ## all the mantissas are those of pi, rounded differently: Bits(c(p, Const("pi", 64))) ###--- and possibly the _internal_ sprintfMpfr() --- see also ./tstHexBin.R ## TODO: use examples above for checking formatBin() <---> ============ spr <- Rmpfr:::sprintfMpfr ##= ~~~~~~~~~~~ (fB.04 <- formatBin(i16.04 <- mpfr(0:16, 4))) (fB.60 <- formatBin(i16.60 <- mpfr(0:16, 60))) stopifnot( identical(sub("00p","p", spr(i16.60, bits = 10)), spr(i16.60, bits = 4)), identical(spr(i16.60, bits = 4), spr(i16.04, bits = 4)) , all.equal(i16.04, mpfr(fB.04), tolerance = 0) , all.equal(i16.60, mpfr(fB.60), tolerance = 0) ) ## not even this one two <- mpfr(2, precBits = 60) stopifnot(identical(two, mpfr(formatBin(two)))) cat('Time elapsed: ', proc.time(),'\n') # "stats" if(!interactive()) warnings() Rmpfr/.Rinstignore0000644000176200001440000000002211776116354013651 0ustar liggesusersinst/doc/Makefile Rmpfr/MD50000644000176200001440000001251615077606366011675 0ustar liggesusers0b5984091a73dc9f4f47019c39d8860f *ChangeLog 6ad4aa4bc23dab94968a9cd17126e132 *DESCRIPTION e2094a6af4937790382653db1f6c355f *NAMESPACE 7e831af360f53300e2164234ced5ff36 *R/AllClasses.R a9b1cf4ae85149ce3b63dca1fda41645 *R/Arith.R af49ae22a3abb7623dda7f03d3210404 *R/Consts.R 72e40cfdbc1d6317f76a0f14276f4c04 *R/Math.R f33439938db1458476c1d0059ab68519 *R/Summary.R a2a7845e101259cbeb9dd91bba0a196d *R/array.R 38c771ad5da1f7490cea386cb6024e9a *R/as.R 69a7ec9c3b497dc0b1056ee4acb2d03e *R/formatHex.R c107b319eda239f1aa67f72d3eac0d11 *R/gmp-convert.R db13b4c1aa1fe454796ccd137f47df10 *R/hjk.R 9fa5c27a196f7ed45ab20d42796cff0e *R/integrate-Romberg.R 97a6248ebd539f6622bbc8f81698be04 *R/mpfr.R c03fa36a103dafa851e2ba55a80aa9d1 *R/optimizers.R de6cf54acc6f8f8913a181e68dafeed8 *R/special-fun.R f42559cfe95d168afeac7a8d53b5dfa5 *R/unirootR.R cdd3f87c191a69a297eace37919cb1b1 *R/zzz.R 9af43e4aadaee883c22b38917ce2dc12 *README.md a46774f719bfe0191ac1900eea153736 *TODO 8973d5c105de6edeb710f745328e8264 *build/partial.rdb 8b875d9febdd888c1e35a776e1dfab7c *build/vignette.rds 7a8f73c9e4e8290acfebf88dc9dee713 *cleanup 8da001ce1b225bf755b427e26132804a *cleanup.win 0c39797749061efeeee1aa350ff41968 *configure df6f1ccb580aefd40ffedff9f191bcc3 *configure.ac 4a8f3a18ff6461fac011331d909c3b1b *configure.win 9e1c8d825bd0b9cb799e9dea92c672b7 *demo/00Index da3fe1f9afd8af15f7f8c2291231501c *demo/hjkMpfr.R d1c983e95692fd67f4c0f93be7c6ec58 *inst/NEWS.Rd 587b6767ddb29e687006d8dd425e920f *inst/check-tools.R 167db203ff72ac5de5263a7f99f4c399 *inst/doc/Maechler_useR_2011-abstr.R ca4d6c443c917a2b41766aa538ac5987 *inst/doc/Maechler_useR_2011-abstr.Rnw c37f5b903cea0d39833673feb74d887b *inst/doc/Maechler_useR_2011-abstr.pdf 0ca5c84debbabe691d0bb3be74e7c3e3 *inst/doc/Rmpfr-pkg.R e445ed0eb9d6f2cb9b5c22f9c14e6d87 *inst/doc/Rmpfr-pkg.Rnw 46b7e706149c1888f908d54f24a58545 *inst/doc/Rmpfr-pkg.pdf 3291df1b02b765417c0c756cf8a41c7e *inst/doc/log1mexp-note.R 2ee39564c6d2a048c36bdc7ea7e9d8ab *inst/doc/log1mexp-note.Rnw ff0023eedae9badc2b0624e67d045cd2 *inst/doc/log1mexp-note.pdf 4969601c85fa6a68b131ff5cbbcda659 *man/Bernoulli.Rd 5d1adcbf216d265846e5542b2212f5fd *man/Bessel_mpfr.Rd e66c83bf74d08c17c71abe49562f440b *man/Mnumber-class.Rd bb52e7424766e0991bbdcfc16c886f4c *man/Rmpfr-package.Rd fd1d85813d46057a45575f90a0ada621 *man/array_or_vector-class.Rd 4219f4788af4e18d27f6cb6f740feaf5 *man/asNumeric-methods.Rd 3e6d56e249fb31f49872b9a4f1cf1fe9 *man/atomicVector-class.Rd 19f32c5f9eef2127ad8d109d7716af7a *man/base-copies.Rd 87174bdb2d3b14d4ff7c71ee68ed0a4c *man/bind-methods.Rd 51aafe1d6e1f9f44966c17330ede8caf *man/chooseMpfr.Rd c3c05a03f6bc5ff5b370b2eb66f0b0a4 *man/distr-etc.Rd 0b6d3ceccb5aa1640d6a3efba0301094 *man/factorialMpfr.Rd 8b0811229b0f62bf40fd1d358f35a4ad *man/formatHex.Rd 4b10d7fa2b3c7ebab9c8baa14aad0964 *man/formatMpfr.Rd de337497be555732ed4924d166445811 *man/fr_ld_expMpfr.Rd f9bede01ca1128755edcbde06dbeac79 *man/gmp-conversions.Rd a998d1b6dc750347f0728e895ac929ef *man/hjkMpfr.Rd 41b1df710cfd87075192fec0d664c5ed *man/igamma.Rd 24b40df99950fba5e4c18d4058061802 *man/integrateR.Rd 83b62f162e8b73fd4c35e1709ae2db1b *man/is.whole.Rd ae9a6e22a52311b484492e0618994402 *man/log1mexp.Rd b59967ffab6946d1e4808d22a005b967 *man/matmult.Rd 61c791dad9714a7cccf1c1f1ce8b5d91 *man/mpfr-class.Rd 74af0d8841b00399af43f4743b8b000a *man/mpfr-utils.Rd 385fab4380c707b5ca4d1d6b26b18b8b *man/mpfr.Rd 934ac439faa2b875ff06d51af475fb1d *man/mpfrArray.Rd 2e780c7c7a5e9f54883cb259e87575b5 *man/mpfrMatrix-class.Rd 60f9e326ddd2e6cd86f1a8be037ae19d *man/mpfrMatrix-utils.Rd 4e70079352dd3237e7d6b669fd22976c *man/num2bigq.Rd c8a1a2e8d638e7049dc8f8e93374e99c *man/optimizeR.Rd cf728b1bd02b740e896c491294c673a1 *man/pbetaI.Rd 92d078f455a67440cc1303e46750a25b *man/pmax.Rd 2ccf68880afa0ba9d0cae0e68b412c1e *man/qnormI.Rd 4b8af5895987ec1453fa6c762eae1740 *man/roundMpfr.Rd 8825230c6ea8b5973ddb45618529333b *man/sapplyMpfr.Rd 61d5331094c01c5932265c0e61789b59 *man/seqMpfr.Rd 6c5082f10c6f2cafe3d3d7008cc81e83 *man/special-math.Rd f04ae96d01961265097f8ceb8f9982af *man/str.mpfr.Rd 505caf2cb629038d577fff32882832be *man/sumBinomMpfr.Rd b95164d43f0feee6ef07b93c3a5d3343 *man/unirootR.Rd c111a034d89e8538669a2742739abadb *man/utils.Rd 72f32aa7f3d8fcaaf0cfe197363a4c84 *src/Makevars.in 38a4bfeeb97fdd47207ab1db54d08247 *src/Ops.c 130412154c8b0fa1b1b437c8a915623e *src/Rmpfr_utils.h 1d32b2911bd1640c603a10a613a04cf0 *src/Summary.c 06cecf8dbebd8a36734d820d1f4336c9 *src/Syms.h dd4c7b24a22dc2742bdcc416d72c4968 *src/config.h.in 16597915838358d9e27015cecbf56ea6 *src/convert.c 98b82147e74327827a2359907250c73e *src/init.c 8f32d9729730c9c34418a3496d082446 *src/utils.c 06a2b514853355a62cb889d4cfd7c2c1 *tests/arith-ex.R b29415f54cecc2d4ffc1ddc4f4bcec9a *tests/binomial-etc.R ab445fb09abc4b474b016397857a5795 *tests/bit-repr.R bf11624748a24ba9a160bf67d754b032 *tests/create.R 8bfe461fc1a620e139accc0feaa13cf8 *tests/functionals.R 4a7787a270bdc2cfa13db0764b18fd87 *tests/lowlevel.R a02ae1fa6174fc3d1ba606d7a47186c7 *tests/matrix-ex.R 825e4c312b85e32970bc0f6ab21b4fdd *tests/special-fun-dgamma.R 2b679c1d879ff120aab7482d4900e102 *tests/special-fun-ex.R f32980cc228ddd92f8d676ac972d6dbc *tests/tstHexBin.R ca4d6c443c917a2b41766aa538ac5987 *vignettes/Maechler_useR_2011-abstr.Rnw e445ed0eb9d6f2cb9b5c22f9c14e6d87 *vignettes/Rmpfr-pkg.Rnw 88c9dc6190d3f167e65563af812f68f0 *vignettes/Rmpfr.bib 2ee39564c6d2a048c36bdc7ea7e9d8ab *vignettes/log1mexp-note.Rnw 30ab044ddacc1d0eca99bfa8a6176f7a *vignettes/log1mexp.bib Rmpfr/configure.win0000755000176200001440000000003315075675673014064 0ustar liggesusers#! /bin/sh ./configure $* Rmpfr/R/0000755000176200001440000000000015075721202011542 5ustar liggesusersRmpfr/R/as.R0000644000176200001440000003376515057534534012320 0ustar liggesusers#### All coercion methods for the "Rmpfr" classes if(getRversion() < "3.5") { isFALSE <- function (x) is.logical(x) && length(x) == 1L && !is.na(x) && !x isTRUE <- function (x) is.logical(x) && length(x) == 1L && !is.na(x) && x if(getRversion() < "3.3") strrep <- function (x, times) { ## (x, times) must be "recycled" if((lx <- length(x)) < (lt <- length(times))) x <- rep_len(x, lt) else if(lt < lx) times <- rep_len(times, lx) vapply(seq_along(x), function(i) paste(rep.int(x[i], times[i]), collapse = ""), "") } if(getRversion() < "3.2") lengths <- function(x, use.names = TRUE) vapply(x, length, 1L, USE.NAMES = use.names) } ##' fast pre-test (for numeric, bigz, bigq, ..): is.mpfr <- function(x) isS4(x) && is(x, "mpfr") mpfr <- function(x, precBits, ...) UseMethod("mpfr") mpfr.mpfr <- function(x, precBits, rnd.mode = c('N','D','U','Z','A'), ...) roundMpfr(x, precBits=precBits, rnd.mode=rnd.mode) mpfr.bigz <- function(x, precBits, ...) { if(missing(precBits)) precBits <- max(2L, frexpZ(x)$exp) if(getOption("verbose")) warning("mpfr() --> .bigz2mpfr() [not efficiently via character]") ..bigz2mpfr(x, precBits) } mpfr.bigq <- function(x, precBits, ...) { if(missing(precBits)) precBits <- getPrec(x)#-> warning if(getOption("verbose")) warning("mpfr() --> .bigq2mpfr() [not efficiently via character]") ..bigq2mpfr(x, precBits) } mpfr.NULL <- function(x, ...) mpfr(logical(), ...) mpfr.default <- function(x, precBits, base = 10, rnd.mode = c('N','D','U','Z','A'), scientific = NA, ...) { if(is.ch <- is.character(x)) stopifnot(length(base) == 1, 2 <= base, base <= 62) else if(is.raw(x)) { # is.raw() is faster stopifnot(missing(precBits) || precBits >= 2) ## else warning("unrecognized raw 'x'") # <- ?? {see use in ../tests/create.R } ## {but 'raw' is treated below} } else { ## typically the result of Vectorize() or similar on "mpfr" if(is.list(x) && all(lengths(lc <- lapply(x, class)) == 1L) && all(unlist(lc) == "mpfr1")) return(new("mpfr", x)) } if(missing(precBits)) { precBits <- getPrec(x, base = base, doNumeric = FALSE) } stopifnot(2 <= precBits, ## libmpfr exits (after good error message) for precBits == 1 precBits <= .Machine$integer.max, is.character(rnd.mode <- toupper(rnd.mode))) rnd.mode <- match.arg(rnd.mode) ml <- if(is.numeric(x) || is.logical(x) || is.raw(x)) .Call(d2mpfr1_list, x, precBits, rnd.mode) else if(is.ch) .Call(str2mpfr1_list,x, precBits, base, rnd.mode) else stop("invalid 'x'. Must be numeric (logical, raw) or character") if(is.array(x)) { dim <- dim(x) ; dn <- dimnames(x) new(if(length(dim) == 2) "mpfrMatrix" else "mpfrArray", ml, Dim = dim, Dimnames = if(is.null(dn)) vector("list", length(dim)) else dn) } else new("mpfr", ml) } ## mpfr.default() .mpfr <- function(x, precBits) new("mpfr", .Call(d2mpfr1_list, x, precBits, "N")) .mpfr. <- function(x, precBits, rnd.mode) new("mpfr", .Call(d2mpfr1_list, x, precBits, rnd.mode)) ##' to be used in our own low-level R programming .d2mpfr1 <- function(x, precBits) .Call(d2mpfr1, x, precBits, "N") setAs("numeric", "mpfr1", ## use default precision of 128 bits function(from) .Call(d2mpfr1, from, 128L, "N"))# <- round to [N]earest setAs("numeric", "mpfr", function(from) .mpfr(from, 128L)) setAs("integer", "mpfr", function(from) .mpfr(from, 32L)) setAs("raw", "mpfr", function(from) .mpfr(from, 8L)) setAs("logical", "mpfr", function(from) .mpfr(from, 2L)) ## TODO? base=16 for "0x" or "0X" prefix -- but base must have length 1 .. setAs("character", "mpfr", function(from) mpfr(from)) .mpfr2d <- function(from) .Call(mpfr2d, from, rnd.mode="N") .mpfr2i <- function(from) .Call(mpfr2i, from, rnd.mode="N") setAs("mpfr", "numeric", .mpfr2d) setAs("mpfr", "integer", .mpfr2i) setMethod("as.numeric", "mpfr", function(x, rnd.mode="N") .Call(mpfr2d, x, rnd.mode)) ## "Z": round towards [Z]ero -- crucial for as.integer() : setMethod("as.integer", "mpfr", function(x, rnd.mode="Z") .Call(mpfr2i, x, rnd.mode)) ## FIXME (in gmp!!): asNumeric() should get "..." argument setMethod("asNumeric", "mpfr", function(x) .Call(mpfr2d, x, rnd.mode="N")) setMethod("asNumeric", "mpfrArray", function(x) toNum(x, rnd.mode="N")) setAs("mpfr1", "numeric", ## just for user-de-confusion : function(from) { warning("coercing \"mpfr1\" via \"mpfr\" (inefficient)") as(new("mpfr", list(from)), "numeric") }) setAs("mpfr1", "mpfr", function(from) new("mpfr", list(from))) setAs("mpfr", "mpfr1", function(from) { if(length(from) == 1) getD(from)[[1]] else stop("only \"mpfr\" objects of length 1 can be coerced to \"mpfr1\"") }) .mpfr1tolist <- function(x) sapply(.slotNames(x), slot, object=x, simplify=FALSE) .mpfr2list <- function(x, names=FALSE) { if(isTRUE(names)) names <- format(x) x <- lapply(getD(x), .mpfr1tolist) if(is.character(names)) names(x) <- names x } ## Breaks the working of vapply(q, FUN.x) in pbetaI() in ./special-fun.R : ## as.list.mpfr1 <- function(x, ...) .mpfr1tolist(x) ## as.list.mpfr <- function(x, ...) .mpfr2list(x) ## and then mpfrXport <- function(x, names=FALSE) { if(!is.mpfr(x)) stop("argument is not a \"mpfr\" object") structure(class = "mpfrXport", list(gmp.numb.bits = .mpfr_gmp_numbbits(), ## currently unused, but in case: mpfr.version = .mpfrVersion(), Machine = .Machine[grepl("sizeof",names(.Machine))], Sys.info = Sys.info()[c("sysname", "machine")], mpfr = .mpfr2list(x, names=names))) } mpfrImport <- function(mxp) { if(!inherits(mxp, "mpfrXport")) stop("need an \"mpfrXport\" object") nbits <- .mpfr_gmp_numbbits() if(!identical(nbits, mxp$gmp.numb.bits)) stop("GMP bits not matching: 'x' has ", mxp$gmp.numb.bits, "; the loaded 'Rmpfr' package has ", nbits) m1 <- lapply(mxp$mpfr, function(o) do.call(new, c("mpfr1", o))) new("mpfr", m1) } .mpfr2str <- function(x, digits = NULL, maybe.full = !is.null(digits), base = 10L) { ## digits = NULL : use as many digits "as needed" for the precision stopifnot(is.null(digits) || (is.numeric(digits) && length(digits) == 1 && digits >= 0), is.logical(maybe.full), length(maybe.full) == 1L, !is.na(maybe.full), is.numeric(base), length(base) == 1L, base == as.integer(base), 2 <= base, base <= 62) if(!is.null(digits) && digits == 1 && base %in% 2L^(1:5)) { ## MPFR mpfr_get_str(): "N must be >= 2"; we found that N = 1 is ok unless ## for these bases where it aborts (in C). ==> prevent that: digits <- 2L message(gettextf("base = %d, digits = 1 is increased to digits = 2", base)) } .Call(mpfr2str, x, digits, maybe.full, base) # -> ../src/convert.c } ##' very low level version, not exported : ..mpfr2str <- function(x, digits = NULL, maybe.full = !is.null(digits), base = 10L) .Call(mpfr2str, x, digits, maybe.full, base) # -> ../src/convert.c ##' more efficient, just getting the (exp, finite, is0) list, 'exp' wrt base = 2 .mpfr_formatinfo <- function(x) .Call(R_mpfr_formatinfo, x) ##' getting the 'exp' (wrt base = 2) only [also for extended erange!] .mpfr2exp <- function(x) .Call(R_mpfr_2exp, x) ldexpMpfr <- function(f, E, rnd.mode = c('N','D','U','Z','A')) { stopifnot(is.character(rnd.mode <- toupper(rnd.mode))) new("mpfr", .Call(R_mpfr_ldexp, f, E, match.arg(rnd.mode))) } frexpMpfr <- function(x, rnd.mode = c('N','D','U','Z','A')) { stopifnot(is.character(rnd.mode <- toupper(rnd.mode))) .Call(R_mpfr_frexp, x, match.arg(rnd.mode)) } formatMpfr <- function(x, digits = NULL, # digits = NULL : use as many digits "as needed" trim = FALSE, scientific = NA, maybe.full = (!is.null(digits) && is.na(scientific)) || isFALSE(scientific), base = 10, showNeg0 = TRUE, max.digits = Inf, big.mark = "", big.interval = 3L, small.mark = "", small.interval = 5L, decimal.mark = ".", exponent.char = if(base <= 14) "e" else if(base <= 36) "E" else "|e", exponent.plus = TRUE, zero.print = NULL, drop0trailing = FALSE, ...) { if(!length(x)) return(character()) ff <- .mpfr2str(x, digits, maybe.full=maybe.full, base=base) # (checks its args!) ## FIXME/TODO: If have very large numbers, but not high precision, should detect it ## ========== and use maybe.full = FALSE also for the default scientific = NA ## digs.x <- ceiling(.getPrec(x) / log2(base)) stopifnot(length(scientific) == 1L) ### max.digits "doomed": scientific := number, (~= getOption("scipen")) should replace it stopifnot(is.numeric(max.digits), max.digits > 0) if(is.numeric(digits)) stopifnot(digits <= max.digits) isNum <- ff$finite ## ff$finite == is.finite(x) i0 <- ff$is.0 ## == mpfrIs0(x) ex <- ff$exp ## the *decimal* exp (wrt given 'base' !): one too large *unless* x == 0 r <- ff$str r.dig <- nchar(r) # (in both cases, digits NULL or not) ## Note that r.dig[] entries may vary, notably for digits NULL when .getPrec(x) is non-constant if(any(Lrg <- r.dig > max.digits)) { ## now "cut down", e.g. in print() when max.digits < Inf r [Lrg] <- substr(r[Lrg], 1L, max.digits) r.dig[Lrg] <- max.digits } if(any(i0)) { ## sign(x) == -1 "fails" for '-0' hasMinus <- substr(ff$str, 1L,1L) == "-" if(!showNeg0 && any(iN0 <- hasMinus & i0)) { ## get rid of "-" for "negative zero" r[iN0] <- substring(r[iN0], 2) hasMinus[iN0] <- FALSE } Ex <- ex Ex[!i0] <- ex[!i0] - 1L } else { Ex <- ex - 1L hasMinus <- sign(x) == -1 } if(!all(isNum)) ## "@Inf@", "@NaN@", ... r[!isNum] <- gsub("@", '', r[!isNum], fixed=TRUE) ##' (maybe) add decimal point after position k patch <- function(str, k) paste(substr (str, 1L, k), substring(str, k+1L), sep = decimal.mark) ## scipen := penalty for using "scientific", i.e., exponential format scipen <- if(is.na(scientific)) as.numeric(getOption("scipen")) else if(!(is.logical(scientific) || (is.numeric(scientific) && round(scientific) == scientific))) stop("'scientific' must be logical or a whole number") else if(is.logical(scientific)) { if(scientific) -32L else max(Ex) + 64 # << penalize much } else ## is.numeric(scientific) and a whole number scientific ## This very much depends on the desired format. ## if(scientific) --> all get a final "e"; otherwise, we ## adopt the following simple scheme : ### TODO: new argument jointly = (NA | TRUE | FALSE) or just (T | F) ### ---- if(jointly) use scalar ("global") hasE and have things *align* ## 'hasE' is *vector* (along 'x') : hasE <- { if(isTRUE(scientific)) TRUE ## hasE := (wF <= wE + scipen) , where (in R's format.default, which has jointly = TRUE ): ## ~~~~~~~~~~~~~~~~ ## wE = neg + (d > 0) + d + 4 + e (width for E format); d = mxns - 1, mxns = max_i{nsig_i} ## e = #{digits of exponent} -1 (= 1 or 2 in R) ## wF = mxsl + rgt + (rgt != 0); rgt := max_i{ (digits right of ".")_i } ## mxsl := max_i{sleft_i}; sleft_i = sign_i + (digits left of ".")_i else { ## scientific = (FALSE | NA | number) --- for now : if(is.na(scientific)) scientific <- scipen isNum & (Ex < -4 - scipen | Ex > r.dig) } } if(aE <- any(ii <- isNum & hasE)) { ii <- which(ii) i. <- 1L + hasMinus r[ii] <- patch(r[ii], i.[ii]) if(drop0trailing) ## drop 0's only after decimal mark (and drop it, if immediately there) r[ii] <- sub(paste0("\\", decimal.mark, "?0+$"), "", r[ii]) chE <- if(exponent.plus) sprintf("%+.0f", Ex[ii]) # "%..f": also when Ex is outside integer range! else as.character(Ex[ii]) r[ii] <- paste(r[ii], chE, sep = exponent.char) } use.prettyN <- (base <= 14 && (!aE || exponent.char == "e")) if(non.sci <- !all(hasE)) { ## "non-scientific" i.e. without final e[+-]?+ : ii <- isNum & !hasE ## iNeg <- ex <= 0 & ii ## i.e., ex in {0,-1,-2,-3} ## iPos <- ex > 0 & ii ## i.e., ex in {1,2..., digits} iNeg <- Ex < 0 & ii ## i.e., ex in {0,-1,-2,-3} iPos <- Ex >= 0 & ii ## i.e., ex in {1,2..., digits} if(any(eq <- (Ex == r.dig))) { r[eq] <- paste0(r[eq], "0") Ex[eq] <- Ex[eq] + 1L } if(any(iNeg)) { ## "0.00..." : be careful with minus sign if(any(isMin <- hasMinus[iNeg])) { rr <- r[iNeg] rr[isMin] <- substring(rr[isMin], 2) r[iNeg] <- paste0(c("","-")[1+isMin], "0.", strrep("0", -ex[iNeg]), rr) } else { r[iNeg] <- paste0("0.", strrep("0", -ex[iNeg]), r[iNeg]) } } if(any(iPos)) ## "xy.nnnn" : r[iPos] <- patch(r[iPos], (hasMinus + Ex+1L)[iPos]) } if(use.prettyN) r <- prettyNum(r, big.mark = big.mark, big.interval = big.interval, small.mark = small.mark, small.interval = small.interval, decimal.mark = decimal.mark, zero.print = zero.print, drop0trailing = drop0trailing, preserve.width = if (trim) "individual" else "common") else { if(non.sci && drop0trailing) ## drop 0's only *after* (and together with!) decimal mark: r <- sub(paste0(decimal.mark, "0+$"), "", r) if(!missing(big.mark) || !missing(big.interval) || !missing(small.interval) || !missing(small.mark) || !missing(big.interval) || !missing(zero.print)) warning("with base >= 15 or 'exponent.char != \"e\", cannot use prettyNum()") } if(is.null(d <- dim(x))) r else array(r, dim=d, dimnames = dimnames(x)) } setMethod("format", "mpfr", formatMpfr) formatN.mpfr <- function(x, drop0trailing = TRUE, ...) { paste0(formatMpfr(x, drop0trailing=drop0trailing, ...),"_M") } setAs("mpfr", "character", function(from) format(from, digits=NULL, drop0trailing = TRUE)) setAs("character", "mpfr", function(from) mpfr(from)) Rmpfr/R/hjk.R0000644000176200001440000001147312470611664012455 0ustar liggesusers#### #### h o o k e j e e v e s . R Hooke-Jeeves Minimization Algorithm #### ## From: John C Nash ## To: Martin Maechler , Hans Werner Borchers ## ## Subject: Re: Rmpfr for optimization? Minor success. ## Date: Tue, 5 Jun 2012 12:37:19 -0400 ## Changing to hjk routine was a bit easier to deal with. I found main changes ## were to wrap output with as.numeric() to allow cat() to function. ## I'll get no prizes for tidy code, but it is running an n=2 Chebyquad ## minimization, and seems to be working on an n=6. This may be a good way to ## encourage the sale of cpu power. ## Best, JN hjkMpfr <- function(par, fn, control = list(), ...) { ## Following fails when par is mpfr number JN120605 ## if (!is.numeric(par)) ## stop("Argument 'par' must be a numeric vector.", call. = FALSE) n <- length(par) if (n == 1) stop("For univariate functions use some different method.", call. = FALSE) ##-- Control list handling ---------- cntrl <- list(tol = 1.e-06, maxfeval = Inf, # set to Inf if no limit wanted maximize = FALSE, # set to TRUE for maximization target = Inf, # set to Inf for no restriction info = FALSE) # for printing interim information nmsCo <- match.arg(names(control), choices = names(cntrl), several.ok = TRUE) if (!is.null(names(control))) cntrl[nmsCo] <- control tol <- cntrl$tol; maxfeval <- cntrl$maxfeval maximize <- cntrl$maximize target <- cntrl$target info <- cntrl$info scale <- if (maximize) -1 else 1 fun <- match.fun(fn) f <- function(x) scale * fun(x, ...) ##-- Setting steps and stepsize ----- nsteps <- floor(log2(1/tol)) # number of steps steps <- 2^c(-(0:(nsteps-1))) # decreasing step size dir <- diag(1, n, n) # orthogonal directions x <- par # start point fx <- f(x) # smallest value so far fcount <- 1 # counts number of function calls if (info) cat(sprintf("step nofc %-12s | %20s\n", "fmin", "xpar")) ##-- Start the main loop ------------ ns <- 0 while (ns < nsteps && fcount < maxfeval && abs(fx) < target) { ns <- ns + 1 hjs <- .hjsearch(x, f, steps[ns], dir, fcount, maxfeval, target) x <- hjs$x fx <- hjs$fx ## found <- hjs$found fcount <- fcount + hjs$finc if (info) cat(sprintf("%4d %5d %-12.7g | %-20.15g %-20.15g%s\n", ns, fcount, as.numeric(fx/scale), as.numeric(x[1]), as.numeric(x[2]), if(n > 2)" ....")) } conv <- if (fcount > maxfeval) { warning("Function evaluation limit exceeded -- may not converge.") FALSE } else if (abs(fx) > target) { warning("Function exceeds min/max value -- may not converge.") FALSE } else TRUE fx <- fx / scale # undo scaling list(par = x, value = fx, convergence = conv, feval = fcount, niter = ns) } ## Search with a single scale ----------------------------- .hjsearch <- function(xb, f, h, dir, fcount, maxfeval, target) { xc <- x <- xb finc <- 0 hje <- .hjexplore(xb, xc, f, h, dir) x <- hje$x fx <- hje$fx found <- hje$found finc <- finc + hje$numf ## Pattern move while (found) { d <- x-xb xb <- x xc <- x+d fb <- fx hje <- .hjexplore(xb, xc, f, h, dir, fb) x <- hje$x fx <- hje$fx found <- hje$found finc <- finc + hje$numf if (!found) { # pattern move failed hje <- .hjexplore(xb, xb, f, h, dir, fb) x <- hje$x fx <- hje$fx found <- hje$found finc <- finc + hje$numf } if (fcount + finc > maxfeval || abs(fx) > target) break } list(x = x, fx = fx, found=found, finc=finc) } ## Exploratory move --------------------------------------- .hjexplore <- function(xb, xc, f, h, dir, fbold) { n <- length(xb) x <- xb if (missing(fbold)) { fb <- f(x) numf <- 1 } else { fb <- fbold numf <- 0 } fx <- fb xt <- xc found <- FALSE # do we find a better point ? dirh <- h * dir fbold <- fx for (k in sample.int(n, n)) { # resample orthogonal directions p <- xt + (d. <- dirh[, k]) fp <- f(p) numf <- numf + 1 if (fp >= fb) { p <- xt - d. fp <- f(p) numf <- numf + 1 } if (fp < fb) { found <- TRUE xt <- p fb <- fp } } if(found) { x <- xt fx <- fb } list(x = x, fx = fx, found=found, numf = numf) } Rmpfr/R/Math.R0000644000176200001440000003025215057534534012572 0ustar liggesusers#### Define mpfr methods for Math and Math2 group functions #### ====== ===== ### "Arith", "Compare",..., are in ./Arith.R ### ---- ~~~~~~~ if(FALSE) print(getGroupMembers("Math"), width = 85) ## [1] "abs" "sign" "sqrt" "ceiling" "floor" "trunc" "cummax" ## [8] "cummin" "cumprod" "cumsum" "exp" "expm1" "log" "log10" ## [15] "log2" "log1p" "cos" "cosh" "sin" "sinh" "tan" ## [22] "tanh" "acos" "acosh" "asin" "asinh" "atan" "atanh" ## [29] "cospi" "sinpi" "tanpi" "gamma" "lgamma" "digamma" "trigamma" if(FALSE) ## the individual functions dput(getGroupMembers("Math")) ## NOTA BENE: explicitly in {Math} in ## >>>> ../man/mpfr-class.Rd <<<< ## ~~~~~~~~~~~~~~~~~ ## Uniform interface to C: ## ## Pass integer code to call and do the rest in C ## Codes from ~/R/D/r-devel/R/src/main/names.c : .Math.codes <- c( "floor" = 1, "ceiling" = 2, "sqrt" = 3, "sign" = 4, "exp" = 10, "expm1" = 11, "log1p" = 12, "cos" = 20, "sin" = 21, "tan" = 22, "acos" = 23, "asin" = 24, "cosh" = 30, "sinh" = 31, "tanh" = 32, "acosh" = 33, "asinh" = 34, "atanh" = 35, "lgamma" = 40, "gamma" = 41, "digamma" = 42, "trigamma" = 43, ## R >= 3.1.0 : "cospi" = 47, "sinpi" = 48, "tanpi" = 49 ) .Math.gen <- getGroupMembers("Math") ## Those "Math" group generics that are not in the do_math1 table above .Math.codes <- c(.Math.codes, "trunc" = 0, "atan" = 25, # "abs" has own method! "log" = 13, "log2" = 14, "log10" = 15, "cummax" = 71, "cummin" = 72, "cumprod" = 73, "cumsum" = 74, ## These are *NOT* in R's Math group, but 1-argument math functions ## available in the mpfr - library: "erf" = 101, "erfc" = 102, "zeta" = 104, "Eint" = 106, "Li2" = 107, "j0" = 111, "j1" = 112, "y0" = 113, "y1" = 114, "Ai" = 120 # Airy function (new in mpfr 3.0.0) ) storage.mode(.Math.codes) <- "integer" if(FALSE) .Math.gen[!(.Math.gen %in% names(.Math.codes))] ## "abs" -- only one left ## A few ones have a very simple method: ## Note that the 'sign' slot is from the C-internal struct ## and is always +/- 1 , but R's sign(0) |--> 0 .getSign <- function(x) vapply(getD(x), slot, 1L, "sign") .mpfr_sign <- function(x) { r <- numeric(length(x))# all 0 not0 <- !mpfrIs0(x) r[not0] <- .getSign(x[not0]) r } setMethod("sign", "mpfr", .mpfr_sign) ## R version, no longer used: .abs.mpfr <- function(x) { ## FIXME: faster if this happened in a .Call xD <- getDataPart(x) # << currently [2011] *faster* than x@Data for(i in seq_along(x)) slot(xD[[i]], "sign", check=FALSE) <- 1L setDataPart(x, xD, check=FALSE) ## faster than x@.Data <- xD } setMethod("abs", "mpfr", function(x) .Call(Rmpfr_abs, x)) ## Simple methods for "complex" numbers, just so "they work" setMethod("Re", "mpfr", function(z) z) setMethod("Im", "mpfr", function(z) 0*z) setMethod("Conj","mpfr", function(z) z) setMethod("Mod", "mpfr", function(z) abs(z)) setMethod("Arg", "mpfr", function(z) { prec <- .getPrec(z) r <- mpfr(0, prec) neg <- !mpfrIs0(z) & .getSign(z) == -1 r[neg] <- Const("pi", prec = prec[neg]) r }) ## Note that factorial() and lfactorial() automagically work through [l]gamma() ## but for the sake of "exact for integer" setMethod("factorial", "mpfr", function(x) { r <- gamma(x + 1) isi <- .mpfr.is.whole(x) r[isi] <- round(r[isi]) r }) ## The "real" thing is to use the MPFR-internal function: factorialMpfr <- function(n, precBits = max(2, ceiling(lgamma(n+1)/log(2))), rnd.mode = c('N','D','U','Z','A')) { if(!length(n)) return(as(n, "mpfr")) stopifnot(n >= 0) new("mpfr", .Call(R_mpfr_fac, n, precBits, match.arg(rnd.mode))) } ##' Pochhammer rising factorial = Pochhammer(a,n) {1 of 2 definitions!} ##' we use the *rising* factorial for Pochhamer(a,n), i.e., ##' the definition that the GSL and Mathematica use as well. ##' We want to do this well for *integer* n, only the general case is using ##' P(a,x) := Gamma(a+x)/Gamma(x) pochMpfr <- function(a, n, rnd.mode = c('N','D','U','Z','A')) { if(!length(n)) return(a[FALSE]) stopifnot(is.integer(n <- as.integer(n)), n >= 0) if(!is(a, "mpfr")) ## use a high enough default precision (and recycle ..) a <- mpfr(a, precBits = pmax(1,n)*getPrec(a)) else if((ln <- length(n)) != 1 && ln != length(a)) a <- a + 0*n ## a@.Data[] <- .Call(R_mpfr_poch, a, n) ## a setDataPart(a, .Call(R_mpfr_poch, a, n, match.arg(rnd.mode))) } ##' Binomial Coefficient choose(a,n) ##' We want to do this well for *integer* n chooseMpfr <- function(a, n, rnd.mode = c('N','D','U','Z','A')) { if(!length(n)) return(a[FALSE]) stopifnot(is.integer(n <- as.integer(n))) ## if(n < 0) ==> result 0 as for base::choose() if(!is(a, "mpfr")) { ## use high enough default precision lc <- lchoose(a,n) precB <- if(any(iF <- is.finite(lc))) ceiling(max(lc[iF])/log(2)) else 0 ## add n bits for the n multiplications (and recycle {a,n} to same length) a <- mpfr(a, precBits = n + max(2, precB)) } else if((ln <- length(n)) != 1 && ln != length(a)) a <- a + 0*n setDataPart(a, .Call(R_mpfr_choose, a, n, match.arg(rnd.mode))) } ## ------------- => ../src/utils.c chooseMpfr.all <- function(n, precBits=NULL, k0=1, alternating=FALSE) { ## return chooseMpfr(n, k0:n) or (-1)^k * choose... "but smartly" if(length(n) != 1 || !is.numeric(n) || is.na(n) || (n <- as.integer(n)) < 1) stop("n must be integer >= 1") stopifnot(is.numeric(n. <- k0), n. == (k0 <- as.integer(k0)), k0 <= n) sig <- if(alternating) (-1)^(k0:n) else rep.int(1, (n-k0+1)) if(n == 1) return(mpfr(sig, 32)) ## else : n >= 2 n2 <- n %/% 2 # >= 1 prec <- ceiling(lchoose(n,n2)/log(2)) # number of bits needed in result precBxtr <- max(2, n2 + prec) # need more for cumprod(), and division n2. <- mpfr(n2, precBxtr) r <- cumprod(seqMpfr(mpfr(n, precBxtr), n+1-n2., length.out=n2)) / cumprod(seqMpfr(1, n2., length.out=n2)) prec <- max(2,prec) if(is.numeric(precBits) && (pB <- as.integer(round(precBits))) > prec) prec <- pB r <- roundMpfr(r, precBits = prec) ## ii <- c(seq_len(n2-1+(n%%2)), n2:1) if(k0 >= 2) ii <- ii[-seq_len(k0 - 1)] one <- .d2mpfr1(1, precBits=prec) r <- c(if(k0 == 0) one, getD(r)[ii], one) if(alternating) { for(i in seq_along(r)) if(sig[i] == -1) slot(r[[i]], "sign", check=FALSE) <- - 1L } new("mpfr", r) }## {chooseMpfr.all} ## https://en.wikipedia.org/wiki/N%C3%B6rlund%E2%80%93Rice_integral ## also deals with these alternating binomial sums ##' ##' version 1: already using the 'alternating' arg in chooseMpfr.all() sumBinomMpfr.v1 <- function(n, f, n0=0, alternating=TRUE, precBits = 256) { ## Note: n0 = 0, or 1 is typical, and hence chooseMpfr.all() makes sense stopifnot(0 <= n0, n0 <= n, is.function(f)) sum(chooseMpfr.all(n, k0=n0, alternating=alternating) * f(mpfr(n0:n, precBits=precBits))) } ##' version 2: chooseZ()*(-1)^(.) is considerably faster than chooseMpfr.all() sumBinomMpfr.v2 <- function(n, f, n0=0, alternating=TRUE, precBits = 256, f.k = f(mpfr(k, precBits=precBits))) { ## Note: n0 = 0, or 1 is typical.. stopifnot(0 <= n0, n0 <= n, is.function(f) || (is(f.k, "mpfr") && length(f.k) == n-n0+1)) k <- n0:n sum(if(alternating) chooseZ(n, k) * (-1)^(n-k) * f.k else chooseZ(n, k) * f.k) } ## NB: pbetaI() in ./special-fun.R uses a special version.. ## --- if we do this *fast* in C -- do pbetaI() as well. sumBinomMpfr <- sumBinomMpfr.v2 ##' Rounding to binary bits, not decimal digits. Closer to the number ##' representation, this also allows to increase or decrease a number's precBits ##' @title Rounding to binary bits, "mpfr-internally" ##' @param x an mpfr number (vector) ##' @param precBits integer specifying the desired precision in bits. ##' @return an mpfr number as \code{x} but with the new 'precBits' precision ##' @author Martin Maechler roundMpfr <- function(x, precBits, rnd.mode = c('N','D','U','Z','A')) { stopifnot(is(x, "mpfr"), precBits <= .Machine$integer.max) setDataPart(x, .Call(R_mpfr_round, x, precBits, match.arg(rnd.mode))) } ## "log" is still special with its 'base' : ## setMethod("log", signature(x = "mpfr", base = "mpfr"), ## function(x, base) ## setDataPart(x, .Call(Math_mpfr, x, .Math.codes[["log"]])) / log(base) ## ) ## setMethod("log", signature(x = "mpfr", base = "mNumber"), # including "numeric", "bigz", "bigq" ## function(x, base) ## setDataPart(x, .Call(Math_mpfr, x, .Math.codes[["log"]])) / ## log(mpfr(base, getPrec(x))) ## ) ## setMethod("log", signature(x = "mpfr", base = "ANY"), ## function(x, base) { ## if(!missing(base) && base != exp(1)) ## stop("base != exp(1) is not yet implemented") ## setDataPart(x, .Call(Math_mpfr, x, .Math.codes[["log"]])) ## }) setMethod("log", signature(x = "mpfr"), function(x, base = exp(1)) { r <- setDataPart(x, .Call(Math_mpfr, x, .Math.codes[["log"]])) if(!missing(base) && substitute(base) != quote(exp(1))) r / log(mpfr(base, getPrec(x))) else r }) setMethod("Math", signature(x = "mpfr"), function(x) setDataPart(x, .Call(Math_mpfr, x, .Math.codes[[.Generic]]))) setMethod("Math2", signature(x = "mpfr"), function(x, digits) { ## NOTA BENE: vectorized in 'x' if(any(ret.x <- !is.finite(x) | mpfrIs0(x))) { if(any(ok <- !ret.x)) x[ok] <- callGeneric(x[ok], digits=digits) return(x) } if(!missing(digits)) { digits <- as.integer(round(digits)) if(is.na(digits)) return(x + digits) } ## else: default *depends* on the generic ## now: both x and digits are finite pow10 <- function(d) mpfr(rep.int(10., length(d)), precBits = ceiling(log2(10)*as.numeric(d)))^ d rint <- function(x) { ## have x >= 0 here sml.x <- (x < .Machine$integer.max) r <- x if(any(sml.x)) { x.5 <- x[sml.x] + 0.5 ix <- as.integer(x.5) ## implement "round to even" : if(any(doDec <- (abs(x.5 - ix) < 10*.Machine$double.eps & (ix %% 2)))) ix[doDec] <- ix[doDec] - 1L r[sml.x] <- ix } if(!all(sml.x)) { ## large x - no longer care for round to even r[!sml.x] <- floor(x[!sml.x] + 0.5) } r } neg.x <- x < 0 x[neg.x] <- - x[neg.x] sgn <- ifelse(neg.x, -1, +1) switch(.Generic, "round" = { ## following ~/R/D/r-devel/R/src/nmath/fround.c : if(missing(digits) || digits == 0) sgn * rint(x) else if(digits > 0) { p10 <- pow10(digits) intx <- floor(x) sgn * (intx + rint((x-intx) * p10) / p10) } else { ## digits < 0 p10 <- pow10(-digits) sgn * rint(x/p10) * p10 } }, "signif" = { ## following ~/R/D/r-devel/R/src/nmath/fprec.c : if(missing(digits)) digits <- 6L if(digits > max(.getPrec(x)) * log10(2)) return(x) if(digits < 1) digits <- 1L l10 <- log10(x) e10 <- digits - 1L - floor(l10) r <- x pos.e <- (e10 > 0) ##* 10 ^ e, with e >= 1 : exactly representable if(any(pos.e)) { p10 <- pow10(e10[pos.e]) r[pos.e] <- sgn[pos.e]* rint(x[pos.e]*p10) / p10 } if(any(neg.e <- !pos.e)) { p10 <- pow10(-e10[neg.e]) r[neg.e] <- sgn[neg.e]* rint(x[neg.e]/p10) * p10 } r }, stop(gettextf("Non-Math2 group generic '%s' -- should not happen", .Generic))) }) ##---- mpfrArray / mpfrMatrix --- methods ----------------- ## not many needed: "mpfrArray" contain "mpfr", ## i.e., if the above methods are written "general enough", they apply directly setMethod("sign", "mpfrArray", function(x) structure(.mpfr_sign(x), dim = dim(x), dimnames = dimnames(x))) Rmpfr/R/Summary.R0000644000176200001440000000714014457744436013345 0ustar liggesusers#### Define mpfr methods for Summary group functions #### ======= ### "Math" are done in ./Math.R , "Ops", "Arith", "Logic", "Compare" in ./Arith.R .Summary.codes <- c("max" = 1, "min" = 2, "range" = 3, "prod" = 4, "sum" = 5, "any" = 10, "all" = 11) storage.mode(.Summary.codes) <- "integer" setMethod("Summary", "mpfr", function(x, ..., na.rm=FALSE) { iop <- .Summary.codes[.Generic] ## --> ../src/Summary.c r <- .Call(Summary_mpfr, if(length(x)) c(x, ...) else x, na.rm, iop) if(iop <= 5) new("mpfr", r) else ## any, all : r }) stats__quantile.default <- stats:::quantile.default setMethod("quantile", "mpfr", stats__quantile.default) ## FIXME: is *slow* *and* uses double precision epsilon internally .Machine$double.epsilon ## ## Not perfect: has the "0%" "25%" "50%" ... names but not as slot ... hmm ... ## 'mpfr' numbers do not have 'names' slot ... (etc) -- but "work" with names ## function(x, ...) { ## if((match("names", names(list(...)), nomatch = 0L)) == 0L) ## stats__quantile.default(x, ..., names=FALSE) ## else ## ... contains 'names = ..' ## stats__quantile.default(x, ...) ## }) setMethod("mean", "mpfr", function(x, trim = 0, na.rm = FALSE, ...) { if(trim == 0) ## based on sum() : sum(x, na.rm=na.rm, ...) / length(x) else { ## cut'n'paste from mean.default() : if (!is.numeric(trim) || length(trim) != 1L || trim < 0) stop("'trim' must be numeric of length one, in [0, 1/2]") if (na.rm) x <- x[!is.na(x)] n <- length(x) if (anyNA(x)) mpfr(NA) else if (trim >= 0.5) quantile(x, probs = 0.5, na.rm = FALSE, names = FALSE) else { lo <- floor(n * trim) + 1 hi <- n + 1 - lo mean(sort(x, partial = unique(c(lo, hi)))[lo:hi], na.rm = FALSE) } } }) setMethod("median", "mpfr", function(x, na.rm=FALSE, ...) quantile(x, probs = 0.5, na.rm=na.rm, names = FALSE)) setMethod("summary", "mpfr", function (object, ..., digits, quantile.type = 7) { ## Should work almost like summary(asNumeric(object, ..., digits=digits)) ## *but* w/o underflow and overflow: nas <- is.na(object) object <- object[!nas] qq <- quantile(object, names=FALSE, type = quantile.type) qq <- c(qq[1L:3L], mean(object), qq[4L:5L]) ## names(qq) <- c("Min.", "1st Qu.", "Median", "Mean", "3rd Qu.", "Max.") if (!missing(digits)) qq <- signif(qq, digits) if(any(nas)) # names() updatingn works for "mpfr" qq <- c(qq, "NA's" = sum(nas)) ## loses names: as(qq, "summaryMpfr") ## workaround : new("summaryMpfr", qq, names = c("Min.", "1st Qu.", "Median", "Mean", "3rd Qu.", "Max.")) }) setClass("summaryMpfr", contains = "mpfr", slots = c(names = "character")) print.summaryMpfr <- function (x, digits=max(3L, getOption("digits") - 3L), ...) { xx <- x names(xx) <- NULL # will be lost anyway if(getRversion() >= "3.5.2") { ## for zapsmall() to work finite <- is.finite(xx) xx[finite] <- zapsmall(xx[finite]) } m <- match("NA's", names(xx), nomatch = 0L) xx <- if(m) c(format(xx[-m], digits = digits), `NA's` = as.character(xx[m])) else format(xx, digits = digits) names(xx) <- names(x) print.table(xx, digits = digits, ...) invisible(x) } setMethod(show, "summaryMpfr", function(object) print.summaryMpfr(object)) ## FIXME: can do this considerably faster in C: [which.max(): loc.(first TRUE)] setMethod("which.max", "mpfr", function(x) which.max(x == max(x))) setMethod("which.min", "mpfr", function(x) which.max(x == min(x))) Rmpfr/R/special-fun.R0000644000176200001440000006676415075433454014127 0ustar liggesusers## erf(), erfc() erf <- function(x) { if(is.numeric(x)) 2 * pnorm(x * sqrt(2)) - 1 else if(is.mpfr(x)) { # maybe also mpfrMatrix ##new("mpfr", .Call(Math_mpfr, x, .Math.codes[["erf"]])) x@.Data[] <- .Call(Math_mpfr, x, .Math.codes[["erf"]]) x } else stop("invalid class(x): ", class(x)) } ## pnorm(x* sqrt(2)) = (1 + erf(x))/2 ##==> pnorm(x.) = (1 + erf(x./sqrt(2)))/2 ## pnorm(x* sqrt(2), lower=FALSE) = erfc(x)/2 ##==> pnorm(x., lower=TRUE) = erfc(x./sqrt(2))/2 erfc <- function(x) { if(is.numeric(x)) 2 * pnorm(x * sqrt(2), lower.tail = FALSE) else if(is.mpfr(x)) { x@.Data[] <- .Call(Math_mpfr, x, .Math.codes[["erfc"]]) x } else stop("invalid class(x): ", class(x)) } pnorm <- function (q, mean = 0, sd = 1, lower.tail = TRUE, log.p = FALSE) { if(is.numeric(q) && is.numeric(mean) && is.numeric(sd)) stats__pnorm(q, mean, sd, lower.tail=lower.tail, log.p=log.p) else if((q.mp <- is.mpfr(q)) || is.mpfr(mean) || is.mpfr(sd)) { stopifnot(length(lower.tail) == 1L, length(log.p) == 1L) rr <- q <- ((if(q.mp) q else as(q, "mpfr")) - mean) / sd if(any(neg <- (q < 0))) ## swap those: Phi(-z) = 1 - Phi(z) rr[neg] <- pnorm(-q[neg], lower.tail = !lower.tail, log.p=log.p) if(any(pos <- !neg)) { q <- q[pos] #==> now q >= 0 ## use slightly higher precision and then "round back": prec.q <- max(.getPrec(q)) two <- mpfr(2, prec.q + 4L) Irt2 <- sqrt(mpfr(0.5, prec.q + 4L)) # 1 / sqrt(2) rr[pos] <- roundMpfr(precBits = prec.q, if(lower.tail) { if(log.p) { r <- q sml <- q < 0.67448975 if(any(sml)) { eq2 <- erf(q[sml]*Irt2) ## |eq2| < 1/2 <==> |q*Irt2| < 0.47693627620447 ## <==> sml <==> |q| < 0.67448975019608 r[ sml] <- log1p(eq2) - log(two) } if(any(!sml)) { ec2 <- erfc(q[!sml]*Irt2) ## ==> ec2 = 1-eq2 <= 1 - 1/2 = 1/2 r[!sml] <- log1p(-0.5*ec2) } r } else ## !log.p (1 + erf(q*Irt2))/2 } else { ## upper.tail r <- erfc(q*Irt2) / 2 if(log.p) log(r) else r }) } rr } else stop("(q,mean,sd) must be numeric or \"mpfr\"") }#{pnorm} dnorm <- function (x, mean = 0, sd = 1, log = FALSE) { if(is.numeric(x) && is.numeric(mean) && is.numeric(sd)) stats__dnorm(x, mean, sd, log=log) else if((x.mp <- is.mpfr(x)) || is.mpfr(mean) || is.mpfr(sd)) { ## stopifnot(length(log) == 1) prec <- pmax(53, getPrec(x), getPrec(mean), getPrec(sd)) if(!x.mp) x <- mpfr(x, prec) x <- (x - mean) / sd twopi <- 2*Const("pi", prec) # or max(prec) ?? {maybe L.o.n.g. vector ..}; ditto for mpfr(sd, prec) below ## f(x) = 1/(sigma*sqrt(2pi)) * exp(-1/2 x^2) if(log) ## log( f(x) ) = -[ log(sigma) + log(2pi)/2 + x^2 / 2] -(log(if(is.mpfr(sd)) sd else mpfr(sd, prec)) + (log(twopi) + x*x)/2) else exp(-x^2/2) / (sd*sqrt(twopi)) } else stop("invalid arguments (x,mean,sd)") } ## 'ncp': not yet -- checked in ../tests/special-fun-ex.R dt <- function (x, df, ncp, log = FALSE) { if(is.numeric(x) && is.numeric(df) && (missing(ncp) || is.numeric(ncp))) stats__dt(x, df, ncp, log=log) else if (missing(ncp) || all(ncp == 0)) { stopifnot(length(log) == 1) if((x.mp <- is.mpfr(x)) | (df.mp <- is.mpfr(df)) || missing(ncp) || is.mpfr(ncp)) { prec <- pmax(53L, getPrec(x), getPrec(df), if(missing(ncp)) 0L else getPrec(ncp)) if(! x.mp) x <- mpfr( x, prec) if(!df.mp) df <- mpfr(df, prec) # or max(prec) ?? {maybe L.o.n.g. vector ..}; ditto for other (*, prec) below twopi <- 2*Const("pi", prec) ## From Catherine Loader's comment in src/nmath/dt.c (n := df) : ## the following form should be "stable" ["contrary" to the direct formula]: ## ## f_n(x) = sqrt(n/2) / ((n+1)/2) * Gamma((n+3)/2) / Gamma((n+2)/2) ## * (1+x^2/n)^(-n/2) ## / sqrt( 2 pi (1+x^2/n) ) ## ## MM "FIXME": consider pkg 'DPQ's b_chi() and lb_chi() {and old c_nu()} ## --------- for the constant if(log) { log(df/2)/2 - log((df+1)/2) + lgamma((df+3)/2) - lgamma((df+2)/2) + (-df/2)*log1p(x^2/df) - log( twopi*(1+x^2/df) )/2 } else { sqrt(df/2) / ((df+1)/2) * gamma((df+3)/2) / gamma((df+2)/2) * (1+x^2/df)^(-df/2) / sqrt( twopi*(1+x^2/df) ) } } else stop("invalid arguments (x,df,ncp)") } else stop("ncp != 0 not yet implemented; see pnt*() function in {DPQmpfr}")# Gil_et_al'23 } dpois <- function (x, lambda, log = FALSE, useLog = { ## MPFR overflow: ln2 <- log(2) any(lambda >= -.mpfr_erange("Emin")*ln2) || any(x*log(lambda) >= .mpfr_erange("Emax")*ln2) }) { if(is.numeric(x) && is.numeric(lambda)) ## standard R stats__dpois(x, lambda, log=log) else if((l.mp <- is.mpfr(lambda)) | (x.mp <- is.mpfr(x))) { prec <- pmax(53, getPrec(lambda), getPrec(x)) if(!l.mp) lambda <- mpfr(lambda, prec) if(!x.mp) x <- mpfr(x, prec) if(log || useLog) { ## NB: For large lambda, x ~= lambda this has a *LOT* of cancellation, e.g., for ## -- lambda = 1e100, prec = 256 is *NOT* sufficient !! r <- x + 0*lambda isI <- is.infinite(lambda) # & is.finite(x) # x <= lambda = +Inf r[ isI] <- if(log) -Inf else 0 ## "else" if(any(!isI)) { lambda <- lambda[!isI] x <- x[!isI] r[!isI] <- -lambda + x*log(lambda) - lfactorial(x) } if(log) r else exp(r) } else exp(-lambda) * lambda^x / factorial(x) } else stop("(x,lambda) must be numeric or \"mpfr\"") } dbinom <- function(x, size, prob, log = FALSE, useLog = any(abs(x) > 1e6) || ## MPFR overflow ["platform dep.": Windoof typically has reduced erange] max(abs((size-x)*log1p(-prob)), abs(x*log(prob))) >= .mpfr_erange("Emax")*log(2), warnLog = TRUE) { if(is.numeric(x) && is.numeric(size) && is.numeric(prob)) ## standard R stats__dbinom(x, size, prob, log=log) else if((s.mp <- is.mpfr(size)) | (p.mp <- is.mpfr(prob)) | (x.mp <- is.mpfr(x))) { stopifnot(is.whole(x)) # R's dbinom() gives NaN's with a warning.. prec <- pmax(53, getPrec(size), getPrec(prob), getPrec(x)) # full prec(x) if(!useLog) { if(is.integer(x)) xi <- x else { xi <- as.integer(x) # needed for chooseMpfr() if(anyNA(xi) || any(xi != x)) stop("'x' coerced from non-equal integer -- used for chooseMpfr()") } } if(!s.mp) size <- mpfr(size, prec) if(!p.mp) prob <- mpfr(prob, prec) if(!x.mp) x <- mpfr(x, prec) if(log && !useLog && warnLog) warning("'log' but not 'useLog': maybe losing efficiency") ## n:= size, p:= prob, compute P(x) = choose(n, x) p^x (1-p)^(n-x) if(useLog) { # do *not* use chooseMpfr() {which is O(x^2)} lC.nx <- ## lchoose(size, x), but that is *not* yet available for "mpfr" __FIXME?__ lfactorial(size) - (lfactorial(x) + lfactorial(size-x)) } else { # use xi : C.nx <- chooseMpfr(size, xi) lC.nx <- log(C.nx) } if(log || useLog) { r <- lC.nx + x*log(prob) + (size-x)*log1p(-prob) if(log) r else exp(r) } else C.nx * prob^x * (1-prob)^(size-x) } else stop("(x,size, prob) must be numeric or \"mpfr\"") }## {dbinom} dnbinom <- function (x, size, prob, mu, log = FALSE, useLog = any(x > 1e6)) { if(!missing(mu)) { if (!missing(prob)) stop("'prob' and 'mu' both specified") ## Using argument 'mu' instead of 'prob' if (all(sI <- size == Inf)) return( dpois(x, lambda=mu, log) ) ## else if(any(sI)) warning("some but not all 'size == Inf' giving invalid/NaN -- rather use dpois(.) (FIXME)") prob <- size/(size+mu) # and continue : } if(is.numeric(x) && is.numeric(size) && is.numeric(prob)) { ## standard R if(!missing(mu)) stats__dnbinom(x, size, mu=mu, log=log) else stats__dnbinom(x, size, prob=prob, log=log) } else if((s.mp <- is.mpfr(size)) | (p.mp <- is.mpfr(prob)) | (x.mp <- is.mpfr(x))) { stopifnot(is.whole(x)) # R's dbinom() gives NaN's with a warning.. prec <- pmax(53, getPrec(size), getPrec(prob), getPrec(x)) if(!is.integer(x) && !useLog) { xi <- as.integer(x) # chooseMpfr() needs it if(x.mp) (if(anyNA(xi) || any(xi != x)) stop else message)( "'x' coerced from \"mpfr\" to integer -- necessary for chooseMpfr()") x <- xi } if(!s.mp) size <- mpfr(size, prec) if(!p.mp) prob <- mpfr(prob, prec) if(!x.mp && !is.integer(x)) x <- mpfr(x, prec) ## n:= size, p:= prob, compute P(x) = choose(n+x-1, x) * p^n * (1-p)^x if(!useLog) { C.nx <- chooseMpfr(size+x-1, x) if(log || ## MPFR overflow: max(size*log(prob), x*log1p(-prob)) >= .mpfr_erange("Emax")*log(2)) { r <- log(C.nx) + size*log(prob) + x*log1p(-prob) if(log) r else exp(r) } else C.nx * prob^size * (1-prob)^x } else { # x not integer, typically |x| > .Machine$integer.max (= 2147483647 = 2^31 - 1) ## => x is large but size >= x is even larger ... so everything is large ## FIXME (?) suffering from cancellation (when ?) ! logC.nx <- lgamma(size+x) - lgamma(size) - lgamma(x+1) if(log) logC.nx + size*log(prob) + x*log1p(-prob) else exp(logC.nx + size*log(prob) + x*log1p(-prob)) } } else stop("(x,size, prob | mu) must be numeric or \"mpfr\"") }## {dnbinom} dgamma <- function(x, shape, rate = 1, scale = 1/rate, log = FALSE) { missR <- missing(rate) missS <- missing(scale) if (!missR && !missS) { ## as stats::dgamma() if (abs(rate * scale - 1) < 1e-15) warning("specify 'rate' or 'scale' but not both") else stop("specify 'rate' or 'scale' but not both") } ## and now use 'scale' only if(is.numeric(x) && is.numeric(shape) && is.numeric(scale)) stats__dgamma(x, shape, scale=scale, log=log) else if((sh.mp <- is.mpfr(shape)) | (sc.mp <- is.mpfr(scale)) | ( x.mp <- is.mpfr(x))) { ## f(x)= 1/(s^a Gamma(a)) x^(a-1) e^-(x/s) ; a=shape, s=scale ## log f(x) = -a*log(s) - lgamma(a) + (a-1)*log(x) - (x/s) if(!sh.mp || !sc.mp || !x.mp) { prec <- pmax(53L, getPrec(shape), getPrec(scale), getPrec(x)) if(!sh.mp) shape <- mpfr(shape, prec) if(!sc.mp) scale <- mpfr(scale, prec) if(! x.mp) x <- mpfr(x, prec) } ## for now, "cheap", relying on "mpfr" arithmetic to be smart ## "TODO": Use C.Loader's formulae via dpois_raw() , bd0() etc ## lgam.sh <- lgamma(shape) ## ldgamma <- function(x, shp, s) -shp*log(s) -lgam.sh + (shp-1)*log(x) - (x/s) ldgamma <- function(x, shp, s) -shp*log(s) -lgamma(shp) + (shp-1)*log(x) - (x/s) if(log) ldgamma(x, shape, scale) else { ## use direct [non - log-scale] formula when applicable ## ok <- lgam.sh < log(2) * Rmpfr:::.mpfr.erange("Emax") & ## finite gamma(shape) := exp(lgam.sh) ## is.finite(xsh1 <- x^(shape-1)) & ## !is.na(r <- xsh1 * exp(-(x/scale)) / (scale^shape * exp(lgam.sh))) ## r[!ok] <- exp(ldgamma(x[!ok], shape[!ok], scale[!ok])) ## r exp(ldgamma(x, shape, scale)) } } else stop("(x, shape, scale) must be numeric or \"mpfr\"") }## {dgamma} dchisq <- function(x, df, log = FALSE) dgamma(x, df / 2, scale = 2, log) pgamma <- function(q, shape, rate = 1, scale = 1/rate, lower.tail = TRUE, log.p = FALSE, rnd.mode = c('N','D','U','Z','A')) { if (!missing(rate) && !missing(scale)) { if (abs(rate * scale - 1) < 1e-15) warning("specify 'rate' or 'scale' but not both") else stop ("specify 'rate' or 'scale' but not both") } if(is.numeric(q) && is.numeric(shape) && is.numeric(scale)) return(stats__pgamma(q, shape, scale=scale, lower.tail=lower.tail, log.p=log.p)) ## else rnd.mode <- match.arg(rnd.mode) if((sh.mp <- is.mpfr(shape)) | (sc.mp <- is.mpfr(scale)) || is.mpfr(q)) { if(!sh.mp || !sc.mp) { prec <- pmax(53, getPrec(shape), getPrec(scale), getPrec(q)) # *vector* if(!sh.mp) shape <- mpfr(shape, prec) else ## !sc.mp : scale <- mpfr(scale, prec) } } ## for now, "cheap", relying on "mpfr" arithmetic to be smart ## work via igamma() above --> ../man/igamma.Rd ## igamma(a,q) == gamma(a) * pgamma(q, a, lower.tail=FALSE) if(lower.tail) { # will quickly suffer from cancellation |--> 1-1 = 0 or log1p(-1) = -Inf : if(log.p) log1p( - igamma(shape, q/scale, rnd.mode=rnd.mode) / gamma(shape)) else 1 - igamma(shape, q/scale, rnd.mode=rnd.mode) / gamma(shape) } else { # lower.tail = FALSE --> use igamma() directly if(log.p) log(igamma(shape, q/scale, rnd.mode=rnd.mode)) - lgamma(shape) else if(any(Lsh <- shape > 4e7)) { # even gamma() eventually overflows ## could expand exponenetial range ("erange") but typically *not* on Windows q <- q/scale r <- q + 0*shape # mpfr of full length if(length(Lsh) < (n <- length(r))) { # recycle: Lsh <- rep_len(Lsh, n) shape <- rep_len(shape, n) } r[Lsh] <- exp(log(igamma(shape[Lsh], q[Lsh], rnd.mode=rnd.mode)) - lgamma(shape[Lsh])) S <- !Lsh r[S] <- igamma(shape[S], q[S], rnd.mode=rnd.mode) / gamma(shape[S]) } else # non-large shape igamma(shape, q/scale, rnd.mode=rnd.mode) / gamma(shape) } }## {pgamma} ## zeta() zeta <- function(x) { if(!inherits(x, "mpfr")) x <- as(x, "mpfr") # keep "mpfrArray" x@.Data[] <- .Call(Math_mpfr, x, .Math.codes[["zeta"]]) x } ## "FIXME" -- rather use 'bigq' in gmp and the "sumBin" algorithm from copula! Bernoulli <- function(k, precBits = 128) { ## Purpose: Bernoulli Numbers (in high precision) ## ----------------------------------------------------------- ## Arguments: k: non-negative integer vector ## ----------------------------------------------------------- ## Author: Martin Maechler, Date: 12 Dec 2008, 11:35 stopifnot(all(k >= 0), k == as.integer(k)) r <- - k * zeta(if(is.mpfr(k)) 1 - k else mpfr(1 - k, precBits=precBits)) if(any(k0 <- k == 0)) r[k0] <- mpfr(1, precBits=precBits) r } ## eint() "Exponential integral" Ei <- function(x) { if(!inherits(x, "mpfr")) x <- as(x, "mpfr") # keep "mpfrArray" x@.Data[] <- .Call(Math_mpfr, x, .Math.codes[["Eint"]]) x } ## Li_2() the dilogarithm Li2 <- function(x) { if(!inherits(x, "mpfr")) x <- as(x, "mpfr") # keep "mpfrArray" x@.Data[] <- .Call(Math_mpfr, x, .Math.codes[["Li2"]]) x } ### ------------- Bessel: --------- ## j0, j1, jn ## y0, y1, yn j0 <- function(x) { if(!inherits(x, "mpfr")) x <- as(x, "mpfr") # keep "mpfrArray" x@.Data[] <- .Call(Math_mpfr, x, .Math.codes[["j0"]]) x } j1 <- function(x) { if(!inherits(x, "mpfr")) x <- as(x, "mpfr") x@.Data[] <- .Call(Math_mpfr, x, .Math.codes[["j1"]]) x } y0 <- function(x) { if(!inherits(x, "mpfr")) x <- as(x, "mpfr") x@.Data[] <- .Call(Math_mpfr, x, .Math.codes[["y0"]]) x } y1 <- function(x) { if(!inherits(x, "mpfr")) x <- as(x, "mpfr") x@.Data[] <- .Call(Math_mpfr, x, .Math.codes[["y1"]]) x } Ai <- function(x) { if(!inherits(x, "mpfr")) x <- as(x, "mpfr") x@.Data[] <- .Call(Math_mpfr, x, .Math.codes[["Ai"]]) x } jn <- function(n, x, rnd.mode = c('N','D','U','Z','A')) { if(!inherits(x, "mpfr")) x <- as(x, "mpfr") x@.Data[] <- .Call(R_mpfr_jn, x, n, match.arg(rnd.mode)) x } yn <- function(n, x, rnd.mode = c('N','D','U','Z','A')) { if(!inherits(x, "mpfr")) x <- as(x, "mpfr") x@.Data[] <- .Call(R_mpfr_yn, x, n, match.arg(rnd.mode)) x } ###-------- 2-argument cases ------- ## We want to automatically construct the methods needed: ## But atan2() as argument list and signature (y, x) ## where beta() and lbeta() have (a,b) --> cannot treat them identically; ## and treat atan2() speparately ## NB: atan2(), beta() and lbeta() all have implicitGeneric()s in methods with no '...' ## == ---> canNOT have 3rd argument : rnd.mode = c('N','D','U','Z','A') ## ---> using "N" instead of match.arg(rnd.mode) setMethod("atan2", signature(y = "mpfr", x = "mpfr"), function(y, x) new("mpfr", .Call(R_mpfr_atan2, y, x, "N"))) setMethod("atan2", signature(y = "mpfr", x = "numeric"), function(y, x) new("mpfr", .Call(R_mpfr_atan2, y, .mpfr(x, 128L), "N"))) setMethod("atan2", signature(y = "numeric", x = "mpfr"), function(y, x) new("mpfr", .Call(R_mpfr_atan2, .mpfr(y, 128L), x, "N"))) setMethod("atan2", signature(y = "mpfr", x = "ANY"), function(y, x) new("mpfr", .Call(R_mpfr_atan2, y, as(x, "mpfr"), "N"))) setMethod("atan2", signature(y = "ANY", x = "mpfr"), function(y, x) new("mpfr", .Call(R_mpfr_atan2, as(y, "mpfr"), x, "N"))) setMethod("atan2", signature(y = "mpfrArray", x = "mpfrArray"), function(y, x) { if(dim(x) != dim(y)) stop("array dimensions differ") x@.Data[] <- .Call(R_mpfr_atan2, y, x, "N") x }) setMethod("atan2", signature(y = "mpfrArray", x = "ANY"), function(y, x) { if(length(y) %% length(x) != 0) stop("length of first argument (array) is not multiple of the second argument's one") y@.Data[] <- .Call(R_mpfr_atan2, y, if(is.numeric(x)) .mpfr(x, 128L) else as(x, "mpfr"), "N") y }) setMethod("atan2", signature(y = "ANY", x = "mpfrArray"), function(y, x) { if(length(x) %% length(y) != 0) stop("length of second argument (array) is not multiple of the first argument's one") x@.Data[] <- .Call(R_mpfr_atan2, if(is.numeric(y)) .mpfr(y, 128L) else as(y, "mpfr"), x, "N") x }) ## Using "macro" {instead of previous aux. function mpfrMath2setMeth.a.b() : for (ff in list(c("beta", "R_mpfr_beta"), c("lbeta", "R_mpfr_lbeta"))) eval(substitute( { setMethod(fname, signature(a = "mpfr", b = "mpfr"), function(a, b) new("mpfr", .Call(Csub, a, b, "N"))) setMethod(fname, signature(a = "mpfr", b = "numeric"), function(a, b) new("mpfr", .Call(Csub, a, .mpfr(b, 128L), "N"))) setMethod(fname, signature(a = "numeric", b = "mpfr"), function(a, b) new("mpfr", .Call(Csub, .mpfr(a, 128L), b, "N"))) setMethod(fname, signature(a = "mpfr", b = "ANY"), function(a, b) new("mpfr", .Call(Csub, a, as(b, "mpfr"), "N"))) setMethod(fname, signature(a = "ANY", b = "mpfr"), function(a, b) new("mpfr", .Call(Csub, as(a, "mpfr"), b, "N"))) setMethod(fname, signature(a = "mpfrArray", b = "mpfrArray"), function(a, b) { if(dim(b) != dim(a)) stop("array dimensions differ") b@.Data[] <- .Call(Csub, a, b, "N") b }) setMethod(fname, signature(a = "mpfrArray", b = "ANY"), function(a, b) { if(length(a) %% length(b) != 0) stop("length of first argument (array) is not multiple of the second argument's one") a@.Data[] <- .Call(Csub, a, if(is.numeric(b)) .mpfr(b, 128L) else as(b, "mpfr"), "N") a }) setMethod(fname, signature(a = "ANY", b = "mpfrArray"), function(a, b) { if(length(b) %% length(a) != 0) stop("length of second argument (array) is not multiple of the first argument's one") b@.Data[] <- .Call(Csub, if(is.numeric(a)) .mpfr(a, 128L) else as(a, "mpfr"), b, "N") b }) }, list(fname = ff[[1]], Csub = as.symbol(ff[[2]])))) ## hypot() hypot <- function(x,y, rnd.mode = c('N','D','U','Z','A')) { if(is(x, "mpfrArray") || is.array(x)) { if(is.array(x)) x <- mpfrArray(x, 128L, dim=dim(x), dimnames(x)) if(is.array(y)) y <- mpfrArray(y, 128L, dim=dim(y), dimnames(y)) if(is(y, "mpfrArray")) { if(dim(x) != dim(y)) stop("array dimensions differ") x@.Data[] <- .Call(R_mpfr_hypot, x, y, match.arg(rnd.mode)) x } else { ## y is not (mpfr)Array if(length(x) %% length(y) != 0) stop("length of first argument (array) is not multiple of the second argument's one") x@.Data[] <- .Call(R_mpfr_hypot, x, as(y, "mpfr"), match.arg(rnd.mode)) x } } else if(is(y, "mpfrArray")) { if(length(y) %% length(x) != 0) stop("length of second argument (array) is not multiple of the first argument's one") y@.Data[] <- .Call(R_mpfr_hypot, as(x, "mpfr"), y, match.arg(rnd.mode)) y } else new("mpfr", .Call(R_mpfr_hypot, as(x, "mpfr"), as(y, "mpfr"), match.arg(rnd.mode))) } ## The Beta(a,b) Cumulative Probabilities are exactly computable for *integer* (a,b) = (shape1,shape2): pbetaI <- function(q, shape1, shape2, ncp = 0, lower.tail = TRUE, log.p = FALSE, precBits = NULL, useRational = !log.p && !is.mpfr(q) && is.null(precBits) && int2, rnd.mode = c('N','D','U','Z','A')) { stopifnot(length(shape1) == 1, length(shape2) == 1, ## for now *error* if not both are integer; previously silently truncated (e.g. 'pi' to '3') (i1 <- is.whole(shape1)), (i2 <- is.whole(shape2)), shape1 >= 0, shape2 >= 0, length(lower.tail) == 1, length(log.p) == 1, 0 <= q, q <= 1, ncp == 0, is.null(precBits) || (is.numeric(precBits) && is.whole(precBits) && precBits >= 2)) int2 <- TRUE # was i1 && i2 # both integer -> can use rational ### TODO: Also have finite (but non-rational) sum if only *one* is an integer number ## Care for too large (a,b) and "integer overflow". ## NB: below have 0:(b - 1) or 0:(a - 1) max.ab <- 2^20 if(is.na(a <- as.integer(shape1)) || (!lower.tail && a > max.ab)) stop("a = shape1 is too large for 'lower.tail=FALSE' and the current algorithm") if(is.na(b <- as.integer(shape2)) || (lower.tail && b > max.ab)) stop("b = shape2 is too large for 'lower.tail=TRUE' and the current algorithm") n <- a + b - 1L if(!useRational) { pr.x <- getPrec(q, bigq. = 256L) if(is.null(precBits)) { aq <- abs(as.numeric(q)) mq <- if(any(po <- aq > 0)) min(aq[po]) else 1 # ==> log = 0 ## -n*log(|x|): such that 1 - |x|^n does not completely cancel precBits <- max(128L, pr.x, -as.numeric(n)*log(mq)) } if(pr.x < precBits || !is.mpfr(q)) q <- mpfr(q, precBits=precBits) mpfr1 <- list(.Call(const_asMpfr, 1, 16L, "N")) # as prototype for vapply() } F <- if(log.p) log else identity ## FIXME: logspace add sum lsum(.) should be more accurate for large n ==> could use larger a,b if(lower.tail) { ## The prob. is P[ X <= x ] = \sum_{k=a}^ n (n \\ k) x^k (1-x)^(n-k) ## but we want to sum from 0 {smallest --> largest} as well: ## P[ X <= x ] = \sum_{k=0}^{b-1} (n \\ k) (1-x)^k x^(n-k) k <- 0:(b - 1L) FUN.x <- function(x) sum(n.choose.k * (1-x)^k * x^(n-k)) } else { ## upper tail ## Prob. P[ X > q ] = 1 - P[X <= q ] = \sum_{k=0}^{a-1} (n \\ k) x^k (1-x)^(n-k) k <- 0:(a - 1L) FUN.x <- function(x) sum(n.choose.k * x^k * (1-x)^(n-k)) } n.choose.k <- chooseZ(n, k) if(useRational) { q <- as.bigq(q) if(length(q) == 1L) FUN.x(q) else c_bigq(lapply(q, FUN.x)) } else { # mpfr roundMpfr(F( ## "vapply() for "mpfr" new("mpfr", vapply(q, FUN.x, mpfr1))), ## reduce the precision, in order to not "claim wrongly": precBits=precBits, match.arg(rnd.mode)) } } ### MPFR version >= 3.2.0 : "https://www.mpfr.org/mpfr-current/mpfr.html#index-mpfr_005fgamma_005finc" ## ## >>> Note: the current implementation of mpfr_gamma_inc is slow for large values of rop or op, ## >>> ==== in which case some internal overflow might also occur. ## ## mpfr_gamma_inc(a,x) =: igamma(a,x) where ## ## igamma(a,x) = "upper" incomplete gamma Γ(a,x) :=: Γ(a) - γ(a,x); ## γ(a,x) = "lower" incomplete gamma γ(a,x) := ₀∫ˣ tᵃ⁻¹ e⁻ᵗ dt, and ## R's pgamma(x, a) :== γ(a,x) / Γ(a) ## ## >>> ../man/igamma.Rd <<< igamma <- function(a,x, rnd.mode = c('N','D','U','Z','A')) { if(mpfrVersion() < "3.2.0") stop("igamma()'s MPFR equivalent needs mpfr version >= 3.2.0, but mpfrVersion()=", mpfrVersion()) if(is(a, "mpfrArray") || is.array(a)) { if(is.array(a)) a <- mpfrArray(a, 128L, dim=dim(a), dimnames(a)) if(is.array(x)) x <- mpfrArray(x, 128L, dim=dim(x), dimnames(x)) if(is(x, "mpfrArray")) { if(dim(a) != dim(x)) stop("array dimensions differ") a@.Data[] <- .Call(R_mpfr_igamma, a, x, match.arg(rnd.mode)) a } else { ## x is not (mpfr)Array if(length(a) %% length(x) != 0) stop("length of first argument (array) is not multiple of the second argument's one") a@.Data[] <- .Call(R_mpfr_igamma, a, as(x, "mpfr"), match.arg(rnd.mode)) a } } else if(is(x, "mpfrArray")) { if(length(x) %% length(a) != 0) stop("length of second argument (array) is not multiple of the first argument's one") x@.Data[] <- .Call(R_mpfr_igamma, as(a, "mpfr"), x, match.arg(rnd.mode)) x } else new("mpfr", .Call(R_mpfr_igamma, as(a, "mpfr"), as(x, "mpfr"), match.arg(rnd.mode))) } ## only as long as we still may have mpfrVersion() < "3.2.0", e.g. in Fedora 30 (2019f) ## mpfrVersion() cannot be called at package build time (underlying C entry point not ready): ## if(mpfrVersion() < "3.2.0") ## dummy .. to pacify "R CMD check" ## R_mpfr_igamma <- quote(dummy) # gives NOTE ‘R_mpfr_igamma’ is of class "name" ## These are identical from package copuula/R/special-func.R -- where MM authored the function also: ## We want to export these, but cannot easily import from copula which "weekly depends" on Rmpfr ##' @title Compute f(a) = log(1 - exp(-a)) stably ##' @param a numeric vector of positive values ##' @param cutoff log(2) is optimal, see Maechler (201x) ..... ##' @return f(a) == log(1 - exp(-a)) == log1p(-exp(-a)) == log(-expm1(-a)) ##' @author Martin Maechler, May 2002 .. Aug. 2011 ##' @references Maechler(2012) ##' Accurately Computing log(1 - exp(-|a|)) Assessed by the Rmpfr package. ##' http://cran.r-project.org/web/packages/Rmpfr/vignettes/log1mexp-note.pdf ## MM: ~/R/Pkgs/Rmpfr/inst/doc/log1mexp-note.Rnw ##--> ../man/log1mexp.Rd log1mexp <- function(a, cutoff = log(2)) ## << log(2) is optimal >> { if(has.na <- any(ina <- is.na(a))) { y <- a a <- a[ok <- !ina] } if(any(a < 0))## a == 0 --> -Inf (in both cases) warning("'a' >= 0 needed") tst <- a <= cutoff r <- a r[ tst] <- log(-expm1(-a[ tst])) r[!tst] <- log1p(-exp(-a[!tst])) if(has.na) { y[ok] <- r ; y } else r } ##' @title Compute f(x) = log(1 + exp(x)) stably and quickly ##--> ../man/log1mexp.Rd log1pexp <- function(x, c0 = -37, c1 = 18, c2 = 33.3) { if(has.na <- any(ina <- is.na(x))) { y <- x x <- x[ok <- !ina] } r <- exp(x) if(any(i <- c0 < x & (i1 <- x <= c1))) r[i] <- log1p(r[i]) if(any(i <- !i1 & (i2 <- x <= c2))) r[i] <- x[i] + 1/r[i] # 1/exp(x) = exp(-x) if(any(i3 <- !i2)) r[i3] <- x[i3] if(has.na) { y[ok] <- r ; y } else r } Rmpfr/R/integrate-Romberg.R0000644000176200001440000001077212402301607015243 0ustar liggesusers#### Romberg integration in pure R #### =================== ====== so it can be used with Rmpfr ## TODO: Lauren K would like to get return()ed all the intermediate sums as well ## ---- I agree: but only if 'all.sums = TRUE' integrateR <- function(f, lower, upper, ..., ord = NULL, rel.tol = .Machine$double.eps^0.25, abs.tol = rel.tol, max.ord = 19, verbose = FALSE) { stopifnot(length(lower) == 1, length(upper) == 1, is.finite(lower), is.finite(upper)) f <- match.fun(f) ff <- ## if(verbose) function(x) { cat("f(x), x="); str(x) ; f(x, ...) } else function(x) f(x, ...) null.ord <- is.null(ord) ## ord := Romberg order has.tol <- !missing(rel.tol) || !missing(abs.tol)# one of them specified if(chkConv <- (null.ord || has.tol)) { ## will use rel.tol and abs.tol if (abs.tol <= 0 && rel.tol < max(50 * .Machine$double.eps, 5e-29)) stop("invalid tolerance values") ## but need (maximal) order for Bauer's algorithm: } if(null.ord && !has.tol) { ## This is "approximate" (and too large, typically); but if it's ## too small, t[.] will be extended automatically: ord <- ## == max(3, min(25, ceiling(-log2(rel.tol)))) with default rel.tol 13 if(verbose) cat("ord =", ord, "(as no '*.tol' specified)\n") } useOrd <- !null.ord || !has.tol if(useOrd) { stopifnot(ord >= 0) if(verbose) cat(sprintf( " ord = %d; ==> evaluating integrand at %s 2^(ord+1)-2 = %d locations\n", ord, if(chkConv) "up to" else "", 2^(ord+1)-2)) } ### Bauer(1961) "Algorithm 60 -- Romberg Integration" Comm.ACM 4(6), p.255 m <- le <- upper - lower # 'l' ## a "hack", but really improves the result: if(!is.numeric(m)) { if(is(m, "mpfr")) { # should get *same* precision if(is.numeric(lower)) lower <- 0*m+ lower if(is.numeric(upper)) upper <- 0*m+ upper } else { ## other high-precision... if(is.numeric(lower)) lower <- as(lower, class(m)) if(is.numeric(upper)) upper <- as(upper, class(m)) } } t1 <- (ff(lower) + ff(upper))/2 t <- rep(t1, if(useOrd) ord+1 else 10)## <- must work for "mpfr" numbers one <- 1 + 0*t1 # for "mpfr" r. <- t[1]*le n <- 1 # 'n'(Bauer) = 2^n (Romberg Algo) if(verbose) { ## In "mpfr" case, cannot use sprintf("%g"); ## ==> rather use format(.) with higher number of digits prDigs <- max(10, min(50, 2 + ceiling(-log10(rel.tol)))) FORM <- paste0("n=%2d, 2^n=%9.0f | I = %",(5+prDigs), "s, abs.err =%14s\n") } h <- 1L repeat { if(verbose >= 2) { cat("range(le*t[1:h]):\n\t"); print(format(range(le*t[1:h]), digits=15), quote=FALSE) } u <- 0 m <- m/2 # == le/(2*n) ## here, we require f(.) to be vectorized: u <- sum(ff(lower+ seq(1, 2*n-1, by=2)*m)) t[h+1L] <- (u/n + t[h])/2 f. <- one for(j in h:1) { f. <- 4*f. t[j] <- t[j+1] + (t[j+1] - t[j])/ (f. - 1) } r <- t[1]*le aErr <- abs(r - r.) if(verbose) cat(sprintf(FORM, h, 2*n, format(r, digits = prDigs), format(aErr, digits = max(7, getOption("digits"))))) if(chkConv) { ## check if we converged: |r - r.| < min(.,.): *both* tolerances must be satisfied if(converged <- (aErr < min(abs(r)*rel.tol, abs.tol))) break } if((useOrd && h >= ord) || h >= max.ord) break r. <- r n <- 2*n # == 2^h h <- h+1L } if(chkConv && !converged) { relE <- format(aErr/abs(r), digits=getOption("digits")) msg <- paste0("no convergence up to order ", ord, "; last relative change = ", relE, "\n", "Consider setting 'ord = ' (e.g. = ", ord+1,").") warning(msg) } else msg <- "OK" r <- list(value = r, abs.error = aErr, subdivisions = 2*n+1, "message" = msg, call = match.call()) class(r) <- c("integrateR", "integrate") r } ## This is such that print.integrate() calls our format() method ## (and do *not* hide it via S3method() in NAMESPACE): ## print.integrate <- getS3method("print","integrate")# from 'stats' possibly not exported ## environment(print.integrate) <- environment() ## setMethod(show, "integrate", function(object) print.integrate(object)) print.integrateR <- function (x, digits = max(3, getOption("digits")-2), ...) { if(x[["message"]] != "OK") cat("Non-convergence message ", sQuote(x$message), "\n", sep = "") ## The "Ok" message: cat(format(x$value, digits = digits), " with absolute error < ", format(x$abs.error, digits=digits), "\n", sep = "") invisible(x) } setMethod(show, "integrateR", function(object) print.integrateR(object)) Rmpfr/R/Arith.R0000644000176200001440000002600613752265550012751 0ustar liggesusers#### Define mpfr methods for Arith + Compare + Logic group functions #### ====== ======= ===== ### "Math" are done in ./Math.R , "Summary" in ./Summary.R ### ---- ~~~~~~ ------- ~~~~~~~~~ ### NB: Look at /usr/local/app/R/R_local/src/Brobdingnag/R/brob.R ### ----------- ##' return 'x' unless it is NULL where you'd use 'orElse' `%||%` <- function(x, orElse) if(!is.null(x)) x else orElse if(FALSE) { print(getGroupMembers("Ops"))# "Arith" "Compare" "Logic" .Ops.list <- sapply(getGroupMembers("Ops"), getGroupMembers, simplify=FALSE) str(.Ops.list, vec.len = 20) ## $ Arith : chr [1:7] "+" "-" "*" "^" "%%" "%/%" "/" ## $ Compare: chr [1:6] "==" ">" "<" "!=" "<=" ">=" ## $ Logic : chr [1:2] "&" "|" } ## Using "vector" and "array" seperately, rather than "ANY" ## ===> shorter distance in method dispatch calculation : setMethod("Ops", signature(e1 = "mpfr", e2 = "vector"), function(e1, e2) callGeneric(e1, as(e2, "numeric"))) setMethod("Ops", signature(e1 = "vector", e2 = "mpfr"), function(e1, e2) callGeneric(as(e1, "numeric"), e2)) ## These should not trigger anymore (because we have "Arith"/"Compare"/...): setMethod("Ops", signature(e1 = "mpfr", e2 = "array"), function(e1, e2) stop(gettextf("'%s'(mpfr,array) method is not implemented yet", .Generic))) setMethod("Ops", signature(e1 = "array", e2 = "mpfr"), function(e1, e2) stop(gettextf("'%s'(array,mpfr) method is not implemented yet", .Generic))) setMethod("Ops", signature(e1 = "mpfr", e2 = "bigz"), function(e1, e2) callGeneric(e1, .bigz2mpfr(e2))) setMethod("Ops", signature(e1 = "bigz", e2 = "mpfr"), function(e1, e2) callGeneric(.bigz2mpfr(e1), e2)) # ..bigq2mpfr(q, NULL) determines the necessary precision for q : setMethod("Ops", signature(e1 = "mpfr", e2 = "bigq"), function(e1, e2) callGeneric(e1, ..bigq2mpfr(e2, NULL))) setMethod("Ops", signature(e1 = "bigq", e2 = "mpfr"), function(e1, e2) callGeneric(..bigq2mpfr(e1, NULL), e2)) setMethod("Logic", signature(e1 = "mpfr", e2 = "mpfr"), function(e1, e2) callGeneric(as(e1, "numeric"), as(e2, "numeric"))) setMethod("Logic", signature(e1 = "mpfr", e2 = "numeric"), function(e1, e2) callGeneric(as(e1, "numeric"), e2)) setMethod("Logic", signature(e1 = "numeric", e2 = "mpfr"), function(e1, e2) callGeneric(e1, as(e2, "numeric"))) ## FIXME?: probably also need etc ###-- 2) ----------- Arith -------------------------------------------------- ## R version, no longer used: .mpfr_negativeR <- function(x) { xD <- getDataPart(x)# << currently [2011] *faster* than x@Data for(i in seq_along(x)) slot(xD[[i]], "sign", check=FALSE) <- - xD[[i]]@sign setDataPart(x, xD, check=FALSE) ## faster than x@Data <- xD } .mpfr_negative <- function(x) .Call(Rmpfr_minus, x) setMethod("Arith", signature(e1 = "mpfr", e2="missing"), function(e1,e2) { switch(.Generic, "+" = e1, "-" = .mpfr_negative(e1), stop(paste("Unary operator", .Generic, "not defined for \"mpfr\" numbers")) ) } ) .Arith.codes <- c("+" = 1, "-" = 2, "*" = 3, "^" = 4, "%%" = 5, "%/%" =6, "/" = 7) storage.mode(.Arith.codes) <- "integer" setMethod("Arith", signature(e1 = "mpfr", e2 = "mpfr"), function(e1, e2) { new("mpfr", .Call(Arith_mpfr, e1, e2, .Arith.codes[.Generic])) }) setMethod("Arith", signature(e1 = "mpfr", e2 = "integer"), function(e1, e2) { new("mpfr", .Call(Arith_mpfr_i, e1, e2, .Arith.codes[.Generic])) }) setMethod("Arith", signature(e1 = "integer", e2 = "mpfr"), function(e1, e2) { new("mpfr", .Call(Arith_i_mpfr, e1, e2, .Arith.codes[.Generic])) }) setMethod("Arith", signature(e1 = "mpfr", e2 = "numeric"),# not "integer" function(e1, e2) { new("mpfr", .Call(Arith_mpfr_d, e1, e2, .Arith.codes[.Generic])) }) setMethod("Arith", signature(e1 = "numeric", e2 = "mpfr"),# not "integer function(e1, e2) { new("mpfr", .Call(Arith_d_mpfr, e1, e2, .Arith.codes[.Generic])) }) ###-- 3) ----------- Compare -------------------------------------------------- .Compare.codes <- c("==" = 1, ">" = 2, "<" = 3, "!=" = 4, "<=" = 5, ">=" =6) storage.mode(.Compare.codes) <- "integer" ## Define "Reverse" codes such that, e.g., ## .Compare.codes[ .Compare.codesRev[">="] ] |--> "<=" .Compare.codesRev <- .Compare.codes # names() in same order; indices swapped: .Compare.codesRev[] <- .Compare.codes[c(1, 3:2, 4, 6:5)] setMethod("Compare", signature(e1 = "mpfr", e2 = "mpfr"), function(e1, e2) { .Call(Compare_mpfr, e1, e2, .Compare.codes[.Generic]) }) setMethod("Compare", signature(e1 = "mpfr", e2 = "integer"), function(e1, e2) { .Call(Compare_mpfr_i, e1, e2, .Compare.codes[.Generic]) }) setMethod("Compare", signature(e1 = "mpfr", e2 = "numeric"),# not "integer" function(e1, e2) { .Call(Compare_mpfr_d, e1, e2, .Compare.codes[.Generic]) }) setMethod("Compare", signature(e1 = "integer", e2 = "mpfr"), function(e1, e2) { .Call(Compare_mpfr_i, e2, e1, .Compare.codesRev[.Generic]) }) setMethod("Compare", signature(e1 = "numeric", e2 = "mpfr"), function(e1, e2) { .Call(Compare_mpfr_d, e2, e1, .Compare.codesRev[.Generic]) }) ### -------------- mpfrArray ------------------------ .dimCheck <- function(a, b) { da <- dim(a) db <- dim(b) if(length(da) != length(db) || any(da != db)) stop(gettextf("Matrices must have same dimensions in %s", deparse(sys.call(sys.parent()))), call. = FALSE) da } setMethod("Arith", signature(e1 = "mpfrArray", e2 = "mpfrArray"), function(e1, e2) { .dimCheck(e1, e2) ## else: result has identical dimension: e1@.Data[] <- .Call(Arith_mpfr, e1, e2, .Arith.codes[.Generic]) e1 }) setMethod("Arith", signature(e1 = "mpfrArray", e2 = "mpfr"), function(e1, e2) { if(length(e1) %% length(e2) != 0) stop("length of first argument (array) is not multiple of the second argument's one") ## else: result has dimension from array: e1@.Data[] <- .Call(Arith_mpfr, e1, e2, .Arith.codes[.Generic]) e1 }) ## "macro-like encapsulation" -- using .Call(, *) for checks .Arith.num.mpfr <- function(x,y, FUN) { if(is.integer(x)) .Call(Arith_i_mpfr, x,y, .Arith.codes[FUN]) else .Call(Arith_d_mpfr, x,y, .Arith.codes[FUN]) } .Arith.mpfr.num <- function(x,y, FUN) { if(is.integer(y)) .Call(Arith_mpfr_i, x,y, .Arith.codes[FUN]) else .Call(Arith_mpfr_d, x,y, .Arith.codes[FUN]) } .Compare.num.mpfr <- function(x,y, FUN) { if(is.integer(x)) .Call(Compare_mpfr_i, y,x, .Compare.codesRev[FUN]) else .Call(Compare_mpfr_d, y,x, .Compare.codesRev[FUN]) } .Compare.mpfr.num <- function(x,y, FUN) { if(is.integer(y)) .Call(Compare_mpfr_i, x,y, .Compare.codes[FUN]) else .Call(Compare_mpfr_d, x,y, .Compare.codes[FUN]) } setMethod("Arith", signature(e1 = "array", e2 = "mpfr"),# incl "mpfrArray" function(e1, e2) { if(e2Arr <- !is.null(dim(e2))) .dimCheck(e1, e2) else if(length(e1) %% length(e2) != 0) stop("length of first argument (array) is not multiple of the second argument's one") if(e2Arr) { e2@.Data[] <- .Arith.num.mpfr(e1, e2, .Generic) e2 } else { r <- new("mpfrArray") r@Dim <- dim(e1) if(!is.null(dn <- dimnames(e1))) r@Dimnames <- dn r@.Data <- .Arith.num.mpfr(e1, e2, .Generic) r } }) setMethod("Arith", signature(e1 = "mpfr", e2 = "array"),# "mpfr" incl "mpfrArray" function(e1, e2) { if(e1Arr <- !is.null(dim(e1))) .dimCheck(e1, e2) else if(length(e2) %% length(e1) != 0) stop("length of second argument (array) is not multiple of the first argument's one") if(e1Arr) { e1@.Data[] <- .Arith.mpfr.num(e1, e2, .Generic) e1 } else { r <- new("mpfrArray") r@Dim <- dim(e2) if(!is.null(dn <- dimnames(e2))) r@Dimnames <- dn r@.Data <- .Arith.mpfr.num(e1, e2, .Generic) r } }) setMethod("Arith", signature(e1 = "mpfrArray", e2 = "numeric"), function(e1, e2) { if(length(e1) %% length(e2) != 0) stop("length of first argument (array) is not multiple of the second argument's one") e1@.Data[] <- .Arith.mpfr.num(e1, e2, .Generic) e1 }) setMethod("Arith", signature(e1 = "numeric", e2 = "mpfrArray"), function(e1, e2) { if(length(e2) %% length(e1) != 0) stop("length of second argument (array) is not multiple of the first argument's one") e2@.Data[] <- .Arith.num.mpfr(e1, e2, .Generic) e2 }) setMethod("Arith", signature(e1 = "mpfr", e2 = "mpfrArray"), function(e1, e2) { if(length(e2) %% length(e1) != 0) stop("length of second argument (array) is not multiple of the first argument's one") e2@.Data[] <- .Call(Arith_mpfr, e1, e2, .Arith.codes[.Generic]) e2 }) setMethod("Compare", signature(e1 = "mpfrArray", e2 = "mpfr"), function(e1, e2) { if(is.null(dim(e2))) { if(length(e1) %% length(e2) != 0) stop("length of first argument (array) is not multiple of the second argument's one") } else .dimCheck(e1, e2) structure(.Call(Compare_mpfr, e1, e2, .Compare.codes[.Generic]), dim = dim(e1), dimnames = dimnames(e1)) }) setMethod("Compare", signature(e1 = "mpfr", e2 = "mpfrArray"), function(e1, e2) { if(is.null(dim(e1))) { if(length(e2) %% length(e1) != 0) stop("length of second argument (array) is not multiple of the first argument's one") } else .dimCheck(e1, e2) structure(.Call(Compare_mpfr, e1, e2, .Compare.codes[.Generic]), dim = dim(e2), dimnames = dimnames(e2)) }) setMethod("Compare", signature(e1 = "mpfr", e2 = "array"),# "mpfr" incl "mpfrArray" function(e1, e2) { if(is.null(dim(e1))) { if(length(e2) %% length(e1) != 0) stop("length of second argument (array) is not multiple of the first argument's one") } else .dimCheck(e1, e2) structure(.Compare.mpfr.num(e1, e2, .Generic), dim = dim(e2), dimnames = dimnames(e2)) }) setMethod("Compare", signature(e1 = "array", e2 = "mpfr"),# incl "mpfrArray" function(e1, e2) { if(is.null(dim(e2))) { if(length(e1) %% length(e2) != 0) stop("length of first argument (array) is not multiple of the second argument's one") } else .dimCheck(e1, e2) structure(.Compare.num.mpfr(e1, e2, .Generic), dim = dim(e1), dimnames = dimnames(e1)) }) setMethod("Compare", signature(e1 = "mpfrArray", e2 = "numeric"),# incl integer function(e1, e2) { if(length(e1) %% length(e2) != 0) stop("length of first argument (array) is not multiple of the second argument's one") structure(.Compare.mpfr.num(e1, e2, .Generic), dim = dim(e1), dimnames = dimnames(e1)) }) setMethod("Compare", signature(e1 = "numeric", e2 = "mpfrArray"), function(e1, e2) { if(length(e2) %% length(e1) != 0) stop("length of second argument (array) is not multiple of the first argument's one") structure(.Compare.num.mpfr(e1, e2, .Generic), dim = dim(e2), dimnames = dimnames(e2)) }) Rmpfr/R/zzz.R0000644000176200001440000000247714022105500012520 0ustar liggesusers## Not exported, and only used because CRAN checks must be faster doExtras <- function() { interactive() || nzchar(Sys.getenv("R_Rmpfr_check_extra")) || identical("true", unname(Sys.getenv("R_PKG_CHECKING_doExtras"))) } .onAttach <- function(libname, pkgname) { packageStartupMessage(sprintf("C code of R package 'Rmpfr': GMP using %d bits per limb\n", .mpfr_gmp_numbbits())) } .onLoad <- function(libname, pkgname) { if(mpfrVersion() < "3.0.0") warning("MPFR C library version ", format(mpfrVersion()), " is outdated, and minor functionality will be missing.\n", " Consider installing a newer version of MPFR (e.g., from mpfr.org),\n", " and re-install the R package Rmpfr after that.", call.=FALSE) } if(packageVersion("gmp") < "0.6-1") local({ ## need c_bigz() and c_bigq() already now env <- asNamespace("gmp") getGmp <- function(x) get(x, envir=env, inherits=FALSE) biginteger_c <- getGmp("biginteger_c") bigrational_c <- getGmp("bigrational_c") rm(env, getGmp) c_bigz <<- function(L) .Call(biginteger_c, L) c_bigq <<- function(L) .Call(bigrational_c, L) }) if(getRversion() < "4.0") { ## deparse(.) returning *one* string deparse1 <- function(expr, collapse = " ", width.cutoff = 500L, ...) paste(deparse(expr, width.cutoff, ...), collapse=collapse) } Rmpfr/R/mpfr.R0000644000176200001440000007463715075433454012663 0ustar liggesusers#### All methods for "mpfr" (and "mpfr1") class #### apart from coercions and the group methods setMethod("is.finite", "mpfr", function(x) .Call(R_mpfr_is_finite, x)) setMethod("is.infinite", "mpfr", function(x) .Call(R_mpfr_is_infinite, x)) ## MPFR has only "NaN" ( == "NA" -- hence these two are identical : setMethod("is.na", "mpfr", function(x) .Call(R_mpfr_is_na, x)) setMethod("is.nan", "mpfr", function(x) .Call(R_mpfr_is_na, x)) mpfrIs0 <- function(x) { if(is(x, "mpfrArray")) .Call(R_mpfr_is_zero_A, x) else .Call(R_mpfr_is_zero, x) ## sapply(x, function(.) .@exp == - .Machine$integer.max) } mpfr.is.0 <- function(x) { .Deprecated("mpfrIs0") mpfrIs0(x) } .mpfr.is.whole <- function(x) { if(is(x, "mpfrArray")) .Call(R_mpfr_is_integer_A, x) else .Call(R_mpfr_is_integer, x) } mpfr.is.integer <- function(x) { .Deprecated(".mpfr.is.whole") .mpfr.is.whole(x) } ## is.whole() is now S3 generic, with default method in gmp ## is.whole <- function(x) { ## if(is.integer(x) || is.logical(x)) rep.int(TRUE, length(x)) ## else if(is.numeric(x)) x == floor(x) ## else if(is.complex(x)) x == round(x) ## else if(is(x,"mpfr")) .mpfr.is.whole(x) ## else rep.int(FALSE, length(x)) ## } is.whole.mpfr <- function(x) .mpfr.is.whole(x) ## The above for "mpfrArray" : setMethod("is.finite", "mpfrArray", function(x) .Call(R_mpfr_is_finite_A, x)) setMethod("is.infinite", "mpfrArray", function(x) .Call(R_mpfr_is_infinite_A, x)) ## MPFR has only "NaN" ( == "NA" -- hence these two are identical : setMethod("is.na", "mpfrArray", function(x) .Call(R_mpfr_is_na_A, x)) setMethod("is.nan", "mpfrArray", function(x) .Call(R_mpfr_is_na_A, x)) mpfr_default_prec <- function(prec) { if(missing(prec) || is.null(prec)) .Call(R_mpfr_get_default_prec) else { stopifnot((prec <- as.integer(prec[1])) > 0) .Call(R_mpfr_set_default_prec, prec) } } .mpfr_minPrec <- function() .Call(R_mpfr_prec_range, 1L) .mpfr_maxPrec <- function() .Call(R_mpfr_prec_range, 2L) ## must be sync'ed with enum def. in R_mpfr_get_erange in ../src/utils.c .mpfr_erange_kinds <- c("Emin", "Emax", "min.emin", "max.emin", "min.emax", "max.emax") ## _erange_codes <- seq_along(.mpfr_erange_kinds) .mpfr_erange <- function(kind = c("Emin", "Emax"), names = TRUE) { if(anyNA(ikind <- match(kind, .mpfr_erange_kinds)) || !length(kind)) stop("'kind' must have entries from ", paste(paste0('"', .mpfr_erange_kinds, '"'), collapse=", ")) r <- .Call(R_mpfr_get_erange, ikind) if(names) names(r) <- .mpfr_erange_kinds[ikind] r } ## NB: This now works to set *both* kinds, simultaneously .mpfr_erange_set <- function(kind = c("Emin", "Emax"), value) { kind <- match.arg(kind, several.ok=TRUE) stopifnot(length(kind) == length(value)) ## value can be double, and need be for "64-bit long" invisible(vapply(seq_along(kind), function(j) .Call(R_mpfr_set_erange, match(kind[[j]], c("Emin", "Emax")), value[[j]]), ## returns error codes from MPFR; 0 is good integer(1)) == 0L) } .mpfr_erange_is_int <- function() .Call(R_mpfr_erange_int_p) .mpfr_gmp_numbbits <- function() .Call(R_mpfr_get_GMP_numb_bits) .mpfrVersion <- function() .Call(R_mpfr_get_version) mpfrVersion <- function() numeric_version(sub("^([0-9]+\\.[0-9]+\\.[0-9]+).*","\\1", .mpfrVersion())) .mpfrSizeof <- function() .Call(R_mpfr_get_sizeof) print.mpfr1 <- function(x, digits = NULL, drop0trailing = TRUE, ...) { stopifnot(is(x, "mpfr1"), is.null(digits) || digits >= 1) cat("'mpfr1' ", format(as(x, "mpfr"), digits=digits, drop0trailing=drop0trailing), "\n", sep="") invisible(x) } setMethod(show, "mpfr1", function(object) print.mpfr1(object)) if(FALSE) ## no longer -- as R CMD check complains about use of non-API R_Outputfile ## For testing, debugging etc if(.Platform$OS.type != "windows") {## No R_Outputfile (in C) on Windows .print.mpfr <- function(x, digits = NA, ...) { stopifnot(is.mpfr(x), is.na(digits) || digits >= 1) ## digits = NA --> the inherent precision of x will be used if(length(x) >= 1) .Call(print_mpfr, x, as.integer(digits)) invisible(x) } }# non-Windows only ## a faster version of getDataPart(.) - as we *KNOW* we have a list ## !! If ever the internal representation of such S4 objects changes, this can break !! getD <- function(x) { attributes(x) <- NULL; x } getD <- function(x) `attributes<-`(x, NULL) ## Get or Set the C-global 'R_mpfr_debug_' variable: .mpfr_debug <- function(i = NA) .Call(R_mpfr_set_debug, as.integer(i)) ## CAREFUL: keep digits, max.digits, ... defaults in sync with ## print.mpfrArray() in ./array.R print.mpfr <- function(x, digits = NULL, drop0trailing = TRUE, right = TRUE, max.digits = getOption("Rmpfr.print.max.digits", 999L), exponent.plus = getOption("Rmpfr.print.exponent.plus", TRUE), ...) { stopifnot(is.mpfr(x), is.null(digits) || digits >= 1) ## digits = NULL --> the inherent precision of x will be used n <- length(x) ch.prec <- if(n >= 1) { rpr <- range(.getPrec(x)) paste("of precision ", rpr[1], if(rpr[1] != rpr[2]) paste("..",rpr[2]), " bits") } cat(n, "'mpfr'", if(n == 1) "number" else "numbers", ch.prec, "\n") if(n >= 1) { ## drop arguments for print.default(*): lFormat <- function(x, na.print, print.gap, max, useSource, ...) format(x, digits=digits, max.digits=max.digits, drop0trailing=drop0trailing, exponent.plus=exponent.plus, ...) print(lFormat(x, ...), ..., right=right, quote = FALSE) } invisible(x) } setMethod(show, "mpfr", function(object) print.mpfr(object)) ## Proposal by Serguei Sokol in order to make diag() work: if(FALSE)## << MM is in line with our "as.matrix" methods, but is extreme setMethod("is.matrix", "mpfr", function(x) length(dim(x)) == 2L) ## e.g. M0 <- (M <- cbind(mpfr(1.1, 100)^(98:99)))[,FALSE]; diag(M0) ## gives list() instead of length 0 mpfr ## For matrix indexing: matrix i |--> regular i : .mat2ind <- function(i, dim.x, dimnms.x) { ndx <- length(dim.x) if(!is.null(di <- dim(i))) { if(di[2L] == ndx) { ## k-column Matrix subsetting for array of rank k if(is.character(i)) { i <- vapply(seq_along(dim.x), function(j) match(i[,j], dimnms.x[[j]]), seq_len(di[1])) if(any(is.na(i))) stop("character matrix index out of limits") } i <- if(is.numeric(i)) i[,1L] + colSums(t(i[,-1L]-1L)* cumprod(dim.x)[-ndx]) else getD(i) } else { i <- getD(i) } } i } ## "[" which also keeps names ... JMC says that names are not support(ed|able) ## --- for such objects.. .mpfr.subset <- function(x,i,j, ..., drop) { nA <- nargs() if(nA == 2) { ## x[i] etc -- vector case -- to be fast, need C! -- ## i <- .mat2ind(i, dim(x), dimnames(x)) xd <- structure(getD(x)[i], names = names(x)[i]) if(any(iN <- vapply(xd, is.null, NA))) # e.g. i > length(x) xd[iN] <- mpfr(NA, precBits = 2L) ## faster than { x@.Data <- xd ; x }: setDataPart(x, xd, check=FALSE) } else if(nA == 3 && !is.null(d <- dim(x))) { ## matrix indexing(!) ## not keeping dimnames though ... message("nargs() == 3 'mpfr' array indexing ... ") new("mpfr", structure(getD(x)[i,j,...,drop=drop], dim = d)) ## keeping dimnames: maybe try ## D <- getD(x); dim(D) <- d ## if(!is.null(dn <- dimnames(x))) dimnames(D) <- dn ## D <- D[i,,drop=drop] ## new("mpfr", D) } else stop(gettextf("invalid 'mpfr' subsetting (nargs = %d)",nA)) } ## .mpfr.subset() .mpfr.msubset <- function(x,i,j, ..., drop) { nA <- nargs() if(nA == 2) { i <- .mat2ind(i, dim(x), dimnames(x)) xd <- structure(getD(x)[i], names=names(x)[i]) if(any(iN <- vapply(xd, is.null, NA))) # e.g. i > length(x) xd[iN] <- mpfr(NA, precBits = 2L) ## faster than { x@.Data <- xd ; x }: setDataPart(x[i], xd, check=FALSE) } else stop(gettext("invalid 'mpfr' matrix subsetting with a matrix (nargs = %d)",nA)) } ## .mpfr.msubset() ### ---------- FIXME: ./array.R has other "mpfrArray" methods for "[" and "[<-" !!!!!!----------- setMethod("[", signature(x = "mpfr", i = "ANY", j = "missing", drop = "missing"), .mpfr.subset) setMethod("[", signature(x = "mpfrArray", i = "matrix", j = "missing", drop = "missing"), .mpfr.msubset) setMethod("[[", signature(x = "mpfr", i = "ANY"), function(x,i) { if(length(i) > 1L) # give better error message than x@.Data[[i]] would: stop("attempt to select more than one element") xd <- getD(x)[[i]] # also gives error when i is "not ok" ## faster than { x@.Data <- list(xd) ; x } setDataPart(x, list(xd), check=FALSE) }) ## "[<-" : .mpfr.repl <- function(x, i, ..., value, check = TRUE) { if(length(list(...))) ## should no longer happen: stop("extra replacement arguments ", deparse(list(...)), " not dealt with") ## if(!missing(i)) i <- .mat2ind(i, dim(x), dimnames(x)) n <- length(xD <- getD(x)) xD[i] <- value if((nn <- length(xD)) > n+1) ## must "fill" the newly created NULL entries xD[setdiff((n+1):(nn-1), i)] <- mpfr(NA, precBits = 2L) setDataPart(x, xD, check=check) } ## FIXME: Should not need this; rather add .mat2ind to .mpfr.repl() above .mpfr.mrepl <- function(x, i, ..., value, check=TRUE) { if(length(list(...))) ## should no longer happen: stop("extra replacement arguments ", deparse(list(...)), " not dealt with") i <- .mat2ind(i, dim(x), dimnames(x)) n <- length(xD <- getD(x)) xD[i] <- value if((nn <- length(xD)) > n+1) ## must "fill" the newly created NULL entries xD[setdiff((n+1):(nn-1), i)] <- mpfr(NA, precBits = 2L) setDataPart(x, xD, check=check) } ## value = "mpfr" setReplaceMethod("[", signature(x = "mpfr", i = "ANY", j = "missing", value = "mpfr"), function(x, i, j, ..., value) .mpfr.repl(x, i, ..., value=value)) setReplaceMethod("[", signature(x = "mpfrArray", i = "matrix", j = "missing", value = "mpfr"), function(x, i, j, ..., value) .mpfr.mrepl(x, i, ..., value=value)) ## for non-"mpfr", i.e. "ANY" 'value', coerce to mpfr with correct prec: setReplaceMethod("[", signature(x = "mpfr", i = "missing", j = "missing", value = "ANY"), function(x,i,j, ..., value) .mpfr.repl(x, , value = mpfr(value, precBits = pmax(getPrec(value), .getPrec(x))))) setReplaceMethod("[", signature(x = "mpfr", i = "ANY", j = "missing", value = "ANY"), function(x,i,j, ..., value) { if(length(xi <- x[i])) .mpfr.repl(x, i, value = mpfr(value, precBits = pmax(getPrec(value), .getPrec(xi)))) else x # nothing to replace }) setReplaceMethod("[", signature(x = "mpfrArray", i = "matrix", j = "missing", value = "ANY"), function(x,i,j, ..., value) { if(length(xi <- x[i])) .mpfr.mrepl(x, i, value = mpfr(value, precBits = pmax(getPrec(value), .getPrec(xi)))) else x # nothing to replace }) ## I don't see how I could use setMethod("c", ...) ## but this works "magically" when the first argument is an mpfr : ## NB: via as(., "mpfr") it currently makes all doubles to 128 bit prec; ## MM now would prefer something like 55 (just barely enough accurate) c.mpfr <- function(...) new("mpfr", unlist(lapply(list(...), as, Class = "mpfr"), recursive = FALSE)) ## and the same trick can be used to implement a *simplistic* sapplyMpfr <- function(X, FUN, ...) new("mpfr", unlist(lapply(X, FUN, ...), recursive = FALSE)) ##' more carefully, also returing mpfrArray when appropriate: sapplyMpfr <- function(X, FUN, ..., drop_1_ = TRUE) { L <- lapply(X, FUN, ...) if((n <- length(L)) && (!drop_1_ | (ll1 <- (ll <- lengths(L))[1L]) != 1L) && all(ll == ll1)) { if(is.null(d <- dim(L1 <- L[[1L]])) || !all(d == sapply(L, dim))) new("mpfrMatrix", unlist(L, recursive = FALSE), Dim = c(ll1, n), Dimnames = list(names(L1), names(L))) else # L[i] have dim(), all the same ones new("mpfrArray", unlist(L, recursive = FALSE), Dim = c(d,n), Dimnames = c(dimnames(L1), list(names(L)))) } else { new("mpfr", unlist(L, recursive = FALSE)) } } ## duplicated() now works, checked in ../man/mpfr-class.Rd ## sort() works too (but could be made faster via faster ## ------ xtfrm() method ! [ TODO ] ## to have this also work *inside* base function factor(), we need S3 method {AARGH!} unique.mpfr <- function(x, incomparables = FALSE, ...) new("mpfr", unique(getD(x), incomparables, ...)) setMethod("unique", signature(x = "mpfr", incomparables = "ANY"), unique.mpfr) ## This is practically identical to grid's rep.unit : rep.mpfr <- function(x, times = 1, length.out = NA, each = 1, ...) ## Determine an appropriate index, then call subsetting code x[ rep(seq_along(x), times=times, length.out=length.out, each=each) ] setGeneric("pmin", signature = "...")# -> message about override ... setGeneric("pmax", signature = "...") ## Check if we should "dispatch" to base ## should be fast, as it should not slow down "base pmin() / pmax()" ## Semantically: <==> is.atomic(x) && !(is(x, "bigz") || is(x, "bigq")) pm.ok.base <- function(x, cld = getClassDef(class(x))) is.atomic(x) && (!is.object(x) || { !(extends(cld, "bigz") || extends(cld, "bigq")) }) setMethod("pmin", "mNumber", function(..., na.rm = FALSE) { args <- list(...) ## Fast(*) check if "base dispatch" should happen (* "fast" for base cases): ## if((allA <- all(vapply(args, is.atomic, NA))) && ## ((nonO <- !any(is.obj <- vapply(args, is.object, NA))) || ## { ## cld <- lapply(args, function(.) getClassDef(class(.))) ## cld.o <- cld[is.obj] ## all(vapply(cld.o, extends, NA, "bigz") | ## vapply(cld.o, extends, NA, "bigq")) })) if(all(vapply(args, pm.ok.base, NA))) return( base::pmin(..., na.rm = na.rm) ) ## else: at least one is "mpfr(Matrix/Array)", "bigz" or "bigq" ## if(!allA || nonO) cld <- lapply(args, function(.) getClassDef(class(.))) ## else have defined cld above is.m <- vapply(cld, extends, NA, "mpfr") is.q <- vapply(cld, extends, NA, "bigq") is.z <- vapply(cld, extends, NA, "bigz") is.N <- vapply(args, function(x) is.numeric(x) || is.logical(x), NA) if(!any(is.m | is.q | is.z)) # should not be needed -- TODO: "comment out" stop("no \"mpfr\", \"bigz\", or \"bigq\" argument -- wrong method chosen; please report!") N <- max(lenA <- lengths(args)) any.m <- any(is.m) any.q <- any(is.q) ## precision needed -- FIXME: should be *vector* mPrec <- max(unlist(lapply(args[is.m], .getPrec)),# not vapply if(any(vapply(args[!is.m], is.double, NA))) .Machine$double.digits, if(any.q) 128L,# arbitrary as in getPrec() unlist(lapply(args[is.z], function(z) frexpZ(z)$exp))# as in getPrec() ) ## to be the result : ## r <- mpfr(rep.int(Inf, N), precBits = mPrec) ## more efficient (?): start with the first 'mpfr' argument i.frst.m <- which.max(if(any.m) is.m else if(any.q) is.q else is.z) ## ==> r is "mpfr" if there's any, otherwise "bigq", or "bigz" r <- args[[i.frst.m]] if((n.i <- lenA[i.frst.m]) != N) r <- r[rep(seq_len(n.i), length.out = N)] ## modified from ~/R/D/r-devel/R/src/library/base/R/pmax.R has.na <- FALSE ii <- seq_along(lenA) ## = seq_along(args) ii <- ii[ii != i.frst.m] for(i in ii) { x <- args[[i]] if((n.i <- lenA[i]) != N) x <- x[rep(seq_len(n.i), length.out = N)] n.r <- is.na(r); n.x <- is.na(x) ## mpfr() is relatively expensive if(doM <- any.m && !is.m[i] && !is.N[i]) # "bigz", "bigq" ## r is "mpfr" x <- mpfr(x, precBits = mPrec) else if(doQ <- !any.m && !is.q[i] && !is.N[i]) # "bigz" ## r is "bigq" x <- as.bigq(x) if(has.na || (has.na <- any(n.r, n.x))) { r[n.r] <- x[n.r] x[n.x] <- if(!doM && !doQ) as(r[n.x],class(x)) else r[n.x] } change <- r > x change <- which(change & !is.na(change)) r[change] <- x[change] if (has.na && !na.rm) r[n.r | n.x] <- NA } ## wouldn't be ok, e.g for 'bigq' r and args[[1]]: ## mostattributes(r) <- attributes(args[[1L]]) ## instead : if(!is.null(d <- dim(args[[1L]]))) dim(r) <- d r })## end { pmin } setMethod("pmax", "mNumber", function(..., na.rm = FALSE) { args <- list(...) ## Fast(*) check if "base dispatch" should happen (* "fast" for base cases): ## if((allA <- all(vapply(args, is.atomic, NA))) && ## ((nonO <- !any(is.obj <- vapply(args, is.object, NA))) || ## { ## cld <- lapply(args, function(.) getClassDef(class(.))) ## cld.o <- cld[is.obj] ## all(vapply(cld.o, extends, NA, "bigz") | ## vapply(cld.o, extends, NA, "bigq")) })) if(all(vapply(args, pm.ok.base, NA))) return( base::pmax(..., na.rm = na.rm) ) ## else: at least one is "mpfr(Matrix/Array)", "bigz" or "bigq" ## if(!allA || nonO) cld <- lapply(args, function(.) getClassDef(class(.))) ## else have defined cld above is.m <- vapply(cld, extends, NA, "mpfr") is.q <- vapply(cld, extends, NA, "bigq") is.z <- vapply(cld, extends, NA, "bigz") is.N <- vapply(args, function(x) is.numeric(x) || is.logical(x), NA) if(!any(is.m | is.q | is.z)) # should not be needed -- TODO: "comment out" stop("no \"mpfr\", \"bigz\", or \"bigq\" argument -- wrong method chosen; please report!") N <- max(lenA <- lengths(args)) any.m <- any(is.m) any.q <- any(is.q) ## precision needed -- FIXME: should be *vector* mPrec <- max(unlist(lapply(args[is.m], .getPrec)),# not vapply if(any(vapply(args[!is.m], is.double, NA))) .Machine$double.digits, if(any.q) 128L,# arbitrary as in getPrec() unlist(lapply(args[is.z], function(z) frexpZ(z)$exp))# as in getPrec() ) ## to be the result : ## r <- mpfr(rep.int(Inf, N), precBits = mPrec) ## more efficient (?): start with the first 'mpfr' argument i.frst.m <- which.max(if(any.m) is.m else if(any.q) is.q else is.z) ## ==> r is "mpfr" if there's any, otherwise "bigq", or "bigz" r <- args[[i.frst.m]] if((n.i <- lenA[i.frst.m]) != N) r <- r[rep(seq_len(n.i), length.out = N)] ## modified from ~/R/D/r-devel/R/src/library/base/R/pmax.R has.na <- FALSE ii <- seq_along(lenA) ## = seq_along(args) ii <- ii[ii != i.frst.m] for(i in ii) { x <- args[[i]] if((n.i <- lenA[i]) != N) x <- x[rep(seq_len(n.i), length.out = N)] n.r <- is.na(r); n.x <- is.na(x) ## mpfr() is relatively expensive if(doM <- any.m && !is.m[i] && !is.N[i]) # "bigz", "bigq" ## r is "mpfr" x <- mpfr(x, precBits = mPrec) else if(doQ <- !any.m && !is.q[i] && !is.N[i]) # "bigz" ## r is "bigq" x <- as.bigq(x) if(has.na || (has.na <- any(n.r, n.x))) { r[n.r] <- x[n.r] x[n.x] <- if(!doM && !doQ) as(r[n.x],class(x)) else r[n.x] } change <- r < x change <- which(change & !is.na(change)) r[change] <- x[change] if (has.na && !na.rm) r[n.r | n.x] <- NA } ## wouldn't be ok, e.g for 'bigq' r and args[[1]]: ## mostattributes(r) <- attributes(args[[1L]]) ## instead : if(!is.null(d <- dim(args[[1L]]))) dim(r) <- d r })## end { pmax } ### seq() : ## seq.default() and seq.Date() as examples : ## ~/R/D/r-devel/R/src/library/base/R/seq.R and ## ~/R/D/r-devel/R/src/library/base/R/dates.R seqMpfr <- function(from = 1, to = 1, by = ((to - from)/(length.out - 1)), length.out = NULL, along.with = NULL, ...) { if(h.from <- !missing(from)) { lf <- length(from) if(lf != 1) stop("'from' must be of length 1") } if (nargs() == 1L && h.from) { # 'One' if(is.numeric(from) || is.mpfr(from)) { to <- from; from <- mpfr(1, getPrec(from)) } else stop("'from' is neither numeric nor \"mpfr\"") } ## else if (!is(from, "mpfr")) from <- as(from, "mpfr") if(!missing(to)) { if (!is.mpfr(to)) to <- as(to, "mpfr") if (length(to) != 1) stop("'to' must be of length 1") } if (!missing(along.with)) { length.out <- length(along.with) } else if (!is.null(length.out)) { if (length(length.out) != 1) stop("'length.out' must be of length 1") length.out <- asNumeric(ceiling(length.out)) } ## status <- c(!missing(to), !missing(by), !is.null(length.out)) ## if(sum(status) != 2) ## ## stop("exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified") ## warning("not exactly two of 'to', 'by' and 'length.out' / 'along.with' have been specified") miss.by <- missing(by) if(is.null(length.out)) { if(!is.mpfr(to)) to <- as(to, "mpfr") if(!is.mpfr(from)) from <- as(from, "mpfr")# need it again del <- to - from if(del == 0 && to == 0) return(to) if(miss.by) { by <- mpfr(sign(del), getD(from)[[1]]@prec) } } else if(!miss.by) { # to mpfr and check it if (!is.mpfr(by)) by <- as(by, "mpfr") if (length(by) != 1) stop("'by' must be of length 1") } ## ---- This is cut n paste from seq.default() : ## ---- It should work, since "arithmetic works for mpfr : if(is.null(length.out)) { n <- del/by if(!(length(n) && is.finite(n))) { if(length(by) && by == 0 && length(del) && del == 0) return(from) stop("invalid (to - from)/by in seq(.)") } if(n < 0) stop("wrong sign in 'by' argument") if(n > .Machine$integer.max) stop("'by' argument is much too small") dd <- abs(del)/max(abs(to), abs(from)) if (dd < 100*.Machine$double.eps) return(from) n <- as.integer(n + 1e-7) x <- from + (0:n) * by ## correct for overshot because of fuzz if(by > 0) pmin(x, to) else pmax(x, to) } else if(!is.finite(length.out) || length.out < 0) stop("length must be non-negative number") else if(length.out == 0) as(from,"mpfr")[FALSE] # of same precision ## else if (One) 1:length.out else if(miss.by) { ## if(from == to || length.out < 2) by <- 1 if(length.out < .Machine$integer.max) length.out <- as.integer(length.out) if(missing(to)) to <- as(from,"mpfr") + (length.out - 1) if(missing(from)) from <- to - (length.out - 1) if(length.out > 2) if(from == to) rep.int(as(from,"mpfr"), length.out) else { f <- as(from,"mpfr") as.vector(c(f, f + (1:(length.out - 2)) * by, to)) } else as.vector(c(as(from,"mpfr"), to))[seq_len(length.out)] } else if(missing(to)) as(from,"mpfr") + (0:(as.integer(length.out) - 1L)) * by else if(missing(from)) to - ((as.integer(length.out) - 1L):0) * by else stop("too many arguments") } ## {seqMpfr} if(FALSE) { ##-- --- I don't see *any* way to define seq() {S4} methods ## 1. Currently need a setGeneric() : ## ---- just calling setMethod("seq",...) as below fails directly {signature problem} ## 2. Trying three different variations --- all of them render the ## *default method invalid : ### ---> seq(1, length.out=3) # afterwards fails with " missing 'by' " setGeneric("seq", function(from, to, by, ...) standardGeneric("seq"), useAsDefault = function(from, to, by, ...) base::seq(from, to, by, ...)) setGeneric("seq", function(from, to, by, ...) standardGeneric("seq"), useAsDefault = function(from = 1, to = 1, by = ((to-from)/(length.out-1)), ...) base::seq(from, to, by, ...)) setGeneric("seq", function (from, to, by, length.out, along.with, ...) standardGeneric("seq"), signature = c("from", "to", "by"), useAsDefault = { function(from = 1, to = 1, by = ((to-from)/(length.out-1)), length.out = NULL, along.with = NULL, ...) base::seq(from, to, by, length.out=length.out, along.with=along.with, ...) }) setMethod("seq", c(from = "mpfr", to = "ANY", by = "ANY"), seqMpfr) setMethod("seq", c(from = "ANY", to = "mpfr", by = "ANY"), seqMpfr) setMethod("seq", c(from = "ANY", to = "ANY", by = "mpfr"), seqMpfr) }##--not yet-- defining seq() methods -- as it fails ## the fast mpfr-only version - should *not* return empty, hence the default: .getPrec <- function(x) { if(length(x)) vapply(getD(x), slot, 1L, "prec") else mpfr_default_prec() } ## binary exponents: [1] should be ok also for 64-bit limbs .getExp <- function(x) vapply(getD(x), function(m) m@exp[1L], 1) ##' The *relevant* number of "bit"/"digit" characters in character vector x ##' (i.e. is vectorized) .ncharPrec <- function(x, base) { if((base == 2 && any(i <- tolower(substr(x,1L,2L)) == "0b")) || (base == 16 && any(i <- tolower(substr(x,1L,2L)) == "0x"))) { i <- which(i) x[i] <- substr(x[i], 3L, 1000000L) } nchar(gsub("[-.]", '', x), "bytes") } ## the user version getPrec <- function(x, base = 10, doNumeric = TRUE, is.mpfr = NA, bigq. = 128L) { if(isTRUE(is.mpfr) || is.mpfr(x)) vapply(getD(x), slot, 1L, "prec")# possibly of length 0 else if(is.character(x)) { if (inherits(x, "Ncharacter")) attr(x, "bindigits") + 1L else ceiling(log2(base) * .ncharPrec(x, base)) ## number of digits --> number of bits } else if(is.logical(x)) 2L # even 1 would suffice - but need 2 (in C ?) else if(is.raw(x)) { if(is.object(x)) { ## Now deal with 'bigz' and 'bigq' if(inherits(x,"bigz")) frexpZ(x)$exp else if(inherits(x,"bigq")) { if(missing(bigq.)) { warning("default precision for 'bigq' arbitrarily chosen as ", bigq.) bigq. } else as.integer(bigq.) } else 8L } else 8L } else { if(!doNumeric) stop("must specify 'precBits' for numeric 'x' when 'doNumeric' is false") ## else if(is.integer(x)) 32L else if(is.double(x)) 53L else if(length(x) == 0) mpfr_default_prec() else stop(sprintf("cannot determine 'precBits' for x of type '%s'", typeof(x))) } } toMpfr <- function(x) if(is.atomic(x)) mpfr(x, getPrec(x)) else as(x, "mpfr") ### all.equal() ## TODO ?? <<<<<<<<<<< ## ==== ## 2) instead of as(., "mpfr") use mpfr(., precBits = ) ## 3) make use of 'formatFUN' in all.equal.numeric() to show *less precise* error ## ## Utility, not exported: all.equalNum <- all.equal.numeric ## use *our* mean() method inside all.equal*(): environment(all.equalNum) <- environment() # = getNamespace("Rmpfr") all.equalMpfr <- function(target, current, formatFUN = function(err, what) formatMpfr(err, digits = getOption("digits")), ## smart default tolerance when *both* args are mpfr {getPrec() otherwise} tolerance = 2^-(0.5 * min(mean(.getPrec(target)), mean(.getPrec(current)))), ...) all.equalNum(target, current, tolerance=tolerance, formatFUN=formatFUN, ...) setMethod("all.equal", signature(target = "mpfr", current = "mpfr"), all.equalMpfr) setMethod("all.equal", signature(target = "mpfr", current = "ANY"), function(target, current, ...) all.equalMpfr(target, toMpfr(current), ...)) setMethod("all.equal", signature(target = "ANY", current = "mpfr"), function(target, current, ...) all.equalMpfr(toMpfr(target), current, ...)) ##' This is almost identical to diff.default -- ~/R/D/r-devel/R/src/library/base/R/diff.R ##' But that uses unclass(x) unfortunately diff.mpfr <- function(x, lag = 1L, differences = 1L, ...) { ismat <- is(x, "mpfrArray") ##_ is.matrix(x) xlen <- if(ismat) dim(x)[1L] else length(x) if (length(lag) > 1L || length(differences) > 1L || lag < 1L || differences < 1L) stop("'lag' and 'differences' must be integers >= 1") if (lag * differences >= xlen) return(x[0L]) # empty, but of proper mode i1 <- -seq_len(lag) if (ismat) for (i in seq_len(differences)) x <- x[i1, , drop = FALSE] - x[-nrow(x):-(nrow(x)-lag+1L), , drop = FALSE] else for (i in seq_len(differences)) x <- x[i1] - x[-length(x):-(length(x)-lag+1L)] x } str.mpfr <- function(object, nest.lev, internal = FALSE, give.head = TRUE, digits.d = 12, vec.len = NULL, drop0trailing=TRUE, width = getOption("width"), ...) { ## utils:::str.default() gives "Formal class 'mpfr' [package "Rmpfr"] with 1 slots" cl <- class(object) le <- length(object) if(le == 0) { print(object); return(invisible()) } if(isArr <- is(object, "mpfrArray")) di <- dim(object) r.pr <- range(getPrec(object)) onePr <- r.pr[1] == r.pr[2] if(give.head) cat("Class", " '", paste(cl, collapse = "', '"), "' [package \"", attr(cl, "package"), "\"] of ", if(isArr) paste("dimension", deparse(di, control = NULL)) else paste("length", le), " and precision", if(onePr) paste("", r.pr[1]) else paste0("s ", r.pr[1],"..",r.pr[2]), "\n", sep = "") if(missing(nest.lev)) nest.lev <- 0 cat(paste(rep.int(" ", max(0,nest.lev+1)), collapse= "..")) if(internal) { ## internal structure cat("internally @.Data: ") if(is.null(vec.len)) vec.len <- getOption("str", list(vec.len = 4))$vec.len str(getD(object), nest.lev=nest.lev, give.head=give.head, digits.d=digits.d, vec.len=vec.len, drop0trailing=drop0trailing, width=width, ...) return(invisible()) } ## if object is long, drop the rest which won't be used anyway: max.len <- max(100, width %/% 3 + 1, if(is.numeric(vec.len)) vec.len) if(le > max.len) object <- object[seq_len(max.len)] if(!is.null(digits.d))## reduce digits where precision is smaller: digits.d <- pmin(digits.d, ceiling(log(2)/log(10) * max(.getPrec(object)))) if(is.null(vec.len)) { # use width and precision (and remain simple enough) ff <- formatMpfr(object, digits=digits.d, drop0trailing=drop0trailing, ...) nch <- if(getRversion() >= "3.2.1") nchar(ff, keepNA=FALSE) else nchar(ff) fits <- !any(too.lrg <- cumsum(nch) + length(nch)-1L > width) if(!fits) vec.len <- max(2L, which.max(too.lrg) - 1L) } else fits <- le <= vec.len if(!fits) object <- object[seq_len(vec.len)] cat(formatMpfr(object, digits=digits.d, drop0trailing=drop0trailing, ...), if(fits) "\n" else "...\n") } ## {str.mpfr} Rmpfr/R/AllClasses.R0000644000176200001440000001560215075433454013730 0ustar liggesusers#### All Class Definitions in package "Rmpfr" ### Historically, we have used /usr/local/app/R/R_local/src/Brobdingnag/R/brob.R ### as partial role image ----------- ## NB: Most MPFR numbers are regular (C: mpfr_regular_p ) ## == ---> then 'd' is well defined. ## If they are not, i.e., it is in {0, NaN, +/- Inf}, then 'exp' shows this ## and 'd' (in mpfr a pointer to the limbs) is *not* used and not defined. ## Since Jan.2018, Rmpfr 0.7-0, we reflect this by using a 0-length 'd' slot long_is_4b <- (.Machine$sizeof.long == 4L) # long = 32 bit, on Windows if(long_is_4b) specExps <- 2:0 - bitwShiftR(-1L, 1L) # -2147483647 -2147483646 -2147483645 (integer) setClass("mpfr1", ## a single Multi-precision float number slots = c(prec = "integer", # precision in bits exp = "integer", # exponent sign= "integer", # signum d = "integer"), # the mantissa as a vector of (32 bit) integers validity = function(object) { if(length(pr <- object@prec) != 1 || is.na(pr) || pr < 2) "invalid 'prec' slot" else if((lex <- length(ex <- object@exp)) != 2 & (bex <- .mpfrSizeof()[["mpfr_exp_t"]]) == 8) "invalid 'exp' slot for 64-bit exponent: must have length 2" else if(lex != 1 && bex == 4) "invalid 'exp' slot for 32-bit exponent: must have length 1" else if(length(sig <- object@sign) != 1 || is.na(sig) || abs(sig) > 1) "'sign' slot not in {-1,1} is invalid" else { nd <- length(d <- object@d) if(nd) { ## "regular" gmp.numb <- .mpfr_gmp_numbbits() # 32 or 64 need.d <- ceiling(pr / 32) if((gmp.numb == 32 && nd != need.d) || (gmp.numb == 64 && !any((nd - need.d) == 0:1))) "length('d' slot) does not match 'prec'" else TRUE } else ## not regular: valid if exp slot shows so if(lex == 2) { ## ex of length 2 if((long_is_4b && ## Windows ((ex[1] == ex[2] && any(ex[1] == specExps)) || ## mpfr 3.1.3, "old" R/Rtools ( 0L == ex[2] && any(ex[1] == specExps))) ## new Rtools (2023); convert.c chg ## (was `-1L` till Aug.2024) ) || (!long_is_4b && (is.na(ex[2]) && any(ex[[1]] == (1:3)))) ## mpfr 3.1.5, Fedora 26++ ) TRUE else if(.Platform$endian != "little") { message(gettextf("@exp possibly invalid for non-regular number _or_ it seems so on a platform with endian=\"%s\". Please report to maintainer(\"Rmpfr\")", .Platform$endian), domain=NA) TRUE } else ## with MJ's change in convert.c --> now on Windows: sprintf("@exp invalid for non-regular number (64b, le(d) == 0, |long|=%d bytes)", .Machine$sizeof.long) } else { ## gmp.numb == 32: 'exp' slot of length one if(any(ex+2^31 == 1:3)) TRUE else sprintf("@exp invalid for non-regular number (32b, le(d) == 0, |long|=%d bytes)", .Machine$sizeof.long) } } }) setClass("mpfr", ## a *vector* of "mpfr1", i.e., multi-precision float numbers contains = "list", ## of "mpfr1" entries: validity = function(object) { ## should be fast ( ==> not using is(., "mpfr1") ) : if(all(lengths(cls <- lapply(object@.Data, class)) == 1L) && all(unlist(cls) == "mpfr1")) return(TRUE) ## else "Not all components are of class 'mpfr1'" }) setClass("mpfrArray", ## mpfr + "dim" + dimnames contains = "mpfr", slots = c(Dim = "integer", Dimnames = "list"), prototype = prototype(new("mpfr"), Dim= 0L), validity = function(object) { if(length(object) != prod(D <- object@Dim)) "Dimension does not match length()" else if(length(DN <- object@Dimnames) != length(D)) "Dimnames must have same length as 'Dim'" else if(any(hasN <- !vapply(DN, is.null, NA)) && any(lengths(DN[hasN]) != D[hasN])) "length of some 'Dimnames' do not match 'Dim'" else TRUE }) setMethod("initialize", "mpfrArray", function(.Object, ..., Dim, Dimnames) { if(!missing(Dim)) .Object@Dim <- as.integer(Dim) k <- length(.Object@Dim) if(missing(Dimnames)) .Object@Dimnames <- rep(list(NULL), k) else if(length(Dimnames) != k) { message(sprintf("in initialize: length(Dimnames) != k = %d; setting to NULL",k)) .Object@Dimnames <- rep(list(NULL), k) } else .Object@Dimnames <- Dimnames callNextMethod() }) setClass("mpfrMatrix", contains = "mpfrArray", prototype = prototype(new("mpfrArray"), Dim= c(0L,0L), Dimnames = list(NULL, NULL)), validity = function(object) { if(length(object@Dim) != 2L) "'Dim' is not of length 2" else TRUE }) ## "atomic vectors" (-> ?is.atomic ) -- exactly as in "Matrix": ## --------------- setClassUnion("atomicVector", ## "double" is not needed, and not liked by some members = c("logical", "integer", "numeric", "complex", "raw", "character")) ## This is tricky ... ## With the following class, arrays/matrices are covered as ## they are also with "vector" already. *However*, they are ## *not* made into vectors in method dispatch, ## which they would be if we used simply "vector" setClassUnion("array_or_vector", members = c("array", "matrix", "atomicVector")) ## However (FIXME?), the above is too large: "matrix" extends "vector" ## and that has "character", "list", ... ## For this class, we want to define '...' methods for cbind & rbind : ## FIXME(?): "array_or_vector" also contains "character" ## (and even if it wouldn't, a "matrix" could have "character" entries!) setClassUnion("Mnumber", members = c("array_or_vector", # *but* must be numeric-like "mpfr", "mpfrArray", "mpfrMatrix", ## from package 'gmp' : "bigz", "bigq")) if(FALSE) { ## if we did this, then ... {see below} setValidity("Mnumber", function(object) { if(is.numeric(object) || is.logical(object) || is.mpfr(object)) return(TRUE) ## else "Not a valid 'Mnumber' class object" }) ## ...., then, the following would fail (!) validObject( new("character", LETTERS) ) } ###----- Simpler {without 'matrix' -> 'character' ...} ------------------------- ### setClassUnion("numericVector", members = c("logical", "integer", "numeric")) setClassUnion("mNumber", members = c("numericVector", "mpfr", "mpfrArray", "mpfrMatrix", ## from package 'gmp' : "bigz", "bigq")) setValidity("mNumber", function(object) { if(is.numeric(object) || is.logical(object) || is.mpfr(object)) return(TRUE) ## else "Not a valid 'mNumber' class object" }) Rmpfr/R/optimizers.R0000644000176200001440000001334513735036657014116 0ustar liggesusers## From: Hans W Borchers ## To: Martin Maechler ## Subject: optimizeR for Rmpfr ## Date: Sun, 3 Jun 2012 16:58:12 +0200 ## This is from Hans' pracma package, ## /usr/local/app/R/R_local/src/pracma/R/golden_ratio.R ## but there's also fibonacci search, direct1d, .... optimizeR <- function(f, lower, upper, ..., tol = 1e-20, method = c("Brent", "GoldenRatio"), maximum = FALSE, precFactor = 2.0, precBits = -log2(tol) * precFactor, maxiter = 1000, trace = FALSE) { stopifnot(length(lower) == 1, length(upper) == 1, lower <= upper) fun <- match.fun(f) f <- if(maximum) function(x) -fun(x, ...) else function(x) fun(x, ...) a <- if(!is.mpfr(lower)) mpfr(lower, precBits = precBits) else if(.getPrec(lower) < precBits) roundMpfr(lower, precBits) b <- if(!is.mpfr(upper)) mpfr(upper, precBits = precBits) else if(.getPrec(upper) < precBits) roundMpfr(upper, precBits) method <- match.arg(method) n <- 0; convergence <- TRUE ## if(method == "GoldenRatio") { switch(method, "GoldenRatio" = { ## golden ratio phi <- 1 - (sqrt(mpfr(5, precBits = precBits)) - 1)/2 x <- c(a, a + phi*(b-a), b - phi*(b-a), b) y2 <- f(x[2]) y3 <- f(x[3]) while ((d.x <- x[3] - x[2]) > tol) { n <- n + 1 if(trace && n %% trace == 0) message(sprintf("it.:%4d, delta(x) = %12.8g", n, as.numeric(d.x))) if (y3 > y2) { x[2:4] <- c(x[1]+phi*(x[3]-x[1]), x[2:3]) y3 <- y2 y2 <- f(x[2]) } else { x[1:3] <- c(x[2:3], x[4]-phi*(x[4]-x[2])) y2 <- y3 y3 <- f(x[3]) } if (n > maxiter) { warning(sprintf("not converged in %d iterations (d.x = %g)", maxiter, as.numeric(d.x))) convergence <- FALSE break } } xm <- (x[2]+x[3])/2 fxm <- if (abs(f. <- f(xm)) <= tol^2) 0. else f. }, "Brent" = { ##--- Pure R version (for "Rmpfr") of R's fmin() C code. ## The method used is a combination of golden section search and ## successive parabolic interpolation. convergence is never much slower ## than that for a Fibonacci search. If f has a continuous second ## derivative which is positive at the minimum (which is not at ax or ## bx), then convergence is superlinear, and usually of the order of ## about 1.324.... ## The function f is never evaluated at two points closer together ## than eps*abs(fmin)+(tol/3), where eps is the square ## root of 2^-precBits. if f is a unimodal ## function and the computed values of f are always unimodal when ## separated by at least eps*abs(x)+(tol/3), then fmin approximates ## the abcissa of the global minimum of f on the interval ax,bx with ## an error less than 3*eps*abs(fmin)+tol. if f is not unimodal, ## then fmin may approximate a local, but perhaps non-global, minimum to ## the same accuracy. ## This function subprogram is a slightly modified version of the ## Algol 60 procedure localmin given in Richard Brent, Algorithms for ## Minimization without Derivatives, Prentice-Hall, Inc. (1973). ## c is the squared inverse of the golden ratio c <- (3 - sqrt(mpfr(5, precBits = precBits))) / 2 eps <- 2^-precBits tol1 <- 1+eps # the smallest 1.000... > 1 eps <- sqrt(eps) w <- v <- x <- a + c * (b - a) fw <- fv <- fx <- f(x) d <- e <- 0 tol3 <- tol / 3 ## main loop starts here ----------------------------------- repeat { n <- n+1 xm <- (a + b) /2 tol1 <- eps * abs(x) + tol3 t2 <- tol1 * 2 ## check stopping criterion if (abs(x - xm) <= t2 - (d.x <- (b - a)/2)) break if (n > maxiter) { warning(sprintf("not converged in %d iterations (d.x = %g)", maxiter, as.numeric(d.x))) convergence <- FALSE break } p <- q <- r <- 0 if (abs(e) > tol1) { ## fit parabola r <- (x - w) * (fx - fv) q <- (x - v) * (fx - fw) p <- (x - v) * q - (x - w) * r q <- (q - r) * 2 if (q > 0) p <- -p else q <- -q r <- e; e <- d } if(doTr <- (trace && n %% trace == 0)) msg <- sprintf("it.:%4d, x = %-19.12g, delta(x) = %9.5g", n, as.numeric(x), as.numeric(d.x)) if (abs(p) >= abs(q/2 * r) || p <= q * (a - x) || p >= q * (b - x)) { ## a golden-section step e <- (if(x < xm) b else a) - x d <- c * e if(doTr) msg <- paste(msg, "+ Golden-Sect.") } else { ## a parabolic-interpolation step d <- p / q u <- x + d if(doTr) msg <- paste(msg, "+ Parabolic") ## f must not be evaluated too close to ax or bx if (u - a < t2 || b - u < t2) { d <- tol1 if (x >= xm) d <- -d } } if(doTr) message(msg) ## f must not be evaluated too close to x u <- x + if(abs(d) >= tol1) d else if(d > 0) tol1 else -tol1 fu <- f(u) ## update a, b, v, w, and x if (fu <= fx) { if (u < x) b <- x else a <- x v <- w; w <- x; x <- u fv <- fw; fw <- fx; fx <- fu } else { if (u < x) a <- u else b <- u if (fu <= fw || w == x) { v <- w; fv <- fw w <- u; fw <- fu } else if (fu <= fv || v == x || v == w) { v <- u; fv <- fu } } } ## end {repeat} main loop xm <- x; fxm <- fx }, ## end{ "Brent" } stop(sprintf("Method '%s' is not implemented (yet)", method))) c(if(maximum)list(maximum = xm) else list(minimum = xm), list(objective = fxm, iter = n, convergence = convergence, estim.prec = abs(d.x), method=method)) } Rmpfr/R/array.R0000644000176200001440000007702415006632323013014 0ustar liggesusers## From an "mpfr" object make an mpfr(Array|Matrix) : setMethod("dim", "mpfrArray", function(x) x@Dim) setMethod("dimnames", "mpfrArray", function(x) x@Dimnames) ## 2 basic methods to construct "mpfr - arrays" ( mpfrArray | mpfrMatrix ) : ##' "mpfr" --> "mpfrArray" --- basically dim() <- dd mpfr2array <- function(x, dim, dimnames=NULL, check=FALSE) { if(check) stopifnot(extends((clx <- class(x)), "mpfr")) if(is.numeric(dim) && all(dim == (iv <- as.integer(dim)))) { rnk <- length(iv) if(check) { cl <- if(rnk == 2) "mpfrMatrix" else "mpfrArray" if(extends(clx, "mpfrArray")) x <- as(x, "mpfr")# drop 'Dim', 'Dimnames' if(is.null(dimnames)) new(cl, x, Dim = iv) else new(cl, x, Dim = iv, Dimnames = dimnames) } else { ## faster, non-checking r <- setDataPart(new(if(rnk == 2) "mpfrMatrix" else "mpfrArray"), x, check=FALSE) r@Dim <- iv if(!is.null(dimnames)) r@Dimnames <- dimnames ##TODO R >= 2.13.2: ##TODO else if(.hasSlot(x, "Dimnames")) # has "wrong' Dimnames else if(is(x, "mpfrArray")) # has "wrong' Dimnames r@Dimnames <- rep.int(list(NULL), rnk) r } } else if(is.null(dim)) as.vector(x) else stop("invalid dimension specified") } setMethod("dim<-", signature(x = "mpfr", value = "ANY"), function(x, value) mpfr2array(x, value)) mpfrArray <- function(x, precBits, dim = length(x), dimnames = NULL, rnd.mode = c('N','D','U','Z','A')) { if(!is.atomic(x)) stop("'x' must be (coercable to) a numeric vector, possibly consider mpfr2array()") dim <- as.integer(dim) rnd.mode <- toupper(rnd.mode) rnd.mode <- match.arg(rnd.mode) ml <- .Call(d2mpfr1_list, x, precBits, rnd.mode) vl <- prod(dim) if (length(x) != vl) { if (vl > .Machine$integer.max) stop("'dim' specifies too large an array") ml <- rep(ml, length.out = vl) } new(if(length(dim) == 2) "mpfrMatrix" else "mpfrArray", ml, Dim = dim, Dimnames = if(is.null(dimnames)) vector("list", length(dim)) else dimnames) } setAs("array", "mpfr", function(from) mpfr(from, 128L)) setAs("array", "mpfrArray", function(from) mpfr(from, 128L)) setAs("matrix", "mpfrMatrix", function(from) mpfr(from, 128L)) ## and for "base" functions to work: as.array.mpfr <- function(x, ...) { if(is(x, "mpfrArray")) x else ## is(x, "mpfr") : as.array.default(x, ...) } as.matrix.mpfr <- function(x, ...) { if(is(x, "mpfrMatrix")) x else ## is(x, "mpfr") : as.matrix.default(x, ...) } ## matrix is S3 generic from 'gmp' anyway: matrix.mpfr <- function (data = NA, nrow = 1, ncol = 1, byrow = FALSE, ...) { dim(data) <- c(nrow, ncol) if(length(dots <- list(...))) { if(!is.null(dn <- dots$dimnames)) { dimnames(data) <- dn # assign and delete from "dots": dots$dimnames <- NULL } if(nx <- length(dots)) # a simplified Matrix:::chk.s() warning(sprintf(ngettext(nx, "extra argument %s will be disregarded", "extra arguments %s will be disregarded"), sub(")$", '', sub("^list\\(", '', deparse(dots, control=c()))))) } data } setMethod("dimnames<-", signature(x = "mpfrArray", value = "ANY"), function(x, value) { if(!is.list(value)) stop("non-list RHS") if(length(value) != length(x@Dim)) stop("RHS (new dimnames) differs in length from dim(.)") x@Dimnames <- value x }) setMethod("t", "mpfrMatrix", t.mpfrMatrix <- function(x) { d <- x@Dim; n <- d[1]; m <- d[2] ## These are the indices to get the transpose of m {n x m} : ## ind.t <- function(n,m)rep.int(1:n, rep(m,n)) + n*(0:(m-1)) x@Dim <- c(m,n) x@Dimnames <- x@Dimnames[2:1] ## faster than { x@.Data <- x@.Data[rep.int(1:n, rep(m,n)) + n*(0:(m-1))] ; x } : setDataPart(x, getD(x)[rep.int(1:n, rep(m,n)) + n*(0:(m-1))], check=FALSE) }) setMethod("t", "mpfr", t.mpfr <- function(x) { # t() |--> {1 x n} matrix r <- new("mpfrMatrix") r@Dim <- c(1L, length(x)) ## faster than { r@.Data <- x@.Data ; r } : setDataPart(r, getD(x), check=FALSE) }) setMethod("aperm", signature(a="mpfrArray"), aperm.mpfrArray <- function(a, perm, resize=TRUE, ...) { stopifnot(1 <= (k <- length(d <- a@Dim))) if(missing(perm)) perm <- k:1 else stopifnot(length(perm <- as.integer(perm)) == k, 1 <= perm, perm <= k) if(!resize) stop("'resize != TRUE is not (yet) implemented for 'mpfrArray'") a@Dim <- d[perm] a@Dimnames <- a@Dimnames[perm] ii <- c(aperm(array(1:prod(d), dim=d), perm=perm, resize=FALSE)) ## faster than { a@.Data <- a@.Data[ ii ] ; a } : setDataPart(a, getD(a)[ ii ], check=FALSE) }) ## `` drop the dim() part '' : setMethod("as.vector", "mpfrArray", function(x) as(x, "mpfr")) ## a "vector" in *one* sense at least, and "mpfr" does extend "vector": setAs("mpfrArray", "vector", function(from) as(from, "mpfr")) .toNum <- function(from, rnd.mode) { ## <- must have only 'from' if(is.null(dn <- dimnames(from)) || identical(dn, list(NULL,NULL))) ## --> result has NULL dimnames structure(.Call(mpfr2d, from, rnd.mode), dim = dim(from)) else structure(.Call(mpfr2d, from, rnd.mode), dim = dim(from), dimnames = dn) } ## to be used in setAs(), must have only 'from' argument: .toNum1 <- function(from) .toNum(from, rnd.mode="N") toNum <- function(from, rnd.mode = c('N','D','U','Z','A')) { stopifnot(is.character(rnd.mode <- toupper(rnd.mode))) rnd.mode <- match.arg(rnd.mode) .toNum(from, rnd.mode) } setAs("mpfrArray", "array", .toNum1) setAs("mpfrMatrix", "matrix", .toNum1) setAs("mpfrArray", "matrix", function(from) { if(length(dim(from)) != 2) stop("dim(.) != 2 ==> cannot be coerced to 'matrix'") toNum(from) }) print.mpfrArray <- function(x, digits = NULL, drop0trailing = FALSE, right = TRUE, ## ----- ## would like 'drop0... = TRUE', but that's only ok once we have a ## format() allowing to "jointly format a column" max.digits = getOption("Rmpfr.print.max.digits", 999L), exponent.plus = getOption("Rmpfr.print.exponent.plus", TRUE), ...) { stopifnot(is(x, "mpfrArray"), is.null(digits) || digits >= 2) ## digits = NULL --> the inherent precision of x will be used n <- length(x) ch.prec <- if(n >= 1) { rpr <- range(.getPrec(x)) paste("of precision ", rpr[1], if(rpr[1] != rpr[2]) paste("..",rpr[2]), " bits") } cl <- class(x) p0 <- function(...) paste(..., sep="") cat(p0("'",cl,"'"), "of dim(.) = ", p0("(",paste(x@Dim, collapse=", "),")"), ch.prec, "\n") if(n >= 1) { ## FIXME: really need a 'format' method for mpfrArrays ## ----- which properly aligns columns !! ## Build character array fx, and print that ## drop arguments for print.default(*): lFormat <- function(x, na.print, print.gap, max, useSource, ...) formatMpfr(x, digits=digits, max.digits=max.digits, drop0trailing=drop0trailing, exponent.plus=exponent.plus, ...) fx <- lFormat(x, ...) dim(fx) <- dim(x) dimnames(fx) <- dimnames(x) print(fx, ..., right=right, quote = FALSE) } invisible(x) } setMethod(show, "mpfrArray", function(object) print.mpfrArray(object)) ## FIXME : should happen in C, where we could "cut & paste" much of ## ----- do_matprod() and matprod() from ~/R/D/r-devel/R/src/main/array.c ##/* "%*%" (op = 0), crossprod (op = 1) or tcrossprod (op = 2) */ .matmult.R <- function(x,y, op = 0L, fPrec = 1, precBits = fPrec * max(getPrec(x), getPrec(y))) { if(!(is.numeric(x) || is.mpfr(x))) stop("'x' must be numeric or mpfr(Matrix)") sym <- missing(y) if (sym && (op > 0L)) y <- x else if(!(is.numeric(y) || is.mpfr(y))) stop("'y' must be numeric or mpfr(Matrix)") ldx <- length(dx <- dim(x)) ldy <- length(dy <- dim(y)) ## "copy, paste & modify" from do_matprod(): if (ldx != 2 && ldy != 2) { #* x and y non-matrices */ if (op == 0L) { nrx <- 1L; ncx <- length(x) } else { nrx <- length(x); ncx <- 1L } nry <- length(y) ncy <- 1L } else if (ldx != 2) { #* x not a matrix */ nry <- dy[1] ncy <- dy[2] nrx <- ncx <- 0L if (op == 0L) { if (length(x) == nry) { #* x as row vector */ nrx <- 1L ncx <- nry # == length(x) } else if (nry == 1) { #* x as col vector */ nrx <- length(x) ncx <- 1L # == nry } } else if (op == 1L) { #* crossprod if (length(x) == nry) { #* x is a col vector */ nrx <- nry # = length(x) ncx <- 1L } } else { # op == 2L: tcrossprod if (length(x) == ncy) { #* x as row vector */ nrx <- 1L ncx <- ncy # == length(x) } else if (ncy == 1) { #* x as col vector */ nrx <- length(x) ncx <- 1L # == ncy } } } else if (ldy != 2) { #* y not a matrix */ nrx <- dx[1] ncx <- dx[2] nry <- ncy <- 0L if (op == 0L) { if (length(y) == ncx) { #* y as col vector */ nry <- ncx # = length(y) ncy <- 1L } else if (ncx == 1) { #* y as row vector */ nry <- 1L # = ncx ncy <- length(y) } } else if (op == 1L) { #* crossprod if (length(y) == nrx) { #* y is a col vector */ nry <- nrx # = length(y) ncy <- 1L } } else { # op == 2L: tcrossprod y is a col vector nry <- length(y) ncy <- 1L } } else { #* x and y matrices */ nrx <- dx[1] ncx <- dx[2] nry <- dy[1] ncy <- dy[2] } ##* nr[ow](.) and nc[ol](.) are now defined for x and y */ z <- new("mpfrMatrix") z0 <- as(0, "mpfr") if (op == 0L) { ## %*% if (ncx != nry) stop("non-conformable arguments") z@Dim <- c(nrx, ncy) z@.Data <- vector("list", nrx*ncy) if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) { j <- 0L:(ncx - 1L) for(i in 1:nrx) { for (k in 0L:(ncy - 1L)) z[i + k * nrx] <- ## sum(x[i + j * nrx] * y[1L+ j + k * nry]) new("mpfr", .Call(R_mpfr_sumprod, # --> ../src/Summary.c x[i + j * nrx], y[1L+ j + k * nry], precBits, alternating=FALSE)) } } else #/* zero-extent operations should return zeroes */ for(i in seq_len(nrx*ncy)) z[i] <- z0 } else if (op == 1L) { ## crossprod() : x' %*% y if (nrx != nry) stop("non-conformable arguments") z@Dim <- c(ncx, ncy) z@.Data <- vector("list", ncx*ncy) if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) { j <- 1L:nrx for(i in 0L:(ncx - 1L)) { for (k in 0L:(ncy - 1L)) z[1L +i + k * ncx] <- ## sum(x[j + i * nrx] * y[j + k * nry]) new("mpfr", .Call(R_mpfr_sumprod, x[j + i * nrx], y[j + k * nry], precBits, alternating=FALSE)) } } else for(i in seq_len(ncx*ncy)) z[i] <- z0 } else { ## op == 2L : tcrossprod() : x %*% y' if (ncx != ncy) stop("non-conformable arguments") z@Dim <- c(nrx, nry) z@.Data <- vector("list", nrx*nry) if (nrx > 0 && ncx > 0 && nry > 0 && ncy > 0) for(i in seq_len(nrx)) { j <- 0L:(ncx - 1L) for (k in 0L:(nry - 1L)) z[i + k * nrx] <- ## sum(x[i + j * nrx] * y[1L +k + j * nry]) new("mpfr", .Call(R_mpfr_sumprod, x[i + j * nrx], y[1L +k + j * nry], precBits, alternating=FALSE)) } else for(i in seq_len(nrx*nry)) z[i] <- z0 } z } ## .matmult.R() ## "FIXME"? make working also with "Matrix" class matrices .. ## ---------------------------- ## An 'explicit' %*% function (with >= 2 arguments) : matmult <- function(x,y, ...) .matmult.R(x,y, op = 0L, ...) setMethod("%*%", signature(x = "mpfrMatrix", y = "mpfrMatrix"), function(x,y) .matmult.R(x,y, op= 0L)) setMethod("%*%", signature(x = "mpfrMatrix", y = "mpfr"), function(x,y) .matmult.R(x,y, op= 0L)) setMethod("%*%", signature(x = "mpfr", y = "mpfrMatrix"), function(x,y) .matmult.R(x,y, op= 0L)) setMethod("%*%", signature(x = "mpfr", y = "mpfr"), function(x,y) .matmult.R(x,y, op= 0L)) ## These cover vectors, etc (!) : setMethod("%*%", signature(x = "mpfr", y = "Mnumber"), function(x,y) .matmult.R(x,y, op= 0L)) setMethod("%*%", signature(x = "Mnumber", y = "mpfr"), function(x,y) .matmult.R(x,y, op= 0L)) setMethod("crossprod", signature(x = "mpfrMatrix", y = "mpfrMatrix"), function(x,y, ...) .matmult.R(x,y, op= 1L, ...)) setMethod("crossprod", signature(x = "mpfrMatrix", y = "mpfr"), function(x,y, ...) .matmult.R(x,y, op= 1L, ...)) setMethod("crossprod", signature(x = "mpfr", y = "mpfrMatrix"), function(x,y, ...) .matmult.R(x,y, op= 1L, ...)) setMethod("crossprod", signature(x = "mpfr", y = "mpfr"), function(x,y, ...) .matmult.R(x,y, op= 1L, ...)) setMethod("crossprod", signature(x = "mpfr", y = "Mnumber"), function(x,y, ...) .matmult.R(x,y, op= 1L, ...)) setMethod("crossprod", signature(x = "Mnumber", y = "mpfr"), function(x,y, ...) .matmult.R(x,y, op= 1L, ...)) ## one argument-case: [FIXME: not copying 'x' and using x_i^2 is more efficient] setMethod("crossprod", signature(x = "mpfr", y = "missing"), function(x,y, ...) .matmult.R(x,x, op= 1L, ...)) setMethod("tcrossprod", signature(x = "mpfrMatrix", y = "mpfrMatrix"), function(x,y, ...) .matmult.R(x,y, op= 2L, ...)) setMethod("tcrossprod", signature(x = "mpfrMatrix", y = "mpfr"), function(x,y, ...) .matmult.R(x,y, op= 2L, ...)) setMethod("tcrossprod", signature(x = "mpfr", y = "mpfrMatrix"), function(x,y, ...) .matmult.R(x,y, op= 2L, ...)) setMethod("tcrossprod", signature(x = "mpfr", y = "mpfr"), function(x,y, ...) .matmult.R(x,y, op= 2L, ...)) setMethod("tcrossprod", signature(x = "mpfr", y = "Mnumber"), function(x,y, ...) .matmult.R(x,y, op= 2L, ...)) setMethod("tcrossprod", signature(x = "Mnumber", y = "mpfr"), function(x,y, ...) .matmult.R(x,y, op= 2L, ...)) ## one argument-case: [FIXME: not copying 'x' and using x_i^2 is more efficient] setMethod("tcrossprod", signature(x = "mpfr", y = "missing"), function(x,y, ...) .matmult.R(x,x, op= 2L, ...)) .mpfrA.subset <- function(x,i,j, ..., drop) { nA <- nargs() if(getOption("verbose")) message(sprintf("nargs() == %d mpfrArray indexing ... ", nA)) r <- getD(x) # the data part, a list() if(nA == 2) ## A[i] return(new("mpfr", r[i])) ## else: nA != 2 : nA > 2 - dim(r) <- dim(x) dimnames(r) <- dimnames(x) r <- r[i,j, ..., drop=drop] if(drop && is.null(dim(r))) new("mpfr", r) else { D <- if(is.null(dr <- dim(r))) # ==> drop is FALSE; can this happen? rep.int(1L, length(r)) else dr x@Dim <- D x@Dimnames <- if(is.null(dn <- dimnames(r))) vector("list", length(D)) else dn if(length(D) == 2 && !inherits(x, "mpfrMatrix")) ## low-level "coercion" from mpfrArray to *Matrix : attr(x,"class") <- getClass("mpfrMatrix")@className attributes(r) <- NULL setDataPart(x, r, check=FALSE) } } ## "[" setMethod("[", signature(x = "mpfrArray", i = "ANY", j = "ANY", drop = "ANY"), .mpfrA.subset) ## this signature needs a method here, or it triggers the one for "mpfr" setMethod("[", signature(x = "mpfrArray", i = "ANY", j = "missing", drop = "missing"), .mpfrA.subset) .mA.subAssign <- function(x,i,j,..., value, n.a, isMpfr) { ## n.a :=== nargs() -- in the calling "[<-" method -- r <- getD(x) if(n.a >= 4) { ## A[i,j] / A[i,] / A[,j] but not A[i] ## A[i,j,k] <- v : n.a == 5 dim(r) <- dim(x) dimnames(r) <- dimnames(x) if(!isMpfr) value <- mpfr(value, precBits = pmax(getPrec(value), .getPrec(if(n.a == 4) r[i,j] else r[i,j, ...])) ) vD <- getD(value) if(n.a == 4) { r[i,j] <- vD } else { ## n.a >= 5 r[i, j, ...] <- vD } attributes(r) <- NULL } else if(n.a %in% c(2,3)) { ## A [ i ] <- v // A[] <- v if(!isMpfr) value <- mpfr(value, precBits = pmax(getPrec(value), .getPrec(r[i]))) if(n.a == 3L) r[i] <- value else ## n.a == 2: r[] <- value } else { ## n.a <= 1 stop(sprintf("nargs() == %d mpfrArray[i,j] <- value __ SHOULD NOT HAPPEN!", n.a)) } setDataPart(x, r, check=FALSE) }## .mA.subAssign ## "[<-" : ## ------- ## E.g., for A[1,,2] <- V ## these are to trigger before the ("mpfr", i,j, "mpfr") [ ./mpfr.R ] does for(it in c("ANY", "missing")) for(jt in c("ANY", "missing")) setReplaceMethod("[", signature(x = "mpfrArray", i = it, j = jt, value = "mpfr"), function(x,i,j,..., value) .mA.subAssign(x,i=i,j=j,...,value=value, n.a=nargs(), isMpfr = TRUE)) ## non-"mpfr" value for(it in c("ANY", "missing")) for(jt in c("ANY", "missing")) setReplaceMethod("[", signature(x = "mpfrArray", i = it, j = jt, value = "ANY"), function(x,i,j, ..., value) .mA.subAssign(x,i=i,j=j,...,value=value, n.a=nargs(), isMpfr = FALSE)) rm(it,jt) ## In the Matrix package we have Diagonal() for *constructing* a diagonalMatrix; ## in any case, we do only want to support the diag() case. setMethod("diag", signature(x = "mpfrMatrix"), function(x, nrow, ncol, names) { n <- min(dim(x)); i <- seq_len(n); x[cbind(i,i)] }) setMethod("diag<-", signature(x = "mpfrMatrix"), function(x, value) { n <- min(dim(x)); i <- seq_len(n); x[cbind(i,i)] <- value; x }) ###----------- setGeneric("cbind", signature = "...")# -> message about override & deparse.level setGeneric("rbind", signature = "...") ## inside such cbind() / rbind() S4 methods, match.call() does *not* work correctly, ## this works *only* for top-level calls : bind_match.call <- function() sys.call(1L) ## so use our "hack" : bind_match.call <- function() { nc <- length(scs <- sys.calls()) # last one is bind_match.call() itself ## want the one call *above* standardGeneric("...") : if(is.symbol(fn <- scs[[nc-1L]][[1L]])) { # e.g. 'cbind' Gcall <- call("standardGeneric", as.character(fn)) # e.g. standardGeneric("cbind") i. <- which(vapply(scs, identical, NA, Gcall)) scs[[if(!length(i.) || i. < 2L) 1L else i. - 1L ]] } else # try "better" match.call() } setMethod("cbind", "Mnumber", function(..., deparse.level = 1) { args <- list(...) if(all(vapply(args, is.atomic, NA))) return( base::cbind(..., deparse.level = deparse.level) ) ## else: at least one is "mpfr(Matrix/Array)" if(any(vapply(args, is.character, NA))) { ## result will be matrix ! isM <- vapply(args, is, NA, class2 = "mpfr") args[isM] <- lapply(args[isM], as, Class = "character") return(do.call(base::cbind, c(args, list(deparse.level=deparse.level)))) } else if(any(vapply(args, is.complex, NA))) { ## result will be matrix; ## in the future ??? stop("cbind(...) of 'complex' and 'mpfr' objects is not implemented") ## give at least warning !! } ## else L <- function(a) if(is.numeric(n <- nrow(a))) n else length(a) W <- function(a) if(is.numeric(n <- ncol(a))) n else 1L ## the number of rows of the result : {for now require integer} NR <- max(lengths <- vapply(args, L, integer(1))) NC <- sum(widths <- vapply(args, W, integer(1))) r <- setDataPart(new("mpfrMatrix"), vector("list", NR*NC)) r@Dim <- as.integer(c(NR, NC)) hasDim <- !vapply(args, function(a) is.null(dim(a)), NA) do.colnames <- deparse.level || any(hasDim) if(do.colnames) { nms <- character(NC) ## help(cbind) has in 'Value' : ## For ‘cbind’ (‘rbind’) the column (row) names are taken from the ## colnames (rownames) of the arguments if these are matrix-like. ## Otherwise from the names of the arguments or where those are not ## supplied and ‘deparse.level > 0’, by deparsing the expressions ## given, for ‘deparse.level = 1’ only if that gives a sensible name ## (a symbol, see is.symbol). nV <- names(widths) # == names(args), possibly NULL hasV <- !is.null(nV) ## argN <- substitute(...)## "fails" here same as match.call() fcall <- bind_match.call() if(!missing(deparse.level)) # must remove: it could be "anywhere" fcall <- fcall[names(fcall) != "deparse.level"] ## cat("fcall: "); str(fcall) ## browser() ## argN <- fcall[-1] # but that makes 1st arg into fn.name! ## vapply(fcall[-1], deparse1, "") ## is what we'd need, incl. *names* ## not ok when called as selectMethod("cbind","mpfr")(x, ....) fcall.ok <- (length(fcall) == 1L + ...length()) ## == 1 + length(args) } j <- 0 prec <- .Machine$double.digits for(ia in seq_along(args)) { w <- widths[ia] a <- args[[ia]] isM <- hasDim[[ia]] # == !is.null(dim(a)) ; true iff matrix-like if(is.mpfr(a)) { prec <- max(prec, .getPrec(a)) } else { ## not "mpfr" a <- mpfr(a, prec) } if((li <- lengths[ia]) != 1 && li != NR) { ## recycle if(isM) stop("number of rows of matrices must match") ## else if(NR %% li) warning("number of rows of result is not a multiple of vector length") a <- a[rep(seq_len(li), length.out = NR)] } ii <- j+ seq_len(w) r[, ii] <- a if(do.colnames) { nms[ii] <- if(isM) colnames(a) %||% "" else { if(hasV && nzchar(n. <- nV[[ia]])) n. else if(fcall.ok) { ## deparsed argument "arg"[[ia]] a <- fcall[[ia+1L]] if(is.symbol(a) || deparse.level == 2) deparse1(a) else "" } else "" } } j <- j + w } if(do.colnames && any(nzchar(nms))) r@Dimnames[[2L]] <- nms r }) setMethod("rbind", "Mnumber", function(..., deparse.level = 1) { args <- list(...) if(all(vapply(args, is.atomic, NA))) return( base::rbind(..., deparse.level = deparse.level) ) ## else: at least one is "mpfr(Matrix/Array)" if(any(vapply(args, is.character, NA))) { ## result will be matrix ! isM <- vapply(args, is, NA, class2 = "mpfr") args[isM] <- lapply(args[isM], as, Class = "character") return(do.call(base::rbind, c(args, list(deparse.level=deparse.level)))) } else if(any(vapply(args, is.complex, NA))) { ## result will be matrix; ## in the future ??? stop("rbind(...) of 'complex' and 'mpfr' objects is not implemented") ## give at least warning !! } ## else L <- function(a) if(is.numeric(n <- nrow(a))) n else 1L W <- function(a) if(is.numeric(n <- ncol(a))) n else length(a) ## the number of rows of the result : {for now require integer} NR <- sum(lengths <- vapply(args, L, integer(1))) NC <- max(widths <- vapply(args, W, integer(1))) r <- setDataPart(new("mpfrMatrix"), vector("list", NR*NC)) r@Dim <- as.integer(c(NR, NC)) hasDim <- !vapply(args, function(a) is.null(dim(a)), NA) do.rownames <- deparse.level || any(hasDim) if(do.rownames) { nms <- character(NR) nV <- names(lengths) # == names(args), possibly NULL hasV <- !is.null(nV) fcall <- bind_match.call() if(!missing(deparse.level)) # must remove: it could be "anywhere" fcall <- fcall[names(fcall) != "deparse.level"] ## not ok when called as selectMethod("cbind","mpfr")(x, ....) fcall.ok <- (length(fcall) == 1L + ...length()) ## == 1 + length(args) } i <- 0 prec <- .Machine$double.digits for(ia in seq_along(args)) { le <- lengths[ia] a <- args[[ia]] isM <- hasDim[[ia]] # == !is.null(dim(a)) ; true iff matrix-like if(is.mpfr(a)) { prec <- max(prec, .getPrec(a)) } else { ## not "mpfr" a <- mpfr(a, prec) } if((wi <- widths[ia]) != 1 && wi != NC) { ## recycle if(isM) stop("number of rows of matrices must match") ## else if(NC %% wi) warning("number of columns of result is not a multiple of vector length") a <- a[rep(seq_len(wi), length.out = NC)] } ii <- i+ seq_len(le) r[ii, ] <- a if(do.rownames) { nms[ii] <- if(isM) rownames(a) %||% "" else { if(hasV && nzchar(n. <- nV[[ia]])) n. else if(fcall.ok) { ## deparsed argument "arg"[[ia]] a <- fcall[[ia+1L]] if(is.symbol(a) || deparse.level == 2) deparse1(a) else "" } else "" } } i <- i + le } if(do.rownames && any(nzchar(nms))) r@Dimnames[[1L]] <- nms r }) unlistMpfr <- function(x, recursive = FALSE, use.names = TRUE) { ## an "unlist(.)" for mpfr contents: if(recursive) stop("'recursive = TRUE' is not implemented (yet).") n <- sum(lengths(x)) ans <- mpfr(numeric(n), precBits=3L)# dummy to fill ans@.Data <- unlist(lapply(x, slot, ".Data"), use.names=use.names) ans } ##-- Original in ~/R/D/r-devel/R/src/library/base/R/apply.R : ## applyMpfr <- function(X, MARGIN, FUN, ...) { FUN <- match.fun(FUN) ## Ensure that X is an array object dl <- length(dim(X)) if(!dl) stop("dim(X) must have a positive length") ##- if(is.object(X)) ##- X <- if(dl == 2L) as.matrix(X) else as.array(X) ## now record dim as coercion can change it ## (e.g. when a data frame contains a matrix). d <- dim(X) dn <- dimnames(X) ds <- seq_len(dl) ## Extract the margins and associated dimnames if (is.character(MARGIN)) { if(is.null(dnn <- names(dn))) # names(NULL) is NULL stop("'X' must have named dimnames") MARGIN <- match(MARGIN, dnn) if (any(is.na(MARGIN))) stop("not all elements of 'MARGIN' are names of dimensions") } s.call <- ds[-MARGIN] s.ans <- ds[MARGIN] d.call <- d[-MARGIN] d.ans <- d[MARGIN] dn.call<- dn[-MARGIN] dn.ans <- dn[MARGIN] ## dimnames(X) <- NULL array <- function(data, dim = length(data), dimnames = NULL) { dim(data) <- dim if(!is.null(dimnames)) dimnames(data) <- dimnames data } ## do the calls d2 <- prod(d.ans) if(d2 == 0L) { ## arrays with some 0 extents: return ``empty result'' trying ## to use proper mode and dimension: ## The following is still a bit `hackish': use non-empty X newX <- array(vector(typeof(X), 1L), dim = c(prod(d.call), 1L)) ans <- forceAndCall(1, FUN, if(length(d.call) < 2L) newX[,1] else array(newX[, 1L], d.call, dn.call), ...) return(if(is.null(ans)) ans else if(length(d.ans) < 2L) ans[1L][-1L] else array(ans, d.ans, dn.ans)) } ## else newX <- aperm(X, c(s.call, s.ans)) dim(newX) <- c(prod(d.call), d2) ans <- vector("list", d2) if(length(d.call) < 2L) {# vector if (length(dn.call)) dimnames(newX) <- c(dn.call, list(NULL)) for(i in 1L:d2) { tmp <- forceAndCall(1, FUN, newX[,i], ...) if(!is.null(tmp)) ans[[i]] <- tmp } } else for(i in 1L:d2) { tmp <- forceAndCall(1, FUN, array(newX[,i], d.call, dn.call), ...) if(!is.null(tmp)) ans[[i]] <- tmp } ## answer dims and dimnames ans.list <- !is(ans[[1L]], "mpfr") ##- is.recursive(ans[[1L]]) l.ans <- length(ans[[1L]]) ans.names <- names(ans[[1L]]) if(!ans.list) ans.list <- any(lengths(ans) != l.ans) if(!ans.list && length(ans.names)) { all.same <- vapply(ans, function(x) identical(names(x), ans.names), NA) if (!all(all.same)) ans.names <- NULL } len.a <- if(ans.list) d2 else length(ans <- unlistMpfr(ans)) if(length(MARGIN) == 1L && len.a == d2) { names(ans) <- if(length(dn.ans[[1L]])) dn.ans[[1L]] # else NULL ans } else if(len.a == d2) array(ans, d.ans, dn.ans) else if(len.a && len.a %% d2 == 0L) { if(is.null(dn.ans)) dn.ans <- vector(mode="list", length(d.ans)) dn1 <- list(ans.names) if(length(dn.call) && !is.null(n1 <- names(dn <- dn.call[1])) && nzchar(n1) && length(ans.names) == length(dn[[1]])) names(dn1) <- n1 dn.ans <- c(dn1, dn.ans) array(ans, c(len.a %/% d2, d.ans), if(!is.null(names(dn.ans)) || !all(vapply(dn.ans, is.null, NA))) dn.ans) } else ans } setGeneric("apply") setMethod ("apply", "mpfrArray", applyMpfr) setMethod("colSums", "mpfrArray", function(x, na.rm = FALSE, dims = 1, ...) { stopifnot((rnk <- length(dim(x))) >= 2, 1 <= dims, dims <= rnk - 1) applyMpfr(x, (dims+1):rnk, sum) }) setMethod("colMeans", "mpfrArray", function(x, na.rm = FALSE, dims = 1, ...) { stopifnot((rnk <- length(dim(x))) >= 2, 1 <= dims, dims <= rnk - 1) applyMpfr(x, (dims+1):rnk, mean) }) setMethod("rowSums", "mpfrArray", function(x, na.rm = FALSE, dims = 1, ...) { stopifnot((rnk <- length(dim(x))) >= 2, 1 <= dims, dims <= rnk - 1) applyMpfr(x, 1:dims, sum) }) setMethod("rowMeans", "mpfrArray", function(x, na.rm = FALSE, dims = 1, ...) { stopifnot((rnk <- length(dim(x))) >= 2, 1 <= dims, dims <= rnk - 1) applyMpfr(x, 1:dims, mean) }) ## Cut'n'paste from ~/R/Pkgs/Matrix/R/Auxiliaries.R {FIXME? load Matrix:::mkDet} mkDet <- function(d, logarithm = TRUE, ldet = sum(log(abs(d))), sig = -1L+2L*as.integer(prod(sign(d)) >= 0)) { # sig: -1 or +1 (not 0 !) modulus <- if (logarithm) ldet else exp(ldet) attr(modulus, "logarithm") <- logarithm val <- list(modulus = modulus, sign = sig) class(val) <- "det" val } ## S3 method instead of S4, as base::determinant is S3 generic determinant.mpfrMatrix <- function(x, logarithm = TRUE, asNumeric = (d[1] > 3), precBits = max(.getPrec(x)), ...) { d <- x@Dim if(d[1] != d[2]) stop("'x' must ba a square matrix") if((n <- d[1]) == 0) determinant(matrix(1,0,0), logarithm=logarithm) else if(n == 1) mkDet(x[1], logarithm=logarithm) else { ## n x n, for n >= 2 if(asNumeric) return(determinant(asNumeric(x), logarithm=logarithm, ...)) ## else use recursive (Care: horribly slow for non-small n!) Det <- function(x, n = dim(x)[1]) { if(n == 1) x[1] else if(n == 2) x[1]*x[4] - x[2]*x[3] else { a <- mpfr(numeric(n), precBits=3L) # dummy to fill n1 <- n-1L for(i in seq_len(n)) { a[i] <- Det(x[-i,-1], n=n1) } ## sum(x[,1] * a), faster : new("mpfr", .Call(R_mpfr_sumprod, x[,1], a, precBits, alternating=TRUE)) } } mkDet(Det(x, n=n), logarithm=logarithm) } } ## Only needed for S4 determinant(), not for S3 one: ## The ``Right Thing'' to do : ## base::det() calls [base::]determinant(); ## our det() should call our determinant() : ## det <- base::det ## environment(det) <- environment()## == asNamespace("Rmpfr") if(FALSE) { ## This will become easy, once we have outer(...) working, basically almost == ## base::.kronecker ~~~~~~~~~ ## ------^--------- setMethod("kronecker", signature(X = "mpfrMatrix", Y = "mpfrMatrix"), function (X, Y, FUN = "*", make.dimnames = FALSE, ...) { ydim <- Y@Dim rprec <- max(.getPrec(X),.getPrec(Y)) xx <- ....... mpfr2array(xx, dim = X@Dim * ydim) }) } scale.mpfrMatrix <- scale.default ## essential, so that colMeans() is using "our" colMeans : environment(scale.mpfrMatrix) <- environment()# = the "Rmpfr" namespace ### norm() - are "lifted" from ~/R/Pkgs/Matrix/R/sparseMatrix.R : ## "FIXME": ideally should be part of the setGenericImplicit("norm",..) setMethod("norm", signature(x = "ANY", type = "missing"), function (x, type, ...) norm(x, type = "O", ...)) setMethod("norm", signature(x = "mpfrMatrix", type = "character"), function(x, type, ...) { type <- toupper(substr(type[1], 1, 1)) switch(type, ## max(, 0) |--> 0 "O" = , "1" = max(colSums(abs(x)), 0), ## One-norm (L_1) "I" = max(rowSums(abs(x)), 0), ## L_Infinity "F" = sqrt(sum(x^2)), ## Frobenius "M" = max(abs(x), 0), ## Maximum modulus of all ## otherwise: stop("invalid 'type'")) }) setMethod("head", signature(x = "mpfrMatrix"), utils::head.matrix) setMethod("tail", signature(x = "mpfrMatrix"), utils::tail.matrix) ## Workaround fact that base::outer() using tcrossprod() does not dispatch (but did on %*% !?!?!?!) environment(outer) <- environment() # and export and document >> ../man/base-copies.Rd Rmpfr/R/Consts.R0000644000176200001440000000100112561376373013142 0ustar liggesusersConst <- function(name = c("pi", "gamma", "catalan", "log2"), prec = 120L, rnd.mode = c('N','D','U','Z','A')) { stopifnot(is.numeric(prec)) if(is.na(i <- pmatch(name, eval(formals()$name)))) stop("'name' must be one of ", paste(paste("'",eval(formals()$name),"'",sep=""), collapse=", ")) new("mpfr", list(.Call(const_asMpfr, i, prec, match.arg(rnd.mode)))) } ## fails here; must happen *after* dyn.load, i.e. in ## ./zzz.R : Pi <- Const("pi") Rmpfr/R/unirootR.R0000644000176200001440000003522214411121562013506 0ustar liggesusers### This is a translation of R_zeroin2 in ~/R/D/r-devel/R/src/appl/zeroin.c ### from C to R by John Nash, ### ---> file rootoned/R/zeroin.R of the new (2011-08-18) R-forge package rootoned ### ### Where John Nash calls it zeroin(), I call it unirootR() ##' Simple modification of uniroot() which should work with mpfr-numbers ##' MM: uniroot() is in ~/R/D/r-devel/R/src/library/stats/R/nlm.R ##' unirootR <- function(f, interval, ..., lower = min(interval), upper = max(interval), f.lower = f(lower, ...), f.upper = f(upper, ...), extendInt = c("no", "yes", "downX", "upX"), trace = 0, verbose = as.logical(trace), verbDigits = max(3, min(20, -log10(tol)/2)), tol = .Machine$double.eps^0.25, maxiter = 1000L, check.conv = FALSE, ## Rmpfr-only: warn.no.convergence = !check.conv, epsC = NULL) { if(!missing(interval) && length(interval) != 2L) stop("'interval' must be a vector of length 2") ## For many "quick things", we will use as.numeric(.) but we do *NOT* assume that ## lower and upper are numeric! .N <- as.numeric if(lower >= upper) # (may be mpfr-numbers *outside* double.xmax) stop("lower < upper is not fulfilled") if(is.na(.N(f.lower))) stop("f.lower = f(lower) is NA") if(is.na(.N(f.upper))) stop("f.upper = f(upper) is NA") form <- function(x, digits = verbDigits) format(x, digits=digits, drop0trailing=TRUE) formI <- function(x, di = getOption("digits")) format(x, digits=di, drop0trailing=TRUE) Sig <- switch(match.arg(extendInt), "yes" = NULL, "downX"= -1, "no" = 0, "upX" = 1, stop("invalid 'extendInt'; please report")) ## protect against later 0 * Inf |--> NaN and Inf * -Inf. truncate <- function(x) { ## NA are already excluded; deal with +/- Inf if(is.numeric(x)) pmax.int(pmin(x, .Machine$double.xmax), -.Machine$double.xmax) else if(inherits(x, "mpfr") && is.infinite(x)) # use maximal/minimal mpfr-number instead: sign(x) * mpfr(2, .getPrec(x))^((1 - 2^-52)*.mpfr_erange("Emax")) else x } f.low. <- truncate(f.lower) f.upp. <- truncate(f.upper) doX <- ( is.null(Sig) && f.low. * f.upp. > 0 || is.numeric(Sig) && (Sig*f.low. > 0 || Sig*f.upp. < 0)) if(doX) { ## extend the interval = [lower, upper] if(trace) cat(sprintf("search {extendInt=\"%s\", Sig=%s} in [%s,%s]%s", extendInt, formI(Sig), formI(lower), formI(upper), if(trace >= 2)"\n" else " ... ")) Delta <- function(u) 0.01* pmax(1e-4, abs(u)) ## <-- FIXME? [= R's uniroot() for double] it <- 0L ## Two cases: if(is.null(Sig)) { ## case 1) 'Sig' unspecified --> extend (lower, upper) at the same time delta <- Delta(c(lower,upper)) while(isTRUE(f.lower*f.upper > 0) && any(iF <- is.finite(c(lower,upper)))) { if((it <- it + 1L) > maxiter) stop(gettextf("no sign change found in %d iterations", it-1), domain=NA) if(iF[1]) { ol <- lower; of <- f.lower if(is.na(f.lower <- f(lower <- lower - delta[1], ...))) { lower <- ol; f.lower <- of; delta[1] <- delta[1]/4 } } if(iF[2]) { ol <- upper; of <- f.upper if(is.na(f.upper <- f(upper <- upper + delta[2], ...))) { upper <- ol; f.upper <- of; delta[2] <- delta[2]/4 } } if(trace >= 2) cat(sprintf(" .. modified lower,upper: (%15g,%15g)\n", .N(lower), .N(upper))) delta <- 2 * delta } } else { ## case 2) 'Sig' specified --> typically change only *one* of lower, upper ## make sure we have Sig*f(lower) <= 0 and Sig*f(upper) >= 0: delta <- Delta(lower) while(isTRUE(Sig*f.lower > 0)) { if((it <- it + 1L) > maxiter) stop(gettextf("no sign change found in %d iterations", it-1), domain=NA) f.lower <- f(lower <- lower - delta, ...) if(trace >= 2) cat(sprintf(" .. modified lower: %s, f(.)=%s\n", formI(lower), formI(f.lower))) delta <- 2 * delta } delta <- Delta(upper) while(isTRUE(Sig*f.upper < 0)) { if((it <- it + 1L) > maxiter) stop(gettextf("no sign change found in %d iterations", it-1), domain=NA) f.upper <- f(upper <- upper + delta, ...) if(trace >= 2) cat(sprintf(" .. modified upper: %s, f(.)=%s\n", formI(upper), formI(f.upper))) delta <- 2 * delta } } if(trace && trace < 2) cat(sprintf("extended to [%s, %s] in %d steps\n", formI(lower), formI(upper), it)) } if(!isTRUE(sign(f.lower) * sign(f.upper) <= 0)) stop(if(doX) "did not succeed extending the interval endpoints for f(lower) * f(upper) <= 0" else sprintf("f() values at end points = (%s, %s) not of opposite sign", formI(f.lower), formI(f.upper))) if(is.null(epsC) || is.na(epsC)) { ## determine 'epsC' ``the achievable Machine precision'' ## -- given the class of f.lower, f.upper ff <- f.lower * f.upper if(is.double(ff)) epsC <- .Machine$double.eps else if(is(ff, "mpfr")) epsC <- 2^-min(getPrec(f.lower), getPrec(f.upper)) else { ## another number class -- try to see if getPrec() is defined.. ## if not, there's not much we can do if(is(prec <- tryCatch(min(getPrec(f.lower), getPrec(f.upper)), error = function(e)e), "error")) { warning("no valid getPrec() for the number class(es) ", paste(unique(class(f.lower),class(f.upper)), collapse=", "), ".\n Using double precision .Machine$double.eps.") epsC <- .Machine$double.eps } else { epsC <- 2^-prec message("using epsC = %s ..", format(epsC)) } } } if(tol < epsC / 8) # "8 fudge factor" (otherwise happens too often) warning(sprintf("tol (%g) < epsC (%g) is rarely sensical, and the resulting precision is probably not better than epsC", tol, epsC)) ## Instead of the call to C code, now "do it in R" : ## val <- .Internal(zeroin2(function(arg) as.numeric(f(arg, ...)), ## lower, upper, f.lower, f.upper, ## tol, as.integer(maxiter))) a <- lower # interval[1] b <- upper # interval[2] fa <- f.lower # f(ax, ...) fb <- f.upper # f(bx, ...) if (verbose) cat(sprintf("==> Start zeroin: f(%g)= %g; f(%g)= %g\n", .N(a), .N(fa), .N(b), .N(fb))) c <- a fc <- fa ## First test if we have found a root at an endpoint maxit <- maxiter + 2L # count evaluations as maxiter-maxit converged <- FALSE while(!converged && maxit > 0) { ##---- Main iteration loop ------------------------------ if (verbose) cat("Iteration >>>", maxiter+3L-maxit, "<<< ;") d.prev <- b-a ## Distance from the last but one to the last approximation */ ##double tol.2; ## Actual tolerance */ ##double p; ## Interpolation step is calcu- */ ##double q; ## lated in the form p/q; divi- ## * sion operations is delayed ## * until the last moment */ ##double d.new; ## Step at this iteration */ if(abs(fc) < abs(fb)) { ## Swap data for b to be the smaller if (verbose) cat(sprintf("fc (=%s) smaller than fb\n", form(fa))) a <- b b <- c c <- a ## best approximation fa <- fb fb <- fc fc <- fa } tol.2 <- 2*epsC*abs(b) + tol/2 d.new <- (c-b)/2 # bisection if (verbose) cat("tol.2(epsC,b) = ",.N(tol.2), "; d.new= ",.N(d.new),"\n", sep="") ## converged <- (abs(d.new) <= tol.2 && is.finite(fb)) || fb == 0 converged <- (abs(d.new) <= tol.2) || fb == 0 if(converged) { if (verbose) cat("DONE! -- small d.new or fb=0\n") ## Acceptable approx. is found : val <- list(root=b, froot=fb, rtol = abs(c-b), maxit=maxiter-maxit) } else { ## Decide if the interpolation can be tried */ if( (abs(d.prev) >= tol.2) ## If d.prev was large enough*/ && (abs(fa) > abs(fb)) ) { ## and was in true direction, ## Interpolation may be tried */ ## register double t1,cb,t2; if (verbose) cat("d.prev larger than tol.2 and fa bigger than fb --> ") cb <- c-b if (a == c) { ## If we have only two distinct points, linear interpolation ## can only be applied t1 <- fb/fa p <- cb*t1 q <- 1 - t1 if (verbose) cat("a == c: ") } else { ## Quadric inverse interpolation*/ if (verbose) cat("a != c: ") q <- fa/fc t1 <- fb/fc t2 <- fb/fa p <- t2 * ( cb*q*(q-t1) - (b-a)*(t1-1) ) q <- (q-1) * (t1-1) * (t2-1) } if(p > 0) { ## p was calculated with the */ if (verbose) cat(" p > 0; ") q <- -q ## opposite sign; make p positive */ } else { ## and assign possible minus to */ if (verbose) cat(" p <= 0; ") p <- -p ## q */ } if (p < 0.75*cb*q - abs(tol.2*q)/2 ## If b+p/q falls in [b,c]*/ && p < abs(d.prev*q/2)) { ## and isn't too large */ if (verbose) cat("p satisfies conditions for changing d.new\n") d.new <- p/q ## it is accepted } else if(verbose) cat("\n") ## If p/q is too large, then the ## bisection procedure can reduce [b,c] range to more extent } if( abs(d.new) < tol.2) { ## Adjust the step to be not less than tolerance if (verbose) cat("d.new smaller than tol.2, adjusted to it.\n") d.new <- if(d.new > 0) tol.2 else -tol.2 } a <- b fa <- fb ## Save the previous approx. */ b <- b + d.new fb <- f(b, ...) if (verbose) cat(sprintf("new f(b=%s) = %s;\n", form(b), form(fb))) maxit <- maxit-1 ## Do step to a new approxim. */ if( ((fb > 0) && (fc > 0)) || ((fb < 0) && (fc < 0)) ) { if (verbose) cat(sprintf(" make c:=a=%s to have sign opposite to b: f(c)=%s\n", form(a), form(fa))) ## Adjust c for it to have a sign opposite to that of b */ c <- a fc <- fa } }## else not converged } ## end{ while(maxit > 0) } -------------------------------------------- if(converged) { iter <- val[["maxit"]] if(!is.na(fb) && abs(fb) > 0.5*max(abs(f.lower), abs(f.upper)))# from John Nash: warning("Final function magnitude seems large -- maybe converged to sign-changing 'pole' location?") } else { ## (!converged) : failed! if(check.conv) stop("no convergence in zero finding in ", iter, " iterations") ## else val <- list(root= b, rtol = abs(c-b)) iter <- maxiter if(warn.no.convergence) warning("_NOT_ converged in ", iter, " iterations") } list(root = val[["root"]], f.root = f(val[["root"]], ...), iter = iter, estim.prec = .N(val[["rtol"]]), converged = converged) } ## {unirootR} ### qnorm() via inversion of pnorm() by unirootR() ========================== " qnorm(p) == q <==> pnorm(q) == p " ##====== TODO: Use good i.e. *tight* inequalities for Phi(x) .. which are invertible ## ===== to (still tight) inequalities for Phi^{-1}(x) == qnorm(x) ## ===> get good *start* interval for unirootR() ## qnorm (p, mean = 0, sd = 1, lower.tail = TRUE, log.p = FALSE) qnormI <- function(p, mean = 0, sd = 1, lower.tail = TRUE, log.p = FALSE, trace = 0, verbose = as.logical(trace), # <- identical defaults as unirootR() tol, # for "base" = .Machine$double.eps^0.25, but here use getPrec() useMpfr = any(prec > 53), # if true, use mpfr give.full = FALSE, ...) # <- arguments to pass to unirootR() { ## The function whose "zeros" aka "roots" we want to find: zFun <- function(q) pnorm(q, mean=mean, sd=sd, lower.tail=lower.tail, log.p=log.p) - p. if(missing(tol) || !is.finite(tol)) { prec <- max(getPrec(if(missing(mean) && missing(sd)) p else p+(mean+sd))) ## not max(getPrec(c(p, mean, sd))) as it's >= 128 by default tol <- 2^-(prec + 2) # 2^(-prec - 1) gives less accurate } else prec <- as.integer(ceiling(1 - log2(tol))) ## if(verbose) cat(sprintf("prec=%d ==> useMpfr=%s:\n", prec, format(useMpfr))) verbDigs <- if(any(is.vd <- "verbDigits" == ...names())) ...elt(which(is.vd)) else max(3, min(20, -log10(tol)/2)) if(useMpfr) { ## This **IS** important here: old_eranges <- .mpfr_erange() # typically -/+ 2^30 myERng <- (1-2^-52) * .mpfr_erange(c("min.emin","max.emax")) if(!isTRUE(all.equal(myERng, old_eranges))) { .mpfr_erange_set(value = myERng) on.exit( .mpfr_erange_set( , old_eranges) ) } } sgn <- if(lower.tail) -1 else 1 INf <- if(lower.tail) Inf else -Inf ## "start"-interval for unirootR() --- see 'TODO' .. *tight* .. above <<<<<<<< ## Notably for the relevant (p <<< -1, log.p=TRUE) case ! qnInt <- if(log.p) { Pi <- if(useMpfr) Const("pi", prec) else pi function(p) { s2 <- -2*p if(useMpfr && !inherits(s2, "mpfr")) s2 <- mpfr(s2, precBits = prec) xs1 <- s2 - log(2*Pi*s2) if(p < -54) { qn <- sqrt(s2 - log(2*Pi*xs1)); e <- 1e-4 } else if(p <= -15) { qn <- sqrt(s2 - log(2*Pi*xs1) - 1/(2 + xs1)); e <- 1e-3 } else { # p >= -15 qn <- stats__qnorm(asNumeric(p), log.p=TRUE) ## FIXME: not good enough, e.g., for p = mpfr(-1e-5, 128) e <- 1e-2 } qn*(sgn + c(-e,e)) } } else { ## log.p is FALSE Id <- if(useMpfr) function(.) mpfr(., precBits = prec) else identity function(p) { q <- stats__qnorm(asNumeric(p), lower.tail=lower.tail) Id(if(abs(q) < 1e-3) c(-2,2)*1e-3 else c(.99, 1.01) * q) } } ## Deal with prob in {0, 1} which correspond to quantiles -/+ Inf : ## idea from {DPQ}'s .D_0 and .D_1 : .p_1 <- as.integer(!log.p) .p_0 <- if (log.p) -Inf else 0 r <- if(give.full) vector("list", length(p)) else if(useMpfr) mpfr(p, precBits=prec) else p for(ip in seq_along(p)) { p. <- p[ip] if(verbose) cat(sprintf("p. = p[ip=%d] = %s:\n", ip, format(p., digits = verbDigs, drop0trailing=TRUE))) ri <- if (p. == .p_1) INf else if (p. == .p_0) -INf else if(is.na(p.) || p. > .p_1 || p. < .p_0) NaN else { ## zFun() uses p. ur <- unirootR(zFun, interval = qnInt(p.), extendInt = if(lower.tail) "upX" else "downX", trace=trace, verbose=verbose, tol=tol, ...) # verbDigits, maxiter, check.conv, warn.no.convergence, epsC if(give.full) ur else ur$root } if(give.full) r[[ip]] <- ri else r[ip] <- ri } r } Rmpfr/R/gmp-convert.R0000644000176200001440000001524715057534534014151 0ustar liggesusers#### Conversions bigz <-> mpfr // also bigq <--> mpfr if(packageVersion("gmp") < "0.5.8")## <-> ../NAMESPACE is.matrixZQ <- function(x) !is.null(attr(x, "nrow")) ## The following code is experimental, hence the "." : ### FIXME: we go via character.. which is not really efficient. ## ------ rather "should" use MPFR Functions ## int mpfr_set_z (mpfr_t ROP, mpz_t OP, mpfr_rnd_t RND) ## int mpfr_set_q (mpfr_t ROP, mpq_t OP, mpfr_rnd_t RND) ## ## Set the value of ROP from OP, rounded toward the given direction RND. ## ## Directly in C, we'd need both Rmpfr and gmp's C code (!) ## TODO(?: gmp should "export" its C++ API ( -> inst/include/*.hh ) ## and we should add 'LinkingTo: gmp' to DESCRIPTION and ## then use C++ with "C" { ...} for those parts .bigz2mpfr <- function(x, precB = NULL, rnd.mode = c('N','D','U','Z','A')) { stopifnot(inherits(x, "bigz")) ..bigz2mpfr(x, precB, rnd.mode) } ## Fast, no-checking (and not exported) version: ..bigz2mpfr <- function(x, precB = NULL, rnd.mode = c('N','D','U','Z','A')) ## precB: 4 == log2(16) = log(base) { stopifnot(is.character(rnd.mode <- toupper(rnd.mode))) rnd.mode <- match.arg(rnd.mode) b <- 16L cx <- .as.char.bigz(x, b) if(is.null(precB)) precB <- 4L*nchar(cx) if(max(precB) > .Machine$integer.max) stop("max(precB) = ", max(precB), " may not be larger than .Machine$integer.max = ", .Machine$integer.max) if(is.matrixZQ(x)) new("mpfrMatrix", .Call(str2mpfr1_list, cx, precB, b, rnd.mode), Dim = as.integer(dim(x)))# "bigz" has no dimnames else new("mpfr", .Call(str2mpfr1_list, cx, precB, b, rnd.mode)) } setAs("bigz", "mpfr", function(from) ..bigz2mpfr(from)) ## FIXME: rather should use MPFR -- Function : ## ---- int mpfr_get_z (mpz_t ROP, mpfr_t OP, mpfr_rnd_t RND) ## Convert OP to a `mpz_t', after rounding it with respect to RND. .... ## FIXME(2): should 'gmp' change as.bigz into an S3 generic, so this becomes S3 method? as.bigz.mpfr <- .mpfr2bigz <- function(x, mod=NA) { if(is.null(mod)) mod <- NA_integer_ stopifnot(is.mpfr(x), is.na(mod) || (length(mod) == 1L && is.numeric(mod))) dx <- dim(x) ### FIXME or rather roundMpfr() [or even round "RND" as in mpfr_get_z() above] ?? cx <- format(trunc(x), scientific=FALSE, drop0trailing=TRUE) if(!is.null(dx <- dim(x))) dim(cx) <- dx ## needed?? {should *not* be, as in base R!} ..as.bigz(cx, mod) } setAs("mpfr", "bigz", function(from) .mpfr2bigz(from)) ## Fast, no-checking (and not exported) version: ..bigq2mpfr <- function(x, precB = NULL, rnd.mode = c('N','D','U','Z','A')) { stopifnot(is.character(rnd.mode <- toupper(rnd.mode))) rnd.mode <- match.arg(rnd.mode) N <- numerator(x) D <- denominator(x) if(is.null(precB)) { eN <- frexpZ(N)$exp eD <- frexpZ(D)$exp precB <- pmax(128L, eN + eD + 1L) # precision of result } ..bigz2mpfr(N, precB, rnd.mode) / ..bigz2mpfr(D, precB, rnd.mode) } .bigq2mpfr <- function(x, precB = NULL, rnd.mode = c('N','D','U','Z','A')) { stopifnot(inherits(x, "bigq")) ..bigq2mpfr(x, precB, rnd.mode) } setAs("bigq", "mpfr", function(from) ..bigq2mpfr(from)) ## not exported ##' @title get denominator 'd' of m = n/d ##' @param m an mpfr number vector ##' @return the denominator 'd' (also mpfr vector) ##' @author Martin Maechler getDenom <- function(m) { ## stopifnot(is.mpfr(m)) e <- pmax(0L, -.mpfr2exp(m)) # 2-exponents to multiply with; integer *iff* .... pre <- getPrec(m) mpfr(2, pre)^(e + pre) ## MM: it *seems* that (e + pre -1) works too ? } ## relies on .mpfr2bigz() above {which has TODO s !} .mpfr2bigq <- function(x) { stopifnot(is.mpfr(x)) d <- getDenom(x) as.bigq(.mpfr2bigz(x*d), .mpfr2bigz( d )) } ##---- Find "as small as possible" rational approximation to real number --- ## Adapted .rat() from MASS/R/fractions.R ## Copyright (C) 1994-2005 W. N. Venables and B. D. Ripley ## num2bigq <- function(x, cycles = 50L, max.denominator = 2^25, verbose = FALSE) { n <- length(x <- as(x, "mpfr"))# precBits = 128 if(is.numeric(x)) fin <- is.finite(x) a0 <- rep(0, n) Z1 <- as.bigz(1) b0 <- rep(Z1, n) A <- matrix(b0) # == b0 bb <- .mpfr2bigz(x) r <- x - bb # fractional part of x B <- matrix(bb) # integer part of x len <- 0L while(any(do <- fin & (r > 1/max.denominator)) && (len <- len + 1L) <= cycles) { a <- a0 # a[] will be in {0,1} b <- b0 which <- which(do) a[which] <- 1 r[which] <- 1/r[which] b[which] <- .mpfr2bigz(r[which]) # includes floor(.) r[which] <- r[which] - b[which] ### FIXME: bug in {gmp} ? cbind(A, a, deparse.level = 0) ## adds a 0-column !!! A <- cbind(A, a) # is always in {0,1} B <- cbind(B, b) # always bigz if(verbose) { cat("it=", len,": r="); print(r); cat("B =\n"); print(B) } } pq1 <- cbind(b0, a0) pq <- cbind(B[, 1], b0) len <- 1L while((len <- len + 1L) <= ncol(B)) { pq0 <- pq1 pq1 <- pq pq <- B[, len] * pq1 + A[, len] * pq0 } if(any(N <- !fin)) pq[N, 1L] <- .mpfr2bigz(x[N]) as.bigq(pq[,1L], pq[,2L]) } ## The .rat() version -- i.e. working with double() ---- *not* exported; just for debugging .. .num2bigq <- function(x, cycles = 50L, max.denominator = 2^25, verbose = FALSE) { n <- length(x <- as.numeric(x)) fin <- is.finite(x) a0 <- rep(0, n) Z1 <- 1 #N as.bigz(1) b0 <- rep(Z1, n) A <- matrix(b0) # == b0 bb <- floor(x) #N .mpfr2bigz(x) r <- x - bb # fractional part of x B <- matrix(bb) # integer part of x len <- 0L while(any(do <- fin & (r > 1/max.denominator)) && (len <- len + 1L) <= cycles) { a <- a0 # a[] will be in {0,1} b <- b0 which <- which(do) a[which] <- 1 r[which] <- 1/r[which] b[which] <- floor(r[which]) #N .mpfr2bigz(r[which]) # includes floor(.) r[which] <- r[which] - b[which] A <- cbind(A, a, deparse.level=0L) # is always in {0,1} B <- cbind(B, b, deparse.level=0L) # always bigz ## if(verbose) { cat("it=", len,": r="); print(r); cat("A, B =\n"); print(A); print(B) } if(verbose) { cat("it=", len,": r="); print(r); cat("B =\n"); print(B) } } pq1 <- cbind(b0, a0, deparse.level=0L) pq <- cbind(B[, 1], b0, deparse.level=0L) len <- 1L while((len <- len + 1L) <= ncol(B)) { pq0 <- pq1 pq1 <- pq pq <- B[, len] * pq1 + A[, len] * pq0 } pq[!fin, 1] <- x[!fin] #N .mpfr2bigz(x[!fin]) pq ## list(rat = pq, x = x) } Rmpfr/R/formatHex.R0000644000176200001440000002502314631125115013622 0ustar liggesusers## sprintf("%+13.13a", x) ## hex digits after the hex point = 13 ## precBits: double precision = 53 = 1 + 13*4 ## conversion from Hex digits to binary sequences of digits HextoBin <- c( "0"="0000", "1"="0001", "2"="0010", "3"="0011", "4"="0100", "5"="0101", "6"="0110", "7"="0111", "8"="1000", "9"="1001", "A"="1010", "B"="1011", "C"="1100", "D"="1101", "E"="1110", "F"="1111", "a"="1010", "b"="1011", "c"="1100", "d"="1101", "e"="1110", "f"="1111") if(FALSE) { ## the code isn't using either of these inverses. BintoHex <- names( HextoBin[1:16]) names(BintoHex) <- HextoBin[1:16] Bintohex <- tolower(BintoHex) } ## RMH mentioned that sprintfMpfr() is "parallel" to formatMpfr() ## and agreed that in principle everything should rather be based on formatMpfr(), hence ## sprintMfpr() should become unneeded (or be *based* on formatMpfr() and renamed as basic formatFOO() ## utility for formatHex() style format -- which differs from what the MPFR lib provides (<--> our .mpfr2str()) ##' @title sprintf("%a", *)-like formatting of mpfr numbers ##' @param x mpfr-number vector ##' @param bits integer (scalar) specifing the desired number of bits ("binary digits") ##' @param style 1-character string specifying ##' @return character vector of same length as \code{x} ##' @author Martin Maechler sprintfMpfr <- function(x, bits, style = "+", expAlign=TRUE, showNeg0 = TRUE) { stopifnot(length(style <- as.character(style)) == 1, nchar(style) == 1, style %in% c("+", " "), length(bits) == 1, bits %% 1 == 0) hexdigits <- 1L + (bits-1L) %/% 4L ## common to both branches ### TODO: For consistency, no longer use sprintf() for bits <= 52 ### ---- currently "fails", e.g., in mpfr(formatBin(mpfr(2, 60))) if(bits > 52) { # <== precBits > 53 neg <- sign(x) == -1 ff <- .mpfr2str(x, hexdigits + 1L, maybe.full=FALSE, ## ???? base = 16) ## need +1 if(!showNeg0) { negzero <- substr(ff$str, 1L, 2L) == "-0" ff$str[negzero] <- substr(ff$str[negzero], 2L, 1000000L) ## force "-0" to "0". neg is already consistent. } isNum <- ff$finite ## ff$finite == is.finite(x) i0 <- ff$is.0 ## == mpfrIs0(x) FirstDigit <- substr(ff$str, 1L, 1L) FirstDigit[neg] <- substr(ff$str[neg], 2L, 2L) BinPlace <- c("0"=0, "1"=0, "2"=1, "3"=1, "4"=2, "5"=2, "6"=2, "7"=2, "8"=3, "9"=3, "a"=3, "b"=3, "c"=3, "d"=3, "e"=3, "f"=3) bitMod4 <- 2^BinPlace[FirstDigit] x[isNum] <- x[isNum] / bitMod4[isNum] ## reduce mantissa by 2^BinPlace ff <- .mpfr2str(x, hexdigits + 1L, base = 16) ## revised input value if(!showNeg0) # force "-0" to "0" ff$str[negzero] <- substr(ff$str[negzero], 2L, 1000000L) ex <- ff$exp ## the *decimal* value of base-2 exp : one too large *unless* x == 0 r <- ff$str # the mantissa, including "-" if negative Ex <- ex - 1L if(any(i0)) Ex[i0] <- ex[i0] if(!all(isNum)) ## "@Inf@", "@NaN@", ... r[!isNum] <- gsub("@", '', r[!isNum], fixed=TRUE) if(any(i <- neg & isNum)) ## r[i] <- sub("^-", "-0x", r[i]) wrongly gives e.g. "-0x.18"; want "-0x1.8" r[i] <- paste0("-0x", substr(r[i], 2L, 2L), ".", substring(r[i], 3L), "p") if(any(i <- !neg & isNum)) r[i] <- paste0(style, "0x", substr(r[i], 1L, 1L), ".", substring(r[i], 2L), "p") ## r[isNum] <- paste0(r[isNum], c("", "+")[1+ (isNum & (Ex >= 0))], 4*Ex) Exp <- 4*Ex Exp[!i0] <- Exp[!i0] + BinPlace[FirstDigit[!i0]] ## increase exponent by BinPlace if (expAlign) { Exp.format <- c("%1.1i", "%2.2i", "%3.3i")[max(1, ceiling(log10(max(abs(Exp[isNum])))))] Exp[isNum] <- sprintf(Exp.format, Exp[isNum]) } r[isNum] <- paste0(r[isNum], ## add "+" for positive exponents: c("", "+")[1+(isNum & (Ex >= 0))][isNum], Exp[isNum]) r } else { ## bits <= 52 nX <- as.character(hexdigits) if(!showNeg0) { negzero <- substr(format(x), 1L, 2L) == "-0" x[negzero] <- 0 } result <- sprintf(paste0("%", style, nX, ".", nX, "a"), x) if(any(pInf <- is.infinite(x) & x > 0)) result[pInf] <- sub("+", " ", result[pInf], fixed=TRUE) result } } ##___ ../man/formatHex.Rd ___ ## ~~~~~~~~~~~~ formatHex <- function(x, precBits = min(getPrec(x)), style = "+", expAlign=TRUE) { if (is.numeric(x)) { precBits <- getPrec(x) x <- mpfr(x, precBits) } precB <- as.integer(precBits) structure(sprintfMpfr(x, bits=precB-1L, style=style, expAlign=expAlign), ##--------- dim = dim(x), dimnames = dimnames(x), base = 16L, precBits = precB, class = c("Ncharacter", "character")) } formatBin <- function(x, precBits = min(getPrec(x)), scientific = TRUE, left.pad = "_", right.pad = left.pad, style = "+", expAlign=TRUE) { H <- formatHex(x, precBits=precBits, style=style, expAlign=expAlign) ## bindigits is number of binary digits after the precision point bindigits <- attr(H, "precBits") - 1L ## hexdigits is the number of hex digits after the precision point hexdigits <- 1L + ((bindigits-1L) %/% 4L)# *must* be correct = #{pure digits between "." and "p"} attributes(H) <- NULL finite <- is.finite(x) H <- H[finite] S <- substr(H, 1L, 1L) # sign A <- substr(H, 4L, 4L) B <- substr(H, 6L, 6L+hexdigits-1L) ## assumes *always* an exponent "p" which is correct pow <- substr(H, 6L+hexdigits+1L, 1000000L) sB <- strsplit(B, "") rsB <- do.call(rbind, sB) hrsB <- HextoBin[rsB] dim(hrsB) <- dim(rsB) hrsBa <- apply(hrsB, 1, paste, collapse="") hrsBb <- substr(hrsBa, 1, bindigits) ## While this is a truncation, ## the mpfr conversion assures that ## only zero characters are truncated. if (!scientific) { powers <- as.integer(pow) Left <- -powers + max(powers, 2-precBits) Right <- powers - min(powers, precBits-1) D <- cbind(S, "0b", strrep(left.pad, Left), A, hrsBb, strrep(right.pad, Right)) D2 <- apply(D, 1, function(x) do.call(paste, list(x, collapse=""))) ilft <- as.integer(max(Left) + min(powers)) + 4L res <- paste0(substr(D2, 1L, ilft ), ".", substr(D2, ilft+1L, 1000000L)) } else { res <- cbind(S, "0b", A, ".", hrsBb, "p", pow) res <- apply(res, 1, function(x) do.call(paste, list(x, collapse=""))) } result <- rep("", length(x)) result[finite] <- res result[!finite] <- as.numeric(x[!finite]) structure(result, dim = dim(x), dimnames = dimnames(x), base = 2L, precBits = precBits, class = c("Ncharacter", "character")) } print.Ncharacter <- function(x, ...) { y <- unclass(x) attr(y,"base") <- NULL attr(y,"precBits") <- NULL myR <- attr(x,"base") != 10L ## formatDec() currently left-aligns [yes, this is a hack] ## print(y, quote=FALSE, right = myR, ...) # protecting against multiple 'quote' and 'right' ## ensuring 'quote=*' and 'right=*' in '...' take precedence : pa <- c(list(...), list(quote=FALSE, right = myR)) do.call(print, c(list(y), pa[unique(names(pa))])) invisible(x) } ## RMH 2017-05-23, ~/R/MM/Pkg-ex/Rmpfr/formatDec-revised2.R : formatDec <- function(x, precBits = min(getPrec(x)), digits=decdigits, nsmall=NULL, scientific=FALSE, style="+", decimalPointAlign = TRUE, ...) { if (is.character(x)) x <- as.numeric(x) if (is.numeric(x)) x <- mpfr(x, precBits) else if (is.complex(x)) stop("complex 'x' are not supported in \"Rmpfr\" (yet)") decdigits <- ceiling(precBits*log10(2)) + 1 chx <- format(x, digits=max(digits, decdigits), nsmall=nsmall, scientific=scientific, style=style, ...) if (decimalPointAlign) { fin.x <- is.finite(x) chx[fin.x] <- formatAlign(chx[fin.x], ...) } structure(chx, dim = dim(x), dimnames = dimnames(x), base = 10L, precBits = precBits, class = c("Ncharacter", "character")) } ##' Non exported utility currently only used in formatDec(); ##' NB: '...' here, so we can pass '...' above which may have arguments not for here formatAlign <- function(x, leftpad=" ", rightpad=leftpad, ...) { if(!length(x)) return(x) lr <- strsplit(x, ".", fixed=TRUE) l <- sapply(lr, `[`, 1) ## l left r <- sapply(lr, `[`, 2) ## r right r[is.na(r)] <- "" nl <- nchar(l) nr <- nchar(r) ## substring() vectorizes (with 'nl'): l.blank <- substring(strrep(leftpad, max(nl)), 1L, max(nl) - nl) r.blank <- substring(strrep(rightpad,max(nr)), 1L, max(nr) - nr) paste0(l.blank, l, ".", r, r.blank) } ##' used in mpfr.Ncharacter() mpfr_Bcharacter <- function(x, precBits, scientific = NA, ...) { ## was scanBin() stopifnot(is.numeric(precBits)) if (is.na(scientific)) ## we look for a "p" exponent.. scientific <- any(grepl("p", x, fixed=TRUE)) class(x) <- NULL if (!scientific) { x <- gsub("_", "0", x) ## TODO: chartr(.......) } mpfr(x, base = 2, precBits=precBits, ...) } ## A mpfr() method for "Ncharacter" mpfr.Ncharacter <- function(x, precBits = attr(x, "precBits"), ...) { class(x) <- NULL B <- attr(x, "base") if(B == 2) ## formatBin() gives very special format : mpfr_Bcharacter(x, precBits = precBits, ...) else mpfr(x, base = B, precBits = precBits, ...) } ## was ## mpfr.Dcharacter <- function(x, precBits=attr(x, "bindigits")+1, ...) { ## class(x) <- NULL ## mpfr(gsub(" ", "", x), base = 10, precBits=precBits, ...) ## } `[.Ncharacter` <- ## == base :: `[.listof` function (x, ...) structure(NextMethod("["), class = class(x)) ## more sophisticated; should work for matrix subsetting as with base .. `[.Ncharacter` <- function (x, ...) { ax <- attributes(x) ## and *drop* some ax <- ax[setdiff(names(ax), c("dim", "dimnames", "names"))] if(length(ax)) { r <- NextMethod("[") # may have dim, dimnames | names `attributes<-`(r, c(attributes(r), ax)) } else NextMethod("[") } ## Don't seem to get these to work correctly (at least not easily): ## cbind.Bcharacter <- cbind.Hcharacter <- ## function (...) structure(NextMethod("cbind"), class = class(..1)) ## rbind.Bcharacter <- rbind.Hcharacter <- ## function (...) structure(NextMethod("rbind"), class = class(..1)) ## NB: It *could* make sense to set default stringsAsFactors = FALSE here.. ## but it would *not* be used when called from data.frame() which has its own default as.data.frame.Ncharacter <- function (x, ...) { ## class(x) <- class(x)[class(x) != "Ncharacter"] ## as.data.frame(x, ...) NextMethod("as.data.frame") } Rmpfr/cleanup.win0000644000176200001440000000003115075675673013525 0ustar liggesusers#! /bin/sh ./cleanup $* Rmpfr/cleanup0000755000176200001440000000006515075721241012722 0ustar liggesusers#! /bin/sh rm -f config.* src/Makevars src/config.h Rmpfr/demo/0000755000176200001440000000000015075721202012265 5ustar liggesusersRmpfr/demo/00Index0000644000176200001440000000006411764511504013422 0ustar liggesusershjkMpfr Hooke-Jeeves Minimization working for MPFR Rmpfr/demo/hjkMpfr.R0000644000176200001440000000601611764511504014017 0ustar liggesusers## some platforms hit zero exactly on the first step: ## if so the estimated precision is 2/3. cyq.f <- function (x) { rv <- cyq.res(x) ## mm <- length(rv) ## f <- 0 ## for (ii in 1:mm) f <- f+rv[ii]*rv[ii] ## f <- sum(rv*rv) f <- crossprod(rv) } cyq200.f <- function (xx) { rv <- cyq200.res(xx) ## mm <- length(rv) ## f <- 0 ## for (ii in 1:mm) f <- f+rv[ii]*rv[ii] ## f <- sum(rv*rv) ## f <- crossprod(rv) f <- sum(rv*rv) } cyq.res <- function (x) { ## Fletcher's chebyquad function m = n -- residuals n <- length(x) res <- rep(0,n) ## res <- mpfrArray(rep(0,n), 200, dim=n) # initialize for (i in 1:n) { ## loop over resids rr <- 0 for (k in 1:n) { z7 <- 1 z2 <- 2*x[k]-1 z8 <- z2 j <- 1 while (j further down %%%%%%%%%%%% % \author{Martin M\"achler \\ ETH Zurich% \\ April, Oct.\ 2012 {\tiny (\LaTeX'ed \today)}%---- for now } \title{Accurately Computing $\log(1 - \exp(-\abs{a}))$ \\ Assessed by the \pkg{Rmpfr} package} %% for pretty printing and a nice hypersummary also set: \Plainauthor{Martin M\"achler} %% comma-separated \Plaintitle{% Accurately Computing log(1 - exp(.)) -- Assessed by Rmpfr} %\VignetteIndexEntry{Accurately Computing log(1 - exp(.)) -- Assessed by Rmpfr} %\VignetteDepends{Rmpfr} %\VignetteDepends{gmp} %\VignetteDepends{sfsmisc} \SweaveOpts{engine=R,strip.white=true, width=8.5, height=6} \SweaveOpts{pdf=FALSE, eps=FALSE, grdevice = pdfaCrop} % defined in R "<>": ^^^^^^^^ %% an abstract and keywords \Abstract{In this note, we explain how $f(a) = \log(1 - e^{-a}) =\log(1 - \exp(-a))$ can be computed accurately, in a simple and optimal manner, building on the two related auxiliary functions \code{log1p(x)} ($=\log(1+x)$) and \code{expm1(x)} ($=\exp(x)-1 = e^x - 1$). The cutoff, $a_0$, in use in \R{} since % version 1.9.0, April 2004, is shown to be optimal both theoretically and empirically, using \pkg{Rmpfr} high precision arithmetic. As an aside, we also show how to compute $\log\bigl(1 + e^x \bigr)$ accurately and efficiently. } \Keywords{Accuracy, Cancellation Error, R, MPFR, Rmpfr} %% at least one keyword must be supplied %% publication information %% NOTE: Typically, this can be left commented and will be filled out by the technical editor %% \Volume{13} %% \Issue{9} %% \Month{September} %% \Year{2004} %% \Submitdate{2004-09-29} %% \Acceptdate{2004-09-29} %% The address of (at least) one author should be given %% in the following format: \Address{ Martin M\"achler\\ Seminar f\"ur Statistik, HG G~16\\ ETH Zurich\\ 8092 Zurich, Switzerland\\ E-mail: \email{maechler@stat.math.ethz.ch}\\ URL: \url{https://stat.ethz.ch/~maechler} } %% It is also possible to add a telephone and fax number %% before the e-mail in the following format: %% Telephone: +43/1/31336-5053 %% Fax: +43/1/31336-734 %% for those who use Sweave please include the following line (with % symbols): %% MM: this is "substituted" by jss.cls: %% need no \usepackage{Sweave.sty} \usepackage[american]{babel}%for American English \usepackage{amsmath}%sophisticated mathematical formulas with amstex (includes \text{}) \usepackage{mathtools}%fix amsmath deficiencies \usepackage{amssymb}%sophisticated mathematical symbols with amstex (includes \mathbb{}) % \usepackage{amsthm}%theorem environments \usepackage{bm}%for bold math symbols: \bm (= bold math) \usepackage{enumitem}%for automatic numbering of new enumerate environments % This is already in jss above -- but withOUT the fontsize=\small part !! \DefineVerbatimEnvironment{Sinput}{Verbatim}{fontsize=\small,fontshape=sl} \DefineVerbatimEnvironment{Soutput}{Verbatim}{fontsize=\small} \DefineVerbatimEnvironment{Scode}{Verbatim}{fontsize=\small,fontshape=sl} %%~-~-~-~ Make space between Sinput and Soutput smaller: ~-~-~-~~-~-~-~~-~-~-~~-~-~-~~-~-~-~ %%--- Best advice, now from : % http://tex.stackexchange.com/questions/19359/reduce-space-between-sinput-and-soutput \newlength{\FVtopsep} \newlength{\FVpartopsep} \newlength{\FVparskip}% <- added as "no. 3" by MMa (after reading fancyvrb doc) \makeatletter \FV@AddToHook{\FV@ListParameterHook}{\topsep=\FVtopsep\partopsep=\FVpartopsep\parskip=\FVparskip} \makeatother % Control the spacing around the Sinput and Soutput environments by using the lengths % % \FVtopsep % \FVpartopsep % \FVparskip % % Both *topsep act quite similar most of the time, more details % can be found in the fancyvrb documentation on page 46. (MM: ==> I add FVparskip) %To kill all extra spacing between the environments, use {0pt} in all these %MM: When all three(!) are {0pt}, there's a large gap *after* Schunk (nothing in %between) %-- and that (end gap) get's smaller when I set all to {1pt} -- logic?? %___TODO/FIXME: Set of experiments (with smaller Sweave file)___ \setlength{\FVtopsep}{1pt} \setlength{\FVpartopsep}{1pt} \setlength{\FVparskip}{\parskip}% default: \parskip %%~-~-~-~ End {Sweave space handling} ~-~-~-~~-~-~-~~-~-~-~~-~-~-~~-~-~-~~-~-~~-~-~-~~-~-~ %% \setkeys{Gin}{width=\textwidth}% Sweave.sty has {width=0.8\textwidth} \newcommand*{\R}{\proglang{R}}%{\textsf{R}} \newcommand*{\CRANpkg}[1]{\href{http://CRAN.R-project.org/package=#1}{\pkg{#1}}} \newcommand*{\eps}{\varepsilon} %- \abs{ab} --> | ab | ``absolut Betrag'' \newcommand{\abs}[1] {\left| #1 \right|} % \renewcommand*{\S}{\operatorname*{S}} % \newcommand*{\tS}{\operatorname*{\tilde{S}}} % \newcommand*{\ran}{\operatorname*{ran}} %\newcommand*{\sgn}{\operatorname*{sgn}} \DeclareMathOperator{\sign}{sign} % \renewcommand*{\L}{\mathcal{L}} % \newcommand*{\Li}{\mathcal{L}^{-1}} % \newcommand*{\LS}{\mathcal{LS}} % \newcommand*{\LSi}{\LS^{-1}} \renewcommand*{\O}{\mathcal{O}} % \newcommand*{\Geo}{\operatorname*{Geo}} % \newcommand*{\Exp}{\operatorname*{Exp}} % \newcommand*{\Sibuya}{\operatorname*{Sibuya}} % \newcommand*{\Log}{\operatorname*{Log}} % \newcommand*{\U}{\operatorname*{U}} % \newcommand*{\B}{\operatorname*{B}} % \newcommand*{\NB}{\operatorname*{NB}} % \newcommand*{\N}{\operatorname*{N}} \DeclareMathOperator{\var}{var} \DeclareMathOperator{\Var}{Var} \DeclareMathOperator{\Cov}{Cov} \DeclareMathOperator{\cov}{cov} \DeclareMathOperator{\Cor}{Corr} \DeclareMathOperator{\cor}{corr} % \newcommand*{\Var}{\operatorname*{Var}} % \newcommand*{\Cov}{\operatorname*{Cov}} % \newcommand*{\Cor}{\operatorname*{Cor}} % % \newcommand*{\loglp}{\operatorname*{log1p}} % \newcommand*{\expml}{\operatorname*{expm1}} %% cannot use "1" in latex macro name -- use "l": \newcommand*{\loglp}{\mathrm{log1p}} \newcommand*{\expml}{\mathrm{expm1}} %% journal specific aliases \newcommand*{\setcapwidth}[1]{} %% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{document} %% include your article here, just as usual %% Note that you should use the \pkg{}, \proglang{} and \code{} commands. % \section[About Java]{About \proglang{Java}} %% Note: If there is markup in \(sub)section, then it has to be escape as above. %% %% Note: These are explained in '?RweaveLatex' : <>= ## Our custom graphics device: pdfaCrop <- function(name, width, height, ...) { fn <- paste(name, "pdf", sep = ".") if(FALSE)## debug cat("pdfaCrop: fn = ",fn,"; call:\n\t",deparse(match.call()),"\n") grDevices::pdf(fn, width = width, height = height, onefile=FALSE)# ...) assign(".pdfaCrop.name", fn, envir = globalenv()) } ## This is used automagically : pdfaCrop.off <- function() { dev.off()# for the pdf f <- get(".pdfaCrop.name", envir = globalenv()) ## and now crop that file: pdfcrop <- "pdfcrop" # relying on PATH - fix if needed pdftex <- "pdftex" # relying on PATH - fix if needed system(paste(pdfcrop, "--pdftexcmd", pdftex, f, f, "1>/dev/null 2>&1"), intern=FALSE) } op.orig <- options(width = 75, SweaveHooks= list(fig=function() par(mar=c(5.1, 4.1, 1.1, 2.1))), digits = 5, useFancyQuotes = "TeX", ## for JSS, but otherwise MM does not like it: ## prompt="R> ", continue=" ")# 2 (or 3) blanks: use same length as 'prompt' if((p <- "package:fortunes") %in% search()) try(detach(p, unload=TRUE, char=TRUE)) Sys.setenv(LANGUAGE = "en") if(.Platform$OS.type != "windows") Sys.setlocale("LC_MESSAGES","C") if(getRversion() < "2.15") paste0 <- function(...) paste(..., sep = '') library("sfsmisc")# e.g., for eaxis() library("Rmpfr") .plot.BC <- FALSE # no Box-Cox plot @ %\section[Introduction]{Introduction \small~\footnote{\mythanks}} \section{Introduction: Not log() nor exp(), but log1p() and expm1()} In applied mathematics, it has been known for a very long time that direct computation of $\log(1 + x)$ suffers from severe cancellation (in ``$1 + x$'') whenever $\abs{x} \ll 1$, and for that reason, we have provided \code{log1p(x)} in \R{}, since R version 1.0.0 (released, Feb.~29, 2000). Similarly, \code{log1p()} has been provided by C math libraries and has become part of C language standards around the same time, see, for example, \citet{ieee04:log1p}. Analogously, since \R{}~1.5.0 (April 2002), the function \code{expm1(x)} computes $\exp(x) - 1 = e^x - 1$ accurately also for $\abs{x} \ll 1$, where $e^x \approx 1$ is (partially) cancelled by ``$-\: 1$''. In both cases, a simple solution %approach for small $\abs{x}$ is to use a few terms of the Taylor series, as \begin{align} \label{eq:Taylor-log1p} \loglp(x) &= \log(1 + x) = x - x^2/2 + x^3/3 -+ \dots, \ \mathrm{for}\ \ \abs{x} < 1, %\mathrm{and} \\ \label{eq:Taylor-expm1} \expml(x) &= \exp(x) - 1 = x + x^2/2! + x^3/3! + \dots, \ \mathrm{for}\ \ \abs{x} < 1, \end{align} and $n!$ denotes the factorial. We have found, however, that in some situations, the use of \code{log1p()} and \code{expm1()} may not be sufficient to prevent loss of numerical accuracy. The topic of this note is to analyze the important case of computing $\log\left(1 - e^x \right) = \log(1 - \exp(x))$ for $x < 0$, computations needed in accurate computations of the beta, gamma, exponential, Weibull, t, logistic, geometric and hypergeometric distributions, %% in ~/R/D/r-devel/R/src/nmath/ : %% grep --color -nHEw -e '(R_Log1_Exp|R_D_LExp|R_DT_Log|R_DT_C?log)' *.? %% --> ~/R/Pkgs/Rmpfr/vignettes/log1mexp_grep and % because of the latter, even for the logit link function in logistic regression. For the beta and gamma distributions, see, for example, % e.g., \citet{DidAM92}\footnote{In the Fortran source, file ``\code{708}'', also available as \url{http://www.netlib.org/toms/708}, the function ALNREL() computes log1p() and REXP() computes expm1().}, and further references mentioned in \R{}'s \code{?pgamma} and \code{?pbeta} help pages. For the logistic distribution, $F_L(x) = \frac{e^x}{1+e^x}$, the inverse, aka quantile function is $q_L(p) = \mathrm{logit}(p) := \log \frac{p}{1-p}$. If the argument $p$ is provided on the log scale, $\tilde p := \log p$, hence $\tilde p \le 0$, we need \begin{align} \label{eq:qlogis} \mathtt{qlogis}(\tilde p,\: \mathtt{log.p=TRUE}) = q_L\!\left(e^{\tilde p}\right) = \mathrm{logit}\!\left(e^{\tilde p}\right) % = \log\Bigl(\frac{e^{\tilde p}}{1-e^{\tilde p}}\Bigr) = \log \frac{e^{\tilde p}}{1-e^{\tilde p}} = \tilde p - \log\left(1 - e^{\tilde p} \right), \end{align} and the last term is exactly the topic of this note. \section{log1p() and expm1() for log(1 - exp(x))} Contrary to what one would expect, for computing $\log\left(1 - e^x \right) = \log(1 - \exp(x))$ for $x < 0$, neither \begin{align} \label{eq:f.expm1} \log(1 - \exp(x)) &= \log(-\expml(x)), \ \ \mathrm{nor}\\ \label{eq:f.log1p} \log(1 - \exp(x)) &= \loglp(-\exp(x)), \end{align} are uniformly sufficient for numerical evaluation. %% 1 In (\ref{eq:f.log1p}), when $x$ approaches $0$, $\exp(x)$ approaches $1$ and $\loglp(-\exp(x))$ loses accuracy. %% 2 In (\ref{eq:f.expm1}), when $x$ is large, $\expml(x)$ approaches $-1$ and similarly loses accuracy. Because of this, we will propose to use a function \code{log1mexp(x)} which uses either \code{expm1} (\ref{eq:f.expm1}) or \code{log1p} (\ref{eq:f.log1p}), where appropriate. Already in \R{}~1.9.0 (\cite{R-190}), % (April 2004) % now, both R_Log1_Exp() and --> R_D_LExp(x) := (log_p ? R_Log1_Exp(x) : log1p(-x)) we have defined the macro \verb|R_D_LExp(x)| to provide these two cases %branches automatically\footnote{look for ``log(1-exp(x))'' in \url{http://svn.r-project.org/R/branches/R-1-9-patches/src/nmath/dpq.h}}. % R-1.8.1: pgamma(30,100, lower=FALSE, log=TRUE) gave 0 instead of -... To investigate the accuracy losses empirically, we make use of the \R{} package \CRANpkg{Rmpfr} for arbitrarily accurate numerical computation, and use the following simple functions: <>= library(Rmpfr) t3.l1e <- function(a) { c(def = log(1 - exp(-a)), expm1 = log( -expm1(-a)), log1p = log1p(-exp(-a))) } @ <>= leg <- local({ r <- body(t3.l1e)[[2]]; r[[1]] <- `expression`; eval(r) }) ## will be used below @ <>= ##' The relative Error of log1mexp computations: relE.l1e <- function(a, precBits = 1024) { stopifnot(is.numeric(a), length(a) == 1, precBits > 50) da <- t3.l1e(a) ## double precision a. <- mpfr(a, precBits=precBits) ## high precision *and* using the correct case: mMa <- if(a <= log(2)) log(-expm1(-a.)) else log1p(-exp(-a.)) structure(as.numeric(1 - da/mMa), names = names(da)) } @ <>= <> <> @ where the last one, \code{relE.l1e()} computes the relative error of three different ways to compute $\log(1 - \exp(-a))$ for positive $a$ (instead of computing $\log(1 - \exp(x))$ for negative $x$). %% TODO? "cache = TRUE": --- <>= a.s <- 2^seq(-55, 10, length = 256) ra.s <- t(sapply(a.s, relE.l1e)) <>= <> cbind(a.s, ra.s) # comparison of the three approaches <>= <> capture.and.write(cbind(a.s, ra.s), 8, last = 6) @ This is revealing: Neither method, log1p or expm1, is uniformly good enough. Note that for large $a$, the relative errors evaluate to \code{1}. This is because all three double precision methods give 0, \emph{and} that is the best approximation in double precision (but not in higher \code{mpfr} precision), hence no problem at all, and we can restrict ourselves to smaller $a$ (smaller than about 710, here).% < 709.78271289338403 (lynne 64b) <>= ii <- a.s < 710 a.s <- a.s[ii] ra.s <- ra.s[ii, ] @ What about really small $a$'s? Note here that <>= t3.l1e(1e-20) as.numeric(t3.l1e(mpfr(1e-20, 256))) @ % ## expm1 def log1p % ## -46.0517 -Inf -Inf % as.numeric(): % ## [1] -46.0517 -46.0517 -46.0517 both the default and the \code{log1p} method return \code{-Inf}, so, indeed, the \code{expm1} method is absolutely needed here. Figure~\ref{fig:bigpic} visualizes the relative errors\footnote{% Absolute value of relative errors, $\abs{(\hat{f}(a) - f(a)) / f(a)} = \abs{1 - \hat{f}(a)/f(a)}$, where $f(a) = \mathrm{log1mexp}(a)$ (\ref{eq:log1mexp}) is computed accurately by a 1024 bit \pkg{Rmpfr} computation} of the three methods. Note that the default basically gives the maximum of the two methods' errors, whereas the final \code{log1mexp()} function will have (approximately) minimal error of the two. %% --- Define figure_1 here ------------------------------ <>= par(mar = c(4.1,4.1,0.6,1.6)) cc <- adjustcolor(c(4,1,2),.8, red.f=.7) lt <- c("solid","33","3262") ll <- c(.7, 1.5, 2) @ %% main = "|relative errors| of three methods for log(1 - exp(-a))" <>= matplot(a.s, abs(ra.s), type = "l", log = "xy", col=cc, lty=lt, lwd=ll, xlab = "a", ylab = "", axes=FALSE) legend("top", leg, col=cc, lty=lt, lwd=ll, bty="n") draw.machEps <- function(alpha.f = 1/3, col = adjustcolor("black", alpha.f)) { abline(h = .Machine$double.eps, col=col, lty=3) axis(4, at=.Machine$double.eps, label=quote(epsilon[c]), las=1, col.axis=col) } eaxis(1); eaxis(2); draw.machEps(0.4) @ %% TODO? "cache = TRUE": echo=FALSE: do not show already, but need (a.,ra2) <>= a. <- (1:400)/256 ra <- t(sapply(a., relE.l1e)) ra2 <- ra[,-1] @ \begin{figure}[htb!] \centering % increasing width --> effective LaTeX *height* will decrease <>= <> <> ## draw the zoom-in region into the plot: yl <- range(pmax(1e-18, abs(ra2))) rect(min(a.), yl[1], max(a.), yl[2], col= adjustcolor("black", .05), border="gray", pch = 5) @ \setcapwidth{\textwidth}% \caption[Relative errors of log1mexp() approximations]{% Relative errors$^{*}$ of the default, $\log(1 - e^{-a})$, and the two methods ``\code{expm1}'' $\log(-\expml(-a))$ and ``\code{log1p}'' $\loglp(-\exp(-a))$. Figure~\ref{fig:zoomin-pic} will be a zoom into the gray rectangular region where all three curves are close.} \label{fig:bigpic} \end{figure} In Figure~\ref{fig:zoomin-pic} below, we zoom into the region where all methods have about the same (good) accuracy. The region is the rectangle defined by the ranges of \code{a.} and \code{ra2}: <>= <> @ In addition to zooming in Figure~\ref{fig:bigpic}, we want to smooth the two curves, using a method assuming approximately normal errors. Notice however that neither the original, nor the log-transformed values have approximately symmetric errors, so we use \code{MASS::boxcox()} to determine the ``correct'' power transformation, <>= da <- cbind(a = a., as.data.frame(ra2)) library(MASS) bc1 <- boxcox(abs(expm1) ~ a, data = da, lambda = seq(0,1, by=.01), plotit=.plot.BC) bc2 <- boxcox(abs(log1p) ~ a, data = da, lambda = seq(0,1, by=.01), plotit=.plot.BC) c(with(bc1, x[which.max(y)]), with(bc2, x[which.max(y)]))## optimal powers ## ==> taking ^ (1/3) : s1 <- with(da, smooth.spline(a, abs(expm1)^(1/3), df = 9)) s2 <- with(da, smooth.spline(a, abs(log1p)^(1/3), df = 9)) @ i.e, the optimal boxcox exponent turns out to be close to $\frac 1 3$, which we use for smoothing in a ``zoom--in'' of Figure~\ref{fig:bigpic}. Then, the crossover point of the two curves already suggests that the cutoff, $a_0 = \log 2$ is empirically very close to optimal. <>= matplot(a., abs(ra2), type = "l", log = "y", # ylim = c(-1,1)*1e-12, col=cc[-1], lwd=ll[-1], lty=lt[-1], ylim = yl, xlab = "a", ylab = "", axes=FALSE) legend("topright", leg[-1], col=cc[-1], lwd=ll[-1], lty=lt[-1], bty="n") eaxis(1); eaxis(2); draw.machEps() lines(a., predict(s1)$y ^ 3, col=cc[2], lwd=2) lines(a., predict(s2)$y ^ 3, col=cc[3], lwd=2) @ %% no title here: main = "|relative errors| of two methods for log(1 - exp(-a))") \enlargethispage{5ex} \begin{figure}[hbt!] \centering <>= cl2 <- adjustcolor("slateblue", 1/2)# (adj: lwd=3) # the color for "log(2)" par(mar = c(4.1,4.1,0.6,1.6)) <> abline(v = log(2), col=cl2, lty="9273", lwd=2.5) cl2. <- adjustcolor(cl2, 2) axis(1, at=log(2), label=quote(a[0] == log~2), las=1, col.axis=cl2.,col=cl2, lty="9273", lwd=2.5) ## what system is it ? sysInf <- Sys.info()[c("sysname", "release", "nodename", "machine")] mtext(with(as.list(sysInf), paste0(sysname," ",release,"(",substr(nodename,1,16),") -- ", machine)), side=1, adj=1, line=2.25, cex = 3/4) @ \setcapwidth{\textwidth}% \caption{A ``zoom in'' of Figure~\ref{fig:bigpic} showing the region where the two basic methods, ``\code{expm1}'' and ``\code{log1p}'' switch their optimality with respect to their relative errors. Both have small relative errors in this region, typically below $\eps_c :=$% \code{.Machine\$double.eps} $=2^{-52} \approx 2.22\cdot 10^{-16}$. \ \ The smoothed curves indicate crossover close to $a = a_0 := \log 2$.} \label{fig:zoomin-pic} \end{figure} \paragraph{Why is it very plausible to take $a_0 := \log 2$ as approximately optimal cutoff?} Already from Figure~\ref{fig:zoomin-pic}, empirically, an optimal cutoff $a_0$ is around $0.7$. We propose to compute \begin{align} \label{eq:def-log1mexp} f(a) = \log\left(1 - e^{-a}\right) = \log(1 - \exp(-a)), \ \ a > 0, \end{align} by a new method or function \code{log1mexp(a)}. It needs a cutoff $a_0$ between choosing \code{expm1} for $0 < a \le a_0$ and \code{log1p} for $a > a_0$, i.e., \begin{align} \label{eq:log1mexp} f(a) = \mathrm{log1mexp}(a) := \begin{cases} \log(-\expml(-a)) & 0 < a \le a_0 \ \ ( := \log 2 \approx 0.693) \\ \loglp(-\exp(-a)) & \phantom{0 < {}}a > a_0. \end{cases} \end{align} The mathematical argument for choosing $a_0$ is quite simple, at least informally: In which situations does $1 - e^{-a}$ loose bits (binary digits) \emph{entirely independently} of the computational algorithm? Well, as soon as it ``spends'' bits just to store its closeness to $1$. And that is as soon as $e^{-a} < \frac 1 2 = 2^{-1}$, because then, at least one bit cancels. This however is equivalent to $-a < \log(2^{-1}) = -\log(2)$ or $a > \log 2 =: a_0$. \section{Computation of log(1+exp(x))} Related to $\mathrm{log1mexp}(a)=\log(1 - e^{-a})$ is the log survival function of the logistic distribution % (see above)%: defined F_L $\log(1 - F_L(x)) = \log\frac{1}{1+e^x} = -\log(1 + e^x) = -g(x)$, where \begin{align} \label{eq:def-log1pexp} g(x) := \log(1 + e^x) = \loglp(e^x), \end{align} which has a ``$+"$'' instead of a ``$-$'', compared to $\mathrm{log1mexp}$, and is easier to analyze and compute, its only problem being large $x$'s where $e^x$ % = \exp x$ overflows numerically.\footnote{Indeed, for $x=710$, $ -g(x) = \log(1 - F_L(x)) = $ \code{plogis(710, lower=FALSE, log.p=TRUE)}, underflowed to \code{-Inf} in \R{} versions before 2.15.1 (June 2012) from when on (\ref{eq:log1pexp}) has been used.} As $g(x)= \log(1 + e^x) = \log(e^x(e^{-x} + 1)) = x + \log(1 + e^{-x})$, we see from (\ref{eq:Taylor-log1p}) that \begin{align} \label{eq:log1pexp-asym} g(x) = x + \log(1 + e^{-x}) = % \sim %\asymp %% x + e^{-x}(1 - e^{-x}/2) + \O((e^{-x})^3), x + e^{-x} + \O((e^{-x})^2), \end{align} for $x\to\infty$. Note further, that for $x\to-\infty$, we can simplify $g(x)=\log(1 + e^x)$ to $e^x$. A simple picture quickly reveals how different approximations behave, where we have used \code{uniroot()} to determine the zero crossing, but will use slightly simpler cutoffs $x_0=37$, $x_1$ and $x_2$, in (\ref{eq:log1pexp}) below: %% Notation x_0, x_1, x_2 are related to the 1st, 2nd and 3rd cutoff in equation (10) %% -37 18 33.3 <>= ## Find x0, such that exp(x) =.= g(x) for x < x0 : f0 <- function(x) { x <- exp(x) - log1p(exp(x)) x[x==0] <- -1 ; x } u0 <- uniroot(f0, c(-100, 0), tol=1e-13) str(u0, digits=10) x0 <- u0[["root"]] ## -36.39022698 --- note that ~= \log(\eps_C) all.equal(x0, -52.5 * log(2), tol=1e-13) ## Find x1, such that x + exp(-x) =.= g(x) for x > x1 : f1 <- function(x) { x <- (x + exp(-x)) - log1p(exp(x)) x[x==0] <- -1 ; x } u1 <- uniroot(f1, c(1, 20), tol=1e-13) str(u1, digits=10) x1 <- u1[["root"]] ## 16.408226 ## Find x2, such that x =.= g(x) for x > x2 : f2 <- function(x) { x <- log1p(exp(x)) - x ; x[x==0] <- -1 ; x } u2 <- uniroot(f2, c(5, 50), tol=1e-13) str(u2, digits=10) x2 <- u2[["root"]] ## 33.27835 @ %% but really the above is still ``non sense'': look at <>= par(mfcol= 1:2, mar = c(4.1,4.1,0.6,1.6), mgp = c(1.6, 0.75, 0)) curve(x+exp(-x) - log1p(exp(x)), 15, 25, n=2^11); abline(v=x1, lty=3) curve(log1p(exp(x)) - x, 33.1, 33.5, n=2^10); abline(v=x2, lty=3) @ \medskip Using double precision arithmetic, a fast and accurate computational method is to use \begin{align} \label{eq:log1pexp} \hat{g}(x) = \mathrm{log1pexp}(x) := \begin{cases} \exp(x) & x \le -37 \\ \loglp(\exp(x)) & -37 < x \le x_1 := 18, \\ x + \exp(-x) & x_1 < x \le x_2 := 33.3, \\ x & x > x_2, \end{cases} \end{align} where only the cutoff $x_1 = 18$ is important and the other cutoffs just save computations.\footnote{see % the %\R{} plot \code{curve(log1p(exp(x)) - x, 33.1, 33.5, n=2\^{}10)} above, revealing a somewhat fuzzy cutoff $x_2$.} %%--- Ok, still do a little deeper analysis for the interested R code reader %%--- invisibly mostly (echo=FALSE) here: <>= t4p.l1e <- function(x) { c(def = log(1 + exp(x)), log1p = log1p(exp(x)), ## xlog1p = x + log1p(exp(-x)), xpexp = x + exp(-x), x = x) } leg <- local({ r <- body(t4p.l1e)[[2]]; r[[1]] <- `expression`; eval(r) }) ##' The relative Error of log1pexp computations: relE.pl1e <- function(x, precBits = 1024) { stopifnot(is.numeric(x), length(x) == 1, precBits > 50) dx <- t4p.l1e(x) ## double precision x. <- mpfr(x, precBits=precBits) ## high precision *and* using the correct case: mMx <- if(x < 0) log1p(exp(x.)) else x. + log1p(exp(-x.)) structure(as.numeric(1 - dx/mMx), names = names(dx)) } <>= x.s <- seq(-100, 750, by = 5) # <- the big picture ==> problem for default x.s <- seq( 5, 60, length=512) # <- the zoom in ==> *no* problem for def. rx.s <- t(sapply(x.s, relE.pl1e)) signif(cbind(x.s, rx.s),3) @ \begin{figure}[htb!] \centering %% using "blue" for the default method, *as* in Figure 1 above <>= par(mar = c(4.1,4.1,0.6,1.6), mgp = c(1.6, 0.75, 0)) cc <- adjustcolor(c(4,1,2,3),.8, red.f=.7, blue.f=.8) lt <- c("solid","33","3262","dotdash") ll <- c(.7, 1.5, 2, 2) ym <- 1e-18 yM <- 1e-13 matplot(x.s, pmax(pmin(abs(rx.s),yM),ym), type = "l", log = "y", axes=FALSE, ylim = c(ym,yM), col=cc, lty=lt, lwd=ll, xlab = "x", ylab = "") legend("topright", leg, col=cc, lty=lt, lwd=ll, bty="n") eaxis(1, at=pretty(range(x.s), n =12)); eaxis(2) draw.machEps(0.4) x12 <- c(18, 33.3) abline(v=x12, col=(ct <- adjustcolor("brown", 0.6)), lty=3) axis(1, at=x12, labels=formatC(x12), padj = -3.2, hadj = -.1, tcl = +.8, col=ct, col.axis=ct, col.ticks=ct) @ % increasing width --> effective LaTeX *height* will decrease \setcapwidth{\textwidth}% \caption{Relative errors (via \pkg{Rmpfr}, see footnote of Fig.~\ref{fig:bigpic}) of four different ways to numerically compute $\log\bigl(1 + e^{x}\bigr)$. Vertical bars at $x_1 = 18$ and $x_2 = 33.3$ visualize the (2nd and 3rd) cutpoints of (\ref{eq:log1pexp}).} % Moved into text:|| down Note that the default method is fully accurate on this $x$ range. \label{fig:log1pexp} \end{figure} Figure~\ref{fig:log1pexp} visualizes the relative errors of the careless ``default'', $\log\bigl(1 + e^{x}\bigr)$, its straightforward correction $\loglp\bigl(e^x\bigr)$, the intermediate approximation $x + e^{-x}$, and the large $x$ ($ = x$), i.e., the methods in (\ref{eq:log1pexp}), depicting that the (easy to remember) cutoffs $x_1$ and $x_2$ in (\ref{eq:log1pexp}) are valid. %% moved from figure caption: Note that the default method is fully accurate on this $x$ range and only problematic when $e^x$ begins to overflow, i.e., $x > e_{\mathrm{Max}}$, which is <>= (eMax <- .Machine$double.max.exp * log(2)) exp(eMax * c(1, 1+1e-15)) @ where we see that indeed $e_{\mathrm{Max}} = $\code{eMax} is the maximal exponent without overflow. \section{Conclusion} We have used high precision arithmetic (\R{} package \pkg{Rmpfr}) to empirically verify that computing $f(a) = \log\left(1 - e^{-a}\right)$ is accomplished best via equation (\ref{eq:log1mexp}). In passing, we have also shown that accurate computation of $g(x) = \log(1+e^x)$ can be achieved via (\ref{eq:log1pexp}). % Note that %% FIXME: %% a short version of this note has been published .... %% \cite{....} a version of this note is available as vignette (in \texttt{Sweave}, i.e., with complete \R{} source) from the \pkg{Rmpfr} package vignettes. \subsection*{Session Information} \nopagebreak <>= toLatex(sessionInfo(), locale=FALSE) <>= options(op.orig) @ %\clearpage \bibliography{log1mexp} \end{document} Rmpfr/vignettes/Rmpfr.bib0000644000176200001440000000460012250313503015106 0ustar liggesusers@Manual{MM-Rmpfr_pkg, title = {Rmpfr: R MPFR - Multiple Precision Floating-Point Reliable}, author = {Martin Maechler}, year = 2011, url = {http://rmpfr.r-forge.r-project.org/}, note = {R package version 0.4-2} } @article{FouLHLPZ:2007, author = {Laurent Fousse and Guillaume Hanrot and Vincent Lef\`{e}vre and Patrick P\'{e}lissier and Paul Zimmermann}, title = {MPFR: A multiple-precision binary floating-point library with correct rounding}, year = 2007, journal = {ACM Trans. Math. Softw.}, volume = 33, number = 2, issn = {0098-3500}, pages = 13, url = {http://doi.acm.org/10.1145/1236463.1236468}, acmid = 1236468, publisher = {ACM}, address = {New York, NY, USA}, keywords = {IEEE 754 standard, Multiple-precision arithmetic, correct rounding, elementary function, floating-point arithmetic, portable software}, } @comment not with jss.bst: @comment doi = {http://doi.acm.org/10.1145/1236463.1236468}, @manual{FousseHLPZ-MPFR:2011, author = {Fousse, Laurent and Hanrot, Guillaume and Lef\`{e}vre, Vincent and P\'{e}lissier, Patrick and Zimmermann, Paul}, year = 2011, title = {MPFR: A multiple-precision binary floating-point library with correct rounding}, url = {http://mpfr.org/}, } % Bauer:1961:ARI:366573.366594, @article{Bauer-1961, author = {Bauer, F. L.}, title = {Algorithm 60: Romberg integration}, journal = {Commun. ACM}, year = 1961, volume = 4, issue = 6, month = {June}, issn = {0001-0782}, pages = 255, url = {http://doi.acm.org/10.1145/366573.366594}, doi = {http://doi.acm.org/10.1145/366573.366594}, acmid = 366594, publisher = {ACM}, address = {New York, NY, USA}, } @manual{GMP:2011, author = {Torbjörn Granlund and the GMP development team}, year = 2011, title = {GNU MP - The GNU Multiple Precision Arithmetic Library}, url = {http://gmplib.org/}, } % citation(package="sfsmisc") @Manual{maechler-sfsmisc, title = {sfsmisc: Utilities from Seminar fuer Statistik ETH Zurich}, author = {Martin Maechler}, year = 2012, note = {R package version 1.0-23}, url = {http://CRAN.R-project.org/package=sfsmisc}, } @Manual{maechler-Bessel, title = {Bessel: Bessel -- Bessel Functions Computations and Approximations}, author = {Martin Maechler}, year = 2012, note = {R package version 0.5-4}, url = {http://CRAN.R-project.org/package=Bessel}, } Rmpfr/vignettes/log1mexp.bib0000644000176200001440000000272112057434374015575 0ustar liggesusers@article{DidAM92, author = {DiDonato, Armido R. and Morris, Jr., Alfred H.}, title = {Algorithm 708: Significant digit computation of the incomplete beta function ratios}, journal = TOMS, year = 1992, volume = 18, number = 3, issn = {0098-3500}, pages = {360--373}, url = {http://doi.acm.org/10.1145/131766.131776}, publisher = {ACM}, address = {New York, NY, USA}, } @InProceedings{ieee04:log1p, author = {IEEE and {Open Group}}, title = {The Open Group Base Specifications Issue 6 --- log1p}, booktitle = {IEEE Std 1003.1, 2004 Edition}, year = 2004, url = {http://pubs.opengroup.org/onlinepubs/009604599/functions/log1p.html} } @comment The version of R, where MM introduced the R_D_LExp() macro in dpq.h: @Manual{R-190, title = {R: A language and environment for statistical computing (Ver.~1.9.0)}, author = {{R Development Core Team}}, organization = {R Foundation for Statistical Computing}, address = {Vienna, Austria}, year = 2004, month = {April}, note = {ISBN 3-900051-00-3}, url = {http://www.R-project.org} } @Manual{MaeM12-Rmpfr-log1mexp, author = {Martin M\"achler}, title = {Accurately Computing $\log(1 - \exp(-\abs{a}))$ -- Assessed by the \pkg{Rmpfr} package}, year = 2012, organization = {R package vignette}, address = {on CRAN}, url={http://cran.R-project.org/web/packages/Rmpfr/vignettes/log1mexp-note.pdf} } Rmpfr/vignettes/Maechler_useR_2011-abstr.Rnw0000644000176200001440000001227112174274363020346 0ustar liggesusers\documentclass[11pt, a4paper]{article} \usepackage{amsfonts, amsmath, hanging, hyperref, natbib, parskip, times} \usepackage[pdftex]{graphicx} \hypersetup{ colorlinks, linkcolor=blue, urlcolor=blue } \SweaveOpts{eps=FALSE,pdf=TRUE,width=7,height=4,strip.white=true,keep.source=TRUE} %\VignetteIndexEntry{useR-2011-abstract} %\VignetteDepends{Rmpfr} <>= options(SweaveHooks= list(fig=function() par(mar=c(5.1, 4.1, 1.1, 2.1))), width = 75) Sys.setenv(LANGUAGE = "en") if(.Platform$OS.type != "windows") Sys.setlocale("LC_MESSAGES","C") stopifnot(require("Rmpfr")) @ \let\section=\subsubsection \newcommand{\pkg}[1]{{\normalfont\fontseries{b}\selectfont #1}} \let\proglang=\textit \let\code=\texttt \renewcommand{\title}[1]{\begin{center}{\bf \LARGE #1}\end{center}} \newcommand{\affiliations}{\footnotesize} \newcommand{\keywords}{\paragraph{Keywords:}} \setlength{\topmargin}{-15mm} \setlength{\oddsidemargin}{-2mm} \setlength{\textwidth}{165mm} \setlength{\textheight}{250mm} \usepackage{Sweave} \DefineVerbatimEnvironment{Sinput}{Verbatim}{fontsize=\small,fontshape=sl} \DefineVerbatimEnvironment{Soutput}{Verbatim}{fontsize=\small} \DefineVerbatimEnvironment{Scode}{Verbatim}{fontsize=\small,fontshape=sl} % but when submitting, do get rid of too much vertical space between R % input & output, i.e. between Sinput and Soutput: \fvset{listparameters={\setlength{\topsep}{0pt}}}% !! quite an effect! %% % \newcommand*{\R}{\proglang{R}}%{\textsf{R}} \begin{document} \pagestyle{empty} \vspace*{-15ex} \begin{flushleft}\footnotesize Corrected abstract for ``late-breaking poster'' and ``Lightning talk'' to be held at ``UseR! 2011'', U.~Warwick, 16th Aug.~2011%, 17:00--18:00 \\[-1ex]\noindent\rule{\textwidth}{0.5pt}\\ % horizontal line \end{flushleft} \vspace*{+9ex} \title{Arbitrarily Accurate Computation with R: Package 'Rmpfr'} \begin{center} {\bf Martin M\"achler$^{1,2,^\star}$} \end{center} \begin{affiliations} 1. ETH Zurich (Seminar for Statistics), Switzerland \\[-2pt] 2. R Core Development Team \\[-2pt] $^\star$Contact author: \href{mailto:maechler@stat.math.ethz.ch}{maechler@stat.math.ethz.ch} \end{affiliations} \keywords Arbitrary Precision, High Accuracy, Multiple Precision Floating-Point, Rmpfr \vskip 0.8cm % Some suggestions: if you mention a programming language like % \proglang{R}, typeset the language name with the {\tt \textbackslash % proglang\{\}} command. If you mention an \proglang{R} function \code{foo}, % typeset the function name with the with the {\tt\textbackslash code\{\}} % command. If you mention an \proglang{R} package \pkg{fooPkg}, typeset % the package name with the {\tt\textbackslash pkg\{\}} command. % Abstracts should not exceed one page. The page should not be numbered. The \proglang{R}\ package \pkg{Rmpfr} allows to use arbitrarily precise numbers instead of \proglang{R}'s double precision numbers in many \proglang{R}\ computations and functions. This is achieved by defining S4 classes of such numbers and vectors, matrices, and arrays thereof, where all arithmetic and mathematical functions work via the (GNU) MPFR C library, where MPFR is acronym for ``\emph{\textbf{M}ultiple \textbf{P}recision \textbf{F}loating-Point \textbf{R}eliably}''\nocite{FousseHLPZ:2007}. MPFR is Free Software, available under the LGPL license\nocite{FousseHLPZ-MPFR:2011}, and itself is built on the free GNU Multiple Precision arithmetic library (GMP)\nocite{GMP:2011}. Consequently, by using \pkg{Rmpfr}, you can often call your \proglang{R}\ function or numerical code with mpfr--numbers instead of simple numbers, and all results will automatically be much more accurate. <>= options(digits = 17)# to print to full "standard R" precision .N <- function(.) mpfr(., precBits = 200) exp( 1 ) exp(.N(1)) <>= choose ( 200, 99:100 ) chooseMpfr( 200, 99:100 ) @ %% Applications by the package author include testing of Bessel or polylog functions and distribution computations, e.g. for stable distributions. %% In addition, the \pkg{Rmpfr} has been used on the \code{R-help} or \code{R-devel} mailing list for high-accuracy computations, e.g., in comparison with results from commercial software such as Maple, and in private communications with Petr Savicky about fixing \proglang{R} bug \href{https://bugs.R-project.org/bugzilla3/show_bug.cgi?id=14491}{\code{PR\#14491}}. We expect the package to be used in more situations for easy comparison studies about the accuracy of algorithms implemented in \proglang{R}, both for ``standard \proglang{R}'' and extension packages. %% references: \nocite{% MM-Rmpfr_pkg} %\bibliographystyle{chicago}%% how on earth do I get the URLs ??/ \bibliographystyle{jss}%% how on earth do I get the URLs ??/ \bibliography{Rmpfr} %% references can alternatively be entered by hand %\subsubsection*{References} %\begin{hangparas}{.25in}{1} %AuthorA (2007). Title of a web resource, \url{http://url/of/resource/}. %AuthorC (2008a). Article example in proceedings. In \textit{useR! 2008, The R %User Conference, (Dortmund, Germany)}, pp. 31--37. %AuthorC (2008b). Title of an article. \textit{Journal name 6}, 13--17. %\end{hangparas} \end{document} Rmpfr/vignettes/Rmpfr-pkg.Rnw0000644000176200001440000006526114361031754015723 0ustar liggesusers%\documentclass[article]{jss} \documentclass[nojss,article]{jss} % ----- for the package-vignette, don't use JSS logo, etc % %__FIXME: use ..\index{} for a good "reference index" about the things we show! % \author{Martin M\"achler \\ ETH Zurich} \title{Arbitrarily Accurate Computation with \R: \\ The \pkg{Rmpfr} Package} % \def\mythanks{a version of this paper, for \pkg{nacopula} 0.4\_4, has been published % in JSS, \url{http://www.jstatsoft.org/v39/i09}.} %% for pretty printing and a nice hypersummary also set: \Plainauthor{Martin M\"achler} %% comma-separated \Plaintitle{Arbitrarily Accurate Computation with R---The Rmpfr Package} % \Shorttitle{} % % The index entry makes it into build/vignette.rds : %\VignetteIndexEntry{Arbitrarily Accurate Computation with R Package Rmpfr} %\VignetteDepends{Rmpfr} %\VignetteDepends{gmp} %\VignetteDepends{Bessel} \SweaveOpts{engine=R,eps=FALSE,pdf=TRUE,width=7,height=4,strip.white=true,keep.source=TRUE} %% an abstract and keywords \Abstract{ The \R\ package \pkg{Rmpfr} allows to use arbitrarily precise numbers instead of \R's double precision numbers in many \R\ computations and functions. %% This is achieved by defining S4 classes of such numbers and vectors, matrices, and arrays thereof, where all arithmetic and mathematical functions work via the (GNU) MPFR C library, where MPFR is acronym for ``\emph{\textbf{M}ultiple \textbf{P}recision \textbf{F}loating-Point \textbf{R}eliably}''. MPFR is Free Software, available under the LGPL license, and itself is built on the free GNU Multiple Precision arithmetic library (GMP). Consequently, by using \pkg{Rmpfr}, you can often call your \R\ function or numerical code with mpfr--numbers instead of simple numbers, and all results will automatically be much more accurate. %% see subsection{Applications} further below: Applications by the package author include testing of Bessel or polylog functions and distribution computations, e.g. for ($\alpha$-)stable distributions and Archimedean Copulas. %% In addition, the \pkg{Rmpfr} has been used on the \code{R-help} or \code{R-devel} mailing list for high-accuracy computations, e.g., in comparison with results from other software, and also in improving existing \R\ functionality, e.g., fixing \R\ bug \href{https://bugs.R-project.org/bugzilla3/show_bug.cgi?id=14491}{\code{PR\#14491}}. } \Keywords{MPFR, Abitrary Precision, Multiple Precision Floating-Point, R} %% at least one keyword must be supplied %% publication information %% NOTE: Typically, this can be left commented and will be filled out by the technical editor %% \Volume{13} %% \Issue{9} %% \Month{September} %% \Year{2004} %% \Submitdate{2004-09-29} %% \Acceptdate{2004-09-29} %% The address of (at least) one author should be given %% in the following format: \Address{ Martin M\"achler\\ Seminar f\"ur Statistik, HG G~16\\ ETH Zurich\\ 8092 Zurich, Switzerland\\ E-mail: \email{maechler@stat.math.ethz.ch}\\ URL: \url{http://stat.ethz.ch/people/maechler} } %% It is also possible to add a telephone and fax number %% before the e-mail in the following format: %% Telephone: +43/1/31336-5053 %% Fax: +43/1/31336-734 %% for those who use Sweave please include the following line (with % symbols): %% MM: this is "substituted" by jss.cls: %% need no \usepackage{Sweave.sty} %% Marius' packages \usepackage[american]{babel}%for American English % \usepackage{microtype}%for character protrusion and font expansion (only with pdflatex) \usepackage{amsmath}%sophisticated mathematical formulas with amstex (includes \text{}) \usepackage{mathtools}%fix amsmath deficiencies \usepackage{amssymb}%sophisticated mathematical symbols with amstex (includes \mathbb{}) % \usepackage{amsthm}%theorem environments % \usepackage{bm}%for bold math symbols: \bm (= bold math) % %NON-STANDARD:\RequirePackage{bbm}%only for indicator functions % \usepackage{enumitem}%for automatic numbering of new enumerate environments % \usepackage[ % format=hang, % % NOT for JSS: labelsep=space, % justification=justified, % singlelinecheck=false%, % % NOT for JSS: labelfont=bf % ]{caption}%for captions % \usepackage{tikz}%sophisticated graphics package % \usepackage{tabularx}%for special table environment (tabularx-table) % \usepackage{booktabs}%for table layout % This is already in jss above -- but withOUT the fontsize=\small part !! \DefineVerbatimEnvironment{Sinput}{Verbatim}{fontsize=\small,fontshape=sl} \DefineVerbatimEnvironment{Soutput}{Verbatim}{fontsize=\small} \DefineVerbatimEnvironment{Scode}{Verbatim}{fontsize=\small,fontshape=sl} % but when submitting, do get rid of too much vertical space between R % input & output, i.e. between Sinput and Soutput: \fvset{listparameters={\setlength{\topsep}{0pt}}}% !! quite an effect! %% % \newcommand*{\R}{\proglang{R}}%{\textsf{R}} \newcommand*{\Arg}[1]{\texttt{\itshape $\langle$#1$\rangle$}} \newcommand*{\eps}{\varepsilon} \newcommand*{\CRANpkg}[1]{\href{http://CRAN.R-project.org/package=#1}{\pkg{#1}}} %% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{document} %% include your article here, just as usual %% Note that you should use the \pkg{}, \proglang{} and \code{} commands. % \section[About Java]{About \proglang{Java}} %% Note: If there is markup in \(sub)section, then it has to be escape as above. %% Note: These are explained in '?RweaveLatex' : <>= options(SweaveHooks= list(fig=function() par(mar=c(5.1, 4.1, 1.1, 2.1))), width = 75, digits = 7, # <-- here, keep R's default! prompt = "R> ", continue=" ") Sys.setenv(LANGUAGE = "en") if(.Platform$OS.type != "windows") Sys.setlocale("LC_MESSAGES","C") <>= if(nzchar(Sys.getenv("R_MM_PKG_CHECKING"))) print( .libPaths() ) stopifnot(require("sfsmisc")) @ \section[Introduction]{Introduction}% \small~\footnote{\mythanks}} %% - Why did I want this in R : There are situations, notably in researching better numerical algorithms for non-trivial mathematical functions, say the $F$-distribution function, where it is interesting and very useful to be able to rerun computations in \R\ in (potentially much) higher precision. For example, if you are interested in Euler's $e$, the base of natural logarithms, and given, e.g., by $e^x = \exp(x)$, you will look into <>= exp(1) @ which typically uses 7 digits for printing, as \code{getOption("digits")} is 7. To see \R's internal accuracy fully, you can use <>= print(exp(1), digits = 17) @ With \pkg{Rmpfr} you can now simply use ``mpfr -- numbers'' and get more accurate results automatically, here using a \emph{vector} of numbers as is customary in \R: <>= require("Rmpfr") # after having installed the package ... (one <- mpfr(1, 120)) exp(one) @ In combinatorics, number theory or when computing series, you may occasionally want to work with \emph{exact} factorials or binomial coefficients, where e.g. you may need all factorials $k!$, for $k=1,2,\dots,24$ or a full row of Pascal's triangle, i.e., want all $\binom{n}{k}$ for $n=80$. With \R's double precision, and standard printing precision <>= ns <- 1:24 ; factorial(ns) @ the full precision of $24!$ is clearly not printed. However, if you display it with more than its full internal precision, <>= noquote(sprintf("%-30.0f", factorial(24))) @ it is obviously wrong in the last couple of digits as they are known to be \code{0}. However, you can easily get full precision results with \pkg{Rmpfr}, by replacing ``simple'' numbers by mpfr-numbers: <>= ns <- mpfr(1:24, 120) ; factorial(ns) @ Or for the 80-th Pascal triangle row, $\binom{n}{k}$ for $n=80$ and $k=1,\dots,n$, <>= chooseMpfr.all(n = 80) <>= capture.and.write(# <- in package 'sfsmisc': ~/R/Pkgs/sfsmisc/R/misc-goodies.R <> , 5, 2, middle = 4, i.middle = 13) @ %%% "FIXME:" drawback of the above is that it is *integer* arithmetic only ... \paragraph{S4 classes and methods:} % Why they are useful here: S4 allows ``multiple dispatch'' which means that the method that is called for a generic function may not just depend on the first argument of the function (as in S3 or in traditional class-based OOP), but on a \emph{``signature''} of multiple arguments. For example, \texttt{a + b} is the same as \code{`+`(a,b)}, i.e., calling a function with two arguments. ... \subsection{The engine behind: MPFR and GMP} The package \pkg{Rmpfr} interfaces \R\ to the C (GNU) library \begin{quote} MPFR, acronym for ``\emph{\textbf{M}ultiple \textbf{P}recision \textbf{F}loating-Point \textbf{R}eliably}'' \end{quote} MPFR is Free Software, available under the LGPL license, %\nocite{ see \url{http://mpfr.org/} and \cite{FouLHLPZ:2007} and the standard reference to MPFR, \cite{FousseHLPZ-MPFR:2011}. %% MPFR itself is built on and requires the GNU Multiple Precision arithmetic library (GMP), see \url{http://gmplib.org/} and \cite{GMP:2011}. It can be obtained from there, or from your operating system vendor. On some platforms, it is very simple, to install MPFR and GMP, something necessary before \pkg{Rmpfr} can be used. E.g., in Linux distributions Debian, Ubuntu and other Debian derivatives, it is sufficient (for \emph{both} libraries) to simply issue \begin{verbatim} sudo apt-get install libmpfr-dev \end{verbatim} \section{Arithmetic with mpfr-numbers} <>= (0:7) / 7 # k/7, for k= 0..7 printed with R's default precision options(digits= 16) (0:7) / 7 # in full double precision accuracy options(digits= 7) # back to default str(.Machine[c("double.digits","double.eps", "double.neg.eps")], digits=10) 2^-(52:53) @ In other words, the double precision numbers \R\ uses have a 53-bit mantissa, and the two ``computer epsilons'' are $2^{-52}$ and $2^{-53}$, respectively. Less technically, how many decimal digits can double precision numbers work with, $2^{-53} = 10^{-x} \Longleftrightarrow x = 53 \log_{10}(2)$, <>= 53 * log10(2) @ i.e., almost 16 digits. If we want to compute some arithmetic expression with higher precision, this can now easily be achieved, using the \pkg{Rmpfr} package, by defining ``\texttt{mpfr}--numbers'' and then work with these. Starting with simple examples, a more precise version of $k/7$, $k = 0,\dots, 7$ from above: <>= x <- mpfr(0:7, 80)/7 # using 80 bits precision x 7*x 7*x - 0:7 @ which here is even ``perfect'' -- but that's ``luck'' only, and also the case here for ``simple'' double precision numbers, at least on our current platform.\footnote{64-bit Linux, Fedora 13 on a ``AMD Phenom 925'' processor} \subsection[Mathematical Constants, Pi, gamma, ..]{% Mathematical Constants, Pi ($\pi$), gamma, etc} Our \pkg{Rmpfr} package also provides the mathematical constants which MPFR provides, via \code{Const(., \Arg{prec})}, currently the \Sexpr{length(eval(formals(Const)[["name"]]))} constants <>= formals(Const)$name @ are available, where \code{"gamma"} is for Euler's gamma, $\gamma := \lim_{n\to\infty} \sum_{k=1}^n \frac 1 k - \log(n) \approx 0.5777$, and \code{"catalan"} for Catalan's constant (see \url{http://en.wikipedia.org/wiki/Catalan\%27s_constant}). <>= Const("pi") Const("log2") @ where you may note a default precision of 120 digits, a bit more than quadruple precision, but also that 1000 digits of $\pi$ are available instantaneously, <>= system.time(Pi <- Const("pi", 1000 *log2(10))) Pi @ As nice example of using Mpfr arithmetic: On a wintery Sunday, Hans Borchers desired to have an exact $\pi$ constant in \pkg{Rmpfr}, and realized that of course \code{mpfr(pi, 256)} could not be the solution, as \code{pi} is the double precision version of $\pi$ and hence only about 53 bit accurate (and the \code{mpfr()} cannot do magic, recognizing ``symbolic'' $\pi$). As he overlooked the \code{Const("pi", .)} solution above, he implemented the following function that computes pi applying Gauss' spectacular AGM-based (AGM := Arithmetic-Geometric Mean) approach [Borwein and Borwein (1987), \emph{Pi and the AGM}]; I have added a \code{verbose} argument, explicit iteration counting and slightly adapted the style to my own: <>= piMpfr <- function(prec=256, itermax = 100, verbose=TRUE) { m2 <- mpfr(2, prec) # '2' as mpfr number ## -> all derived numbers are mpfr (with precision 'prec') p <- m2 + sqrt(m2) # 2 + sqrt(2) = 3.414.. y <- sqrt(sqrt(m2)) # 2^ {1/4} x <- (y+1/y) / m2 it <- 0L repeat { p.old <- p it <- it+1L p <- p * (1+x) / (1+y) if(verbose) cat(sprintf("it=%2d, pi^ = %s, |.-.|/|.|=%e\n", it, formatMpfr(p, min(50, prec/log2(10))), 1-p.old/p)) if (abs(p-p.old) <= m2^(-prec)) break if(it > itermax) { warning("not converged in", it, "iterations") ; break } ## else s <- sqrt(x) y <- (y*s + 1/s) / (1+y) x <- (s+1/s)/2 } p } piMpfr()# indeed converges *quadratically* fast ## with relative error relErr <- 1 - piMpfr(256, verbose=FALSE) / Const("pi",260) ## in bits : asNumeric(-log2(abs(relErr))) @ \subsection[{seqMpfr()} for sequences:]{\code{seqMpfr()} for sequences:} In \R, arithmetic sequences are constructed by \code{seq()}, the ``sequence'' function, which is not generic, and with its many ways and possible arguments is convenient, but straightforward to automatically generalize for mpfr numbers. Instead, we provide the \code{seqMpfr} function... \subsection[Rounding, {roundMpfr()}, {asNumeric()} etc:]{% Rounding, \code{roundMpfr()}, \code{asNumeric()} etc:} In \R, the \code{round()} and \code{signif()} functions belong to the \code{Math2} group, and we provide \code{"mpfr"}-class methods for them: <>= getGroupMembers("Math2") showMethods("Math2", classes=c("mpfr", "mpfrArray")) @ For consistency reasons, however the resulting numbers keep the same number of precision bits, \code{precBits}: <>= i7 <- 1/mpfr(700, 100) c(i7, round(i7, digits = 6), signif(i7, digits = 6)) @ If you really want to ``truncate'' the precision to less digits or bits, you call \code{roundMpfr()}, <>= roundMpfr(i7, precBits = 30) roundMpfr(i7, precBits = 15) @ Note that 15 bits correspond to approximately $15 \cdot 0.3$, i.e., 4.5 digits, because $1/\log_2(10) \approx 0.30103\dots$. \paragraph{asNumeric():} Often used, e.g., to return to fast (\R-internal) arithmetic, also as alternative to \code{roundMpfr()} is to ``round to double precision'' producing standard \R numbers from ``mpfr'' numbers. We provide the function \code{asNumeric()}, a generic function with methods also for \code{"mpfrArray"} see below and the big integers and big rationals from package \pkg{gmp}, <>= showMethods(asNumeric) @ see, e.g., its use above. \paragraph{Formatting:} For explicit printing or plotting purposes, we provide an \code{"mpfr"} method for \R's \code{format()} function, also as explicit utility function \code{formatMpfr(x, digits)} which provides results to \code{digits} \emph{significant} digits, <>= cbind( sapply(1:7, function(d) format(i7, digits=d)) ) @ There, \code{digits = NULL} is the default where the help has (``always'') promised \emph{The default, \code{NULL}, uses enough digits to represent the full precision, often one or two digits more than you would expect}. However, for large numbers, say $10^{20000}$, e.g., \Sexpr{x <- mpfr(10,80)^20000}, all of \code{formatMpfr(x)}, \code{format(x)}, and \code{print(x)} (including ``auto-printing'' of \code{x}), have shown all digits \emph{before} the decimal point and not at all taken into account the 80-bit precision of \code{x} (which corresponds to only \code{80 / log2(10)} $\approx 24$ decimal digits). This has finally changed in the (typically default) case \code{formatMpfr(*, maybe.full = FALSE)}: <>= x <- mpfr(2, 80) ^ ((1:4)*10000) cbind(x) # -> show() -> print.mpfr() -> formatMpfr(.. , digits = NULL, maybe.full = FALSE) nchar(formatMpfr(x)) nchar(formatMpfr(x, maybe.full = TRUE)) @ \section{``All'' mathematical functions, arbitrarily precise} %% see ../../man/mfpr-class.Rd %% but also .... %% {Math}{\code{signature(x = "mpfr")}: All the S4 ``\texttt{Math}'' group functions are defined, using multiple precision (MPFR) arithmetic, i.e., <>= getGroupMembers("Math") @ % \code{{abs}}, \code{{sign}}, \code{{sqrt}}, % \code{{ceiling}}, \code{{floor}}, \code{{trunc}}, % \code{{cummax}}, \code{{cummin}}, \code{{cumprod}}, % \code{{cumsum}}, \code{{exp}}, \code{{expm1}}, % \code{{log}}, \code{{log10}}, \code{{log2}}, % \code{{log1p}}, \code{{cos}}, \code{{cosh}}, % \code{{sin}}, \code{{sinh}}, \code{{tan}}, % \code{{tanh}}, \code{{acos}}, \code{{acosh}}, % \code{{asin}}, \code{{asinh}}, \code{{atan}}, % \code{{atanh}}, \code{{gamma}}, \code{{lgamma}}, % \code{{digamma}}, and \code{{trigamma}}. where currently, \code{trigamma} is not provided by the MPFR library, and hence not implemented yet. %% cumsum(), cumprod() now work! \code{factorial()} has a \texttt{"mpfr"} method; and in addition, \code{factorialMpfr()} computes ${n!}$ efficiently in arbitrary precision, using the MPFR-internal implementation. This is mathematically (but not numerically) the same as $\Gamma(n+1) = $\code{gamma(n+1)}. Similarly to \code{factorialMpfr()}, but more generally useful,the functions \code{chooseMpfr(a,n)} and \code{pochMpfr(a,n)} compute (generalized!) binomial coefficients $\binom{a}{n}$ and ``the'' Pochhammer symbol or ``rising factorial'' \begin{eqnarray*} a^{(n)} &:=& a(a+1)(a+2)\cdots(a+n-1) \\ &=& \frac{(a+n-1)!}{(a-1)!} = \frac{\Gamma(a+n)}{\Gamma(a)}. \end{eqnarray*} Note that with this definition, \[ \binom{a}{n} \equiv \frac{a^{(n)}}{n!}. \] \section{Arbitrarily precise matrices and arrays} %%% FIXME --> ~/R/Meetings-Kurse-etc/2011-Warwick/1_MM_/Poster/MM-poster.tex The classes \code{"mpfrMatrix"} and \code{"mpfrArray"} correspond to the classical numerical \R\ \code{"matrix"} and \code{"array"} objects, which basically are arrays or vectors of numbers with a dimension \code{dim}, possibly named by \code{dimnames}. As there, they can be constructed by \code{dim(.) <- ..} setting, e.g., <>= head(x <- mpfr(0:7, 64)/7) ; mx <- x dim(mx) <- c(4,2) @ or by the \code{mpfrArray()} constructor, <>= dim(aa <- mpfrArray(1:24, precBits = 80, dim = 2:4)) <>= aa <>= capture.and.write(aa, 11, 4) @ and we can index and multiply such matrices, e.g., <>= mx[ 1:3, ] + c(1,10,100) crossprod(mx) @ and also \code{apply} functions, <>= apply(7 * mx, 2, sum) @ \section{Special mathematical functions} \code{zeta(x)} computes Riemann's Zeta function $\zeta(x)$ important in analytical number theory and related fields. The traditional definition is \begin{equation*} \zeta(x) = \sum_{n=1}^\infty \frac{1}{n^x}. \end{equation*} \code{Ei(x)} computes the \textbf{e}xponential integral, \begin{equation*} \int_{-\infty}^{x} \frac{e^t}{t} \; dt. \end{equation*} <>= curve(Ei, 0, 5, n=2001); abline(h=0,v=0, lty=3) @ \code{Li2(x)}, part of the MPFR C library since version 2.4.0, computes the dilogarithm, \begin{equation*} \mathtt{Li2(x)} = \operatorname{Li}_2(x) := \int_{0}^{x} \frac{-log(1-t)}{t} \; dt, \end{equation*} which is the most prominent ``polylogarithm'' function, where the general polylogarithm is (initially) defined as \begin{equation*} \operatorname{Li}_s(z) = \sum_{k=1}^\infty \frac{z^k}{k^s}, \ \forall s \in \mathbb{C} \ \ \forall |z| < 1, z\in\mathbb{C}, \end{equation*} see \url{http://en.wikipedia.org/wiki/Polylogarithm#Dilogarithm}. Note that the integral definition is valid for all $x\in \mathbb{C}$, and also, $Li_2(1) = \zeta(2) = \pi^2/6$. <>= if(mpfrVersion() >= "2.4.0") ## Li2() is not available in older MPFR versions all.equal(Li2(1), Const("pi", 128)^2/6, tol = 1e-30) @ where we also see that \pkg{Rmpfr} provides \texttt{all.equal()} methods for mpfr-numbers which naturally allow very small tolerances \code{tol}. <>= if(mpfrVersion() >= "2.4.0") curve(Li2, -2, 13, n=2000); abline(h=0,v=0, lty=3) @ \code{erf(x)} is the ``error\footnote{named exactly because of its relation to the normal / Gaussian distribution} function'' and \code{erfc(x)} its \textbf{c}omplement, \code{erfc(x) := 1 - erf(x)}, defined as \begin{equation*} \operatorname{erf}(x) = \frac{2}{\sqrt{\pi}}\int_{0}^x e^{-t^2} dt, \end{equation*} and consequently, both functions simply are reparametrizations of the cumulative normal, $\Phi(x) = \int_{-\infty}^x \phi(t)\;dt = $\code{pnorm(x)} where $\phi$ is the normal density function $\phi(t) := \frac{1}{\sqrt{2\pi}}e^{-t^2}$=\code{dnorm(x)}. Namely, \code{erf(x) = 2*pnorm(sqrt(2)*x)} and \code{erfc(x) = 1 - erf(x) = 2* pnorm(sqrt(2)*x, lower=FALSE)}. <>= curve(erf, -3,3, col = "red", ylim = c(-1,2)) curve(erfc, add = TRUE, col = "blue") abline(h=0, v=0, lty=3); abline(v=c(-1,1), lty=3, lwd=.8, col="gray") legend(-3,1, c("erf(x)", "erfc(x)"), col = c("red","blue"), lty=1) @ \subsection{Applications} The CRAN package \CRANpkg{Bessel} provides asymptotic formulas for Bessel functions also of \emph{fractional} order which do work for \code{mpfr}-vector arguments as well. \section{Integration highly precisely} Sometimes, important functions are defined as integrals of other known functions, e.g., the dilogarithm $\operatorname{Li}_2()$ above. Consequently, we found it desirable to allow numerical integration, using mpfr-numbers, and hence---conceptionally---arbitrarily precisely. \R's \code{integrate()} uses a relatively smart adaptive integration scheme, but based on C code which is not very simply translatable to pure \R, to be used with mpfr numbers. For this reason, our \code{integrateR()} function uses classical Romberg integration \citep{Bauer-1961}. We demonstrate its use, first by looking at a situation where \R's \code{integrate()} can get problems: <>= integrateR(dnorm,0,2000) integrateR(dnorm,0,2000, rel.tol=1e-15) integrateR(dnorm,0,2000, rel.tol=1e-15, verbose=TRUE) @ Now, for situations where numerical integration would not be necessary, as the solution is known analytically, but hence are useful for exploration of high accuracy numerical integration: First, the exponential function $\exp(x) = e^x$ with its well-known $\int \exp(t)\;dt = \exp(x)$, both with standard (double precision) floats, <>= (Ie.d <- integrateR(exp, 0 , 1, rel.tol=1e-15, verbose=TRUE)) @ and then the same, using 200-bit accurate mpfr-numbers: <>= (Ie.m <- integrateR(exp, mpfr(0,200), 1, rel.tol=1e-25, verbose=TRUE)) (I.true <- exp(mpfr(1, 200)) - 1) ## with absolute errors as.numeric(c(I.true - Ie.d$value, I.true - Ie.m$value)) @ Now, for polynomials, where Romberg integration of the appropriate order is exact, mathematically, <>= if(require("polynom")) { x <- polynomial(0:1) p <- (x-2)^4 - 3*(x-3)^2 Fp <- as.function(p) print(pI <- integral(p)) # formally print(Itrue <- predict(pI, 5) - predict(pI, 0)) ## == 20 } else { Fp <- function(x) (x-2)^4 - 3*(x-3)^2 Itrue <- 20 } (Id <- integrateR(Fp, 0, 5)) (Im <- integrateR(Fp, 0, mpfr(5, 256), rel.tol = 1e-70, verbose=TRUE)) ## and the numerical errors, are indeed of the expected size: 256 * log10(2) # - expect ~ 77 digit accuracy for mpfr(*., 256) as.numeric(Itrue - c(Im$value, Id$value)) @ \section{Miscellaneous} For probability and density computations, it is known to be important in many contexts to work on the $\log$--scale, i.e., with log probabilities $\log P(.)$ or log densities $\log f()$. In \R{} itself, we (R Core) had introduced logical optional arguments \code{log} (for density) and \code{log.p} for probability (e.g., \code{pnorm()} and quantile (e.g., \code{qnorm}) functions. As our \code{pnorm()} is based on MPFR's \code{erf()} and \code{erfc()} which currently do \emph{not} have scaled versions, for \code{Rmpfr::pnorm(.., log.p=TRUE)} we do need to compute the logarithm (instead of working on the log scale). On the extreme left tail, \R{} correctly computes <>= pnorm(-1234, log.p=TRUE) @ i.e., \code{-761386.036955} to more digits. However, \code{erf()} and \code{erfc()} do not have a log scale or other scaled versions. Thanks to the large range of exponents compared to double precision numbers it does less quickly underflow to zero, e.g., <>= (p123 <- Rmpfr::pnorm(mpfr(-123, 66), log.p=TRUE)) # is based on (ec123 <- erfc(123 * sqrt(mpfr(0.5, 66+4))) / 2) # 1.95....e-3288 (p333 <- Rmpfr::pnorm(mpfr(-333, 66), log.p=TRUE)) exp(p333) stopifnot(p123 == log(roundMpfr(ec123, 66)), ## '==' as we implemented our pnorm() all.equal(p333, -55451.22709, tol=1e-8)) @ and indeed, the default range for exponent (wrt base 2, not 10) is given by <>= (old_erng <- .mpfr_erange() ) @ which shows the current minimal and maximal base-2 exponents for mpfr-numbers, by ``factory-fresh'' default, the number $-2^{30}$ and $2^{30}$, i.e., $\pm 1073741823$ which is much larger than the corresponding limits for regular double precision numbers, <>= unlist( .Machine[c("double.min.exp", "double.max.exp")] ) @ which are basically $\pm 2^{10}$; note that double arithmetic typically allows subnormal numbers which are even smaller than $2^{-1024}$, also in \R{}, on all usual platforms, <>= 2^(-1022 - 52) @ is equal to $2^{-1074}$ and the really smallest positive double precision number. Now, \emph{if} if the GMP library to which both \R{} package \pkg{gmp} and \pkg{Rmpfr} interface is built ``properly'', i.e., with full 64 bit ``numb''s, we can \emph{extend} the range of mpfr-numbers even further. By how much, we can read off <>= .mpfr_erange(.mpfr_erange_kinds) ## and then set # use very slightly smaller than extreme values: (myERng <- (1-2^-52) * .mpfr_erange(c("min.emin","max.emax"))) .mpfr_erange_set(value = myERng) # and to see what happened: .mpfr_erange() @ If that worked well, this shows \code{-/+ 4.611686e+18}, or actually $\mp 2^{62}$, \code{log2(abs(.mpfr_erange()))} giving \Sexpr{log2(abs(.mpfr_erange()))}. However, currently on Winbuilder this does not extend, notably as the GMP numbs, <>= .mpfr_gmp_numbbits() @ have \emph{not} been 64, there. \section{Conclusion} The \R\ package \pkg{Rmpfr}, available from CRAN since August 2009, provides the possibility to run many computations in R with (arbitrarily) high accuracy, though typically with substantial speed penalty. This is particularly important and useful for checking and exploring the numerical stability and appropriateness of mathematical formulae that are translated to a computer language like \R, often without very careful consideration of the limits of computer arithmetic. \bibliography{Rmpfr,log1mexp} FIXME: \textbf{Index} of all functions mentioned \dots \end{document} Rmpfr/src/0000755000176200001440000000000015075721240012132 5ustar liggesusersRmpfr/src/utils.c0000644000176200001440000005421615075433454013455 0ustar liggesusers/* * MPFR - Multiple Precision Floating-Point Reliable Library * ---- - - - - */ #include /* imax2() */ # include //-> void R_CheckUserInterrupt(void); #include "Rmpfr_utils.h" extern #include "Syms.h" //Dbg: #define DEBUG_Rmpfr #ifdef DEBUG_Rmpfr /* ONLY for debugging !! */ # ifndef WIN32 # include # endif # define R_PRT(_X_) mpfr_out_str (R_Outputfile, 10, 0, _X_, MPFR_RNDD) #endif // Currently not in the API (hence "should be" (?) 'static') : int my_mpfr_beta (mpfr_t ROP, mpfr_t X, mpfr_t Y, mpfr_rnd_t RND); int my_mpfr_lbeta(mpfr_t ROP, mpfr_t X, mpfr_t Y, mpfr_rnd_t RND); int my_mpfr_choose(mpfr_t ROP, long n, mpfr_t X, mpfr_rnd_t RND); int my_mpfr_poch (mpfr_t ROP, long n, mpfr_t X, mpfr_rnd_t RND); int my_mpfr_round (mpfr_t ROP, long prec, mpfr_t X, mpfr_rnd_t RND); /* argument order above must match the one of mpfr_jn() etc .. */ /* MM: for debugging, use gcc -I/u/maechler/R/D/r-patched/F19-64-inst/include -I/usr/local/include -fpic -g -O3 -pedantic -Wall --std=gnu99 -DDEBUG_Rmpfr -Wcast-align -Wclobbered -c utils.c -o utils.o */ /*------------------------------------------------------------------------*/ int my_mpfr_beta (mpfr_t R, mpfr_t a, mpfr_t b, mpfr_rnd_t RND) { mpfr_prec_t p_ab = max2_prec(mpfr_get_prec(a), mpfr_get_prec(b)); if(mpfr_get_prec(R) < p_ab) mpfr_prec_round(R, p_ab, RND);// so prec(R) = max( prec(a), prec(b) ) int ans; mpfr_t s; mpfr_init2(s, p_ab); #ifdef DEBUG_Rmpfr R_CheckUserInterrupt(); int cc = 0; #endif /* "FIXME": check each 'ans' below, and return when not ok ... */ ans = mpfr_add(s, a, b, RND); if(mpfr_integer_p(s) && mpfr_sgn(s) <= 0) { // (a + b) is integer <= 0 if(!mpfr_integer_p(a) && !mpfr_integer_p(b)) { // but a,b not integer ==> R = finite / +-Inf = 0 : mpfr_set_zero (R, +1); mpfr_clear (s); return ans; }// else: sum is integer; at least one {a,b} integer ==> both integer int sX = mpfr_sgn(a), sY = mpfr_sgn(b); if(sX * sY < 0) { // one negative, one positive integer // ==> special treatment here : if(sY < 0) // ==> sX > 0; swap the two mpfr_swap(a, b); // now have --- a < 0 < b <= |a| integer ------------------ /* ================ and in this case: B(a,b) = (-1)^b B(1-a-b, b) = (-1)^b B(1-s, b) = (1*2*..*b) / (-s-1)*(-s-2)*...*(-s-b) */ /* where in the 2nd form, both numerator and denominator have exactly * b integer factors. This is attractive {numerically & speed wise} * for 'small' b */ #define b_large 100 #ifdef DEBUG_Rmpfr Rprintf(" my_mpfr_beta(): s = a+b= "); R_PRT(s); Rprintf("\n a = "); R_PRT(a); Rprintf("\n b = "); R_PRT(b); Rprintf("\n"); if(cc++ > 999) { mpfr_set_zero (R, +1); mpfr_clear (s); return ans; } #endif unsigned long b_ = 0;// -Wall Rboolean b_fits_ulong = mpfr_fits_ulong_p(b, RND), small_b = b_fits_ulong && (b_ = mpfr_get_ui(b, RND)) < b_large; if(small_b) { #ifdef DEBUG_Rmpfr Rprintf(" b <= b_large = %d...\n", b_large); #endif //----------------- small b ------------------ // use GMP big integer arithmetic: mpz_t S; mpz_init(S); mpfr_get_z(S, s, RND); // S := s mpz_sub_ui (S, S, (unsigned long) 1); // S = s - 1 = (a+b-1) /* binomial coefficient choose(N, k) requires k a 'long int'; * here, b must fit into a long: */ mpz_bin_ui (S, S, b_); // S = choose(S, b) = choose(a+b-1, b) mpz_mul_ui (S, S, b_); // S = S*b = b * choose(a+b-1, b) // back to mpfr: R = 1 / S = 1 / (b * choose(a+b-1, b)) mpfr_set_ui(s, (unsigned long) 1, RND); mpfr_div_z(R, s, S, RND); mpz_clear(S); } else { // b is "large", use direct B(.,.) formula #ifdef DEBUG_Rmpfr Rprintf(" b > b_large = %d...\n", b_large); #endif // a := (-1)^b : // there is no mpfr_si_pow(a, -1, b, RND); int neg; // := 1 ("TRUE") if (-1)^b = -1, i.e. iff b is odd if(b_fits_ulong) { // (i.e. not very large) neg = (b_ % 2); // 1 iff b_ is odd, 0 otherwise } else { // really large b; as we know it is integer, can still.. // b2 := b / 2 mpfr_t b2; mpfr_init2(b2, p_ab); mpfr_div_2ui(b2, b, 1, RND); neg = !mpfr_integer_p(b2); // b is odd, if b/2 is *not* integer #ifdef DEBUG_Rmpfr Rprintf(" really large b; neg = ('b is odd') = %d\n", neg); #endif } // s' := 1-s = 1-a-b mpfr_ui_sub(s, 1, s, RND); #ifdef DEBUG_Rmpfr Rprintf(" neg = %d\n", neg); Rprintf(" s' = 1-a-b = "); R_PRT(s); Rprintf("\n -> calling B(s',b)\n"); #endif // R := B(1-a-b, b) = B(s', b) if(small_b) { my_mpfr_beta (R, s, b, RND); } else { my_mpfr_lbeta (R, s, b, RND); mpfr_exp(R, R, RND); // correct *if* beta() >= 0 } #ifdef DEBUG_Rmpfr Rprintf(" R' = beta(s',b) = "); R_PRT(R); Rprintf("\n"); #endif // Result = (-1)^b B(1-a-b, b) = +/- s' if(neg) mpfr_neg(R, R, RND); } mpfr_clear(s); return ans; } } ans = mpfr_gamma(s, s, RND); /* s = gamma(a + b) */ #ifdef DEBUG_Rmpfr Rprintf("my_mpfr_beta(): s = gamma(a+b)= "); R_PRT(s); Rprintf("\n a = "); R_PRT(a); Rprintf("\n b = "); R_PRT(b); #endif ans = mpfr_gamma(a, a, RND); ans = mpfr_gamma(b, b, RND); ans = mpfr_mul(b, b, a, RND); /* b' = gamma(a) * gamma(b) */ #ifdef DEBUG_Rmpfr Rprintf("\n G(a) * G(b) = "); R_PRT(b); Rprintf("\n"); #endif ans = mpfr_div(R, b, s, RND); mpfr_clear (s); /* mpfr_free_cache() must be called in the caller !*/ return ans; } int my_mpfr_lbeta(mpfr_t R, mpfr_t a, mpfr_t b, mpfr_rnd_t RND) { mpfr_prec_t p_ab = max2_prec(mpfr_get_prec(a), mpfr_get_prec(b)); if(mpfr_get_prec(R) < p_ab) mpfr_prec_round(R, p_ab, RND);// so prec(R) = max( prec(a), prec(b) ) mpfr_t s; mpfr_init2(s, p_ab); /* "FIXME": check each 'ans' below, and return when not ok ... */ int ans = mpfr_add(s, a, b, RND); if(mpfr_integer_p(s) && mpfr_sgn(s) <= 0) { // (a + b) is integer <= 0 if(!mpfr_integer_p(a) && !mpfr_integer_p(b)) { // but a,b not integer ==> R = ln(finite / +-Inf) = ln(0) = -Inf : mpfr_set_inf (R, -1); mpfr_clear (s); return ans; }// else: sum is integer; at least one integer ==> both integer int sX = mpfr_sgn(a), sY = mpfr_sgn(b); if(sX * sY < 0) { // one negative, one positive integer // ==> special treatment here : if(sY < 0) // ==> sX > 0; swap the two mpfr_swap(a, b); /* now have --- a < 0 < b <= |a| integer ------------------ * ================ * --> see my_mpfr_beta() above */ unsigned long b_ = 0;// -Wall Rboolean b_fits_ulong = mpfr_fits_ulong_p(b, RND), small_b = b_fits_ulong && (b_ = mpfr_get_ui(b, RND)) < b_large; if(small_b) { //----------------- small b ------------------ // use GMP big integer arithmetic: mpz_t S; mpz_init(S); mpfr_get_z(S, s, RND); // S := s mpz_sub_ui (S, S, (unsigned long) 1); // S = s - 1 = (a+b-1) /* binomial coefficient choose(N, k) requires k a 'long int'; * here, b must fit into a long: */ mpz_bin_ui (S, S, b_); // S = choose(S, b) = choose(a+b-1, b) mpz_mul_ui (S, S, b_); // S = S*b = b * choose(a+b-1, b) // back to mpfr: R = log(|1 / S|) = - log(|S|) mpz_abs(S, S); mpfr_set_z(s, S, RND); // s := |S| mpfr_log(R, s, RND); // R := log(s) = log(|S|) mpfr_neg(R, R, RND); // R = -R = -log(|S|) mpz_clear(S); } else { // b is "large", use direct B(.,.) formula // a := (-1)^b -- not needed here, neither 'neg': want log( |.| ) // s' := 1-s = 1-a-b mpfr_ui_sub(s, 1, s, RND); // R := log(|B(1-a-b, b)|) = log(|B(s', b)|) my_mpfr_lbeta (R, s, b, RND); } mpfr_clear(s); return ans; } } ans = mpfr_lngamma(s, s, RND); // s = lngamma(a + b) ans = mpfr_lngamma(a, a, RND); ans = mpfr_lngamma(b, b, RND); ans = mpfr_add (b, b, a, RND); // b' = lngamma(a) + lngamma(b) ans = mpfr_sub (R, b, s, RND); mpfr_clear (s); return ans; } /** Binomial Coefficient -- * all initialization and cleanup is called in the caller * @result R = choose(X, n) */ int my_mpfr_choose (mpfr_t R, long n, mpfr_t X, mpfr_rnd_t RND) { mpfr_prec_t p_X = mpfr_get_prec(X); mpfr_t r, x; mpfr_init2(x, p_X); mpfr_set(x, X, RND); mpfr_init2(r, p_X); if(mpfr_integer_p(X) && n > 0 && mpfr_cmp_si(X, n) >= 0 && mpfr_cmp_si(X, 2*n) < 0) { // integer X, 0 <= X-n < n ; /* ==> choose(X,n) == choose(X, X-n) ; X-n is smaller => faster: do n <--> X-n */ mpfr_sub_si(r, X, n, RND); /* r = X-n */ n = mpfr_get_si(r, RND); } if(n > 0) { mpfr_set(r, X, RND); for(long i=1; i < n; ) { if(!(i % 100000)) R_CheckUserInterrupt(); // for *large* n mpfr_sub_si(x, x, 1L, RND); // x = X - i mpfr_mul (r, r, x, RND); // r := r * x = X(X-1)..(X-i) mpfr_div_si(r, r, ++i, RND); // r := r / (i+1) = X(X-1)..(X-i) / (1*2..*(i+1)) #ifdef DEBUG_Rmpfr Rprintf("my_mpfr_choose(): X (= X_0 - %d)= ", i); R_PRT(x); Rprintf("\n --> r ="); R_PRT(r); Rprintf("\n"); #endif } } else if(n < 0) // ==> result 0 as for R's choose() mpfr_set_zero(r, +1); else // n = 0 mpfr_set_si(r, (long) 1, RND); int ans = mpfr_set(R, r, RND); mpfr_clear (x); mpfr_clear (r); return ans; } /** Pochhammer Symbol -- *rising* factorial x * (x+1) * ... (x+n-1) * all initialization and cleanup is called in the caller */ int my_mpfr_poch (mpfr_t R, long n, mpfr_t X, mpfr_rnd_t RND) { int ans; long i; mpfr_t r, x; mpfr_prec_t p_X = mpfr_get_prec(X); mpfr_init2(x, p_X); mpfr_set(x, X, RND); mpfr_init2(r, p_X); if(n > 0) { mpfr_set(r, X, RND); for(i=1; i < n; i++) { mpfr_add_si(x, x, 1L, RND); // x = X + i mpfr_mul(r, r, x, RND); // r := r * x = X(X+1)..(X+i) #ifdef DEBUG_Rmpfr Rprintf("my_mpfr_poch(): X (= X_0 + %d)= ", i); R_PRT(x); Rprintf("\n --> r ="); R_PRT(r); Rprintf("\n"); #endif } } else // n = 0 mpfr_set_si(r, (long) 1, RND); ans = mpfr_set(R, r, RND); mpfr_clear (x); mpfr_clear (r); return ans; } /** round to (binary) bits, not (decimal) digits */ int my_mpfr_round (mpfr_t R, long prec, mpfr_t X, mpfr_rnd_t RND) { int ans; if(prec < MPFR_PREC_MIN) error("prec = %ld < %ld is too small", prec, (long)MPFR_PREC_MIN); if(prec > MPFR_PREC_MAX) error("prec = %ld > %ld is too large", prec, (long)MPFR_PREC_MAX); mpfr_set(R, X, RND); ans = mpfr_prec_round(R, (mpfr_prec_t) prec, RND); return ans; } /*------------------------------------------------------------------------*/ SEXP R_mpfr_get_version(void) { return mkString(mpfr_get_version()); } SEXP R_mpfr_get_sizeof(void) { const char *nms[] = {"mpfr_prec_t", "mpfr_exp_t", "mp_limb_t", ""}; SEXP ans = Rf_mkNamed(INTSXP, nms); int *p = INTEGER(ans); p[0] = SIZEOF_MPFR_PREC_T; p[1] = SIZEOF_MPFR_EXP_T; p[2] = SIZEOF_MP_LIMB_T; return ans; } SEXP R_mpfr_get_GMP_numb_bits(void) {// for diagnosing return ScalarInteger(SIZEOF_MP_LIMB_T * CHAR_BIT); } /* Set or get the C-global debugging level -- * currently only used in R_mpfr_dbg_printf() --> ./Rmpfr_utils.h * * Called from R .mpfr_debug(i = NA) */ SEXP R_mpfr_set_debug(SEXP I) { if(LENGTH(I) < 1 || INTEGER(I)[0] == NA_INTEGER) return ScalarInteger(R_mpfr_debug_); /* else : */ int prev = R_mpfr_debug_; R_mpfr_debug_ = asInteger(I); return ScalarInteger(prev); } SEXP R_mpfr_get_default_prec(void) { return ScalarInteger((int) mpfr_get_default_prec()); } SEXP R_mpfr_set_default_prec(SEXP prec) { // return the previous value int prev = (int) mpfr_get_default_prec(); mpfr_set_default_prec((mpfr_prec_t) asInteger(prec)); return ScalarInteger(prev); } // is MPFR's exponent range 'erange' representable as R's (32 bit) integer [INT_MIN not allowed] : int mpfr_erange_int_p(void) { mpfr_exp_t r = mpfr_get_emin(); int i_ok = (INT_MIN < r && r <= INT_MAX); if(i_ok) { r = mpfr_get_emax(); i_ok = (INT_MIN < r && r <= INT_MAX); } return i_ok; } /** R's .mpfr_erange_is_int() - workhorse */ SEXP R_mpfr_erange_int_p(void) { return ScalarLogical(mpfr_erange_int_p()); } /* MUST be sync'ed with ../R/mpfr.R * ~~~~~~~~~~~ and its .mpfr_erange_kinds */ typedef enum { E_min = 1, E_max, min_emin, max_emin, min_emax, max_emax } erange_kind; // Called from R's .mpfr.erange(), now allows 'kind' to be a vector SEXP R_mpfr_get_erange(SEXP kind_) { int k = LENGTH(kind_), nprot = 0; erange_kind *kind; if(TYPEOF(kind_) != INTSXP) { SEXP kk = PROTECT(coerceVector(kind_, INTSXP)); nprot++; kind = (erange_kind *) INTEGER(kk); } else { kind = (erange_kind *) INTEGER(kind_); } mpfr_exp_t *r = (mpfr_exp_t *) R_alloc(k, sizeof(mpfr_exp_t)); Rboolean int_ok = TRUE; for(int j = 0; j < k; j++) { switch(kind[j]) { // keep the 'case' list in sync with 'erange_kind' enum above: case E_min: r[j] = mpfr_get_emin(); if(int_ok && (r[j] <= INT_MIN || r[j] > INT_MAX)) int_ok=FALSE; break; case E_max: r[j] = mpfr_get_emax(); if(int_ok && (r[j] <= INT_MIN || r[j] > INT_MAX)) int_ok=FALSE; break; case min_emin: r[j] = mpfr_get_emin_min(); if(int_ok) int_ok=FALSE; break; case max_emin: r[j] = mpfr_get_emin_max(); if(int_ok) int_ok=FALSE; break; case min_emax: r[j] = mpfr_get_emax_min(); if(int_ok) int_ok=FALSE; break; case max_emax: r[j] = mpfr_get_emax_max(); if(int_ok) int_ok=FALSE; break; default: error("invalid kind[j(=%d)] (code = %ld) in R_mpfr_get_erange()", j, (long)kind[j]); } R_mpfr_dbg_printf(1,"R_mpfr_get_erange(%ld): %ld\n", (long)kind[j], (long)r[j]); } SEXP ans; // int_ok: only now know if we can return integer or need double if(int_ok) { int* R = INTEGER(ans = allocVector(INTSXP, k)); for(int j = 0; j < k; j++) R[j] = (int) r[j]; } else { double* R = REAL(ans = allocVector(REALSXP, k)); for(int j = 0; j < k; j++) R[j] = (double) r[j]; } if(nprot) UNPROTECT(nprot); return ans; } // R's .mpfr_erange_set() -- here, set *one* of Emin and Emax: SEXP R_mpfr_set_erange(SEXP kind_, SEXP val) { erange_kind kind = asInteger(kind_); mpfr_exp_t exp_val; if(isInteger(val)) exp_val = asInteger(val);// assume this is always valid to set else { // we allow larger values from the R side PROTECT(val = coerceVector(val, REALSXP)); exp_val = (mpfr_exp_t) asReal(val); UNPROTECT(1); } int i_err; switch(kind) { case E_min: i_err = mpfr_set_emin(exp_val); break; case E_max: i_err = mpfr_set_emax(exp_val); break; default: error("invalid kind (code = %d) in R_mpfr_set_erange()", kind); } if(i_err) warning("e%s exponent could not be set to %ld (code %d)", (kind == E_min) ? "min" : "max", (long)exp_val, i_err); return ScalarInteger(i_err); } SEXP R_mpfr_prec_range(SEXP ind) { long r = (long) ( (INTEGER(ind)[0] == 1) ? MPFR_PREC_MIN : MPFR_PREC_MAX); R_mpfr_dbg_printf(1,"R_mpfr_prec_range(): %ld\n", r); // in 64 bit, int << long, so go "2nd best": return ScalarReal((double)r); } /** Get the 'base 2 exp slot' -- also in extended erange where it does not fit into integer * Directly called from R's .mpfr2exp(x) */ SEXP R_mpfr_2exp(SEXP x) { int n = length(x); mpfr_t R_i; mpfr_init(R_i); SEXP val; if(mpfr_erange_int_p()) { // integer is ok: 'exp' values won't be too large val = PROTECT(allocVector(INTSXP,n)); int *exp = INTEGER(val); for(int i=0; i < n; i++) { R_asMPFR(VECTOR_ELT(x, i), R_i); exp[i] = (int) mpfr_get_exp(R_i); } } else { val = PROTECT(allocVector(REALSXP,n)); double *exp = REAL(val); for(int i=0; i < n; i++) { R_asMPFR(VECTOR_ELT(x, i), R_i); exp[i] = (double) mpfr_get_exp(R_i); } } mpfr_clear(R_i); mpfr_free_cache(); UNPROTECT(1); return val; } //---------------------------------------------------------------------------- #define INIT_1_SETUP(_X_, _R_) \ mpfr_t _R_; \ \ mpfr_init2(_R_, R_mpfr_prec(_X_)); \ R_asMPFR(_X_, _R_) #define FINISH_1_RETURN(_R_, val) \ val = PROTECT(MPFR_as_R(_R_)); \ mpfr_clear (_R_); \ mpfr_free_cache(); \ UNPROTECT(1); \ return val SEXP const_asMpfr(SEXP I, SEXP prec, SEXP rnd_mode) { SEXP val; mpfr_t r; int i_p = asInteger(prec); R_mpfr_check_prec(i_p); mpfr_init2(r, i_p); switch(asInteger(I)) { case 1: mpfr_const_pi (r, R_rnd2MP(rnd_mode)); break; case 2: mpfr_const_euler (r, R_rnd2MP(rnd_mode)); break; case 3: mpfr_const_catalan(r, R_rnd2MP(rnd_mode)); break; case 4: mpfr_const_log2 (r, R_rnd2MP(rnd_mode)); break; default: error("invalid integer code {const_asMpfr()}"); /* -Wall */ } FINISH_1_RETURN(r, val); } /** For functions <- FUN(x = ) : */ #define R_MPFR_Logic_Function(_FNAME, _MPFR_NAME) \ SEXP _FNAME(SEXP x) { \ SEXP D = PROTECT(R_do_slot(x, Rmpfr_Data_Sym));/* R list() */ \ int n = length(D), i; \ SEXP val = PROTECT(allocVector(LGLSXP, n)); \ int *r = LOGICAL(val); \ mpfr_t r_i; \ mpfr_init(r_i); \ \ for(i=0; i < n; i++) { \ R_asMPFR(VECTOR_ELT(D, i), r_i); \ r[i] = _MPFR_NAME (r_i); \ } \ \ mpfr_clear (r_i); \ mpfr_free_cache(); \ UNPROTECT(2); \ return val; \ } R_MPFR_Logic_Function(R_mpfr_is_finite, mpfr_number_p) R_MPFR_Logic_Function(R_mpfr_is_infinite, mpfr_inf_p) R_MPFR_Logic_Function(R_mpfr_is_integer, mpfr_integer_p) // is.whole.mpfr() or .mpfr.is.whole(x) R_MPFR_Logic_Function(R_mpfr_is_na, mpfr_nan_p) R_MPFR_Logic_Function(R_mpfr_is_zero, mpfr_zero_p) // mpfrIs0() #define R_MPFRarray_Logic_Function(_FNAME, _MPFR_NAME) \ SEXP _FNAME(SEXP x) { \ SEXP D = PROTECT(R_do_slot(x, Rmpfr_Data_Sym)),/* R list() */ \ dim = PROTECT(R_do_slot(x, Rmpfr_Dim_Sym)), \ dn = PROTECT(R_do_slot(x, Rmpfr_Dimnames_Sym)); \ int n = length(D), i; \ SEXP val = PROTECT(allocVector(LGLSXP, n)); \ int *r = LOGICAL(val); \ mpfr_t r_i; \ mpfr_init(r_i); \ \ for(i=0; i < n; i++) { \ R_asMPFR(VECTOR_ELT(D, i), r_i); \ r[i] = _MPFR_NAME (r_i); \ } \ \ mpfr_clear (r_i); \ mpfr_free_cache(); \ setAttrib(val, R_DimSymbol, duplicate(dim)); \ setAttrib(val, R_DimNamesSymbol, duplicate(dn)); \ UNPROTECT(4); \ return val; \ } R_MPFRarray_Logic_Function(R_mpfr_is_finite_A, mpfr_number_p) R_MPFRarray_Logic_Function(R_mpfr_is_infinite_A, mpfr_inf_p) R_MPFRarray_Logic_Function(R_mpfr_is_integer_A, mpfr_integer_p) // is.whole() .. R_MPFRarray_Logic_Function(R_mpfr_is_na_A, mpfr_nan_p) R_MPFRarray_Logic_Function(R_mpfr_is_zero_A, mpfr_zero_p) // mpfrIs0() SEXP R_mpfr_fac (SEXP n_, SEXP prec, SEXP rnd_mode) { int n = length(n_), i, *nn; SEXP n_t, val = PROTECT(allocVector(VECSXP, n)); int nprot = 1; mpfr_rnd_t rnd = R_rnd2MP(rnd_mode); mpfr_t r_i; if(TYPEOF(n_) != INTSXP) { PROTECT(n_t = coerceVector(n_, INTSXP)); nprot++;/* or bail out*/ nn = INTEGER(n_t); } else { nn = INTEGER(n_); } int i_p = asInteger(prec); R_mpfr_check_prec(i_p); mpfr_init2(r_i, i_p); for(i=0; i < n; i++) { // never happens when called from R: if(nn[i] < 0) error("R_mpfr_fac(%d): negative n.", nn[i]); mpfr_fac_ui(r_i, nn[i], rnd); SET_VECTOR_ELT(val, i, MPFR_as_R(r_i)); } mpfr_clear(r_i); mpfr_free_cache(); UNPROTECT(nprot); return val; } /** For functions FUN(x = , y = ) : */ #define R_MPFR_2_Numeric_Function(_FNAME, _MPFR_NAME) \ SEXP _FNAME(SEXP x, SEXP y, SEXP rnd_mode) { \ SEXP xD = PROTECT(R_do_slot(x, Rmpfr_Data_Sym)); \ SEXP yD = PROTECT(R_do_slot(y, Rmpfr_Data_Sym)); \ mpfr_rnd_t rnd = R_rnd2MP(rnd_mode); \ int nx = length(xD), ny = length(yD), i, \ n = (nx == 0 || ny == 0) ? 0 : imax2(nx, ny); \ SEXP val = PROTECT(allocVector(VECSXP, n)); \ mpfr_t R, x_i, y_i; \ mpfr_init(R); /* with default precision */ \ mpfr_init(x_i); mpfr_init(y_i); \ \ for(i=0; i < n; i++) { \ R_asMPFR(VECTOR_ELT(xD, i % nx), x_i); \ R_asMPFR(VECTOR_ELT(yD, i % ny), y_i); \ mpfr_set_prec(R, max2_prec(mpfr_get_prec(x_i), \ mpfr_get_prec(y_i))); \ _MPFR_NAME(R, x_i, y_i, rnd); \ SET_VECTOR_ELT(val, i, MPFR_as_R(R)); \ } \ \ mpfr_clear(R); mpfr_clear(x_i); mpfr_clear(y_i); \ mpfr_free_cache(); \ UNPROTECT(3); \ return val; \ } R_MPFR_2_Numeric_Function(R_mpfr_atan2, mpfr_atan2) R_MPFR_2_Numeric_Function(R_mpfr_hypot, mpfr_hypot) #if (MPFR_VERSION >= MPFR_VERSION_NUM(3,2,0)) R_MPFR_2_Numeric_Function(R_mpfr_igamma, mpfr_gamma_inc) #else SEXP R_mpfr_igamma(SEXP x, SEXP y, SEXP rnd_mode) { error("mpfr_gamma_inc requires mpfr >= 3.2.0"); return R_NilValue; } #endif R_MPFR_2_Numeric_Function(R_mpfr_beta, my_mpfr_beta) R_MPFR_2_Numeric_Function(R_mpfr_lbeta, my_mpfr_lbeta) /** For functions FUN(x = , y = ) : */ #define R_MPFR_2_Num_Long_Function(_FNAME, _MPFR_NAME) \ SEXP _FNAME(SEXP x, SEXP y, SEXP rnd_mode) { \ SEXP xD, yt, val; \ mpfr_rnd_t rnd = R_rnd2MP(rnd_mode); \ int *yy, n, nx, ny = length(y), i, nprot = 0; \ mpfr_t x_i; \ \ if(TYPEOF(y) != INTSXP) { \ PROTECT(yt = coerceVector(y, INTSXP)); nprot++;/* or bail out*/ \ yy = INTEGER(yt); \ } else { \ yy = INTEGER(y); \ } \ PROTECT(xD = R_do_slot(x, Rmpfr_Data_Sym)); nprot++; \ nx = length(xD); \ n = (nx == 0 || ny == 0) ? 0 : imax2(nx, ny); \ PROTECT(val = allocVector(VECSXP, n)); nprot++; \ mpfr_init(x_i); /* with default precision; set prec in R_asMPFR() */\ \ for(i=0; i < n; i++) { \ R_asMPFR(VECTOR_ELT(xD, i % nx), x_i); \ _MPFR_NAME(x_i, (long) yy[i % ny], x_i, rnd); \ SET_VECTOR_ELT(val, i, MPFR_as_R(x_i)); \ } \ \ mpfr_clear (x_i); \ mpfr_free_cache(); \ UNPROTECT(nprot); \ return val; \ } R_MPFR_2_Num_Long_Function(R_mpfr_jn, mpfr_jn) R_MPFR_2_Num_Long_Function(R_mpfr_yn, mpfr_yn) R_MPFR_2_Num_Long_Function(R_mpfr_choose, my_mpfr_choose) R_MPFR_2_Num_Long_Function(R_mpfr_poch, my_mpfr_poch) R_MPFR_2_Num_Long_Function(R_mpfr_round, my_mpfr_round) Rmpfr/src/config.h.in0000644000176200001440000000355415075433707014174 0ustar liggesusers/* src/config.h.in. Generated from configure.ac by autoheader. */ /* Define to 1 if you have the header file. */ #undef HAVE_INTTYPES_H /* Define to 1 if you have the 'gmp' library (-lgmp). */ #undef HAVE_LIBGMP /* Define to 1 if you have the 'mpfr' library (-lmpfr). */ #undef HAVE_LIBMPFR /* Define to 1 if you have the header file. */ #undef HAVE_STDINT_H /* Define to 1 if you have the header file. */ #undef HAVE_STDIO_H /* Define to 1 if you have the header file. */ #undef HAVE_STDLIB_H /* Define to 1 if you have the header file. */ #undef HAVE_STRINGS_H /* Define to 1 if you have the header file. */ #undef HAVE_STRING_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_STAT_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TYPES_H /* Define to 1 if you have the header file. */ #undef HAVE_UNISTD_H /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT /* Define to the full name of this package. */ #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the home page for this package. */ #undef PACKAGE_URL /* Define to the version of this package. */ #undef PACKAGE_VERSION /* The size of 'mpfr_exp_t', as computed by sizeof. */ #undef SIZEOF_MPFR_EXP_T /* The size of 'mpfr_prec_t', as computed by sizeof. */ #undef SIZEOF_MPFR_PREC_T /* The size of 'mp_limb_t', as computed by sizeof. */ #undef SIZEOF_MP_LIMB_T /* Define to 1 if all of the C89 standard headers exist (not just the ones required in a freestanding environment). This macro is provided for backward compatibility; new code need not use it. */ #undef STDC_HEADERS Rmpfr/src/convert.c0000644000176200001440000006672015075433454014000 0ustar liggesusers/* * MPFR - Multiple Precision Floating-Point Reliable Library * ---- - - - - */ #include /* for imax2() */ #include "Rmpfr_utils.h" extern #include "Syms.h" /*------------------------------------------------------------------------*/ /* NB: int nr_limbs = R_mpfr_nr_limbs(r) [ in MPFR_as_R() ] or * = N_LIMBS(i_prec) [ in d2mpfr1_() ] * R_mpfr_exp_size is sufficient also for enlarged exponent range, as that is still < 2^62 */ #if SIZEOF_MP_LIMB_T == 4 # define R_mpfr_nr_ints nr_limbs #elif SIZEOF_MP_LIMB_T == 8 # define R_mpfr_nr_ints (2*nr_limbs) #else # error "R <-> C Interface *not* implemented for sizeof(mp_limb_t)=" ## SIZEOF_MP_LIMB_T #endif #if SIZEOF_MPFR_EXP_T == 4 # define R_mpfr_exp_size 1 #elif SIZEOF_MPFR_EXP_T == 8 # define R_mpfr_exp_size 2 #else # error "R <-> C Interface *not* implemented for sizeof(mpfr_exp_t)=" ## SIZEOF_MPFR_EXP_T #endif // Initialize contents (4 slots) of a "mpfr1" R object #define R_mpfr_MPFR_2R_init(_V_, _d_length_) \ SEXP _V_ = PROTECT(R_do_new_object(PROTECT(R_do_MAKE_CLASS("mpfr1")))); \ SEXP prec_R = PROTECT(ALLOC_SLOT(_V_, Rmpfr_precSym, INTSXP, 1)); \ SEXP sign_R = PROTECT(ALLOC_SLOT(_V_, Rmpfr_signSym, INTSXP, 1)); \ SEXP exp_R = PROTECT(ALLOC_SLOT(_V_, Rmpfr_expSym, INTSXP, R_mpfr_exp_size)); \ SEXP d_R = PROTECT(ALLOC_SLOT(_V_, Rmpfr_d_Sym, INTSXP, _d_length_)); \ /* the integer vector which makes up the mantissa: */ \ unsigned int *dd = (unsigned int *) INTEGER(d_R), \ *ex = (unsigned int *) INTEGER(exp_R) /* the one for the exponent */ /*------------------------*/ /* Convert integer 'u' of unsigned type 'utype' to corresponding signed * type 'stype' without relying on implementation-defined behaviour when * 'u' exceeds the maximum of 'stype'; see C99 6.3.1.3 */ #define CAST_SIGNED(u, utype, stype) \ (((u) <= ((utype) -1 >> 1)) ? (stype) u : -(stype) ~(u) - 1) #if SIZEOF_MP_LIMB_T == 4 /* ---- easy : a gmp-limb is an int <--> R */ static R_INLINE void R_mpfr_FILL_DVEC(int i, mpfr_t r, unsigned int *dd) { mp_limb_t limb = r->_mpfr_d[i]; dd[i] = (unsigned int) limb; R_mpfr_dbg_printf(2, "r..d[i=%d] = 0x%lx\n", i, limb); } static R_INLINE void R_mpfr_GET_DVEC(int i, mpfr_t r, unsigned int *dd) { mp_limb_t limb = (mp_limb_t) dd[i]; r->_mpfr_d[i] = limb; R_mpfr_dbg_printf(2, "dd[%d] = %10lu -> r..d[i=%d] = 0x%lx\n", i, limb, i, limb); } #elif SIZEOF_MP_LIMB_T == 8 /* ---- here a gmp-limb is 64-bit (long long): * ==> one limb <---> 2 R int.s : */ // This is only ok if( mpfr_regular_p(.) ), i.e. not for {0, NaN, Inf}: static R_INLINE void R_mpfr_FILL_DVEC(int i, mpfr_t r, unsigned int *dd) { mp_limb_t limb = r->_mpfr_d[i]; dd[2*i ] = (unsigned int) (limb & 0x00000000FFFFFFFFu); dd[2*i+1] = (unsigned int) (limb >> 32); R_mpfr_dbg_printf(2, "r..d[i=%d] = 0x%llx\n", i, (unsigned long long) limb); } static R_INLINE void R_mpfr_GET_DVEC(int i, mpfr_t r, unsigned int *dd) { mp_limb_t limb = ((mp_limb_t) dd[2*i+1] << 32) | ((mp_limb_t) dd[2*i] & 0x00000000FFFFFFFFu); r->_mpfr_d[i] = limb; R_mpfr_dbg_printf(2, "dd[%d:%d] = (%10lu,%10lu) -> r..d[i=%d] = 0x%llx\n", 2*i, 2*i+1, dd[2*i], dd[2*i+1], i, (unsigned long long) limb); } #else # error "will not happen" #endif #if SIZEOF_MPFR_EXP_T == 4 // these work on (r, ex[0]) : static R_INLINE void R_mpfr_FILL_EXP(mpfr_t r, unsigned int *ex) { ex[0] = (unsigned int) r->_mpfr_exp; } static R_INLINE void R_mpfr_GET_EXP(mpfr_t r, unsigned int *ex, unsigned int ex1) { r->_mpfr_exp = (mpfr_exp_t) CAST_SIGNED(ex[0], unsigned int, int); } #elif SIZEOF_MPFR_EXP_T == 8 // these work on (r, ex[0], {ex[1] or ex1}) : static R_INLINE void R_mpfr_FILL_EXP(mpfr_t r, unsigned int *ex) { mpfr_uexp_t exponent = (mpfr_uexp_t) r->_mpfr_exp; ex[0] = (unsigned int) (exponent & 0x00000000FFFFFFFFu); ex[1] = (unsigned int) (exponent >> 32); R_mpfr_dbg_printf(2, "_exp = 0x%llx\n", (unsigned long long) exponent); } static R_INLINE void R_mpfr_GET_EXP(mpfr_t r, unsigned int *ex, unsigned int ex1) { mpfr_uexp_t exponent = ((mpfr_uexp_t) ex1 << 32) | ((mpfr_uexp_t) ex[0] & 0x00000000FFFFFFFFu); r->_mpfr_exp = CAST_SIGNED(exponent, mpfr_uexp_t, mpfr_exp_t); R_mpfr_dbg_printf(2, "ex[0:1] = (%10lu,%10lu) -> _exp = 0x%llx\n", ex[0], ex1, (unsigned long long) exponent); } #else # error "will not happen" #endif static R_INLINE void R_mpfr_MPFR_2R_fill(mpfr_t r, unsigned int *ex, int nr_limbs, int regular_p, // Fill (i.e., modify) these : unsigned int *dd, /* = INTEGER(d_R) , the vector which makes up the mantissa */ SEXP prec_R, SEXP sign_R) { /* now fill the slots of val */ INTEGER(prec_R)[0] = (int)r->_mpfr_prec; INTEGER(sign_R)[0] = (int)r->_mpfr_sign; R_mpfr_FILL_EXP(r, ex); if(regular_p) { /* the full *vector* of limbs : */ for(int i=0; i < nr_limbs; i++) { R_mpfr_FILL_DVEC(i, r, dd); } } } /* Return an R "mpfr1" object corresponding to mpfr input: */ SEXP MPFR_as_R(mpfr_t r) { int nr_limbs = R_mpfr_nr_limbs(r), regular_p = mpfr_regular_p(r); R_mpfr_MPFR_2R_init(val, (regular_p ? R_mpfr_nr_ints : 0)); R_mpfr_MPFR_2R_fill(r, ex, nr_limbs, regular_p, // Fill these : dd, /* = INTEGER(d_R) , the vector which makes up the mantissa */ prec_R, sign_R); UNPROTECT(6); return val; } SEXP d2mpfr1_(double x, int i_prec, mpfr_rnd_t rnd) { R_mpfr_check_prec(i_prec); mpfr_t r; mpfr_init2 (r, (mpfr_prec_t)i_prec); mpfr_set_d (r, x, rnd); int nr_limbs = N_LIMBS(i_prec), regular_p = mpfr_regular_p(r); R_mpfr_MPFR_2R_init(val, (regular_p ? R_mpfr_nr_ints : 0)); R_mpfr_MPFR_2R_fill(r, ex, N_LIMBS(i_prec), regular_p, // Fill these : dd, /* = INTEGER(d_R) , the vector which makes up the mantissa */ prec_R, sign_R); /* free space used by the MPFR variables */ mpfr_clear (r); mpfr_free_cache(); /* <- Manual 4.8 "Memory Handling" strongly advises ...*/ UNPROTECT(6); return val; }/* d2mpfr1_ */ /** * Translate an "R rounding mode" into the correct MPFR one * * @param rnd_mode: an R character (string with nchar() == 1). * * @return one of the (currently 4) different MPFR_RND[DNUZ] modes. */ mpfr_rnd_t R_rnd2MP(SEXP rnd_mode) { const char* r_ch = CHAR(asChar(rnd_mode)); switch(r_ch[0]) { case 'D': return MPFR_RNDD; case 'N': return MPFR_RNDN; case 'U': return MPFR_RNDU; case 'Z': return MPFR_RNDZ; case 'A': return MPFR_RNDA; // since MPFR 3.0.0 default: error(_("illegal rounding mode '%s'; must be one of {'D','N','U','Z','A'}"), r_ch); /* Wall: */ return MPFR_RNDN; } } SEXP d2mpfr1(SEXP x, SEXP prec, SEXP rnd_mode) { if(LENGTH(x) != 1) error("length(x) (=%d) is not 1", LENGTH(x)); return d2mpfr1_(asReal(x), asInteger(prec), R_rnd2MP(rnd_mode)); } SEXP d2mpfr1_list(SEXP x, SEXP prec, SEXP rnd_mode) { int nx = LENGTH(x), np = LENGTH(prec), n = (nx == 0 || np == 0) ? 0 : imax2(nx, np), nprot = 1; SEXP val = PROTECT(allocVector(VECSXP, n)); if(nx > 0) { mpfr_rnd_t rnd = R_rnd2MP(rnd_mode); if(!isReal(x)) { PROTECT(x = coerceVector(x, REALSXP)); nprot++; } if(!isInteger(prec)) { PROTECT(prec = coerceVector(prec, INTSXP)); nprot++; } double *dx = REAL(x); int *iprec = INTEGER(prec); for(int i = 0; i < n; i++) { /* FIXME: become more efficient by doing R_mpfr_MPFR_2R_init() only once*/ SET_VECTOR_ELT(val, i, d2mpfr1_(dx[i % nx], iprec[i % np], rnd)); } } UNPROTECT(nprot); return val; } /* -- Function: int mpfr_set_z (mpfr_t ROP, mpz_t OP, mpfr_rnd_t RND) -- Function: int mpfr_set_q (mpfr_t ROP, mpq_t OP, mpfr_rnd_t RND) --> would want functions SEXP mpz2mpfr1_(mpz_t x, int i_prec, mpfr_rnd_t rnd); SEXP mpz2mpfr1 (SEXP x, SEXP prec, SEXP rnd_mode); SEXP mpz2mpfr1_list(SEXP x, SEXP prec, SEXP rnd_mode); {and the same for 'q' instead of 'z'} completely parallel to the d2mpfr*() functions above *BUT* we cannot easily do the [R package gmp C++ code]-part of SEXP -> mpz ! MM - FIXME: still do it .. should not be so hard to "guess" ... horrifically, ... for now, R's ..bigq2mpfr(), ..bigz2mpfr() "simply" go via character strings */ /* From the MPFR (2.3.2, 2008) doc : -- Function: int mpfr_set_str (mpfr_t ROP, const char *S, int BASE, mpfr_rnd_t RND) Set ROP to the value of the whole string S in base BASE, rounded in the direction RND. See the documentation of `mpfr_strtofr' for a detailed description of the valid string formats. This function returns 0 if the entire string up to the final null character is a valid number in base BASE; otherwise it returns -1, and ROP may have changed. */ SEXP str2mpfr1_list(SEXP x, SEXP prec, SEXP base, SEXP rnd_mode) { /* NB: Both x and prec are "recycled" to the longer one if needed */ int ibase = asInteger(base), *iprec, nx = LENGTH(x), np = LENGTH(prec), n = (nx == 0 || np == 0) ? 0 : imax2(nx, np), nprot = 1; SEXP val = PROTECT(allocVector(VECSXP, n)); mpfr_rnd_t rnd = R_rnd2MP(rnd_mode); mpfr_t r_i; mpfr_init(r_i); if(!isString(x)) { PROTECT(x = coerceVector(x, STRSXP)); nprot++; } if(!isInteger(prec)) { PROTECT(prec = coerceVector(prec, INTSXP)); nprot++; } iprec = INTEGER(prec); for(int i = 0; i < n; i++) { int prec_i = iprec[i % np]; R_mpfr_check_prec(prec_i); mpfr_set_prec(r_i, (mpfr_prec_t) prec_i); int ierr = mpfr_set_str(r_i, CHAR(STRING_ELT(x, i % nx)), ibase, rnd); if(ierr) { if (!strcmp("NA", CHAR(STRING_ELT(x, i % nx)))) mpfr_set_nan(r_i); // "NA" <=> "NaN" (which *are* treated well, by mpfr_set_str) else error("str2mpfr1_list(x, *): x[%d] cannot be made into MPFR", i+1); } /* FIXME: become more efficient by doing R_mpfr_MPFR_2R_init() only once*/ SET_VECTOR_ELT(val, i, MPFR_as_R(r_i)); } mpfr_clear (r_i); mpfr_free_cache(); UNPROTECT(nprot); return val; } #undef R_mpfr_MPFR_2R_init #ifdef _not_used_ /* This does *not* work: gives *empty* .Data slot [bug in R_do_new_object()? ] */ SEXP d2mpfr(SEXP x, SEXP prec) { int i_prec = asInteger(prec), nx = LENGTH(x), np = LENGTH(prec), n = (nx == 0 || np == 0) ? 0 : imax2(nx, np), nprot = 1; SEXP val = PROTECT(R_do_new_object(R_do_MAKE_CLASS("mpfr"))), lis = ALLOC_SLOT(val, Rmpfr_Data_Sym, VECSXP, n); double *dx; if(!isReal(x)) { PROTECT(x = coerceVector(x, REALSXP)); nprot++; } REprintf("d2mpfr(x, prec): length(x) = %d, prec = %d -> length(lis) = %d\n", nx, i_prec, LENGTH(lis)); dx = REAL(x); for(int i = 0; i < n; i++) { SET_VECTOR_ELT(lis, i, duplicate(d2mpfr1_(dx [i % nx], i_prec [i % np]))); } UNPROTECT(nprot); return val; } #endif /* The inverse of MPFR_as_R() : * From an R "mpfr1" object `x`, create mpfr `r` (with correct prec): */ void R_asMPFR(SEXP x, mpfr_ptr r) { SEXP prec_R = R_do_slot(x, Rmpfr_precSym); // SEXP sign_R = R_do_slot(x, Rmpfr_signSym);// only used once SEXP exp_R = R_do_slot(x, Rmpfr_expSym); SEXP d_R = R_do_slot(x, Rmpfr_d_Sym); int x_prec = INTEGER(prec_R)[0], nr_limbs = N_LIMBS(x_prec), i; Rboolean regular_x = length(d_R) > 0; /* the integer vector which makes up the mantissa: */ unsigned int *dd = (unsigned int *) INTEGER(d_R), *ex = (unsigned int *) INTEGER(exp_R), ex1; /* the one for the exponent */ if(regular_x && length(d_R) != R_mpfr_nr_ints) error("nr_limbs(x_prec)= nr_limbs(%d)= %d : length() == %d != R_mpfr_nr_ints == %d", x_prec, nr_limbs, length(d_R), R_mpfr_nr_ints); if(length(exp_R) < R_mpfr_exp_size) { if(length(exp_R) == 0) error("'exp' slot has length 0"); /* else: we got a 32-bit one in a 64-bit system */ ex1 = 0; } else ex1 = ex[1]; mpfr_set_prec(r, (mpfr_prec_t) x_prec); r->_mpfr_sign = (mpfr_sign_t) INTEGER(R_do_slot(x, Rmpfr_signSym))[0]; R_mpfr_GET_EXP(r, ex, ex1); if(regular_x) /* the full *vector* of limbs : */ for(i=0; i < nr_limbs; i++) { R_mpfr_GET_DVEC(i, r, dd); } return; } #ifdef R_had_R_Outputfile_in_API #ifndef WIN32 /* This only works on "unix-alikes" ... but we don't really need it */ /* for R_Outputfile : */ #include SEXP print_mpfr1(SEXP x, SEXP digits) { mpfr_t r; Rboolean use_x_digits = INTEGER(digits)[0] == NA_INTEGER; mpfr_init2(r, R_mpfr_prec(x)); R_asMPFR(x, r); /* Rprintf(" * [dbg] after R_asMPFR() ..\n"); */ mpfr_out_str (R_Outputfile, 10, use_x_digits ? 0 : asInteger(digits), r, MPFR_RNDD); /* prints the value of s in base 10, rounded towards -Inf, where the third argument 0 means that the number of printed digits is automatically chosen from the precision of s; */ Rprintf("\n"); mpfr_clear (r); mpfr_free_cache(); /* <- Manual 4.8 "Memory Handling" strongly advises ...*/ return x; } SEXP print_mpfr(SEXP x, SEXP digits) { SEXP D = R_do_slot(x, Rmpfr_Data_Sym);/* an R list() of length n */ int n = length(D), i; mpfr_t r; Rboolean use_x_digits = INTEGER(digits)[0] == NA_INTEGER; /* #if MPFR_VERSION >= MPFR_VERSION_NUM(2,4,0) */ /* char buf[R_BUFSIZE], *p = buf; */ /* #endif */ mpfr_init(r); /* with default precision */ for(i=0; i < n; i++) { R_asMPFR(VECTOR_ELT(D, i), r); /* #if MPFR_VERSION >= MPFR_VERSION_NUM(2,4,0) */ /* Rprintf */ /* #else /\* requires R_Outputfile from R's Interfaces.h ___Unix-alike only__ *\/ */ mpfr_out_str (R_Outputfile, 10, use_x_digits ? 0 : asInteger(digits), r, MPFR_RNDD); /* #endif */ Rprintf("\n"); } mpfr_clear (r); mpfr_free_cache(); /* <- Manual 4.8 "Memory Handling" strongly advises ...*/ return x; } #endif /* ^^^ Unix-alike only */ #endif /* Convert R "mpfr" object (list of "mpfr1") to R "double" vector : */ SEXP mpfr2d(SEXP x, SEXP rnd_mode) { int n = length(x), i; SEXP val = PROTECT(allocVector(REALSXP, n)); double *r = REAL(val); mpfr_t R_i; mpfr_init(R_i); /* with default precision; set prec in R_asMPFR() */ for(i=0; i < n; i++) { R_asMPFR(VECTOR_ELT(x, i), R_i); r[i] = mpfr_get_d(R_i, R_rnd2MP(rnd_mode)); } mpfr_clear (R_i); mpfr_free_cache(); UNPROTECT(1); return val; } /* Convert R "mpfr" object (list of "mpfr1") to R "integer" vector : */ SEXP mpfr2i(SEXP x, SEXP rnd_mode) { int n = length(x), i; SEXP val = PROTECT(allocVector(INTSXP, n)); int *r = INTEGER(val); mpfr_t R_i; mpfr_init(R_i); /* with default precision; set prec in R_asMPFR() */ for(i=0; i < n; i++) { R_asMPFR(VECTOR_ELT(x, i), R_i); if(!mpfr_fits_sint_p(R_i, R_rnd2MP(rnd_mode))) { warning("NAs introduced by coercion from \"mpfr\" [%d]", i+1); r[i] = NA_INTEGER; } else { long lr = mpfr_get_si(R_i, R_rnd2MP(rnd_mode)); r[i] = (int) lr; } } mpfr_clear (R_i); mpfr_free_cache(); UNPROTECT(1); return val; } /* Get "format info" from R "mpfr" object -- into list with (exp, finite, is.0), * a subset of mpfr2str() [below] : ---> see also R_mpfr_exp() in ./utils.c * */ SEXP R_mpfr_formatinfo(SEXP x) { int n = length(x); static const char *ans_nms[] = {"exp", "finite", "is.0", ""}; SEXP val = PROTECT(mkNamed(VECSXP, ans_nms)), exp, fini, zero; int erange_is_int = mpfr_erange_int_p(); SEXPTYPE exp_SXP = (erange_is_int ? INTSXP : REALSXP); SET_VECTOR_ELT(val, 0, exp = PROTECT(allocVector(exp_SXP,n))); SET_VECTOR_ELT(val, 1, fini= PROTECT(allocVector(LGLSXP, n))); SET_VECTOR_ELT(val, 2, zero= PROTECT(allocVector(LGLSXP, n))); int *is_fin= LOGICAL(fini), *is_0 = LOGICAL(zero); mpfr_t R_i; mpfr_init(R_i); /* with default precision; set prec in R_asMPFR() */ if(erange_is_int) { int *exp_ = INTEGER(exp); #define FOR_I_N_ASSIGN(exp_typ) \ for(int i=0; i < n; i++) { \ R_asMPFR(VECTOR_ELT(x, i), R_i); \ exp_ [i] = (exp_typ) mpfr_get_exp(R_i); \ is_fin[i] = mpfr_number_p(R_i); \ is_0 [i] = mpfr_zero_p(R_i); \ } FOR_I_N_ASSIGN(int) } else {/* 'exp' needs to use "double" as it may not fit into integer, consistent with R_mpfr_get_erange(), or R_mpfr_prec_range() : */ double *exp_ = REAL(exp); FOR_I_N_ASSIGN(double) } mpfr_clear (R_i); mpfr_free_cache(); UNPROTECT(4); return val; } /* Convert R "mpfr" object (list of "mpfr1") to R "character" vector, * using 'digits' (or determinining it): * 1) digits = NULL , maybe_full = FALSE (<==> 'scientific = TRUE') * --------------- -------------~~~~~ ==> set digits <=> getPrec(x) * 2) digits = NULL , maybe_full = TRUE (<=> 'scientific' = NA or FALSE in the calling formatMpfr() * ------------- ----------------- ==> set digits <=> max(getPrec(x), #{"digits left of '.'"}) * 3) digits = , maybe_full = TRUE (<=> 'scientific' = TRUE in the calling formatMpfr() * ------------- -----------------==> set digits <=> max(digit, getPrec(x), #{"digits left of '.'"})) * * Rmpfr:::.mpfr_debug(1) ==> to add debug output here * * mpfr2str() is the workhorse for R level formatMpfr() , called from format() <- print() */ SEXP mpfr2str(SEXP x, SEXP digits, SEXP maybeFull, SEXP base) { int n = length(x), i; int B = asInteger(base); // = base for output int n_dig = isNull(digits) ? 0 : asInteger(digits); if(n_dig < 0) error("'digits' must be NULL or a positive integer"); if(asLogical(maybeFull) == NA_LOGICAL) // cannot happen when called "regularly" error("'maybe.full' must be TRUE or FALSE"); Rboolean maybe_full = asLogical(maybeFull); R_mpfr_dbg_printf(1,"mpfr2str(*, digits=%d, maybeF=%s, base=%d):\n", n_dig, (maybe_full ? "TRUE" : "False"), B); /* int dig_n_max = -1; */ /* SEXP val = PROTECT(allocVector(VECSXP, 4)), */ /* nms, str, exp, fini, zero; */ /* int *i_exp, *is_fin, *is_0; */ char *ch = NULL; /* N_digits == 1 , for base = 2, 4, 8, 16, 32 (base <= 62 !) gives bad abort from MPFR: get_str.c:2306: MPFR assertion failed: m >= 2 || ((((b) & ((b) - 1)) == 0) == 0 && m >= 1) ... Aborted ... (Speicherabzug geschrieben) the MPFR doc (see mpfr_get_str below) *says* N >= 2 is required, but we have used N = 1 for B = 10 a lot in the past ! */ Rboolean base_is_2_power = (B == 2 || B == 4 || B == 8 || B == 16 || B == 32); Rboolean n_dig_1_problem = (n_dig == 1) && base_is_2_power; int N_digits = n_dig_1_problem ? 2 : n_dig; static const char *ans_nms[] = {"str", "exp", "finite", "is.0", ""}; SEXP val = PROTECT(mkNamed(VECSXP, ans_nms)), str, exp, fini, zero; // NB: 'exp' may have to be 'double' instead of 'integer', when erange allows large exponents int erange_is_int = mpfr_erange_int_p(); SEXPTYPE exp_SXP = (erange_is_int ? INTSXP : REALSXP); SET_VECTOR_ELT(val, 0, str = PROTECT(allocVector(STRSXP, n))); SET_VECTOR_ELT(val, 1, exp = PROTECT(allocVector(exp_SXP,n))); SET_VECTOR_ELT(val, 2, fini= PROTECT(allocVector(LGLSXP, n))); SET_VECTOR_ELT(val, 3, zero= PROTECT(allocVector(LGLSXP, n))); // depending on erange_is_int, only need one of d_exp or i_exp (but don't see a more elegant way): double *d_exp; // = REAL(exp); int *i_exp; // = INTEGER(exp), int *is_fin= LOGICAL(fini), *is_0 = LOGICAL(zero); double p_fact = (B == 2) ? 1. : log(B) / M_LN2;// <==> P / p_fact == P *log(2)/log(B) int max_nchar = -1; // := max_i { dig_needed[i] } mpfr_t R_i; mpfr_init(R_i); /* with default precision; set prec in R_asMPFR() */ if(erange_is_int) { i_exp = INTEGER(exp); d_exp = NULL; } else { i_exp = NULL; d_exp = REAL(exp); } for(i=0; i < n; i++) { mpfr_exp_t exp = (mpfr_exp_t) 0; mpfr_exp_t *exp_ptr = &exp; int nchar_i; Rboolean use_nchar = TRUE; R_asMPFR(VECTOR_ELT(x, i), R_i); int is0 = mpfr_zero_p(R_i); int isFin = mpfr_number_p(R_i); is_0 [i] = is0; is_fin[i] = isFin; if(N_digits) {/* use it as desired precision */ nchar_i = N_digits; R_mpfr_dbg_printf(1,"N_digits: [i=%d]: ... -> dig.n = %d ", i, nchar_i); } else if(!isFin) { nchar_i = 5; // @Inf@ @NaN@ } else if(is0) { nchar_i = 1 + base_is_2_power; } else { /* N_digits = 0 --> string must use "enough" digits */ // MPFR doc on mpfr_get_str(): use 'm + 1' where m = 1+ceil(P * log(2)/log(B)) double P = (double)R_i->_mpfr_prec; if(base_is_2_power) P--; // P := P-1 iff B is a power of 2 double m1 = 1 + ceil(P / p_fact) + 1; double dchar_i = maybe_full ? // want all digits before "." : fmax2(m1, ceil((double)mpfr_get_exp(R_i) / p_fact)) : m1; if(dchar_i > 536870912 /* = 2^29 */) // << somewhat arbitrary but < INT_MAX ~= 2^31-1 error(_(".mpfr2str(): too large 'dchar_i = %g'; please set 'digits = '"), dchar_i); nchar_i = (int) dchar_i; R_mpfr_dbg_printf(1," [i=%d]: prec=%ld, exp2=%ld -> (nchar_i,dig.n)=(%g,%d) ", i, R_i->_mpfr_prec, mpfr_get_exp(R_i), dchar_i, nchar_i); if(nchar_i <= 1 && base_is_2_power) { // have n_dig_problem: R_mpfr_dbg_printf_0(1," base_is_2_power & nchar_i=%d ==> fudge dig_n. := 2"); nchar_i = 2; } use_nchar = FALSE; } if (i == 0) { /* first time */ max_nchar = nchar_i; ch = (char *) R_alloc(imax2(max_nchar + 2, 7), // 7 : '-@Inf@' (+ \0)n_str, sizeof(char)); } else if(!N_digits && nchar_i > max_nchar) { // enlarge : ch = (char *) S_realloc(ch, imax2( nchar_i + 2, 7), imax2(max_nchar + 2, 7), sizeof(char)); max_nchar = nchar_i; } /* char* mpfr_get_str (char *STR, mpfr_exp_t *EXPPTR, int B, * size_t N, mpfr_t OP, mpfr_rnd_t RND) Convert OP to a string of digits in base B, with rounding in the direction RND, where N is either zero (see below) or the number of significant digits output in the string; in the latter case, N must be greater or equal to 2. The base may vary from 2 to 62; ......... ......... ==> MPFR info manual "5.4 Conversion Functions" */ R_mpfr_dbg_printf_0(1," .. max_nchar=%d\n", max_nchar); /* // use nchar_i notably when that is smaller than max_nchar : */ /* mpfr_get_str(ch, exp_ptr, B, (size_t) nchar_i, R_i, MPFR_RNDN); */ /* ---- alternatively, * N = 0 : MPFR finds the number of digits needed : */ mpfr_get_str(ch, exp_ptr, B, (size_t) (maybe_full || use_nchar) ? nchar_i : 0, //========== --- R_i, MPFR_RNDN); SET_STRING_ELT(str, i, mkChar(ch)); if(erange_is_int) i_exp [i] = (int) exp_ptr[0]; else d_exp [i] = (double) exp_ptr[0]; } mpfr_clear (R_i); mpfr_free_cache(); UNPROTECT(5); return val; } /* R ldexpMpfr(f, E) * * return "mpfr" x = f * 2^E where 'f' is "mpfr" and 'E' is "integer". * ------- * "Problem": here, the exponent is limited to +/- 2^31-1 ("ok" with default erange; * but the maximal erange is +- 2^61 which corresponds to *two* 32-bit integers */ SEXP R_mpfr_ldexp(SEXP f, SEXP E, SEXP rnd_mode) { /* NB: Allow *recycling* for (f, E) * -- using 'mismatch' and the MISMATCH macros */ mpfr_rnd_t rnd = R_rnd2MP(rnd_mode); int nprot = 0; if(!isInteger(E)) { PROTECT(E = coerceVector(E, INTSXP)); nprot++; } int *ee = INTEGER(E), nx = length(f), ny = length(E), // instead of 'nf, nE' for MISMATCH macros n = (nx == 0 || ny == 0) ? 0 : imax2(nx, ny), mismatch = 0; SEXP val = PROTECT(allocVector(VECSXP, n)); nprot++; mpfr_t x_i; mpfr_init(x_i); /* with default precision; set prec in R_asMPFR() */ SET_MISMATCH; for(int i=0; i < n; i++) { R_asMPFR(VECTOR_ELT(f, i % nx), x_i); mpfr_mul_2si(x_i, x_i, (long) ee[i % ny], rnd); /* -- Function: int mpfr_mul_2si (mpfr_t ROP, mpfr_t OP1, long int OP2, mpfr_rnd_t RND) Set ROP to OP1 times 2 raised to OP2 rounded in the direction RND. Just increases the exponent by OP2 when ROP and OP1 are identical. */ SET_VECTOR_ELT(val, i, MPFR_as_R(x_i)); } MISMATCH_WARN; mpfr_clear (x_i); mpfr_free_cache(); UNPROTECT(nprot); return val; } #ifdef _not_yet_ /* For R functionality: from "mpfr" x, return list(z, E), * z = "bigz", E = "integer" (or integer-valued double) such that x = z * 2^E exactly */ SEXP R_mpfr_get_2exp(SEXP x) { /*-- Function: mpfr_exp_t mpfr_get_z_2exp (mpz_t ROP, mpfr_t OP) Put the scaled significand of OP (regarded as an integer, with the precision of OP) into ROP, and return the exponent EXP (which may be outside the current exponent range) such that OP exactly equals ROP times 2 raised to the power EXP. If OP is zero, the minimal exponent ‘emin’ is returned. If OP is NaN or an infinity, the _erange_ flag is set, ROP is set to 0, and the the minimal exponent ‘emin’ is returned. The returned exponent may be less than the minimal exponent ‘emin’ of MPFR numbers in the current exponent range; in case the exponent is not representable in the ‘mpfr_exp_t’ type, the _erange_ flag is set and the minimal value of the ‘mpfr_exp_t’ type is returned. */ // placeholder -- FIXME ! return R_Nilvalue; } #endif // _not_yet_ // R frexpMpfr(x) |-> list(r, e) SEXP R_mpfr_frexp(SEXP x, SEXP rnd_mode) { mpfr_rnd_t rnd = R_rnd2MP(rnd_mode); // NB: 'exp' may have to be 'double' instead of 'integer', when erange allows large exponents int erange_is_int = mpfr_erange_int_p(); SEXPTYPE exp_SXP = (erange_is_int ? INTSXP : REALSXP); int n = length(x); static const char *ans_nms[] = {"r", "e", ""}; SEXP ans = PROTECT(mkNamed(VECSXP, ans_nms)), r, e; // r: fractional parts; still "mpfr" numbers: SET_VECTOR_ELT(ans, 0, r = PROTECT(duplicate(x))); // e: 2-exponents (integer or double see aboe) SET_VECTOR_ELT(ans, 1, e = PROTECT(allocVector(exp_SXP, n))); int *ei_; double *ed_; if(erange_is_int) ei_ = INTEGER(e); else ed_ = REAL(e); mpfr_t x_i, y_i; mpfr_init(x_i); /* with default precision; set prec in R_asMPFR() */ mpfr_init(y_i); mpfr_exp_t Ex = (mpfr_exp_t)0; // create and initialize "valgrindably" // Rboolean int_ok = TRUE; for(int i=0; i < n; i++) { R_asMPFR(VECTOR_ELT(x, i), x_i); mpfr_set_prec(y_i, mpfr_get_prec(x_i)); int ierr = mpfr_frexp(&Ex, y_i, x_i, rnd); /*-- Function: int mpfr_frexp (mpfr_exp_t *EXP, mpfr_t Y, mpfr_t X, mpfr_rnd_t RND) Set EXP (formally, the value pointed to by EXP) and Y such that 0.5<=abs(Y)<1 and Y times 2 raised to EXP equals X rounded to the precision of Y, using the given rounding mode. If X is zero, then Y is set to a zero of the same sign and EXP is set to 0. If X is NaN or an infinity, then Y is set to the same value and EXP is undefined. */ if(ierr) { #define MPFR_CLEAR mpfr_clear(x_i); mpfr_clear(y_i); mpfr_free_cache() MPFR_CLEAR; error("R_mpfr_frexp(): mpfr_frexp(x[%d]) gave error code %d\n", i+1, ierr); } if(erange_is_int) ei_[i] = (int) Ex; else ed_[i] = (double) Ex; SET_VECTOR_ELT(r, i, MPFR_as_R(y_i)); } MPFR_CLEAR; UNPROTECT(3); return ans; } // TODO : get *exact* as.bigq.mpfr(), i.e, "mpfr" --> "bigq". (R's "bigq" is C 'mpq') // ---- inside the GMP library, have // _________ // -- Function: void mpq_set_f (mpq_t ROP, const mpf_t OP) // ^^^^^^^^^ // Set ROP to the value of OP. // There is no rounding, this conversion is **exact**. /* ---not-yet--- #include */ /* maybe we only need very little of the above, such as #define mpf_t mpfr_t --------------------- ? */ Rmpfr/src/Ops.c0000644000176200001440000006637114644765014013064 0ustar liggesusers/* * MPFR - Multiple Precision Floating-Point Reliable Library * ---- - - - - * * Arithmetic, Math, etc */ #include #include /* imax2() */ #include "Rmpfr_utils.h" extern #include "Syms.h" SEXP Rmpfr_minus(SEXP x) { int n = length(x); SEXP val = PROTECT(duplicate(x)); for(int i=0; i < n; i++) { int sign = asInteger(R_do_slot(VECTOR_ELT(x,i), Rmpfr_signSym)); SEXP r_i = VECTOR_ELT(val, i); R_do_slot_assign(r_i, Rmpfr_signSym, ScalarInteger(-sign)); SET_VECTOR_ELT(val, i, r_i); } UNPROTECT(1); return val; } /* Rmpfr_minus() */ SEXP Rmpfr_abs(SEXP x) { int n = length(x); SEXP val = PROTECT(duplicate(x)); for(int i=0; i < n; i++) { SEXP r_i = VECTOR_ELT(val, i); R_do_slot_assign(r_i, Rmpfr_signSym, ScalarInteger(1)); SET_VECTOR_ELT(val, i, r_i); } UNPROTECT(1); return val; } /* Rmpfr_abs() */ /*------------------------------------------------------------------------*/ SEXP Math_mpfr(SEXP x, SEXP op) { #ifdef using_Data_slot SEXP D = PROTECT(R_do_slot(x, Rmpfr_Data_Sym)); #else # define D x #endif mpfr_prec_t current_prec = mpfr_get_default_prec(); int n = length(D), i_op = asInteger(op), i; SEXP val = PROTECT(allocVector(VECSXP, n)); mpfr_t R_i, cum; Rboolean is_cum = (71 <= i_op && i_op <= 74); mpfr_init(R_i); /* with default precision */ if(is_cum) { // cummax, cumsum, ... mpfr_init(cum); switch(i_op) { case 71: /* cummax */ mpfr_set_inf(cum, -1);/* := -Inf */; break; case 72: /* cummin */ mpfr_set_inf(cum, +1);/* := +Inf */; break; case 73: /* cumprod */ mpfr_set_d(cum, 1., MPFR_RNDZ);/* := 1 */; break; case 74: /* cumsum */ mpfr_set_d(cum, 0., MPFR_RNDZ);/* := 0 */; break; } } for(i=0; i < n; i++) { R_asMPFR(VECTOR_ELT(D, i), R_i); if(is_cum) { /* hence using cum */ mpfr_prec_t i_prec = mpfr_get_prec(R_i); if(current_prec < i_prec) /* increase precision */ { current_prec = i_prec; mpfr_prec_round(cum, i_prec, MPFR_RNDN); } } #define NOT_YET error("Math op. %d not yet implemented", i_op) switch(i_op) { /* Note we assign use R_i as "input and output" ==> *same* precision, even though in some cases the result may need higher precision */ case 0: /* trunc */ mpfr_trunc(R_i, R_i); break; case 1: /* floor */ mpfr_floor(R_i, R_i); break; case 2: /* ceiling*/ mpfr_ceil(R_i, R_i); break; case 3: /* sqrt */ mpfr_sqrt(R_i, R_i, MPFR_RNDN); break; case 4: /* sign */ error("'sign' is dealt with in R. Should not happen, please report"); break; case 10: /* exp */ mpfr_exp(R_i, R_i, MPFR_RNDN); break; case 11: /* expm1 */ mpfr_expm1(R_i, R_i, MPFR_RNDN); break; case 12: /* log1p */ mpfr_log1p(R_i, R_i, MPFR_RNDN); break; case 13: /* log */ mpfr_log (R_i, R_i, MPFR_RNDN); break; case 14: /* log2 */ mpfr_log2 (R_i, R_i, MPFR_RNDN); break; case 15: /* log10 */ mpfr_log10(R_i, R_i, MPFR_RNDN); break; case 20: /* cos */ mpfr_cos (R_i, R_i, MPFR_RNDN); break; case 21: /* sin */ mpfr_sin (R_i, R_i, MPFR_RNDN); break; case 22: /* tan */ mpfr_tan (R_i, R_i, MPFR_RNDN); break; case 23: /* acos */ mpfr_acos (R_i, R_i, MPFR_RNDN); break; case 24: /* asin */ mpfr_asin (R_i, R_i, MPFR_RNDN); break; case 25: /* atan */ mpfr_atan (R_i, R_i, MPFR_RNDN); break; case 30: /* cosh */ mpfr_cosh (R_i, R_i, MPFR_RNDN); break; case 31: /* sinh */ mpfr_sinh (R_i, R_i, MPFR_RNDN); break; case 32: /* tanh */ mpfr_tanh (R_i, R_i, MPFR_RNDN); break; case 33: /* acosh */ mpfr_acosh(R_i, R_i, MPFR_RNDN); break; case 34: /* asinh */ mpfr_asinh(R_i, R_i, MPFR_RNDN); break; case 35: /* atanh */ mpfr_atanh(R_i, R_i, MPFR_RNDN); break; case 40: /* lgamma */ { int sgn[1]; mpfr_lgamma(R_i, sgn, R_i, MPFR_RNDN); break; } case 41: /* gamma */ mpfr_gamma(R_i, R_i, MPFR_RNDN); break; case 42: /* digamma */ #if (MPFR_VERSION < MPFR_VERSION_NUM(3,0,0)) error("digamma() not implemented in oldish MPFR library version '%s'", MPFR_VERSION_STRING); #else mpfr_digamma(R_i, R_i, MPFR_RNDN); break; #endif case 43: /* trigamma */ NOT_YET; break; case 47: /* cospi */ { mpfr_prec_t i_prec = mpfr_get_prec(R_i); mpfr_t tmp; mpfr_init2(tmp, i_prec); mpfr_abs(R_i, R_i, MPFR_RNDN); // R_i := | R_i | mpfr_set_si(tmp, (long) 2, MPFR_RNDN); // tmp := 2 // R_i := R_i mod 2 : mpfr_fmod(R_i, R_i, tmp, MPFR_RNDN); if(mpfr_cmp_d(R_i, 0.5) == 0 || mpfr_cmp_d(R_i, 1.5) == 0) mpfr_set_zero(R_i, +1); else if(mpfr_cmp_si(R_i, (long) 1) == 0) mpfr_set_si(R_i, (long) -1, MPFR_RNDN); else if(mpfr_cmp_si(R_i, (long) 0) == 0) mpfr_set_si(R_i, (long) 1, MPFR_RNDN); else { // otherwise return cos(pi * x): mpfr_const_pi (tmp, MPFR_RNDN); mpfr_mul(R_i, R_i, tmp, MPFR_RNDN); mpfr_cos(R_i, R_i, MPFR_RNDN); } break; } case 48: /* sinpi */ { mpfr_prec_t i_prec = mpfr_get_prec(R_i); mpfr_t tmp; mpfr_init2(tmp, i_prec); mpfr_set_si(tmp, (long) 2, MPFR_RNDN); // tmp := 2 // R_i := R_i mod 2 : mpfr_fmod(R_i, R_i, tmp, MPFR_RNDN); // map (-2,2) --> (-1,1] : if(mpfr_cmp_si(R_i, (long) -1) <= 0) mpfr_add(R_i, R_i, tmp, MPFR_RNDN); else if(mpfr_cmp_si(R_i, (long) 1) > 0) mpfr_sub(R_i, R_i, tmp, MPFR_RNDN); if(mpfr_integer_p(R_i)) // x = 0 or 1 : ==> sin(pi*x) = 0 mpfr_set_zero(R_i, +1); else if(mpfr_cmp_d(R_i, 0.5) == 0) mpfr_set_si(R_i, (long) 1, MPFR_RNDN); else if(mpfr_cmp_d(R_i, -0.5) == 0) mpfr_set_si(R_i, (long) -1, MPFR_RNDN); else { // otherwise return sin(pi * x): mpfr_const_pi (tmp, MPFR_RNDN); mpfr_mul(R_i, R_i, tmp, MPFR_RNDN); mpfr_sin(R_i, R_i, MPFR_RNDN); } break; } case 49: /* tanpi */ { mpfr_prec_t i_prec = mpfr_get_prec(R_i); mpfr_t tmp; mpfr_init2(tmp, i_prec); mpfr_set_si(tmp, (long) 1, MPFR_RNDN); // tmp := 1 // R_i := R_i mod 1 : mpfr_fmod(R_i, R_i, tmp, MPFR_RNDN); // map (-1,1) --> (-1/2, 1/2] : if(mpfr_cmp_d(R_i, (double) -0.5) <= 0) mpfr_add(R_i, R_i, tmp, MPFR_RNDN); else if(mpfr_cmp_d(R_i, (double) 0.5) > 0) mpfr_sub(R_i, R_i, tmp, MPFR_RNDN); if(mpfr_zero_p(R_i)) // x = 0 : ==> tan(pi*x) = 0 mpfr_set_zero(R_i, +1); else if(mpfr_cmp_d(R_i, 0.5) == 0) mpfr_set_si(R_i, (long) 1, MPFR_RNDN); else if(mpfr_cmp_d(R_i, -0.5) == 0) mpfr_set_si(R_i, (long) -1, MPFR_RNDN); else { // otherwise return tan(pi * x): mpfr_const_pi (tmp, MPFR_RNDN); mpfr_mul(R_i, R_i, tmp, MPFR_RNDN); mpfr_tan(R_i, R_i, MPFR_RNDN); } break; } case 71: /* cummax */ mpfr_max(cum, cum, R_i, MPFR_RNDN); break; case 72: /* cummin */ mpfr_min(cum, cum, R_i, MPFR_RNDN); break; case 73: /* cumprod*/ mpfr_mul(cum, cum, R_i, MPFR_RNDN); break; case 74: /* cumsum */ mpfr_add(cum, cum, R_i, MPFR_RNDN); break; /*--- more functions from the mpfr - library but not in R "Math" : ---*/ case 101: mpfr_erf (R_i, R_i, MPFR_RNDN); break; case 102: mpfr_erfc(R_i, R_i, MPFR_RNDN); break; case 104: mpfr_zeta(R_i, R_i, MPFR_RNDN); break; case 106: mpfr_eint(R_i, R_i, MPFR_RNDN); break; case 107: #if (MPFR_VERSION < MPFR_VERSION_NUM(2,4,0)) error("Li2() not implemented in oldish MPFR library version '%s'", MPFR_VERSION_STRING); #else mpfr_li2 (R_i, R_i, MPFR_RNDN); break; #endif case 111: mpfr_j0(R_i, R_i, MPFR_RNDN); break; case 112: mpfr_j1(R_i, R_i, MPFR_RNDN); break; case 113: mpfr_y0(R_i, R_i, MPFR_RNDN); break; case 114: mpfr_y1(R_i, R_i, MPFR_RNDN); break; case 120: #if (MPFR_VERSION < MPFR_VERSION_NUM(3,0,0)) error("Ai() not implemented in oldish MPFR library version '%s'", MPFR_VERSION_STRING); #else mpfr_ai(R_i, R_i, MPFR_RNDN); break; #endif default: error("invalid op code (%d) in Math_mpfr", i_op); } // end{switch()} if(is_cum) SET_VECTOR_ELT(val, i, MPFR_as_R(cum)); else SET_VECTOR_ELT(val, i, MPFR_as_R(R_i)); } mpfr_clear (R_i); if(is_cum) mpfr_clear(cum); mpfr_free_cache(); #ifdef using_Data_slot UNPROTECT(2); #else UNPROTECT(1); #endif return val; } /* Math_mpfr() */ #undef NOT_YET // %% operator -- do what R does: ~/R/D/r-devel/R/src/main/arithmetic.c // ----- --> it uses %% (only sometimes!) and myfmod(); // .... ok, now checked in ../tests/arith-ex.R // ~~~~~~~~~~~~~~~~~~~ // NB: When using R_mpfr_mod(x, x, y) -- i.e., r == x as pointers, thrashes x static int R_mpfr_mod(mpfr_t r, mpfr_t x, mpfr_t y, mpfr_rnd_t RND) { if(mpfr_nan_p(y) || mpfr_nan_p(x)) { mpfr_set_nan(r); return 0; } int s_y = mpfr_sgn(y);// --> {-1, 0, 1} if(s_y == 0) { // y = 0 |-> NaN : mpfr_set_nan(r); return 0; } int s = mpfr_fmod(r, x, y, RND); if((s_y > 0 && mpfr_sgn(r) < 0) || // as R : (-5) %% 3 |--> 1 (s_y < 0 && mpfr_sgn(r) > 0)) // as R : 5 %% (-3) |--> -1 s += mpfr_add(r, r, y, RND); return s; } SEXP Arith_mpfr(SEXP x, SEXP y, SEXP op) { #ifdef using_Data_slot SEXP xD = PROTECT(R_do_slot(x, Rmpfr_Data_Sym)), yD = PROTECT(R_do_slot(y, Rmpfr_Data_Sym)); #else # define xD x # define yD y #endif int nx = length(xD), ny = length(yD), i_op = asInteger(op), i, n = (nx == 0 || ny == 0) ? 0 : imax2(nx, ny), mismatch = 0; SEXP val = PROTECT(allocVector(VECSXP, n)); mpfr_t x_i, y_i; mpfr_init(x_i); /* with default precision */ mpfr_init(y_i); SET_MISMATCH; for(i=0; i < n; i++) { mpfr_prec_t x_prec, y_prec; R_asMPFR(VECTOR_ELT(xD, i % nx), x_i); x_prec = mpfr_get_prec(x_i); R_asMPFR(VECTOR_ELT(yD, i % ny), y_i); y_prec = mpfr_get_prec(y_i); if(x_prec < y_prec) {/* increase it, since it will store the result */ mpfr_prec_round (x_i, y_prec, MPFR_RNDN); x_prec = y_prec; } switch(i_op) { /* Note we assign use x_i as "input and output" ==> *same* precision, even though in some cases the result may need higher precision */ case 1: /* + */ mpfr_add (x_i, x_i, y_i, MPFR_RNDN); break; case 2: /* - */ mpfr_sub (x_i, x_i, y_i, MPFR_RNDN); break; case 3: /* * */ mpfr_mul (x_i, x_i, y_i, MPFR_RNDN); break; case 4: /* ^ */ mpfr_pow (x_i, x_i, y_i, MPFR_RNDN); break; case 5: /* %% */ R_mpfr_mod(x_i, x_i, y_i, MPFR_RNDN); break; case 6: /* %/% */ { mpfr_t r; mpfr_init(r); if(mpfr_get_prec(r) < x_prec) mpfr_set_prec (r, x_prec); // want to ensure x == (x %% y) + y * ( x %/% y ) // <==> x - (x %% y) == y * ( x %/% y ) // <==> [ x - (x %% y) ] / y == ( x %/% y ) R_mpfr_mod(r, x_i, y_i, MPFR_RNDN);// r := x %% y, mpfr_sub (x_i, x_i, r, MPFR_RNDN); // x~ = x - r = x - (x %% y) mpfr_div (x_i, x_i,y_i,MPFR_RNDN); // x = x~ / y = (x - (x %% y))/y mpfr_clear(r); break; } case 7: /* / */ mpfr_div(x_i, x_i, y_i, MPFR_RNDN); break; default: error("invalid op code (%d) in Arith_mpfr", i_op); } SET_VECTOR_ELT(val, i, MPFR_as_R(x_i)); } MISMATCH_WARN; mpfr_clear (x_i); mpfr_clear (y_i); mpfr_free_cache(); #ifdef using_Data_slot UNPROTECT(3); #else UNPROTECT(1); #endif return val; } /* Arith_mpfr */ SEXP Arith_mpfr_i(SEXP x, SEXP y, SEXP op) { #ifdef using_Data_slot SEXP xD = PROTECT(R_do_slot(x, Rmpfr_Data_Sym)); #else # define xD x #endif int *yy = INTEGER(y); int nx = length(xD), ny = length(y), i_op = asInteger(op), i, n = (nx == 0 || ny == 0) ? 0 : imax2(nx, ny), mismatch = 0; if(TYPEOF(y) != INTSXP) error("Arith[%d](mpfr,i): 'y' is not a \"integer\"", i_op); SEXP val = PROTECT(allocVector(VECSXP, n)); mpfr_t x_i; mpfr_init(x_i); /* with default precision */ SET_MISMATCH; for(i=0; i < n; i++) { int i_ = i % ny; R_asMPFR(VECTOR_ELT(xD, i % nx), x_i); switch(i_op) { /* Note we assign use x_i as "input and output" ==> *same* precision, even though in some cases the result may need higher precision */ case 1: /* + */ mpfr_add_si(x_i, x_i, (long) yy[i_], MPFR_RNDN); break; case 2: /* - */ mpfr_sub_si(x_i, x_i, (long) yy[i_], MPFR_RNDN); break; case 3: /* * */ mpfr_mul_si(x_i, x_i, (long) yy[i_], MPFR_RNDN); break; case 4: /* ^ */ mpfr_pow_si(x_i, x_i, (long) yy[i_], MPFR_RNDN); break; case 5: /* %% */ { mpfr_t yy_i; mpfr_init_set_si(yy_i, (long) yy[i_], MPFR_RNDN); R_mpfr_mod(x_i, x_i, yy_i, MPFR_RNDN); mpfr_clear(yy_i); break; } case 6: /* %/% */ { mpfr_t r, yy_i; mpfr_init(r); mpfr_prec_t x_prec = mpfr_get_prec(x_i); if(mpfr_get_prec(r) < x_prec) mpfr_set_prec (r, x_prec); mpfr_init_set_si(yy_i, (long) yy[i_], MPFR_RNDN); R_mpfr_mod(r, x_i, yy_i, MPFR_RNDN); mpfr_sub (x_i, x_i, r, MPFR_RNDN); // x~ = x - r = x - (x %% y) mpfr_div (x_i, x_i,yy_i,MPFR_RNDN); // x = x~ / y = (x - (x %% y))/y mpfr_clear(r); mpfr_clear(yy_i); break; } case 7: /* / */ mpfr_div_si(x_i, x_i, (long) yy[i_], MPFR_RNDN); break; default: error("invalid op code (%d) in Arith_mpfr", i_op); } SET_VECTOR_ELT(val, i, MPFR_as_R(x_i)); } MISMATCH_WARN; mpfr_clear (x_i); mpfr_free_cache(); #ifdef using_Data_slot UNPROTECT(2); #else UNPROTECT(1); #endif return val; } /* Arith_mpfr_i */ SEXP Arith_i_mpfr(SEXP x, SEXP y, SEXP op) { #ifdef using_Data_slot SEXP yD = PROTECT(R_do_slot(y, Rmpfr_Data_Sym)); #else # define yD y #endif int *xx = INTEGER(x); int nx = length(x), ny = length(yD), i_op = asInteger(op), i, n = (nx == 0 || ny == 0) ? 0 : imax2(nx, ny), mismatch = 0; if(TYPEOF(x) != INTSXP) error("Arith[%d](i,mpfr): 'x' is not a \"integer\"", i_op); SEXP val = PROTECT(allocVector(VECSXP, n)); mpfr_t y_i; mpfr_init(y_i); /* with default precision */ SET_MISMATCH; for(i=0; i < n; i++) { int i_ = i % nx; R_asMPFR(VECTOR_ELT(yD, i % ny), y_i); switch(i_op) { /* Note we assign use y_i as "input and output" ==> *same* precision, even though in some cases the result may need higher precision */ case 1: /* + */ mpfr_add_si(y_i, y_i, (long) xx[i_], MPFR_RNDN); break; case 2: /* - */ mpfr_si_sub(y_i, (long) xx[i_], y_i, MPFR_RNDN); break; case 3: /* * */ mpfr_mul_si(y_i, y_i, (long) xx[i_], MPFR_RNDN); break; case 4: /* ^ */ { #define R_MPFR_SI_POW(_XXI, _YI) \ long _x = (long) _XXI; \ if(_x >= 0) \ mpfr_ui_pow(_YI, (unsigned long) _x, _YI, MPFR_RNDN); \ else if(mpfr_integer_p(_YI)) { /* ^ */ \ mpfr_ui_pow(_YI, (unsigned long) -_x, _YI, MPFR_RNDN); \ mpfr_neg(_YI, _YI, MPFR_RNDN); \ } \ else /* ^ |-> NaN : */ \ mpfr_set_nan (_YI); \ break R_MPFR_SI_POW(xx[i_], y_i); } case 5: /* %% */ { mpfr_t xx_i, r; mpfr_init_set_si(xx_i, (long) xx[i_], MPFR_RNDN); mpfr_init(r); R_mpfr_mod(r, xx_i, y_i, MPFR_RNDN); mpfr_set(y_i, r, MPFR_RNDN); mpfr_clear(r); mpfr_clear(xx_i); break; } case 6: /* %/% */ { mpfr_t r, xx_i; mpfr_init(r); mpfr_prec_t y_prec = mpfr_get_prec(y_i); if(mpfr_get_prec(r) < y_prec) mpfr_set_prec (r, y_prec); mpfr_init_set_si(xx_i, (long) xx[i_], MPFR_RNDN); R_mpfr_mod(r, xx_i, y_i, MPFR_RNDN); mpfr_sub (xx_i,xx_i, r, MPFR_RNDN); // x~ = x - r = x - (x %% y) mpfr_div (y_i, xx_i,y_i,MPFR_RNDN); // y = x~ / y = (x - (x %% y))/y mpfr_clear(r); mpfr_clear(xx_i); break; } case 7: /* / */ mpfr_si_div(y_i, (long) xx[i_], y_i, MPFR_RNDN); break; default: error("invalid op code (%d) in Arith_mpfr", i_op); } SET_VECTOR_ELT(val, i, MPFR_as_R(y_i)); } MISMATCH_WARN; mpfr_clear (y_i); mpfr_free_cache(); #ifdef using_Data_slot UNPROTECT(2); #else UNPROTECT(1); #endif return val; } /* Arith_i_mpfr */ SEXP Arith_mpfr_d(SEXP x, SEXP y, SEXP op) { #ifdef using_Data_slot SEXP xD = PROTECT(R_do_slot(x, Rmpfr_Data_Sym)); #else # define xD x #endif double *yy = REAL(y); int nx = length(xD), ny = length(y), i_op = asInteger(op), i, n = (nx == 0 || ny == 0) ? 0 : imax2(nx, ny), mismatch = 0; if(TYPEOF(y) != REALSXP) error("Arith[%d](mpfr,d): 'y' is not a \"double\"", i_op); SEXP val = PROTECT(allocVector(VECSXP, n)); mpfr_t x_i, yy_i; mpfr_init(x_i); mpfr_init(yy_i); /* with default precision */ SET_MISMATCH; for(i=0; i < n; i++) { double yi = yy[i % ny]; /* this fails for yi = 'dOO <- 9223372036854775808', see ../tests/arith-ex.R , * (because in double precision 9223372036854775807 == 9223372036854775808 !!): * int y_is_int = (yi == trunc(yi) && LONG_MIN <= yi && yi <= LONG_MAX); ==> use '<' instead of '<=' twice ! */ int y_is_int = (yi == trunc(yi) && LONG_MIN < yi && yi < LONG_MAX); R_asMPFR(VECTOR_ELT(xD, i % nx), x_i); if(y_is_int) { /* can use o routines */ #ifdef DEBUG_Rmpfr REprintf("yi: %.20g, (long)yi: %ld; yi is int. in [L_MIN, L_MAX]=[%ld,%ld]\n", yi, (long)yi, LONG_MIN, LONG_MAX); #endif switch(i_op) { case 1: /* + */ mpfr_add_si(x_i, x_i, (long)yi, MPFR_RNDN); break; case 2: /* - */ mpfr_sub_si(x_i, x_i, (long)yi, MPFR_RNDN); break; case 3: /* * */ mpfr_mul_si(x_i, x_i, (long)yi, MPFR_RNDN); break; case 4: /* ^ */ mpfr_pow_si(x_i, x_i, (long)yi, MPFR_RNDN); break; case 5: /* %% */ { mpfr_set_si(yy_i, (long)yi, MPFR_RNDN); R_mpfr_mod(x_i, x_i, yy_i, MPFR_RNDN); break; } case 6: /* %/% */ { mpfr_t r; mpfr_init(r); mpfr_prec_t x_prec = mpfr_get_prec(x_i); if(mpfr_get_prec(r) < x_prec) mpfr_set_prec (r, x_prec); mpfr_set_si(yy_i, (long) yi, MPFR_RNDN); R_mpfr_mod(r, x_i, yy_i, MPFR_RNDN); mpfr_sub (x_i, x_i, r, MPFR_RNDN); // x~ = x - r = x - (x %% y) mpfr_div (x_i, x_i, yy_i, MPFR_RNDN); // x = x~ / y = (x - (x %% y))/y mpfr_clear(r); break; } case 7: /* / */ mpfr_div_si(x_i, x_i, (long)yi, MPFR_RNDN); break; default: error("invalid op code (%d) in Arith_mpfr_d", i_op); } } else { mpfr_set_d (yy_i, yi, MPFR_RNDD); switch(i_op) { /* Note we assign use x_i as "input and output" ==> *same* precision, even though in some cases the result may need higher precision */ case 1: /* + */ mpfr_add(x_i, x_i, yy_i, MPFR_RNDN); break; case 2: /* - */ mpfr_sub(x_i, x_i, yy_i, MPFR_RNDN); break; case 3: /* * */ mpfr_mul(x_i, x_i, yy_i, MPFR_RNDN); break; case 4: /* ^ */ mpfr_pow(x_i, x_i, yy_i, MPFR_RNDN); break; case 5: /* %% */ R_mpfr_mod(x_i, x_i, yy_i, MPFR_RNDN); break; case 6: /* %/% */ { mpfr_t r; mpfr_init(r); mpfr_prec_t x_prec = mpfr_get_prec(x_i); if(mpfr_get_prec(r) < x_prec) mpfr_set_prec (r, x_prec); R_mpfr_mod(r, x_i, yy_i, MPFR_RNDN); mpfr_sub (x_i, x_i, r, MPFR_RNDN); // x~ = x - r = x - (x %% y) mpfr_div (x_i, x_i, yy_i, MPFR_RNDN); // x = x~ / y = (x - (x %% y))/y mpfr_clear(r); break; } case 7: /* / */ mpfr_div(x_i, x_i, yy_i, MPFR_RNDN); break; default: error("invalid op code (%d) in Arith_mpfr_d", i_op); } } SET_VECTOR_ELT(val, i, MPFR_as_R(x_i)); } MISMATCH_WARN; mpfr_clear (x_i); mpfr_clear (yy_i); mpfr_free_cache(); #ifdef using_Data_slot UNPROTECT(2); #else UNPROTECT(1); #endif return val; } /* Arith_mpfr_d */ SEXP Arith_d_mpfr(SEXP x, SEXP y, SEXP op) { #ifdef using_Data_slot SEXP yD = PROTECT(R_do_slot(y, Rmpfr_Data_Sym)); #else # define yD y #endif double *xx = REAL(x); int nx = length(x), ny = length(yD), i_op = asInteger(op), i, n = (nx == 0 || ny == 0) ? 0 : imax2(nx, ny), mismatch = 0; if(TYPEOF(x) != REALSXP) error("Arith[%d](d,mpfr): 'x' is not a \"double\"", i_op); SEXP val = PROTECT(allocVector(VECSXP, n)); mpfr_t y_i; mpfr_init(y_i); SET_MISMATCH; for(i=0; i < n; i++) { double xi = xx[i % nx]; int x_is_int = (xi == trunc(xi) && LONG_MIN <= xi && xi <= LONG_MAX); R_asMPFR(VECTOR_ELT(yD, i % ny), y_i); if(x_is_int) { /* can use o routines */ /* REprintf("x[i] (= %g) is int: (long)* = %ld\n", xi, (long)xi); */ switch(i_op) { case 1: /* + */ mpfr_add_si(y_i, y_i, (long)xi, MPFR_RNDN); break; case 2: /* - */ mpfr_si_sub(y_i, (long)xi, y_i, MPFR_RNDN); break; case 3: /* * */ mpfr_mul_si(y_i, y_i, (long)xi, MPFR_RNDN); break; case 4: /* ^ */ { R_MPFR_SI_POW((long)xi, y_i); } case 5: /* %% */ { mpfr_t xx_i, r; mpfr_init_set_si(xx_i, (long)xi, MPFR_RNDN); mpfr_init(r); R_mpfr_mod(r, xx_i, y_i, MPFR_RNDN); mpfr_set(y_i, r, MPFR_RNDN); mpfr_clear(r); mpfr_clear(xx_i); break; } case 6: /* %/% */ { mpfr_t r, xx_i; mpfr_init(r); mpfr_prec_t y_prec = mpfr_get_prec(y_i); if(mpfr_get_prec(r) < y_prec) mpfr_set_prec (r, y_prec); mpfr_init_set_si(xx_i, (long) xi, MPFR_RNDN); R_mpfr_mod(r, xx_i, y_i, MPFR_RNDN); mpfr_sub (xx_i,xx_i, r, MPFR_RNDN); // x~ = x - r = x - (x %% y) mpfr_div (y_i, xx_i, y_i, MPFR_RNDN); // y = x~ / y = (x - (x %% y))/y mpfr_clear(r); mpfr_clear(xx_i); break; } case 7: /* / */ mpfr_si_div(y_i, (long)xi, y_i, MPFR_RNDN); break; default: error("invalid op code (%d) in Arith_d_mpfr", i_op); } } else { mpfr_t xx_i; mpfr_init_set_d (xx_i, xi, MPFR_RNDD); switch(i_op) { /* Note we assign use y_i as "input and output" ==> *same* precision, even though in some cases the result may need higher precision */ case 1: /* + */ mpfr_add(y_i, xx_i, y_i, MPFR_RNDN); break; case 2: /* - */ mpfr_sub(y_i, xx_i, y_i, MPFR_RNDN); break; case 3: /* * */ mpfr_mul(y_i, xx_i, y_i, MPFR_RNDN); break; case 4: /* ^ */ mpfr_pow(y_i, xx_i, y_i, MPFR_RNDN); break; case 5: /* %% */ { mpfr_t r; mpfr_init(r); R_mpfr_mod(r, xx_i, y_i, MPFR_RNDN); mpfr_set(y_i, r, MPFR_RNDN); mpfr_clear(r); break; } case 6: /* %/% */ { mpfr_t r; mpfr_init(r); mpfr_prec_t y_prec = mpfr_get_prec(y_i); if(mpfr_get_prec(r) < y_prec) mpfr_set_prec (r, y_prec); R_mpfr_mod(r, xx_i, y_i, MPFR_RNDN); mpfr_sub (xx_i,xx_i, r, MPFR_RNDN); // x~ = x - r = x - (x %% y) mpfr_div (y_i, xx_i, y_i, MPFR_RNDN); // y = x~ / y = (x - (x %% y))/y mpfr_clear(r); break; } case 7: /* / */ mpfr_div(y_i, xx_i, y_i, MPFR_RNDN); break; default: error("invalid op code (%d) in Arith_d_mpfr", i_op); } mpfr_clear(xx_i); } SET_VECTOR_ELT(val, i, MPFR_as_R(y_i)); } MISMATCH_WARN; mpfr_clear (y_i); mpfr_free_cache(); #ifdef using_Data_slot UNPROTECT(2); #else UNPROTECT(1); #endif return val; } /* Arith_d_mpfr */ SEXP Compare_mpfr(SEXP x, SEXP y, SEXP op) { #ifdef using_Data_slot SEXP xD = PROTECT(R_do_slot(x, Rmpfr_Data_Sym)), yD = PROTECT(R_do_slot(y, Rmpfr_Data_Sym)); #else # define xD x # define yD y #endif int nx = length(xD), ny = length(yD), i_op = asInteger(op), i, n = (nx == 0 || ny == 0) ? 0 : imax2(nx, ny), mismatch = 0; SEXP val = PROTECT(allocVector(LGLSXP, n)); int *r = LOGICAL(val); mpfr_t x_i, y_i; mpfr_init(x_i); /* with default precision */ mpfr_init(y_i); /* with default precision */ SET_MISMATCH; for(i=0; i < n; i++) { R_asMPFR(VECTOR_ELT(xD, i % nx), x_i); R_asMPFR(VECTOR_ELT(yD, i % ny), y_i); if(mpfr_nan_p(x_i) || mpfr_nan_p(y_i)) { r[i] = NA_LOGICAL; } else { switch(i_op) { case 1: /* == */ r[i] = mpfr_equal_p(x_i, y_i); break; case 2: /* > */ r[i] = mpfr_greater_p(x_i, y_i); break; case 3: /* < */ r[i] = mpfr_less_p(x_i, y_i); break; case 4: /* != */ r[i] = mpfr_lessgreater_p(x_i, y_i); break; case 5: /* <= */ r[i] = mpfr_lessequal_p(x_i, y_i); break; case 6: /* >= */ r[i] = mpfr_greaterequal_p(x_i, y_i); break; default: error("invalid op code (%d) in Compare_mpfr", i_op); } } } MISMATCH_WARN; mpfr_clear (x_i); mpfr_clear (y_i); mpfr_free_cache(); #ifdef using_Data_slot UNPROTECT(3); #else UNPROTECT(1); #endif return val; } /* Compare_mpfr */ SEXP Compare_mpfr_i(SEXP x, SEXP y, SEXP op) { #ifdef using_Data_slot SEXP xD = PROTECT(R_do_slot(x, Rmpfr_Data_Sym)); #else # define xD x #endif int *yy = INTEGER(y); int nx = length(xD), ny = length(y), i_op = asInteger(op), i, n = (nx == 0 || ny == 0) ? 0 : imax2(nx, ny), mismatch = 0; SEXP val = PROTECT(allocVector(LGLSXP, n)); int *r = LOGICAL(val); mpfr_t x_i; mpfr_init(x_i); SET_MISMATCH; for(i=0; i < n; i++) { int yi = yy[i % ny], c; R_asMPFR(VECTOR_ELT(xD, i % nx), x_i); c = mpfr_cmp_si(x_i, (long) yi);/* gives c > or == or < 0 */ if(c == 0 && /* also includes case where an operand is NaN */ (yi == NA_INTEGER || mpfr_nan_p(x_i))) { r[i] = NA_LOGICAL; } else { switch(i_op) { case 1: /* == */ r[i] = (c == 0); break; case 2: /* > */ r[i] = (c > 0); break; case 3: /* < */ r[i] = (c < 0); break; case 4: /* != */ r[i] = (c != 0); break; case 5: /* <= */ r[i] = (c <= 0); break; case 6: /* >= */ r[i] = (c >= 0); break; default: error("invalid op code (%d) in Compare_mpfr_i", i_op); } } } MISMATCH_WARN; mpfr_clear (x_i); mpfr_free_cache(); #ifdef using_Data_slot UNPROTECT(2); #else UNPROTECT(1); #endif return val; } /* Compare_mpfr_i */ SEXP Compare_mpfr_d(SEXP x, SEXP y, SEXP op) { #ifdef using_Data_slot SEXP xD = PROTECT(R_do_slot(x, Rmpfr_Data_Sym)); #else # define xD x #endif double *yy = REAL(y); int nx = length(xD), ny = length(y), i_op = asInteger(op), i, n = (nx == 0 || ny == 0) ? 0 : imax2(nx, ny), mismatch = 0; SEXP val = PROTECT(allocVector(LGLSXP, n)); int *r = LOGICAL(val); mpfr_t x_i; mpfr_init(x_i); SET_MISMATCH; for(i=0; i < n; i++) { double yi = yy[i % ny]; int c; R_asMPFR(VECTOR_ELT(xD, i % nx), x_i); c = mpfr_cmp_d(x_i, yi);/* gives c > or == or < 0 */ if(c == 0 && /* also includes case where an operand is NaN */ (ISNAN(yi) || mpfr_nan_p(x_i))) { r[i] = NA_LOGICAL; } else { switch(i_op) { case 1: /* == */ r[i] = (c == 0); break; case 2: /* > */ r[i] = (c > 0); break; case 3: /* < */ r[i] = (c < 0); break; case 4: /* != */ r[i] = (c != 0); break; case 5: /* <= */ r[i] = (c <= 0); break; case 6: /* >= */ r[i] = (c >= 0); break; default: error("invalid op code (%d) in Compare_mpfr_d", i_op); } } } MISMATCH_WARN; mpfr_clear (x_i); mpfr_free_cache(); #ifdef using_Data_slot UNPROTECT(2); #else UNPROTECT(1); #endif return val; } /* Compare_mpfr_d */ #ifdef __NOT_ANY_MORE__ /* Not really used anymore : */ #define INIT_1_SETUP(_X_, _R_) \ mpfr_t _R_; \ \ mpfr_init2(_R_, R_mpfr_prec(_X_)); \ R_asMPFR(_X_, _R_) #define FINISH_1_RETURN(_R_, val) \ val = PROTECT(MPFR_as_R(_R_)); \ mpfr_clear (_R_); \ mpfr_free_cache(); \ UNPROTECT(1); \ return val SEXP exp_mpfr1(SEXP x) { SEXP val; INIT_1_SETUP(x, r); mpfr_exp(r, r, MPFR_RNDN); /* - - ((result may need higher precision)) .. */ FINISH_1_RETURN(r, val); } SEXP log_mpfr1(SEXP x) { SEXP val; INIT_1_SETUP(x, r); mpfr_log(r, r, MPFR_RNDN); FINISH_1_RETURN(r, val); } /* Unused */ #define INIT_2_SETUP(_X_, _R_, _S_) \ mpfr_t _R_, _S_; \ \ mpfr_init2(_R_, R_mpfr_prec(_X_)); \ /* _S_ should get same precision as _R_ :*/ \ mpfr_init2(_S_, mpfr_get_prec(_R_)); \ R_asMPFR(_X_, _R_) #define FINISH_2_RETURN(_R_, _S_, val) \ val = PROTECT(MPFR_as_R(_R_)); \ mpfr_clear(_R_); mpfr_clear(_S_); \ mpfr_free_cache(); \ UNPROTECT(1); \ return val #endif /* __NOT_ANY_MORE__ */ Rmpfr/src/Summary.c0000644000176200001440000002020114457744436013745 0ustar liggesusers/* * MPFR - Multiple Precision Floating-Point Reliable Library * ---- - - - - * * Arithmetic, Math, etc */ #include #include "Rmpfr_utils.h" extern #include "Syms.h" /*------------------------------------------------------------------------*/ SEXP Summary_mpfr(SEXP x, SEXP na_rm, SEXP op) { enum { MAX = 1, MIN, RANGE, PROD, SUM, ANY = 10, ALL } i_op = asInteger(op); /* MUST be sync'ed with ../R/Summary.R * ~~~~~~~~~~~~~~ where .Summary.codes <- * c("max" = 1, "min" = 2, "range" = 3, "prod" = 4, "sum" = 5, * "any" = 10, "all" = 11) */ mpfr_prec_t current_prec = mpfr_get_default_prec(); int n = length(x), return_list = (i_op < ANY), // return "mpfr1" list; any() | all() return logical remove_na = asLogical(na_rm); SEXP val = R_NilValue; int ans = -1; /*"-Wall"; result only for any() | all() */ mpfr_t R_i, Summ, Sum2; /* for range(), max(), min(), sum(), prod() */ mpfr_init(R_i); /* with default precision; set prec in R_asMPFR() */ if (return_list) mpfr_init(Summ); #define Rmpfr_set(_N_) val = PROTECT(allocVector(VECSXP, _N_)); break switch(i_op) { case MAX: mpfr_set_inf(Summ, -1);/* := -Inf */; Rmpfr_set(1); case MIN: mpfr_set_inf(Summ, +1);/* := +Inf */; Rmpfr_set(1); case RANGE: mpfr_init(Sum2); mpfr_set_inf(Summ, +1);/* := +Inf for min() */ mpfr_set_inf(Sum2, -1);/* := -Inf for max() */ Rmpfr_set(2); case PROD: mpfr_set_d (Summ, 1., MPFR_RNDZ); Rmpfr_set(1); case SUM: mpfr_set_d (Summ, 0., MPFR_RNDZ); Rmpfr_set(1); case ANY: ans = FALSE; break; case ALL: ans = TRUE; break; default: error("invalid op code (%d) in Summary_mpfr", i_op); } Rboolean Fini = FALSE; for(int i=0; i < n && !Fini; i++) { SEXP xi = VECTOR_ELT(x, i); R_asMPFR(xi, R_i); if(mpfr_nan_p(R_i)) { /* handling does not depend on i_op */ /* REprintf("Summary_mpfr(), i=%d : R_i is NA/NaN\n", i); */ if(remove_na) /* skip this NA / NAN entry: */ continue; else { /* result is NA */ /* should not be needed: R_i *is* NaN already : mpfr_set_nan(R_i); */ switch(i_op) { case MAX: case MIN: case PROD: case SUM: SET_VECTOR_ELT(val, 0, xi); break; case RANGE: SET_VECTOR_ELT(val, 0, xi); SET_VECTOR_ELT(val, 1, xi); break; /*---------------------------------------------*/ case ANY: if(ans == FALSE) ans = NA_LOGICAL; break; case ALL: if(ans == TRUE) ans = NA_LOGICAL; break; } } if(return_list) { /* return() *unless* for any()/all() : */ mpfr_free_cache(); UNPROTECT(1); return val; } else continue; /* next i; */ } if(return_list) { /* hence using Summ */ mpfr_prec_t i_prec = mpfr_get_prec(R_i); if(current_prec < i_prec) /* increase precision */ { current_prec = i_prec; mpfr_prec_round(Summ, i_prec, MPFR_RNDN); if(i_op == RANGE) mpfr_prec_round(Sum2, i_prec, MPFR_RNDN); } } switch(i_op) { /* Note we assign use R_i as "input and output" ==> *same* precision, even though in some cases the result may need higher precision */ case MAX: mpfr_max(Summ, Summ, R_i, MPFR_RNDN); break; case MIN: mpfr_min(Summ, Summ, R_i, MPFR_RNDN); break; case RANGE: mpfr_min(Summ, Summ, R_i, MPFR_RNDN); mpfr_max(Sum2, Sum2, R_i, MPFR_RNDN); break; case PROD: mpfr_mul(Summ, Summ, R_i, MPFR_RNDN); break; case SUM: mpfr_add(Summ, Summ, R_i, MPFR_RNDN); break; case ANY: if(!mpfr_zero_p(R_i)) { ans = TRUE ; Fini=TRUE; }; break; case ALL: if( mpfr_zero_p(R_i)) { ans = FALSE; Fini=TRUE; }; break; } } /* for(i .. n) */ #if 0 if(!return_list) /* any() or all() */ REprintf("Summary_mpfr(), at end: ans = %s\n", ans == NA_LOGICAL ? "NA" : (ans ? "TRUE" : "FALSE")); #endif mpfr_clear (R_i); switch(i_op) { case MAX: case MIN: case PROD: case SUM: SET_VECTOR_ELT(val, 0, MPFR_as_R(Summ)); mpfr_clear (Summ); break; case RANGE: SET_VECTOR_ELT(val, 0, MPFR_as_R(Summ)); SET_VECTOR_ELT(val, 1, MPFR_as_R(Sum2)); mpfr_clear (Summ); mpfr_clear (Sum2); break; case ANY: case ALL: /* nothing to be done */ break; } mpfr_free_cache(); if(!return_list) /* any() or all() */ return ScalarLogical(ans); // else UNPROTECT(1); return val; } /* Summary_mpfr() */ /** Compute sum(x * y) == x %*% y for two [mpfr-]vectors of the same length Both x and y can be in {mpfr, double, integer} ! */ SEXP R_mpfr_sumprod(SEXP x, SEXP y, SEXP minPrec, SEXP alternating_) { int n = length(x); if(length(y) != n) error("%d == length(x) != length(y) == %d", n, length(y)); int i_min_prec = asInteger(minPrec), nprot = 1; Rboolean alternating = asLogical(alternating_); // Simplification (FIXME: more efficient -> use 6 cases; s/ M_n / M_d and M_i /) if(isInteger(x)) { PROTECT(x = coerceVector(x, REALSXP)); nprot++; } if(isInteger(y)) { PROTECT(y = coerceVector(y, REALSXP)); nprot++; } if(isReal(x) && isReal(y)) error("R_mpfr_sumprod(x,y, .): either x or y must be \"mpfr\", but both are numeric"); // --> three cases: // M_M: both mpfr, // n_M: x numeric, y mpfr // M_n: x mpfr , y numeric enum { M_M, n_M, M_n } R_case = isReal(x) ? n_M : isReal(y) ? M_n : M_M; Rboolean use_r = alternating && R_case == M_M; mpfr_t Summ, x_i, y_i, r; mpfr_inits(Summ, x_i, y_i, (mpfr_ptr) 0); /* with default precision */ mpfr_set_d(Summ, 0., MPFR_RNDZ); double *xx = NULL, *yy = NULL; if(R_case == n_M) xx = REAL(x); else if(R_case == M_n) yy = REAL(y); mpfr_prec_t min_prec = MPFR_PREC_MIN, xy_prec, S_prec = mpfr_get_prec(Summ); if(i_min_prec != NA_INTEGER && min_prec < i_min_prec) min_prec = (mpfr_prec_t) i_min_prec; if(S_prec < min_prec) { mpfr_prec_round (Summ, min_prec, MPFR_RNDN); S_prec = min_prec; } if(use_r) mpfr_init2(r, S_prec); for(int i=0; i < n; i++) { double xi = 0., yi = 0.; // Wall #define IF_NA_set_and_continue(_NA_COND_) \ if(_NA_COND_) { \ mpfr_set_nan(Summ); \ continue;/* -> "next i" */ \ } switch(R_case) { case M_M : R_asMPFR(VECTOR_ELT(x, i), x_i); R_asMPFR(VECTOR_ELT(y, i), y_i); IF_NA_set_and_continue(mpfr_nan_p(x_i) || mpfr_nan_p(y_i)); xy_prec = max2_prec(mpfr_get_prec(x_i), mpfr_get_prec(y_i)); break; case M_n : R_asMPFR(VECTOR_ELT(x, i), x_i); yi = yy[i]; IF_NA_set_and_continue(mpfr_nan_p(x_i) || ISNA(yi)); xy_prec = max2_prec(mpfr_get_prec(x_i), 53); break; case n_M : xi = xx[i]; R_asMPFR(VECTOR_ELT(y, i), y_i); IF_NA_set_and_continue(ISNA(xi) || mpfr_nan_p(y_i)); xy_prec = max2_prec(53, mpfr_get_prec(y_i)); break; } // switch() if(S_prec < xy_prec) {/* increase it, since it will store the result */ mpfr_prec_round (Summ, xy_prec, MPFR_RNDN); S_prec = xy_prec; if(use_r) mpfr_set_prec(r, S_prec); } if(alternating && (i % 2)) { // Summ := Summ - (x_i * y_i) switch(R_case) { case M_M : /* mpfr_fms (ROP, OP1, OP2, OP3, RND) * Set ROP to (OP1 times OP2) - OP3 rounded in the direction RND. */ mpfr_fms (r, x_i, y_i, Summ, MPFR_RNDN); // r = x_i * y_i - Summ mpfr_neg (Summ, r, MPFR_RNDN); break; case M_n : mpfr_mul_d(x_i, x_i, yi, MPFR_RNDN); mpfr_sub(Summ, Summ, x_i,MPFR_RNDN); break; case n_M : mpfr_mul_d(y_i, y_i, xi, MPFR_RNDN); mpfr_sub(Summ, Summ, y_i,MPFR_RNDN); break; } } else { // Summ := Summ + (x_i * y_i) switch(R_case) { case M_M : /* mpfr_fma (ROP, OP1, OP2, OP3, RND) * Set ROP to (OP1 times OP2) + OP3 rounded in the direction RND. */ mpfr_fma (Summ, x_i, y_i, Summ, MPFR_RNDN); break; case M_n : mpfr_mul_d(x_i, x_i, yi, MPFR_RNDN); mpfr_add(Summ, Summ, x_i,MPFR_RNDN); break; case n_M : mpfr_mul_d(y_i, y_i, xi, MPFR_RNDN); mpfr_add(Summ, Summ, y_i,MPFR_RNDN); break; } } } // for( i ) // val <- list( Summ ) : SEXP val = PROTECT(allocVector(VECSXP, 1)); SET_VECTOR_ELT(val, 0, MPFR_as_R(Summ)); mpfr_clears(Summ, x_i, y_i, (mpfr_ptr) 0); if(use_r) mpfr_clear(r); mpfr_free_cache(); UNPROTECT(nprot); return val; } // R_mpfr_sumprod Rmpfr/src/Rmpfr_utils.h0000644000176200001440000001370415075433454014625 0ustar liggesusers#ifndef R_MPFR_MUTILS_H #define R_MPFR_MUTILS_H /* #ifdef __cplusplus */ /* extern "C" { */ /* #endif */ #include #include /* for va_list ..*/ #include /* includes Rconfig.h */ #include #include #include /* must come *after* the above, e.g., for mpfr_out_str() (which needs stdio): */ #include #include #ifdef ENABLE_NLS #include #define _(String) dgettext ("Rmpfr", String) #else #define _(String) (String) #endif #ifdef HAVE_CONFIG_H # include "config.h" #endif #if (MPFR_VERSION < MPFR_VERSION_NUM(3,0,0)) /* define back-compatibility types:*/ # define MPFR_RNDD GMP_RNDD # define MPFR_RNDN GMP_RNDN # define MPFR_RNDU GMP_RNDU # define MPFR_RNDZ GMP_RNDZ // # define MPFR_RNDA GMP_RNDA # define mpfr_exp_t mp_exp_t #endif static R_INLINE mpfr_prec_t max2_prec(mpfr_prec_t x, mpfr_prec_t y) { return (mpfr_prec_t) (x >= y) ? x : y; } /*----------------------------------------*/ #ifdef _in_Rmpfr_init_ /* global */ int R_mpfr_debug_ = 0; #else extern int R_mpfr_debug_; #endif /* A version of Rprintf() .. but only printing when R_mpfr_debug_ is large enough :*/ static R_INLINE void R_mpfr_dbg_printf(int dbg_level, const char *format, ...) { if(R_mpfr_debug_ && R_mpfr_debug_ >= dbg_level) { va_list(ap); Rprintf(".mpfr_debug[%d]: ", R_mpfr_debug_); va_start(ap, format); REvprintf(format, ap); va_end(ap); } } static R_INLINE void R_mpfr_dbg_printf_0(int dbg_level, const char *format, ...) { if(R_mpfr_debug_ && R_mpfr_debug_ >= dbg_level) { va_list(ap); va_start(ap, format); REvprintf(format, ap); va_end(ap); } } /* This is from Matrix/src/Mutils.h : */ static R_INLINE SEXP ALLOC_SLOT(SEXP obj, SEXP nm, SEXPTYPE type, int length) { SEXP val = allocVector(type, length); R_do_slot_assign(obj, nm, val); return val; } #define N_LIMBS(_PREC_) (int)ceil(((double)_PREC_)/mp_bits_per_limb) static R_INLINE int R_mpfr_nr_limbs(mpfr_t r) { return N_LIMBS(mpfr_get_prec(r)); } // Note: "in theory" we could set precBits > INT_MAX, but currently not in Rmpfr: static R_INLINE void R_mpfr_check_prec(int prec) { if(prec == NA_INTEGER) error("Precision(bit) is NA (probably from coercion)"); if(prec < MPFR_PREC_MIN) error("Precision(bit) = %d < %ld (= MPFR_PREC_MIN)", prec, (long)MPFR_PREC_MIN); /* 2018-01-01 gives a WARNING with clang: Found the following significant warnings: ./Rmpfr_utils.h:89:13: warning: comparison of constant 9223372036854775807 with expression of type 'int' is always false [-Wtautological-constant-out-of-range-compare] ... of course, I don't want a WARN in the CRAN checks, hence disable (for now): if(prec > MPFR_PREC_MAX) error("Precision(bit) = %d > %ld (= MPFR_PREC_MAX)", prec, (long)MPFR_PREC_MAX); */ return; } #define R_mpfr_prec(x) INTEGER(R_do_slot(x, Rmpfr_precSym))[0] #define MISMATCH_WARN \ if (mismatch) \ warning(_("longer object length is not a multiple of shorter object length")) #define SET_MISMATCH \ if (nx == ny || nx == 1 || ny == 1) mismatch = 0; \ else if (nx > 0 && ny > 0) { \ if (nx > ny) mismatch = nx % ny; \ else mismatch = ny % nx; \ } /* ./convert.c : */ mpfr_rnd_t R_rnd2MP(SEXP rnd_mode); SEXP d2mpfr1 (SEXP x, SEXP prec, SEXP rnd_mode); SEXP d2mpfr1_(double x, int i_prec, mpfr_rnd_t rnd); SEXP d2mpfr1_list(SEXP x, SEXP prec, SEXP rnd_mode); SEXP mpfr2d(SEXP x, SEXP rnd_mode); SEXP mpfr2i(SEXP x, SEXP rnd_mode); SEXP mpfr2str(SEXP x, SEXP digits, SEXP maybe_full, SEXP base); SEXP str2mpfr1_list(SEXP x, SEXP prec, SEXP base, SEXP rnd_mode); SEXP R_mpfr_formatinfo(SEXP x); #ifdef R_had_R_Outputfile_in_API # ifndef WIN32 SEXP print_mpfr (SEXP x, SEXP digits); SEXP print_mpfr1(SEXP x, SEXP digits); # endif #endif SEXP Rmpfr_minus(SEXP x); SEXP Rmpfr_abs(SEXP x); SEXP Math_mpfr(SEXP x, SEXP op); SEXP Arith_mpfr(SEXP x, SEXP y, SEXP op); SEXP Arith_mpfr_i(SEXP x, SEXP y, SEXP op); SEXP Arith_i_mpfr(SEXP x, SEXP y, SEXP op); SEXP Arith_mpfr_d(SEXP x, SEXP y, SEXP op); SEXP Arith_d_mpfr(SEXP x, SEXP y, SEXP op); SEXP Compare_mpfr(SEXP x, SEXP y, SEXP op); SEXP Compare_mpfr_i(SEXP x, SEXP y, SEXP op); SEXP Compare_mpfr_d(SEXP x, SEXP y, SEXP op); SEXP Summary_mpfr(SEXP x, SEXP na_rm, SEXP op); SEXP R_mpfr_sumprod(SEXP x, SEXP y, SEXP minPrec, SEXP alternating); #ifdef __NOT_ANY_MORE__ /* deprecated: */ SEXP exp_mpfr1(SEXP x); SEXP log_mpfr1(SEXP x); #endif void R_asMPFR(SEXP x, mpfr_ptr r); SEXP MPFR_as_R(mpfr_t r); /* ./utils.c */ SEXP R_mpfr_set_debug(SEXP I); SEXP R_mpfr_set_default_prec(SEXP prec); SEXP R_mpfr_get_default_prec(void); int mpfr_erange_int_p(void); SEXP R_mpfr_erange_int_p(void); SEXP R_mpfr_get_erange(SEXP kind); SEXP R_mpfr_set_erange(SEXP kind, SEXP val); SEXP R_mpfr_prec_range(SEXP ind); SEXP R_mpfr_get_version(void); SEXP R_mpfr_get_sizeof(void); SEXP R_mpfr_get_GMP_numb_bits(void); SEXP R_mpfr_2exp(SEXP x); SEXP R_mpfr_ldexp(SEXP f, SEXP E, SEXP rnd_mode); SEXP R_mpfr_frexp(SEXP x, SEXP rnd_mode); SEXP const_asMpfr(SEXP I, SEXP prec, SEXP rnd_mode); SEXP R_mpfr_is_finite(SEXP x); SEXP R_mpfr_is_finite_A(SEXP x); SEXP R_mpfr_is_infinite(SEXP x);SEXP R_mpfr_is_infinite_A(SEXP x); SEXP R_mpfr_is_integer(SEXP x); SEXP R_mpfr_is_integer_A(SEXP x); SEXP R_mpfr_is_na(SEXP x); SEXP R_mpfr_is_na_A(SEXP x); SEXP R_mpfr_is_zero(SEXP x); SEXP R_mpfr_is_zero_A(SEXP x); SEXP R_mpfr_atan2(SEXP x, SEXP y, SEXP rnd_mode); SEXP R_mpfr_hypot(SEXP x, SEXP y, SEXP rnd_mode); SEXP R_mpfr_beta (SEXP x, SEXP y, SEXP rnd_mode); SEXP R_mpfr_lbeta(SEXP x, SEXP y, SEXP rnd_mode); SEXP R_mpfr_igamma(SEXP a, SEXP x, SEXP rnd_mode); SEXP R_mpfr_jn(SEXP x, SEXP n, SEXP rnd_mode); SEXP R_mpfr_yn(SEXP x, SEXP n, SEXP rnd_mode); SEXP R_mpfr_fac (SEXP n, SEXP prec, SEXP rnd_mode); SEXP R_mpfr_choose(SEXP a, SEXP n, SEXP rnd_mode); SEXP R_mpfr_poch (SEXP a, SEXP n, SEXP rnd_mode); SEXP R_mpfr_round (SEXP x, SEXP prec, SEXP rnd_mode); /* #ifdef __cplusplus */ /* } */ /* #endif */ #endif /* R_MPFR_MUTILS_H_ */ Rmpfr/src/init.c0000644000176200001440000001114015075433454013245 0ustar liggesusers/* Setup here "copied" from Matrix package */ #include #define _in_Rmpfr_init_ #include "Rmpfr_utils.h" #include "Syms.h" #undef _in_Rmpfr_init_ #define CALLDEF(name, n) {#name, (DL_FUNC) &name, n} static R_CallMethodDef CallEntries[] = { CALLDEF(d2mpfr1, 3), CALLDEF(d2mpfr1_list, 3), #ifdef Have_interface_Rmpfr_gmp CALLDEF(mpz2mpfr1, 3), CALLDEF(mpz2mpfr1_list, 3), #endif #ifdef R_had_R_Outputfile_in_API #ifndef WIN32 /* only works on "unix-alikes" */ CALLDEF(print_mpfr, 2), CALLDEF(print_mpfr1, 2), #endif #endif CALLDEF(mpfr2d, 2), CALLDEF(mpfr2i, 2), CALLDEF(mpfr2str, 4), CALLDEF(R_mpfr_formatinfo, 1), CALLDEF(R_mpfr_2exp, 1), CALLDEF(R_mpfr_frexp, 2), CALLDEF(R_mpfr_ldexp, 3), CALLDEF(str2mpfr1_list, 4), CALLDEF(Rmpfr_minus, 1), CALLDEF(Rmpfr_abs, 1), CALLDEF(Math_mpfr, 2), CALLDEF(Arith_mpfr, 3), CALLDEF(Arith_mpfr_i, 3), CALLDEF(Arith_i_mpfr, 3), CALLDEF(Arith_mpfr_d, 3), CALLDEF(Arith_d_mpfr, 3), CALLDEF(Compare_mpfr, 3), CALLDEF(Compare_mpfr_i, 3), CALLDEF(Compare_mpfr_d, 3), CALLDEF(Summary_mpfr, 3), CALLDEF(R_mpfr_sumprod, 4), CALLDEF(R_mpfr_set_debug, 1), CALLDEF(R_mpfr_set_default_prec, 1), CALLDEF(R_mpfr_get_default_prec, 0), CALLDEF(R_mpfr_prec_range, 1), CALLDEF(R_mpfr_get_erange, 1), CALLDEF(R_mpfr_set_erange, 2), CALLDEF(R_mpfr_erange_int_p, 0), CALLDEF(R_mpfr_get_version, 0), CALLDEF(R_mpfr_get_sizeof, 0), CALLDEF(R_mpfr_get_GMP_numb_bits, 0), CALLDEF(const_asMpfr, 3), CALLDEF(R_mpfr_is_finite, 1), CALLDEF(R_mpfr_is_finite_A, 1), CALLDEF(R_mpfr_is_infinite, 1), CALLDEF(R_mpfr_is_infinite_A, 1), CALLDEF(R_mpfr_is_integer, 1), CALLDEF(R_mpfr_is_integer_A, 1), CALLDEF(R_mpfr_is_na, 1), CALLDEF(R_mpfr_is_na_A, 1), CALLDEF(R_mpfr_is_zero, 1), CALLDEF(R_mpfr_is_zero_A, 1), CALLDEF(R_mpfr_atan2, 3), CALLDEF(R_mpfr_igamma, 3), CALLDEF(R_mpfr_hypot, 3), CALLDEF(R_mpfr_beta, 3), CALLDEF(R_mpfr_lbeta, 3), CALLDEF(R_mpfr_jn, 3), CALLDEF(R_mpfr_yn, 3), CALLDEF(R_mpfr_fac, 3), CALLDEF(R_mpfr_choose, 3), CALLDEF(R_mpfr_poch, 3), CALLDEF(R_mpfr_round, 3), {NULL, NULL, 0} }; void #ifdef HAVE_VISIBILITY_ATTRIBUTE __attribute__ ((visibility ("default"))) #endif R_init_Rmpfr(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); #define RREGDEF(name) R_RegisterCCallable("Rmpfr", #name, (DL_FUNC) name) RREGDEF(d2mpfr1); RREGDEF(d2mpfr1_list); #ifdef Have_interface_Rmpfr_gmp RREGDEF(mpz2mpfr1); RREGDEF(mpz2mpfr1_list); #endif #ifdef R_had_R_Outputfile_in_API #ifndef WIN32 RREGDEF(print_mpfr); RREGDEF(print_mpfr1); #endif #endif RREGDEF(mpfr2d); RREGDEF(mpfr2i); RREGDEF(mpfr2str); RREGDEF(str2mpfr1_list); RREGDEF(Rmpfr_minus); RREGDEF(Rmpfr_abs); RREGDEF(Math_mpfr); RREGDEF(Arith_mpfr); RREGDEF(Arith_mpfr_i); RREGDEF(Arith_i_mpfr); RREGDEF(Arith_mpfr_d); RREGDEF(Arith_d_mpfr); RREGDEF(Compare_mpfr); RREGDEF(Compare_mpfr_i); RREGDEF(Compare_mpfr_d); RREGDEF(Summary_mpfr); RREGDEF(R_mpfr_sumprod); RREGDEF(R_mpfr_set_debug); RREGDEF(R_mpfr_set_default_prec); RREGDEF(R_mpfr_get_default_prec); RREGDEF(R_mpfr_get_version); RREGDEF(R_mpfr_get_GMP_numb_bits); RREGDEF(const_asMpfr); RREGDEF(R_mpfr_is_finite); RREGDEF(R_mpfr_is_finite_A); RREGDEF(R_mpfr_is_infinite); RREGDEF(R_mpfr_is_infinite_A); RREGDEF(R_mpfr_is_integer); RREGDEF(R_mpfr_is_integer_A); RREGDEF(R_mpfr_is_na); RREGDEF(R_mpfr_is_na_A); RREGDEF(R_mpfr_is_zero); RREGDEF(R_mpfr_is_zero_A); RREGDEF(R_mpfr_jn); RREGDEF(R_mpfr_yn); RREGDEF(R_mpfr_atan2); RREGDEF(R_mpfr_hypot); RREGDEF(R_mpfr_igamma); RREGDEF(R_mpfr_beta); RREGDEF(R_mpfr_lbeta); RREGDEF(R_mpfr_fac); RREGDEF(R_mpfr_choose); RREGDEF(R_mpfr_poch); RREGDEF(R_mpfr_round); /* Sync this with declarations in ./Syms.h : */ Rmpfr_precSym = install("prec"); Rmpfr_signSym = install("sign"); Rmpfr_expSym = install("exp"); Rmpfr_d_Sym = install("d"); Rmpfr_Data_Sym = install(".Data"); Rmpfr_Dim_Sym = install("Dim"); Rmpfr_Dimnames_Sym = install("Dimnames"); /* not suppressable, hence moved to suppressable R startup code: Rprintf("Loading C code of R package 'Rmpfr': GMP using %d bits per limb\n", GMP_NUMB_BITS); */ /* if(GMP_NUMB_BITS != 32) */ /* error("The Rmpfr package currently needs 32-bit limbs"); */ } /* void R_unload_Rmpfr(DllInfo *dll) */ /* { */ /* } */ Rmpfr/src/Makevars.in0000644000176200001440000000142515075433454014244 0ustar liggesusers# -*- Makefile -*- # Link with GMP (GNU Multiple Precision) # and with MPFR (Multiple Precision Floating point Reliable) Libraries # was # PKG_LIBS = -lmpfr -lgmp # # To find things in non-default location, when the user uses something like # R CMD INSTALL --configure-args="--with-mpfr-lib=/*/mpfr-3.1.5/lib --with-mpfr-include=/*/mpfr-3.1.5/include" # then CPPFLAGS and PKG_LDFLAGS should be set from ../configure # PKG_CPPFLAGS=$(CPPFLAGS) #-- "Regularly" -- PKG_CPPFLAGS = @MPFR_CPPFLAGS@ @DEFS@ PKG_LIBS = @MPFR_LDFLAGS@ -lmpfr -lgmp #--MM-- "Works to get newest" (for me via PKG_CONFIG_PATH & sym.link in /usr/local.nfs/app/pkgconfig) # PKG_CFLAGS = `pkg-config --cflags mpfr` # PKG_LIBS = `pkg-config --libs mpfr` # PKG_LDFLAGS = `pkg-config --libs-only-L mpfr` $(LDFLAGS) Rmpfr/src/Syms.h0000644000176200001440000000026112443134043013230 0ustar liggesusersSEXP // keep in sync with ./init.c Rmpfr_precSym, Rmpfr_signSym, Rmpfr_expSym, Rmpfr_d_Sym, Rmpfr_Data_Sym, Rmpfr_Dim_Sym, Rmpfr_Dimnames_Sym ; Rmpfr/ChangeLog0000644000176200001440000004407513742567662013146 0ustar liggesusers2015-04-29 Martin Maechler * inst/NEWS.Rd: new; this 'ChangeLog' should not be used anymore 2015-02-28 Martin Maechler * R/array.R (matrix.mpfr): new S3 method for 'matrix(, ...)', mostly to help confused users. * R/special-fun.R (pnorm, j0, ...): do *NOT* use as(x, "mpfr") when 'x' is an "mpfrMatrix" / "mpfrArray" (-> uses dim(), etc!) 2015-02-16 Martin Maechler * R/array.R (norm): new matrix norm()'s of "all kinds" 2014-12-13 Martin Maechler * DESCRIPTION (Version): 0.6-0 * is.finite(M), is.na(M) now keep dim() for "mpfrArray" inputs. 2014-11-27 Martin Maechler * DESCRIPTION (Version): 0.5-7, released to CRAN, 2014-11-27, r205 * R/as.R (as.integer): fix bug, ensuring that "Z" rounding is used 2014-09-05 Martin Maechler * R/as.R (mpfrImport, mpfrXport): new utilities, somewhat experimental 2014-06-23 Martin Maechler * R/integrate-Romberg.R (integrateR): when 'ord' is specified and one of 'rel.tol' or 'abs.tol', convergence is checked, and if achieved, computations stop earlier. When 'ord' is NULL (default), and '*.tol' is specified, continue until convergence (or memory explosion). The default (none of these specified) is to try convergence up to 'ord = 13'. * DESCRIPTION (Version): 0.5-6, released to CRAN, 2014-09-05, r203 * R/as.R (mpfr): also allow rounding mode "A" (= "Away from zero") * R/array.R (mpfrArray): as that is supported from MPFR 3.0.0 on * R/array.R (toNum): new optional argument 'rnd.mode' * man/mpfr.Rd: doku and mini check * src/convert.c (R_rnd2MP): allow "A" as well * src/convert.c (mpfr2d, mpfr2i): extra argument rnd_mode. NOTA BENE: "D" rounding previously, but new default is "N". Consequently, asNumeric(x) etc give 'Inf' instead of 1.797693e+308. * R/gmp-convert.R (..bigz2mpfr,...): add 'rnd.mode' argument 2014-06-19 Martin Maechler * DESCRIPTION (Version): 0.5-5 released to CRAN, 2014-06-19, r190 * R/integrate-Romberg.R (print.integrateR): own print method: print _value_ even when warning. 2014-05-19 Martin Maechler * vignettes/log1mexp-note.Rnw: update to log1pexp(); cosmetics 2014-05-01 Martin Maechler * R/special-fun.R: pbetaI(a,b) for larger (a,b); new mpfr versions of * man/distr-etc.Rd: dbinom(), dpois(), dnorm() * R/mpfr.R (mpfr_default_prec, .mpfr.minPrec, .mpfr.erange, ..): * src/utils.c (R_mpfr_get_default_prec, ...): new functions to get, check, (and partly working) set default exponent ranges and precision. 2014-01-01 Martin Maechler * src/Ops.c (Math_mpfr): new sinpi(), cospi() for R >= 3.1.0 2013-10-21 Martin Maechler * DESCRIPTION (Version): 0.5-4, released to CRAN, 2013-10-22, r173 Now again depends on 'methods' (instead of just importing). 2013-05-04 Martin Maechler * R/mpfr.R (.mat2ind): from a proposal by Serguei Sokol, new utility, to be used for matrix subsetting and replacement, in .mpfr.subset() and .mpfr.repl(). __FIXME__ add checking code! 2013-02-28 Martin Maechler * R/Math.R (sumBinomMpfr): oops: docu had (-1)^k instead of (-1)^(n-k); alternating=FALSE has been wrong, since (r101, 2012-05-15) 2013-02-14 Martin Maechler * R/gmp-convert.R (..bigq2mpfr): precB = NULL --> at least 128 2013-02-05 Martin Maechler * DESCRIPTION (Version): 0.5-2 * R/as.R (asNumeric): new function; mainly for 'mpfrArray' * src/Ops.c (R_mpfr_mod): for Arith_mpfr[_i|_d]), R's %% and %/%: now working correctly, checked in * tests/arith-ex.R: * R/array.R (mkDet, determinant): provide recursive method for determinant() and hence det(). *Only* for small matrices !! * src/Summary.c (R_mpfr_sumprod): new for sum(x * y) == x %*% y -> 20-40% faster matrix multiplication {still not fast!}. 2012-12-03 Martin Maechler * DESCRIPTION (Version): 0.5-1, released to CRAN 2012-12-03 * man/Rmpfr-package.Rd: a nice overview help page * inst/doc/log1mexp-note.Rnw: cosmetic changes {would be ready to submit now}. 2012-06-16 Martin Maechler * DESCRIPTION (Version): 0.5-0, released to CRAN on 2012-07-07 * R/as.R (mpfr): or arguments now "work" (with a warning). * R/gmp-convert.R (.bigz2mpfr, .bigq2mpfr): new optional argument \code{precB}, typically for increasing the default precision. 2012-06-04 Martin Maechler * R/optimizers.R (optimizeR): new simple golden ratio, thanks to Hans Werner Borchers. 2012-05-22 Martin Maechler * DESCRIPTION (Version, Depends): 0.4-8, released to CRAN on 2012-05-23 * R/mpfr.R (diff.mpfr): new method; as diff.default() commits unclass(x) (str.mpfr): new. 2012-05-04 Martin Maechler * R/as.R (formatN.mpfr): add method * NAMESPACE: import S3 generic 'formatN' from gmp. 2012-05-01 Martin Maechler * NAMESPACE: import S3 generic 'is.whole' from gmp( >= 0.5-2) now. * man/is.whole.Rd: only mpfr method. 2012-04-30 Martin Maechler * DESCRIPTION (Version, Depends): 0.4-7; depend on new gmp; can get rid of if() tests. * R/gmp-convert.R (.bigq2mpfr): new. 2012-02-06 Martin Maechler * DESCRIPTION (Version): 0.4-6, released to CRAN on 2012-02-06; (Depends): gmp, not just "suggest", so we have a well-defined search() path order: Rmpfr comes before gmp. * R/special-fun.R (pnorm): much improved partly bad code, thanks to a report from Jerry Lewis. 2012-01-14 Martin Maechler * src/utils.c (my_mpfr_choose, my_mpfr_poch): fix case n == 0. * R/mpfr.R, R/array.R: add argument 'right = TRUE' to the print() * man/mpfr-utils.Rd: methods which looks better, e.g., for integers. * src/utils.c (R_MPFR_2_Numeric_Function) (R_MPFR_2_Num_Long_Function): do *not* warn anymore when arguments are of "non-matching" lengths. * R/Math.R (chooseMpfr.all): new arguments 'k0', 'alternating' and 'precBits'. 2011-12-27 Martin Maechler * DESCRIPTION (Version): 0.4-5 * src/convert.c (mpfr2str): dig_n_max was off 2011-11-28 Martin Maechler * DESCRIPTION (Version): 0.4-4, released to CRAN on 2011-11-30 * src/Ops.c (Compare_mpfr, etc): fix (silly!) nx * ny integer overflow; problem reported by Anton Korobeynikov. * R/unirootR.R: produce warning when convergence happen to "pole". 2011-09-08 Martin Maechler * DESCRIPTION (Version): 0.4-3, released to CRAN on 2011-09-09 * R/array.R (applyMpfr): -> apply() method for "mfprArray" (mpfr2array): fix for the case of dim() <- (colSums, etc): also add simple methods for colSums, rowMeans, etc. * man/mpfrArray.Rd: add apply() examples 2011-08-23 Martin Maechler * R/unirootR.R (unirootR): R-only version of uniroot(), carefully ensuring * man/unirootR.Rd: that as.numeric(.) is used only in some cases; thanks to John Nash's very recent R code in his 'rootoned' package. 2011-08-11 Martin Maechler * R/Arith.R: add "Logic" methods (mpfr, numeric), avoiding inf.recursion. * tests/arith-ex.R: now checks that. 2011-08-09 Martin Maechler * DESCRIPTION (Version): 0.4-2, now with a * NAMESPACE: 2011-07-30 Martin Maechler * src/Ops.c (Rmpfr_minus, Rmpfr_abs): new C versions, called in * R/Arith.R * R/Math.R 2011-07-29 Martin Maechler * R/array.R (mpfr2array): speedup, not using new(cl, ...) for check=FALSE (= new default). 2011-07-21 Martin Maechler * R/mpfr.R ([[): finished adding a '[[' method which returns one "mpfr" number (instead of a "mpfr1" one). Needed a bit of changes, notably in .getPrec() etc. 2011-05-12 Martin Maechler * DESCRIPTION (Version): 0.3-0 -- "finished" integrateR(); using vapply() 2011-04-30 Martin Maechler * R/special-fun.R (Bernoulli): B(0) = 1 now also works. 2011-03-09 Martin Maechler * R/integrate-Romberg.R (integrateR): new pure Rfunction for Romberg integration; works with "mpfr". * man/integrateR.Rd: docu & examples. 2011-01-18 Martin Maechler * R/Math.R (roundMpfr): "round" to precBits (bits!) also to *increase* precision for further computation. * src/utils.c (my_mpfr_round): C implementation. * R/Math.R (factorialMpfr, pochMpfr): new functions, e.g., as tools for choose(). * src/utils.c (my_mpfr_poch, R_mpfr_fac): underlying C code. 2011-01-17 Martin Maechler * R/as.R (formatMpfr): fix the case where 'Ex == digits' 2011-01-16 Martin Maechler * src/Ops.c (Math_mpfr): enable digamma() for mpfr 3.0.0 and later (Math_mpfr): implement cummax(), cummin(), cumprod(), cumsum() * src/Ops.c, R/special-fun.R: enable Airy function ai() 2011-01-15 Martin Maechler * R/mpfr.R (.getPrec): return default precision instead of NULL for 0-length input; this enables [FALSE] <- 1. * R/array.R (mpfr2array): new utility as alternative to 'dim(.) <- *' * R/as.R (mpfr): now also works with matrix or array input, returning "mpfrArray"/"..Matrix". 2011-01-10 Martin Maechler * DESCRIPTION (Version): 0.2-4 * R/Math.R (factorial): improve integer test (thanks to Petr Savicky). 2010-01-22 Martin Maechler * DESCRIPTION (Version): 0.2-3 * src/convert.c (R_rnd2GMP): new; allow to specify "rounding mode" from R. For now, for conversion to MPFR. Change default to use (round to) [N]earest rather than [D]ownwards. 2010-01-21 Martin Maechler * DESCRIPTION (Version): 0.2-2 * R/as.R (formatMpfr): add 'showNeg0' argument, and fix printing of zeros. * R/mpfr.R ([): ensure out-of-range indexing returns valid "mpfr". * tests/create.R: test the above. 2010-01-20 Martin Maechler * R/mpfr.R (.getPrec, getPrec): previous getPrec() renamed to .getPrec(); the new getPrec() also works for simple R "numbers", and is used in mpfr(), and the following : * R/mpfr.R ([<-): for non-"mpfr" value, use at least the previous precision, following a chat with Petr Savicky. * src/convert.c (d2mpfr1_list): ensure x is recycled when prec is longer than x. (str2mpfr1_list): ditto. 2010-01-18 Martin Maechler * DESCRIPTION (Version): 0.2-1 * R/array.R (.matmult.R): "obvious" speed up, replacing the innermost for() loop by a sum(); inspired by a patch from Petr. *However* the real speedup would use a .Call(..) directly! 2010-01-16 Martin Maechler * R/mpfr.R (.mpfr.repl, [<-): change such that x[] <- 1 works; also z[i] <- v when i is larger than length(z). * tests/create.R: test the above. 2010-01-15 Martin Maechler * R/array.R (.matmult.R): tcrossprod changes along to the bug fix in R (!). * DESCRIPTION (Version): 0.2-0 2010-01-14 Martin Maechler * R/array.R ([<-): define for more signatures (%*%, crossprod, tcrossprod): extend signatures to include more pairs, and using "Mnumber" instead of just "array_or_vector". * tests/matrix-ex.R: test part of that * man/*-class.Rd: additions, notably as.vector() and as(, "vector"). 2010-01-13 Martin Maechler * DESCRIPTION (Version): 0.1-8 * R/Math.R (.mpfr.sign): fix to ensure sign(0) |-> 0. Reported by Petr Savicky. * tests/arith-ex.R: test it. * src/init.c, src/convert.c (d2mpfr): outcomment unused function 2009-10-31 Martin Maechler * R/array.R: add "mpfrArray" -> "matrix" coercion * R/Arith.R (Arith): fix length check in ("mpfr", "array") * R/Consts.R (Const): nicer error message when 'name' is invalid. 2009-10-29 Martin Maechler * R/special-fun.R (beta, lbeta): new methods added * src/utils.c (my_mpfr_beta, my_mpfr_lbeta): own C functions, calling mpfr_*() ones, for beta() and lbeta(). * tests/special-fun-ex.R (B,lB): add tests for beta(), lbeta() 2009-09-14 Martin Maechler * src/Makevars.win: -lmpfr *before* -lgmp (does matter some places) 2009-09-10 Martin Maechler * R/mpfr.R (mpfrVersion): factor out .mpfrVersion() 2009-09-07 Martin Maechler * DESCRIPTION (Version): 0.1-7; released to CRAN * R/mpfr.R (mpfrVersion): amend for funny version string on Debian testings. * R/mpfr.R (mpfrVersion): new utility * src/utils.c (R_mpfr_get_version): C level * man/utils.Rd: doc * src/Ops.c (Math_mpfr): older MPFR libraries do not provide Li2(). 2009-09-03 Martin Maechler * R/Math.R (factorial): method which rounds in integer case. * man/mpfr-class.Rd: docu and examples. * man/is.whole.Rd: new for new is.whole() 2009-09-02 Martin Maechler * R/special-fun.R (Li2): add Li2() * man/mpfr-class.Rd: explicitly "enumerate" the 'Math' and 'Summary' group functions. 2009-09-01 Martin Maechler * DESCRIPTION (Version): 0.1-6, CRAN-released on 2009-09-04 * R/Math.R (Math2, i.e., round, signif): allow missing digits { => default digits = 0 or 6, respectively}. * R/mpfr.R (print, etc): use drop0trailing = TRUE per default. * R/as.R (formatMpfr): renamed from .format.mpfr; finalize using prettyNum(), add corresponding arguments and document: * man/formatMpfr.Rd: new * src/convert.c (mpfr2str): allocate the char 'ch' ourselves, carefully using R_alloc() and S_realloc(); unfortunately, the MPFR allocator *still* messes with our SEXPs. 2009-08-31 Martin Maechler * R/mpfr.R (seqMpfr): seqMpfr(3,1) works (again?) 2009-08-16 Martin Maechler * src/convert.c (mpfr2str): be over-PROTECT()ive, as Kurt reports VECTOR_ELT() errors on some platforms, and I can "randomly systematically" reproduce them with gctorture(). 2009-08-06 Martin Maechler * DESCRIPTION (Version): 0.1-5 -- release-ready * man/seqMpfr.Rd, ...: add all missing *Rd pages. * R/mpfr.R (seqMpfr): remove FIXME, using new pmin(), pmax(). * R/Math.R (Math2): group methods - for round() and signif() * src/convert.c (mpfr2i): new, for as(. "integer") 2009-08-05 Martin Maechler * R/mpfr.R (pmin, pmax): now seem to work * R/as.R (mpfr): as(, "mpfr") now uses mpfr() (mpfr): now also works for 'raw' and 'logical'; adding as(*,.) methods ==> x[.] <- NA should work * R/array.R (cbind, rbind): correct behavior when length/dims do not quite match. * R/array.R (dim<-): make work for NULL. * tests/matrix-ex.R: test these. * src/convert.c (d2mpfr, etc): PROTECT(.) all coerceVector()s. 2009-04-30 Martin Maechler * man/mpfr-class.Rd: mention sort(),.., duplicated(), ... 2009-04-13 Martin Maechler * src/convert.c (d2mpfr1_list, str2mpfr1_list): allow 'prec' to be a vector. * R/as.R (mpfr): now support mpfr(, prec) * src/convert.c (str2mpfr1_list): implement character |-> mpfr * src/utils.c (R_mpfr_set_default_prec, *_get_*): * R/array.R (cbind, rbind): also work when there are "character" * R/AllClasses.R (array_or_vector): only contain 'atomicVector' 2009-03-31 Martin Maechler * src/Makevars.win: add this after suggestions from Uwe 2009-02-06 Martin Maechler * R/Arith.R (Compare): add missing ', .Generic' to some methods. * tests/matrix-ex.R: testing 'A >= 3' etc 2009-02-02 Martin Maechler * R/array.R (cbind, rbind): new "..." methods for cbind(), rbind(), * R/AllClasses.R: using new "Mnumber" class * man/bind-methods.Rd: docu 2009-01-31 Martin Maechler * R/array.R (aperm): method. * R/AllClasses.R: 'Dimnames', not 'DimNames' * R/Arith.R: use .Arith.mpfr.num() macros etc, and make sure, these are used also in the o cases. * tests/matrix-ex.R: test array / mpfr 2009-01-27 Martin Maechler * R/array.R (.mpfrA.subset): if A[...] has length(dim(.))== 2, ensure it becomes an "mpfrMatrix" 2009-01-24 Martin Maechler * R/array.R (mpfrArray): make more (user friendly) like array() ([<-): render working also for A[i,j,k] <- val. (.mpfrA.subset): make A[,,1] working (.mA.subAssign): separate auxiliary function for more than 1 method 2009-01-22 Martin Maechler * src/Ops.c (Math_mpfr): activate (trunc,floor,ceiling) * tests/arith-ex.R: and test them minimally 2009-01-12 Martin Maechler * DESCRIPTION (Version): 0.1-1 -- another "snapshot" * R/array.R (t . mpfr): --> [ 1 x n ] - matrix * R/Arith.R (.dimCheck): add o methods, further o ones, etc. * tests/matrix-ex.R: testing them 2008-12-31 Martin Maechler * R/Math.R: slightly re-write methods so they automagically work for mpfrArray. * R/array.R (.matmult.R): %*%, crossprod(), tcrossprod(), t(), .. * tests/matrix-ex.R: new 2008-12-29 Martin Maechler * R/AllClasses.R: add "mpfrArray" and "mpfrMatrix" classes. * R/array.R (dim<-): from "mpfr" to "mpfrArray/Matrix" 2008-12-16 Martin Maechler * DESCRIPTION (Version): 0.1-0 -- "snapshot", not released. Rmpfr/NAMESPACE0000644000176200001440000001621515075433454012576 0ustar liggesusersuseDynLib(Rmpfr, .registration=TRUE) ##-- From 'gmp' (on which we 'Depend' ------------------------------------------ ## The user can and typically should just use mpfr() or mpfr() export(.mpfr2bigz, .bigz2mpfr, .bigq2mpfr, .mpfr2bigq, # new in Jan. 2024 ## e.g., for use in gmp :: Math.bigz & Math.bigq : ..bigz2mpfr, ..bigq2mpfr) ## Import all we need, but not more importMethodsFrom("methods" ## as we define methods for them: , coerce, "coerce<-", show , Arith, Compare, Logic, Math, Math2, Ops, Summary ) importFrom("methods", as, "as<-", callGeneric, callNextMethod, is, extends, new, validObject, setClass, setClassUnion, setMethod, setOldClass, setValidity, slot, "slot<-", .slotNames, getDataPart, setDataPart, getClass, getClassDef, signature, representation, prototype ## needed implicitly [or "bug" ..]: , loadMethod) importFrom("utils", str) importFrom("stats" # import *and* rename -- we extend these : , stats__pnorm = pnorm , stats__qnorm = qnorm , stats__dnorm = dnorm , stats__dpois = dpois , stats__dbinom = dbinom , stats__dgamma = dgamma , stats__dnbinom = dnbinom , stats__dt = dt , stats__pgamma = pgamma ) importClassesFrom("gmp", "bigz", "bigq") importFrom("gmp" , asNumeric, as.bigz, as.bigq, .as.char.bigz, ..as.bigz , apply # , apply.default # *.default: else apply() breaks in pkg SNscan , crossprod, tcrossprod# <- as we write (S4) methods for those (*not* '%*%' !) , matrix, numerator, denominator, frexpZ, chooseZ , is.whole, formatN # because we add own S3 methods ) if(packageVersion("gmp") >= "0.5.8") importFrom("gmp", is.matrixZQ, #-> R/gmp-convert.R which.min, which.max)# the generics if(packageVersion("gmp") >= "0.6-1") importFrom("gmp", c_bigz, c_bigq)# for sapply() like usage ##------------------------------------------------------------------------------ exportClasses("mpfr1", "mpfr" , "mpfrArray" , "mpfrMatrix" , "summaryMpfr" # mainly for printing , "atomicVector" , "array_or_vector" , "Mnumber" ## new, *not* containing "matrix" (which has -> "character"!): , "numericVector" , "mNumber" ) ## Standard (base, stats) functions which we made into S4 generics export(mean, median, quantile) export(.mpfr, .mpfr. ## ".Arith.codes" ## , ".Arith.mpfr.num" ## , ".Arith.num.mpfr" ## , ".Compare.codes" ## , ".Compare.codesRev" ## , ".Compare.mpfr.num" ## , ".Compare.num.mpfr" ## , ".Math.codes" ## , ".Math.gen" ## , ".Summary.codes" ## , ".abs.mpfr" ## , ".dimCheck" , .getPrec , .getSign , .mpfr_erange, .mpfr_erange_set, .mpfr_erange_kinds, .mpfr_erange_is_int , .mpfr_maxPrec, .mpfr_minPrec ## , ".mA.subAssign" ## , ".matmult.R" ## , ".mpfr_debug" , ".mpfr_negative" ## , ".mpfr_negativeR" ## , ".mpfr_repl" , ".mpfr_sign" ## , ".mpfr_subset" , ".mpfr2str" , .mpfr2d, .mpfr2i , .mpfr_formatinfo , .mpfr2exp ## , ".mpfrA.subset" , .mpfrVersion, .mpfr_gmp_numbbits , .mpfrSizeof , .mpfr2list, mpfrImport, mpfrXport # <- experimental: for a possible save format ## , ".packageName" ## , ".print.mpfr" ## , ".requireCachedGenerics" , "Ai" , "Bernoulli" , "Const" , "Ei" , "Li2" , "all.equal" , "aperm" , "apply" ## <- we make it S4 generic , "atan2" , "beta", "lbeta" ## S3 "c.mpfr" , "chooseMpfr", "chooseMpfr.all", "sumBinomMpfr" , "dbinom", "dpois", "dnorm", "dgamma" , dchisq , "dnbinom" , dt , "erf", "erfc" , "factorial" , "factorialMpfr" , "format" , formatMpfr, formatBin, formatDec, formatHex , frexpMpfr, ldexpMpfr , "getD" , "getPrec" , "hypot" , igamma # working iff MPFR version >= 3.2.0 >>> R/special-fun.R <<< , "integrateR" , is.mpfr , "j0" , "j1" , "jn" , log1mexp, log1pexp , matmult , "mpfr" , mpfrIs0, .mpfr.is.whole # as substitutes of , "mpfr.is.0", "mpfr.is.integer" # <-- now (Aug. 2015) deprecated , "mpfr2array", "mpfrArray" , "mpfrVersion" , "mpfr_default_prec" , num2bigq # our "fractions", new Jan.2024 , "optimizeR" , outer # <- our own instead of base, so it uses tcrossprod() methods , "hjkMpfr" ## <-- FIXME, rather part of an optimR(...., method = "hjk") , "pbetaI" , pgamma , "pmax", "pmin" , "pnorm" , qnormI , "pochMpfr" , "roundMpfr" , sapplyMpfr , "seqMpfr" , "t" , "toNum" , "unique" , "unirootR" , "y0", "y1", "yn" , "zeta" ) exportMethods(##___ "own generics" ___ "apply" # <- we made it into S4 generic (with "ANY" method = S3 generic from gmp!) , "asNumeric" ##___ "other generics" ___ ## Group Methods , Arith, Compare, Logic, Math, Math2, Ops, Summary , "abs", "log", "sign" , "Re", "Im", "Mod", "Arg", "Conj" , "all.equal", "aperm" , "as.vector", "as.integer", "as.numeric" , "coerce", "coerce<-" , "cbind", "rbind" , "diag", "diag<-" , "dim", "dim<-", "dimnames", "dimnames<-" , "atan2", "beta", "lbeta" , "factorial" , "is.finite", "is.infinite", "is.na", "is.nan" , "%*%", "crossprod", "tcrossprod", "t" , "format" , "mean", "pmax", "pmin" , "show", "unique" , "colSums", "colMeans" , "rowSums", "rowMeans", "norm" , summary , head, tail , "which.min", "which.max" ) ## Our own S3 generic mpfr(): S3method(mpfr, default) S3method(mpfr, bigz) S3method(mpfr, bigq) S3method(mpfr, mpfr) S3method(mpfr, NULL) S3method(mpfr, Ncharacter) ## needed because gmp "forgets" to S3method() these: ## (and so things only work, when gmp / Rmpfr is attached): ## S3method(apply, default) ## S3method(apply, bigz) ## S3method(apply, bigq) S3method(c, mpfr) S3method(as.array, mpfr) S3method(as.matrix, mpfr) ## Would break the working of vapply(, FUN) e.g. in pbetaI(): ## S3method(as.list, mpfr1) ## S3method(as.list, mpfr) S3method(determinant, mpfrMatrix) S3method(scale, mpfrMatrix) S3method(diff, mpfr) S3method(str, mpfr) S3method(is.whole, mpfr) #S3method(is.whole, mpfrArray) S3method(formatN, mpfr) S3method(print, mpfr) S3method(print, mpfr1) S3method(print, mpfrArray) S3method(print, integrateR) S3method(print, Ncharacter) S3method(print, summaryMpfr) S3method("[", Ncharacter) S3method(as.data.frame, Ncharacter) ## not easily ## S3method("cbind", Ncharacter) ## S3method("rbind", Ncharacter) S3method(matrix, mpfr) ## useful, to have base::outer() work automatically: S3method(rep, mpfr) S3method(t, mpfr) S3method(t, mpfrMatrix) S3method(aperm, mpfrArray) ## trying to get base::factor() to work: S3method(unique, mpfr) Rmpfr/TODO0000644000176200001440000003300115057547524012043 0ustar liggesusers -*- org -*--> Emacs [Tab] key + [Org] menu; C-c C-o follows links * Very Short Term ** TODO 61) Q: Why is quantile() so slow [hence summary() very slow!]? A: because sort() |--> rank() is so slow (in C code!) l2x <- seqMpfr(mpfr(4, 1024), 513, by=1/16) # 8000 numbers of 1024 bits system.time(ql2x <- quantile(l2x, names=FALSE)) # user: 10.735 (nb-mm5, Nov.2020); 1.62 (v-lynne; Sep.2025) *** quantile() -> sort(*, partial=.) -> xtfrm.default() -> rank(l2x) is so slow *** Partial SOLUTION (not yet implemented): use is.unsorted(.) which is *fast* FALSE for sorted vetors (as 'l2x' above) ** TODO 55b) possibly more documentation on .mpfr* functions, e.g. .getSign(), at least *internally* (roxygen) ** TODO 31) Valgrind problems + leaks: Brian's e-mail 2014-06-19; ~/R/Pkgs/Rmpfr.Rcheck_valgrind/ ** TODO 11) format() method for "mpfr", "mpfrArray" (and hence "mpfrMatrix") which nicely and correctly *jointly* formats (for "mpfr") and aligns columns ! Then, formatDec() would be unnecessary. drop0trailing is not really sensible there. ** TODO 19) outer() now works always ? {as rep() now S3 dispatches ---> need systematic checks *AND* docu changes! ** TODO 17b) see 'Ops' in R/Arith.R , Rmpfr:::.Math.codes, and design a "test all Ops" with all combinations of "mpfr", "numeric","logical" (and possibly more). * Short Term ** TODO add trigamma() where MPFR is new enough: *** [MPFR] new function: trigamma -- 02 Dec 2024 17:09:18 *** To: mpfr@inria.fr / Reply-To: Paul Zimmermann * Short or Mid Term *** TODO Split this section into Short | Mid (?) ** TODO 66) Improve pnorm(*, log.p=TRUE) using Abramowitz asymptotic formulas ==> 1st need Rmpfr'ified DPQ:pnormAsymp() Abramowitz and Stegun (1972), p.932, (26.2.12) and (26.2.13) see also ~/R/Pkgs/DPQ/vignettes/qnorm-asymp.Rnw *** TODO 66a) "mpfrify" pnormAsymp() and qnormAsymp() but in pkg {DPQmpfr} !! ** TODO 60) Should have *exact* as.bigq.mpfr(), i.e, "mpfr" --> "bigq". (R's "bigq" is C 'mpq') ** TODO 62) integrateR(): option 'all.sums=TRUE' --> R/integrate-Romberg.R *** Inside the GMP library, have # -- Function: void mpq_set_f (mpq_t ROP, const mpf_t OP) # Set ROP to the value of OP. There is no rounding, this conversion is exact. *** MPFR documents 'mpf2mpfr.h' after which you can compile any mpf_ program.. ** TODO 53) plogis() {and dlogis, qlogis} are "easy": do use /src/nmath/[dpq]logis.c, as they already use all the numerical tricks including R_Log1_Exp(x) .. : R_Log1_Exp(x) := ((x) > -M_LN2 ? log(-expm1(x)) : log1p(-exp(x))) ** TODO 54) zapsmall() would be nice, base::zapsmall() fails ** TODO 35) tests/bit-repr.R : Bits() fails to work with 2^k ** TODO 37) mpfrXport()/*Import() should work for arrays. Test Windows-portability: - as save() seems not portable; see ~/R/MM/Pkg-ex/Rmpfr/save-load-ex.R ** TODO 2) Now have working "mpfrMatrix", dim(.) <- ..; t(), %*%, crossprod()... - %*% should work the same as with numeric vectors - %*% t() ditto Note that matrix multiplication seems too slow --> ./Savicky-matrix-mult_tst.R - [i] & [i] work but [i,j] not yet --> want things to work like which( == ., arr.ind = TRUE) - ok [No longer sure if this is true :] For this, we must ensure that the methods are used, instead of the .Primitive base functions : One way: --> see ~/R/MM/NUMERICS/bessel-large-x.R -------------------------------- ## really interesting is bI(x., nu) {for "mpfr" argument}: ## it uses outer(), but that needs to dispatch on, e.g. "^", ## i.e., not only look at "base" environment(outer) <- as.environment("package:Rmpfr") environment(dim) <- as.environment("package:Rmpfr") environment(dimnames) <- as.environment("package:Rmpfr") environment(`dim<-`) <- as.environment("package:Rmpfr") environment(`dimnames<-`) <- as.environment("package:Rmpfr") environment(which) <- as.environment("package:Rmpfr") ** TODO 5) have seqMpfr(), but would like seq() methods, but that seems currently impossible because of a "design infelicity" in base::seq.default --- ???? E-mail to R-core ?? --> R/mpfr.R ** TODO 6) It is "wrong" that the class "Mnumber" also extends "character", "list"; but it's not clear we can find better definitions, see R/AllClasses.R ** TODO 7) Add tests for hypot() & atan2() to tests/special-fun-ex.R ** TODO 8) round(x, .) & signif(x, .) currently return "mpfr" numbers of the same precision. That *looks* ugly. Potentially add a swith 'keepPrec = FALSE' -- i.e. by default *reduce* precision to "match" 'digits' argument. ** TODO 16) psigamma(x, n) {and digamma(), trigamma() aliases} --> experiments in ~/R/MM/Pkg-ex/Rmpfr/psigamma.R ) Note that since, MPFR 3.0.0, there is a digamma(); .. which we now interface to ** TODO 18) ifelse() fails ... maybe I should mask it {or "fix it" via assign*() in base ?? -- they will love that!} or provide ifelse2() -- a fast simplified version ? ** TODO 24) Bernoulli(): we use builtin zeta(); alternatively, use *exact* rationals from 'gmp', using "bigq" (and "bigz") -- and R code from ~/R/Pkgs/copula/R/special-func.R ** TODO 26) (?) Revert the decision to *not* care about rounding mode in Ops/function, and rather expose that as in mpfr(), e.g., in R/Math.R roundMpfr -- see MPFR_RNDN in src/utils.c and others; --> use src/convert.c R_rnd2MP() -- and all the SEXP functions get an additional SEXP rnd_mode argument, the same as SEXP d2mpfr1() in src/convert.c has already. ** TODO 29) Our sum() should use system mpfr_sum() : mpfr_sum (mpfr_t ROP, mpfr_ptr const TAB[], unsigned long int N, mpfr_rnd_t RND) ** TODO 32) Use ./LUP.R to compute the lu() decomposition of an mpfrMatrix ---> solve() and use this for determinant() for larger (n >= 4 ?) dimensions! ** TODO 50) For *complex* arithmetic, build interface to the "MPC" library ---> http://www.multiprecision.org/mpc -- which is LGPL and itself builds on MPFR and GMP. Ubuntu now has 'libmpc-dev' (!) {but there's no '*-doc' package yet; on nb-mm, I've installed from source --> Info comes along} One idea: Since the names are so much in parallel, try to take each src/*.c file and mechanically s/mpfr/mpc/ producing a mpc version of that; then "the same" for the R interface code. ** TODO 51) Incomplete gamma, i.e. pgamma(), is being added to MPFR. -> do in Rmpfr! ~/F/IN-lists--2016-08 : From: paul zimmermann Subject: [MPFR] incomplete Gamma function Date: Mon, 18 Jan 2016 09:54:51 +0100 zimmerma@tomate:~/mpfr/tests$ ./tgamma_inc 60 30 100 1.3868299023788801161747839921242e80 *** Will be in MPFR 3.2.x (Oct.2016: current is 3.1.5) *** MPFR-devel(svn): https://gforge.inria.fr/scm/viewvc.php/mpfr/trunk/src/gamma_inc.c?view=markup - get: --> http://mpfr.loria.fr/gforge.html explains: - svn checkout https://scm.gforge.inria.fr/anonscm/svn/mpfr/trunk mpfr * Accomplished ** DONE 1) R: character -> mpfr "3.14159265358979323846264" -> mpfr ** DONE 3) "Arith" and "Compare" methods currently ``lose dim + dimnames'' for "mpfrArray" (& "mpfrMatrix") The solution is a bit tedious because the Ops do recycling pretty generously for vectors, but pretty stringently when one of the operands is a matrix. If the other part is a matrix their dim() must be identical, if just a vector, its length must be a divisor of length() ** DONE 10b) a factorialMPFR() which automatically uses full precision for integer-valued argument, notably using MPFR's mpfr_fac_ui; see also end of man/mpfr-class.Rd ** DONE 13) all the NOT_YET in src/Ops.c are implemented, *apart* from trigamma() --> TODO 16) ** DONE 14) Want to *change* 'precBits' of existing MPFR numbers; MPFR has mpfr_set_prec(X, PREC) but that sets the value to NaN. Manual: "In case you want to keep the previous value stored in X, use `mpfr_prec_round' instead." --> fulfilled via roundMpfr(x, precBits) ** DONE 15) beta(.,.) and lbeta(.,.) .. using my_mpfr_beta() in C. Interestingly, the speedup is not dramatical (50% for length 200; 300% for length 1) ** DONE 4) format() got more (optional) arguments, along the format.default() example. Note that an option to "round() after decimal" should not be needed, rather format(round(..), digits= ., drop0trailing=TRUE) does work. ** DONE 12) crossprod(), tcrossprod() (and more?) methods for "mpfrMatrix". ** DONE 10) chooseMpfr(a,n) is now implemented --- *NOT* based on gamma(), but rather n. ** DONE 11b) No longer --- problem were missing mpfr_clear() statements in src/utils.c : format() --> .mpfr2str() -> C mpfr2str() still suffers from a memory bug, inspite of my efforts in src/convert.c I think this is the MPFR library just allocating memory that's in use by R, but it seems hard to prove and or fix that. ** DONE 17a) as(1, "mpfr") & TRUE : no longer gives infinite recursion error ** DONE 17a) Write a 'Rmpfr-package' help page that mentions that we have *many* Math etc functions, including gamma, digamma, .... {which are not quickly visible on the help pages now}. ** DONE 20) integrateR( ... rel.tol, verbose= TRUE) : the precision of the output should be increased a bit, (still depending on rel.tol !) ** DONE 21) What's the exponent range -- and possibly change it: R interface in R/mpfr.R via .mpfr_erange() [and .mpfr_erange(.) <- v ] to - Function: mpfr_exp_t mpfr_get_emin (void) - Function: mpfr_exp_t mpfr_get_emax (void) - Function: int mpfr_set_emin (mpfr_exp_t exp) - Function: int mpfr_set_emax (mpfr_exp_t exp) - Function: mpfr_exp_t mpfr_get_emin_min (void) - Function: mpfr_exp_t mpfr_get_emin_max (void) - Function: mpfr_exp_t mpfr_get_emax_min (void) - Function: mpfr_exp_t mpfr_get_emax_max (void) ** DONE 22) apply(, .) --> S4 method ** DONE 22x) *do* test rank(), sort(), order() : we claim they work in man/mpfr-class.Rd quantile() should work from R 2.15.1 (June 2012) on ~~~~~~~~~~~~~~~~~ ** DONE 23) quantile() does not work ---- but will from R 2.15.1 with better quantile.default() Reason: in stats::quantile.default(), ifelse(h == 0, qs[i], (1 - h) * qs[i] + h * x[hi[i]]) produces a list of 'mpfr1' instead a real 'mpfr' vector. -> Fixed in ~/R/D/r-devel/R/src/library/stats/R/quantile.R ** DONE 23x) sumBinomMpfr() accept f.x ** DONE 28) determinant() and hence det() "fail" (with a reasonable error message). Easy: go via asNumeric(.) with a warning() that can be suppressed Standard R uses LAPACK's LU() decomposition. Would be cool to have that in C (using MPFR). Alternatively, do it for 2x2 and via recursion mxm for small m. (but it is *really* inefficient: complexity \propto m! ) ** DONE 30) pmin() and pmax(), for simple cases pmin(x,n) are now, 2013-02, quite "fast", (see also --> ~/R/MM/Pkg-ex/Rmpfr/SLOW-pmin.R) ** DONE 33) asNumeric(mpfr(10, 99)^500) gives 1.797693e+308 without warning. Should (warn or) give Inf ** DONE 36) got mpfrImport(), reading mpfrXport() ** DONE 38) Define a norm() method. For expm(*, "Higham08") need solve() ! ** DONE 34) Can specify the rounding mode in mpfr() and roundMpfr(), since 2015-08-08 ** DONE 9) median() now works, as does mean(, trim = *) and quantile() w/o warning. ** DONE is.finite(.) etc: *Must* keep matrices -> src/utils.c ** DONE 52) No longer use 'representation' but rather 'slots' in 'setClass(..)' ** DONE 25) mpfr(, ...) should work: return argument unchanged *if* precision and rounding mode are ok; otherwise use roundMpfr() *BUT* that needs an additional rnd.mode argument -- as mpfr ** DONE 27) Now have simple sapplyMpfr() ** DONE 57) Fix pnorm() bugs reported by Jerry Lewis (>> ~/R/MM/Pkg-ex/Rmpfr/pnorm-* ) ** DONE 58) print() somehow fails to use max.digits = 9999 [print.mpfr(*, max.digits = ...)] ??? *** Why did we introduce 'max.digits' *and* allow digits=NULL to use *all* digits before the decimal point? **** I now think max.digits is almost superfluous if digits=NULL behaved as promised: We have in R code comments __digits = NULL : use as many digits "as needed"__ , and in help man/formatMpfr.Rd __The default, \code{NULL}, uses enough digits to represent the full precision, often one or two digits more than you would expect.__ ** DONE 56) Add regr.tests for new dgamma() !! ** DONE 55a) .getPrec(), .mpfr_erange, .mpfr_erange_set, .mpfr_maxPrec, .mpfr_minPrec etc are documented now. ** DONE 59) *exact* dhyper(), phyper().. -> in package 'DPQmpfr' dhyperQ() etc exact via 'gmp' exact rationals ** DONE 63) R interface to mpfr's functions `mpfr_get_ld_2exp()` and `mpfr_frexp()` compatibly to DPQ's `ldexp(f, E)` and `frexp(x)`: -> frexpMpfr() and ldexpMpfr(). ** DONE 64) formatMpfr(x, scientific=FALSE) does *not* "work" e.g., for `x <- Const("pi", 128) * 2^200`. ** DONE 64b) formatMpfr(x, scientific=FALSE) does *not* yet "work" for small x, i.e., x << 1; e.g. `x <- Const("pi", 128) * 2^-(10:20)`. indeed we had the scipen = *penalize* scientific wrong: *and* we used 'scientific' instead of 'scipen' ! ** DONE 65) unirootR(): *update* with R's uniroot() enhancements: extendInt = c("no", "yes", "downX", "upX"), check.conv = FALSE, ** DONE 67) igamma() [incomplete gamma] always returns 53-bit ** DONE Change Macros to static R_INLINE Functions Tomas K: "Macros were outdated even when I was a CS student .." Rmpfr/configure.ac0000644000176200001440000000447415075433454013651 0ustar liggesusers# autoconf this file --> configure AC_INIT AC_CONFIG_SRCDIR([Rmpfr]) AC_CONFIG_SRCDIR([DESCRIPTION]) AC_CONFIG_HEADERS([src/config.h]) dnl Select an optional include path, from a configure option dnl or from an environment variable >> mpfr_INCLUDE << AC_ARG_WITH([mpfr-include], AS_HELP_STRING([--with-mpfr-include=INCLUDE_PATH],[the location of MPFR header files]), [mpfr_include_path=$withval]) if test -n "$mpfr_include_path" ; then MPFR_CPPFLAGS="-I${mpfr_include_path}" elif test -n "${mpfr_INCLUDE}" ; then MPFR_CPPFLAGS="-I${mpfr_INCLUDE}" fi dnl Ditto for a library path environment variable >> mpfr_LDFLAGS << AC_ARG_WITH([mpfr-lib], AS_HELP_STRING([--with-mpfr-lib=LIB_PATH],[the location of MPFR libraries]), [mpfr_lib_path=$withval]) if test -n "$mpfr_lib_path" ; then MPFR_LDFLAGS="-L$mpfr_lib_path ${LDFLAGS}" elif test -n "${mpfr_LDFLAGS}" ; then MPFR_LDFLAGS="-L${mpfr_LDFLAGS} ${LDFLAGS}" fi dnl Now find the compiler and compiler flags to use : ${R_HOME=`R RHOME`} if test -z "${R_HOME}"; then echo "could not determine R_HOME" exit 1 fi CC=`"${R_HOME}/bin/R" CMD config CC` CFLAGS=`"${R_HOME}/bin/R" CMD config CFLAGS` CPPFLAGS=`"${R_HOME}/bin/R" CMD config CPPFLAGS` LDFLAGS=`"${R_HOME}/bin/R" CMD config LDFLAGS` dnl Setup the compilers AC_PROG_CC AC_PROG_CPP dnl use the include and lib CPPFLAGS="${CPPFLAGS} ${MPFR_CPPFLAGS}" LDFLAGS="${LDFLAGS} ${MPFR_LDFLAGS}" AC_CHECK_HEADER([mpfr.h], , [AC_MSG_ERROR([Header file mpfr.h not found; maybe use --with-mpfr-include=INCLUDE_PATH])]) AC_CHECK_HEADER([gmp.h], , [AC_MSG_ERROR([Header file gmp.h not found; maybe use --with-mpfr-include=INCLUDE_PATH])]) AC_CHECK_LIB(gmp, __gmpz_init, , [AC_MSG_ERROR([GNU MP not found, see README])]) AC_CHECK_LIB(mpfr, mpfr_init, , [AC_MSG_ERROR([MPFR Library not found, see README])]) dnl Our Version check <= 3 -- etc seems to fail nowadays dnl src/Rmpfr_utils.h dnl ~~~~~~~~~~~~~~~~~ AC_CHECK_LIB(mpfr, mpfr_digamma, , [AC_MSG_ERROR([MPFR Library must be at least version 3.0.0, see README])]) AC_CHECK_SIZEOF([mp_limb_t], [], [[#include ]]) AC_CHECK_SIZEOF([mpfr_prec_t], [], [[#include ]]) AC_CHECK_SIZEOF([mpfr_exp_t], [], [[#include ]]) AC_SUBST(MPFR_CPPFLAGS) AC_SUBST(MPFR_LDFLAGS) AC_CONFIG_FILES(src/Makevars) AC_OUTPUT Rmpfr/inst/0000755000176200001440000000000015075721202012316 5ustar liggesusersRmpfr/inst/doc/0000755000176200001440000000000015075721237013073 5ustar liggesusersRmpfr/inst/doc/log1mexp-note.pdf0000644000176200001440000047751615075721240016303 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 5349 /Filter /FlateDecode /N 91 /First 775 >> stream x\[sƒ~_oǮ0[*ZKlŒeS8%P$ [=Hr 3=3==_   X eQ\ \H7c 80B)LJS q4(. 0ĴTs)hn)pZ;Z`%X5 !kn!܁9'@p`BP5HƘ 40aqF) +@8`\kVj6JNS &9 0)-I9` HGQ)&HLISi@1`S جJN1PaR40#lseK (8AS`1HZƞЖx,h:Ac0#@`NpY@1 sHҁaxY)R;)Fi08T1Ʈ(SY9 g8J m`pfsX3Zk BQp8WTc O@Σ,YNe41~?;3*(W<FIC)<շe(~ٗb-iM Qj8FR:ELP-zLVg GI"a9QΘa(x^[$,>8o(Is oo_$]ÊFtqqA(GEzU7.SeZOsTZO(5Rv8_Lv5d1YzwixU{ruh@lj_ҾaFn+M7Ҵ ?=~g<=tA9e(Ῡ\kY7u5`G<M:Op_ogP q[?JnrEרVQePOEJ|y]~YRFFj&U=mFupG*MhL%]y($t$%G}U5Tm(\pLїU8#a,{&$Oy}#(MxuߑxJ r$y,ۼL]beǚ4-6~{믟/sǝLL>4<ذm~M~fy?,!h(7}H00*ÌȔܓ%Isق7{_ZA}o}/9yn-5;%kJ.]-]-{Zb ᢬}GٷM ^BbvC̉kD2$Rͧ(^ɿ{SsPy XbSZxsAMᛥxυ Pmn 3Hϟ{&¶50]W9&/ yE^S yCμuAy5| #SE~w$*aFd:PV<}!_VQ@ ZdfS7yb_FFs }nן+jw/W,Lu%@S#u͍)- u]R%ɇ~=+ ҵm<5'tx34 ص Ń͚Uʦ%ܑ#edu$g\OPZ[-~)FAu{ FMyvpuLmrZO._4QhWfNL [-i?s!Rk 2l ^ J:T L=g?(t{4^Qalh8WL-E:JEB(Kpxd5u1o˴#CY,zzc[)Z8j9{%//PnD6ۨ^5*5ʮgfG0jC*EE֚W9ghd΢BY9ޮƳ3v<\AT$]I h@[[_ ph6,j=CO)m5-3ok M]n#?]ˇ,bwc4B>N*돮^/?Q,ݥ[[47CYQDC~Fpnn}>a@=9_ IqBy4 ڰaOջefsiakvqѶDӸإ>Bۆ! ]Lλ~vqTH< 8~6AӖ؃HgvW4`ZKMm#mcb0͆_$J ˉ#(Š"T|3(n0hCY li_9Űq2!x`FZB(?Y<$HM>`MV&LNh^WDt]WoO.?rrγ-Z=)Ɏh^ Tl8 EPrh-*nɡR2}4*v țUx(몺Dz.^5"130oqAZOb|Ӄ01\uxq3CŲ?;&2*Ӷ29;o'ttEey}xc T 8m_{,݂0OghS#:G{>Ѧ[{*ޞ0O|x_Dth%dtVJR/ڪG@ה0ث0+鷸$m0vktnvَVgt0rc񺍃6 [f^0NSx78ؿt˷k=La[VW'EӍ;Ծ=ӍwGL<6vPd˧G}c90|͑#E$GԢ: 鉱b_Mb%#C?jBA@(I=V~Yq$/Haךv"?x+e޿x{Svk{US4=C>**νA!}>nj)4P]~'ʛD ڀz}W:A$dLy@ ̃J@ N@-ıq*]K96t wƵ H pi,@C&O3kn A-r qVwQ2@7g"6>G8m J$tOA\O:(ܱQ}:icNoq fIUl AK F;ѳ,[H`tL KH0iGx~9M{Lv{/Ұ7\TfЁ1[v( Q?BUd>R2:``f.MdMKp8Ud: #!+7'USs P`ғ?⸣Uq[j7y*5k%0J;v}]^+(ok0;6*. 2q ZLonU\ūmOSVŠ VÊ xiD&&F<0+$c[R~0&B(Hfu ,ۻAem%|n?&'SRmThO/erG/od{ȝi\.6DP7FU8c `:PX^ߔn36P}-V qs HptI77ZHLe%|;B 猼\ݤbojRTΑjNlq˖]v?{ĜX`VTE4 Olkh`XpSG3P(9Vׯupjw$ p D{"zx-~,J',@.#:\daK7eC!͜-k|EU`nEF4A4J9ΈMx:crP[kO} .Հ .+B<S] I?ꉲGXk㝐#ai>ueRͱ U7B c_+f`e܄6N-߄. v?QO!B HPm6[@S 6#)i d:emuB&oy-4kendstream endobj 93 0 obj << /Subtype /XML /Type /Metadata /Length 1775 >> stream GPL Ghostscript 10.05.1 Accuracy, Cancellation Error, R, MPFR, Rmpfr 2025-10-21T17:11:28+02:00 2025-10-21T17:11:28+02:00 2025-10-21T17:11:28+02:00 LaTeX with hyperref Accurately Computing log(1 - exp(.)) – Assessed by RmpfrMartin Mächler endstream endobj 94 0 obj << /Type /ObjStm /Length 3693 /Filter /FlateDecode /N 91 /First 846 >> stream x[ms7~&$dqMlME^ٚ%W~ /7W2Zr$(.B`! P!Nx 7|aA+h Phƒ&[tPE08@T`&@D0'C &,߲`: l@ 6|+#& #8"V"F Pk  5|@(PL=x"w>h4 K Yh 2Bp8 !3"F42WxE 묁Hb`&F+@"WdL} >P\)j@fc #,Ñ`.Bw\`2&' >UkI3yVN(8$ϳ~=6+iv͒HNVm_WӋo_d ~ˍvr`7F7qS/oOW93Kd!1~{C*."?(8d{:8Aj-#:y01u,*>lDN|u;Yv]/&k./r3H*fr>6nZ'RiByqa@*mB]t20Q?bkYE{!`u3e 'wMټY^.3y-r%WL;|Ͷ՚d&Mח't=y2_db6t;Y̧GE |/&C^l۟:h5W2_lɗBE#x%x3CIf?:T](_D~S4@fFBVjlr-7r+P׎6{Ȏ W24VX}T8ӕ~wM.>~X-6}[c xð4 !ڻ:yv#GT#>4C XmryOe_rI簑 5t`LwfH@.<-~*ގ}_XݠEmhԬ`o^5)M҄u<[q/8>|/8ma۝z̔!ʪ>IV/,olB8;O ȇndC|xt1>ǚ59WͫBeV^hp&AZthxu]Ats`%^qBO?ѱ>Aw݆aݕ~AO\i\!^BJ$z: g?5+?EOO)~{;l7ٟR~p:[.0}ƻ*.{jO;֟{WNTTHe7.TlKG:&=A\6Fq3XhlȉkYL67;]AqUS 6:JZ޿f_\l[\zt/‬6t3$:ćTGX4 XHyWC{5yamVlp?C\TKm#;zdqu<,pI "ʐ0@# GxP|8D ^EmFaTĎ#ّ0Qp}WbSA(J>AB^j ƔpE6˩~k9<%a.rj]i2=xB{-̶餑)(ͳPz,G0,6n~8 R `:&aBsZVBN >|{U5 xy=a٢TTX|,lHNt:Ew.C&=Z7%mQ1FXxk8YIsF0x募Od Ew8L uC!O .tl"¯Wō h/t*TX X_S$UYnWHFRk6ӪAkT9)v.m\T$"W- Fp:@9yF[@i 89 Hpk0]z|} FG(KBƳ~2BA{*Gssh>;#v+\3٨~\W΄|K=ڶzɥbuGTQxڥxwk`tVYpZ pdhx$uD@:h]J&A#04 \"Wۃ#- -zYAh)Ӧ|''ߑ{3`>\ endstream endobj 186 0 obj << /Filter /FlateDecode /Length 5413 >> stream x\ݓqW^)~L? s@4![bdQ"Y6}UqWڽ=CRfٻrR|h4[#84/6'> ЯMbW`p\雓8P;8)8mN7'ًVvqqWmB/ۻC<F79^P\4,҆ R=3xՒ=-QNԡts.TK9 F5 &vQHe V߻s-V9Ё]2 $GD"Ⱦ8㽮cdS>[o4 r<1_U #]]_U3m?FO)ܹ+puNxް_/]l gF,^F@yA,r &|w(rO5SHddAOe"!N*a&X?Dc=ڟT~bro5Sc!c.sv2xv: 0LϖvnONAb)t5)+jBdRIqڷ0Jz\ʬSZqBe٫^Ѓ:Od (j&hkB9|gV²{47eMG3 S߇Z )Goo(.6xpkiMsjU Sҥ#=x!&!N<ΐT6CZp_Uk)= Ϯ"뷵t:nM:]J>5 =zN950\cC-*vK.@S^~߯.g\*` %*) \~(yT%Ӻϓai$<ĤIuٖ$Ty5dKZtŸhōnqg_^<(o ѯGmLSaPu1QluHD|(?֣820\H/u;)HlbPDNR%: x{d Zo5 1J,~_OZ5b<=+Ӭb۔ 8mg>9c֤JxS(+cnp#,,1hsHyW+5ڡFE9bn2jJ:0QJ}yGm4v,Ȝ Ei;ɥ EV= ^p\{3Ij١|HN$FADmBxvVR@dkAubYAt]J䰴)k~bO ƌ10$[e>!͊mnl+,[G|t&16tJ*u9dPWx7ȢwZ;ƒYV ƪDDx|uQysLe51j9ثt'\X˝$$f[[E$lYm9R$gXn 3}[bOh,H%0,:((Kr!fdܨ|!4R‘+]Ah9g [90^wQ;tO+$eiŬ{U:D 1$EC!C#+`92h3ciU64L#I;Tiv9_*`0bYqͽ$<|.{lXRP?-?p?QlCa%jgdѯ嶄wiDWc ]~kaB*AqcoYNy[P$̵SZs|5x1:VH_: QH!Ag2 EFHM^/K.z``+Lk%)S9vtrX@PM^K# 玔$iLļk:F(Ϩk!;g~٣uخ@}'%׹Gҭ3Q_Q#cu(ϝ!ܒ}HvMĘªf47"%͝}W|i`HFayrÝǘKT.>eb8U 3PB 3 B ůYvܳw|-+%# @ՠT/';ɕ)f8GAD'&C uӁ6"_LUcc쏵:+c:fZ1yGy1 ͏OEd*#{5S֔3bD Q#2#3&4⡶2rѝ?;"_YFWB"_@r3UDuJ: 6expVz⹖VNh=RԚJJZ%e[PS5leNUuDPd3@`E`d !ITG:=Б}>T@r ňRHJCMC&]B)RB*6JYWK%{5(_hTKlZ"*Zb^NVuDKJV=.ըLl Rөαh'h .UmWPm[>_:qK4U]FZ.̠S2 BmG`Ob ި{5sbH'&U_kT8{M JRbHnhqըc p<86gl 슑̤pUQ5=(^^[.z0@[\ S sCH=eC5` YǼ?!}Ee9zt㎆`UIo ѻ0 Yjj@e[&#$-Om-cMURCOݒ@~)Օgۣbsh &ct4]˽T^fI;8v*]WǺT_h8hMF%̪LWVOj*]mMa] hmfl=I3oBwSKLz %sw# Q4=hitq3`1`:xML8= MwFh!eo΀GlI oE㮱nu@$ٺeߵW):ﯚ*Ϗzy]*\|q>_68(|^Bb=68~9NbM 0lHfۭ%K\:EABc: p5跟ʩqE45\k݀b I ew*87Q]7L7q1RX.MITu7]un=ڍ0oRxSAddv0{)<76#@7%O5(m?K7$ÏJ%~\갸cs&)iUׇkmgS47nJhzIaj)\H%3 !jvx\fs"T塗:?RP\+ f;=LhGЦ+F8YT ZėtZ?eKo0஧anwqCW~yf([(E| Ǫψ6P^72S 1̧ajݟ'(m=7$ ^l>pT5$ҷgϟzuηf> stream x\Yo$qg>Il샳׬`F9#@+5V',ԐMvt7`v#22I!2}dEFFW'oN0|Z?Wsa*$>j ^bu⧓sRWv&,x'$kWyklwZJ>[^9:{w;K[9[nng5J3L?# *vD3H&:N-i_j48E RN)i㟦8%I l>&/z7nWm:ݑT57{cp7"IFF#l<-7mсqgss{E)ZZhtUK Θ Ҳ-GTU#y\ msV+J$1tf8WeLDʹJʋ@x.W&je%p~` QhޝOPr WV( TTw'˓?2ZgxQ,]t9ʓTOg8 GdzyY ${^qXd4D{!HUsNr>ʷ۷5=ݴ_o&ss˻"A"J^M<8{a/MDfx$D(@i,y8T`ZH Xy!$eD"Q:O Xb!e+uNVP{WEE )iW:0a#t<|bry'>n Wo.z[۩ȊaJQ+e鏳$u;TČ`fa"$oW]MлQ)X~81e{ձb+J!qoaS IT@*#9x+ZRQ(%ZsNoyҪH5 ,:_aV+fȵTlM4\@T+KTR Ђ;/}n~lIO9z‘l5۬GzA+A<2l'D/e [GY6B@=zîfa1 *cbyߕ12Hʘ>^Ƥ`6pOYE3ʩ4PJIueza?ʽ`b }hM ґ .ݣ7dY{ٗcM9GuO'%`SM #jҬ5  Z)e]j{m~f/ojX_!Hq(k4ތik™A}qhN+a Z"%4@$E` 鉦ɍ!H#gzTKUMz};jS-*_D7ٛvEK|vyE=Z=LKVMpKc*hUbvTδQf&T0+Eu%ΐ.۝ZՃ4 06vO&?+ &GF@- 'C$d%Qb{*+M2n;n2~iRU1xjV9wCyJ*Y{i)²`$7A;;&A eT;h܃)*JQC}V+ӛ2,nj[0 &-yMZ dRF*S)O=؀RaH8: #0ԣAJ(Wrg͖(yinsIwlF.eA%pݓw8Ǥ#13}خ]fLfʈb]@~ #R~_]y].ݨk Pf2l"QHw?\|sC;5v7FM4NKX{wؙ#AQ9)^R:2DͬFmu&}|/Y=|ұ؞) i[T^:GN*xh.8Iǯ%t" 1e.鯿nf7) `ߙ4`X\u"\" ],}5{݆A:ظ?jԬ ǎ],_u*QӎOnx&7rP{Bҝ:fYjmvv\owQg_C~3pywҗf8e~h@i;E7yɰ_#60M7o&E{q7)]{{7c/o7vvx4Lvwv/mWhm̹ooUO;`}\rhz bdvaKw) ˼usCGQjt9n0r8x),Xj)䥥E45Z?7iLO t2c8$䝁Ϗu >c0Yqeb2-~.&'ˬD _aj +t,0en!M>7'}3=e9&A.BKuilk;UJ(M۬uPoҏ +5إ1~QGdyn Irƅ};ܘioJCDn:-YuX,C~:Dux)M 7lH92skTX&3 m3y_ mG(#b1i=x m w$nB5>&'҄.~<9FwC8R8BŗxAjCfQ =X&DuZ"85d&YՉVhdc.EqW X!a!h_mcu4 x? Dԙ`7qb8F_> stream x]An@=n "Q4 3}T,xHU\^_^~uۗ>R۹n{Ӆv3Zަ<}چv#gmT9ʦ;siRpe3LPP<. ,+; ;1R=& ljĉ͘: U)R{@ל T)@@z/WYG?d/HL0z `Gf3J̏ `ނحPc7h7h+͘A2< )@r;=QR5d& P&k|}-Yf^3oq}iCҩendstream endobj 189 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4218 >> stream xXiT維*P6j08O85Ѩ8" 6CA&fjDr h7z%So5 ﾷzk}>{O( %]PEN1Mxuk&^F>+K%t˯v.NE 5Q1!gxy͜2e\wu;SݗvicBU˦Nu_W utW Qkw5OC "5 bbw-U%w&?,]@,ƀ>SH?^q$*eM@-6T))) \\vxI(e h r$C[l:IG3XQ"܆"g@q]b7d~(g@_/C|䭤+Mj4{Ϻ,}#fF*$^,Q#Git2{kĉ8wO8B '@geM\ERMQG5ǂ!63œS1V2zvq_&ȏfAK'<`:,WBrg/\UՑE(LU +!'пcIp%T25N PH)d=c,k{Qyh>X9rS7 a;s4Cg?s-]w*`pԏXw"cnXTV 0fGt:vqQ8<]MI{dYwmwlS*3X$s~[ɻPp ? xK>D[.)UeOuh\EeXpdV'j{o CG%TpyѪ"`=r-1qVH!R]2NefkA&q3LKF.ƀy Vp =h!{t1x\+jE}p4ߡHՎC۝˻T҈Ua%OWцǏfv{^q;.(+Η*W- AB 跷7?<Ǻ?ii#xA Ë5t N<=(`8P AQHt C;<q+a2 ,(Fp yy:$q+p* ߹L<]lUCLWTA07vU 2s;{!wOS@-)+? )6-gT786|ƋNbC%2ZTRpspiHP䪤3u+fMCl ց(?ы!Nd\JN7\WZh+O'h*MRʪLB A虁 L. t"_qԔGd- 0;m;}hّcϧ8FArkb7oI H`Z8q a*^ AXkEb0Fӡ,Pÿ\4t@rvv![Al2yY4 ~mbWi RLƺbhf,-TΩc C$87}N,8 ).!j4`` }èT7Ou{1aM^zs%FSwVE;B'CyʓPZ 鐮%.D'H/O-Peg0Dg% V*M1?耻(ClNdpHcuRҎQ+,*W+yVA,Y/lʶzCFIk_Gg,-5TmHv#g͊ * N%Z[}HSg}rޭ`QVf0AUvmqLth!6`WB *J1J *=*㹥cRv** k-ՁvC3 c!;9^T2ƀn2twUKVC^C^8 '~zT1 ]$]fj375G( ƍsQ`[X o)o n_E; ÍYC=CO|O^?b)2yܾ=ev4$h:|{,}4hy<ͻ2.xʫTJ6Q˱T:`־8Pؓ *˰ߤf^3\ovyY[ԊhN}!ސd1{!C yxJ4q/8\uL[dcuUiO0ߟ(~eaXk5;QOՆܘD=KHO*OY}14A#<&6-r2Xs] K$PpGh%ŋ vdrPJ$(Q"(AiqLqum4G< CVYdM⃣ s<(bů_-{hF2 =)Y/KTHxk&:iJYLJ1(0Aq=+ڞ;޽FYz .g*-LɂL)*5x>QvEM_Dž%B4òAFjl>oH_PZ )J*^j7>f1]gQ&HߧL(Ke'ûm'9b+,v(Ijmks99F`~]{3L9\_ -endstream endobj 190 0 obj << /Filter /FlateDecode /Length 221 >> stream x]An! E>7pФ#!oM`D, 2YxHU m ߼Kl|]n- T1 _a8sPENpglDVrfpZKK4m9A4Hഡ = $ ˉDe q =!0m"p'A}D=r_ ָҐ4υKK.%mendstream endobj 191 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1123 >> stream xR_L[e;U@d·e!s 2alCXf7:J2)_{{[ڎ2)+̈́u4Uht!As̠O>(~:1l>-v;'! jj]=-vG:1J޹m6!?CDB̥$2lztQy!(vHtrSy-)..ݾma-dG4zm_c k 4z6%Mf[rQVs=86WճUu ,u\%P*ʮBGvݑV ՂDD1I4@n DH$ϐf'ed]55mdrT薡}?a1&JvrMSɿ9>Ӝwh,:y+6yf?߅7&񋘭@"TpFH G`8%*2ԈP#@6O  N6ZZNLDHpOwWPND]ڙa_;06!ZJ@' Y8٘hz}aZ 1.# o6ORU3RE+ uA_gSI:4*^zTCH@z'I$oEbT2DV, J6]N.vnt0 rP-2|&;>/A QlFʊZ~LknTsq(R+W_ULHmnnw&SRW›VOtr yp^pow@K?GL˃'VM#Az  >(3^:~D7IϗvX@a~߀u(3[?Y|9{>HA?>M@O]:> stream x]1 EwN ⠆tKVU 0C "W8IOu} nye%[B.yS|ڷI:]Lz~I%U_͛:T&;:M|Ewլo/ @PtZ#uPt- B Vk[JLq攜,">"$E'`endstream endobj 193 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 843 >> stream xuklSusʬ[tHZf&ұ@ۭcK:aY6Y[OFؖ9p  9F>xGgLx dBF4x~y҃Q F]3`S!zV-4K]mGZ_9ev6)+t5ަDoYq:Rh7IAoRϿ_t׉=Yo"!D d/#դ&0DG[NfY 34[dB|$2J c^@R̯V0dō/"|iÍ8$ <e4GJVrӡ΃ [lRDƆۓ=xKjꃩK%3B)|E@4(RڼdMżK]꬟|z[b$ݞO26z~yґ'-WGQ=Gp293L9f(ؙf~E=:5kz> z+,)pXBC4. / rTTS-Xz Kh/旲ed $D&_8*90iޞtnYhM@nlĠ1uix?.NnGm`rFW7[v`嗮"@u͔>[9|x Y|׳EJrWCQmNra/Pe}akқ%Txh>ɸ;m4*ñ 'Ox+$O0dendstream endobj 194 0 obj << /Filter /FlateDecode /Length 566 >> stream x]Խ`W;o"Ep(f=@AD$Ke:^=Əu.6]??>=ܿC:lc?-K_o/q_Xnt]Ӹm_gdytgYbޢĜl\4SSGc'$ E E4dsF(g9$21d.21d25&ܢ2=ʣ rD'䈐%]yt. J Y J Y J Y J Y J Y J Y J Y2(1d9ɠĐeA!E*ol2(ʐAPvXAR jY5"kAɠFeP#`]dP#Beb-ɠEߖeТo+2hѷUۚ Zm]- Z,dbmATXl[ebmAŶ!m Z,# zI=,y{AʠGd#o2葷e#o?ɠG޾ȠGQd0Ѿ`_}h^9qW8\w/x0n=zendstream endobj 195 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7721 >> stream xyw\, ;cCe\3%{I^A ."=Kua) Kh4$ƘDMB4A͛Xs3Mn<<| ekCI$\Ǐ*&8I6+RObzHRi{|ఛ›}7CI%!sCw;O7n1ƍ.;\ws_}WǎIN:m 9‰ jJޤ^\(WjNQ#5Hj-5ZG͡FS멹j5Kmަ^Sxj!H-&QKRj J-Q7TՋ 7՗rtKT*r@9Q F9S%%=6ǒ$m6wsmސ}L02wcUOEOs/^:3ݻ>[``{ |L8:9o)>4 N7?0}_yp*ys AM~29}#;5"k{dxW25[U/քv[t60(WMOz=uWYs0[(c0f=V{ꅉN<@ % p䡲$5,L If. SY(sLM",LN:$Y zHRNrNp?!QwHx r=ĸҎ.G?/ǕaHw5`^*mrĉy̞ 3}yVGZ$۰T$kϲ$x\|<'}ｆ'ԚUdKɵ/ 9ۑ}eˤ5bjF-؎,8bH;1W* %cY.M`Il$7\czuQ1YFuLfTʿǭo9%np[,6" dpj|$=[۠±4;AKF9>*B=K^gp^ (Gx~=ԂC,lQn=?VLסɩ@wҬhȯWcDLM92vDW*zp$X\?C(X* *u.z#; ;NY==5wa>c꫚oMx#gH&KU?Y4Eq65!1UU{!^ ]}#Tu!5Oc9똹zΘs.NOK&UDAt3XRz|Q*X^xՊ+Sڥa"ib)cRѷMjo61h1Povg<VչJL!;qId"\dCV MirO%Qj I<.rrX'xφgxy/;8'CQ1)T<"Y&7\r뚏𸿫OK;迉U%T k\%//Ykb+ik8rz 7}|Z;O?jwxtuyLHa|zs=ɱ=&6wzTd$=|PˍJv |qۥx?B})W%FxvxY},2-.D< 8Mp٩{r"yI+҅raIO7sa$RSկ,:M>(i"!/B&TdS!Ҳr++i5|GEm6,DhmȮ:ҕka"x }Uun__ﺆck`cء'V5y;bX}eEW?<3d3J.r]7'Rcj.PcPh RƑlpK!]YeO@`WPˉKdLR,%|/hǚ㐧C"=֔$fĘ^6(~&ijqI&1K+Eq>lļǢꮡG6NjJ ըwNp -Ӹi}F`ߴ(lwUMIYU^ʾUu:`>AMӾ]0kGZʰ7^l=rh)Lv?T~+y5cgZpzgTKޟ 2-gge:A!Z?p&Ɵ>DIHHJ&/[q. "Rʀ]$L#4 dV=pXe\xt.@g`iֹ\3bR4f(fFPBaavayPHd0菮x@M+@e㪕H`*#o fgE v߅ORǀVO#e&^9\huQ٣ϸۈD6cۦ?Z:  9A޺["vzoʰr0A 4!3YpB*Fq2Egݤ«B*K$#]3; zI͑25lge\ڈ6LF:{%A)L(M|3f6,mudRf^*hO6lr_=xp]:΢ZDPn ѠSfئ["9m!ڳ NC=D3VVi5iǶMK6:gP7% Ab:=ŠO;) L` T%#ELl}VaIƔD&I <7 `lnH_¼>%~4Fij*$A#Qqڮi&n}$»rFF, c$Aq,q1‰Z '%䕩">n#?p7Yf ڶVּ=e o B|2tCw !OP&({TEޡ2=BGoF~w<$g"9v'ᰢKp" ģ](@p#Kha8n{V;>wwSeT G <V=vj55`96H6EPiPQ\Ԭ-˗54V7:2W!ٝ_SYyCoOhR|x'0aEТb/*j:} UhC6o8u@!d KH7٫ M+b|=${ t kW@xʌ'93 7N zN37:6@҉TD_ڰou:#}Cq䣗 |^ +VbՈ!iZ~<O^_רH0Q>? 2#R̓AM9Z(6ڦWUO%]-߂7{Ց EM*AJg5T"~S=땬b:*`GTPhpEe5n"x|ǙߨwKTHrxeXV4c>9}:i&Ӷdp hr Tlxz}|2P<D:ui\V妞dwu򐜝~pNk/9I}S7Yujw\i}ymT]PAE ax=ۢVG^/4-ZX6KR!?+L++j*,((:*d{Ag?1Rte呸4X0,Ҏ:.9@.T ((*ѕ™Jz7%OuO4L@z/ @MiN$t{Z f^N; c~[ATdA73O}i)y޸CaJ4%C3q7:3] ; ]oJξ?x'H W.; g4_y()DiEad)-K,e8J~pv{sb<^fOV g{Pymo}\|Z3VՈR8$uzNXl|p{8&bUqE{_2{,鱎H8"G'5#q*Rm2+KpY[ Ka͞!! 9[7i4z=2y7n aְ|Z{/wG zCQWj`տ;?fS%';d#qlԘ=Q5-sp9I.HWϑU,TqLg͝3T|,XOk*+jk++k0w(̒6j L?N/r0'c&J<7FE._̴<9̂%{Fl<܅f.g[`FqTKQ L*L㵹*] pnْ':e>b: imxOA8Z'{?>#{Lv'; Ce)[$'-`BG8e$n\>*7Iz-Wsy*Cxs[dB-0FebBk C+OX$8.܅Ra3ΔK)'pz{^bNZ\{|c 4[Uq6T%C>Y :C n6}_U} oLCpY`_q/B ߹3gM5( "~x. 2ȈIԊ<9߹K'f6)r-pMoyheYcEp޾Ti6E9>~}7,j_,S)ۗ\焽?MOV(-h7D-tEn؝5'Y3) hsrgv q ?uJ3OÉ3W1n:iq"rBʐ= 9l}VlN p^S}zEG`ϕx: >Ru.JJʈ=SKPNag/ef\|`SFlɄi'QrNpt&tZEC(EF"i9^~xK ^-crIheN8;nFlrC-WNv̠v?ß} _K潩a˕;ٳN<%lƯh&Vo޲h{\G!Wv3ea1rǁz|ڎ9Qbt#H7V?_G`ߎ- Py~iK7x ?8nGP>(LxK,vݢ$vjU^'*6A:q3+H%ypNߐd9E?\8poI5i/ Jn'R 3rI3<}kq0iLQ/^F#蝍w>6;w.w}10QH~Ae sY;*b+Dub9Թ`P mjXhn발BG&/Kzޕ*MU]V28w4~9\9'4{F{ hRS5ZЕF?K&2ӛ#}C\ jR3rn C)|#4%hjVhv0 ]WnJM]ӃMxn4O#C{{n$VZDgMv}%}fOKrvpRTZI_Rʉ.{z!'a'9$߮K (ȋ)IaHmz>%0 s107,_u]Գ`3h4]l0fL􌴞(0endstream endobj 196 0 obj << /Filter /FlateDecode /Length 295 >> stream x]Mn0OfnhU1E "dW3$]t!=t~9i:Olm텿jZg)o|Ӝ^gaeoÕ:j<|[P:rnǫ#H H p:I.=H[Ro%:Rw=){H L") h̤ B L) R@ ɑ#yR@c@ HR") ɾl9R@'KuʵK\7vQ7Uy*u4ܖendstream endobj 197 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2467 >> stream x]{Xg' "0UVDkѶVU@cŀ-IB V!uUjuWY].~~aD8{'|L& X4>;35kZd F}0iLzN.UoQ|}:^ԍ7)L9نi6nQk&OV%Ӧdە]tK8l5{cao@a@:VQ'H42:?hNU:?іkZHY9f760[-&LG0gHu,q!f#tr`I fc!ZF+D8YI(>uPSޅј: cV !Pl,Y-ibk ׍)-;݋7{0OˆP$2 8T~~j~2L8}y 'Oi8YئX !PhL K|@|!{q rMq dRv ̤uD. Q*/1G:[<ߴֺmo@9JWG?N<%PrRH/@")Qf(_J]ү}B۶BY)+m0D ̨8R s0v{kT}44 \BNFETxpĮ_4dQ(@sqA"3RuF%=`;$I{%j2| $Utk>vB[ %-nzdqwEn`렟/̞n1z7Vl++ gm] S1C7Afx5%ȌPwfU >Ǔvz8 UP$zP!Eq%,EfJ4ԣg4L'pỸ_>/o@[=/cZ1Ps88HjH^c" ڠr[3Q š-}<++aBawJa85f'WԴAGBo@|"sq90ӭ@G53hs,UU%@TjbZR^eW__u^t 7[؀҄66]&a1mKȞ:8RaAc.7|ͺ u~ߨ_^3١ J<|Ab 3Sa+d `L | ݇GAS )ZSSh}Z.G(|<h[9TZ6%q4>]{띫G>|,AF>jZe\N|_z}wb-V34vЇH '6u\AUm?|-0%yp8r*M|0MƖc):w={5'ZPL2d7,cv ق]W? ~<Ǯ1ٵF%:@+۞?ݐ-5 ax_oe %}Ln+͋d&6K,yhRW_DYZ5NXb Զn1"OxOKGw ߈= WH5dix go͇ǡn6WZ`5 V-$H^:@E3۠oX myBZ~t)B-ۚ{@oIݾL@W BR䚧8ٻvqb&XmV'0OxbwbT;vZ]%DKf_ӵS<#VKJQܲP ܝ% bq6Bv(cWZj $ͩW-=B,wQQYᨪp}}c gUQ E!endstream endobj 198 0 obj << /Filter /FlateDecode /Length 251 >> stream x]n w7!uKdhU}Α`8C߾sҡÇ!~|)fuI_i.yXۑs1> stream xmypw-G٤mJSUIAINZ H8 8񑐫9|FɑCsӮNزק3 9BB :0e hv MSw f}230JAAY\Z-2oMq呺RBks\|8C|DV-qww KY^|@2q|&&CŨ=15O=.7Uo+-64R}zڂ톆jzA.ԔT Uꝕ{ԻJ^*.QUXzjeI[cc=ȳ<~ã+ŠFl/Ƕ`˰,{pX&v wg3%23,gw dgYq{3wehflוjF*5}eJo Xa4i[ Cc~";nto3T4@, G2 ~6v.'R_T&5oDtS l4:VDy1!}|qM؊_>w ipw}2Ţmu$fRR\SuU AOd 508tvh h m5S@ =V#Wh_گbk!.=၁Τjl(bWSX[*y|J-&nć M! !6J"R^`B.[yJֽYqi#[}OS|)Z`q0B83I)O vx>8FxjKg^⏉g\T|3!tnMwkD `\ (N^BIʹ~{׹TV4ŀCE"n(3 FV1@$b)ҤwA(}nځ Q8xyG7y̖u@E?pTH)G9= f04P%3rc?$~l?qyZҺRXD-%,%G Pu[Muu i98DʕVJ+\q*R:;cs|c<! fβ&{[.8rz&oXi ?lBKTe\ӷ{eR:uQ!$gQHuP[ tLD8 wN\*Lh4Hv=ˋ%q"e;}@E5-Uj*Д7>a45>pGƪ+f R-z7fPɛcD&nNrݴtWI8(yCb VYIz\ߠ݉X.2iķ~ 1TH}!Ǿ2\䁞2+UGIw=c7I B0GY9E!IXbuϚ^G24Edb?!|?\Zi9/BKZk7;ǷS~NRzUU#(q[R^vo聛$ɴS~}lkT[j,z 6_8FK Ob6 M{>ςLz +f+t FCmױX<m'9Z^( {!~GvN+Ҧ^d{MtooR #js7CJW 4uq."6Pe˖\>`[hN@~( ,ZPcj%禤vЦ└P],p@(OXq 9J([^`96GНpQ ฏDZJHbyFV7e(BtM3KMUR%oN_;A0ԫ*5^keYS0@\fq0L'Sb qc u%pve|$Zhvy}Pmt;NȮM<GGt'̝%({> stream x]MN0}NtbSHi nX"2_v*oviyO׭X{yiֹ\~s\Ӹֆt^Cjnʩymap&6]8N?oU { zG l ᱣg1R=& Lbxѷ{ }qqX)@#썂P|洧i1QLz |T(@*+HP2 DfȠ/' 6w yQjѣWoam\TN*y[Ojm7`endstream endobj 201 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3058 >> stream xiTTWoQTݫh!\L"h4!)j$dF)b(M2 NЍb&&1OIbKV_z=뜽:ڊH$^q1an}#&Ԗ4;)vL$'߷6;E)T"02aE\V52eۼٳ纹-r ׺,wuy/lSt&1:%,v{^.i6EǦu Smq%_?վkfK^(]l\:)5b(Ukns/-\8xIYM|(?*ZOVSk(/jeGS,(GʊriTSj"[QʚQ$*+7+KYɜer

L;ӥ 66W'5 ^3R 2AgGav`[Ŷ!h?~4AՑY8/t2EYGJ@` QfDkL=iO~^˓%SzYt3I]פb4nWFdb*;=| '?"/,`+$$ĮPi?3`豆n腏CC"Ց@_7NB~tk9SĽ}^h2RxL({=oӻ]=A?"\8L~gǦ|fC=4Bi_GdJcIMED;M|L,LTncЭwRhŠ%{=yE^_Ɇ&!ô\+Ktf|Kzjlv`8TO{DlYwjyeljyѢYL2 7H~q~ⱕ 8(`_);zj@k@kHj%ḿDSqX1# 1E bFE. eYΐ#k%NP]aPXopR_@q1{s }7-LFE7f^(dc^U3Z|y2]U:E WH[PB'cɉ \dIyhÕvl/-#CM:ct0&7^Ď0s;UQquwщ#9u|i-]w]2FnIql̖Λ/~[52{ՐWgh@$hZZx'{HcM#Bcv=λKD8n۬ Yk 3&Os]?BLeVvD*BxE&f=Tćf@ W3E6 vxRgzQqc^`X@)t;tͤUeהו6d%8/Pf'm RVmVgue݂Wh5n\?kƪ?57[rOѪzP2jCa@[RŲNv$爭`"'_|$5Di 3{9X6{:^<(Sꉱ+yˣ"`O`ֿcA+qH#eұ4rɓ6l:R3yNTh`I<RnF暑zB'MCװT ů8J_. oXjx t?_iN\lmxeYX2X{?uߘ` kڻApn3Ðnf,OF!A; E*.*DNxnC<Njz>۝VoA7t-8pգ}ߣ1sjw!F>7tC~p; Qǜ~}`=XyY[Ez@)`|x=oߋm:B"#r }8gf H \U/7\m9|\k3z/fJmM}!N Uusd{vOB2fC^][XEyEJ_\=*6$tYH oE *W*ƨ=M$p&7x$4RPQ/60dDRfgC!虼]*]ĉ<N<{BD};fq;;.a(ܻDz˺ ԓe36A)T dHGfJ$Jli[cv$' Wk\n(x -> EQxRF+Gv̑#rª:F-FeffU% $'d;(N9|()i8i> stream x]?Gᜧ H gz*WZ9p(~ՍO_>ޏ/<ֿqݷu~rnGmy^><1g}6_,qWoX\_:dP,rxAdʠ\32(kMe8ePf]e"JƓ )cA- jdPseP{ƐACud<ˠfzA͂uA]229sC-gn'5u ZN.2hn[er'&;٦ Zd/29ʠ&c.c z`dsˠg8 `DUFAen "ǐAYDnN,2< B2ܺd( ".vD`䁎"GȂ`de0,8 Fg,8l4 K7o_/q| _y ȧbendstream endobj 203 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5427 >> stream xXyXWD,Щ&%FQDQP4qAٚ};4"4(A%q%&)lhbqƙ[|E2WwϹWЀH$fʗw 8K*fhWG#0iSϛIT"qQ<nh/ZpWkG}JUXg~kN 7+U(}=X+Xzzmoa)Ze:l 5wޞ <^Z,Y+NmޠR3Y 5rQ۩)7jeGINͧR ]:%ʞZOmŔ# ZBmRNfj%eBMVS)SʆDQKM<(B) ʒRF8ʚ2VPʐDrIIEp`deDOekd-1}g˸g i&%L8񒩵i$vۤ2K7;o6`yy?*{|zΔKb8eϔ<5K˫xxTC!niZ*K " ":'!Ʉz 5CZVbZZ3A-P?k@ۮE?p)8GAMPxBWVAVXF;cUg=)hP=0e;+7EEUx;:6ZRqyp1]Z \Gmo=wR'ySLtNrQfA*` f Cb`1# ~|}]UDžD%~4 9k!2]sܣxQ[Vo"h{ݞ$w~DVa?e:u|oX˗.+`DNrWA*F_$<YJ0{hKSȸĔH!FĒ0!D"t1\8)n_V ~IF\G0_OAݘ#P_ߔ ǢPF&*hpQIb 'pR XqI^$Hmh@vd j8߬d\&{vb. _fR#܏|nú4\`/9'sPxLoڏf{^^w(zvgwCԛHQ"5&Ԙy#Ec ߼oJLyNxeY+M$6mQBqtlpF4ȃr:Zh(,d|t wIq& h0 lZE&9gMgğJ~? #2S>CdnxΨgH!J1x=hWH~x^q<y%5{9y L]E委@9tA& [hR9 Yc9%j9m(y&(+ޙ`TTZҕCqNN]neN . s6}']}Ey&Lѩ Ю A8Df؊wHuX7]83"w^dd\41:NWy8h?OpK8N1C&%Fh8nHT|H1 *e~nH'IBA{G?xVAdkB((0M^T=Iսc/e_׀H4G4vHn /k ؤ,U*_L+pj1HV֪in9܉2m11a&0-סFg~wo8wom\{$Z֡DB{A:9dqHIN fӋ<0) "`롃PpwJphYٞ5?8» 0<*2k,, %&}V -HEe7wiy^Þ<<Qo'Tx?XfEgw'fU aC1=&(V ڬ\×a 4bZӾTbʝ2ήɮή vbJ6VvǃtWA{T(ălG9/zpA"YE━4ĀwA@`HȍɃ\(bZë##by6yЍ3B<;9G|Iҷ}A*qSnT/M6zScE5Z֯ixW.^A6q M^h21rLd> qTH{;\W'v~A~ Ǔ.σ2~JubNr[DA*Vw#'ܘvpsx__g1=OMPg,0NM%.c2 <3r e Nf = wINx@q}=_X*_gs5qժԸ4|l誘BվHPl9"|b0^pLb8XG >F+t82ǑZ8g nݼ=,u8Q%tA*nB֋bTZBB:-1*+6;2 LhMzUmwѾ?b|? aI2N|w3{O] Mf&K&V7VW$UNO,^s)i頶 l }eF`KaUܩ3?ѿ} ю/;h{j2>$2bnNaeZif~C=謏{PE@HhOsF@0g fK۰u˦VQBU觭h?gXto9M&61-=-RĪ! RJ+T~p1fbb5eEES P\P_yAj=޾^[Oé~x"H,P1%<iL0ZNH’صs$P|b4v.I -H@t~Y31HSǼiRR+bPGw%`s|mWS* i D%_:4DGߡtǣArk?Ì9{Z mҋ[;_pMbAzzzzD3a5jmϻ/+bE&wvx;(,qp~qN'56A%w'_\`߿4R. R1|v@4ѐDD)<;hm+4%A ;h\W 0SuGg~BpQп7ێm??t.2w!ɫ+W8za ,F34'~眝sq\2^Aw_ܴyLaMwސOa t22'$2i՜ >9BfBBU1A5kq2Z)N~է6e+x,ӱ$jՐdèlMrϴU4СR#2e3Ϊ5;R :Й~OAZ^b-q/s;\44Pz0OD$D%)`cCqmiZ5kty,/s|{vM0`BT)qe \F$Ud 8DA.KJI8&P܆{KuӡVwN'9}/땊sJHɄ$7;BN~y֓Izļ渄Wy6^%k42'Km V;yW{䉭+ee, ycCWɸ.Ĥ>7(6å&(Hendstream endobj 204 0 obj << /Filter /FlateDecode /Length 163 >> stream x]1 EwN@"uKVU c"DWC[>|/> stream xcd`ab`dd N+64 JM/I, f!Cß^<<,{$ݟ3#cxzs~AeQfzFBRWbrv~yqvBb^_~ybrvF~BRjFbNB~BHjBhkP{h@`| c&FFk3^eXP33~~G}iKw$f|[Yw_/~7b"k .~|];y҅?|_8{! r\,!> stream x]O10 ʀЅU!Q(bCt|:zyH st&XÖ fY#u&Ytdp;j5 k3Ux7vf+%6Vj%BAPbGMSR-]:cE[_7endstream endobj 207 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1189 >> stream xuR}Lw!w`a~lg{14S8IPNJi`m)` k "C)gCg6XBmMe&l˖-_ ȘO|O4h~~_iYdmج2 v- y9Dc8 (n K8 >ZDea7xGϓE6a19 oA'mz`%yy~P]oV۬TghlB鈠/u\s耾|M6}&k֩glltMOObvfj,Vsib::4:[9ShjVnB" Dn:BG ҨN9/i~ '7xuX<ȷK*f)* " Ak DHlBq=9>Tsoiv sb %CQ)wGo*bM^Mh?4}\)Q E*Fn$} yc?hLIԌ*.O&\4S.~U705D D"˾?A8%,b'n'HFfRwNUC_oKvIq QjŮ&N:n @{ʭzcOx$1z 9 hb,h?$P;^dOwOB.>풛Ƶc'O֪7;Gwp*X 3CVu.*!@@*qo\8 񧮜cv p+2=]2TG wj~@6 VB61H~=:{1kiTOaRT( fpSFp';iJ~,K*<]7.rm!gC4ySgI=C E7f}~dݼ.9z/HҀfa>,`"Nх˯0 Y!5dNL왙mߠ{k @*ڢՀ(9-餞p;A /r)> stream x]10 E"7 , \ 8@e(.00> stream xmkLSwikWYd9'A%.,yC{@)Hm r@[~=--HQp3%6ݖ-Lܲ-[1Dž-|x/IHDI++ uEɦlV-W$Fį6?zw Ĉ!Fruy9BLꆭڪ]\Ϥ$'6S&1iJQhJ$&CkPTV0 Z S,WmlavdgِTAH{JED}b; 1G%ūŀʻůq<͑|=1vϿyLQ?tbXQw )tGf,s\qFot8] V7>x\w0^JU+x^OoCY-slouÅv4s;8/7vq"rЁClAf!az?qOx6mv95NǑ#o0{͎6d ; "z_;3q0͇OJjMh`ƞeʣzzA@fozYgܙ| Ve0+ amsJq,P u@mF,R=}܅ >0 8[(o|w=fg [[SJ:"H l7kUQ !:xq4B}NFOAB /?mUA\ мA:v{w{d F9r;|W%Vk{9I@#ѯ't<09)hQi>tܮLa@ >q(O-eȑWyZq@7g=4 _ٯ~vBIo܄E8T&f @AIG3Ӏ.JhYӃܲ˩e\m!~Ĝvz#vtΘg ?&endstream endobj 210 0 obj << /Filter /FlateDecode /Length 230 >> stream x]1 E{N IaM4)v 0\#}4g->b~s> stream x]{PSwoEd%!ݛV@N[u]A][,Ce WhBՄbyHL]SPזV[JGl^vaZ9wp8~E ݗZ<sW=paOoEz|<^QJ5^q9Yl(B,^!E[DSsù9 0*5=7GZ/JNIDr(.(>v۾Xю}Į ;aKR'X;;a>H <:oe v|K%oL~lG$^u6IARg)߹7rK$.|ߋph9#f8⢞ g^$0>k{@.Ø)/vMnz d~ {#%NlwEi&M-@DkS5<°Xque5pڻBHb% qQ֑lv;-$Ǣ)gшz8tp`꜊#81:@O1"}z4'Bxӱފ~ *Q8G3ʒͲ rЩ ::3si .3d鬚$Iu<8/]O}93U,wZ:T܊.$E"h˲v-52)fvC٦PiäD_ԎK} z{vX<{ə =M4eY{w>4>_FUVaR:@]R nAtPGav+&d8K#|23Tj"ui2+pAF5O*3@UC:k5 vh8SNrg{^%|ژH^_ƣ'Pޞqr_c6kLNӉZS|g)@*endstream endobj 212 0 obj << /Filter /FlateDecode /Length 191 >> stream x]1 EwN SĒ.ZUm/@D !&Co_$:ofꡚ3dgGd,eG-nׂj6Xkk-ZT@U$jȓfTdlxѵ-}]spJNQ~T\_r_Yendstream endobj 213 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 906 >> stream x]oLu:= ٦wcK )L\1*d8KhBA(ڕm ,(($3aK^lₚȲ rK4xyAE|əZTU}a[ID߃L䠊~5M5.~ODrx5T[]\^355Chvqy&wp&g%&{wrUV PWxG=BH =( )e@q <7N,$-sEX$XIgghg0耲Q_DIϫc6d'gQ.hfZIwx:>w{n{4%[pB_dJ9ߔ ] v3>:;0`iL)x׿;wenݝ#KYI#%)谷:7_X'57VWV+t"-~eabwpur/XG/{@њNSs[puB5s̴rq$KcInpsc :Yxӝ{8Y\,h$onck  ZMS8ŧ\d8{RXâB{KX1r9Kcn_B̒xb*_zlmS@a/3ǃ'NV]5@E=m!P-Jbz"--?9WU`CZykm cGǝgݍc9 ' Ow( L|\ z,xP(=Rłhd8 TmDendstream endobj 214 0 obj << /Filter /FlateDecode /Length 430 >> stream x]ӱn@О_?x+4v"A(h0ErvdHxGq˶ӏ6vY﷏c[ӥv^guzmkڹ.}|Ɋ>\qǸf8, q]>v$t( fHg / ]"N 4SfAzD(@ELO3sB)@lQʅXdx9*1Dr4ʕP@JT(xr%~+([YG `QXT0LL{JqmU ` ` A<{> stream xXy\Sg־!r)(@PieZZw*↢,J  aINXd.Qkj[[,[;qZZ;ewA̴3}_Ir<9#lD2fMP߰ų6(}#' %wRƁ-K~ĉ ゜WcmMH%A*wU}An]0ksp[>m*.*do^5v۠6U tSmb۪M<b$a'#b8J̱9!]"m1qDTTkj A_rdJ'CqXc01NK2ci:Xe/8\ƻĻy Oy;N2'PAbqu:P':VRkB#cM#i''SqU xLI7ϨY@: R(X*),n,@#k*HZD&0266_Q8W5mmdBI*mqBSzWPu) Wִcp W_ / ~)w#Wt :l4`-<ǭ=VVZFub ҩ_a#d*C;\VN(L(Pn'@iPi%U;t" EԼD\.r]kC9S{t adTCI <'1ˇ|3Bʓfxhc9!t# sK*de L]$ Do }aR$b3\EKLJt}H&VRJ 㷳R4%Z4 }&ԚUixV-q(Ȃ[.E^0>Bm9fJۃE&KhZeeBm]yEmO6(j>y>`b?[f{pVo?Yk1,ͮjo\rC1BwtY90TG^"XyB!Ɗ]|0|M^TsI0.  GDW qd}Uڷi:#亂\-">{E7bEɫ7A=4BQԄHw %e5|mA:hRDk3DYXז l"_38PՒT Q}vSPҦGE1z@]*' tG39 ;U@aXv+Ւe6d07akvՏROZwzӅ a>SBOAd&3%3u2T^ MP)BXq r91[VHH(4]464:@bO[=[â+eWO$#4VtNUԇvߕ K(Yt lJψm@]| MEsot],:lQf%AQW[[yoőx 7<MCvHшg`&Lmx x$*p%)?yXւlF#H_;M2<毓ѨO:+k)f*\FҌirW=_ѮЕsXUc+Xl]9c9 ^XK‡v@SCW .,AUVt؊.NB?Xff]gK >S|E6"Gˊg#zJ&Vzztd^K8v҂Nc<ݖ9)z6c2J !H=^MH}O!6߫|FOa23D=u 2 oPKn(p0_p:<4* ֘_olJxغN3LecD8FĢƂryjMfQ x+;Y:w8G3rO᯲ШК%_da؂=hJgQnىG^nvjr`NmIDoNDOL֦Qr!b_M }+g.1yjHrMJф0_Ϲ>s}@2!;?],b>MtB෉zP<}R?.L@ǭ?-oǚXWE}"xvlEȐN\<[wo'h:D-1WcnH\G:SQ6Q:H; 竏GYؽJPӡ5 u;^Xl0>B+'O~#bX Zc"죈͖R@g~qٱ?f=CߩtT`H8Y]{oXੂ "WVҫؤ4X=b&$Npz):! "hY}%44*2Ԓ"b,Nɱ>T'B'2 tKkނ4j/RXcj׋%vkmÜO,(#DB(#۔ *|n>[qJYq 7k_R g>͙[9ʢ7F%J.Zz Գ%ytZ0lᣇ#TC+d*Rꑜ] q@_NCWDͼ1ܹ3J7V)38g5=WyIK^ުkأE h/IХ^j$* 7^'iY`.926FI^6} 2G12=^eHi4/V$y0KՂ\lsz']V#2o{GbP0S Z>_.OʀL*vJ=<%Z ) E1hY<0e7uל1AJXQx%f˭/:ǔǪs8IYmzhaSzm w 7eW"|Q(+5ա}:A n~Yl8|XqT˰Nq崊܏ldVu޹"snP 4 $g`W".x=NRאSW' y9"x\6a..899Sau:ѠRwh4 NMcʔamuu _V2W$?q.KX+lΔen/z;9 2[fdc=#j"Qɳv tnvV/7GRteOjdI=O@R #xw+BƓx 4gL-0_C3lً }ۅy@ p5+=ȟLy>UW! K|$-2~$s˴\T (!W©A jSbw}G77X* +̩"yQ݈*5h1rߵ,y&s)+;9_endstream endobj 216 0 obj << /Filter /FlateDecode /Length 441 >> stream x]=n@ ?$ n\$\^. Z.r`)>.wf5rO?knzٖ}\?vٺ!˥޾>wo/m{; eУᾨ^ϵֺ3kWix]? R9 ' &qa(@hW Vv qq(@ #c1{, #~8Qg3DžD?s(@cL(Hޜ4Q;Jw# )@r9y lǰ@̷H̷D̷LL[0? `+)ylL{eh 0o5 `~ݶR.ů x%PHX(^`x(@K ,#(OYz Q_?m7F'겵ӹ_w_շmendstream endobj 217 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4327 >> stream xXwXWuavDb  Q=hDD Re),eE (IP) 4cű%k&;s~7!H$XS̝ m0V$c]8FhH -!VZbS}"<62( Pim;}ݴiӧϵvv QBlmW+޾!A֓a>ޡrkzzknkU/ 8L,JZY/t Z=ti6Nak7s, A|LH%XGd“XO8%4b)H,#_+;‰XI$fjb8aF%!%hb1E&c!&BDI}.:5dҐFTb4Hkk̸\@^8IZ)ECg -7 1y:,k[Ӫ OlUss;u9ZX4[:Z^VciwZC_a5"̈́*Ľ jQ(Rd(%Pz0)?N"PRJj(6-KjQHp-*aADסf d+_ Y98PCP[/u2lIւl(-,ؤMCI_['Mpaq㉹^F}FcOP`]k fEIKv+,&=YɎ0\7ok&Tqp]࡜ A*i?bclu?+K[FXHeZ(8D׳^U f _~06?H3AsrJNAVPghcTȜi޹+ Q UTYA*-C{E[낰Յ(vf78D% })k$ ThXվLjEzQrT%T\W9؍*j^j)L @=!̞M D-F]5,Ā=w}Xd}yϑLGXC e^K_7jȾ9Iw^3h!jhdJk`E۳+Pػq Mz`BPar#D =ḡhA‰jp[XWsg$xaKG a8J>!#>|ϒ+ D}@A ^DJPʾ1 I9QT ' b=Y]}(+#Aw((A_SpB@9˰ xe1'װ0^ ߴ}n7-`ʉ +"y>e6L7k^4 o"t$o=dWW"S8 jW㊔㝿vGB0BVjPn&geAN?,MO@ȻRgn'~u]~ *,%s)(dţt/9~e}9uFDo?mJegis#*SU]^Vb',o۶~g;3bAm'G;Zf.AA\y1z/h.}ăVk%'E fמM$:y&0 aY0P/OM* L!kPMFCEAJ1h5 . Bφ~.62Ahw^=oE%lK @<.lfЙ.@B^YP( E^njDN@MȽ.|jJnm;U7:ǡ4!{Kat 9ီ'_n~E}K=N,;D?" "( ) iZci Ud|Kg,|aB+\gZ_vL̞옓HS"(t5ZK#,НlؿÙq~L`lÊI4@`LZY/r{.%/OdTwB*JS[y0T]@薵N_#ܿcY؊Z@7кyxh1I92[*俏UF%$1:ģ :ZY)/+a{K 4ͼXnVOc^#0~cY\( Ä>G.ɁZXX>R޸]LonMjN wִUVT3JODNzfݻ'5D3XE? FT鹆~`ؤ؂goSR1C-=XÖ?^{Qg:8 {"h1UI ONzʗ%[x+:XPz|ѫgco=p6waZ\ǡ\Dh;~ޅ}תk' |kSu| } cu.ѥ™Swvym`plŪmުW]V[6=W?DapE3OM`tcL?E (L.A Wl $s@m\ϣzZQUe(Jsp 3F%GB M݉w&76W럝Ս+u\uwb!^ ~CC#,C(BaI!,(Ғ ?11Z0ZRfffkK3Tgfdgh3N{7endstream endobj 218 0 obj << /Filter /FlateDecode /Length 1202 >> stream xVMDNc{gD6R Tk+X#٪ hl(>R>ȣ~^k<:|6:fssN|qE έuv /ʮVH)K/~_2a+`IKv0Kϋ\4n)_\gMV(BjtƄpq>TNxaIA+H+DKVg$ gd O ^W@+Ejb]qgaG~,:9;sv./&܏hz1]f|1%vwN)@ƥG>HjvWqګKRBDl^pZyOYq"+H\ $_WCы \ J-8>X/}\Jޫ-q[rEl~w6ݭuvvYlf6fDސsC C gCpp:"!`J }|1N!j>jn )$YHCTXZv>]01C N[i B0ex'i:FX!E%Gb^$\|O轇qB)NZĢplZ|9֗}5!N %ȀFͧ;\s4JmGy<8/XtZk߬}@I?>Cl2ٜ' MhWjY49aplEЎ6#9!ƻE(JH=q*#R֔ɑL~ Ϟ]&O' .,Mv ~JUR%/U]ȋ ׌`#4۪hv۲I^BFQSp[js-:Vf ߼|5y-uyF G0g~=m.O~endstream endobj 219 0 obj << /Filter /FlateDecode /Length 297 >> stream x]1n0 EwB7P `pI -%:p/$:<OR_|:i:/8mI yJlM~q_2>JPQ,O"GvR򿣦}T jBͮ -@hU3@:H/S@j@ZK v 6:l4&6J Ia QhdED6lQG-@b`:BܱD!6) @=5OuYf9˼h/Cendstream endobj 220 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2957 >> stream xViTWTDl Ѹx:hw}fkhow¦nq 45"!1dd^njs0n3z̯[so}˽Ixz$I._6!.4>P2eĵ*EhGz_T=!R𒀗Wڡ(}0 BHHrC\„teltLɓM8ua &/ ߙ3?4>٤W&O_?(p@%kW7?7ۯAΏOXLNQݩ&*b51XC b=XHl&&&DXF,'V+KA'CH7d2<釲_Ro m^A Tݓ $Ȟ6A.[9C=2n#2e 3ICLG2&l*[5 <_d\A Y Fdd q_@MGrYxA ܉w.nMJgPvAȪ+ XQCwQ*8tؕ` $㑄 v?Z.k,~XrFld[4Ud7)Z 3x(~LCUX~g<h?M,so!u~qMB%LH$} Y"#4`sڝxIX 84j=ֆHtMܞR3GBZKšFЪg^x5Cbq8SJ@3y;E 9^/ n|nw| 򥇈gBB{)hhyY{'vt` ВYh A?zsx4c|Z&l=[ i~H ݷ}iq8TnK 5@D _tap ԏ?'cm4UFOPloF{?XbL*!ɘPrWbDhDN<)a3ڒĺȂe޷?|hTn1nɏ(ϗ1@>dFMQYas6PSPIڧv^14|P3 KnU 9`q*0\IW 60+ X\Φ P?8Q}=*4; hyz*ʗ~FCJݚN=?*2 (Rv % R,~,ۄ8S yB00*|)_# @" `%B9' 1lw/Z.|;H:kRj(M4H1Qta1%8}-Rdz*O6U\B¿Eq (i\>xR: hz } h~;Mj,+ŋlL!x؟" +І,ECIa`!Mܒ"wɲq/coG#K0iqG ^}cH:># m-6J24|[l1X 觞AY6>ڨ l̠8_f`#hsZs>]Btq3ҥ)Aǥby*oE2 4KzFr9nɠCĖͪ`Yq0㰽Bc>hY8* 2 KFe -p_1yCz.o)M?IuH:x]e"E&G)Q?@pIx'r hܝxj짋EUTV"TWvzmm#6h==SX9_4oD}T̥HWjVV}AሬI[h͂!o?4g֭5lY+:š)VkeEECa ݟۛrTGlD:M(VB|%cBnLLSjՉ @$ZI&ζ^**9_A)ށܠٛXZxsoi:SeyBtib+I|YATєI>/>e/IX?l CR~ם8ȟ}vTtKW!ngs4EB>o3jJА`bi}u_zuĂ24$:CTXGPң?ف:|[bp*?þ,FgzBI֣&0q\$@4d i*2չ:<{37)]BdC'>Kg]]!Z1O`!9×nB}=>~@|a)>`%-@=N=g_srk>Dߩ=}Ў.|;X$ֽҨ2*R*k%ᙷ-.,CvL=pu ^]fl -E/wy{6kA C,endstream endobj 221 0 obj << /Filter /FlateDecode /Length 193 >> stream x]A EtJR2ݸBJ0m]x$̧.ev72 wq$'z$z%}tuU|۟͢l2I%=E퓺;.͞^:*6=H4!0堐 52Z7Tgm]`Ww)*my%)yʧ`endstream endobj 222 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 953 >> stream x_L[uaX/.a.E6DIL&sa ecBA)na Ja׸%N].f$ >w dBy9/CT 0LbQqlϵ60ZZ;sR #*^fz %hTWо )(;|1~OFFѸ'#UͿl.7ten5i;o14&z̫ *J*woj?MBTJH9$$ Q0gŠzei7"׈LTbDۢn iK I\t )|!Yl~=+ݦ0 a=ԥ|<aDŽ:uޠS6y90pZNH<&%5g"1]W!yZ\X" (!@mW&%Ե鷠G}tWn p@S 9ayaTd_,`9ݝ}3h?akf :1b5ۢ?du<$MJ'mWr%2y>M,:fT:Ȧs2~J 3yiDcvCblgEbjb5w1[^?Lt Up Oуjԭᵬ{렖S]ZMQap;*&g8ާu6/( g_Cfk >XFE}+Ol=qb \jrou1R,XH1JN2-Y \n<\;K`(4}*.ώyQ:˜&^װT>8bx8UCeN̏8 B''GQ#3endstream endobj 223 0 obj << /Filter /FlateDecode /Length 173 >> stream x]10 E"7HH`@YЪj{8(NW[,:\> stream xmOHaݦ 4<1,NIVTRummϫsӜwmV[6B^ cC9<=AQsRHBEUgv9bqCV>FU 5@潼u&w*CHMQ7n3dx\g4 ׃/p3kvpa>lh56͚v|s^ucwZqWSn4]j8e?!kAZ(ANR(z󏾑|%ʮZAj+a. fu,ЖW酕 &OB*I$<,:xm)xij0>gcu=ʁF6$b$&2M7>L90by-V; ҫe7wo״3v<{¾㶁&%HY)nkF {%Tdrb6VzN+׀V* >ha>tv rbh;<8 "50]t* ~~0XCzbgū r "thFn/.LqdTWyAL> ѰV|*B,Ę ^endstream endobj 225 0 obj << /Filter /FlateDecode /Length 170 >> stream x]10 E7hcTe)K.&NNGI)B ߒ - γM5&B"Xo:|EKnzx#LDm(iHtm: +q!JTk Qk|7KiGD+x+<[ ؊7wV-endstream endobj 226 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 450 >> stream xcd`ab`ddM,M) JM/I,If!CgɏTnn=? ~-[_PYQ`d``kd``Tध_^竧_m%Eٹ% L Yt_*{NƟ%DvV[]R{l3v/$#hUOK|W9=y;dV՘]wNǢnښZFYu~>-YY_]S1ujw*ލuE侫m2dqsjkK|g^Z=[rٳnShl;vrq1p.0gbτi<> stream x];n0D{7CmE dji0ErSxp9Olkͦ%ϕF.ٴgM4Ƿ|9=}q^g(3NfhL S'.i)Ȍ#p@ QG dRD I|M>HD[RЊ5^W6>jiZd븬ERl~sUsaendstream endobj 228 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1433 >> stream x]TkPWސYy nLZ3L^1X@ h > D(0qUG@YֵSi--J-̴L =9`Ø]n4HnШ2܅SP!CW.+>P =/L($"t9zuzFD& I!BIxD:;?ȃc%;tTԒUlIJjJ&ѥIRwKc#(G;c ?Wðźȼt:.^a;][azLm6b1 &DX$6$ ]" 'DѢvWUxc, qPCA)$BUk tjа{O~yRڃ!= ײ6<8(HϷj49]֐JF=h;AsaK9zz`d0W/<$Hy_/cbw[.+mEq#$n6u(JsS:@ y=] ]n_kkePVXvMxc3HR0&p]`3`JgЏ|y?5.Ku @^`O^Sh8`= Z[1X]42YUoI35=eiV+7FTk֩z쪨z%|Ԡ=IWU9p&С;a:ZF+[hS~Hڙ sa@eJZOXr,Y-6>X(ytIoGOp`4;|5Gza|5O8I4Yֽ˂nߜXl,1h@FA fvpi2L pʶx)8 J+1p rU Uu'_8CBꜶuhnfP4R 21^ M<540p{h!D)C\z~tmOO T 1]fN 9 Փ̟m9]ZVoJ#& A곲lyhFY~/T2q+A>U5Yeč[$QIvI9;_RޝpΏdd;t | tEђyKxc'36` fٺ\X7 1ꕦᙥL 37Amf㠙}$^AOqh.ngߨ)y>^;=xzp.n5{Xс|ꗝ-Q&D-禅GXfKgݸŴ(N\Susjvw?ZYUSav} dendstream endobj 229 0 obj << /Filter /FlateDecode /Length 546 >> stream x]͎WE9O RkO$/PTݲF=GgA ymk}{o?<^p*~[O-yc9ns_͗?K~qeu^Aüo{iquRdPʠ J,r"rqAYrʠ\s\eP7-)2sePv^+2xA=XdP3VLM5jA9 j8dPGg쭋 j֫ jU5{&uʠfo;ɠeQ+2hYԪ Z. -d2]dmAcM-ы z~Q2EɠOׯ2Wɠ z]=ohdELj*cDA1 2?B1dy,;D8 U 206DƔAd`2 `?vd0wU#{Ge0w F!,"*cȢ1e0wǯ%k$үs\<孔v-#:v6endstream endobj 230 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6956 >> stream xYy\S׶>rzi jZZֱjQQTDe S$de@ešCJQ[=8z;H[p{ۻO(v{-(B Lz}ݺԴMԬ-)ǽ2p.oBߝ|_njvN$q+ir3̟p/ ܝ;5`čܾ?,hG\T}rSk;nc/T@:hSF\zO!70I!!/IŠ#"]!Nv(!!/l6ڇo{(LD Q_@upQoƍ>q 8@bQy #%>L:RkJDyAA/˰뛏?Wt|>͕߰֋"[g&(AYN|fqnk~mD3v.{ҘgA7,ѓҘ.ԨuŠHm X8ON)~<MDOqɍ.Xc3'\v "!2wV=h^BD5dye4ٍvwQu?It0lY誀 Szy}N_G?du,՜ <޶w3B:lO H]&65i'DcH0-oF2iOqp;)mOъx yrD/] /Ö>׮ooE/*CF|:h8\cO(\KDBGwdzsM]\cOԻ)Gvh!ғ1]Nqvw\Xۋ@MQ.Bz_*o| eKWZ-H_nS;֏q D'I[e4o0F $!{ZHmFr|DU>ubkI8KYz {!]gkɓQԻ!r_~-]Ial.+Ie0lF'+h;T{ފ?oiݾ( cٻm䒐\mK$JtyuaY"OY)za%ÝD%$MU$:)E) o#_dϞ[Cy h~4ϏUm*|Dl[8|\QROjMĀiKh@[OoB` yqzn* " tuL#\B ɸHRyR"kK*h@z(ߎa11 :86J J9M(AO/q<|= ~oDR7t Љ^^/c]pS0t&r7h8ɍW*SyBNMӐMCXzO$A o?dKgyg7[Jb-jKQ *-lu)#^>#6*$y^eah0Z Zc+w?{N2\P sRnRAB':[O "#Ǔ=S'Pt/| miv"\C6]^EӇq-lY4+?z7̝9>X2Xw*Wmaf`?f 7מBh 'K߼mo(6Zhx25}^ _#†opv+9Q W8Fdٯh JnHK{5; A]Τ|Y~6E()X\W*u=z _zTh%{jY6A s=E RasPtNo:-|qO ¬mŭ- q_U贶R8{T##`3$&83еC:HtL k*y\m5h»A#nGl5?Е?:xc=f/HHv-kecY?_uY;xYȏR EPxJ_BWXQP\h5DS;Y hp~GՋ,-iiڴhtL?VST'N/ ^Yq&w|@c0(6d;41=S#Q` bO3>YT*bK HHKB3E64ULɃR!3Z`N9+K t8 nnq1-ʭ D7WMNOCBIahh6%jEZ% YWpЋƕ]h+ b֏nd4ICA0k? "FHїGA`AmBx ā"ףH"1GCB[T{2Avk:)@8 9~NpKOxNubmT IZL~d&.U]'!]H LlCbeHyqⶡiCPͤ $09\EcǏ>Utpism "@ OثʨNdHVeS6rR@>ug->:qH~(S &zwwO;m壢 ND*]o̮ZיYƜcK*J5Fu)0&GV֙II2!g.0v=A \\8?1xLXZI À\eh& DjPi:lF񑩩71BLP foo.uPhoӄhaJhŖ.PCC }طoC>?us"[w4Հhmӄx*Y&@uh*IeimB7Ln4!J:l\TXwmXFVert"SIZØ yP UjĐ(rEHK&c3:%RSmb.Gμ*uz1t$R~i%u pb |q,4r@,hF/I 4Bi“ЮG=nvܼzqCaE ~d?k (8U:"zT`̩Zm6s@e@V6El{0#N D mX1ʯW|u* YNi^[N)uBчK\ ~=C7 A\%;#e=9A+H2%2nx Z]nY^Ciyg~>x [N:##&q(lmD' ~]h/Y|LQUY.%|uz?uS[Ϡ<CqNe0_.,zAL-^sfqZ[Z$URPA\zb;/"Rv JA|(Lqd_pPFQ@ } N&jN@9yE\ ˙oDeia vg\oٟ甁 t 7jE}MiW8)W v:e}1WdǓRq`tzzN;,5D6#~ + s5e|2vQ2grʊj! !j>⬪Js8lYYdri,2'y&AU?ѓoJ-&P%مR> stream x]1 EwN@,QtЪj{bLz t`K_~xgEgh [BfϢ`=cn&?@%w|˾jKk4HLSnZJOD ypK8WJR<bI_/S2endstream endobj 232 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 327 >> stream xcd`ab`ddI+14 JM/I,ɨf!CO&nnw }/=[1<9(3=DXWR!RIO+19;8;S!1/EKWO/<19;SA#?O!)5#1'M!?M!$5B!45(X=?4 XSP KKR3sRJ Y\Dzh)ڻf^I7GWyUkIOWwGqcڦݓ-*1C3N3aimOc;u[%$s= 0a~DýzOzpⲩ< kendstream endobj 233 0 obj << /Filter /FlateDecode /Length 3547 >> stream xZ_o#I#0Z!]d:]:8$B$C8amAPutIv?k~U F`_m_|ZVWWK `1"ג2 uBW5w뇲S'4_kꤓ}(SsmJF ٗ^nq~u*#[ V\.(8piQ%\Q EHxMٷe TSVΑw#E%cFGXU@ 'Z䜝EΆZgN$5+*Iv*e-0(ԂM8IF&%)h7A45 TPLq mRA2YjsMD"(wF<%DA\0jy 4Hff z(VI)yc5?el~mPT 䊧e}$~I}h1+JҔq>MP#%%J m&O6OmR* Sw2%u(Ig&?ԚCW!sJ˝#~CdHo `ʒK$qʐln /J A3KuʂՖ{l/We剸"YYI)c{ŽhN_{%osq<&DPNZKMaܣh&.}!Q)nsERT޽߸t\(BpG(2uΆJ:.q7SmO=EdYj급2'E65zA U (W$ں[ǐz 3ocK%C1H̴!6)à9Bq -+'Ujz0NQg̘#7!4Juà"u6 5ךѸ6;Y$ N0< 1L(b}Xo(sFgmpr"'eL>?!!E)H}c1O8~Tq>u7J^G-&S<$\Ԝi~_8Z3S3N˗a RW?1Ғe.9Vf{}Bj;0 CslvwYWjRͫfeyVVB'MkJHC2ypYSS"6+} "WWQ S!JsFA!'Y!WfbC_g^z(\YQl&c aSmzEhM/Gn8˔w[>j 7!qG Y9-D =!C;g˒"5EQnXt7&E c)#P`Y3g؋V5㽙8 Q@^a^'0 K/J{l}MA/zI'h ͒@Sq,2ʍmsWV <6? 6mh oNbMe!mvSҍir游Ŀzfk[XGUÂ桊c)8rLu^N>0钄ƶLᅹ XF W} ꄉ%|CS[A+±E+Xkfi3!?ri+d_[+l>jEbzp:9qp R@@ ij"ۏ%5:ewM_tT(c)+'@i!(ບNBOf\_1vS0ϛ҈Q!~Ÿh65uzbnBR'^biLOhYI(Wsޮqy}U4#\UYSrZs8`_&x1lȏB ׍$i Y킵.<;u<u% o>_Jcmó$8d g|+L-wqܻ9щ)VvfV$%uxqW8;q.nZ$;@=ב+:<,Inb 8Ƴ>oxVv_w7m۸mN$.jTX>v,^JoCMfwdEn`{bhi}XDT]bciڋ]$n׫oc`5i$bm)Bm6+`TjRP5AqX?E-_FN!'M滳2Z θ/ KE1D-dѡ4hl7NO" aLθ.>)(9(C|/ݙנ;7{yd}Q w[^("~du>z]NlY r7E,ǻ,mm|{H*'7*kهs|.E*C{5[CynL/ λl{o~`+c Xo'$7!"A~8i\A,Nj ,HΡ:X6n>1ye7l9/E>ZS 6̐sZ,-skw_3Pv3Vk?+*3&o9}}}VirP'I}F/=|&u?? }|!̕%OՒa8y+FEQg(R( Ќ*(5Z+b4!MycrtI/y4߳yjɌ8L[CwYG$[v// b Vfao>+Og E1:T #+ARb//((flQ ju|usض~a1WhvǸ/SߦrPB.f0kO+]rCj64UJMUG3l!a\gܭVꩻ3xFfx> W-_ )I/fLpo71MyMHM3t" qVse+oh2@g{{Aʨd 4y9R &c6RIaW8{p7n  !Ǯ _"W}5NLM(\~"\:'7"Tql\ɶ-uCq=h\{Oſ`endstream endobj 234 0 obj << /Filter /FlateDecode /Length 9423 >> stream x}MoeGqճʛ@Ѱ lV PU{HdT^'"ǒT@A2fFFF^ƿ/ogQevg*%=ӟĥťrz۳οolX_X<խחa s?SKWw7/rN[oe۷?NߛOo\Cĸ5Kvs"-Ė5ߤ`ʖ)$G[l?OTzz:y;n!j6-gŹxY?*qBazy~y~{;Ã{FeZA{Wimr:*T!+_m[MufhqQEO/Tz)[Yq)g7_71VB%.gR_R ܿ^YZ gqYМbmKu), 7,f[t*H[K!l\e y)--gAz8.ǾQBG\6_Q[Ki]~ $KîP2-'r$piU cd%Y)mM2H3ܒ4p>WX<n⃹ŤTprWjP2!~!7t.I+w9ZHC dx -o1Ʀaia}rk.92pU4|eȱ!Ԅ&+ 2.џru-`IPRg^ f:EjRɚN#+\2ՅK`uT~.*CFĜSE%)0 Jw %i#b)},)pĀАJ%'~q֔Bϋ^BrWD)7,SrJ,zh)@$yYR%1]29tфr n P)Ƣ$"%G崄XCRUzL #"8:m+dX9C ڊщr,Y t1u5SG-!q ĩ9 {B=RDE#YiR'\th%=Z&J$ (IA%ZbPI" )c|OTjRI[QRdG"#VH2!cui -HlhXz-]֍~[;\E*_X51^? &DbX(JeȰ>>34эU83g )R(DZ!ыIo-\ Qdg>E+Jԗ`-s-sn=8$Ŀ5'_"՜8 ќc 4އ1$'BLFq^xH Cq"ɥʼnzeuSqPYDMEg(N Qw:Mrɐ8pZÐfdrzЛ8ИHNL1zCbVoԉToދSo"xћ©7QgquM7Col&S)!8T'٩NW:xSBzPq[9U'4i^DC9Nԩ qNpjN0E'PR&N%щ0N'u1E' `ڑ$nHoN"O)N0BVuBfT'Bd+:ȉNp L `\f+:IHVtڧ#d2D')l"g+:+9aL+kNb P*:cӡFǴN(G#:ɸ9 IS):aNbb\Ct"hZCt Xщ:hNR] 9M)kNPsY)M At3E=h\`MN4z]t):a߬79Q籔85'V ͉:Fh4' T$Э=#9E'dmVt1 &$StB2Z34ȃ4$LPKd!oN緫NRSlT't䜲IzNf`1e'B٪XԝD|Z;Q+Gw*iW O38“tX$ሌfHx OF >/<FuϺӋ!RM}pMJGN[̲(l%5O}y}@}y}@J>ž}@x}@v?)D?c01C:t6zL Bc*S 4)j 2Z1 Ї3ȺOCu]AjS T4$M]A 4YM*ө #VRݧ C& Cb #zdk-S9MAFp # 2HBddYBE!Ȉ:ǺA9uL=cD1PjC!&^Ǩr8uU*wդ1Y&hZ??rpڤt*ўNjY y}Φp.5bdg@鿘h咣[k%C$3Ӌk<$d8e+88')S%V'(q DzR:ztsOTeF[#89K,KZ}>zk[JY5z zl̊oOf_'c۟=s5 g%}?$ ͈=K368ޞQS'G\\ɚ,rNXRƼ,:躓&`IP_uf'Md_W7 R%H\3I;`IDC<&`Iu)Sd΁4K9  揦;`Iv3>[JI8$ݬL*p M3D@eCUƾ}sN6J]5擝t׋$c>|~^!#r7i_ribQ{4/Σj$~H~BOß*W'>U zKK|8je~&H,j! jv8RX4Kžl(Q7d8p$ Z-i! ;#n:HX's) Ȉ4G†pXR p$X'K#UmHIpd4Gbp$۰vTE78R|r_qMA6WX('HY4WC#HEQC#U& il%'5v#d  XR rLCHh~ {܄f<8ReiC#UY@%U p$H6 8R@%5Onkp$ώ4[p$U iT XGώ R@hq~v@e#<8AC#:`IQ7Hp$r@#a?gGɹ$tnF?GJ2};H䇾$I5v6?;Jc#aV \Jpc%Rؚ#8R^4Gr`I.d#l48R%#5ـgHp^K®Fk'㳣D?#Ἥ} X֕ ;HP]Jp`9'HXm8H㳣d4GJeHp$p7 G 8R#'#u?!Q<8ROnc--r(4G64ώR';HjHpܤs,)l?&H-bÁ! r 7G k4GrːHGGkp$쎲U0KqZ~'MJw|'YN?`Ij=GJ ;HYHp$nGFr[ XRI@vp<|Ԣl 8H]d,F9h8#ᰵ 8p~ 6 87G*p$ıŞ%[ώ=D0$9:fWvng6UczzǥJ&J%w#}/Ӌ+Z}+q+iR^?Muz զ[Ц:j =t*L?ݱ>>ikgY?RpXbW2mБSFNE[.Pijp\Ƴ6O9tE4̑oȒ D1s{s-e8X`Y]nY">@@<+n=2 qˢqŲg:9"U䈌e)YR(c$@<̣e)YؙHxN#gu9bkYd\͐pg㐐q69g5Z">R稪lIq\eY8Hq#u=4bY8HxvKROH|:g%W 4.,,OY,SY,,L?ij\2`Y 87g1,l,E!'Y,k ^< GcD<+auˊe%9EoYi\bYY@DM9mYx.$t=l ^ǁ,Yx>,:cYxӑ8#o:Ϫ\`Y8VMy Ӄ5"ٲhlY%hq"W YּdȲpg)YxE`"^t@dnIJ,nS,E<ɒeq;eʼnxy=J5JijrD"grV-O呞cg1Xp"U1KjGcD<qȫ|YD:Nt^'XS=PZ6,(wOJ%pC=Q9[{XNV춐cNc^_7bbob_!4ߞ_%_S[Dw<4z Z _u0^V\ޝ\A0ݷ0oKAJZ_=yx%Wwb7_|'46L^ ]ڿ•&Sמ]8ZٰcX*qtwۦ8!Wߣ;EY?Ӊ}}}W)q9N}uMҸ;b Fӆj9e_O BOW4.(8.hgv/ܫq}Y]ڸj=\`|8z%x>΅s9XI?e /p9OL$8<30W2|pNmz6.I' 쿬)mגKź_4|)߽?~ۃ /G TC^p-[$.DHӫؒmz/on`MOߜ_$DZ+5m3=vdkv8xwݕ$u}s%Hu}'M}!7'xWRQnǻcܓ^{s_q twUzjdߝ^V){%Mg7 (G>0τاss~I b5ƝbzxMoa ֫:Ҵ֖NKWy}{胑w3ڄo`[ԥ}">/0]k\G%~r4Ƕ>q^,Wp~x}l>M?!*Q//pq騲$5Tnh10jܽxwpwE.xQ\z.cz_>amV冘A-ftQm=ݙѰw3>=Sa5Eu}ت7Y4U{2;p.䐇7kM+L/s}gݽtUmڑsǿoիZζ{VZw+u#x=@3oRӤSCDiWt~!=/*߲׫틉a{ux}{urJ2KmO{sKiA?|2råFŸUK1#Ӽڟ&7W^r _Ɏ~-s{~rÿGK?$&[{׏]~v{HG n-$z$|VN%qy_woe`*] k/CʏW~%vh5&MCO*T.tt߼!0tjx)E ,m{'Nةڥn'Vl!V9g1eCYN#ޡ_`[bjm2rN.uaF[;sA_YK{wDr)!m ҶS!n.m <o#^ډB\&{|nR3wnoOr_/bRMGAlƠ/n|Ey^}ys> stream x}]%q:O"/Bv1?"Jɐ =\@;;;mgz4w''>3ͥHA72322"ɨ[}EXyo/HWo~Yya߼П%Rn=ś_|ui빬^]u~{׻Wap_/~T$t˼勯_|ſ//}%έm:JA/n\]s-ļ~pCZl?\l6Z|?^^X9m9\LjAD}_uzo~o}vw:z>j}ww>{<OKӋ/^|r/[\¯|y߽{xZϧݾ}r>o_=\˫Oo=ӯa4h~|z/Nj2|-bZ\(Ǎڒxyz/[-9l%q]~u+)|".".",EL-͋Kr](2o/w/b cY I[ S[m*[ @[HPh[ 6~HEmxmxc2m}NU7孥J[.8mma.UmRVTiЖJ[&o%.3oDyခɈW S,[ L Z$I"Dq_ qJ8n.LԶ$[0Kz]8֪u4V%jc.K@\0**L)m29 Ǎ34  ^.-'Lpr^XTZYJ{ْv\˖0}KՠZI- Ր@xzءEUG5ZI6Y53F?L迢pTrC9yZx6;"b ^[ި/T(n]BS"&3-ʳ[ [^{ko)-#mUmm1/(ˮTKl!%}y!lS?kjp Ix$琰!a0利I Tymܰm+[T@qFA[s $D[n&EVhCI bazƅ3W$3%e[ @͝B([G?$FzB"NuSyyayI$y,XyVuR(āQ$]LpNɟUŲF}&#-\Cc`@NNe\jW#bʰLTtsX+V [gI)RBsh *_TTRi D;mZB;'/$1 ʃ`aKfHrزL{PRm-DR0b@1Ɖ`p!) gj? T2s,jFSIr-rP692S.U>!#td䙊`̼q\f6]ʅ`Ī5qRQ%gKb PƘ{p݋D!`֘mY ![bäQ4hG2 5H)h10w1RIbI $U4mFMޝu@XlBf{U)}qL~*ITT9l1D&?sTdBRX2nƶV&%c="FLT9פX"AQzN8 icd"zp%(..8fTJIU 8?0A0JK+ AtU}!,G/p `F](Im؟իK5w1h5%q=2I)x $*&HX ET{c\H<u3Z]>:.8jcB5X2&pjd&qѴ}̰GrPx5{.Xg&3ZG\zlsNa$2z2& گZی8\wbrpanpXR5!Tq~&ElqJaI9d?UP12jNbkHjs/y/5!pA5v^s@uI%Lݽ1 z9bf(DcKw3 R0I9RRժ;ۉ]L14 iǥ\1~CUlq96q /Zcg?.tR pDrr# ݤ=!qԠcN䜂{" U9qS GKS̡?-e Xrj,ref(Nκ\KS2gxA27$glcx[p^Ta%9ιh{[aRBNtd0_9ؐ" ? TT4Vw##ucrWOFM`0 * d8t*^enUbun]!8[ah3\e8r4\/*c_"U%]1v1rOc Tzey70jٯXRνdqc5cA`p*}%oQC~B >l+ AE NDE$I)ZzHR'vF6ĜvփeE#EREc >l -9 r 0IPzE#]A C@1JKa$!"Ɩb&M]e5ȥQ$2^@eĦPDZUjv( Mj6I%!p\VɊLXH-%ZA09YW%4GPTRb9dGCLu)&sWsI[\ &iK w/(94$IDE"Ae65Zod{25MtҝO-RzfI385UcCRV{A`Z^I6{V=gA$f'Q$]SHh?Y<&@БKz3 S% w!=5UMuܢH'Dd)?&U, Mg-wX7=hyp}.JBd$MCvoaRmL!{і"fcmIR ,'(=o*$UH&V`=)[O*蒼~# ` {.aϞ WHLQD%A d>ZE03JBhUUX9 jT]N+( b9+W )m:i(\i` QU%1܎ 6h,`OA)$x(v腺V0U"'$ r/UejYAf3d=$uHȣz1S0.2|0*>bXrfƹ;8SZॖF3ȇZB0_y2tROQq>Vhe+ӂ,@"?_EJ0KF!f_g ̂$u0K Ma Aar0#0>CtlK&'a'!L.b0S1x`--N&iarAOX0PhfШb%Df&93@Lߙ&;Woǃ02b"){# l1x)fD b)uc&&DfS%yF1z eF1drk(&vI ,ȶDdғ0t~2YK7aLHͬaL8Ϟc bsIc%.cVm PU$9(~QLXVpԨ1F+dž1ocr\1eÈ5KLX Bd"sd9@&f sl1=8&=8&Td1?8&bqL23#@&Gd"7~Y,(fMΆ(e;mX (&h5-b`E*91P̆iEܚF3 ƌH)2YCqLFpOX>rudSqL8E#8&IL^qL8ӺTme2qLR .-Ⲣ5_ c%ssxBLgx*Nxe8uIջorL{7{h7_{chH ]{y+)R6_wo]>y`lŎ?xm;˫B~n˩-}kW7[PH5l8WDT|y" }f"'yEAIw g Hޣm.9*NES+fIP[ЪKhjT6tBZs|SU\ܪJP:6xH[k:C+K MLrl]r VIwɱU0}nU ^dEtɱs+OL2 ,욽K<2ɥsZ;~Trhj8N>[V_}VӾ?8a<_RpBBPQI~g|YgZ! x:y}?By>k+5- T.1\3鹦@@'Q NTqU ;Z9{-4JfuNt('S͚tR4)̐LN :7#rR4:Qשu{S7΋dVEn Es}dg:vJ;xр th g^4НGH3/:hE`EC2vB KNĘZɲ\-Ӣ'ѢW}ECRxE*O-:-/hBiѐPiѐ-=vZEOECfZ(EDIFG5j;fT~EsƾuZ4IhfQfZ4 ~EgP̋FslVlwJ^lwJkD1:'6R3tbt~C9[܉)}w%FWq9w*N6bt&M ^tdZhPNt:/:S2f $K_]1Ԝ h2^4. ċF"]8/z'H^t:8sg#/:w9-%9-iZ4t2ʹhAL&:'so ]zƉ:WՏ;HѠ(IрA D'EЙqRri&ETl)ӍCJ3+%:+ȋ9+bh&i > 2=1Z4$΋$xx2-%FcJ^tj4$NlW7qe%޹јy5΍@K)ux;lFLTFAW Sp`F׸eheQC'F+}`F?P +tp^t ^8B4K΋E#qEȦ hjMbJ2dТvEPL˥6;e~ ΗӢJbwZt~E#RQHYх.`EdJڃ NwSKu^۩eҼ|SA:%eAN qS;':x DK2stD _F0( tZ7VکfT:%z\D#|&+98Ѹ̉ĺrV)Ϝhl{q8vb %'5vfP %N|]JN 9 I/3%+% bDK-|Dh"hVioth|hH|hHM|h8Ƈtj$@bXE]\hPN*ө:&xШ?]Aג|,ӞpK;4hPc9x/6x5'uS4 8z7xЈ̃fmU΃ҫi5':xLNFzXiFFi]zӠk Ɣ6t̓XU-ʨT[h jΖӠQRYNƝ}Ӡ6ӠqLF[giM*h M4h tr"=s4 H Vr׊q4mfAK̓>[q{5'HLFP5ND$hHTݬ@CM4U('q4q.oĭH^DՍZ#yzG8<7ZƑ<6!y`#y eQp ycF[{}#MNPtQak%wPu3'3Wy@l<\`37XQ(b3$ԁ:FP t$PoVɠw(:P"ųC!*ErʃhCy8bP^5ʃCyDCy(Cy;P"H{/ AyrPBVg(o 7!GdAyQP2TڏCyNǀ*(r!S1;s_kп8 V_Ʊ<$ykD=3<$(~_j!PҚPnpCy3+ Gj!CyA(#y"ayK<p,/cНbyQıCy=PU<̧ιCysPlΰCyX2#yz*R;'ZRg$l $>ɃYe"CZʑ<\S ؑ<!yP}-H^,đ`yѳ+MyP2Ay0CVȰ< u,O$<ɏ<c#ȇ"GԼ|(r;P Rg(UK]87h4CyTŠ<)GȯʃX樒Cy(aXK֭y"ȳ={ꥥͣ Gp(h=3_摺sj !2c$crJ883gF DoqHO37|+G T#"TA '~_AT`hzX0W7Q=w=T7BtTo8m72?P=(VrTóakT8 e æ 4XuFuLi ^wz*rz4Cu#vcnz*JdI`xzNE6B:zpsToԳuC9'_o'>aQ=0Tu((3ǚP=ZKk|%W/dz,FdlIN̸4\QۈZ\.,"ߚieڂ}U^'DUKD伄$zjS W,j7YSmZ-t[RR7kbk>53ʐ2劖V:lZZp Rj7SݠyO9mҸK*7cq̇}zlK}{[ThkT(+JB/׻޾}j^TtJzq~C!~+懚kh/Lx4 :۷Sw?q9sЍ˖y*4H:|a:{OAW!ԲN' Ӵ>%WZ+WKRr$AMSt$k/pl?N%]75^ݩhLs3Tnf&ܟr^Q V#(/~\e.-sßqz/R=uW޾}_w纏 THk86aIfŬS;*l߆z쿜y`qQњQ^ OzAۓEIϜ#/ltmpYK;NfU!5}qbp]7ظ '=C[+fG˛ߍxWcLǑ?~г[r<)y\b~ND#OvV_d7x8k5Kp݉52_0I-z"27{:\gIhT ]/^!4qA ' Do(:! u7k8 oG湕ՏvG@*3Krl%8/SS,s`hyNs,2JIcBu <>̉Leux繬~x_ # :gq78+9BL=ؠbY D|X/oU?-})^`7i7dt3ny CgI[;ĺU~)]>\j? +M0s.Ku֛\0M.glnFj0su`=zqKwT*Ga2oz_ \ON$gsC.1J>u i*vlYIqVmeaNycy2s*XΞ8YyƳ e &]+%h'W7i)Yzb;$yӼC&3~b}>A5X/o >ѣomFP> G>{;ٗq5d>06&ۈc4FCvjt~q?ڎO мg>矟o.іX7|V0T@H%V|EګT#v7RO'#MTQjGG10{%:|ElGzvQ8qs<SN}s*F!F:ç&&/z3yCC/=7"*ÖQEwWFBÙCW'=?{D=z^i榐ys9i\Ҷ\ ,R 77J-ӢapgRh7(L29g2X N8q y٧}sև[=;LgW(x{'nƜ1}tvo'[s9͓+Y^9up8/1w{Ax]+'s!jD[B^{:F̟?>z,@3J׼M.to0/'jGLJy-& 14$yӌ?޾;mq}oMa!PShթq)#oN[-գN=$9 @nPY8QLަ&uK1Bj|v|!yO1@Џʼn.ӿ:sBN ?M'\@o,Jҗ.삧t|#_IP$),$ x5 :?O ї"҄`II-Gd:b ܥӊ)~9E {^Ov>/&m09ׁ[/$-z'dC}@Qm y0n.;ԨuDqp< >?8u֪ip8=澾?xendstream endobj 236 0 obj << /Filter /FlateDecode /Length 3641 >> stream x[[o3 6)a=3In q'(hPLRřٝ!h.]\;8`_ՀW7 VgWNO^S!=V'f V+-x3Ó_O^XиW'St(,x'$;k Y9=[דRw}N6ӴWαt]_8xBڌ Dpl(lİ#x:Gavcl)wcwM-G@&Y j7iH%%py+6E%:@z-Vo筎bH\z&s֯nE[a 6:ƍ_o^$VD[ǭӹ`r 4*ZրuU-58c$ k9)Lf=^Oa-[\dã]c^j4zIJ .2 NW nnlyJT`E&WE:m6BAzis3(5S6ka8>pf)[z5FSefx[ru+I.]Jd,>HцN׊.ЂquҞH?8[!WInRk}P+BRdYC DZsE ^\b,S%Q4r^-؊NYΓz9}EX^K&Z`QWZyF՛ҁ-{V?ArG8z ]KkN\EɵalK: EӢvtLyhyc&dvAqYJ?6rD,ZmWx_v:9%@l5^n#[O]KWȻGJ&V{>]{k󦸲5pWن߿DF<[&W7WҀ\]Ʉ/YRpwIh\ ?褓,5]OEڦut Sr,.ӄ!_`hZOz99{Ɗ[jNjTEA 4vw$_FG Fuݛ<9ķKFZh4^菻bQk:JGL$>b|dOe/$M:3>,9t &woǻk,[;ˌC@ 0  h@q'Ap*aQ'5{aC`H` 3tW]az3q8+{`MB)Q;689E>ఇCNE Ԉ=P*'Bv&]V/.ReRŪ:“W1)Qp1NyO&TC E#t.=de,r`4wu*4U-x6HOV#:dO!:N.Kt)iG0H=e4!:̎ 7`ݱW2o%->8Ż^˳-_ ..;ɥMu-nA(B# {ģC `mrMwW#2zf|yP>t֙ Tճdb(> stream x}]%qwia6,OWdFz5V h~薁ROMO1M˿w03DߞI`Oif$<)^^^偞<{yWW)$k_˫'/n߼u}S^ZuZ//4/?#zJ_]-o>ޤMtStPo]ߨrY^.UJJvvL7_)zrd)enESQ㿣p_[@IVE&oBݿ{s_;ݿ޿v7w~rZ&rw^ɦs +oA{ytW:ܖD~F|#/|{g_|q}?G8?gOGGymON[^>8?Vv=-Kg᳻>]n><>~˗ox<t> ڒ[o9?^tWwO}!?:/_'.K8ΖB?<)WʚGNҧ.N>qqWYr_s=6zS6յS.IZOoNzzuUZJ?}wO?ʧ\?]dԳ K {@^UNj״.vFZOj֔7%"4\vw[1k3S¥j!y5dmv҆kؑj2u-{Di8̈Z^7iH^E3#rҖvkqFtH[sT[_U7=UZ;!Vl@^3zcD)kʀENZ-uGښ5"n:#3RZ8pkF25YS8#eHkqsJ2}M!r_]=DA i5x=iQYeZg-DALTmeFl5W5 Eg5qd-3RgDW- BlMZ͎8>>!- H^2"3R@u<̈*Rִ2Tؠ:#x)̈Ɓ{T ȠA0uƈis>>#JaLק2FK< Y&k-s: 3x?Ymm!r\\\g9Մ6eD!$ˠ\OEu>m|W.ak)*sPIip32^ӱ ~O@K`` 7~Ҥ oD_[& f 0W edzFh3ތ  ẍ5D G<͈qdo fe*d\Dgdtnx{3bk8 ˔M1ϒ5)3R`Ft0 &9T7NTHH͐Hք@P4Vz8hZ+?+ͫp`; !LY;=Rp*8i8!CY qZ7C m(LJ%16TAWlM!8H>#=9N+WV褡PW \d<*c 91] XZ?2$mIe ƮTLϩL26>#nCe|=B2-!*3^@,DVU9{TwT:#NO+!9p}2ep}F*4m@#CM5K~`祴)L 4/Cb/s:T ǀ9j-A@RFs^{dx$o v*y@oKn_h!I T$FrANQ[ܞnFsV"r>izsMHzv:Gb7n;Su+?.i0hKu]W0N}z*'`Sy+=9K#mSxSM@juytpy6m7Job6Tta`󹈧HfσSv Ʃ *{T ]7hCN%z p wqMi( ȃ OE¿!ZA h9I\|>+NAs^5KpeÌP_sp57p} 0pν;fp\%z> KD o*xPV>*pjIC 0۸:(ssώLZSк J'0{kZVMZk3b@j <$)aa-eZUzt:k ,(ҪME|h3 d~` 72 3-3AР`x=hڃ6]X`Okӻ6{ ?ま)I/>ӵZ ̪i௵_ z =g|://9h䝀=nnL^MEMM0u5nk`&ejj\MsMp!3suKU0qPw2q5+WƧ4W3qPkP bL%1a⪔10 0Ui[>`L[g~\KPcZ1N0mg$wT-:FƼ%Mμ՚ƀqǁHfj&Zpqy 8h\kbZm'o5B Twy(*aZ,T$1UeFjqjU Ugⶠôe&`ⶠômaӕ69EjA S@fW S`nρ=Ϩ]q{ A)^tl=/ ԂR>ZPgΚrC6&fY`ROcp89%% + Օ ԃR 1*)lm).4&l0[[֖j)Ȯ:dLWABѵc–f Z.c&㘕ڲlY[L֖ e۝3I\ @udmWdmb<&8|m%3_[ T&,n %HVV:3㎻`r̔mUl) dʓ{gVgA 9)pVj4xIP6V} X :@ؖa[f1ٚN5w:ZZ'VhF̝w֚+ I3cۃjXHc-ZZ̈́dk50ւj砝'٘G.^c=C@3c:Al5w=%&lOz„\@Os/v:LX1 ۓ3a{j砶zV=flAnLٞlAoL.ds] ۥ0cTR] ۥ1a%-|%qK[cVk/t1]{,${1pL^ӵBWaZBSAnrWe!k t;^-5\k t誅骕e$j@W Rꁮ% z R7a[Y9D~i`kkZ$h-:D&IkR&#?,TI;ΤԘ&BJbZLZ+¤@zJa-i2i(wV޲c1 83i&&̤*,&&-㠕IkUVI=Z m@$ib1iiU7eɅcVXM?8;[:Iٖgz jlxq\:Ik3c9y sٞYLZY/ +I-P@n=h.G_-.j'm< &͂2끮XOa)S2֒%k`Cl!=-Ճrc2y ю}[1[ zS[B* 9B$;sa52a=+sc0YMzpc1Z>INv)W \ri%].Ak8KH~^B3⫗|u,gS1_5Au51a5-$$ys{ jk Zp̄!٫j[Algא Alj`X큱Ox4M_8jkSkk-H-oAj`6Nuv,秘=(-C3w -Pw n<gb%8k8kAlĖZHsv jggg=ԝ{P[8%p+ϴ`b>m{Hrvw"䖤rKRgI%%[a`gJJ6VRr"jkNdNo:"jKRV 9F[8idV[2g6KDp *+ +)IJ$J$l1: $ 5K‚: ZXoI*Hh 喤rKRQbipډ /:T<4y͒*5)h%%ޒT9YRӚ. K8Hj4T=e%I33kKf550ov:f%I9yXXe%ޒ8YR@&ʶ(hhNR끱b=Ǥf:/0s ,Qrk\v }wo=S28fvtj9xi$e`Z tz+$Yt5 tB9LWdfI]]B,$qvd8uo[ݘ69&<#ҏ:n8:R`s*/ )GDf_c^Q6+k3 &~DWxLǜ,+3-fs}cr /yivk_砝 ϾJ"L`G|@|u# Ay-nA9Y8(0 |#¥$T9Y`ѧ2ga'W I[ڂ9-x󑔄5Vs NA|YU9L3g bb9llV-h-UNd1g/!uꁴ3|L.]i{ 2xz>]i{ *x 9Z Ǥ5Nej ƹ=&Y y @Z,&ǤH%4H.5i:K.3g>{{I`s>{JApf$lR q6{|xLXLxAk`,qPNe1eee=-ߑqwY8gdf5qyZc1yN29&2  Z ^wcr*b.wDXܑ5XqP R qPe {;堜,0p#؎ _;kGb v9('3 LecK;p;XXchG)I~v*3-ucV[p#DU „9Χ@XLX@XuV0c¶7;;5±܂sq*9@L;ꈫpti5:*Sx͘N90 P A9YVGl[fuVV[TGyјpdO]p`QSIu0#¤.; : u1yјCpc1Cu4e:b+ꈭЂA]㘜,0PЪp:mQ w:b+*/9&x1[kYp:1]bՠ`LtAg`jYc*-遭XF10 L֚ڂʂ']Q5<阮-,x1]0 Lr8L꘮]];xqyvax1_ZYHg|pcZ HDŽ5Na7 B tYY׌=Ly’0kbG,f%[`:Zpkt@C`HGvphLG9&/qLZ4&#ŽH ;:H :pё܂~tr.y1!`HG!tZZ8Ѹtrp `HJC:\0#F~0;AyјN9(g2 脃r&;:H ;:"-舴r*CUc;:4`FǤ̤ EGj^tLZLZ VtcZ z s:&m?պ-D~zswӫ+~*~~OJڶFKrz Pg;_#aaDRT !TRȹȲl}d*ustz~۫Ng/O/ HxUʜXݮ'|UWOܮo ^-Ht\$qz?Wʉ r_>:Ƕ=X:w2s2c9ЁP)RR;BJMW#/ 1L]<6ߞo,뛊5z>W0gt.0r⪤(+Pi1"׏sg, 1,eNwHˇo.7^nN/^?>]"w3zOpPN:Wԉ7ə;0)ᔲO|^*˫u@+`b4Np8Fvʌ 1 9)%tBތl#o aBo&|[nj`adp gdwddP5`Fڰ%d?FtH߆)v.%V:>>!=Vz3#~n`6l?L]mR4m*Α'O%/@ESlBv_α.1لm;!=q<|è(MHuulL>,\+>y> nHOo [#PX+ڰ"{`)?|`_>Ҷ1ׄ&)Z&&xtk][WqzهRbuwX S?b\,h|]cUc Ɂ~Xp*q0bE!KrGj|_>!\):\X}.p,ŊΑr39@?,J"VՈ|f!sF\,Rq\4:֜05%\XCbHaMHtݖ=O:؇5εNJPâ s \>,#U{ 2Pa]DcMt\$X*YS#C{s5ŴC"cu:V0ϵl d*L?$s|C>ds#هys \Α/!>"+||**)L?s#%trsΏZrR\ )ΑBO9c|joXh5H X=!:ґv7-ȑf!IO{=5}BZt>O=ys ].2-"XȡΑQ C؇`s=\r$_-9rv GF.OfJG.9)D@?r뱉ĄC„hu=6ZGʫr`M\=pjآhk]$rLC{*LJoHr$ꡌ2y`L:?6-u~J0!x`B$H unw0!{ 9v~XOZ?'CTF5?OHCao v8OH @fIq#/2=Tz;N?w̾vOzB<s\p|Mvؽ́sƀ3.JB7Bdsr>! i}#CVt+|Vc[039t#rOLT)|Hfb{B,od+ #9H\> '\e$C"[Èl̈!݇|=|z\p;Rr8rP##W CMu$]h, sr'pd3fFd˒mֱqc<NqmGF qqc:uRîtb[: $vca9ȵjǮq,j^=1 whn{O۰Jo-Jokb4tOw-z@@^g֭D"1#[y쑀H^B{bòb71v k @?L n_%Pͫ3PBcʴP*lW,9t\;]lub}d196ba+ -TDMV\~a1!\]-pKW QU;T -GĄHc @=?6y Lb?&_ U~l0!=`Px_RrߧRCF]"Ǐ} &$N`/"rC!-Y;|'zO:G/: |CdWF&' i~*F#\Y+}$‘-@6*)\c ߑt?|V[û{B§)ž=DG9C-=dcR%ڇ_?.uFΉeRȹH9Jfz@ΥW'%KVĜ`4뛊fo G2rG8sRCb^/[BoRciK\JqZԁP)X:*R;B`m.#T u.Tf6SiHr(m8,H8R(ۿG{WLߛ?R<%!pZ*_!sq 1svWpu&nߍC](|In+zq\t77:qey[7UtIn?\({EQ^sy\ G@jn['|qUyMɋ,JoQm׳? U]P=f>ICy| VOXxHvhINj^!sZ8{RO9n~O۲T1^?ӻ,X*A\*娄??@?Զ%JG'$o1^lMwRty ?xmxk.Ӱ)(KuKdPd|دV0WCb1C;T=a<=`q;`VFY;񥘟O@"aņE1#\?fx$]1VdUG5Katg(g3q"lЋO6?0JtxxRh,d"SjD.MXs.϶?SGIaw3<<:ER9~*X!YIdOt>љ$Ύk+C!;eދʡBNG"xf_\0h4= ϝ ?>Xh'܌{]_B= ;/߼}u )b˻GrqॱN;D`s截^ۣlGzr;qW W.Qhv=cbӛOpٕfcEQ{OG0ˮu!~ \qMȋǼ;4*a -otȲN]T ,/n_÷44 wGak;2 ѠMΐTw f}/ v k۽]亼}7{-7]hWܾzSƞ C73UFcT>RjA./էSTD ~*&<ׂԣ?~=t06SK3;yૉ)۔Ĉ۹e/kcߧn)Ø1wAyy]yVhYO~f7|EV %JjǬ(b >Z1_^Eַܜ5ْm/szlն9\(Q4K}3pӭ.7k_# *Gv||QY BV%* 6S.}op>-UxN}K ǐZ*%Fw1e>㪼6F }wbN&zA~|=?6l;o/n}soz/֗;b.$e .`üzҌ$jdqK?*~5_>W}:]̳K~tY?u|wd7cP~,$;a[Bk[OUO穆텞{NyQʧ{$6K ^F+l駚y5CPj~T{&?'_S3<\-X/~LiЅ/^w]5 rє^GֽvcB6c|JQU]o`?_z3'-uR뽁\t3J{g6>Yxcv]HR=rPry1ِ4(ir8~L¸.K(L6ʼn7hwu>U\/~P[+ -j#4 y/OFyhZu͓3\|"ZN~kXóo~w!,Wrs~o}8TGޣ-#n:|mi VںWp!D0FЁ=noK}P^f+XY~{|tBMw ?'.8)&je@X1Z~Tu9\dU4dendstream endobj 238 0 obj << /Filter /FlateDecode /Length 221 >> stream x]An DxLcKoM FYI]<Fp:.W+ߖ{ |ꍎsX_JpEu_~ёӦ?ocF7SX"ߊ\}rHqpNf$0#)g&3r`דrÞ`7iId B`H E# %;Qʿp* oIJҜzVmendstream endobj 239 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1344 >> stream xekLSgӖbz(7Y[3AY&LDrh  鿧-ؖAE j `ȖeQ FY-{,eq߇'GIòyVjp#4>9-vG} P [I|I0+cZ8 }tdp\p&u18_ҟ?_B#C$Ek?ĝ~l[Xly\ھlrf_Eu:z. oQ~0#1zˈ '3/OY1*4&lc^Fy4:gzYgN/N*?V)EWuwφZf0Vƭl*g@YM)O9 LӝXE'~A$>U K! LE AoWoWQ`~s0R8uhAo<*9d[ӎڎH$**0*0-;W*Vn~q׮bǀ ,ͣ"AwNr=u9A?1)}ap{>^˵Uo=FS2'=:3@9#~M?ծUjtRSY,z)bP`},>oc8l6O6Q*kn!DqQXyޢk]blǼ6bYVsL-0 Le2 6YLشT#g40Mr;1gNTr.RzIޞM&mNgo^bz/Foȏ endstream endobj 240 0 obj << /Filter /FlateDecode /Length 163 >> stream x]1 EwNQ)ʒ.ZUm/@b!Co_Alr# (laKH0Y|Lb'4`,$EՕC, %3NsO:;k)?-M-%\I+ILgb%V|+OS)endstream endobj 241 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 412 >> stream xcd`ab`ddM,,IL64 JM/I,If!CG_nn?~O'[_PYQ`d``kd``Tध_^竧_i N L, 1mZُrgc~;h[UwgmEi~|BL7GRɆcV}gU~]7usaQ)]֦v nΥMI~ ߵ(9aZMvsF}\҂YVq4],jes箟v~?N` cr\,!> stream x]10 E7HR*T]BRǩ2ԉt(i`K_~reA>Repm% F< ݀vMrD,m9Jo! hDT9 b'VjuJ&qx31Ēb+-S)endstream endobj 243 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 379 >> stream xcd`ab`dd M3 JM/I, f!Cnn }G1<=9(3=DXWR!RIO+19;8;S!1/EKWO/<19;SA#?O!)5#1'M!?M!$5B!45(X=?4 XSQ0>###K5|Lb޽B~)m/dX?%vL.nno*=CЦnx }[{6tԵc;pBpy{&*ۉ ;%ij7gm}l_c+]yim-ùor_<<[M7^]endstream endobj 244 0 obj << /Filter /FlateDecode /Length 299 >> stream x]1n0E{7c$4ͦ"Q`b b"fv7Egawu:r}_g>켔zcS^MK<kNelK>kS}kmyw6<%r>1͏f5wYfhjVF lYHvɱE[VjE;VR @ @hd(X(ά$XD+@TIVЈABb$ڱzV?XZ>x\-]K.Ŷn2esI$?1endstream endobj 245 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2654 >> stream x}VkTT0]23*Pbl5F(ʨCQޏAQ08#b&j&KCS{kDMl?w:뜽H{;F"8,Jo(ۓ!'؉N7>^%G)8ڟ8ae ɱ[t>>/{{yE\>S"!#bs\fJB&2Z5FY , Z*xz0 )iѺظ־4oY2j&Yìe|ubf=Yg f̨dc$=\DJHGK }OA"#6Q?Ű4:' \i<4J}{3q[܅k`p̠̆ruq)#ZE:Y6C+0}қWIrcL!~%rVI]b'+q:DUt=/| @'*e(G9@;p(_}z'NW !U ec=xG!u9?B9 ōc!(QN\fkf*GʴCƥZ&t6Ȅp9㻻=p_ZM]\ZZ8)#T#gT] V KnU!B7E\!+τۼ. GORK#uteT\L5;olhiiÒ L^[Uhsqze(7]vTKyAyſ}z?oa̯׫?%PQ|Rμmt&P55];y7ahy&+a')=,EV-NĽ 5jřm;a3Qp=q6,KI['D1lqJ' &T)z*\_ >&w-n1VS(M5PILpcYr9 (+-U\yQ(we}6d+P,Ƒ/\Sb˛ͭm=U"ms  ձdZr9qlO:[6הAn@L828┉i$uEZ^aTehiIݗvD%3ɴ F@kӠA&L~3@!JЎʢrt4ɞg]xFqMON] \Qꡇ:TYrWr|S:)*>rCNAoXLO@GZZxA!A-gTl{F5KZH9Wy-[P`5W@;{$!6!^*D^y{<Ɖ,&eP)%.ѩ˹]Uทpw_LFeN؝YX'Cj@]Q^e0ՙY{?;5\-]%3p&0[NJO̶tF*A!=o/Â:sܚ׿:ƺR`98:i[J=+iS{QԅAV Y3q6.2cH4˹?' MPr yZ?)% Y_s dܸFt^{r*L28յtޟM}hX/vp0gW]*JK,-2$&C&nE= ri .n \/Zs4'qb:'y-9\t׸phY'` Wac]E~'>!W#F>7p0=g I|YhAXd]-3>]:Zs>OHoǔ?$ SS $PWa9l1Z'%. v~Fy! jnO:_sVFP5BAs%kwh͋YwsTST 6_1O!]8Z*qF'up0)_fhkp~5;TAZrq-ON/wJN޹rgݑR ֿ}z.CT7C6sc6,L(*qgЎ`'nng$TQڗۧ"CsuLo{ Zx> stream x]1 EwNP(KdhU1&bA }I-YedAS'epm5l &= zT;.& 9\M|#Knof!m[WjaF $;zAl#0g)S)qR"Ε}&XR@l)(Sendstream endobj 247 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 286 >> stream xcd`ab`ddM,M)6 JM/I,If!CYyyXv~*=E{"8fFjʢ#c]]#KJ'=Lļ/=_=L<ԌĜ44`נ` Ѐ`M=NCe```d``XȢ} ; 0\OtIIwܟwl%Eŋgx6cqbyƩ'Zi!=r\<'N4aB${f> stream x]= wN QdX%C2$Y eD)`h,aMG"$佫ռu$lDZp[o`y>ՑB&XX64@zU"o%vg#TPo;Uya, Ӂ@͚`xo1Ē|VTendstream endobj 249 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 620 >> stream xcd`ab`ddM,,IL6 JM/I,ɨf!C<<,{\"={3#cxNs~AeQfzFBRWbrv~yqvBb^_~ybrvF~BRjFbNB~BHjBhkP{h@V2000%V0081D2031020fL?S*?3weu]-r- ͙~ROn8eĥwuOXX9>UlMn"~+V:U6?ڸ{}sW-4Hw?oﶢ1[KK+$9җ^:;Ӣ;o<ΖyLo=医|kÃ9˖m\oX{MJ95R-+9~xϭ7%7OmͱfYety}dS|o̬ЈnɎ[fȱjVI~^qZ=;غDnqءO|\.W>ԩӿg[u[%$syO_O 3&MówMOOO=< hqendstream endobj 250 0 obj << /Filter /FlateDecode /Length 162 >> stream x]1 EwN@K%]2^1 B޾lr=(ul"m~H0X4-N㪃M'`]$EUsڂFRCo ͟TN TJf&#q*$83b#)SS endstream endobj 251 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 355 >> stream xcd`ab`dd M3 JM/I, f!Cnj:<<,{$ݟ3#cxzs~AeQfzFBRWbrv~yqvBb^_~ybrvF~BRjFbNB~BHjBhkP{h@`|FA&FFk3Y2/ɱq1hw[svn]{sktY`hccO{irwl߲Ǻv_}}֡N/}{١=&|87u|\XBy8Nꝴz򉽛{'OPk{endstream endobj 252 0 obj << /Filter /FlateDecode /Length 402 >> stream x]=n@~OqfExݸH$E. Z.r`)>O wvwmzݖ>uzB:I۴ӷigo]얶~[;)h-}vLk #q]ڶS~T\_3 3Fbc(@Ǟc)zL %qɟ& &1 {(@VP\< {|qyaKY(޹d P(@1z `~*K20BiFL*L/ `>RlYwd+aկF P}(@jGT>Buu"~mo2wqW@+}ڿd^յm c6Ӕendstream endobj 253 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5166 >> stream xXitYX KLQt!B\- -`1ް-dڷ^iY7ްwc,!fIH !+$ЬM{o=#l4M{s{ѯ9|>lBpeGNvE 6$g SCa01?_Au8L |ޜʦ1.!Y#)fd,^hɂ-ZR˜Mɩ|0&Yiᖅ1[sSE˜9☔Y191ٽ3vΘ;vo9og 笕n,*N\%`zF]Y/g_K\5wmll;6ۉvc/cOaEl>[-b_c Fl [ۂ-ǶbaӰX$أc$l2T&`W8–ޘ8Fxыz_Py̵G{KbіY*)Rj(dͳ8?8 <׸vu)0ggsf7aG/>$ʼnwI xZzP⶝#.lTˁmdĽ7h0\ࠧpfVL.hA&^Ztu{MV vşg##:tҥN îfo^%Ѭˍ虛(~饹zPd\n\kr$-.@=?ǝۛ!DOO(&j4TIV@֦w4lv*|ew4YkN4Q֘rhNc7yI{߮ʹI@۝o AQ"_}_ |@nPJ@MlgM^;2ɫ%o!hM1 F pM[VU$1"Qpxya> 4u'Mz(\kQ,ݤ"fTP*w@0hC9>:zT#iփ@EԐL>fG('l]x=NSsnT9̼[\FL>댄B)<;oJqi!j3=-P'TR"&o'ĔbJk7‘!?-<"_2?CjoJE= xC.U4PJ{YCmxJFvR"kAEggnm0E9e[3FOu㡽_5_AS.r36`*R_kPh!ECyny %u*MP_fS婊 D$|Aoֲ&A 2A3yzLaсKMB!Y\h:6nMuqV1/R0傒qG/qt۪ $-dƐTY gwÀTnJ"K#scs@@c|2Fq}2Nnn0AMdE^B F^{.p]f("Bur(QVldɣKw躳|uk-ڃ)B-T8h2 >6Vjx;8+6@&~˶@t$1=DVh^V8G/yT}~f% a[~(Zqj6_}Y  !6c^kHymh}N7VJ|( ƺ"I uqMj~ThBvDҒ8;eXvb{<h"AW#OrCHuNO=j_ni,-wxFu.wwlEO{X\CRr3φ,4c2eEMhx4[mum_O؇X D2̨`|. (ۙ-lz8yl7N'cQBNP${[b"p񎝑QjNR w8ZEఴ7 )}w#ь'^%Oo\#377U"@ϻXz1}[s8/W%d% R|u=e%bL~}?[$ik c 0\AFЁ.Ӂ|8m (-% EX]}|zkrMZC!a-ݝAcQRzI&w\ va/KH;UNɢϔ;R]տX 5nlwA0J4jMP`w-.'4*vQ~pQ9q!Z 0VlX!Nx@t>Z/mMj:hG|yF](C3ժ% YyN4yQ@[d9O Y rhq =tDh4;-P e[PF!k4qGcJE.::N+-I`R&/wkn$j;ꘊt0 n .ѭ̗PGd!Z N%J'8MdA W=L}xY*@RpB&}p}^jȢγGG-%f} <`3k޷:]\7CO^?6lBs5ޗqׁ)x _8)hF5,S".#.5R2ŢêF*aTdNZMC)/9\:/>-kjm~rH ~ߗh1|#,Y^waY7C?B<_?aO<ࢤ?~Nvwx_g5lgqbKߣ)ɡ,7:3TRaX=Fcܩt&SX҇\+<`>e8AGF1=?HC?9ǩaq~?lESɷ-ཤBa@SjpUdFiw^q4qܕlb{chjW!:HV9(pq[*[˕6wBsuX,npx;[ Z˚Jыw~DZO],_83L|yێ}S)sf-􉻺w E脔HpʅqW:YVb+^0V"joظT=7> j|Px`1tɸ(E~>)Bub"Wm: `P\P^:VҰ p҄CE[\>mt"ed2 (\kn4#4# Z7ʷy'ʙ:O_O>ujwjvX6S?! osendstream endobj 254 0 obj << /Filter /FlateDecode /Length 9098 >> stream x}M$utI{cv f+!\=#0M%kzjV|P@?[܁H ;C,Wpw>N};ouyc}YԹ|mc$$B:'rqr6v6Dϩ_=^{xE?^j]ճQE)" eZBt<\/sysŮzY o+0.a\&ZU N.ERWrw(xq۫@ɣ}\hHv\@.FE$:Y$ňJX$;6:Ov'.q."]LpN{Df!ٕHJ^!kbv9^$VqZRX$IrY,.΀Ȯ"ԦJ !ű,KpɔO"!s@2\q֯QX "#}peRtT )E{<+L$VH8kz&A[b'0@e0dِu&5,&:210,NUfw4.̈NMjF<9DU߆"jV"|D1^@8N.C^1 #N;h"[HK05 ѡS8V fk0)VkE`݈cnP.tŖ"JI5vDKK겎hjs.Q҅JIW63"&W+RH%ؐ\Q-rUb@{@w:].e1+֥p{C*}[c+DI]Klcv\ )BfY k[Yj3uj,\Y1ĝllB jH_ bmL( djS$7SJV)Ԥ.cȓL%253 @"(/?"16|Eøt?KcegIf0g:~i"z 9nT$=))bbav=l#E4>[IydKJ`ZRBJHjJ _wr}*i ÷+Yl+B%ƶ{ lӳL*4[R-X2 e[%7c6cy\T`[5+S%uD8<e4Ycl&}Ok `4f5G%pw|چ*?lFLl*k'ɐ6=ԯ8(gS ]ckQM !-L-@.Q!zX>'B= P'ɫCD/$>˄A[`pMjpGե2~ Fgl[1[*ؓMh1hKy9EL,2}1C1q حkcz]6Omz[eu&L$wKDyJS4(e.G-N8LAe5z#QAXDoD`W^l6G9Uk[#\`ӰqȖ4sK[۬c4fAw;`:`t$Me4}+#Loi\#\#Q ` FVv4:D飵FmcdMH 1h@D)@3Ru3 E4 jI()jH"Rh" HjH"D"tDRD#`,рTgfDy346 ad HL$iB#)AumRxHƶo''P4{?"\ʄ HiQ4"F H)kX#R@O픠KuB(2h@X'Tb>(1hDʉ1NFD[;NWE#bDрE|bK5[hN\\rsRsDfx#RGchߐ #h򳋋}ACT du3 Yy TfDTψ(;1 IT|2hD.$v>5 H~1<{$3 =c<{H3g{<#3ٞ"E >R 󌔊oZrV'<#ʛuVyFBoaY27M1<T&i9щ3J}s;(7S##ebzDZ1&NꀆI1Hq@2#81hDG{f}3&s}3PftbNjʳ0HӸ:H}f;Xٜ)!O4'uD9ۍyQP4F e 4kr4r߬18YZ3}:W*&u2}:9sϱ{N ~舠7z4^j#Ri\rGx9x_2obAoRg4!yOg80[{Q霝gAoRzbMk!8O;'k vڧ c%d%\ҏ|\ Z!ȼ^RsⰕ627| 0,_ \K8CZ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ.ǎ,\ш\ QC.ǎш\˱;ڐ˱;:cGGrh@8vADO-7 en+KwX8tFTl\KgBҙB)t5B."X3jtvs@kKg0R) ukc{]:{c]:{ C]:{V hK . ptMW[iu!4 钥Rʴ9i, yLceLi,x^6!t)#[JEߊŠcD~[Pmܮ-W8bWۋq VqbC9mHc{:2ѽL"NH^^,hi{i|o'|oΝ^Gȅȅ="wB.|G ; \5V~<&Bw xV.*m5{_wK]}g=T.M۳.\BnŒ/Sse#Q*-SnM+I#t?%$b(i^CNs;}uqms #7n oaݣMw ٍOHmvB޼ip ڛTGF۶ E`5w PFR5ۭmRP:0q6dBFTG)Zq6dƒ$mRNlAG8vl=rf<+kIe I?GW`Ω}NF(Q& % K}O &|- \+IœTCF)4܆LRR-w?J5dKh+2JaOT´2J- o(שrQ!Tb9&ՑQvZ2H~\u{M#T5yYmy)<<7S9Hj1 5d'R"TG&F Q4?#t1{#OQ/AND x0r>Ewsnە/vqHqqmu\82-981գ"c3J2IqзT R a7J2KeݴRdb2dv Agj,EǏRNRF)Cf);3J@TFmR6(P(1Q0 !#ѐY*hi2dbiQʐY G4&2K%-bRFRij,%Z >>J 2KR&!fs!)ƴ!~lņR5g{sǐNơ# LL,b;2Ku2d 8i2I5d‰ ;2K80BLyUtd8֎REFc\1/_^[ejmUTk(B<{ӆ^|;JA:&dp@JOȳrgSv5%$j9˙s=)N"/I$HZǏӴk(/?v bJ|C5w7~G)yԙGsN n=Criev|epF$ ~0’Fy;pJ׻=꼔G#/y}~O}*KNo/֯o2ĠV$ǼH߽B?KYSpKۃM5j7q$YތxzV/sM-wo>? x^i +1fp{r2(wOGOzWzlp_m8ovx[Vi}J7;{ӑuc{庎wheDl(noca֚=BuhfZDZx+nXwT7sa8oh+^qjs&r=%nbId+Swд6}Od&5%J}q/ˆ?^}>S|zr'yP:u XARHȞV+ɻ4*gnZWpfT|"։L!.d7 Z @OEq˂!ſ>`_՞uN~3qsnb1'躰5Kq)*m@% e^ÅաAŔ.q}R]ޥnnc|]%Aw^y}>'#O"NնO>|}}BoaiJ덛nOA77O_Bo8Îz0~kJO+ bţ}y^K.]4ќe

2L}\^?:~> 5yՇ; ,v*\>?~>O}+O}>^?bA/ ,ǟ|Ǔ2)vT#69kGX~;Gozq N"]rԥϤ_w],yJZ;5T!xʾ/o//7ovWN'd Z~@5 qJ=w]ܻ_|񧃲gg_=;\gz{xzgy?yErnjan;O>o|q-r^4(Ͼz|j?{WTTw /t~ͷ|\՟_N㴖>j&ux:̔GmY_?j&goSzZ0=^q]" eҤjY>}y|dEëP[wՏxHUY__Xs=L4~O5pׇ29~!mg-n4hl 1C@칤e Bx+&>q~~%KdA'/{xͯ9ъQs"wT^rJIo(Zɳܵ=ٗ:yuw×-;8j5{7/z:ۃVu!c٢ԓ=lv;g׻}Ď4~0Q[{ｭQp&0{ Ws /nxIgI^v8tX2cZl뾼ƎJvIk\_<}sx 8[XϦQ>jDAaH.x|N9@-C9%Y /ºt~3ǔ$ײ7X:s'+䒲2`j;jq'}kϟ={u/gbz9$-, uHxW7+endstream endobj 255 0 obj << /Filter /FlateDecode /Length 252 >> stream x]An Ecp$4dE"/-,zIE>|x*󦻏/tK|[5>e.X=MxVަgemuݧd$S: Pșos~# I'{R @7M= @&> 74$e]$pi"p*I\&endstream endobj 256 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1752 >> stream x{PSw@D |&; u[li(j7! AHr!E `Dǂҩcvgmױزۙ9=gP Qr_T*G#$&-CT/7k(~i~zx ZZKW$1޿ (*>C+,o {)$dKXyrPy"%[)Β+rS呡Q*"%;Kʕ'e*rUPZ<.XyD́_9BH+NPmޞ; htA7PڏV"o!O$vCrGh(X!s_pqأcBNŗDnWH⃜?#qd?`1<~)DY! ~n`v{V˜ FOvYW{4IKX)ށ%qGi$-#Z%ywd tdxBᆞ70,;讓}'>/nl/F3)LǍ;-S Ge 0yè- Jp?sSNo>3OR;?ђC4|D(J% ኉[8_~J\d}I}HZbcR_cI/Qj缷z7>d~y=pߔzN+F/?k蛞O뿄V`{etR9\=*'`n<> s`7{?}枀eӡ:ۀS>֋FIYhulRoaf_^ #Rbo5Ip -gǛl Nn"~ėDTJ I#A;Jh̍Xc΁ :^ Ň]R`aeyw\[P7'/Ov5 s25ڡI,ln9Q ؅(RۡE [`_2HqJ5IB|J38=8XLfc5ᄊcm* @cs}bbRcX CR_1ղ[؍rȺYOuPLUٻ#R8\]y.g=9&h7\fYf1[~?U͖endstream endobj 257 0 obj << /Filter /FlateDecode /Length 200 >> stream x]10 E"7[Jy Sehv(na`x/:OfYd4KlI4(F`MkGDu|'tW}5#Uf\WMHhޣZj5~s4n2BU T(vtR(yKLqd ~wIS*.IщcCendstream endobj 258 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1182 >> stream xm[LSwikl9qE7'L SPj+Bs{~W8ЖCP#K67.qKe&`d|8&p_iAzWR>9kʠU盵›Z"%?C2ҮN[oʥ2LlիU􆜜6l+Xz{6[y\3iԴ; ޣ3)kz] ]QYVѺ*]| x7b&ۡdT[1l+vb2lñ41JIҋh4sN`Ms^ދGm<2 Xs;SIvpɊWC*= lک<$wU =) "贁tZGit@$W.{h^rY @v&!*Binp-@'{= 2L9 ư-4~g8^]:m}nj F@-2EeD%*F;O<> < gʯˎTICy ȓ1`$M-E L![0zVg<2Q7$s^"i"$Fn@<]=0#3Ṿ|^X3?Hr$6-:'i$+KŷE:ήGW.ã1:ւ 4>};ҕ^"5k؊/-|f^L +ebzš}J RvJMO~qy{]ǘ_6[P6wڬg\_ v; IˏBQ(2 I!8KEEiEѐŃ_Xa=Cendstream endobj 259 0 obj << /Filter /FlateDecode /Length 162 >> stream x]1 0 EwB7plPY%CKi{Gq޾IJ GO. >)l-aMH0Y( cާq6Qj 4Xr|33ɇ>Jm! hD4]\'ퟴF,(%Z kJĹVK ,S%endstream endobj 260 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 288 >> stream xcd`ab`ddM,M) JM/I,If!Cg%<<,{O"={3#cxns~AeQfzFBRWbrv~yqvBb^_~ybrvF~BRjFbNB~BHjBhkP{h@v2000200,c`bdd?|m?c.讖st^lf.^ 8uB7-dƵ[9\sIOoߴމ{,;cڄI}=< Q kendstream endobj 261 0 obj << /Filter /FlateDecode /Length 162 >> stream x]1 EwN@آ,钡UĘ2$,2q( 9 .3-E,:mr$ >CVhM)[^HJ v4zh*5Z!Λ[ĥ6 ~Ϥj /S/endstream endobj 262 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 331 >> stream xcd`ab`dd N+ JM/I,f!CǗ^<<,{/݇3#cxZs~AeQfzFBRWbrv~yqvBb^_~ybrvF~BRjFbNB~BHjBhkP{h@\ c&FFk3|̰3'z{ǣG?~}*˗J}q ^|?݄{?E|V>:w| pB3\XBy80u*}}===xxendstream endobj 263 0 obj << /Filter /FlateDecode /Length 161 >> stream x]10 E7H+b CqP(C[>|/> stream xcd`ab`dd M3 JM/I, f!CǺ<<,{_$ݟ3#cxzs~AeQfzFBRWbrv~yqvBb^_~ybrvF~BRjFbNB~BHjBhkP{h@`|F#a&FFk3%K1t?;ÓM3|Ǻil5 -Vݵپ|^U+%Wܲw߬W~K54Ӎ:mɊ֭[ _Z8zn՝#ÝlYN^KH>ޞI=l?JT^VZ endstream endobj 265 0 obj << /Filter /FlateDecode /Length 162 >> stream x]10 E7d ]ZUm/eBz* t`K_~t%E ci{DǢU`c*Wo:?@![^I>եBoh )j^HM3IG`RQO%G3yp8BCN_3kS>endstream endobj 266 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 281 >> stream xcd`ab`dd M34 JM/I,f!Cܬ<<,{7 }_1<9(3=DXWR!RIO+19;8;S!1/EKWO/<19;SA#?O!)5#1'M!?M!$5B!45(X=?4 XSUp&FFk3sgx} [^-z댍[Μ%Wy&.d[u[%$saOoOooϤ޾<> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 268 /ID [<5b02df8055dacdb11c1ffc721c46aedc>] >> stream xҽ/CQ眶⥩Ib`#a/Hb1J$v1Y;xD />=Ǜ~ޙռ .5,Z further down %%%%%%%%%%%% % \author{Martin M\"achler \\ ETH Zurich% \\ April, Oct.\ 2012 {\tiny (\LaTeX'ed \today)}%---- for now } \title{Accurately Computing $\log(1 - \exp(-\abs{a}))$ \\ Assessed by the \pkg{Rmpfr} package} %% for pretty printing and a nice hypersummary also set: \Plainauthor{Martin M\"achler} %% comma-separated \Plaintitle{% Accurately Computing log(1 - exp(.)) -- Assessed by Rmpfr} %\VignetteIndexEntry{Accurately Computing log(1 - exp(.)) -- Assessed by Rmpfr} %\VignetteDepends{Rmpfr} %\VignetteDepends{gmp} %\VignetteDepends{sfsmisc} \SweaveOpts{engine=R,strip.white=true, width=8.5, height=6} \SweaveOpts{pdf=FALSE, eps=FALSE, grdevice = pdfaCrop} % defined in R "<>": ^^^^^^^^ %% an abstract and keywords \Abstract{In this note, we explain how $f(a) = \log(1 - e^{-a}) =\log(1 - \exp(-a))$ can be computed accurately, in a simple and optimal manner, building on the two related auxiliary functions \code{log1p(x)} ($=\log(1+x)$) and \code{expm1(x)} ($=\exp(x)-1 = e^x - 1$). The cutoff, $a_0$, in use in \R{} since % version 1.9.0, April 2004, is shown to be optimal both theoretically and empirically, using \pkg{Rmpfr} high precision arithmetic. As an aside, we also show how to compute $\log\bigl(1 + e^x \bigr)$ accurately and efficiently. } \Keywords{Accuracy, Cancellation Error, R, MPFR, Rmpfr} %% at least one keyword must be supplied %% publication information %% NOTE: Typically, this can be left commented and will be filled out by the technical editor %% \Volume{13} %% \Issue{9} %% \Month{September} %% \Year{2004} %% \Submitdate{2004-09-29} %% \Acceptdate{2004-09-29} %% The address of (at least) one author should be given %% in the following format: \Address{ Martin M\"achler\\ Seminar f\"ur Statistik, HG G~16\\ ETH Zurich\\ 8092 Zurich, Switzerland\\ E-mail: \email{maechler@stat.math.ethz.ch}\\ URL: \url{https://stat.ethz.ch/~maechler} } %% It is also possible to add a telephone and fax number %% before the e-mail in the following format: %% Telephone: +43/1/31336-5053 %% Fax: +43/1/31336-734 %% for those who use Sweave please include the following line (with % symbols): %% MM: this is "substituted" by jss.cls: %% need no \usepackage{Sweave.sty} \usepackage[american]{babel}%for American English \usepackage{amsmath}%sophisticated mathematical formulas with amstex (includes \text{}) \usepackage{mathtools}%fix amsmath deficiencies \usepackage{amssymb}%sophisticated mathematical symbols with amstex (includes \mathbb{}) % \usepackage{amsthm}%theorem environments \usepackage{bm}%for bold math symbols: \bm (= bold math) \usepackage{enumitem}%for automatic numbering of new enumerate environments % This is already in jss above -- but withOUT the fontsize=\small part !! \DefineVerbatimEnvironment{Sinput}{Verbatim}{fontsize=\small,fontshape=sl} \DefineVerbatimEnvironment{Soutput}{Verbatim}{fontsize=\small} \DefineVerbatimEnvironment{Scode}{Verbatim}{fontsize=\small,fontshape=sl} %%~-~-~-~ Make space between Sinput and Soutput smaller: ~-~-~-~~-~-~-~~-~-~-~~-~-~-~~-~-~-~ %%--- Best advice, now from : % http://tex.stackexchange.com/questions/19359/reduce-space-between-sinput-and-soutput \newlength{\FVtopsep} \newlength{\FVpartopsep} \newlength{\FVparskip}% <- added as "no. 3" by MMa (after reading fancyvrb doc) \makeatletter \FV@AddToHook{\FV@ListParameterHook}{\topsep=\FVtopsep\partopsep=\FVpartopsep\parskip=\FVparskip} \makeatother % Control the spacing around the Sinput and Soutput environments by using the lengths % % \FVtopsep % \FVpartopsep % \FVparskip % % Both *topsep act quite similar most of the time, more details % can be found in the fancyvrb documentation on page 46. (MM: ==> I add FVparskip) %To kill all extra spacing between the environments, use {0pt} in all these %MM: When all three(!) are {0pt}, there's a large gap *after* Schunk (nothing in %between) %-- and that (end gap) get's smaller when I set all to {1pt} -- logic?? %___TODO/FIXME: Set of experiments (with smaller Sweave file)___ \setlength{\FVtopsep}{1pt} \setlength{\FVpartopsep}{1pt} \setlength{\FVparskip}{\parskip}% default: \parskip %%~-~-~-~ End {Sweave space handling} ~-~-~-~~-~-~-~~-~-~-~~-~-~-~~-~-~-~~-~-~~-~-~-~~-~-~ %% \setkeys{Gin}{width=\textwidth}% Sweave.sty has {width=0.8\textwidth} \newcommand*{\R}{\proglang{R}}%{\textsf{R}} \newcommand*{\CRANpkg}[1]{\href{http://CRAN.R-project.org/package=#1}{\pkg{#1}}} \newcommand*{\eps}{\varepsilon} %- \abs{ab} --> | ab | ``absolut Betrag'' \newcommand{\abs}[1] {\left| #1 \right|} % \renewcommand*{\S}{\operatorname*{S}} % \newcommand*{\tS}{\operatorname*{\tilde{S}}} % \newcommand*{\ran}{\operatorname*{ran}} %\newcommand*{\sgn}{\operatorname*{sgn}} \DeclareMathOperator{\sign}{sign} % \renewcommand*{\L}{\mathcal{L}} % \newcommand*{\Li}{\mathcal{L}^{-1}} % \newcommand*{\LS}{\mathcal{LS}} % \newcommand*{\LSi}{\LS^{-1}} \renewcommand*{\O}{\mathcal{O}} % \newcommand*{\Geo}{\operatorname*{Geo}} % \newcommand*{\Exp}{\operatorname*{Exp}} % \newcommand*{\Sibuya}{\operatorname*{Sibuya}} % \newcommand*{\Log}{\operatorname*{Log}} % \newcommand*{\U}{\operatorname*{U}} % \newcommand*{\B}{\operatorname*{B}} % \newcommand*{\NB}{\operatorname*{NB}} % \newcommand*{\N}{\operatorname*{N}} \DeclareMathOperator{\var}{var} \DeclareMathOperator{\Var}{Var} \DeclareMathOperator{\Cov}{Cov} \DeclareMathOperator{\cov}{cov} \DeclareMathOperator{\Cor}{Corr} \DeclareMathOperator{\cor}{corr} % \newcommand*{\Var}{\operatorname*{Var}} % \newcommand*{\Cov}{\operatorname*{Cov}} % \newcommand*{\Cor}{\operatorname*{Cor}} % % \newcommand*{\loglp}{\operatorname*{log1p}} % \newcommand*{\expml}{\operatorname*{expm1}} %% cannot use "1" in latex macro name -- use "l": \newcommand*{\loglp}{\mathrm{log1p}} \newcommand*{\expml}{\mathrm{expm1}} %% journal specific aliases \newcommand*{\setcapwidth}[1]{} %% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{document} %% include your article here, just as usual %% Note that you should use the \pkg{}, \proglang{} and \code{} commands. % \section[About Java]{About \proglang{Java}} %% Note: If there is markup in \(sub)section, then it has to be escape as above. %% %% Note: These are explained in '?RweaveLatex' : <>= ## Our custom graphics device: pdfaCrop <- function(name, width, height, ...) { fn <- paste(name, "pdf", sep = ".") if(FALSE)## debug cat("pdfaCrop: fn = ",fn,"; call:\n\t",deparse(match.call()),"\n") grDevices::pdf(fn, width = width, height = height, onefile=FALSE)# ...) assign(".pdfaCrop.name", fn, envir = globalenv()) } ## This is used automagically : pdfaCrop.off <- function() { dev.off()# for the pdf f <- get(".pdfaCrop.name", envir = globalenv()) ## and now crop that file: pdfcrop <- "pdfcrop" # relying on PATH - fix if needed pdftex <- "pdftex" # relying on PATH - fix if needed system(paste(pdfcrop, "--pdftexcmd", pdftex, f, f, "1>/dev/null 2>&1"), intern=FALSE) } op.orig <- options(width = 75, SweaveHooks= list(fig=function() par(mar=c(5.1, 4.1, 1.1, 2.1))), digits = 5, useFancyQuotes = "TeX", ## for JSS, but otherwise MM does not like it: ## prompt="R> ", continue=" ")# 2 (or 3) blanks: use same length as 'prompt' if((p <- "package:fortunes") %in% search()) try(detach(p, unload=TRUE, char=TRUE)) Sys.setenv(LANGUAGE = "en") if(.Platform$OS.type != "windows") Sys.setlocale("LC_MESSAGES","C") if(getRversion() < "2.15") paste0 <- function(...) paste(..., sep = '') library("sfsmisc")# e.g., for eaxis() library("Rmpfr") .plot.BC <- FALSE # no Box-Cox plot @ %\section[Introduction]{Introduction \small~\footnote{\mythanks}} \section{Introduction: Not log() nor exp(), but log1p() and expm1()} In applied mathematics, it has been known for a very long time that direct computation of $\log(1 + x)$ suffers from severe cancellation (in ``$1 + x$'') whenever $\abs{x} \ll 1$, and for that reason, we have provided \code{log1p(x)} in \R{}, since R version 1.0.0 (released, Feb.~29, 2000). Similarly, \code{log1p()} has been provided by C math libraries and has become part of C language standards around the same time, see, for example, \citet{ieee04:log1p}. Analogously, since \R{}~1.5.0 (April 2002), the function \code{expm1(x)} computes $\exp(x) - 1 = e^x - 1$ accurately also for $\abs{x} \ll 1$, where $e^x \approx 1$ is (partially) cancelled by ``$-\: 1$''. In both cases, a simple solution %approach for small $\abs{x}$ is to use a few terms of the Taylor series, as \begin{align} \label{eq:Taylor-log1p} \loglp(x) &= \log(1 + x) = x - x^2/2 + x^3/3 -+ \dots, \ \mathrm{for}\ \ \abs{x} < 1, %\mathrm{and} \\ \label{eq:Taylor-expm1} \expml(x) &= \exp(x) - 1 = x + x^2/2! + x^3/3! + \dots, \ \mathrm{for}\ \ \abs{x} < 1, \end{align} and $n!$ denotes the factorial. We have found, however, that in some situations, the use of \code{log1p()} and \code{expm1()} may not be sufficient to prevent loss of numerical accuracy. The topic of this note is to analyze the important case of computing $\log\left(1 - e^x \right) = \log(1 - \exp(x))$ for $x < 0$, computations needed in accurate computations of the beta, gamma, exponential, Weibull, t, logistic, geometric and hypergeometric distributions, %% in ~/R/D/r-devel/R/src/nmath/ : %% grep --color -nHEw -e '(R_Log1_Exp|R_D_LExp|R_DT_Log|R_DT_C?log)' *.? %% --> ~/R/Pkgs/Rmpfr/vignettes/log1mexp_grep and % because of the latter, even for the logit link function in logistic regression. For the beta and gamma distributions, see, for example, % e.g., \citet{DidAM92}\footnote{In the Fortran source, file ``\code{708}'', also available as \url{http://www.netlib.org/toms/708}, the function ALNREL() computes log1p() and REXP() computes expm1().}, and further references mentioned in \R{}'s \code{?pgamma} and \code{?pbeta} help pages. For the logistic distribution, $F_L(x) = \frac{e^x}{1+e^x}$, the inverse, aka quantile function is $q_L(p) = \mathrm{logit}(p) := \log \frac{p}{1-p}$. If the argument $p$ is provided on the log scale, $\tilde p := \log p$, hence $\tilde p \le 0$, we need \begin{align} \label{eq:qlogis} \mathtt{qlogis}(\tilde p,\: \mathtt{log.p=TRUE}) = q_L\!\left(e^{\tilde p}\right) = \mathrm{logit}\!\left(e^{\tilde p}\right) % = \log\Bigl(\frac{e^{\tilde p}}{1-e^{\tilde p}}\Bigr) = \log \frac{e^{\tilde p}}{1-e^{\tilde p}} = \tilde p - \log\left(1 - e^{\tilde p} \right), \end{align} and the last term is exactly the topic of this note. \section{log1p() and expm1() for log(1 - exp(x))} Contrary to what one would expect, for computing $\log\left(1 - e^x \right) = \log(1 - \exp(x))$ for $x < 0$, neither \begin{align} \label{eq:f.expm1} \log(1 - \exp(x)) &= \log(-\expml(x)), \ \ \mathrm{nor}\\ \label{eq:f.log1p} \log(1 - \exp(x)) &= \loglp(-\exp(x)), \end{align} are uniformly sufficient for numerical evaluation. %% 1 In (\ref{eq:f.log1p}), when $x$ approaches $0$, $\exp(x)$ approaches $1$ and $\loglp(-\exp(x))$ loses accuracy. %% 2 In (\ref{eq:f.expm1}), when $x$ is large, $\expml(x)$ approaches $-1$ and similarly loses accuracy. Because of this, we will propose to use a function \code{log1mexp(x)} which uses either \code{expm1} (\ref{eq:f.expm1}) or \code{log1p} (\ref{eq:f.log1p}), where appropriate. Already in \R{}~1.9.0 (\cite{R-190}), % (April 2004) % now, both R_Log1_Exp() and --> R_D_LExp(x) := (log_p ? R_Log1_Exp(x) : log1p(-x)) we have defined the macro \verb|R_D_LExp(x)| to provide these two cases %branches automatically\footnote{look for ``log(1-exp(x))'' in \url{http://svn.r-project.org/R/branches/R-1-9-patches/src/nmath/dpq.h}}. % R-1.8.1: pgamma(30,100, lower=FALSE, log=TRUE) gave 0 instead of -... To investigate the accuracy losses empirically, we make use of the \R{} package \CRANpkg{Rmpfr} for arbitrarily accurate numerical computation, and use the following simple functions: <>= library(Rmpfr) t3.l1e <- function(a) { c(def = log(1 - exp(-a)), expm1 = log( -expm1(-a)), log1p = log1p(-exp(-a))) } @ <>= leg <- local({ r <- body(t3.l1e)[[2]]; r[[1]] <- `expression`; eval(r) }) ## will be used below @ <>= ##' The relative Error of log1mexp computations: relE.l1e <- function(a, precBits = 1024) { stopifnot(is.numeric(a), length(a) == 1, precBits > 50) da <- t3.l1e(a) ## double precision a. <- mpfr(a, precBits=precBits) ## high precision *and* using the correct case: mMa <- if(a <= log(2)) log(-expm1(-a.)) else log1p(-exp(-a.)) structure(as.numeric(1 - da/mMa), names = names(da)) } @ <>= <> <> @ where the last one, \code{relE.l1e()} computes the relative error of three different ways to compute $\log(1 - \exp(-a))$ for positive $a$ (instead of computing $\log(1 - \exp(x))$ for negative $x$). %% TODO? "cache = TRUE": --- <>= a.s <- 2^seq(-55, 10, length = 256) ra.s <- t(sapply(a.s, relE.l1e)) <>= <> cbind(a.s, ra.s) # comparison of the three approaches <>= <> capture.and.write(cbind(a.s, ra.s), 8, last = 6) @ This is revealing: Neither method, log1p or expm1, is uniformly good enough. Note that for large $a$, the relative errors evaluate to \code{1}. This is because all three double precision methods give 0, \emph{and} that is the best approximation in double precision (but not in higher \code{mpfr} precision), hence no problem at all, and we can restrict ourselves to smaller $a$ (smaller than about 710, here).% < 709.78271289338403 (lynne 64b) <>= ii <- a.s < 710 a.s <- a.s[ii] ra.s <- ra.s[ii, ] @ What about really small $a$'s? Note here that <>= t3.l1e(1e-20) as.numeric(t3.l1e(mpfr(1e-20, 256))) @ % ## expm1 def log1p % ## -46.0517 -Inf -Inf % as.numeric(): % ## [1] -46.0517 -46.0517 -46.0517 both the default and the \code{log1p} method return \code{-Inf}, so, indeed, the \code{expm1} method is absolutely needed here. Figure~\ref{fig:bigpic} visualizes the relative errors\footnote{% Absolute value of relative errors, $\abs{(\hat{f}(a) - f(a)) / f(a)} = \abs{1 - \hat{f}(a)/f(a)}$, where $f(a) = \mathrm{log1mexp}(a)$ (\ref{eq:log1mexp}) is computed accurately by a 1024 bit \pkg{Rmpfr} computation} of the three methods. Note that the default basically gives the maximum of the two methods' errors, whereas the final \code{log1mexp()} function will have (approximately) minimal error of the two. %% --- Define figure_1 here ------------------------------ <>= par(mar = c(4.1,4.1,0.6,1.6)) cc <- adjustcolor(c(4,1,2),.8, red.f=.7) lt <- c("solid","33","3262") ll <- c(.7, 1.5, 2) @ %% main = "|relative errors| of three methods for log(1 - exp(-a))" <>= matplot(a.s, abs(ra.s), type = "l", log = "xy", col=cc, lty=lt, lwd=ll, xlab = "a", ylab = "", axes=FALSE) legend("top", leg, col=cc, lty=lt, lwd=ll, bty="n") draw.machEps <- function(alpha.f = 1/3, col = adjustcolor("black", alpha.f)) { abline(h = .Machine$double.eps, col=col, lty=3) axis(4, at=.Machine$double.eps, label=quote(epsilon[c]), las=1, col.axis=col) } eaxis(1); eaxis(2); draw.machEps(0.4) @ %% TODO? "cache = TRUE": echo=FALSE: do not show already, but need (a.,ra2) <>= a. <- (1:400)/256 ra <- t(sapply(a., relE.l1e)) ra2 <- ra[,-1] @ \begin{figure}[htb!] \centering % increasing width --> effective LaTeX *height* will decrease <>= <> <> ## draw the zoom-in region into the plot: yl <- range(pmax(1e-18, abs(ra2))) rect(min(a.), yl[1], max(a.), yl[2], col= adjustcolor("black", .05), border="gray", pch = 5) @ \setcapwidth{\textwidth}% \caption[Relative errors of log1mexp() approximations]{% Relative errors$^{*}$ of the default, $\log(1 - e^{-a})$, and the two methods ``\code{expm1}'' $\log(-\expml(-a))$ and ``\code{log1p}'' $\loglp(-\exp(-a))$. Figure~\ref{fig:zoomin-pic} will be a zoom into the gray rectangular region where all three curves are close.} \label{fig:bigpic} \end{figure} In Figure~\ref{fig:zoomin-pic} below, we zoom into the region where all methods have about the same (good) accuracy. The region is the rectangle defined by the ranges of \code{a.} and \code{ra2}: <>= <> @ In addition to zooming in Figure~\ref{fig:bigpic}, we want to smooth the two curves, using a method assuming approximately normal errors. Notice however that neither the original, nor the log-transformed values have approximately symmetric errors, so we use \code{MASS::boxcox()} to determine the ``correct'' power transformation, <>= da <- cbind(a = a., as.data.frame(ra2)) library(MASS) bc1 <- boxcox(abs(expm1) ~ a, data = da, lambda = seq(0,1, by=.01), plotit=.plot.BC) bc2 <- boxcox(abs(log1p) ~ a, data = da, lambda = seq(0,1, by=.01), plotit=.plot.BC) c(with(bc1, x[which.max(y)]), with(bc2, x[which.max(y)]))## optimal powers ## ==> taking ^ (1/3) : s1 <- with(da, smooth.spline(a, abs(expm1)^(1/3), df = 9)) s2 <- with(da, smooth.spline(a, abs(log1p)^(1/3), df = 9)) @ i.e, the optimal boxcox exponent turns out to be close to $\frac 1 3$, which we use for smoothing in a ``zoom--in'' of Figure~\ref{fig:bigpic}. Then, the crossover point of the two curves already suggests that the cutoff, $a_0 = \log 2$ is empirically very close to optimal. <>= matplot(a., abs(ra2), type = "l", log = "y", # ylim = c(-1,1)*1e-12, col=cc[-1], lwd=ll[-1], lty=lt[-1], ylim = yl, xlab = "a", ylab = "", axes=FALSE) legend("topright", leg[-1], col=cc[-1], lwd=ll[-1], lty=lt[-1], bty="n") eaxis(1); eaxis(2); draw.machEps() lines(a., predict(s1)$y ^ 3, col=cc[2], lwd=2) lines(a., predict(s2)$y ^ 3, col=cc[3], lwd=2) @ %% no title here: main = "|relative errors| of two methods for log(1 - exp(-a))") \enlargethispage{5ex} \begin{figure}[hbt!] \centering <>= cl2 <- adjustcolor("slateblue", 1/2)# (adj: lwd=3) # the color for "log(2)" par(mar = c(4.1,4.1,0.6,1.6)) <> abline(v = log(2), col=cl2, lty="9273", lwd=2.5) cl2. <- adjustcolor(cl2, 2) axis(1, at=log(2), label=quote(a[0] == log~2), las=1, col.axis=cl2.,col=cl2, lty="9273", lwd=2.5) ## what system is it ? sysInf <- Sys.info()[c("sysname", "release", "nodename", "machine")] mtext(with(as.list(sysInf), paste0(sysname," ",release,"(",substr(nodename,1,16),") -- ", machine)), side=1, adj=1, line=2.25, cex = 3/4) @ \setcapwidth{\textwidth}% \caption{A ``zoom in'' of Figure~\ref{fig:bigpic} showing the region where the two basic methods, ``\code{expm1}'' and ``\code{log1p}'' switch their optimality with respect to their relative errors. Both have small relative errors in this region, typically below $\eps_c :=$% \code{.Machine\$double.eps} $=2^{-52} \approx 2.22\cdot 10^{-16}$. \ \ The smoothed curves indicate crossover close to $a = a_0 := \log 2$.} \label{fig:zoomin-pic} \end{figure} \paragraph{Why is it very plausible to take $a_0 := \log 2$ as approximately optimal cutoff?} Already from Figure~\ref{fig:zoomin-pic}, empirically, an optimal cutoff $a_0$ is around $0.7$. We propose to compute \begin{align} \label{eq:def-log1mexp} f(a) = \log\left(1 - e^{-a}\right) = \log(1 - \exp(-a)), \ \ a > 0, \end{align} by a new method or function \code{log1mexp(a)}. It needs a cutoff $a_0$ between choosing \code{expm1} for $0 < a \le a_0$ and \code{log1p} for $a > a_0$, i.e., \begin{align} \label{eq:log1mexp} f(a) = \mathrm{log1mexp}(a) := \begin{cases} \log(-\expml(-a)) & 0 < a \le a_0 \ \ ( := \log 2 \approx 0.693) \\ \loglp(-\exp(-a)) & \phantom{0 < {}}a > a_0. \end{cases} \end{align} The mathematical argument for choosing $a_0$ is quite simple, at least informally: In which situations does $1 - e^{-a}$ loose bits (binary digits) \emph{entirely independently} of the computational algorithm? Well, as soon as it ``spends'' bits just to store its closeness to $1$. And that is as soon as $e^{-a} < \frac 1 2 = 2^{-1}$, because then, at least one bit cancels. This however is equivalent to $-a < \log(2^{-1}) = -\log(2)$ or $a > \log 2 =: a_0$. \section{Computation of log(1+exp(x))} Related to $\mathrm{log1mexp}(a)=\log(1 - e^{-a})$ is the log survival function of the logistic distribution % (see above)%: defined F_L $\log(1 - F_L(x)) = \log\frac{1}{1+e^x} = -\log(1 + e^x) = -g(x)$, where \begin{align} \label{eq:def-log1pexp} g(x) := \log(1 + e^x) = \loglp(e^x), \end{align} which has a ``$+"$'' instead of a ``$-$'', compared to $\mathrm{log1mexp}$, and is easier to analyze and compute, its only problem being large $x$'s where $e^x$ % = \exp x$ overflows numerically.\footnote{Indeed, for $x=710$, $ -g(x) = \log(1 - F_L(x)) = $ \code{plogis(710, lower=FALSE, log.p=TRUE)}, underflowed to \code{-Inf} in \R{} versions before 2.15.1 (June 2012) from when on (\ref{eq:log1pexp}) has been used.} As $g(x)= \log(1 + e^x) = \log(e^x(e^{-x} + 1)) = x + \log(1 + e^{-x})$, we see from (\ref{eq:Taylor-log1p}) that \begin{align} \label{eq:log1pexp-asym} g(x) = x + \log(1 + e^{-x}) = % \sim %\asymp %% x + e^{-x}(1 - e^{-x}/2) + \O((e^{-x})^3), x + e^{-x} + \O((e^{-x})^2), \end{align} for $x\to\infty$. Note further, that for $x\to-\infty$, we can simplify $g(x)=\log(1 + e^x)$ to $e^x$. A simple picture quickly reveals how different approximations behave, where we have used \code{uniroot()} to determine the zero crossing, but will use slightly simpler cutoffs $x_0=37$, $x_1$ and $x_2$, in (\ref{eq:log1pexp}) below: %% Notation x_0, x_1, x_2 are related to the 1st, 2nd and 3rd cutoff in equation (10) %% -37 18 33.3 <>= ## Find x0, such that exp(x) =.= g(x) for x < x0 : f0 <- function(x) { x <- exp(x) - log1p(exp(x)) x[x==0] <- -1 ; x } u0 <- uniroot(f0, c(-100, 0), tol=1e-13) str(u0, digits=10) x0 <- u0[["root"]] ## -36.39022698 --- note that ~= \log(\eps_C) all.equal(x0, -52.5 * log(2), tol=1e-13) ## Find x1, such that x + exp(-x) =.= g(x) for x > x1 : f1 <- function(x) { x <- (x + exp(-x)) - log1p(exp(x)) x[x==0] <- -1 ; x } u1 <- uniroot(f1, c(1, 20), tol=1e-13) str(u1, digits=10) x1 <- u1[["root"]] ## 16.408226 ## Find x2, such that x =.= g(x) for x > x2 : f2 <- function(x) { x <- log1p(exp(x)) - x ; x[x==0] <- -1 ; x } u2 <- uniroot(f2, c(5, 50), tol=1e-13) str(u2, digits=10) x2 <- u2[["root"]] ## 33.27835 @ %% but really the above is still ``non sense'': look at <>= par(mfcol= 1:2, mar = c(4.1,4.1,0.6,1.6), mgp = c(1.6, 0.75, 0)) curve(x+exp(-x) - log1p(exp(x)), 15, 25, n=2^11); abline(v=x1, lty=3) curve(log1p(exp(x)) - x, 33.1, 33.5, n=2^10); abline(v=x2, lty=3) @ \medskip Using double precision arithmetic, a fast and accurate computational method is to use \begin{align} \label{eq:log1pexp} \hat{g}(x) = \mathrm{log1pexp}(x) := \begin{cases} \exp(x) & x \le -37 \\ \loglp(\exp(x)) & -37 < x \le x_1 := 18, \\ x + \exp(-x) & x_1 < x \le x_2 := 33.3, \\ x & x > x_2, \end{cases} \end{align} where only the cutoff $x_1 = 18$ is important and the other cutoffs just save computations.\footnote{see % the %\R{} plot \code{curve(log1p(exp(x)) - x, 33.1, 33.5, n=2\^{}10)} above, revealing a somewhat fuzzy cutoff $x_2$.} %%--- Ok, still do a little deeper analysis for the interested R code reader %%--- invisibly mostly (echo=FALSE) here: <>= t4p.l1e <- function(x) { c(def = log(1 + exp(x)), log1p = log1p(exp(x)), ## xlog1p = x + log1p(exp(-x)), xpexp = x + exp(-x), x = x) } leg <- local({ r <- body(t4p.l1e)[[2]]; r[[1]] <- `expression`; eval(r) }) ##' The relative Error of log1pexp computations: relE.pl1e <- function(x, precBits = 1024) { stopifnot(is.numeric(x), length(x) == 1, precBits > 50) dx <- t4p.l1e(x) ## double precision x. <- mpfr(x, precBits=precBits) ## high precision *and* using the correct case: mMx <- if(x < 0) log1p(exp(x.)) else x. + log1p(exp(-x.)) structure(as.numeric(1 - dx/mMx), names = names(dx)) } <>= x.s <- seq(-100, 750, by = 5) # <- the big picture ==> problem for default x.s <- seq( 5, 60, length=512) # <- the zoom in ==> *no* problem for def. rx.s <- t(sapply(x.s, relE.pl1e)) signif(cbind(x.s, rx.s),3) @ \begin{figure}[htb!] \centering %% using "blue" for the default method, *as* in Figure 1 above <>= par(mar = c(4.1,4.1,0.6,1.6), mgp = c(1.6, 0.75, 0)) cc <- adjustcolor(c(4,1,2,3),.8, red.f=.7, blue.f=.8) lt <- c("solid","33","3262","dotdash") ll <- c(.7, 1.5, 2, 2) ym <- 1e-18 yM <- 1e-13 matplot(x.s, pmax(pmin(abs(rx.s),yM),ym), type = "l", log = "y", axes=FALSE, ylim = c(ym,yM), col=cc, lty=lt, lwd=ll, xlab = "x", ylab = "") legend("topright", leg, col=cc, lty=lt, lwd=ll, bty="n") eaxis(1, at=pretty(range(x.s), n =12)); eaxis(2) draw.machEps(0.4) x12 <- c(18, 33.3) abline(v=x12, col=(ct <- adjustcolor("brown", 0.6)), lty=3) axis(1, at=x12, labels=formatC(x12), padj = -3.2, hadj = -.1, tcl = +.8, col=ct, col.axis=ct, col.ticks=ct) @ % increasing width --> effective LaTeX *height* will decrease \setcapwidth{\textwidth}% \caption{Relative errors (via \pkg{Rmpfr}, see footnote of Fig.~\ref{fig:bigpic}) of four different ways to numerically compute $\log\bigl(1 + e^{x}\bigr)$. Vertical bars at $x_1 = 18$ and $x_2 = 33.3$ visualize the (2nd and 3rd) cutpoints of (\ref{eq:log1pexp}).} % Moved into text:|| down Note that the default method is fully accurate on this $x$ range. \label{fig:log1pexp} \end{figure} Figure~\ref{fig:log1pexp} visualizes the relative errors of the careless ``default'', $\log\bigl(1 + e^{x}\bigr)$, its straightforward correction $\loglp\bigl(e^x\bigr)$, the intermediate approximation $x + e^{-x}$, and the large $x$ ($ = x$), i.e., the methods in (\ref{eq:log1pexp}), depicting that the (easy to remember) cutoffs $x_1$ and $x_2$ in (\ref{eq:log1pexp}) are valid. %% moved from figure caption: Note that the default method is fully accurate on this $x$ range and only problematic when $e^x$ begins to overflow, i.e., $x > e_{\mathrm{Max}}$, which is <>= (eMax <- .Machine$double.max.exp * log(2)) exp(eMax * c(1, 1+1e-15)) @ where we see that indeed $e_{\mathrm{Max}} = $\code{eMax} is the maximal exponent without overflow. \section{Conclusion} We have used high precision arithmetic (\R{} package \pkg{Rmpfr}) to empirically verify that computing $f(a) = \log\left(1 - e^{-a}\right)$ is accomplished best via equation (\ref{eq:log1mexp}). In passing, we have also shown that accurate computation of $g(x) = \log(1+e^x)$ can be achieved via (\ref{eq:log1pexp}). % Note that %% FIXME: %% a short version of this note has been published .... %% \cite{....} a version of this note is available as vignette (in \texttt{Sweave}, i.e., with complete \R{} source) from the \pkg{Rmpfr} package vignettes. \subsection*{Session Information} \nopagebreak <>= toLatex(sessionInfo(), locale=FALSE) <>= options(op.orig) @ %\clearpage \bibliography{log1mexp} \end{document} Rmpfr/inst/doc/Rmpfr-pkg.pdf0000644000176200001440000050467415075721240015445 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4784 /Filter /FlateDecode /N 80 /First 678 >> stream xҠ^ï@^'S8OOlRTL~-y/[ux~Q!!7lp[ʍw+'πɮI<|XriIc<CrVt\ۖaofv2$b" jF!-`.8;x'ӫt7!R{Q:@>ɢ̘!N;I&B @1uL/'y [W+wykUdEw$J uN0Fv|ղ{)gl< 5T0plh9gS#ګpE ʻT T ǭG3-zVsDf/|8*r*9=vg9;f쌝 ,<[ Xo:NXozu>Xx g 9} g6fWl¦l:،͈Q٠WY6ϧ}m9-qhPb9[E{6aͳ_lɾ[8ΞJ{Tp9ћ$8|AUzd"罣pv/d.-RuFq={_@i,>}s*G<.&_ػ|r4Y늵1MI%jun1FXޮ~:pAA)@zդiAƙ:M?b,c6 D8#ڠ)䡇M:|N1v(E7GGVDF*Pn"-: b(+Q#Nrad, ֩@:UYp< k+Go+XC~(rAHݤ)<޺ЎoC.\`Ū6AUFeV4U@g:ڹZ,}i~?4{̞A `석WJ^{>nO9+*jїioYd,+]ňexmYvWAT 솊KR]^q@r5+/}e?tS7v@x9-يm[*q/qeEFG0HNjzdV4D//.? r TMlUݒYvIfe5Vc]#WV{9.[yQ<|Ms-4Ņ,l ~쵋-JȔU c0|K ~Ǝ+vҚiKL|eDEKvAwʃmU$6@,wO]>",nl{:$`Ene;רl7^mZq}^ZMܐ][1ۈ9Eƹi '/l@@ئD ;X)Lw6D|_Ne?.hvn#:^S9r?us!:Q)*"E5-Hywz* QWc{eS ›e; v4To1wz$\ Z&!KZ -SqZH4Vd ,ǵ혶Pot+2׺"[VצwW<08<6$:<@1z.R>o?|'i1Dd"`n\\" jkov_Z ֈ>jQ]A%|y&2Q0i/RA8Tnt0Ε{0'7 ;#wj<l1dÔJ18!frI4:xEP( s 7c1Pފ^ryIO'v۔/U..BSTvD wv\ծYkϴ6}mK^yoy9,-(PVq:_c\bL CLW"W=^.fbäkv琵v =ʪ j.m= ;ZtMDǥ[ؓt+})nh~k)`Iea5˼ыRC\IqXZ%'A]m{[.xoc=-s/o]/ϋ|Yv"lle+8wi )4)க0}[XDP,M{-Y|34%_`p%xr.]W ˡި(f.Q|HUq*b4Oax?=ټ8 /S])>FuBY҉+ MbUd:'WS:WxGiemS>>}m2n'km'|__.͖}nQuJl^3.hwl~b~)f%rz%q2bbW1hi+MSm휢^8ۣLoFIovGZo<0o^n, bᆃOogD46mjzٿ-ӗ]պ?M\o'Ԧ n{`?ZӢ`8ҼX`3n{q޳`]St jԮ|2<}z <."aۢ.+څ["S#Wq?_UȮ(ץOլ"\,n꭫ zf|MjKηu?HW9ͯeakyMZmui;nymi+nyim^K]嵑Ŷִ joTg/.9zu7FS%StK>{#G S4%Ey:̮?2v5̃?{ ՊDPIH6:\R:“lA]A Ky/#xJc俅]7,tRܜI3 pj$0o4Rf"DWVM0.\/e4#*GJŴw'J3i2W7 *phI.1WR']> stream GPL Ghostscript 10.05.1 MPFR, Abitrary Precision, Multiple Precision Floating-Point, R 2025-10-21T17:11:28+02:00 2025-10-21T17:11:28+02:00 2025-10-21T17:11:28+02:00 LaTeX with hyperref Arbitrarily Accurate Computation with R—The Rmpfr PackageMartin Mächler endstream endobj 83 0 obj << /Type /ObjStm /Length 3503 /Filter /FlateDecode /N 80 /First 729 >> stream x[YoH~_Q |7 LFN& HHtjyl(fwuWGKV@9` HnZFu(0.98LZNӒTpN8KpfnxRs` p `TPOB@XeQ - +@j́1 q 1PL[`Jc> Ĺ >n@[Y0 w`08c\e3.JW$X#sJ lr3%ђ<M#YK>.^sB5ɳ,<+qI>'٤_IqNR|uFW7Z{zP}`lӮ@AFGhn3eC-blVvwohhmT7a?xb+~qviL ߦY8^->-ˎU)^d&Y ~I6O*W˻ Y%4_ Y:Yֱ.K?'M~ZKvj N1 1} *d;7ǧl;݈cC甪 U pjՉ} ZK{(clvY./O~{yrtr}ՈPLO(iB(N E )X[ e*mk C$]yA~v n^v[/rF,nLYѰT4|_~?ݡLWx-9IȊ;QAL0ܽA q/nc[G޷3ϯ~}}TY~xSAf)aG n[veɍlo fA<٤xH$ĭ!7 =vкG7+ƿֆM$EgҦ?~.@*S*V:cQ|Po߮>(Y!l.Oߟ<<N`f9x74GNKZ2'L|9U ǝ)Q(X=#oR.=EgnbB,nE`ΗߖuNۿEg'gym^VEZ2BpHj#Gp#D#4&턿m}7d5dķo{53vg\((?sq/s<''h;@BO dlҡzB#FV3²(F]dj:̌ W|/̊HJpUȟbTmɞfdv*=]'U<3Nyl6r兯לX PIv h Dd`(`\D.%mdD)YdT8"I};wN6ay6Iޅ$BɞWpۧU:J{"J2TPVh<|~[V]ڥg@CSBM "]eתv5ty|VTR^ˁv"|endstream endobj 164 0 obj << /Filter /FlateDecode /Length 4078 >> stream x[Io+[ b0ԾHq; dG0f2IF7?$xU$[@lWoVq(1/:ُg⟫?K Yw\pa#4NC~jCLۄ2]O)&F3spu76J1rcd4dO{r:D'J^l./2yYzLM23ܐ6tT~j#8OsV%,uaGx0HZiЀѻ3"㠗Z 0J()p Q3E,7҈4m,V3e~G0M0(fDa_uqIWP3䌫:<^<,l9{(t$rv`(Ϛ-XSgR|.2aY<1`ʴO [3W-n k])A]Ӭ7%E]JB |ij0S?X,+@ ~;T: M%S5Y-K<:·8Y:: 4JU͡%e+JAU6BT%P EE#)cBOWK%RgÑ&HصT v*UK wIeUmdҏôPpr' L91~c6^ nGcxW+bN Ǎ醈'ǧz`*oi\X QڐW%bFCҰB? Vj#r>pENzsy|r|' j}M$KGOpQ9,K4$#O=`fs+v (H/) g)- _?XBy> stream xZKsdS-`L4rRb/!U!wkP2oɿH5N*j_?Иf -O~8~tYϾ89;0:$,3%eR͌2ԁ]O.ɫMU@WN:I*FÙ#EŨZq ]o'gs6*5c sf:-4Ψ%(j̬E~ ?8VTcvVs8N$TBQ&Up+$cU-8cqµ`VcV0I<=Uo2$ 'A۪9b5Y,S @ H:MUse$ N8ƴҲ87*s;\FW n1Ns+3]k \(V2@jԣ;\^O2k3e(w/4c'и4e0nYʸ&7F9`ʒ}x'fh$pj1aȼVZn*:mT/7QYEj[ 8y̅[!w/=&0̳g5Í'&-$x g]PَIa w/-fmZXʸ4Puń*imPr\-pp=q7W+Qx4$Èl65IJjgQWzͻN+k$iKH*F!]nᡫ`ɬIKCZoܞ(U,,-i:DY>xs#!zy4WUJ$©MZZl2njp^F9~U4 1o+NIIC}ྍHc1#(Z0XDY(WšӪVX'2A.>dYor]Հ86,Y\9yǀ~~; c`t̨acT8p]T H m\;2jP.vc&욃SS䊼WUMVmw{FӳZHLeOSip!IqfAՒ$(<1EAǠL^ţT9VyhWBx zZ1FK E8fCCn'#S*츇\%nE&v3LԊ|PvI9˶^eq%}쏭 -"bL"PJŔ'|r9~&eZU6GP PeMjyf88RjҴz/s 8Z3.=>aՇ/ nȪ-њ_G}yq >㭒2%V $`'b mG M|"u ų~F<"m;kdѧ-fVc *Z2)_R&INZJ/ LWtN^{tȿwǶUrG|?&1ؓ>ik[AѮb[S7&(3 ^}+FjZR x^S,U3s݋ W=)@v {a ,CZ-8uS#sP@a1f,]jQ&=#)~MЃzƦTO5<~vw_yˆ X(e'*ΐP e-opti@Gi3CԶA1Nztڣ$]MHpso x!5:lZ!Ry=d5.*$[|/[`"$׵*TŻ}Y}<'w>4xbQ1+Sp#WΩ*kNDMvȁJLbt屦y]wa#։1-^&r1% &4jTҶٌK R+ 0QH+—޷ńL$]{c?Ó:1dAw8kunv,a *X gHIvoi˒[l%'œ0Jn}n> stream xZoCz`Yjwg?@&EuݬgPirm bowvv>3_*FyvŪ/+Vmsg1ǫWWWF@UV5kFۊUW˚QpH7Cy_7:+׵0Ynplr-yQ8wKʔ"췷ُarZ2CŃ4n|d\tZ9'ϗf(҉tg:c=c |xߴ @QfT20^Ju`A DuZhрfT1Y5:뇺QBQƁ_᳤ E0fsaqjfMnkB ttD#W_.[u#sԹv"&LJͤ[7\{vk$y3! 5:}T.I2Q&\%\>nӝ_oO#[O3uT[ wu#Nj3W9ʘ!wޔ?\ HR7Rq7;aHO`FM9:m;L]]8\DgQr]D5֠h^ 9I<*iJw S#IޖGI$uXc @$i&+ ~ٶ)2t}z]%.pI)K:9)%{/FT ᲏ M,< (4ܢ>g69I{8 JjT D9^ Juo:ir2RRb xd^e?*%SRW$~a_KL=yZE:Kw{24r}mTsU5\SㄈY<0of.\_#^uRB۶bOy*wxie"ec)=%%?1R) e>9PF.N(6#]Q)=E-Z ׊:f(D jqYȢ<[ /$P.}psGCpEyH6kNIGJʥM>`BObHXI~c(U!y1GNXjÒV )a %]G)8OǸiEv"B'<%-cϤ&2_L( nJN$(9SP"T2'u*UROFhn]FHGUI}N5,\)| aѓ@Ruڝe(Bp!%/G<> 3ANy4E@K{Մ #o^bs5`+wA!XOԃ}fYD&0u=n?e4anr!2]aE.]{. ,O2)D`KC"LJ1ڲAacgG "JL,[*Y,Z>,y. lrpMv=B }qy 'ŋ I.(sL@:29`͔*Xⲳơ<bn]wSsOag$eISzŲDZje] }N_`cQM/+Rj 2;#]"Sg/ׇtK&t3żlD>Pf <0F$kFV3$BFrԮdPc[*.SdNEDDbvJKY̗ܲlP2U6ӣG%ɏm2>3oI4k<~Dw#.Va$¾h*`~Qΐ0C7;.׻H[G3YK1_=0E>KP0ш6g]ԡc6.tʾ!6\ *SYo;saʌoW?ZUG䍹8y-rch']+}`ͪul- ^A9ŘF?0vYoۡ zG2T CIj*ۭv`lѹ;|Ɗ@0il|Quݶ4fz\ 8ILZLx:m|AfAY)0c?[ |f>bs_Gc9$8 Qmȶ]^Kmpq1󬡝zYL;A183RG~x-y:]E"xHo ov(KWvѸ l.JʄBnΊ*¥!Bdڍ_DQWtRBcY*En&RAzH~HnK)hn/֩bewm7ETKݮ?P!b On''n{+M{J]ɓZ<b(?L 5N2]y4bHmڗ7QWyFL&fi$R &I㒥HI^e2xoA$Nx°9{8ƙznZI66P>FT6yGvC7&A%&Po -8kqq%a:P`ZKߤx+b%ܦK~Ze·HYf?}W4BJ**.-ja>٬~ `@  <|zy'j4VPp\'r`WnJ3ۈ91B35%6P y)^Ϧ>? (c}Sˋf#?$ }d{݅Dt `AXf慕wr {{#./fM-R<\DcPn8[0ܞw{ݮקiU %v7|^4 ͹.j:R 9A+K3yg9 F9 ?;+`+?Ö!pj8ײyYU} ;03ItXGLjh 9 g}y'i?5Qz{z> stream x]nP=Ox߹FBI6YھKE0"΢o_qE>eӏ6j~noK{n]rI۴wo/m}[;q(շmzendstream endobj 168 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5130 >> stream xiT׶ǫiDDlhµ 8␨1&QpFeM2L H jbb$S4ܗKM[H3uCWS笳H(K J" ]rMX:tI ‚w%,đR YO{e`-kˎ9X7Ɇ] vDq6}Ҥinn|bLvZ pRtZ6yd´ANB|v}|vZxǚU<^E򏢨iCpTٱr._O?5^kCN4y3^Y 2GQU'BP^Xj-5ZGSj!ZDMS5ZB-S˨+ j%!5RK)%@9R J2nAI(K*ꑼ%ahiˏe#edmro=ڛg>j%ViߵN=0Mͥ& ?jؗZz 6ai E(5hy&]@@7Aܦv ik|Xw0"@C2(.,="= Qɏއ0u1 3 NSbC&1 *9S2^h-JQPbv;M,BMK9'Jgp h:Rw:/,|#wyf1-Ji_2I5T4b|O3F;b5 ̯G[X+fa5pͧ .4. ;`3cL:10H K,fH{0ZQ?!\"H2~CƠ|W|囏&u-YdH̃B`*Pc(] Qܼ^KI"+%>2yu4ڠo+#t5`ۃFk{vF*8zzkvpgie?rd?Q#|cxbmG\z/W*ڂ9̡';K?I3՝ FlH/z.~K߱n)8n+dUT6v}'~2(ԯ{|Et1oxk[ygfpE3;==?"c:ocñͯpzkd ǠBf2g8;bjS)ŅIYjM.-"+z*B1APY%1Nzqr/[V-_}kpC"2y&iRLR-Vx]/#pO}@ !4{qˈ5QtOA~.-=>95=72(u<7R99n^QƥgF{xBѐ\c#Ѳ08UffJ16#M5(E֝+p[%P`0ݵq"V3u1ښƲ{ 8S^sԮL#ӷ2kzg}AoC^ <ـfm1Rǿ;<~"hu==X`VA*8r7d$->A / [ҲҲ#7 l5$`"~G] n1 ]Q. |REC;Ħy2$#VvPpL>ԸqmA! >ېQ[)<$8RUs7Zp r/{TAxHاǥrѻL8N<}1>.:OO~ouy㡶{^GoN88293 Ƕ=h%}o'8ݏ@k 5$$'A$@c9Di1:>=*yV/={ݠ,}T0 N(R?Xʌnghz0ꘁLΜUȞ]&~K4+t*^ 5f:q"η 4;%k|KHWFٕp ZcLKVQ) UolbLtٳQ8HQRcSeK5!zt99Se6T&ƫ[Jlӏn8'~\OAINe47՝ 댍J\ i!2R5Z.pU7?OQ.?=WJL.۟4̎ ŭ3)_l ؆bloq,j O  әULW뼅s/Q$hA1{Y9㚛CqDKm: 8MhA, LPߒ)Ư\ͅX|mcӾ5'T&oZN]l`{HH >< \Kt) il8µFo΄,ͬ yǡ9Zñԡ)P}?fgF;a<ʻ|Zq[%SI"'s7[.[-hƹ́lGk 3mEnUͬTLTRY)Uǧ= A(tHM+nr\ & A^$ߐ5> &F+ Y'PsvR Fߐ-3n4'w?a.yNq gHQ'~xss9^zH'`NBb:V̠EڠbS}4]4|yع ҫ"v ݌qOQSi;>EsI Ř[6C1^q.7;`;γ9c֓OUV^sCKRA@^>gL,R6% ?T:Єsąd%@V\#80G B(;A|A=(d+tLjĥ,GKb)E`n7W%W P~C %ŽQ47{*.NT*>> stream x]1n0 EwB7K%]2(^@CdAq޾ tHD)@Fa PV0^h˦i"R/ԺV\ozp7endstream endobj 170 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1484 >> stream xukPeǟ n b FMc" "^[I.J ,EPۺgEP&"oIyDftfLXyվt|9ߙ#!r)H$SWGŦ.3lKZe0ff:Do#ˀntOx|*9&D&O 6f$f^ {- m]\n.,6>ٔmNNŦ&u$S.ΰ56%QgJE6֮ Z[jmWs !K2̆DcT6Bfd &d9YAI8 DBAKvJgHma9Q^6 >#z75YK=q#nRϯMv(}S 9 G qC-]߫ ),؀:k'ׁNߪaYi1,86C[!vqvB 8)J^]dp=zib8;*-HMO)4Mhfdbf&b⨹gq`7zM6q4FQiw$r\uESu]TjH%Q"ͱYA+UWiyQx+8[69yq]]-r\bM'NK=hvPcUå΂Uqkgl [ӽwWf`Ae;E-.,7U ̘p]ڮgvp62&?&8UǗY94SK%XUJGݾJ{$߸B0IJ{qe79UG@=]ݘey{ xsR9KZ3mU#CFtzA їx58<nk͎{tE-h?0)ArU2WUz:xKqg_Oɰ0ݿ`uE%yni?rWىF`$Éov eȣLI+P-I0yӉ!4wdjS-?NfdGitfԴMgc./P_ͤWcls/+u^F}i=E55:ղ ،C<]7O"BCY |#?26Q g\Sy1ZN'v>3W@Qny+_~v PrKKkV{as]+=}v'sB{2ÆUNKȿe6pسD-7eacZ0N=&OnVUU^Sk;QVHȟpMendstream endobj 171 0 obj << /Filter /FlateDecode /Length 597 >> stream x]=A|NӖJ !!`Yn^-Vzk\-w]_O/zد1~|p߯iNw}^ӻۯ86<e}Lgy5Gv,1,K[UsMs/:CcL2H)Ʈ7̧2HO2HtAiAi M 212#'䈑 rTE9**\cl2-.c< G|A yA^b _bdQeP"sI2(d\ Jd.U%2&KA(I%2U%l2(9dP.k:WdPjA 5ˠFZdPB2Q6ԨP jTGԨPԸzA{ jTh ZsK2heي ZlU-B&![A(!I--2h]d"s[e& C-^2h x>ˠGߞdУo2ѷ۫ zM=.}Q= z zE#~he08`}zUb/]1n^^o_q0nPQendstream endobj 172 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7894 >> stream xyy\@fP# u_Zkw}d}F $a@XźW֭Zk[Vkokg/Ao}&yFDP"aƏ]bY& lDݞhĀaEokzQbhw en/0O;v3ܔN9-uu iVFvck]y丿EQs6 yA! C-_\"zJUvYCǝ-Ƽmwq?I:mA3xs^#F(jA VSC5ԛPj-5rS 5ZO6Py&j>5L-Q[שxj5ZL-&QK2j JQ+W%j&O({*H>zSb>KER䔘GPP.TWQWQ7j %l)%X`3ӦTW\.&~7\JK~5-&i2뺮5t=Ǹi#{I0ĺ'(ܖn};v*˖c?YO_v Pƾfxs8AiS/Z3H?x Y=qCaآჱ޾=x "E}y% 2UįN͌ШS{2FXGlDZcӛBUF}ޠ8vSd>ՠT3q~t# R.A[agf^U&WZ/OoeЙ5yug WB菲7+H9]9?hk9bVr{/庬HKxQeZqO_><en34ka ~)`V"2KF5dALŇ O{kF_)}JKq9ed:I6 ~4Mp5rަ6e DdH5F ;-n0^dY xl5a36(""{#,)xK;6NQt$ +ߩ>r«vV5at*oˋ{$8idƫ@G%N3d><}Ptg<V0ā"0+p] THH6lxb4*2L";;N%p%N(:qIqfW͑%Q,\+'C,x5SClhG9ΤπnR{ Ae lkOva}y{^,2i$(ƒA&<=dʋuHYv{I$@It(WS >7)%qⱑLpV Dksd5ÀY$~ZG%JVgOYyyVGEڰX$ϲ$ =׸]z4%C棃jM M)*C|3oGmlޒZ y6x8l4۝0W" !9.K0cIdo7Tcz]Q0fI uDbTʿǭo;N%xg6S $ph|=Wۨq4;A˝2 3p]d3屦s^gFQ8qّm~H=JX4?B}hvoP6CDL3vdg*Kp?)P* ,u?nŽ9ӱHބ<]YYιPu6ڤO3p\`!TASiR$jԪ6s"_ȋJ۝/ a奍:@ ڔ$[6RtHW7CӃ5&(ħs3,K=KDqF;?i|с&K3&YfH/ e?4eIFy|~S4EwꮣkfG6^#}/ę^VNp+ -մyS`f,ܺĿ,*/~^Qp<gwMTx5okv0!Z8ZʱӪ]/PyR߽}[É3-m8#5xOQ%Sb CeziBi"`>Ȓ@;ʶֵ[֬FGWx}|4;'ܘ_L>l,KjHL 1ƏFX ͺZЂгq649Gdέ?;yo:3Ӎ Z6}D/O~>.2)P  -j~LV%J*7ZpcHayfGsTU #`fH`/ y ;B5YϐD+Jw(ґ=fuE{tڔaD'#b4h M^lǠ qTH:|]e g@DiY&(b"xtJ.x5Yˆ{bavM6U-MfC8j9}IՠpӨ! .*+H Ez>F {gT?,,=__d$@$e_8h@ɬs^C!Nň],dtVz&=>=1`JE]{9X7?fh@,Yc]P\% $; *A^螝kő$PrDEؙ%?6 0(*B<.J9l1 =-`_:BA BE/4wVX^=h$(|x_YfUE3l;o5g 4.ןhF ij5N^ECX l Rțc(1O9y˯VReB]F(佘NO˜.,Uj8{Q`8*[UX!%QNrC&{ÚA+42X'1}қ0!I_G!Q\Xr)#_(eA]SU㑸Iq'SR%qqd<.ĥ8'vnHצ> 0}5^@-ǟL/L"m{J<׿=u@3>'~tAرw\%*! +-,^Uxwhx#[8GUhCnBIC8$w$8 n^Vk(@HpI§#K0BZP+r͕c…o0y#J|>rUNpg?X7Nn׬;!YCAEqYsAM)0]r))BѸ1Q F*5E Lt~BQNifGJ A:ؐ@w`&Êj}]Y^VeU5 SMG7˂M#-VoVӋm РݧuO*ݑ!A{՘λ mgx|F\B*%>lEpLߞՠ}pU$t ɜZZAN& ~jލ EnɄ&x`iӏ֜\5r@\mL!70՟w_ v#(:Bqw%I*h2ƒٖq'NY\aZYT3Uʲ@ed~zۧ}Rtu%+#p=/j4c2 QY(]RS q4@hSAaLG%q~ƟGpP (gP%ij( >d pZ05[?mmnudۄ< qH3dҮɺtPn!x/XaR] !2.!) $2!f^W"#ڼG38RYd-jrp^3<_Ÿ#i2hԛcf\ &A@w()e Fa딳DȊ'VG -i4~8#MlnuSyQiq{~Zw]0+0HҨj#BF*jςi/BEZ`aDɇb0`𕬠Cu O-F{}=7wKq}`_<~CFޡI#ښ)H7KЕ@5IZ5&#x]6{A5S,lgr2-#du`|SBZJ'nh{ i8CHU—%g4/[qWs4wAW4Scv*2VVFT)CCês eeeꮧ|8[R/)9sU&Eݨ ځxɘ"z@Y(=0ɘk/}ANġȞrN!1Fȵ:-Y8I؎\۸'sӪ!/(HDɟ؈? :Ndƻ)Hşs"ĸC/z[\XXfܱU INOMsJíay:_ wK :}A[*``:ןsǒ^}vݕ PA[f|q1JĒ>fZBs\,c-#%k? \`U o+[RǦfrcAT* Yd!vL"R-#KjH !cb\wJZZPZ[[YYC#(K*:#b%A̬\ȓ pS$jnì6IfMO0V`q Sf0'mه޸yNg|_w%|LϓXZ;fvT5t)v4 Ъ, a8^h/G00/KO6)st%¸&@**$L|-k8kK$zObOb,{L8m_N#DpyI=IK XGix(GɄĞ}} 07RVy'iA*>8to1C~onnYG|d*eZbIhUdpHvY='l)Z~cps̭I6{lST-_f=b9xk~#0τOHЮ ޡ߲[K҅j!I=*w$$9}oEC oLcPY@o܎-AϜ5؏#Ex )?\BAFLbtE:",]h8e^J4]쬱͏p 1&dt8 (%6)vP[vx{qfruY}r]ѷdۅ@&2qsb`Xen-O2ZG쁤9N+! `HrNy[Ӱ 67 u  S39:Qۿ\YmNަ`eSB[d~Y^z,&cp[z>@[V =TW(@ +}]9\gL *ھ=`vhsud;mSx-\%ثdezu~wNDJI2 SgP?Qj[J,BQ %̍w +񄍰җH.'2)I{槖2!fg/ef܀|`]Bl QP~Npx&tZEw.b\+˶ ucA%AJc>V0닙f2@jIW{OD Ԝ4L)4{D,;qw7o4lo&4Lqv߷-vזUޤMٶAk7;ҹs6̘2b۹_笚b)yHXCJ]^l ޗp'[.><%l[R4É6+ܶf$^8rImk] wj]O}RxtQ8Q N7U؟G~wve<ߴ= |6^a폍ݤO\IQ\>א 0k?pZҲ(:~EAdd)*J KLAۖEA,OIlNR-=FHǝNpVEW{EQ9e~|"RF&3%-E5}6麪r* j;*QF<=8'/I`.&aOR=v5$1LYbw44cO1؂F)Pauh {N`0TJŏ#ΒI@<$ H/ߙ0uZjF};6y(/-g:M"4B+ۙF}ΫwxpMA!BGN|V'];z>+Ih"-nZRDH`Mv}Vk{I##{$jj~I- J rN[0i{ kp-Xe#/rBN y1%) kaï߯lH Mb 0IWq]mvb,i0/tn>h0d=(endstream endobj 173 0 obj << /Filter /FlateDecode /Length 324 >> stream x]MN@}̣f6q1) 3 ooft#y?Ewrn깙ut٫6ʹ-~[8=Ml&iKL_M46VCpg]bxoKcOĞaG: 耔,f: e#F!t@n- vrV: +%:ĎHHřJ::@:bWtXUR':@&J,3 3P"PȒbEL+tt@"KOozw]>0>6˪36:˹endstream endobj 174 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2910 >> stream xiPǻfQf@2=㒗,Ⴘ :"("J9&""JD,ϭ|I41DK괹Tj4XyzC[uY~4eoG4=waѓgl-Դ4N&vQgX儇~ .Dhzedؔ-jhS'Nվ O̚ [AhfqLRڨ 1њH}ئuu@Mr?ͼKyLz5EgFl5aAXrڈő6m:mXA-R~;OP+q,*M͡)Oj.5Z@PӨEbʙRQjʁG hʞJݠf]ݷe }} A魦hޒf*0TR(Hm>n>w-$ kJZM/o4J OHw};? 6 [B3ɰ$/HqGpjpAK&eh^B'b?ѕ뒜p. >Ljd cz Rh'\ɋ7a4 3f.h$! VY++;3; ?_u2^u(EdHTL!< P(tLGZRиY%pbS:`t氪",F1|F<! U5emǒZK¼ # d4eA)Wom<7c?8T%pm p3V[t۰{*%8!jt@}sxGY:f?v6i7&@F"*#u_JSjp1Y" /t!vESY`hqU)q:rRƫmdx;)=]"s`)}:=8"Ã3"8T`Q dޡEԄ΀8ؕ{$mAaGٔNh'p)L;_k=.22o&aKܾǐR,JF\f"M9H?dkSd%Լ2w#d̈d8ɩÕ5*=W&JN#Bu.BKTy4m!tW ܱsxܱsܠg8pcrPsNa9 7%j l3B˹ %QMRl#eMޢSp3MYjl[7R-)VY#eܕsZUPP!H(XZYnp6U+{l?@dNtP$CV)kO\<X2܌ng( U5Agu+JKMEמqJ|ME2͖#--EՀM\-zV) 8q[0P-]*RtF}-J +&?^U6B"YnlC>v,z[{o WA0dYB29rgMjuk►±eمSi'X_#GK$jj ̟sN/N/:;a=T# q\q AQrX$IK"P㛯qތ\ןC{i>Nߠ(r*E\$3E2v*\UP>4AH1]bOjL!*@;R2fzm?z dh'L}* Xټ#_ç`5 Ǐ .KN߅t|gr<@Ze"G&o.>Ay.hy|GZ ߺn/yⲶc8m x\ӿ'O[GiWI<0 emvۥ/ח'?esR8ѫ5aMNQB3 蚫e7/=Kd8·CkbNV(po8z"ػօuA7Yf̃2RB 5Q'HGF[jZY0tzw t'X -aL [-J|a8uN|s<_ l^k.>D pF]d`3w3TM@'\OLH&;"KK3!k/n;^\£=+~e\SP!CECjd_rtsZdZP\.endstream endobj 175 0 obj << /Filter /FlateDecode /Length 164 >> stream x]10 E7HR.:NNGI[[+ (l-aMH0Y4ǼOl'hnfO}:U0XZAJ'R}\/ퟴF;[R(%Z kJĹV~K 0;S1endstream endobj 176 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 324 >> stream xcd`ab`dd N+64 JM/I, f!Cß^<<,{$ݟ3#cxzs~AeQfzFBRWbrv~yqvBb^_~ybrvF~BRjFbNB~BHjBhkP{h@`| c&FFk3^eXP33~~G}iKw$f|[Yw_/~7b"k .~|];y҅?|_8{! r\,!> stream x]O1 y? SĒ.ZUm?@D !pپk 7CteS[F&f$;;P@vᚌlℬнat# FlNdY/&HY@T*4@ 2?mꝚ 3BoQ6D}TUc_\endstream endobj 178 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 932 >> stream xoluv `VV KT4&dcncҍRf[ۭ۵+c[^iG7(`͘% t]YgB\L` 1&w_ɛyiT ݮ{Vs}{Wy$!רZ5j4bchՠ(Vw67!5AwtnP/lnf6og:Ytu;=v845n;`:,=AfikmjiehݶyZdBכ 2U41zW*VV^Dgs8#Uw~ē>8$d|J #},8LM%(73n )Nm xHwiUF|5i px2O7% )8n`6ܯe#'!\q|gi>!j  V5%9q_Pu) ]BOyP:Y>ʌ]`PIHir2¤0%}hPF^ GH $/Ipp/+ 0bƵrB$*}%y`xB֋b,-6ÿv-/Ana8YBITO&aZU?0e&\.ޑ? ʺ Feu _`."-HWcifFiaZgˈ 4ʈ3x&GwGB?j{ƟϜұ9@Wvgp+p•6|A<׹BxZ;X7}?QyIԁwN[D$b Wɯt/)w=+_1uj+g#bX%1&Kh7h7 '9 endstream endobj 179 0 obj << /Filter /FlateDecode /Length 399 >> stream x]An0=OxD6 &dѢh{-" ?q S$8e[qڽ[m>㨭u }I6m[-N?cSOp\-ǎx% cS"aD_3Zm 6q(018P4x4 cxRtX)@k$Fj 52(@Hr8Pȉ1SF)y((Q(Q)(}PvvxvX)y})y}k-7J+P(^d PB1 PB)xr+ ( Lt sW?mw}qukms NK՛endstream endobj 180 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5170 >> stream xXyxSu>ih8FzP)JqFDPZ]itMӦi&iNl%mC-m)PEdՊ2:(sܫN>OڢU/νOJ$~}+a`$._BQr$5υ]0a!ϊ`R8Œ)Cw}lT>„ABFBIFfQeVĬXgFKNJsӢ-ݰ4zc^IrT(/7:%=39{Otޞmۣ㷮ݲ5:vK\o_cܼ5-*$X!mcM[$[gܽ䞘a 8lvۊ=maKX{[%bkl,[ {Ŗcc/`+u#أl#ݎbL `K06k"8pua)A.:ۧomoOOȺ}m ̇f{=s\ #;^g?GFH&.ϛ;τ"¾v%7 {-(hGL L>B^_(*ILd*iB+  .-hJdVwuhN\%{UIjUn`{G~p,"]  [ S<=+>FZU@jo\fiq:Ɠh ?q Rw\ҙPRȑVl5Nzg%o\IT4v7 vz5Y}gyln~2Е wg-c' Ga!ϛ~ŋoBb=@CR}Ҹmwt$~ZC lד5ǥOW: poȊvm<zE!#Ƅ5X)F`̖ %`J."ԛ<&a%+^aT%mS7q"Ä숟#G |p6u m3;q7ԕ/G %4q>S,}9-CKЉkz$Oz"K J4Y5YLW?** uK5QWDk&AJ"+u?&*,ê~u;}&STn(j&.0+K[[gR0VVܜ݀7!U,8A L0us8z|uy&( u<iojP qHZz@svρ7 |s-/#B󄏠zKTH!ip^/>zd{7?@vzO+kN'h rȉ$$IgScB AA* FeWoQEa7mq2P V"2Y MV%+*G>D:y ҙu)4Q¦M|P`4()?ܾ0@nwףਸ਼9V/ՃC hBnЩTm7KvBa )$uUt⪐+ EHbZ2%f!G7Սn{(,@2UΗmY;G!s;:+p;RvT)ɞPVnZUf(,e,:rlr\ Ch^#uChA:K\%2 ֘L4H2M 'N9fihZ QDkR x`e4MCțzaV{{:7@_wa{=dU@L\GJW$8 'DmQnn 3UaN^R M9+ cI"COSpVp$c3;rS65#fL_;}V`v[mP7)\dUߚ0 y?}ז &Q߇j5!تui &FKYa(33'oQOMFPW74y],y 3fo1p-P+a ?YBl7**LU*,ۚ#zKe$yl7yD;[ wWBk<:OƄ.u9'zf *^*?Xv|~-Dg[hMQMަ-y#XGBTtTܥlfJi\+Y;SU* 8^4ݎYfpb>l)ʅ:7r>q?Z]4 S \$I/̌|OmԒV_蒲? 30YˏehC;QŌ ʻ?Dm9t90 | ᢜ?` |ǵޡᚃAhQ]E|^hkj8$#P)'&DWb >|`0^m5X$0@ ϋ}-3 c70i߃e]endstream endobj 181 0 obj << /Filter /FlateDecode /Length 318 >> stream x]Mn0O 0N$4tE=D,b!޾颋ƌ˥L[ux_)[5N%rk*u*n<73݆ίHTY= 79|4uk}Rܗ!:~I>5ψsh䝏5w>zv} 64'h6c Јh3-ZݨMlVw`t/lҚePcVE ]N# - @z@G ׅ pdƁ ӳ!2mUznmT-*)3endstream endobj 182 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3540 >> stream xVitTU"!ݥUF5ԧ*,Ai0 2TRSBjHխ[խ!5&$@BA dp!m؈mۯ΍'K*[޿η>{oqM,_"C&@9wNeC87bMI24>|^P*4.CzG&9s楦>3g ) )f,/֕S2R^1;b]Ff:efqQ܌✔R֭ymWK[3kF_3 Jr3vdfKrlMEQ/)dsv ^zq')JREF*DF-Rsשerj5B=Bhݴ@{Q45:AO;`Um2n!r*~~Ww @9y+&Z5.潹Go&}2I?vn.y

Ċ_ WS^UQ32&y~]'u(>} y!&mt".ȯg`O^(S1nIlgvlܺ&yTn <AgK$)A`WEiH_$ã+LJs>Km1e"r2fNѣvê(.vmЀvJ* t^lWl"k쥚 Jk(0XuOlm?v@^8H@Ps _7|pXF4%%%:cK3G*yonSUutjWb:hB6fֱz"17;{ _k:,lMV*YJ@6Ӄ]R*r۠S_ˤnfC: }ub [\;20x1W醀]pKpnY`mN͞[j^Z̨2~^T&YT,ej\f~u2}vܪ41.F/x𿯄7495*?Dg>i= '2(8xƶ*y(4O= v%K+-\h; M{}9J0&@% PdV%*!oϼT3\]O-?yl rkKB׷߅iwT0Y=1@C|2y1 `C]5Swq'L6x$b͍1?:0X{2|a< = Z\r-IMG;'1dE\_'l}SzB&7:UDaNiR͖l nntyF^Y<*N#g4{i'-0/aw̉t4~58(+`&`lb/Wʛ34~'yOpzZ3Ls XJY.A3Ł p>F!PL]O!ˁ /w4ͨDSZi26q`gGW.`sm}m#Dax]Jprqk'M݂vչݓ&{w 0i2EB!endstream endobj 183 0 obj << /Filter /FlateDecode /Length 566 >> stream x]MZW9`r~AjĞx(Jb10p{GUmgT_O_>/<ߖv_e_Pmy|;?v/~;?~ݮr8Cۺ}yvU>\~k (ձ)4Ǯ (GǓrv(\qU@Y7rAXPݨVT7MՍjW@u:PT@GT'TgT U h hЊ+ )B hІ+ljZ|c({^=d 7tٻ'tO/ }U@T}S@T8(`$GQ*`x0< r   㨀=)`Ѹ(`X0|cUp)`*`D> .8 Ϊ邳)` .8 Ω>%{ׂ 2ˏsgeyKS'/A%endstream endobj 184 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6444 >> stream xygXT+Hќ1b45jbl (I;ްD,C4XIL&&:fܛx޳kwPzD"sm]C|Փ q4^YH)?79Fc7w=='-?ܹ _:%|Ҫy{+='9d=fޤM ޞfMrqpq6umvkm&ݼm[ۭ1EQ~w>&`mePpU9ec~\7mq;k9{:sz{w,|wL^:eiW|˜&S)j5JMl5Q۩Yj'ERjZKMYRu;zʊZHYSRbʆDS#QJj4eHSc( j,eDXjQ)cʄ2OM (zapMj%hJIN+I_407Iϥkd[eϙaB];刯Gy{Q݆7(<?cm>7bhx0N113I3ѦٛL0p{ȉpx|1ZT In~bR+%Ʌ19IY!dXmX~ dT!)-6))F+롵Mbn||R ]rwrĄ?1X^GcXʵB$Q;O,_ƳB;WёSI7…ti#Ski/oLInf\k9T*vko,^{2w7="RiryS4c,~*:X}uly',"O_rTOR䲀 TtG{Ad,azs4-y66}w;׭J)>ڂ BGO-'Xe$ƴZ!J>u=khI s8.kVN@@ jPS{U^b.: 6>ķ3o8 k.+gEdF 5rʡ7<9.1OK@;!'fĚl@}b T*I' Ƭ႟ɳ/ZJ]ņ }D|;0(dg^Y5zGzWGV R1?E8ep2ym2D7B$\$Om%Di4!r{X RצAZOp4C!,,ԻyFN}m~q*I9wKq):l0Wl3pBgxT)끩h;f2q!44B*дT*=z>=z:1k o^T.R] E8ĸ%1tܙXWJ`4->5+ej԰9`a?n!+{gG$&'C f~Z&lܣ[cT?]dWR+]SB 'h/^Ԉ2rt*S!Գxѐͅj(cCY;Zb_ګť|0D2{aldo=ǛZyv;(M{idͷߺqzz0G*&7ujOF15#* A_6D4nO-(Oor1A\S OH KCvns0? *BzOd<1{1]dӑC3O58#Utݫn ,ʼ=6 Rpx<Ѓ9^smpcm- 85bBB9sK 7N\m+~3̾x&f8V%JE+CʽgϤw^WӱGg臟@+Rpy@nTa,s,ON!q,'ﳜͿOXnאR5|~pQ˕0VBacv %&\]X۶XtϽ<;*;a*䬄5Mcb _{YI~ngSts; 2 bJvrlliz-AvfivaVn`޽'gCk|KDsMq}vIFB`*[d=rNN;9ȳ7r.%FYİ~U:fpZ@DtB?^ !f` U͑r98nϯF;4ݯK#|J0fU?yPECm@zɨ!(RA"*ãŠJ(B-1I0M<n~-5*O[MLuIeڟ%WST b@缚s4"++1[On!^GoIPqK*FUbx21|]}|Z7}%6jWUINɗX&F$ET敕+˼ |]y) *) 2T%1ZvIQ盘| VeÔvqH/#z;vD8!(INNNNp&RP],bF(HP }‘rlW[V)z(ez- C+*IF~\ȗtRy8$ !ar_cM,FOrΊ>p.R]̄RfO*ܫ2:)ث_տѢUϛNuedew}C7l17l!EQiv9sg/!/%G8K+%Y1s6ă{FhyvNN.T0_58MǢgvɲvϝre1-ք{p-\Jt2] j(V=!wKQT>EFLٕ:' tGHbLxiDM[VKq&_ 7jY,C+NTcցV!o W\z*\W|A 2sq 1W6w=C]Eo, (P܇!Q2\ڨمP4U(S.XM-Z?,U翁[ -my8{ho!+9gC,~O8N58^L)ΞޞDeၞ[W;}}^h:aPbXL2OX aUyE<6Z]y]ݵmEזs纮I9Ą5):L!:?0!&YWiiǭG$bhu'/hxxttqs;Bw: <<Ԋ]ڥh!HEm%f1_ES@}xyh]yQ^61~d1!dw:wWݷ1:_Ϳ)W9{x~׼'$EBTQbNIY0ÍɄQq $*Zp`w*lUWIN|׃k{b\?EB\ f!wMuLf޷^D Ȉ[u??7#2!d=Y)Nzpmqӗ:u?:H\]+hpa?\꿜ܑ#;k222 ?(9\endstream endobj 185 0 obj << /Filter /FlateDecode /Length 206 >> stream x] <o-Cxav #[NS ywezMK$z(T-]f|$Q&=މd-/fV-_N^X&>I{{kෟj 4PBSEd(!^7h n;۳ U}HLqp-D)MTIN|gendstream endobj 186 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1371 >> stream xm[LSi)naSeMFܒM&nꈀ\" mK)- ZNjux&[Y\Ff\=xV̲d.(@P}h~>_^/dW lk[(AogIBRږj|Rn7Q՛%jHX/pϞ9985jNn6'Q58ZN^v~6@nqvK85z# J9%Es8%NJ%Y Ⱥ&jd#H!R HrC0") 403بU~!4E׾g4&=ًkw"g5Bup7qp?\Є뗪JARyXVI0Gg!x+ب]ڪQu7uw)P7xن#?m]SV# sˀM +*I44wNxzxUIBFv=Զ;Lc X 9*jǂ{N]jrB RLф3wFo/%A8)#@"yA$:Yy_;p2xsm{]c*w_оhq8uBR b3vqeEg)mDSV!ڈvpMo>مTPuz!@ zTWgw<}Q%~` ѡ՚ RY&ׅ}5imgqaS!%=.Д(,!FH\.|ҕ <r&|7K 3Usg/,g&5J -L),}qb+BF+T?=~I_:8` p|]'bv m0 Ý]Z0bp8H8:XW)hWyhArduc%"n/v1$*Uݍ(D? l#7QZ䂪+W'/p|0 Mm髌O2J%VQJ0 j#l9R X!|k"hW1<ޥk3O,Cgυ/dey\.~+jFgn5[>fŽ&9^dl5}fw3]/zxr{|s׏Q%ò l٫1uBvl?39xkD z=zĤɈJ OR+BI1Xv|-vմDrc]TS)ԣa|rRX8z8z `H茣b "?\N]R ]n7<̊_R,I{eb1[> stream x]An0=Oc2 M"E2IZDgAODEi]n~-ۭ]˲>vu)I:mŮL+4'kmoT>/-yfhkU3.O0bMa=ǁij @ { `E `ѣQmؑc更L,{(&m6y*x,Xt DJ$/ B y4S43 HF(@t ]y?oem_-]7յWendstream endobj 188 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3229 >> stream x}yTwǫipiĩd .q85Qٛ}i[@it) 4 b,qK(&yq˄DGhܢ-A３yw~WFP2ao|lHoXD6$iE& "ۢ!rb{|j٣~ 2٪}RTDdf735yOCBcu1Q Oݽ5BBc4qa!pM|fEjǾ~E>ƹNٻeQBbcC(qiXxD6v)S}8fc(ZF-5ZD->Ϩ!=@FReC9S.OQd2`C([*z* &WZ[o[ѶWQU+E} Fܰ 8nPos_=6$*yXd{{p_\hG}IDF |ЧgrA@0%I:Tá=Gֵ!"uw`Xa"+EhLKXvCvcb;;$(Uw/dA/#uXkiPaTbVGz{z珐SI~<+4ܑgAL'5pr~ QUd" /o9&mc<%]ijRNRhnth5Ӭ;ߗ uYeXvY+x+a] bCTʑ".)B/}k-tT-bD: 0baisYM]AQyklO ja+EP4X[`rAQQDŽsZk}/+HFK6EIٹBne(46cJ [d$2QK#%쁶}Ϊ>IE}'Xً ,璔?e{JcmAIZGfQɺ#<` m+LuQ` v)Ud)cpA-`,ǴuKA^N9a Ki&E{LCɨFaת?Agd+q܏ZF\6 Lfpꏥv߻-Ǿa\kxʏ?\O菴7ȵݯR$vCBVY͐ĤT4Vxd$zzrUG6Hzɕjڠ [³"/\ K5M9C u>b!xpdX_w9|I E1DhmP_cn0sҥkI-w:J@(4o5@2' ABaLFRNVJ|(0SI*`(rƦѦ0`͸CNy maڀ\k({?gu;V"I6$ٯf`.\M,,ά )'ewl.>)>q~^+xLv:ۑmґ@Ύy5 ֣% c}F*H} p DmKfMy9L Ma'K{R0^֛ |8:|`^z[gßa6ώ9_̺;C.m7̅E%}cXf?4t=8T- Эu-9QIFVN KG1U-{/1l298鯢#Y|Vy@ uk\Å/_ZMVh' hw{/#cqo2t\ 9~s;0̄̉ll͖k!uWq:3`yb:6 ʘTS\ 9J?u82za\Pܚs[E dZq1A?Az{]QW~39q@8}rxbziZep:#d"GJ4Jv׽ͣ =Ƃ=?ߛft1rw% p' Nq2uy&]oeq{ըn10  %kr|`؃ِ&h=,1 S` ,W6 ቁ0|ta-rkC&ktfdnsvi<"!^{zۭwn]G_ `|Q@c1o9Йe3Ba!RoG[WЗ3B8H,fO, l ܚK!+Jn.zӓG[wj|`t Ӥ[ךt2\pO.8$*(̯edªw|[YQR|*P%%=K4Qßaݑ#p?Aitm;o]iG/eύkNؕ2r* E5L⒓7*<^w#Z :7֥-ik뱓ܛY^zӺε|yVkui~ʼl T<'q!' /?0/v^ra|殚9m7=g.tan< 9m_n I{x MtnGvٙ>d>yY~VV 5o ge[|JopJ=>+I.6{tn< LI&a:.'COEv2` %:c' \7a.fgZd 0 s28l΂02yhSrq i_ANrKCQv NYO}n3ωL`μKhIփ;D~#~4qLW8. s"U:>1ghT!_2fMd >2AH `:ZJ~+qdnH\<*wiob۴d CK&ռ ͦJ#-&.*"ͯbRti0?vE;Kd**1CX;bS ۋ JQ י6endstream endobj 189 0 obj << /Filter /FlateDecode /Length 581 >> stream x]ԽGEO7+XDJ0lpG` .AQw%>Er:A|~|5ߏ=u~8v[N\-˧ߖ<̿/˟uxh}Dzr:}a޷uRdPʠ J˱ˠ2(/2(%ǫ 5UeqAr2(3]e"J'SE5jA͢dPv,Cu2Y5{E5{"*uA޺ɠfo2N2hYԊ Z*EˠeB2hB-E-wn Zn6ܪMܪ#ދ znի zn՛ zs2d2dʠYU= znէ e'endstream endobj 190 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7586 >> stream xYy|֞P2,C'EDAJ@@@}M$MINMQEٵl^T UOz}ߤz{sÇ`MŅ%4qa)?39o7iG κ?쾿F{'֏Gcq@jbRVJtdTڔ/|/?k)ab%SNiޔ͉Sf'&L1%1bJ`)۷ݺmolܼi۠E 6IM|5)ymʺi~l>9<" 2jkq;?gB慾8_l|aˋ/Y:uٴWXT b@L'[6bH&;9D%v/׈yD0xXG'^"6~BŸxXDl$%fbM"$^!1O!<MO@x !&?|sc^.ÅB\?,h4zphpU5:.9﹍=A2e¤!I: fo-* itx6b$|D޽;e0MFB I*|!}ZKUÁ3 L: k5d||}n鷟|x9|eJW|ˢ_XΎVl&!ũa>ͩGk/Pػ|)(mN0W[jd\f,j5<0d$4U,'cxz/&oq BXaSC\tc}x!8`EO'P{Fb?EkVk HKP;j1Ժ /tZU Sxy+/:}7\Hֳz֋p8PdmM񶛼˽++͖h(gkӛ#C4rn3[s0vRH+Mxuqu< y_&T[7.[k`GO7f?v^Q5݅By:hz81QiR (K\EFBEj륝se]\i(0H5)EvP!2 }f^z;Rmr^gyhM%di?ۓA x!=EOzS%Pe~ b gar=Vw2N3xQC(F&޵knNL8ϵ<]HxQ8I9 XZ{1ِmnL5C! \svVj6b_|ۋ(C(!y)-`2SE[ M;.<ٗ(B:eQ9iD֖>׏78<| ͪG/-脋iFL- (3["J쉽_x(8'Zj)zxz^MS}>ך:kω):oJ{CmFjo95QؼjNGj>'w -f= ō osr!"0`v#MoL Y>Cy7%vypp&E`l4x n ?AJ!c[ - A\ Pގ|L8q G5nڒ Y@dx]\-Tu$4S_6EA.d<]وH(#i@gMdzM52i ;zjw5=s􎹤2yA|=D^U'12Uc>☢a.RZl//4KL`OD5V])ZNyo]pl+Eĕ4n~K-/#,C@ :lG짾B3, ٳ n+ڍ^u0LMFGh| BZ0&S{gqH~$wl<^$<@̓BO h,1}Z Di ]wb![?%y sO </_ BqʹHFN.Ub+gVV7Is}x0ʻԊȍ~rLf]w.vh~s./z\:O+RxUURxbI)bpO'Hz8gE{z(Z9ר\a C[d)S@ k

[%7̥cqؿwX/Z6}%e@ x\ƍ9zwÉƶfG+L%"s*`+ޯA޲~a|GճۃC?;GB#9k$Lz7R/:.rB}AT-Pl1?y=򤓸 gJs*|+ !l] O< Yx,Ew1/f"7b7zj*•d끳p!E=} h`u_¢_{F] xefŲ'z搂^7X$ g%!3D1$=D+bc`'TA}߶.w =I|Dew#iADM'[FSF.nzGCz_uj;af֜}=K/c6=…-lwycDZyvPncP4E_9X$,/seHsu(GJbYrA)_)JuNik^j-@ %s E RbsP!#w^^`mkV4:,%&SRP6S8{T[B`;DƝw9~]أAX ]ôo7WuV5:P41d&=sV'dRπ?eţd7V6{\]H3xZ PL8.j͙Պk]ͮc%_mGM}<F %:ߝ"++35aK(u%e^}:?*8LB?ԻUH+;P0ƏEܾe51!'CMՈ,MY5yĊ&h>:,-9>HxSUu4bUsYx~ɫFS1ݡo'kߓ:;'>3-Vn4y$1O%UA;VB"[):f~E~y~Elo撢5`/)i댿 }}YWUVԘ{04c!#5CtwÐC(g KQ0 (x3 A(^918ShF;"l&4קxEKq[zmnGSAD5eid*.~QH}ׇXktqz`~n x+>kOPw8p5<ߓW_?U=_\\ˀDr }-hbHh#6zp?>:ٌS"#v|e$Mr}W,'f:9o?(g,e P ](` 4tY(Oq}b2!cD}9QU)1 t,,AKLd|t;e ZЧzKO8] EJXd>SoS'q;dH)Q\LSKȋLqAId6՘Uыk+óKJhчY6Yrݹ$*Jnpi"0 p[1|,BQ.tȕslm+5QrfWA 8J -12 }jQ+ڼyaaXg83Nh,؂ E<{1 VAYfס_ݻsxVip!A"ksIl;dmmDKخwۭ|T,u<`-`؅z.Q¥ei m^.#"Ix9WH8$GY#Dϼ \y_gZQ-ޮ(3 ļr])T›3_{?DEYgWrtv|yb\1a>SHaD<}Z?Bcy䋵 rrKSP.y\{@vlrm@lśZСC@N< є &,/nB+KS{C6Y /&Wzڠ$E#H=Ƽ%h#LC?Ϸ6~K)=iz=yԋv{X/:!_j-u[|c< Vȫ~69֫`c8gDŧG$" [dK;$mG7nݼa|8>EY'lBR'J4Hbe ނ򂟾+& }-/SIA Z C.hJgnqvu4$A4%;M2H2Zhlj*+E9ee 55υ}޽EGp(!dW/vma4T%('1mLosYn &@C$U"B7a_PZ]hKg=8**ix$DA&$ mefH!/Dg奵AXvG{ p}X0=^`6K2AJ{PZ>D~S<1~ -s uhxA`vYDܾP:VZ*iz~PRx*9@ቀ'q=tUh4n|꭯?ğuilu%KOsxsCGw%n?z"?\.y5YP|sŵ_4{~hR\kd27 G:Bs;eEEܭB}[}anN~ T*GDu-\ ۺX-|lm.@8[ AMPr O@}\v uh,v UEGv6;od&&/@,W~X7w(Sfjy&iٺx]5~,ƷݔD׷.vFןw_.)i8hTƛR=hDU&)<_bv4+!q($3_2Z_!LGH<֨geWC+6[?㓇5OB~"݆i ?;:PKҺ<85Z-*<4vL{ yNZӊ3ui5L9l]-sp sVYZeL-F{fqZj-MPADf|ۯ Rp7ʭzs0<+?CP t9Tx{G/;_xT;)惜NEEC$%uEQ }lV/}~y wWKh%]DE΋o%tnޢYռ$7)d/R!7SxuF>XZ ]8*lEz0[MԮo$]`O@ŚƀpN\tޠ+C@џ)@Txv8^B;4I PxF'84I_oEJeanv ? ?gAiRlvJAzT`r2>ӐcS5 gUF;ARKPw:#8G! vN'䛜N*:cbtQ]Y]`/ (z Kg~ ~ o8/\QvJ0[Im ?./ZNlQ/5::^'׬7 ]UQq$ݿ;R WbTdvUfb/RgzOsgtQ/PbBvj{*gFL2Y,ѣL][c Wendstream endobj 191 0 obj << /Filter /FlateDecode /Length 2795 >> stream xZߏ n_šލBR@ZHmpyyvm}AI3#ͭ Pg5ERǏ]% O/^(D./ni .=.q2([j.U\CYūťـBCǦUdZ|ݐM]!+^%#/^&hš;wۼUzXqSHz5/ls4iRN\ŪP=o*^Tܔ6yu2V!/A9ut!M*X\b2`ɲVYUFzk&lZCZ@_}WWɋUyê~*{RXonYXqxF(q]'eӀRh4 ?Ԛ]vXJ|NX+<-હj#u(|^Y-6OkBȱ4B%HRC9`I26#j`f_]1 uMƱgalԲMN I%~763Aq}F>3d>tІQ;Pj:}uAZ anV#_V=V]`@s[~]AQG4FmI,F->+8<ebi,I]\byZĪ"rb0SfCeJ~]Lc*{7x]$J6jWv] blFCx%[axaLIck &KMJMQB^ԁF^:0\M8?AmnmPxؙ:j~Sͪ.GgHu y+V% .Aʨ8RЈc[)Ti݆&20s"5.,Ȭb6F޴h)3 Ckb<;MχtWIZJ,jiS$*N9Jh ӵwRCcT%}ug},hq]Z Z/y) pŕsXeBiYz^E>L\rA>KcдJ<$^^Z*bKK' Iy; / 08juY]Sqnǹq9 iHx |t31fzx4Qss)b 1©U,}3QV_=̇9k|M1U<$28M)j?,Юdf;: iQb #"Q*HHt?,鹬DFy>L7uWbgGn !mQ\=4Q*갑^B WNE :iTKPF4%306#5;]Jp0ʕvut iVgK8 i4D[hAc ]jT5WgRVgqk*`$BB)Iꌰg!GTzuF2c%1]R&Ğth!jUˠ#ݫC]iIcmsd#Ʀ]X | FCR36֦5DkșLJ$g!6:K.naxA'1bsGqfnUS`ptzw'>*Nʏˣ;}-ް"s;SXoHXT5x~uKi׃t#PGWIQD|=ͮV ?vgsf~8Ο>]𹔼V@zm s}+u{?}+ $ pxjhak4V.N2€7ͥỦ - BŢi60otCRM5D:YHJl%N=}* %HLń⍸pQP|>Ok]ATDCjN:B90R&BR}ʚVaRY II<ȦM*<::P3cs΂vR `Xu{èxi ʎ>Cn [ nF[t|gL}EtI{s6t^RloVwNڜ[m;m Ue. sv! ?M'{8a;O-@20m*RnM/ g)}5=ztKxX>DaG |JiωGh|2)$,C;,J .YS!ݔCD\,]|/> stream x]An0нO3N$4tE*1Eo_$颋[c}W˹̻޷%}MmKG?=eX]uz֯U|L6\hҒI|SWv`>lPkl՘!;:h l.fnE -tgill:h<qdШ1(ilҙI$'6M6@ņ uQ;6@ԙcdD9Q`<Ўg>ݶMnW*צ"f]V]d \Vendstream endobj 193 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3111 >> stream xVkTT>0'' ڔz)hmo!En: 9̞9srAjҠ_c㊟YYmm>kcd޽{? ۋR(kmNOMĦ,?wsBV ͒+Hߴc1*Q ,1)B-`UzF~VJRrN͝p%AqA+7=/{oJPl7筛>=/6~oJXMbPzbЖAoZyCƈyJQ*#+G.acRrʖѥLm6R!&*R۩*j'jZ@SoPoRZjBRzQ ʛ*V O^3"gGTT7BZ~skS\9O/{5+ wHyؙ6IOobx8Q`WKsc #M w_DZI; mkAk̖0C\0&#oH 0h^&DKR{5G@UFpH;gڤm#|'FczM"cvk ǎt5pTwgy7hQ)ؤpAIUn+`,ۼqn4ҢOtnyK![qډ,y@|QZ;YfIZT+5zgxS'j.{}GO 8 64Ŕn'0~BiUc[Hm1;A&P@|=8Qݗ|#f)>wK- x#dmddQ I!Hzŀ~&dGygdOot&dJzǯ^BIg$|W*gUl/yIidu6Y bbX~M0 ,R2l{ Gګɕ!ӱx,,MC6I[jCѠ15xTYQLxRm:lml,B94p}ğ,ԙ-`}rx ?UlA3c/KWK@WÝ'䡭V+6}ਙk=g3dè*.(ݔ'Ͷ.=}QoX{Ðڰ lkA殣pw.dۄׅ5ҔmV賬+p "^h=+bȢA5{pYJtNH>Z5P q+>/{.LW`m\[#4,Q5zBTnu9];>FטĒ I= {[{K Y| Up:3*6Wyrv"O%+?1|#9CEF2o+KM%$ptU֘zi 3U"yfKφ  ;u.Km}Av!a+zk\As=xlϺ~vn>58Um)@0 y%^} Cqh9MI 8AZYl<m`;°'?]ݷ<3Kgo62XjjϔSH \.7:xK7ge'&]Xk?uљ|2<~#9eAj?^8CFyTr""#ؤ:m;̏=*3K,jk2˙9IFri VN\RȁI-Lz|k(|W{v`'Dgý/0׫_4=*#~ǀ?7[Iclch&dfyT>"`sIlwҸ/ׂ~Pۇ@Ս! `lؠ yǰOS]q6p,]]au{#=o}iI\P -Efk2U*y%e$q9*[9Q񄣆{wE/߸oJ1Ac4q}*v[P  0̿YUz3~\sŭ/ /ZV[2@,֘Րs$p- I`l{`짶u䵦Ag i&ܜ 2.yU]4etsS<4-f\m/*Qmv/EYendstream endobj 194 0 obj << /Filter /FlateDecode /Length 162 >> stream x]1 EwN@EY%C1C "d+Hҡ-YudA>Repm5l &=Fv\LrD >B/m]5{5dx&)wIG`r}-Z]R D+i%)L ؊/-S-endstream endobj 195 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 347 >> stream xcd`ab`dd N+64O,,M f!CgO/nn} }G1<=9(3=DXWR!RIO+19;8;S!1/EKWO/<19;SA#?O!)5#1'M!?M!$5B!45(X=?4 XSQ0>c1##K5|Z2,(~_?^z~~iKsH.xgr7VX~wY Zb𛫛 3X}>PWG g/d;[%$POOOOo_Oo>+{z{z{z~e`Շendstream endobj 196 0 obj << /Filter /FlateDecode /Length 193 >> stream x]1 EwN І,vЪj{b(A$z '!}÷Na-A!LӸdKrWV;oO6ITIO"#ySuWdGGS2/vޣ0ehNkd.!dZ(R!*w-cK}_i)ΜSCG1`endstream endobj 197 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 953 >> stream x_L[uaX/.a.E6DIL&sa ecBA)na Ja׸%N].f$ >w dBy9/CT 0LbQqlϵ60ZZ;sR #*^fz %hTWо )(;|1~OFFѸ'#UͿl.7ten5i;o14&z̫ *J*woj?MBTJH9$$ Q0gŠzei7"׈LTbDۢn iK I\t )|!Yl~=+ݦ0 a=ԥ|<aDŽ:uޠS6y90pZNH<&%5g"1]W!yZ\X" (!@mW&%Ե鷠G}tWn p@S 9ayaTd_,`9ݝ}3h?akf :1b5ۢ?du<$MJ'mWr%2y>M,:fT:Ȧs2~J 3yiDcvCblgEbjb5w1[^?Lt Up Oуjԭᵬ{렖S]ZMQap;*&g8ާu6/( g_Cfk >XFE}+Ol=qb \jrou1R,XH1JN2-Y \n<\;K`(4}*.ώyQ:˜&^װT>8bx8UCeN̏8 B''GQ#3endstream endobj 198 0 obj << /Filter /FlateDecode /Length 164 >> stream x]10 E7H!R.:NNGI[[+ (l-aMH0Y4ǼOl'hnfO}:U0XZAJ'R}\/ퟴF;uRJ(%Z kJĹV~K 2S7endstream endobj 199 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 334 >> stream xcd`ab`dd74 JM/I, f!CL<<,{o$={ #cxz~s~AeQfzFBRWbrv~yqvBb^_~ybrvF~BRjFbNB~BHjBhkP{h@`̼TbCFu.&FFk~,r﹏ϊ '|?hy%ml%]UU%}xymX޻nTva}&3{2_ôӾNvKH>{@`<<O3< ~2endstream endobj 200 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1306 >> stream xu{LSwmKV`с^_'|MaluNPNȊRF q-K&Dlӈ1$CE݈Yf\Yt#|I盓CSEիUfޤ3ǦkjS;GxX%QRbfCJ'Dz@kK;z~^n(6괅fnA|sy՜*KVo,2TtZ%ǭ*t\Ai dsY+3YisDڨk *V yJYgЛ5UfެO"_g*-VWy%E1M6nREMI(7Ѽ(Lx0|LqbVU0$j=e8% $/T qRa4\QRv eM"q,$'riYl! @@Pv"8 k$fD2kis >Cb ;"AADQ<`6[jm{LDA.!#TAA&IDP 6<(B:\%LD颞ԝGjG-r5k[19x_x .G[#NR$ Hc}UiQ蠃`=K֩ ^إ* o$POt󷄈[bqwݡԘWj[2P "|d=IC=8+vsyWSѯ~0x78>8`W3lfW(vv<ِ'}r4d\IE2 LT*Nh ;`H^Yoj^$ CX'5akqؠ -Xnihb1ݿw>O~wH<,~}uGpC7ʷFQ8*u̦@mמ@!E}%b1_,gE.;ow\9%;M]W0C%\ֺԺzlLV1 9A}[v<{ni9 #Llܖ|f\6eھ]Y4.!\ڲ쌦&0mևMLxO.(}6iB&4m[\NwǑv^-4~˪Zendstream endobj 201 0 obj << /Filter /FlateDecode /Length 163 >> stream x]10 E7H!T]BRǩ2ԉt(i`K_~reA>Repm% F> stream xcd`ab`ddI+14 JM/I,ɨf!CO&nnw }/=[1<9(3=DXWR!RIO+19;8;S!1/EKWO/<19;SA#?O!)5#1'M!?M!$5B!45(X=?4 XSP KKR3sRJ Y\Dzh)ڻf^I7GWyUkIOWwGqcڦݓ-*1C3N3aimOc;u[%$s= 0a~DýzOzpⲩ< kendstream endobj 203 0 obj << /Filter /FlateDecode /Length 1941 >> stream xXryؓ44~y (HLR)9 ;;١ysH!~fw@( ЍF_7SE;cjӌEY73tb~?"0ʠ#Up]6;4], A+wk8oKLA3u߬)+"J8+AgB˭? }=,Dd2.TNZ C=4&m >4a_K'J-cdR:1:wZV|6&!h;zZ&RȌߖ"#á^@*?֫hZ +DZx%B"VdJ2KpH²_nKR%Iŭ@C&(Uox( #,e%C8cwߔXVi_W] e%C%hvZVht6 ۲Cͳ3~5B `֬>ci,9Yҹ,yue׶,+%:gT ^^g4xʾ1Hȴ$ӢQnhƋƢ R>ͻI(qiZʢgߑ1+f@3*pCi*piY[h#)kNa{zrr5X/Z gȹT'2Ƀb1dL,+%%2N"yJ?M|")Q#mmo!\C"GaO}UZ9av<..^ıOfJ ^ eOD94罼 k~vM$--E?4m,:rNrzŝ8$mڜ,܀`Df"mxuu:l hKI&raP .5l^)1.@)YL_*O _O&zmdTĝ'qUQД#8gwQ?>CU1ìjSs>sG^]50/F|Üu e=({PI 'Ul5zϙ6vrgi C]OrY6$ri2T\ö/'&`FXtthnM$'e~_w\³'q5|Ht M `7룉ȩC2y~S„5Qcf /|aπL~ 3,%׏Y~sKFG&?<bZ!ҫ;E5>~FjI#~Ҧw*#x֮׮> stream xZoG_>n!kLJ~{ cH_~RH>4ԟ&-P#4eBX6wYQD22:utE|:%eZOCjN7s*(P t"R@9%*F%%5JYM(%H~]xp PLiVpӖiܩAƍVs K-g祡JK~ÜS+%_\}vVZqiA)fbB2a(90D,Sڂ QBk@[i Ց*U$JcE@h-Rs 6V1= PڢKfUR@ Dn j Ա*.%Nh-jɏT n@եF/i(?X0W03*p TI i{wFTJ'CbB#lu;Bmb^5GN$# UQriuw~7Дi\7<݊L`V +LS`WPt_j{>p?(ƑpGm\zM0S.Wwҙb!zϿ}^.A!O~u5ز;mva/cpf$f%epL>n8H $!['3N-q@ܤs@QcK]0q )c@mQv ]r~5g׻UÍAFQ-%j k} 6 3v!\]b')}U^|S7+7)ӤF0K2\ U[ _>{܈5ʢ!}{Bdfu%7AC=\ K I $A U05I O6HR6X-hw?CIPhK>GaA.+J7[q&56u\OR >T0iuAgWZ$GL!]VxBPطFUM^xW[&}~&j{y=Yڸm 4/LPi >X݅4\Yr=DfE)<]Z}6?Dj &YLpBM ^'IVzhU7w!R:=i%XG8#(%c>ݿ5n"$v `M~(+Mf:NS&" `-y(8XWs-A0 tg{Z=3͋H<('͑iu6Yۓ*9LCs2Ns>o8ܛl:g]xV%I&.{Uoan)"wn鉻ˑyɼׅ%+uyca ȹ+#gw#(*1+ݔRv7'a2Mu)5M626O2}R4/<d{9[ quvvEp$޻O/mY;+ñ8hFvUݿTz_c߂/ڶx`E6&ow+w.*FtdIUhE6*WLFB_ E-u Rvtv2OkT|L2-!-w'M ,tE)\*H ~@f==am6Kaa7B_r(yf8LNQ{҈3gm9.vxIhCYcN黋QP<"syKRÇf[!.51rOuY֓ ҄3v|PZF_kL=EnulʒvZ8f{#^L<=9 #\q=Zvo IQefoXʞQ-VpG݇bPe]Cep JHr$86{> Қ>d⧼ȐAϡ\Λ\>nog{)S> stream xZ[n^dd_ivW)M".;YykI5feF^;f9<<\_+Fy_]mWW+ΨcWo^Y^eU] b__]i*AoM(S`8s; m@Pg%yY C@Vu0eӃV[Q)E0Q9i-9n i 4#ؤ9ۛLJ'^ԍ0:LqS(sUlm:~]p2?Rvo{XBka*Gi4ULV (j^3($uh&'F EYVqIAjYԂɩ`U֍b~g/q Պl6 ow=tvFp@ U^]o!&2|)9֫.`8.̼I, ZE FV8hL~&Y;RXU{ V"L~ZInC}΁B sWf=dGR֒vu>$7g9fKQcS].g6ڒ(SQ{6)I~(($H*R%y;PR+ղ$$P@ץ,WבK2 `\p kS#5zDK2W]kr9ep>|7_7a$hE˺vE0f[ xއ EW\E-:Ƈպtۋfp3F.vu9:XmV}߾G"ʨmaw3z8~?2~`3m2-6 ?OHuݎovovb&ݏC$n.H2ލ4ph6О2i'TN_TN!t ;M0![Z CzJ0ͥ!u7o) o|5y`2`Ko l<ᱶ: ʸ%m7cMe73%_Q>'D{4cG$&'p ڠG5055 mWе%Y'fU`.v_7B8M%O6D.Ŝcxr5wuJ" @hWN鶑[ ){+Zq[_ݿgvh-":ewi LhKaqUd t|>ǟJץ% jr<i\1]3Pi#z~: R%&sf6 spZCKMڈ 9aL=˷GGFP;epq;8_ȕn6Iܐ%ysBT`=8}P^  sO,t8-<o$9NL$ +S#iI9ecTKv/60p !_"ň >.K> Pad38!Y)w۴On-*S@J%JsCB~4۳`ʴpb3<6{ρ3_|j8И0nۯDPP2`0%a _:)c k3ŧ%n`ql9l'h_"yhG Zxw,u$bTB,wҨY( *KQ8: G^ AZJ?ѧ pK!KڛlV{0 \Z-u ȳThHa|!?W~T W x4'H %0](̺8lԠ>`x<+d~.yrLv((}A0t56UoҰ&05 sY߳'FxO&zSLʪf˂q|SѴ~+ٮTd=Tl,~u^C8VT:>ʒg([`Wdwщ?rL.gnRYjIqw)ɞ`2㽃Rj)/]Fn,ոV{V="ba:bŲG]ˋ.؛KvTLPUhNq/r$˛NĶ _V, 9AV|o~5CEk_S3mO)'Ӥޒ(iJRWQ; wr,S*8uKBєn $ΞGe"^xLQIc?u\xs͒O/ļ?\ iv,s0I? RN7&_u1̨/F>{f VY> v*VȄƾ_Hw*Ǥ$oLp@:^_WZ \`ۜl\ L?. 0z:,nH3.MFg Ui̸5غoZy9j>x!TԿ'8#24؈ctBkAt)6?ovìs6nTw̝c۞=!eRo. Elϲ4^C6I:W*?.&endstream endobj 206 0 obj << /Filter /FlateDecode /Length 1713 >> stream xXnGrzrWU@b}CR1E 4B҈ϻL9- m$ 5U_}]3B_ voՖ/!mѫ`I΀6Cd[b^7f[zUEF4huTwJC$gվxqnĬ.緅ŵeȉDm 5[ΉB--YК@ 4ə#K!rbB]=GRM\|"ǁY :A{$&K,9MT^U5j!FT4rg*s=TjsbjtU47KD#J}khN&T i3Ά"+}g?!$:/h쁞|Cv.f|#%~1sN S'p !t1q1=-4<(y}gw3;˟jju %`㨏JPgm48GG,T՝'jU5wtwu7 ڲQ+5࢟>6K%7S`)`Ap_@1nUh1z}6'XWꟲ Rz޽&P6MRw1ڧfId23PIaʌbҧӴ9 KI֒3e0/nWoNjS1UOg8nj{d&}9fG37O3PO4GAw%u7c#2׍~j~=<{c~6jA&E7MR}*_XP" #ޮDE:1e* ts|D srDZ@EW8u62&p)w;\v͋BP0PZ_fDh.ۂ4v.{TvIM#۱@ٝ@_ے-F;Xnu) L;m8&~y3fhLD\n:-@ X&ݑY j0B=$F1ݸɲNɍ#Ժ:Wʣ^n U樁9 Ay'"v*(/#LD"fmT0P&PT1uJt@b{̷vZDm=hh,*+-<7|w>S0qܩendstream endobj 207 0 obj << /Filter /FlateDecode /Length 3267 >> stream xZ[oݸ~ا8oKCh d]`ŢC}9J@|$RG8ёǹs?Wgbws˳.ށN8]>S`gagphwy{@V=B|0Y.ډ {U .HCtᾪYd+iR-Xm3 ]3l䂈}{}}ɡlhxҊ}l7_bNr6"gk{3\ :9nF (}=-c mG^;". ^I˅2Hms!h4;'R+MܑՊ:#I.d߽;WGN@Vh.Agz12thٷ wNQ̾^t&8>` 7wFny}z?j^"!\.kw 4C{~(pMkBC^Z sn'.&~aߔ!sVss_eǂF(`Xs3c )&U$sXshj;cv5(NhmsKu D j:<wuUdog뜩8>qؽMN lba\8Z9Br%a^w- OǑ#B O:㦸Ě&W4m4\vlI'42fW\FAxW8ZR^ҲaӍ^°7͛.o2]j?R׻Z*P?r;S,ϫkoUupAtCsXNʱB92s)rb":%nB Xt(CUh Ul(taa7h,ƣοwZ*Ɏ1>ލ(FuHXTWU [=G'pi1{n2AhN wF![tRjZ02Q%1Fyud/5GSNѼZ w,yn^ը56HJ-yMplp+WB*˓%zq޶PFз]g}$b1-.,k?E͝%>,=!h*vm!tj(4ZT4yP׆a}l}{sg78bhǒh(V;^hmy/ w\2jϻٙ ma\_4 ~HɶeH;CIy/./O8>/hњщw1(L_q+v_1z!x&= a8\x=5oۤqFDY)5(PEɱ(Bb24#WFq;!rU3$!M_uMdΓK}vX<Ȕ&J@tn;7!8U->f8q~~YNO⥁_f6+xޟ^(]Z-,TM߷Et 7Wm5ߖnf!MG"{/g%M*F4՘fg5i5 4>eŽ|kLVe\4ԺI<,%nS$F"Y?] H <h~N#I!K9xϽǷmu7DÚa`C v"_ioќ/:>ޣm)D.9i=fa5͸/T(jQ]~]2㔫PTMn|/u q"1.R$1r8B2B9'$8yJ/ꏇ^b6,l kAk|$Y?xxh}'!|{;>W~ݳy18#gUA8(eAXw>nd`(H_ hFQMZڔVhHPT(ZC6Q'TJJrJ 8 8IP!^ J 1M\ +BIqV`F|0i#|^ <_2z^ 7Π4(B)Un|U3FFK;9c}C&ļu`v$`'+NZD0J UhL gs}SspP 䓠!/^r P(BTDR{*8@DRvd) !Lam\&nM`R}0d"hEă&ށUP8D\B ( )\@<0Bڄeɧ9֠) ,U:ON T@ZY_~vebd :>T;Q{YbW͛{[gE~u lna=HD-b%pjߵ]?谸,eoS٠H=JLIІ}~W֚@[ےOٯ.,ܦ ͧd%^VRdPg[457O4!VSmlvG0:"ŎUJS k7n귅 ~|ƂR\;}hDYrFBIהذE,!cqb9X'Ru]ƢF>婟Z)FJCK)z?جklVi ,o$mYܖAov!010u`Z*M=KGFb0ȵK_gR^zw^ZLw>:\B'--?gy endstream endobj 208 0 obj << /Filter /FlateDecode /Length 2848 >> stream xYݏܶ>XB%'Ө hp}ۨ]iu9;ۋ!)isSV5o~3_1W ǿ[6n:*W2ԁZѐ.V +^@ڽ)e g4}Wu}Q$- ą[mDBW5-)S|NðP9i-髾iq# xT\etZifl2)(%!dR'mL&CP &;]z"i2+ 'R Z DN 2JЊ:V%(j(9A^~W-^(ʘ tq|8]qդ;_k4 q[A4nS@wz\sk[s^~-|Њ}lMĺϰGLn]3@桫6'wm7psz==J`pGn8DPAbsSTgݳ&Cx\|x/}f7pk],D1FWpFK*% uUl%?q*%PPBZ186ı$i>98S ɦc>$7rS̆=.9nJS%IklI+#UzI2fHuLm>&& @Ƀsid`p u뢔P@GdmdsCަ/H8; }OaySx/(N뫣m0'SN]>e\S#s!?Qgy/2I۽EdfXI Eg8`*Rn`v*¬4JʌΛD*+JzhhG*U8~pC4\UY7}?K'X@O(zN軰$c˸dMH*$rI P\AJdnKlCL& e+K2bi.PZp@Z79}<}S(j܌PZCcMLK(!#*Rp2 dMn2Xi)9񾲈 黶(= .E &n B&[5lܙeXڒۥ{}&SaL}2bxY_#:iQZOB'S -8pj0Aځu1l$QkzY秧;zh|gCmwe23Uh%i$`Bo0zsbtXA1:Ϛ9 )uBycu+!B ~\i>[<h`D9NH&! sZ;Pp@.yϖӑ3N".W JlB)<؄M8C~TMp7Ã1ڻ/`u@- ņ~  R#i%P/ ޫڐHbmPYdJJS+cFj yHwǐ; JiTL3Քb7؟|6 nozf@G Hf37*?8^B++NE~B[0h8g# _jϴÈ-Eُ`F#6-5ΰ,q{}7O &͍a٣ʂx:6)Trz,dѳg^L>f 7T$.a͂ݣx@; 9M0 A2oك'Cg <0br/0>뚰co -4;on2k}8!)(&Ca Jgʍ d/OQ$<-VaœbW ]0mI槷Hq`)2Ⱦv&]τ+#X+ KϊǬВU`QSQPVT>qxRϏpJ+%8F3ٜ\gx _9KsaT}#Yu_ubr^tݧd|ʐU8bp1Y 28J//0­#z LJ{=,2 ?-"krYN\Xlh.˴LojzEx~jrj>?3tڨ{”.:?$&l4QLJÛIESWobsѺ(2h#RbY VQ[댲qôxg577ʼJ|$m]?Q5rKB7G2M^yC?(.AX{raͱKg(i 4ӚB S;3ROSJ*N01&9cJԫߝw,Zk01FץsySswl@)մ`֤ko}{仞r={EzZS#g4˝UX Yd^qQURws8C}>\!|N~1=sCڇp= ,K`;F"ݪ5Yw#ar| $ξ qbaǸ8OgUJÄq \I/rUz 3S9z$qO^!ivgaZ>@vMoqԃ_~1C%?q71Qĩ:j#XFTsVR1^l>Tbk9Ǹ"R pQ=|W_}w7endstream endobj 209 0 obj << /Filter /FlateDecode /Length 3249 >> stream xZIo)tϹ4Ɨ-Ծdlc#0j1nH!b% Al6z{Wj{BV']W'_Q-tu~sS!WZjl\oOޡU7Իaz߫)l H)Y[$+~93i +劬ίONJ!;tYꫂilJ(̢( KC%3P*}Zt5gH`"-'ҠM׭G;7*9&m]2o8FU:ܗ me2iWaNi1d~/jAsnPNځW !,IMm5mԕ~ l0v]%쏢]ZLLE~T`?bWChL4_ReJJ+JG y{[,qAQ.!L;KueU<.UplK)niS3`E)GiC|;1!LkXhPǝn}_6 #0}@ذ p~g$`N>̰wj4((GV[LE0,I|ݤ=kK2yp\T|}7;ȋ#j4. Ckal.4T. xk8٤N9R1Lj8ك 53h[-|l[ 󨄎Yrv6BvAjꏄy=u EeRk VAh!8jT*^|kL6i1MnYob`(?K1sTSTޜSp&=BnKuGn@toͿ@:sgl)X| aֹas6}uPK]{7'?|?endstream endobj 210 0 obj << /Filter /FlateDecode /Length 163 >> stream x]1 EwN@.QtЪj{bLz t`K_~xgEgh [BfϢ`=cn&?@%w|RW`i)ItJs lu_KVWh8on)JZI g=C,) -S-endstream endobj 211 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 369 >> stream xcd`ab`dd N+64uIf!CO/nn}/}M1<%9(3=DXWR!RIO+19;8;S!1/EKWO/<19;SA#?O!)5#1'M!?M!$5B!45(X=?4 XSE0c1##K5|`XP}WOŕo;5#vna^ߐ&{ r6NN-~oY<{a1sW&P_bl9z.7{\eXBy8̛8gb_ϻ'Me`}Sendstream endobj 212 0 obj << /Filter /FlateDecode /Length 183 >> stream x]O1 y?Hp#UKthU1 B$U,;rϼ`daI'&[oj5:9pn7=aNԖXE&X64d*bHoԭlPLPN<@j۔;%%%\ߪKZO> stream xm]HSa3mJAŠi A4]ܜֶI;;5 f.jxE(( ;ۙU^<$@ Ljm鷙4]CN3c?ʅ3P(WG+r@rtI;x !L&ۘnq5:FtneFmQXVmjs1&fFt@tuti_6j4YM4 0fVA9 .8".v%aځCu'{lj8ZV {rG L`6YLMd]DƃCJ,'J68og3",S^RӛdCo~JGx6Z%#s|}< O|DƋJL1!UTZRsrӶ{݈"" `[CǷo|(K6NYqb͕έV=z'! ZuP;KEDx{>/jᴀ \/lϡ(v 3+w,*FE@YS7Q%īvac9:F x Ȳ0i(c\8Կ$.H> stream x]=n0 wB7h0$KE 8x,(d>95Žlan T[6jUUb RSWݰFu@[@xͫi7*|*y eqY~rzendstream endobj 215 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1512 >> stream x]RTTu0o03D{Uj XnJK1 sq!aD  Bu);jʳ}={?|WBPDDάQ;r^g JECR i^(YD*,T+yT"ٜcXkUZ3 ҨXYa[&Zؐo0 Yۅ F)+;?WXl(e鵂A+$HROL')iI˚) .}?/{nRR*|* 8jD)( HUQK%6Hi/0,0;pX!87 \GuXe<Vt$QAFT!gMb /8_/0|wqƙX6A9uy Z,aF,|t;pvOƝ qm9^g& /KŤ~ܰ0ܗR8wW ILoNPT{6J^LIhОN!%R?&ɝq)#{հfl&:7>8PKNY*ے#D0x Id#/Zǥ :p  J|S Lu_M-Թ< dA/yH4$,J˨٠q;:rp|`Bŵ4hhAdb>SNBsxoN益?rendstream endobj 216 0 obj << /Filter /FlateDecode /Length 250 >> stream x]1n0 EwB7Ȥ \%Cd u9?x˚Sv̗5@ָ(=5ӝ^B*l&^~ W RJ\CiYpN,8y3* P^dO 7HO "L H q 3@ HN8Jy耤 :> :RгH zER)4#ė"xmkRCVdrN;})endstream endobj 217 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1395 >> stream xTmLSg/-"~dM`c٘D7\D4xUhAJ?(:Be t sәaؖ%nꜺ9~ǼЎl?ss!L Bo3u5R\6;Dv^Ψ2=/鲩),N#%Rb1B{: ~xoߞ,P6VIrs33s_H%$ۘjF]]%a%۲$o)5LEudR!*LWtKIdǮCcFqTb*eurّQLS[Rje9R)5X{,Gv2\V#ST)յz9\UU 2RYEw$վB ]BE$GȉXBnAX@ BH$Bh)E 'Nl ?%nc).76L5kN*7c4rR<i>b54_Zmn=.JuYcP>'D4fp CKd2ĸ0"5xMn<, !.1$˂t4?(h,G~u4KiA11I=݋J]%ۏЯ aBV+၁az&e\B׈zOOҁ6zF-n 6#>?G͛9qn 2n5mMFm-lP>R4~hh@ٴ%ǞpݿWa򏕗+![.-% S 8'B8G pfoH<vh:p)ɩO !s!oXoS38k2rbVhu}6W[g>-؝ >J=1wg\lVi`nZ (Wr#'*b1!{ ꂦzOZtՖ]??9~NjydPX8X-đTL&(fλ? DE7Et#fvsI^|=~6>@d#x$N yc=/)k|>^/x](7uηϐ:h ?@<4i1z?dPk6l&\1C `j]Fp2 ^sx_ȣs:| NWG;0UJy2K8-!l . u1hD tۼ:H3{C^tHpF|O9>s)Ʈ;|I20^(س&yIe]^rIt3)y1A PTkendstream endobj 218 0 obj << /Filter /FlateDecode /Length 171 >> stream x]= wNSĒ.ZUm/@D 1 Iϒ|#}ae\-„s &`ѵjn&? ACw *yi#lt&c1B{͐JN&!:Y)$DZ4KDTx<[ɱ/uV+endstream endobj 219 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 455 >> stream xcd`ab`dd M̳ JM/I, f!CGO]nn? ~#_PYQ`d``kd``Tध_^竧_(ЈAAd?Kk3 ;0tzr`阾A~e=rIa:Y˺v]g*{ZG\Fۖ;wt?5_ޮ:Ubą(.QY_l]ۍwٳ=Scq|V[PN87QԦ V(/?^nŕsKtsmcd7ob“;~ȳ-<{ p]b \&N>óoֲz'Lϻendstream endobj 220 0 obj << /Filter /FlateDecode /Length 162 >> stream x]=0 7Rե,@@8U(Mn dr/##>2-qH0Xh.`٧mզ'pf$[%Yly&)wI{`SVꄪF+qp͙4FRSM_:S]endstream endobj 221 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 399 >> stream xcd`ab`ddM,,IL64 JM/I,If!Cά<<,{.={ #cxnus~AeQfzFBRWbrv~yqvBb^_~ybrvF~BRjFbNB~BHjBhkP{h@vd2000J20v1012L?v>ôc]хݕrﲕtgvFeurN8oww/8VPdb۹ln۔n.7{_wGI|ge+RmQa˂Lm%Wpaݗ<6cMjy?N` cr\,!> stream x]O10 JXP0~ $@ }:}s>4`. GX)f=U3Ȋ n',BHj &Fd-jS ]vMY)keVm@T(@#wr3 7[JVzb>8Ǭ,Q\oendstream endobj 223 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 727 >> stream xu]HSquej,C`T-#ʋn-Rs~Gk: ?u~nn4EHDx]?u B޻y^IASSY={X\)+nlnB'K@5!KBڎO# AdQ*DE(L^ ͤhh khKi 0Y'3SBrNCH2PJD~@Rd#v OFE΋y>Љgr_&KU-ۍ.?dSafCu?ri6s -/PºƑA']`ղy͛tK|3tbBrL$.5/;;lv@Bj%XNpդ*2*q}M.wnb[lDf2\Vʉkgjn~ 8rvtm] l}d]"L*l#-m&PSŠ~@WL|~fͭכ,/܋b[UTuW0!ˊo./fX8Ϗn <~i'N 1BesVP G˲79=vj-y|T4o z,rc|ooC^endstream endobj 224 0 obj << /Filter /FlateDecode /Length 169 >> stream x]= wN5bI  `"DW@ҡód=0͗Bឣ}be-‚k &$`ѵj&a$ }oC>=d-Њl\kV8M+٨n\?Re:9#*O b)@r tLV)endstream endobj 225 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 443 >> stream xcd`ab`dd M3 JM/I, f!CǺ<<,{( }G1<=9(3=DXWR!RIO+19;8;S!1/EKWO/<19;SA#?O!)5#1'M!?M!$5B!45(X=?4 XSQ0>0~gJbcߗ>d+)]{Wwyzvws/>}|9ǟ^:C7w}jϿ3> stream x]ҽn@O7$n\}<,L\)R|F#g==<=>m?s[yzk_1}unT1m®mG||4*1JDٍRqQ  1 HR(@J3H@(@2 .(@L?*~7 JOg }`0E `>% `>e `^ `>0oeg `g `>U `^f `^qB(>Bx(@%S@w.g PdPrn}//~8vVkk}Y׭[ms :ʓendstream endobj 227 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4218 >> stream xWyTwTliФQ1ƅFY (E h,Bc/"KwfAB(*.D3&̘uDI4b[5M5]7!e\/orߥ/:E{g&ݘ^q |6mRGNʔ^>|Ƭa5ZBRSnR%j5ZNPdʟzrQ)/j |JN )A)('*RR#MKv@KJb$vvWK g{ozz&S]U%sa<#ǁg[+u+d}Ł0EcdC'3<ߨix9 ]a C87A,U?+Gtn8ƪdszӓ6v8a"h4[v0bo2l6b7seOEGNR1']!ւ2 VIcq( 8X_ioh;s6R3cL1 2 ]ze!-3UM *bwtu<ߤޟq<=-vX 6E_?vҀ;y2EyFcyWXۺ]g}z?R XArWecBuZXa:u#cN DN&A,ہ-؈ޝIfpTcV10[c,2tLngwzd&Nz|jL!IɽɟHrZl (].*o[8YN }^a ihkac'&_urݥ}rUo<#SJi2_m7zܙYm'9UMAVx( q:,0ԂS-zOJ6P̼8YFkauh(-p. g)Pހ6OP]-0ڣ?<=ދV;^ԥkOYwsUn}h(˅/y2焂L\f]ӱ' HD@A$[_w(vjެ dftx$BJ6+so(Л  mhC F'`ҷ@K ࢦuPhh1VYvv /9ǃ2A=5ֶ\ZM56l7 J]A 3>{&,*K3|Z=V地$̉F\A!&e[%mܸr06w68[]obHҵ[*~ L;nq$^O|V%6(tk͌5˞Ն,gQ+8V\q]֋{ı Щ!46jLnC(d6{{q$ݙ ݐR@N~좦C( >c|WlR31;֝M#kJbS[CNS5.(-;t""9wZvUtHŷqH :-drqFf8=ON=y]px2BpC&\_Irr^[LWj)K H&q/:8 ) \ț?vn>em쀣Pb8i078ZNjшR9ER9hsp6_Ϛ/A A\ﵘVPeVL4Y0Ķn^QbsJ_Dgv 2QU iv< k^^4j=DF?F8Y{ p0.( d+'يVgUK߮6pܦBlk 0V˪rߒa2(| (xT{Hɖ{wNY ^l!WV-%;V+]ƱޚO7_5݅@=͎qcG]]۳S .Oԕڸz xAp< Ыdb؛7E"cj]l>|G41 ]{oݜؑ92-2..CؿR῭D0Rƀwel/ QɋgP>BR]Qsh(3d̋<|æJP СcXEClMddllddMlCCMM =;O4[+Jw;G(f?|1tآJ{_.%eCn/ ZTv\WiV}+2d$sSe2Cg\-R 2)>nURR 0\vd0Yy_]A6DWQs^RuR܏>·~& HrO[%g1RqMZQMH֥!ekQFAiNaQ?6r ?bp1QWNB+jӴ`|j`t9t.͝P˚ͷnhWw;|SS2C"0d78G^'}I-mYU U,+Oӻo|3Vd!jAq."ۯ_ k<8oqlCI0JPrW:hp&V3:1o^T__YYϱ/RbK6q*:V`Mdf@L0 o3N}vJ70I {#M"#BW%M 䛳hbTnܪ3=G b|uf)7џ4a[:G8^֓W. vO{H Ce!@wJ *5&:>7,7~HSB8\M7 YMz 3' !+_v Cεsu-<9B*9@N049# jQ*UFZb$f!,*AWPʱ8p/"ISbZ&^W\nU=✂Bd20e/\:d=]q=Os\svۣGOFO=޷웕b8S ]bd} gNT *=:a II.KZxz:Ӄ(ȟKbI c=>AgèO atO?Q~~$>2쟘KRwK;+`rk;e ׻'=wb8kSN3?;VDGVrd;vY\$%G.\ߍ T3j8;9c&}Q:prpl3|)\؅$Ǡ\~D?E]R]Xjjv[Qy7;z7fer338r OⰰVպ5NĹ{psa^L=4`a`d4sf|sQ9'7aE(ۊ6endstream endobj 228 0 obj << /Filter /FlateDecode /Length 3440 >> stream xZKo$GrdF@Pt1Y@Z,5v`>MK@lRAKoCzf9|5vUeF;s_ù?;{yz}@_ޞ[מ^qQz_n7 xH:ZYG:~4BR{j`?I9``"%Iɭ$vƤ]O uάR6CԪe6,jƞn{"w5]sytP3w/eZPW+r0v"K_e:&M(V~kO ծje{ߥgw3dyanHs]D3jwm9C꣭7~5:iLc%媹:g^rd7~3y1f~PiWq=πkEEe?,a^UU)=? '!OLJ(lNq2Ū/ndg2{ȹKo? P+h'B|z2ϧum!gRS, G>TO(}IXBE!pM"F " Ib xC""s@LI8:R >E As0jQ+E Q ``1IBHH mDG 9FȢ| QȪ P1OA(0 %y y!vCRI 1k8>=$A2 +xPa4C1H#&@<@(D>HL^G rGo)K3gc^(!DA QDV?!$x^F`@b*11FQS0QQ#e"'!&hNc2yiW4I@R3(HR)FC}J hSO)b9%s "=B@¼ECJ 77S$ yxK4 (D}0Uր#yc(yF"4$P#U$QrP&6 QQc$2N@p>}5 uJ^%8DCS]UC>7K13\#9ڇ2n Q]l]i 6NKϞf, Һ2eྩfѷ(6=3ɲӲۂCǗl&@s ZH0tVն)CǗFvw`ўMl$/;5e<7a[XBT]Zh}Wb2:ۘ[GV8T| A-V8vCbB3P`)}I5c $O3IcP\aߛNIrɮ#Ɨ-T-۩S!V7v2\j[r',ȣ1)?smTg~"KҐNEXRSij#['RQ*Rh1?J.vpLHcä?z: (ƈǣX(D/4^}W9kgvelڕs+G!4i_'jIK W CSUjY=aM|zzA8)"K B=y~h/1f$VЍ+{ϖ3|7-s2u?Lf0mEPN&X'qRM}a]mS偩1q|7 S9Jë<.\-!\QL/ޝ4mqg~sOTGo~Ώ]-W_-~d$;dp {Q(Ogj`ӆ0۞mA7:iߜi9ҩ+=ϳ(fݺ^}$8I|ev_2d0S75[80e|8vlT=a*<)B1 vCalI#|C;4ҍVOGϟ2&jV,vˏ-"_t}1mPGN_.Pa{EF3LZG+4)j&笍ӼFVMZ08cr0|{x #.ƕk<ŭݺ 6ת/ֻI=ؽѱO<'l.vw'[nM TgvhgS?JY2(KviB_]M;~!Ë(${~ܓ\\D!{VZw_}/]>ʧ{ Bl|j`$)uZ=u;< endstream endobj 229 0 obj << /Filter /FlateDecode /Length 271 >> stream x]1n0 EwB7bS `pI -p$p/$:<OA9^Nu|S6_Wη5?T]|0;e\\s|E|YƋ4!{Q\1:oqC)O^q.ap`vC*leVu@;Վ :՞ zUb R=@ڗ oan`PmN@ ;6Cƞ btus>UfIYT/e^K endstream endobj 230 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1948 >> stream x}{PSwo\- #{#([XYbFRFY' VGD tB Xϡ5B5/lO9Z!i;% =MӵOdgi !U$82rcxAS =mX>]NtGv^,D3 ]:eĘ$&{M@aQR<-nhgq.Iah'xx醡`;br_ObJ= x!^7Ɇ$pZaN 9-'D4Wswԭl=Uʮd*e6I˱3 @Ն0Sob{󜥟QE R5!>96&#Hr 'mpHy(mqLЛ>!L#v?I^iصN0S6ru?P[gwA7;jdz'!+̪C8ǯ\s ZmizԨS=![ \Wȃh~,KY0נogm  E&(K2/>iMxD1ۘ eBg6Lw*Ȳc%ypWo@)Ǩ0& 'cL dա7QhMcPUazd/eI]nvMNrGrc&nShlohfC<S!K Bs/(赸<~ OԔ]s"qW,ȮuI [l`)Yh$\^k>J^N( xoSQϘyt(fNYѮzew=X?p!j̙ *8yLLb,M3;`dj%Yo?VzX3K7[.d ޽S 6K'ޜB V(Bb!>}Vj> stream xZKodpYkzF`" "DQ4Y%GߛT?fɡ `Luuu=/3Fa_>c۳_.ξ u,,ג2fFꄚ].ɇf׷S'4E5uIrW1ʔ0Y-+F U.tGm8UjfgT@R¬Z4][ոLYy6`r*%UZ9MUs+@:r^ RIRU1Mv]QNZKvi{!I&۰I2'Q #jAQv ʤtJvSq 6|j^ͭ&ͮs˃ ܐA4}@}<&8ҬqM;o?{gsF\qj s.\~Z!*go?lovGSҚIOQ@2Ů|*:Pa{DC]jWe- }Bݷ]Ꮌ[Q C5#䙟6򤙵vӔr%(ӿEJЅ4FPVۏ@:PA҇X-D0k xJQ(a' yfU5ZreUKQC{v|ns%@ ۧHyٜ2u'7\>SU8>x2;yUK.ʛ s۔GL)%XG%Si+<yC2=.FμXPNj_ dj}5ON!-Kz޴Ē,W!5.Ti:uu["5=VX;(vzH-85}ךU WQ3E5 a5LD HORdRm& %`AfcE{ vXe\Uu]wgU^4C3bvKfzayN Wsm+@)i#y|z^oOEjo9O >rQ}I[~ycͮ['IA1)ꑱ܁-#&bz0R LJAXa}41Q$#}t0~=I_$TY;ڵrڣnn۷*}(3R-ΪRmVEV 1ɥ%m9^V'~CІmY UpD aa.x?1_Gy> F4?)dRUטb@E?…Ðu0D2NPHόEl E1";ʯzlrs;n"<ڎqAHc*},\-!-z3>yDP m۶ߟHt ~= Վ+7@PU>.Iυh}vG hJ(TT?jQ) qRe.qUY5c^U/S*A^1>zsɏ eNJ1A) R'PSVgzBĜ '= D'!/:}>BQ1AthrM%8'1'  KK͐n}W{pwjnV|bo|ON]mRD>M@EzkO~2=`,5jQVu!:8kKA#zyܯ֭6s-,FۢN$,g 0(7/,7a,)Q0o uAI/7}GOY&fܯA+: Fu:_ ?9B!}Y闛Yn83ぜ?ߍgú=WI4yø%,RyXv`cBY>nCexLώC^2I,SG0xO9j;@ًDk)Uy埂"Djp4Hٰ|%50fiV (cH/'5V0'5BaSWf˴;YӴ T#DFFĔC*z[9J[TIYQ# }YУQXB]9tԪ xa}2yzh~iK؊^VG})5܎`;0ؙjN4I5Dve!aU<0p* )$uIƊqSd.ڬ!:D.ϷVJa߮ A .π%}"NZ#qBY{,MZR̪Fw(^b CflƱHˣ .Ƶ~eUЈ2_k1,s~mVⰭd1Bn+n ѺSw]x0T֏@r$Y=ML.z߲qC[>'1d FE~` e.T 1דFiQWG!?hJթ㊟aza @FFj7~ Q$҃VV7 (TdNp-9yږqB.-ʘ᪏E:j _ǎy<]-=4x7~$ʦ۩ *Tsz|Ba0np {Jy5 `4A qvW)砗+(AO"3[:4⇚iqdF?O_zPui(}tidEXIQ.Kiwm̳#ũ`"p;ffTu]U`N`nA`*}b>Q2yrFr,,F1Y@PL m-3 +Fr|#kqX`Vbh+iJ ff> stream xߏ7%zZ?MCyE2 9m ;n/05feS.UKYl{ =ɏG2 KK^˷/_/>2Rm]//BEec\^{q^|eǺry͋_]_ߕ[1k7?#m~wmjqr=Gok2޿?Z׏>y?q~z_=*>rK5~\iy}׏'h' ޹ĸ9NkVb뫯ّ]շB61.%q9n{}tM~~ۻ]^ukZ>}J_}o|o( [׷E|uf˷C [[ۗu渴]V֥Ʈ/݋qkuEz݋r/*D\ed[w@e@m֛˘%oYۈ˘5neY@֭^nu_lzqA$o} i76.cBq ȸM#y³D-r)dcvJrHM=3 yKf-, q+@FU?@CG}xͼ%54}[AF5YnVBx6LRc鷎F}vDފ_<1ݚj"uԬF[G2"qhT[SsH"yhf9o ͚V]j*>[FU%NW:zF56sXOdI֒8QO#@]9\~ݲ Fs_{H܊޼KH>osӃ{ZT^(~D]M$n])ԡc~CHb܏[˼2%irM׊7~ԛk%d͵*۴n~͐0?Dդe }×vz+*Ӛ-&ԨaD[kBZ]OdI;<~{[C3w? CGdZǭT%2TNdnBoFMH/LU7Is/67;M3 h"3R(U#gZ3o'ހ-a"3`U|V}B":hRmDR¬ Uv€x@񦐹4IvXB"`:܍ XH ,:U([ҬWo}lU0W.ӿMHJuT:lF+ 1Z[u_`~F AAlƳD& 7~@52bYF## V# ra7GJ;1oK:96 ٣,5+]CD*3^ C5`mLWkhT%vzcT+uh+x1XcLs ,,1$ =  c5π]!qF9vuF,@,Ŏ#2\j"b`#Ac32dY@`L YV4{bi.'K-,@.$cZg(/@jĶdXb5M>)[<{q}(bZ93?23˾IsW[MKE,|$'cKC`BS ,-Y vfU?Fdq4'êC1KT;( U9\\ rɳw{1K61XLqsv,}8˙q}xsZBK1Kv3b0Dbjq̝su32UI$jeLuim>.!qeDԌ\QPױC{(fAG)'kEv%D,E1KNT,'2lSHnyn "18 YbQMβbeɍ"횵JXFv!Ƙ1]bQ]ܨ֮bѬ^,VVfS5[ɍgTM"c ٖKmSC&S&rH 2hݑDv 4iB-$H&"'a1"?7a3 2 Z)jkLbnшH.J Ҏoe/ʣp6V!VQ-< ḳq+jlẹp*ND<)du.qR66!mҍ39 էsI!HJVjJLU&dq #$aUpYlܐ #ӟފXظ!LjY MKVO9.rpՈ2nݯqC~K6'"̠Ո]P%lbĒ'GPĒ ygt1d$%ʇT#V>&v;$mT;Q d1'fk*4}HM-N $#R=N5n V2=]㴻 q\H0cei|4VL-Yiϊɝ r!Dʇt)0a*mC!^~v.caP gc$B,*8=[ҷa]CMMՖn ъ?`V'ya\C2l4,2-EȞo! ;Ml.̓<)%-mc˴ lÍoPJ߮UmnÍeU+F@-C ]YguW'dtQ ,4"gVjg[ 4'dV= U7vBZ(NYH8!Ny#3oKH7u=>4!r;A.I1Dpkf<[X"ƻ;=}6DZY+}+NY'1kn,T! VuzGPzmѾtJ=YiocڇT4egɘur;AN[v)k|%k_nE)klZG1)L0k #kՀQgM'cɠdGVOkցQdy˙u˙]y+`XByZ"@31v&fƚ5)ʇ5' 31&J)& RZCzt iSvHZ)lh8I s;UJYRT}+XaT:HXB XǷ/@B2[[ E+plUK9&l%`jBj)j¼N)ZEUK^բ zVa mLsɋZױfm[u)D\Ub]4Vn MU],|w(DU20@Y8FY+9hd֬ڸ-46`ō+[+9Fz١U8 82Uc,٪1rN:Ddj(VZ e`lUCCVBN"U20@d*r?ηzɡUℐHWuGeD0E"^rh !$T5"V kR*?*œGBIX`EJ`XaQ$dZXB^,4V$d +T#+fFI3Ibrr)fln^ahu1:R8Ҫ"b"٭jՕmn Xgq8$b9[6#JtOήn%`t?3$浄V7D* ^Jhus 9V< %LDK1kr QLF5,Y.@bllV)t!қV醉:)4.ҚVU'”EVҼHZS jQzq.iG֚r0@KM6n,eOְ34,i4m-m4iTZHy؊TZE-ZogGE"(Jֻ"Nֺ0߱~V(ͨGK|BĨ TC/MJ$XiBYcHю`f@;l)GMzӅXMI{0%ÝVT$<[8wZ.2om)}kXiBdJCt.׆=.5,˴5is*LlRikVηƑͷ$|kH߄t8%=P[ S\jʷ3!-`d.SIP>**PkmòG%To.cb[QJwErl8,1 RzFD R3-20@R_վ%ʖ${o rUHQ77@?KL(=l .()"[1Jwf["OIݩ+Hݞ$Pһ=ITҝ o՛.Ԗ$9,-(H|7Rsxq#3'trlifN5]j*H̗RQ^yW>YQ*9U7] su47y94!-'K?x9QF&xӄhc$]j*H eTs8ڨv $K1ahH.4 Jsxs1aʈ#hH(LQȐ_)i~$>яB e#qP8IV{uE)c8,+ap0ex;t-mx;t#-^$8ma2T!{ȭ 99D{*F6rrhCĻ[/U~m8 #r0FA[@*DI'sY9CױX9tkELnY9hgVOB$]rd-Ǐz@wl !.89Q9+1J6K:9Xrsrorm*Dn JZvoRrh"Jc%O:=RLn0DInjrrؤ,'GNrWS(3JJ%J.;Mw,(8TQx%Ot(M tGCӰbAe#ȡi@,ȬP<7qT{8]086hI !/kq99Ov|)d'iBw3c' :e9XBSӀ肎( ~'é rqb0J'U8F&N  B4>dH * Wsl?Y1r "A[*JMG I!ř|r0@.N`\>h9S%~fIͻy8\^F~Fg!~fHښsX)k8+f&&D<#p{x 'o@Nb-i''u38U3L$4?@H! |5qB"q,j -@VDnDd ӟy8C:H16ڠ@Q BF#L$?2$8ۣHI!3Ш0o$"Ņiʍ4"zb)a I?3~٘! fcHoAá8cZo % 'O;1Y¡2:8c.E6ܧK;t0؝4~6)c}:ؗL^ӧy=pXGǒ()rKFd A;J@SfpB]whv &XBeLj8  Q&}\?dp~62\3fy"b6RqRPqF*d6rqت}trB~,1b\\$b`+dgکckYC}DBg *#qÈe 4!F;,RÈe$8l& ,">$mM*H2Irq,;8)DGQAǡ@t&D6LaȂq,=fT62rP<jQǡd8)D[ld4!&g9f= W,JE,y6Ӆh"6=\ DW05UXa l,9OWD0̶aCς=8CF'٫KuKChD\X@CJ!9 y2fNB:y&NfQ8 BcyI`1fgy4kvF0r+Co{Xq>bC_iM!e:%%G Y:ڄ^ ț[NnP "|k:MG -ˇ@5qcD49Nĝ uЪ~Hpq졠eyu˛ xE\K"[>nzԼQ7a34e̲*99U6,3N!Ȕ8יdp7xcuAII!X!H'.53 -i=o`#13a/#bmKN),ی=O,2:yQbkuaw$Z Qc{ ], 9yCAH[<iuz!g)!֝y$w^$5Puآ[ZҷHa@|Pr3+,v*~A˹DAf-vOD+@40I]HYָ"m˂s-J\rv{ urED.+N}Fם oઆ 6C' %+h8:0C\] p6{]4h,Y&y"7fgm#fhu2/Fwv4>u"`i7ֆDRSN"kx!^oI-~$NYv -LjzX]Ivq5YC;O"NUҌ}hx #3&vC;DR.k/ jĜ&$Ո {Av3?ŷ=Cspzi6p"9kw30sz3c=fr-ᛵ|@݆/ KV'Hl7gE? sHQ\0ӘupHD"6(j刣$A&6wco#[B<֔{;[#S,IP+!3Ip˽}D9i ~Akx")ImR9}q[: ssO9UH=%x Y&TtJy9Fi Wڰ_#fgQgJӄYu)`}UYNZ"4$`LoD sզ\4,H!b' XCEUrc9,U<+jt'8VBM\ǗBuGd(`OA]O &=UAvڸ`-S(@ ;2퇮)' ;@&̥xeӄU&*M-ӄYIJMp\zbLJV@Dp >Nkg8H@Ѥ} JBrn oVL s.>la΋ArN(΂j4diS,#%89Jy!4@ρkg3e ?ͬI!Kmhd9g;+~JyuS,#AS7-e;A~zS:5砝M;i *ŢGGAc"=}9ppC1ghl[~i%QO!sŐDeo@ϡ@$\IOiA9Llg-ϙ4ϡ8YvO t;@Q~j!yrBVLX+Rv֔ 4S]MJ 7H:UyvG' BBHJ} #@ :hY׉tzv(B%N E e b ~r2ma$蠑 U0рM H2tX*0ن2tȱNn*8'3PRGg McD -{R*{VK@ +Z$AgfH+xH:*um .5)LxjriB %otЪy[(%AD_jJ@/5I! fNS4mz%HA0h:to3OHs Fu* ]XltV9:۪aD܁wt$Tu2C2JʴՏ{@ @ tΕG2]9 NgNu44aGhHD!,y:(Ϝ <BACwA̓ t^OĀ[V*'R2mCo tb}\2QB&0d9@tqrANA:z3 B_ I/dVTj~Zt~-HtkRB&O t04KX[;` ^˨>m#BuF̓zbs/q>4̈́}DrU' 1 Rst hgDZtPF5/G/H@ #$t Y:hD"x:Ke'a1dI.M 3K EK1N40U@ŗ}QBJC Dx ucAAOaE͆uBַC>r4H!;yDD*o$^$Uwcxejܻ4^ϑ0yNg;]A ppuw:؋D!HA AAi bl#,r#AE@$F3:hQzaT fԐ,3lZ@Ar 9aF LLd:,O-Yy(%K$IyztФsh g; 1 i|U{92M,X:R`< 2Sm0mI!0]<2a-4/7yiDdC [` JVL4jSn-V+dSQ 8=Am Qf:tl,CaxHfmKu*]9I{W2צ)'SU|Tc/vHqKݤF%b ũy:Dy:AA021uʣ )0o=’^?dcHAԁcQG`H+(>EÌD4 Qj>\7@ԁgW3<2U1 R =DfR|0wQ0N.Dg݃<pOq xZmDI?%f QߊO@HuPAkV*G$GKV3dBpbEt&]dNgRf41 'X6uI}aNa쫈l s=y:h8itЪ`]̊$\GbL6<'#Oe> @A ?g9=6i ȴK#¥ _͞>*@ԁs[̳Z gN UhIxP:TO3:hQ!I_$ꠝsoUNڳ/頋[Li@%O ΐSUk[>頝ڄ`==N<;2C$v$cs)}|"y:h6rѹ•Q5*Hi@&i:ȰM R h4 d;%M_r3Mʨ>r59Ē,I:Do!9?5OnTS˃< %HҼ.T/N&LWqBd<7xPWt \Et.D :hUx}::g \CT*||]VE!3y_Lx0HqbRuЮ[LT|:W|,W} [  ϗA3yT@&<}9F9b!ifGD r Ml`pq%t8!Z4 }PPC䤱сx2}z|hI$M=Aڔ>M&ҁõtBOY:h<;njLaJ$|$h:,4="K9DA t3,+cKm,?SXgBu莩>UH*^ tS0L]c+UEf mc94=: 4f'"Kpr蓓w 9Ӫ~ԯd8FJ722h9PDJ\wf \FH\N8f$U683xK2r狔4* wi%m'd!IKZ.I_1GQ{]jDsIxK\Sw[dYp2S@$2˘2!=tA9"2{'rLmS''Sɩʋ&&(9hC_> ' AAl;Tg'\;T'\;T|') W(g FbBYgQ x̳FFK1gՃ.!#"s{lr҉ ''+E:$1Q/wa2qKf&|k gIT #gҙ 90`5qr9L):HkD|>٬+EJ㎄IKg/c)r E4# H5e9ͳ:>NlTҮ"q $xbH_vT!֍{JvtBؼt NFHI!F@V#=Rt%i_-⠂ gg60.>>Rq <ێ.fL\e6y? zMؼ$>>HA;h*U`کVid` RqPAdjnC "m `Nx\ ِH&ZOʉLf t[[#rmQcˮ$o@?}KCsn0q2sM:Ĺ$xz~dk{~9cx}2g1]ngW98xKkݛp$67&#ʻsaz'H87ӋxbqA3Ͻܝ\awPqTȇuPq ͭOTN&^t%Bi;8,Tj/"K>vPqbt#ڟOpGTb0QOz˨5E2.r|B/e]~|Q/^~\㋊t{ʋ'OS~\驃2 ySyVPk<~ȓRaJ\֥./ц\\Fch݋޽ݧF`8''/|uׯ+_.ERϗriJw]=Ҕw[|}ˮdKnx_~W#;Lbֲ>|$x{_|)c_?>/]xL׷o~^}V߿a=~,4};R'>|wbƵ|k>}wGߟGJU~}3(| {'X%Ix"\3ipS]~_{ s#a^8jx$¢}bTݰ'g]*j(f|9{Z86wn{ְڗ{ |S48\|-n+,~r<Q͒q!bs4y~}#]Ig㇞'>>۠U<yd"9@iȿl~R#aҙׁb-&O=_6Ro:^ۻ{{'LIc4ϬwOV2P]ٯ9c߫n7fOGؿOaP|Qx=J`}O>UޞW45ʆ <yx;۷8~䛟vG-{wK>Y{*Cq':K^?X_]՝ y༴v5Lo w)[+O=\iՖW<~=cz[_18r㵾.Q 3 NXNkrpVw:{nln@?_OM/[Q.XExiO||8x]Ͻ V|nŰNCn'?"Q!f;]z<{窈m-hgx $Qga<t߽H;ăXziUp~ =/)?fxa4şhlT*o?~|n?7͛W>G_/򻇑o%T;_wYO*qAz_y֭b_]O>3?;y}O a hGzӔOF# wc\_}O3Wo=7wSež7*S@YwdNqWwGMº+Ew Bl;YO,Oك`\*=_}? cc%uS;ȗOR0y4|-ӼLU}^xMɾˏGl1| +X8|=ԞNT`FsemWU|z_?̺~W:<0)##xW]xSJ^l޿}o޵]<~u]Ob2qܙn8tk\?4FqL%1k>$@޿}NOmZ@R{2,@ԗW3ޯ״=fg^gl@+vuVJč_}믮|㟾ۉufendstream endobj 233 0 obj << /Filter /FlateDecode /Length 188 >> stream x]O0 CB2F = gɏ;Un⬫S³1YȷTm4:twYUۃWfmGwlQhȎtceІ[5+a ˍAƠ !TPlףE+Y jziXb{q)/,ɫ7Q] endstream endobj 234 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 656 >> stream x]]HSa߳W]ǯuABbc) A)ɴI5b.l~1'kA[X),$Bx]{"GBy hT|KMΚ->MrRR# V#Zf\q}.5Eh*=^u/1KWjMhx_m1R&ŒonqE'/9ykMRzP%FP U hئꨯx!GQ&Ql#Vl{mĂm̺27$Q(.kT.G`EEKE%(!֑bGʴȄ8 (D"n\C;B,ESI S)H%f\L%vWY|>I},=&<fX Y$ .-d2y^{qL;럙2{4x` -J|DKluWi'CL i?!7?Th&u#Nc#gF'FfG&?,L:endstream endobj 235 0 obj << /Filter /FlateDecode /Length 162 >> stream x]1 EwN@R(KdhU1&bA }I:t%/?a3G γM-!DgѴ`=cn&?Knf!lfaF $:ι^?LpK_K)}S)qR"Ε{&XR@l-S-endstream endobj 236 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 409 >> stream xcd`ab`ddd v541U~H3a!]gk7s7ˤ B``fdnls/,L(Q105H105T04Q020TpM-LNSM,HM,LNQOL-k())///K-/JPYZZTWqr-I-b```tf`Pa`bddgZ"7:柪?EtϮ/nΘU>%baBwu7o߾JSKӶ_߹b3k&w44z%usOn]{߮}qR\+8cN9E(Z:kri3z'O}hIinY:8];_wO^b1?endstream endobj 237 0 obj << /Filter /FlateDecode /Length 17837 >> stream x]7r˃}s`anP!Yd< `Y2,hIVǓߛ<\{m[Pg/_ŏbU=]ʭ^ \~J}?gZnzOz^Z[2ǼϿ}?7߽zn;WZvWVFZW[wzgi(vK|ӵW_|7xp]~jZھ-.5v{sƭROWOOO5V5m[ VeUou_[@mE$n [0na`F[! k[ >1ڷncrKH'V[@6 ko &0M#h޷*d۞K #)xčOĭuVHGiD $oȼ2oȾdݖ,Sr@qRc85~H?5q8UI:O_@w]sPp+gU4ɳ:o[?⛃mܖ 430n6l tG9#n tG=#nQcG`PƎF㶍 4M}&剡8[֌FzEGٕl5unhT.U|[U}R܉>u+h(v-Z} tmhFH^:ʼnգ Hs[,!SbQnv VrhTRDę!I^;L_q?$"K-qΎ*8MOvkh՜з[Z5iy*ĉ!ՄPDc@YVkH+oCM*Yb1S02ȵ-0bcMƔ,w(=<5{D#Asa{#Ne)E,`, 5'z$KR\u74f) Q!,a3V'o (1n+DŽ yjXdo.ec\dPZ$΀4vJfq@bRg鉽H ¦BK"˨gM4iZ$8ڔHlMv,:5Z_߁- 64fw 3ݵSqӞY2ϐpG{Q ,*Yz[D9ϰc2{}qCgGIl YȈ,sils5Ϟ Z~$0ea7C\\p H5,yuk3G+^aGčŜ-``ߎKR tvLJB3Ҭ%oYnTTLeFEuZJ3G Jq8fqL2YYGU/fm"Jiֵ |$ϰzFƉOdPmѹff 7άh :WV,zf4JYfœj,ko`Eڻ jg֞^ؒfEDVrfŚ0ѪqQcX瘧KsJP'ړIfexJ9lh1;eg!s@:q`De٘KҜ: S,ӂՠsf],&ljYKcKkBϺ&2?v yvJYb徏Of8rnsRd+<jefX_giP8A3AQ,l$NjZ%2o(M!FY2JefJ$ pR;oBk@ڲglQ,ﬓlѼd]eٛucibYM0[]m@ljdӏD>Unl*hS glcX0Ӎ-H3)D"SU*cad˳gg/(1[.GQ(Mi1e9ۜٓJg\,* ْVssY~8QPU'T Up Ȕ8<]:m_26p]ȤQe#" JFqFggcT<[I30e,3jڔgcY-fzޚgM j?'ճNfB0xB@Hh).xSiPm*lU)Oi F?aYak!} 2V,odsN"i~[בժzk_2'LPP3' %Zz}6΁C%<ڍcA90ݡyBEm.&%P엦i!$нRyBQԬZ-(g% O*wtU6&t3vЂлȢ JUUeF*jD!vfl@ LNJKIB8O U1e# ~5xu,Y[oeBi.M畕D[K !Pm/+{rP\8I9)ʵݙ JZ. ~ DQ tNQ<7f,7v43(Kx%tXgCfRɝު@(a,Jk;TfvmK/uaLXVkEK,8^CnYԨ6ӄ9ٕ {+N؁ͳ΄W܉|)^z t+aڨ`?= ܊0(p-]W0j(&Ui=DZ:/JńT%@@O oDmV3c&v$mˊA[K,}/N4j șbѫ8kL^ e3Kwrw1a &<0/ z7п8T// $t { $2pC0\jPJ+va&ZՎBswWqVЫ8atvz'L1'؃^ 6-?y>x->',`Ai*>NJfM/;jL@=I0ƨ%l&"n ;V8!+Շy8!|­8aJ;i sۓn ۪pJr miϔ8`Q}8Ughј0U0gǀdM9X.eKxkh+Uj/Xt`:һi ;R)9rM\uf0w9̻Oh+FeyJfzhp^R#S+YInVJ w&ř6o53T9E"[ϚնR kqS5%jq.$\6EdHi/p+ː!gMn.j@DMIZQ E9h%\$RUHS-)D TлHTG&Vz,} npf=-gdZȲ,ȠwBF0na<^|ЄACmq3=XMTd>Gei < H,DRMθP[gN: KR}4} henKSvM]t~K%Vmְ0mjVS'sq/8 \qUXziW 362^$RTA(7Mk[㺵٤4n%M~~ۨ^ PS%fS@je xXqOnt|IcKnUnZj~K$UJg9mP(1uoPjBCv^$LM@՗ڐ4t JJ!,*A4 Q$Y$̪\DT=K'\~fJG=hTTw)y@cJ#Џ(aCs#9rS'4զ/鞈_s[K硆R}yCvݟF_s◆tϞgH4a5UuƤ40jJz tNy4O%҃KˑJ5g%qbCRsK!Nzhk-ݳX3{9Aiƾ0c{s$KzsK ۴T=.FG]*ebޤ>G3=vQϊ`iuo8ְ8̗5K!-#GԡJkE+S„Z5, :O9 !U Hkpo#U'nͭaXGs2lYMa@[>VY]]1ɩz6[B2kp DgmJA{/TZTUPEHИ%̚Gt1t8'bJT=ыԖ0}^opS57DhQ=zS߈fb)Yj+$2m!gg@"EU,Kq aeGPQR=AY;F1,2hhYu( lBKrvKlAQES40s҈U%ϞI$NDPC }Rqg?;2h88H㱾S ڼ:CiIK0蓀O"$p2%L0;@ˡ)@!T'CaR@̑l) B݂#ϔQ  3z 3q<&^#CX@%y6b}(OT9^FnSR1b$%fBCLMg7[5VmN81q[57TqE|,9NSPuzAx%5D#AmX@<*ƪhj2fjo l#Ŧ3 j@r [dS,g~ƒV{2̗B)<}R@3`/c3`DQ!?[&d !nr6Őڇ,Ar߈p_x*NnD<'7ڄã E59 V }y**H'_T\gT?3gܸ{)D<^̽›[[4) ^6uH {17jo?1 02yN nKFPPq k/1FKH5$JBj(WF"45/#742(J;t)Q鹁55鐀v_:0s(8jCńQ>9T_9g-PwrNmH@ScY gW?RgHRRt 3ώ9 3ώ85tiҌlrCQ=1inp5gzǚ>d}.jdJ'j nUW "!8HHX!w7fLtNT0f8l xzd4B9FX7C:,j^7ɋ {~<_r S`91?'dpsV^7lHaf0n:9rl̍o\ШbPÂ-6EBu?b,O k=K92{lD(r.^"FBOfP\${Cu a`KPEI$٪"4uVOT:Czt܄y>.{T#o*eM2!.B< N{BDnE_<@x932).2ӆ2 >`)pLn4O"zIςҜ 3(頟p2G"O#~҉@T@u!*V(Si>hՆؼ 4Zx ЧGS$]j0#uH2lc9GokPrpH!/3Vd$Eٝ7'@8Aӷ\p^ӄSpr(;ɡ<M[97KdGjISr-q-ڕ:݊d!yF?q1wH$2V; nUHI bF=$eU IxݪNgJ( _[loD,.""ܬBIE"#$6N[$6 .r@!yD\d+7JDR@%8 yNe}iTʅčRD89ʾVa)o}n$h/ QZEfuԪ L]܋LN`Ʌ@cL?#"-4g9S^Z"ޒѢD,-"N-=9'`鑷D\D|]bm0^b.&d%." %<a2<X9V]E"%˽%ӽ^M>Ppr"~"rb XAw6.b"Xa6r}Ύ:'."$E]$"K.YA]706H \0Hsui{89: -DI&]E"RMp;W})I].Y> :prP.ol "#Bu9!Oȋpsy]E"ʿ"ȿD$d(u1Q*"Ref Z!#,/E]$ W.FRX' ]]ň8r1yiW{;ȩ˹wU?1@D"qc^I<E\L0<I\d_Ex..AFKr(bB"r1\\r1lba x1HPD]$"`uH 1pKNWcm]]E"1ȋ B۹b TEcHDy yM x7gu!HR 9]dgjlRpKP|v3R9]L2rs\|xͬbGq3<*#"7SExcf"r*ǵRi#y$!b 1`6DrHč yIR#5o4##ģbzq"y)bBCE"nd#t0(.F N1s&W4ĎD8|"D!#g蛢p/fVs7TE"Z$撁/-@PA}f\ۑ1\$G`$2Mܷ+sozoݐ ;n ]}5`o\GV̗|a c#3kοP왕0P9I rF IVL[R\\XLm>i} erPFǴ OgDTyuk8FB.F^F,aE4yIDďn9<,'A4{Hu9/_b0A096fjADzO: &U@q1r3] ՟JD~F ψmWՄh]U ')P9e|M].G~~. Zt93XCs!4W,\t1rf.G~Fh2Dcٖ@a"i#&l}m|mc+ii /5$"O#`/W #< HJ%S,wbhAoVRg 'R]P-`hIxZ^ M'9xr4B$ \SwXKKNF,\RI}.y3IR}Y.2+tBS .j-w@.{8:i'Et}Mf ʠn!.F~FI. "2" 7NP] ap6O8i !nu!͈|c!ۈ)#R=Ț2E#"+84CDgդ9hBmhLV|4"{p4XDqFXC4}a'>[b@!WGZ=K!O#rn #gŸ]~FX4{FY6gq']#"rd; AdJ!W ѯ8ճC"݈輎XlBxpQ 2hB#l ,UVkāOZFT 6T g}WaV%EA>3!gSS~F К %"Sy+ԉAn::b)z.D4Sokjl,@"n>m B)P\o+@[z]%ay-\È[F?:-r4€1cgq&ՀgqDmP9𒯣K .:] "F7*qW_vBD Oljv ri`PYL!|j4.p}޿S^{KY?<_=?<_V/c-\x̮q|O*bVOݑ~\*< ?yY7ȼ]>S3^E}ۧ_]˫׵0IuzIZ^?SEwzA_ m3ThCOBx KOyOݩZ@k?޿ ?=n|?znGS磛*m^ pMְ&#{忹{R7jFQBkVmT+,zGUEG\Z|"X8HF |PCf$D"nzziU=  #paɯȈk*2,* ǙËw_֬W0͔\qүY߿<Z\ԞʨQǿ|?]߽鏋|o^AS諣^Dw_±*l+8J/O^W}=[^9/~5n|q}:a Տ.h}Ώ.h?}a" %>8KD^5]NkKSyq?ܦqCbr ,h~yb`܉r>Aj0,dzSbˆY\}q8o?徘-~ !a8^`L*n?ZY'aJ/\%٧O΋5PSUwBm%@=%%3C?޽ھxg=A ]S朆@GO7\x>&~l^:BXo}߿ۿ棘~;k?Tk߿7_p^_'q~~Ӳv|kqoQ/^Yz%O('_Ň+ _~ݛ/<|ո}OWYT_D=_z[b"ALgTa^L?$=yT4d]S]#b"E3d!e"h9W2]2}%\2_Bj˫H'T]0  3:M^ЦO"D$S,(8; vB W1SPUdn5\3]'wU P}63muz.V rUƪLgɩU$4T:$X(8ΕX0Qp?O'[? 6Myp`w-/ IӔȐxBQiVN ޅ/ Krx ;@aqɺw_~e o-+ʼTkL ot^p^l㴝=C^4׋Jy\Z7k='ϭ»!‹=W^|J˛jF? 3.dNv&RtcIu=mY^-cĥ!6ߓDmzړ >D;m{F5?τӉYsx:ivpLwfw є^ \]ty&ߙlLp)8Ah8M41&Q 5&M`6zs= r#E&7ie7^C4;=DlGc˽6`4ǃ!ġq^Q"b0y{xDn~Dx)*/\wF+]PO.4Fk?(Uѻ]=\'$;O ]Fy) :+~GQaV9eUwq>*޼w粆xC}978VVxOVys<*q(+uGśaďz7s5Bgw#zqG;IwsQG\zws4V{Իzw ̣ڍ\^Nnand{u#iλZnZw>Zws9Һlڣ \p.?w s2 tVÃ"Yrj^QzT˺]:ʤy{0w_~ Dμm＾/z2Q0"~,뛯="7 Lzcb9@{=V_|^;`MܱzZ_Uo~x=pW|endstream endobj 238 0 obj << /Filter /FlateDecode /Length 161 >> stream x]10 E7H+b CqP(C[>|/> stream xcd`ab`dd M3 JM/I, f!CǺ<<,{_$ݟ3#cxzs~AeQfzFBRWbrv~yqvBb^_~ybrvF~BRjFbNB~BHjBhkP{h@`|F#a&FFk3%K1t?;ÓM3|Ǻil5 -Vݵپ|^U+%Wܲw߬W~K54Ӎ:mɊ֭[ _Z8zn՝#ÝlYN^KH>ޞI=l?JT^VZ endstream endobj 240 0 obj << /Filter /FlateDecode /Length 1680 >> stream xXmo#5_qHxK73Q> THT-t{,&Mng{fywS8W/ LNM|:QStv7yjJx:'obX)^?kkXY/iғaT~}7y}L Sn'U4mJސ Cbq+Θ0X]D1ޓMסGTw8uˮydʶ@i9aO4f+ӢzW.1'!L: S?&92zҖ-=ٲ l6DyM-[Yzh/NG`G,tNiT}#""8wOD%8m8Q?fqemK q}1~6OXE.,J|ѺNZ@WeUdAۺpZiGދ4( E؋<8tƉ I6!Yzok7lٚ/N?nf7WW9 Z S4^D1Y N33jA}UFLe Ze]6@JDtoD9$Q<"]zyiLkiqަI$Dc/GboAGA}&94V'7G1THtI![gS)v󂬣č%aRClO hЋ)V?Vm11Q!N">uOY&Ƥ(lb󲰭th MZᘿ9$A?%+̔7IB8QQu@>B5g5 ɇ%)WA3NXU#ވ}~]w7EȶzV]29nݶ\gqZm+o.K$TLƐ6`=[ի}Rmұoq<-E"Yԏe*o?}OKNIHg顁2pLĝ&rl{Jcq'b%Py<"Mq]?` ntox jUM(ҳb/iy6_nK(x߿ɠVMVy4'uT~mK EY&o9R2672R9Wb=﷋WV 0KXVfBZ[QԣPdڽ쇢~v2 !n\\e||#rbqLɞ%HgEO6!SҦ2 5ާ.56͗/rپ+DcJkݕ{BJkjM7oiwEȐDlj"[ YeYNjwx[y#D]sOfBr5akSEqCx!.mk>>~w5\_*r|eU-],"P6FQslG }&ᠰ#4c'o7= CȳS# u#]a%FV6y_):>؄2KA^ J4yuCܹiqn,TEV5-Շ8JMkO$ֈendstream endobj 241 0 obj << /Type /XRef /Length 288 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 242 /ID [<5b02df8055dacdb11c1ffc721c46aedc>] >> stream x픿/Q9U?6b!щXb7,Y $"[,6bAQTPCoxrs}=7_pAj!@0yffp۝uef=4),U1B,^)q|xW?u{~KT̈MqG}<4,cOط"͛|B9C;NHn<tK胫I,*/Lv&d'=gXˍ9(KqƎ(+8@ XC_7q~16 endstream endobj startxref 165769 %%EOF Rmpfr/inst/doc/Maechler_useR_2011-abstr.pdf0000644000176200001440000010612615075721240020060 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 2337 /Filter /FlateDecode /N 36 /First 273 >> stream xYo8m[%*zGf&6ݢ8(6mk+K$7I)Q" AM3̐ pHy ('4P%@U%@)0E%PLk '*3_ EJ5g@5N4d F'c@@ 9|+`d`)PA@ @ P)(pJi Ҋ_AKДq 4# xbp!p .&Q'oQé9I}nΖE%&/? ʪW aNk7β<{vb0JL B~6ᕹۨ~aL3i6]'γt ,͋|E(瀗˛̨p]^EEllZ^L qszI+k1Yęu{iRȁČp7O@ӠtPnCf2o‚IwiRX q,]>^;_7Rc7̍k>]87" 3]IF8JV*YbofMtAu ΀^hdLLUS/ hO\'{O#<aIc2[oi.択lN[syWsc[QUo?; UQZ)dtzX'Ő{{{,j-kMR%+F};{C@(hoݘ溗MetrK{5A/+"6Ixym.m(DZ"}d?bGjBz OErbnY3ި㑕6^kue,裎\҈DJ4шWH56צ~g{س큯VmTX+\nmqɣW Ǜl}G+l"A(f1;~l$Z[ڷA["DW^K Uva@N-ۿxtY x&іE.e>?CIBܻbFNvn]rM>ȝi7nh;')" p[ͶFC:}kҹ.25.S{\j&Q&[%hAuRP o&Y ^EwRiж~|!q*Gx@*r؃ǘo`߯8{؝H=G5R:xy&)iKpv#ozkopNt)Mcڻof_OlTXyMC[Yfm@^t%w<$?I񠝯v=%Yu>=Q\b;/›37=wi66Y)wQ2\h^~ee g7Ʃ GɗռM"xE"/ͦ(C,rꍦѿ? J<]sxLCߣ#\ߴZLN7z;jɜDYhOfj̀xs_endstream endobj 38 0 obj << /Subtype /XML /Type /Metadata /Length 1658 >> stream GPL Ghostscript 10.05.1 2025-10-21T17:11:27+02:00 2025-10-21T17:11:27+02:00 2025-10-21T17:11:27+02:00 LaTeX with hyperref endstream endobj 39 0 obj << /Filter /FlateDecode /Length 3344 >> stream xYYabI$c3Z%ypzwhq1z7,!A_$g5l8 4utuW0"vjOg^Ug׫@@2)cdb .I6/(7f 0V]S|]7iC77e`f7o00K8l|gH(wY\+ ,J 5^e[W̯wfAX՟W&Vݮpl%%CިiDT_ 1zzҬ^k"$# Q"N.J)ĕ7KqǾ.YF:hg\JmSLtSg(>媷(/8>A3\[O{k/1P;B(8ʜP%&Ĵ0PMPq33&gNM]vÑ6<"в@# 8z.F!o c݌3ɜ?*u8pW3OZ)v"KU@s*<~s܋6Cpv mD}($B]w *(hGwDB0ͭI6jMԜs%)|YSjwUIݩ+tT?{B#=ZEzE/Z`^m_ņ<]PE`rXa?ajh4QBd$>H9oBP|긂m}S; iBЫ&rX5-_] ~>e-mza%%E_4*o>y cwW$O9%3Rr/H h]TܳPQT\9wS礣/\E:2ԝR8',LB1v6 <'8+2$ZqERRnr aFJ#9EMcphj;u(qZP'>4&jic&ˡ$&NXk&r2!CF=`maMN1a u1ׄf~""7FNO޻1XvHT4H&jhfln14?t=T().|WIQkd׶m/%}\$IHi639ERT+uQSN"nXmۜUpJ^ؗu< _Q4* ̧R6,]}+Ek"9i\!;4 Q)ʾ j3^#}w{WO@0t.Cб$<46 (0?M{u;o_? J2}Ag_ata+hY||U%0CI{ҕBLŅJ Äx3"ŰFs?\ZOfeD2D`z=RڍMO06 }M e~;yK-7yn^laendstream endobj 40 0 obj << /Filter /FlateDecode /Length 524 >> stream x]ԿFO73wD@8ݸH$y.92TX+"oܳv#sO_>O/=1NtG}6^?ߎݿ\OQ?xkePfMyxA9g\eP.g> stream xxyTCZ)D$ZB3NWTE $@$$@S y:V[k[vBۖw+'쓳áfQGS R$T/Ƨ]a>$>Skyhp'D=My?~{8{/mT(3Se j2___It7O'KIӥr2I^" J%$N&J6 ۶sdᖝ{$[($ -Z.b* 8ED$F+Sɪ%*IDȢ&Ft^(I2JHTԨd4VVHd1X{JHVKԨ$,Y% PԪTR-QJ6?QvUTjD'*b\M%KVIR'Z*Li*el&4,9w/IRQrj^*OWG)̙*fN˿Lܭsܵ?rGszW*ҙyL #eaqk Vϛ^kz& #ϛ`!ݧBO99S!Xp׼2$v:g;y>';Xpam3*/)-)X'ĩYy!%HUji繳E?tƹLjm8Ƞ -DZHӡ:܏>u61_:k+rL^Y۷>3eBC38<7 )X05xAG4^!Aovǧh氼#MY5-@~>pt>-D֋|ɗwDA /b=1Cy0 Uwd҇-v(_ J!l] l_qdK_$"<"|[X`/H$[Ƶ g?7з'OeNQl t)=;'bY[^VbݛvH`2 /|L[{ <+~ے|;`7 OAA5$S]jZ 4k0,(uZ6et_bF0o\'R|6IO¢uLD6 /9 ciH]FtYkWU97wMӲW㹊_ySP3p1G \p;Uҝ緼O8IH3_$:GdU[utZΞbBa2;zBsV`S-AѦk+GGd{ 0ͮf%UbDHȳ.o=5*&4 Xl*|   Ƽ4Mb˱&y#~7oݽڕu;fFB@ރՌF* FJ~8ȷkq Kϱ]oA͠U >K#R핕m"Xn6,CGE o/(зLV4Svt Hahwvv8gl:TgGass_DFwn.0֊u&+F-t,*Y.]P7 ЪUU\WBOB{hcpB=zMΆ?D џmȝrUSיBxg旔b  HPVЍ1w#ė2TX.<ɭMQfEMZ:VlBS{[a\പgWP(GppNfTnu |Vw* ~eHU&.Ϟ[y>S>htj{ w*Gvf~&M.q9rFdyx/ f DrRr.YvN ȎqO]bCהM\SnQ`Dv!5 bs1&9_y`6=5˘qڶ0D ȟ)iI0)Bhamm r. };ր7u1g+]z]ފo dY؀?Ю~)ɾޠy㞂'XiP{B rZГE_-30Drh( 4yNFz y^G*i~D*7Nok|hyigU<)7I.ЮNiഃ5g͙poڬANkƟ;[so89l ]d7b 6 IsPmp7ZNB`xYCL|s^efe^%}[^UZ:EcC-ݛ_֤2(T:1 qSI(38X4MeRl55FU#;٪M|UTZ n51MXh +dŠKWDž/`gw,]N#umT {i|CےjgFsagSyIEE\\]R-ix-yh'M;(Mp"F^=z1^|o B_0X^)r1JPi|h?u%;WzrQ/%A0Y]*ZƄu8''-U^`g^c؊mVKg)m5݉]g&EZxN+r*)HMe&lbW$n9C_xj5SPU xtei9`4\%w?I#ky  ?{jN}h>b|Дɒڬݙ>moW$߰>@)"9aS%6I8{a.R/s KLEEPiZq7-#eNutka* ˜gOjZ!֪t)i62cƒU:#C؝z 91,a_vִ.r}:8Gns٧a))^[ q5ʴ*Eca,lmr4_trexhF|8,R,~Q[2rʜ36Nr^c?`h쓣iBg7ݰZoU"Itfx$\7E4~V1! 並XV34Oldwr`Yn 3e별,Yn(FDć&@ټF~M-@'xZvL<휶 wF̒b\Q|^ 1]P`ܞ%̦J+qFh1YJK1z ᑧcY'{i!3#՘Oͱ}!b83 WF]Eo 8[h"[=ש;fX G-oxA B 'h9} t?} | |#b`~OWy׌Iax_T/Z}}*~tc"r^bj\Wpº=Hi W]~k͘(O36`hllݵ#D?E_ \ j}͆ZN?GMpڥ}leZJZ|f+]|L7]Ѿ#4h[y5yƵY=9f]F ]iZ4S'xġvN}&^:k*/e"%7.o(dff 8۫Lq(Ni=vV4Ѝ}֛ SRZ뱳RbƎbkI%v{>; u݈Ogz?5au>>pm,1l;-o}'ZE uq, NNؿ+}уmw9q9΅ep9vaG7I8S~AsDvE,I *]=Ԍ+0;(>DM<4$]=`挚^ ^׭u=mݭc$tHkYz^Sn} rNGL{m0̻tpqXzTF?%bKa; s'=L6)ltm/iҺ2ki5{-7 ]4my5.o@ PHgjBѤnhnhW7'7uiN9=nLG aj! qVyV-8#Qx/^5 nJFV+ұ m ۿayp$;JlБ=@OFn5ϡ?u#,\LQt_3|\M-Y] |ܔLf Md faK>v\V`SOxoQFb1eZ? \XVTVd.V&\rsM9"Hu,^=Q%0:PIm!\.o?\ז֕Va]'N޿i`sjyޣ fI3`j3cjC4Eʜ$="/׉7]r\[j+Ec6r(>eC*{Sf'r&uO3Vs뇭1tŦ .AZH!eZF6I WtP_EPAw4bGLi)eIeF<$hfǾ&04%p(m ?/ B=>.53#"^p",=lrZ\s΅SC_,]%!}YvN~caKD5,gA5{b3j VLwV88[[f rM;| G<]㞂k]{c>n#-(tpކ#|_Q"& .J(\awi܄D <䢘d*l#Cq;v[d5(Y/N6ęV|w0?{!O/SW[tЁZ&>Ԭ鯴V,.4R0P6qN A  3s+XdjsİdK1٢1'$ȓvtJiM !%V[qЩKdf7YV:i.QYq RBc&3K it~SSTŒ'<"%HɫF p}M 'd\a֥<]WQ[^^hi(pإٹ\]Q;5bs\1|_OpY<+ 򛡏~f޴8!PwŠ/Y\L6@^;V'xîvz;kn{ a<F@v%ha$l}!|ȇ.-ʾ3=C܋‡4k)ø &+O N7P Z1P!PkxE+#aTW1G'<3BGKm"Z&Cds+{gڝv>R?8+(+6YM,1#iڷvzWK˲IRIMiM#Ibw2Jˁ'?!n^01!/JTnvrFf/O0[ĻPhx_Ksoo/)11.(TYn@ *;LL=䜚©)f}DRJ~ 3"xhM;{kۊ>G놏ۮ_M̭S'nGXwLFJi۝[Bk7~FܩOX7{@<aOMfuB~+Fd qGa7.^]o,#oER.KiEiXxFiQmm 2YH|-ހCc'ێEV$Z]x 52Kv b>8mN,&Y_خ*- H٧ONSb9{tR3lv;>YUQcΙsRYWY9g.E7ȵendstream endobj 42 0 obj << /Filter /FlateDecode /Length 337 >> stream x]1n@мO MGB?VtǁooUi:?>wkrӛf;mOT{ߧbǴZd[c^7hLc?14ȭǞȽǙȳ4`xce, 3H802x@ģ2xfWHXFb DžiT0}ci77ҁPoW3ϖq?s3&M8ۮ1\1<>4fo쾫/(endstream endobj 43 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3510 >> stream xVyTTW%ZFIZZbG֘xLbck6K*TYM(V,žRPUAVQ@H\qm\Ҟt:=,3Ɍ̜9bsϜ3{w[~"j J$I#Ud4on ˇ3~xn"b/p`=KA럚'~EQƮ˖-`2gY)Vfexx8b~|Oc7(Dɉ m8y1U#1q#+ រڂzyف@G QmO>ּ9^.Cr{WzD߂x`Q]SXdDž8<ۥVa–L.IGCDjáFM$/o.\s>W>;8f^t2곚o#۠˼R#_J>u2'7o rK}CL!%-s뽼tqAg6pz`/Xno&IG+n$DiN0r>>wY.zh"F=c+4Wsvmɒ7 p-v׹+8DqYi떪l+h-j 18;* ;@`Ny~{"8 9Y Iok"[PV@uDBf]YNuz n W.w\r9R:MX Z"\ts>=,H$33FΡ˧NM!h _Ou~5˼$ao',tKiSHc>Ez=1c0h|}ׅs }hA4ͱoGOongҝ~J2Z9;B-H'9[,T) >`0iR&^։ËUp<|KAI@Z5eJf2 [)g(/="7 B!,G 0GNKvd1 M rwYTpYG(! {xߡV̯-e2W WcG1btz5ۼ/a)Lp˩ $so!<}&D2P zs hKhWX}з2 eZ[1rb騅~)oB4aˈ/,yG4x_s;H4|ܓHvUe 6b$8H A'ǝA] B5ΓQ|:P6N~MK܉P2gFפhZmcYUGYv΢zzZ5{;N/o.ͮ!hWzBSޓO!.ɽ2u {JUwyeԧS6ʮXց1c#̄!L#̄|Bi=RakNٔ٫#RrZA a'7ea[U^#IwZ]c!<J=fnQS0yykIC2yo(m72\U\QUUv1b itšڂuHSx>]x,!SQ5- |7A$n_THoȰ/i N𤳊ԕVJ ;+`~ޒØZ+_]Ti+tڎC=T8h.p6GL#!ʼnJYX3_s8C]Yv+B% V g!|+?F1-  BT[#w[KuKfkT%6MKS+?)S N.w4jdZ!bb䆫x;N0Q^Fd6>ݍ/ #2M=f?ox3UuNe}%VkY>ׯ;38pz=3X~͙c`p?Dǀoq=|TEӏ\J^QV1ɳb @G39=Ձ02I_˯~endstream endobj 44 0 obj << /Filter /FlateDecode /Length 171 >> stream x]=0 7OY,ea!iTDi:p{e`xlg}rP?r/,K\Eq ĤlٻVlͤ'!(pnfӹM䖱ᒌlhB {5Cr+F;;f}tjX/U3Ri܍k)$Ǿ:Uendstream endobj 45 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 422 >> stream xcd`ab`dddu 1T~H3a!.k7s7ˤB'``fdq/,L(Q105H105T04Q020TpM-LNSM,HM,LNQOL-k())///K-/JPYZZTWrp-(-I-ROI-c```24b`b9˻Xf|)(@.)9X#}Y8LeOבb{GG[:(`阾Ad]xW}O=k3O9vwnEmj`լ#V\9dO7Nj6N~-V]$Cmwwfnnl|r\,y8E:endstream endobj 46 0 obj << /Filter /FlateDecode /Length 161 >> stream x]1 EwN@RuX%C1C "d+Hҡ-Ym`A)286͞Eӂv\LD,}~3, %3N)9eҵjOD ypK8W R<bI_ Sendstream endobj 47 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 286 >> stream xcd`ab`dddsTH3a!;{wfnnIW }O=Q9(3=D! 9P\GR17(391O7$#57$391G!8?93&J_\/1X/(dByfIBPjqjQYj[~^_bn؝z`9?$H7?%(њGݿ|w9wY^Am͓['Mw;7,5GO|>'a"endstream endobj 48 0 obj << /Filter /FlateDecode /Length 161 >> stream x]10 E7HSե,@@8U:Q%ilr#=(ul"~H0X ôO㢃M'(0d| nښAoh )jItMwI{`dRJ%G3qp8CN_!Sendstream endobj 49 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 379 >> stream xcd`ab`ddds4T~H3a!nnI?g ~*XU79(3=D! 9P\GR17(391O7$#57$391G!8?93&J_\/1X/(dByfIBPjqjQYj[~^_bn؝z`9?$H7?%($ўeBSxG5E{{'N>5q~e'vsL4iĔ u vvVnsKb 'qLZ׬V^-RWݧsfnƒ>#6u4Ll&κ20V2'÷yRiSXp20lendstream endobj 50 0 obj << /Filter /FlateDecode /Length 349 >> stream x]n0л?vFBuI.9lD 29G]䰇T@[^R۵[֭qֽu յ\m׼nj[ni~k?)N)c^[NжߣqM,_ ag 0 S)@=1S= JaJ  1Q&)W@gm6z(KtQF)y#vLPV)y_k-)d B)@ 9Rr+Ls>S||j_ߪ%qjJ[T׶>endstream endobj 51 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4612 >> stream xWgxSgp,_0b)dtE&!I„tz`l%YV,]Y\[-ٸئaf )Sl2u>>>۟;lSXl6;cDVQeVYZDD/M1 _Wp??LecX0&<s1ę>15%'kݫӦM_)%%ԢYsDUhhB,-Sr X&KbU뗬\,xehX.VKEP\R(į˔"QaHU3DsU|J!.KEB"i.R2J%)$*Q2_e"P)JDerH,+QD(_YR ZTe.X$G|u2JRDeŢ|QQY&YͿl|\%R+8bQDEIW q D^s"$_Y$Ms}UuB!=ŗUbi'e墕esDEKd%m5bM+/S(5E+ř%۲$9RYkX/V2YYkXYSX9\<|k EŬYYKXobf`dY鬉GجXŬ?u/ 姧NY9|nb 薧S>}1ڱثӏ/ : lQ^VQms_Gb. (* (8ZV @\e] (IFtM@{n{~}ѼryV]h8EFܫDE[Ѳ/ /#91WޤT1O8mGa Z-*j1>O̷}a$ވ\t9@ҮFVu,A`4m_W Po G*!쉸ma#hrҘu-h~-B^+I<SOgƸ.LoO@웇dph2OHr` B+$R{KN|p;*l:C  qDVqlU6W \i&ۘqi"o_;7 Yl?Qb 3}BC9e8wx*ЫrXׄG %8oŠ] 6ro*Gp#h?z*Zw1@Dq3VwZ@Gff>m34i 7@ "Tto+[h~:1A?#޻ｾ$OatCXb}Ui; p{ig>t[=4mXem`#4 P_. )Q]O>B>$Ɖ!.^7Gy( PmyO3yUrK'5yh_ĞeT' VͩJ|tDISe&EPApseMW3uqfv2F)8 ~z;}5.n|_Z \ O|^w>jj:@0D/AS["SƠ-jF ! O3oJ|nfpnSi5fwi̴ev\۝.M833>!d(pm2bЇC#_"v?mD0*>4}6L{ښ%w Nw oU)$z9]>3C{lj2㏰4j8wAVиn #TWAѬk~p]@xe;Azkcpc%d8"\nu89xO8yexSFȡʥ+̛v A13h6mtFM_x`317 ҙLfN<'yW{k44*bKwѠAtmT1ٌ\m3@hzS E^A:o[&SS7 a+TAa$-"Gk.X=%HW%Ii`sdYDd_:Kvui Dkt;]VntJvt$퇶SOƯO$N9'Lqf8Gw9K6cIK(Qz`s:6 &| uɵ!A'ڃ14ۑ139y#۩ZRBѴ!kz 櫏$7 Fl2u_'4~VV2(laEjzQzEv|1589}Iw 0zU[|>]3{.^9Ҝ6+b}<.5^JUkfy}m7RK*턧-hʡ݈)h⨶` 0OUJ+[[; 2̟c2g4N Vo Fڨ*jS@4s@nEv"qOrn*=Sjs/8o_ 9zw#P/oﻌ.RPȑ.vE¾7m&JMJxMkq6_YePHLf2>~vBI\=wSP%dzf4Ҡ ׆u8{^;F=.qVr6-Ĵ|1)C?St a0'ym胃h xe&vylbڬ- dڮ}=;~VHEW HoͿ33| =nqy '`Un@'5ʢM)Gic9U/bbmsf^ {$⺘FK4%}Wz*hK7@В0vNm|v#`9}@$ cưX |endstream endobj 52 0 obj << /Filter /FlateDecode /Length 184 >> stream x]O1 y?A$SĒ.ZUm?@D !pپY 5#/]uٲE>"k$wQIL 7ޟ\r~w3xu]ck2@k.:MPfrf} BRZIMSrX+J]ӆӒct *\endstream endobj 53 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 968 >> stream xO[UZLJja7bbe8BW r{rxZ7ShK%xČ/6eccb %&n&0}Uq<pot)a~q.HTgˌuM6㐓rꬸz"Qo^mi󨯫ᤢj8ҡzoZAC :$E #Yon@!` w,>C}d6FqL3Sn|~l7ИX|+3pC抝i][u|s=tM| :⎪+3̹o)=3e?u:9/nendstream endobj 54 0 obj << /Filter /FlateDecode /Length 360 >> stream x]n0лB)-m@KrɡAjYPC>qCO~ku~]KWҳM{sz1ަv垟7?~{u}~L۫7#qY6Ք(@JlƔ)@ #^(@D Ո3HsDٌ #bGr1QcBrX)@Lr8O:$ 0Īub S#F" `1](ŷJ,`39 ` t%QW(e%f.g Pw*ѹ8|*^n_wZz;endstream endobj 55 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3376 >> stream xV{Tg!0*jKv fF VVֻxA*!@,$1  ! IoVPNDlݳ==?\~8{LPٳ߼y{q,6qҍejUEQʍ%J|2b_jPYϒ ^q/m^ylφ2ˁƻq&'-Pk*ʢb=;u̙J])Txv\Q֔*T7U /V`eVt6%=3MWZy UDf(*"-Tkْ6_*Pj v:"_)/a `jRNTX-UzEWJU~IY^c *=ѪRVblZk=ֲY /노:NcՅ-P ռJ+*B @Ӕ++VNLTEOb"D PFU-hJ*÷^Wu7eWUj6-kYe#loa6F5_eLEaQt7LM1f；a+XVc{|,[-~-ұ%دe ,Fbb `",%&l6X,Óq~?fhhwD{r"$Q\Y3:79#^6sXO7ş:|4\o;$4z.ְut }b L"M;L*7d/o9rrh3oX5H_'ۛ${{@3+/ .8%s'յa'Ǐpfc?nfL@V/iA *yVЃ-⹫'Hџ­L%?Tک 2f ylxá('D|2FQ(1cq84dιbFYo"Ơai=CC_q0=$p?D1mDnTddrU23SwP C)#/94kaYg+#H0/-g4QdeMݶ0HܾNV>jiwW3(=L~tlω`g]ct/{lUX}*ZtvjeƠ4XJ$zw4FW[ mw'%3z 5ud*d5YVoiq϶ږrPEe볳w=vN' ʆA'LpfH}p)u5Z4idmՃ:ii7gn#;&7[l:UV|teڽy$&#Z8xX/Oc]>@qdy$jB2/U'o(=\gm5jlmۥ+C׮?{U"BJBI(I\H12<KVq+dfS= ^ݲ[9_'4Mb33 W)&2bSyď|@etƽ0 K0:8DrA1zH4%ɨ / TE CTI#`0 ‘(XuCQG xWLCI|Owm_(4IPJM㢟 c:FX/`湀zs?{;BLUdW ̖"xA37HKP¬qǡ$gCR]iyh򋼎@$hLy%F\QFHBYMq1m_[ F-SHeyk"Dg:vb(L ʨ >qSG>;1l98ßp<}Li>^B흛G)( @2$;RojmlM5f-Ͽwst_P.̲RYp<'|< *&?kÙΫ@p=&ji xг[dJ~)~xFU{3R-ZD{S(I|{tɵ-JBWPbovQ#z[@(aƑ']s8;>T1E 4徃3{ٻ?BVq8 h(%wAөFwSJcʏvCCZvn 9Ȋ@M?UL^>!w %7) ?84 &Dx^?#7I8Kgec>rP4J S+!h9}. y\`vX`FVF)BBuT#ll3Lt= GCt%q;zG>x筓hlrBGi1YM,iknywz&4 p8h!|8ˁrF8Ro %{;}+tXkS=tû"|B{;]s% L@8J$+`,Ş^=yq8SH7_~#uڬc*Ҷ-ߴ7RUqAF@-*C~A-Q^vjzdCh&z1<@C"(hװ}[z7;pjɥY35ɴˊA5e}+;7u9zLֲ sjVJxz'?_ EҶ q8h@cC z[}2rBnc3" >~K=BBp?OoA.n-݃tbtgӋSl&p8_yAXeI#/AkI,@ebw=ϋ,Q1;7|M"-"{dZk7}mn%XF<,6'X.2dEs&0.F L';i^ ns<r xN]y~4 x<^'61 V% 99ދzV$~*z?[Foa'= faR306MVb@09,^3$Qv v"q ^nN~5r*&Gq%u▼Zmq)9mNF+:Qp$hx)['j~*8n[e Ġ4,p`涶s!N8] }nf@aB0$LJq/6endstream endobj 56 0 obj << /Filter /FlateDecode /Length 384 >> stream x]n@;_l1J.ŇDQ`a8Ex}G]kC*`Ĕ9=> stream xViT׶DCYë"q"*  $@7t0Maep"Z*NQqJH]"ՍНֽ?Zgsj}g0DC 1I*墉$D~=/1_Mrig,YahWwS +:*GdJ S Zv̙3٘T;O+q2nqrdа#$, )eh4)F!eceJ̓SYEƪRVRj|6$b V+Klx2u\\ƫZժX2V$k8R&UVd٥*V'jY]:/7Gh%FjXUJUI4{hRje)ZK+kѩ2UZnM!I#Wۢ{jY|Zi~-vUSZL[XvJb*ZU?a㕪DF+-!ߨHX~Ǔ&O:3fc0l  ǖa˱HlcX6 Ŧb b, fa.l(抑0†cn;69` L9`Q/A𫣿c#>I$/"~ 1pl4gP7N S r \.A'ȹ|~΍/ FCCެ:^7XZQ/MeLf<ب:gW(\DP?:&.F) +EpK n o߄aL?7v̌GR$)˰fKU&} cMz.w[^n6-K[/|@ $JK0\k7R/nW9,Hp(8ٴdyXgVŞ766 x?Vtf"e8Ύ͹`'۸0^tL/tWJa C=Ύ}^a,My*r7TGW8yvQ P.!OF6G@w7Ӌ!<ww?|nק7F>7T0D#'x °[kkMLm*0:öʵ5s!f:aW1i%x.!gXaЧzw\ <+P;޳5߇ Bet4KLye;95<2s|57/NWZ Vq$! # X6F]&vӜH ΡoB]mI*q81)B5BSC۶ T`i-̦R"&/\1 j[ic╦>xo 9Eg81̄t pi{bƽ0ŞH;oxO4P7ύu~C~LEZqRlG!/!C͇Z D.._@ # ~qrH?'('˶QH@[@zZ&C%6hQP˛oV^F#N=)*:F%z',ZAZo&+ENGv WlV~US/ΜC73yB,,ۯA89@LܻdJ +*ή2 SfgaWi8ٽZ:*[P{Vp3! Y&7n`p#=yB_͉}<$d0wǞY2x_jPV/tqJs_-9dÕcuF e;mD ~C"F#f~uɫtҹM{@4)Sk-, ލDpCBuu2h۝Q7ȴ)fwYL{gwm9 (i*.8c=֘P+lSEeE0:] -Ǣ\uΤ7*J-88Z˧[ &q SaJZnT>tfO}}ItէZ_S$hajH$<%E#yuR}™F5O sssPIg,(+/cOu{v2ussq pTʹW *g28:ER Qo2TѻZk[aQ)3AK$~WNT:^G+bGTA~A~>j"Bxk R:9=#Qo.+,a֟W,VISd]zjD|q觳LZ:P :^Yy$:y yO70xgN;ç0,Ю 'ؿ[ q!qq)qn 8DnN | 9vaY7O9m>.gs=#^J-뒙 /_B8=\!GW1/pRS`q8ˉa>Ryy;ݨg;P5f--+Fhł+ً6" O ׁO'͋CDRNv;zbw#"^ i"͈sZ$WswNsb>?I zLy[rжYFT\.Ǜ=%)jNJjN69e(87wVOkį~&MnGendstream endobj 58 0 obj << /Type /XRef /Length 106 /Filter /FlateDecode /DecodeParms << /Columns 4 /Predictor 12 >> /W [ 1 2 1 ] /Info 3 0 R /Root 2 0 R /Size 59 /ID [<4db4c20197336001e122435b3a52656b>] >> stream x̭ PH? N5;P$cT Ky|s (X~"=݌ Q5/iވ6Z ޏ&  endstream endobj startxref 35548 %%EOF Rmpfr/inst/doc/Rmpfr-pkg.R0000644000176200001440000002650515075721230015064 0ustar liggesusers### R code from vignette source 'Rmpfr-pkg.Rnw' ################################################### ### code chunk number 1: preliminaries ################################################### options(SweaveHooks= list(fig=function() par(mar=c(5.1, 4.1, 1.1, 2.1))), width = 75, digits = 7, # <-- here, keep R's default! prompt = "R> ", continue=" ") Sys.setenv(LANGUAGE = "en") if(.Platform$OS.type != "windows") Sys.setlocale("LC_MESSAGES","C") ################################################### ### code chunk number 2: diagnose-lib ################################################### if(nzchar(Sys.getenv("R_MM_PKG_CHECKING"))) print( .libPaths() ) stopifnot(require("sfsmisc")) ################################################### ### code chunk number 3: exp-1 ################################################### exp(1) ################################################### ### code chunk number 4: exp-1-dig-17 ################################################### print(exp(1), digits = 17) ################################################### ### code chunk number 5: exp-1-mp ################################################### require("Rmpfr") # after having installed the package ... (one <- mpfr(1, 120)) exp(one) ################################################### ### code chunk number 6: factorial-1 ################################################### ns <- 1:24 ; factorial(ns) ################################################### ### code chunk number 7: factorial-full ################################################### noquote(sprintf("%-30.0f", factorial(24))) ################################################### ### code chunk number 8: factorial-mpfr ################################################### ns <- mpfr(1:24, 120) ; factorial(ns) ################################################### ### code chunk number 9: chooseM-ex-fake (eval = FALSE) ################################################### ## chooseMpfr.all(n = 80) ################################################### ### code chunk number 10: chooseM-run ################################################### capture.and.write(# <- in package 'sfsmisc': ~/R/Pkgs/sfsmisc/R/misc-goodies.R chooseMpfr.all(n = 80) , 5, 2, middle = 4, i.middle = 13) ################################################### ### code chunk number 11: ex1 ################################################### (0:7) / 7 # k/7, for k= 0..7 printed with R's default precision options(digits= 16) (0:7) / 7 # in full double precision accuracy options(digits= 7) # back to default str(.Machine[c("double.digits","double.eps", "double.neg.eps")], digits=10) 2^-(52:53) ################################################### ### code chunk number 12: n-digs ################################################### 53 * log10(2) ################################################### ### code chunk number 13: ex1 ################################################### x <- mpfr(0:7, 80)/7 # using 80 bits precision x 7*x 7*x - 0:7 ################################################### ### code chunk number 14: Const-names ################################################### formals(Const)$name ################################################### ### code chunk number 15: Const-ex ################################################### Const("pi") Const("log2") ################################################### ### code chunk number 16: pi-1000 ################################################### system.time(Pi <- Const("pi", 1000 *log2(10))) Pi ################################################### ### code chunk number 17: pi-fn-Gauss-HB ################################################### piMpfr <- function(prec=256, itermax = 100, verbose=TRUE) { m2 <- mpfr(2, prec) # '2' as mpfr number ## -> all derived numbers are mpfr (with precision 'prec') p <- m2 + sqrt(m2) # 2 + sqrt(2) = 3.414.. y <- sqrt(sqrt(m2)) # 2^ {1/4} x <- (y+1/y) / m2 it <- 0L repeat { p.old <- p it <- it+1L p <- p * (1+x) / (1+y) if(verbose) cat(sprintf("it=%2d, pi^ = %s, |.-.|/|.|=%e\n", it, formatMpfr(p, min(50, prec/log2(10))), 1-p.old/p)) if (abs(p-p.old) <= m2^(-prec)) break if(it > itermax) { warning("not converged in", it, "iterations") ; break } ## else s <- sqrt(x) y <- (y*s + 1/s) / (1+y) x <- (s+1/s)/2 } p } piMpfr()# indeed converges *quadratically* fast ## with relative error relErr <- 1 - piMpfr(256, verbose=FALSE) / Const("pi",260) ## in bits : asNumeric(-log2(abs(relErr))) ################################################### ### code chunk number 18: Math2-def ################################################### getGroupMembers("Math2") showMethods("Math2", classes=c("mpfr", "mpfrArray")) ################################################### ### code chunk number 19: round-ex ################################################### i7 <- 1/mpfr(700, 100) c(i7, round(i7, digits = 6), signif(i7, digits = 6)) ################################################### ### code chunk number 20: roundMpfr-ex ################################################### roundMpfr(i7, precBits = 30) roundMpfr(i7, precBits = 15) ################################################### ### code chunk number 21: asNumeric-meth ################################################### showMethods(asNumeric) ################################################### ### code chunk number 22: format-ex ################################################### cbind( sapply(1:7, function(d) format(i7, digits=d)) ) ################################################### ### code chunk number 23: format-lrg ################################################### x <- mpfr(2, 80) ^ ((1:4)*10000) cbind(x) # -> show() -> print.mpfr() -> formatMpfr(.. , digits = NULL, maybe.full = FALSE) nchar(formatMpfr(x)) nchar(formatMpfr(x, maybe.full = TRUE)) ################################################### ### code chunk number 24: Math-group ################################################### getGroupMembers("Math") ################################################### ### code chunk number 25: Matrix-ex ################################################### head(x <- mpfr(0:7, 64)/7) ; mx <- x dim(mx) <- c(4,2) ################################################### ### code chunk number 26: mpfrArr-ex ################################################### dim(aa <- mpfrArray(1:24, precBits = 80, dim = 2:4)) ################################################### ### code chunk number 27: pr-mpfrArr-fake (eval = FALSE) ################################################### ## aa ################################################### ### code chunk number 28: pr-mpfrArr-do ################################################### capture.and.write(aa, 11, 4) ################################################### ### code chunk number 29: crossprod ################################################### mx[ 1:3, ] + c(1,10,100) crossprod(mx) ################################################### ### code chunk number 30: apply-mat ################################################### apply(7 * mx, 2, sum) ################################################### ### code chunk number 31: Ei-curve ################################################### getOption("SweaveHooks")[["fig"]]() curve(Ei, 0, 5, n=2001); abline(h=0,v=0, lty=3) ################################################### ### code chunk number 32: Li2-1 ################################################### if(mpfrVersion() >= "2.4.0") ## Li2() is not available in older MPFR versions all.equal(Li2(1), Const("pi", 128)^2/6, tol = 1e-30) ################################################### ### code chunk number 33: Li2-curve ################################################### getOption("SweaveHooks")[["fig"]]() if(mpfrVersion() >= "2.4.0") curve(Li2, -2, 13, n=2000); abline(h=0,v=0, lty=3) ################################################### ### code chunk number 34: erf-curves ################################################### getOption("SweaveHooks")[["fig"]]() curve(erf, -3,3, col = "red", ylim = c(-1,2)) curve(erfc, add = TRUE, col = "blue") abline(h=0, v=0, lty=3); abline(v=c(-1,1), lty=3, lwd=.8, col="gray") legend(-3,1, c("erf(x)", "erfc(x)"), col = c("red","blue"), lty=1) ################################################### ### code chunk number 35: integrateR-dnorm ################################################### integrateR(dnorm,0,2000) integrateR(dnorm,0,2000, rel.tol=1e-15) integrateR(dnorm,0,2000, rel.tol=1e-15, verbose=TRUE) ################################################### ### code chunk number 36: integ-exp-double ################################################### (Ie.d <- integrateR(exp, 0 , 1, rel.tol=1e-15, verbose=TRUE)) ################################################### ### code chunk number 37: integ-exp-mpfr ################################################### (Ie.m <- integrateR(exp, mpfr(0,200), 1, rel.tol=1e-25, verbose=TRUE)) (I.true <- exp(mpfr(1, 200)) - 1) ## with absolute errors as.numeric(c(I.true - Ie.d$value, I.true - Ie.m$value)) ################################################### ### code chunk number 38: integ-poly-double ################################################### if(require("polynom")) { x <- polynomial(0:1) p <- (x-2)^4 - 3*(x-3)^2 Fp <- as.function(p) print(pI <- integral(p)) # formally print(Itrue <- predict(pI, 5) - predict(pI, 0)) ## == 20 } else { Fp <- function(x) (x-2)^4 - 3*(x-3)^2 Itrue <- 20 } (Id <- integrateR(Fp, 0, 5)) (Im <- integrateR(Fp, 0, mpfr(5, 256), rel.tol = 1e-70, verbose=TRUE)) ## and the numerical errors, are indeed of the expected size: 256 * log10(2) # - expect ~ 77 digit accuracy for mpfr(*., 256) as.numeric(Itrue - c(Im$value, Id$value)) ################################################### ### code chunk number 39: pnorm-extr ################################################### pnorm(-1234, log.p=TRUE) ################################################### ### code chunk number 40: pnorm-extr ################################################### (p123 <- Rmpfr::pnorm(mpfr(-123, 66), log.p=TRUE)) # is based on (ec123 <- erfc(123 * sqrt(mpfr(0.5, 66+4))) / 2) # 1.95....e-3288 (p333 <- Rmpfr::pnorm(mpfr(-333, 66), log.p=TRUE)) exp(p333) stopifnot(p123 == log(roundMpfr(ec123, 66)), ## '==' as we implemented our pnorm() all.equal(p333, -55451.22709, tol=1e-8)) ################################################### ### code chunk number 41: mpfr-erange ################################################### (old_erng <- .mpfr_erange() ) ################################################### ### code chunk number 42: double-erange ################################################### unlist( .Machine[c("double.min.exp", "double.max.exp")] ) ################################################### ### code chunk number 43: really-min ################################################### 2^(-1022 - 52) ################################################### ### code chunk number 44: mpfr-all-eranges ################################################### .mpfr_erange(.mpfr_erange_kinds) ## and then set # use very slightly smaller than extreme values: (myERng <- (1-2^-52) * .mpfr_erange(c("min.emin","max.emax"))) .mpfr_erange_set(value = myERng) # and to see what happened: .mpfr_erange() ################################################### ### code chunk number 45: GMP-numbs ################################################### .mpfr_gmp_numbbits() Rmpfr/inst/doc/log1mexp-note.R0000644000176200001440000003075615075721237015730 0ustar liggesusers### R code from vignette source 'log1mexp-note.Rnw' ################################################### ### code chunk number 1: preliminaries ################################################### ## Our custom graphics device: pdfaCrop <- function(name, width, height, ...) { fn <- paste(name, "pdf", sep = ".") if(FALSE)## debug cat("pdfaCrop: fn = ",fn,"; call:\n\t",deparse(match.call()),"\n") grDevices::pdf(fn, width = width, height = height, onefile=FALSE)# ...) assign(".pdfaCrop.name", fn, envir = globalenv()) } ## This is used automagically : pdfaCrop.off <- function() { dev.off()# for the pdf f <- get(".pdfaCrop.name", envir = globalenv()) ## and now crop that file: pdfcrop <- "pdfcrop" # relying on PATH - fix if needed pdftex <- "pdftex" # relying on PATH - fix if needed system(paste(pdfcrop, "--pdftexcmd", pdftex, f, f, "1>/dev/null 2>&1"), intern=FALSE) } op.orig <- options(width = 75, SweaveHooks= list(fig=function() par(mar=c(5.1, 4.1, 1.1, 2.1))), digits = 5, useFancyQuotes = "TeX", ## for JSS, but otherwise MM does not like it: ## prompt="R> ", continue=" ")# 2 (or 3) blanks: use same length as 'prompt' if((p <- "package:fortunes") %in% search()) try(detach(p, unload=TRUE, char=TRUE)) Sys.setenv(LANGUAGE = "en") if(.Platform$OS.type != "windows") Sys.setlocale("LC_MESSAGES","C") if(getRversion() < "2.15") paste0 <- function(...) paste(..., sep = '') library("sfsmisc")# e.g., for eaxis() library("Rmpfr") .plot.BC <- FALSE # no Box-Cox plot ################################################### ### code chunk number 2: def-t3 ################################################### library(Rmpfr) t3.l1e <- function(a) { c(def = log(1 - exp(-a)), expm1 = log( -expm1(-a)), log1p = log1p(-exp(-a))) } ################################################### ### code chunk number 3: def-leg ################################################### leg <- local({ r <- body(t3.l1e)[[2]]; r[[1]] <- `expression`; eval(r) }) ## will be used below ################################################### ### code chunk number 4: def-test-2 (eval = FALSE) ################################################### ## ##' The relative Error of log1mexp computations: ## relE.l1e <- function(a, precBits = 1024) { ## stopifnot(is.numeric(a), length(a) == 1, precBits > 50) ## da <- t3.l1e(a) ## double precision ## a. <- mpfr(a, precBits=precBits) ## ## high precision *and* using the correct case: ## mMa <- if(a <= log(2)) log(-expm1(-a.)) else log1p(-exp(-a.)) ## structure(as.numeric(1 - da/mMa), names = names(da)) ## } ################################################### ### code chunk number 5: def-test-funs ################################################### library(Rmpfr) t3.l1e <- function(a) { c(def = log(1 - exp(-a)), expm1 = log( -expm1(-a)), log1p = log1p(-exp(-a))) } ##' The relative Error of log1mexp computations: relE.l1e <- function(a, precBits = 1024) { stopifnot(is.numeric(a), length(a) == 1, precBits > 50) da <- t3.l1e(a) ## double precision a. <- mpfr(a, precBits=precBits) ## high precision *and* using the correct case: mMa <- if(a <= log(2)) log(-expm1(-a.)) else log1p(-exp(-a.)) structure(as.numeric(1 - da/mMa), names = names(da)) } ################################################### ### code chunk number 6: comp-big (eval = FALSE) ################################################### ## a.s <- 2^seq(-55, 10, length = 256) ## ra.s <- t(sapply(a.s, relE.l1e)) ################################################### ### code chunk number 7: bigpic-show (eval = FALSE) ################################################### ## a.s <- 2^seq(-55, 10, length = 256) ## ra.s <- t(sapply(a.s, relE.l1e)) ## cbind(a.s, ra.s) # comparison of the three approaches ################################################### ### code chunk number 8: bigpic-do ################################################### a.s <- 2^seq(-55, 10, length = 256) ra.s <- t(sapply(a.s, relE.l1e)) capture.and.write(cbind(a.s, ra.s), 8, last = 6) ################################################### ### code chunk number 9: drop-large-a ################################################### ii <- a.s < 710 a.s <- a.s[ii] ra.s <- ra.s[ii, ] ################################################### ### code chunk number 10: a.small ################################################### t3.l1e(1e-20) as.numeric(t3.l1e(mpfr(1e-20, 256))) ################################################### ### code chunk number 11: bigpict-setup (eval = FALSE) ################################################### ## par(mar = c(4.1,4.1,0.6,1.6)) ## cc <- adjustcolor(c(4,1,2),.8, red.f=.7) ## lt <- c("solid","33","3262") ## ll <- c(.7, 1.5, 2) ################################################### ### code chunk number 12: bigpict-def (eval = FALSE) ################################################### ## matplot(a.s, abs(ra.s), type = "l", log = "xy", ## col=cc, lty=lt, lwd=ll, xlab = "a", ylab = "", axes=FALSE) ## legend("top", leg, col=cc, lty=lt, lwd=ll, bty="n") ## draw.machEps <- function(alpha.f = 1/3, col = adjustcolor("black", alpha.f)) { ## abline(h = .Machine$double.eps, col=col, lty=3) ## axis(4, at=.Machine$double.eps, label=quote(epsilon[c]), las=1, col.axis=col) ## } ## eaxis(1); eaxis(2); draw.machEps(0.4) ################################################### ### code chunk number 13: zoomin-comp ################################################### a. <- (1:400)/256 ra <- t(sapply(a., relE.l1e)) ra2 <- ra[,-1] ################################################### ### code chunk number 14: bigpict-fig ################################################### getOption("SweaveHooks")[["fig"]]() par(mar = c(4.1,4.1,0.6,1.6)) cc <- adjustcolor(c(4,1,2),.8, red.f=.7) lt <- c("solid","33","3262") ll <- c(.7, 1.5, 2) matplot(a.s, abs(ra.s), type = "l", log = "xy", col=cc, lty=lt, lwd=ll, xlab = "a", ylab = "", axes=FALSE) legend("top", leg, col=cc, lty=lt, lwd=ll, bty="n") draw.machEps <- function(alpha.f = 1/3, col = adjustcolor("black", alpha.f)) { abline(h = .Machine$double.eps, col=col, lty=3) axis(4, at=.Machine$double.eps, label=quote(epsilon[c]), las=1, col.axis=col) } eaxis(1); eaxis(2); draw.machEps(0.4) ## draw the zoom-in region into the plot: yl <- range(pmax(1e-18, abs(ra2))) rect(min(a.), yl[1], max(a.), yl[2], col= adjustcolor("black", .05), border="gray", pch = 5) ################################################### ### code chunk number 15: zoomin-show (eval = FALSE) ################################################### ## a. <- (1:400)/256 ## ra <- t(sapply(a., relE.l1e)) ## ra2 <- ra[,-1] ################################################### ### code chunk number 16: boxcox ################################################### da <- cbind(a = a., as.data.frame(ra2)) library(MASS) bc1 <- boxcox(abs(expm1) ~ a, data = da, lambda = seq(0,1, by=.01), plotit=.plot.BC) bc2 <- boxcox(abs(log1p) ~ a, data = da, lambda = seq(0,1, by=.01), plotit=.plot.BC) c(with(bc1, x[which.max(y)]), with(bc2, x[which.max(y)]))## optimal powers ## ==> taking ^ (1/3) : s1 <- with(da, smooth.spline(a, abs(expm1)^(1/3), df = 9)) s2 <- with(da, smooth.spline(a, abs(log1p)^(1/3), df = 9)) ################################################### ### code chunk number 17: zoom-in-def-1 (eval = FALSE) ################################################### ## matplot(a., abs(ra2), type = "l", log = "y", # ylim = c(-1,1)*1e-12, ## col=cc[-1], lwd=ll[-1], lty=lt[-1], ## ylim = yl, xlab = "a", ylab = "", axes=FALSE) ## legend("topright", leg[-1], col=cc[-1], lwd=ll[-1], lty=lt[-1], bty="n") ## eaxis(1); eaxis(2); draw.machEps() ## lines(a., predict(s1)$y ^ 3, col=cc[2], lwd=2) ## lines(a., predict(s2)$y ^ 3, col=cc[3], lwd=2) ################################################### ### code chunk number 18: zoom-in-fig ################################################### getOption("SweaveHooks")[["fig"]]() cl2 <- adjustcolor("slateblue", 1/2)# (adj: lwd=3) # the color for "log(2)" par(mar = c(4.1,4.1,0.6,1.6)) matplot(a., abs(ra2), type = "l", log = "y", # ylim = c(-1,1)*1e-12, col=cc[-1], lwd=ll[-1], lty=lt[-1], ylim = yl, xlab = "a", ylab = "", axes=FALSE) legend("topright", leg[-1], col=cc[-1], lwd=ll[-1], lty=lt[-1], bty="n") eaxis(1); eaxis(2); draw.machEps() lines(a., predict(s1)$y ^ 3, col=cc[2], lwd=2) lines(a., predict(s2)$y ^ 3, col=cc[3], lwd=2) abline(v = log(2), col=cl2, lty="9273", lwd=2.5) cl2. <- adjustcolor(cl2, 2) axis(1, at=log(2), label=quote(a[0] == log~2), las=1, col.axis=cl2.,col=cl2, lty="9273", lwd=2.5) ## what system is it ? sysInf <- Sys.info()[c("sysname", "release", "nodename", "machine")] mtext(with(as.list(sysInf), paste0(sysname," ",release,"(",substr(nodename,1,16),") -- ", machine)), side=1, adj=1, line=2.25, cex = 3/4) ################################################### ### code chunk number 19: uniroot-x1 ################################################### ## Find x0, such that exp(x) =.= g(x) for x < x0 : f0 <- function(x) { x <- exp(x) - log1p(exp(x)) x[x==0] <- -1 ; x } u0 <- uniroot(f0, c(-100, 0), tol=1e-13) str(u0, digits=10) x0 <- u0[["root"]] ## -36.39022698 --- note that ~= \log(\eps_C) all.equal(x0, -52.5 * log(2), tol=1e-13) ## Find x1, such that x + exp(-x) =.= g(x) for x > x1 : f1 <- function(x) { x <- (x + exp(-x)) - log1p(exp(x)) x[x==0] <- -1 ; x } u1 <- uniroot(f1, c(1, 20), tol=1e-13) str(u1, digits=10) x1 <- u1[["root"]] ## 16.408226 ## Find x2, such that x =.= g(x) for x > x2 : f2 <- function(x) { x <- log1p(exp(x)) - x ; x[x==0] <- -1 ; x } u2 <- uniroot(f2, c(5, 50), tol=1e-13) str(u2, digits=10) x2 <- u2[["root"]] ## 33.27835 ################################################### ### code chunk number 20: log1pexp-plot ################################################### getOption("SweaveHooks")[["fig"]]() par(mfcol= 1:2, mar = c(4.1,4.1,0.6,1.6), mgp = c(1.6, 0.75, 0)) curve(x+exp(-x) - log1p(exp(x)), 15, 25, n=2^11); abline(v=x1, lty=3) curve(log1p(exp(x)) - x, 33.1, 33.5, n=2^10); abline(v=x2, lty=3) ################################################### ### code chunk number 21: def-test-pfuns ################################################### t4p.l1e <- function(x) { c(def = log(1 + exp(x)), log1p = log1p(exp(x)), ## xlog1p = x + log1p(exp(-x)), xpexp = x + exp(-x), x = x) } leg <- local({ r <- body(t4p.l1e)[[2]]; r[[1]] <- `expression`; eval(r) }) ##' The relative Error of log1pexp computations: relE.pl1e <- function(x, precBits = 1024) { stopifnot(is.numeric(x), length(x) == 1, precBits > 50) dx <- t4p.l1e(x) ## double precision x. <- mpfr(x, precBits=precBits) ## high precision *and* using the correct case: mMx <- if(x < 0) log1p(exp(x.)) else x. + log1p(exp(-x.)) structure(as.numeric(1 - dx/mMx), names = names(dx)) } ################################################### ### code chunk number 22: comp-big ################################################### x.s <- seq(-100, 750, by = 5) # <- the big picture ==> problem for default x.s <- seq( 5, 60, length=512) # <- the zoom in ==> *no* problem for def. rx.s <- t(sapply(x.s, relE.pl1e)) signif(cbind(x.s, rx.s),3) ################################################### ### code chunk number 23: bigpict-2-fig ################################################### getOption("SweaveHooks")[["fig"]]() par(mar = c(4.1,4.1,0.6,1.6), mgp = c(1.6, 0.75, 0)) cc <- adjustcolor(c(4,1,2,3),.8, red.f=.7, blue.f=.8) lt <- c("solid","33","3262","dotdash") ll <- c(.7, 1.5, 2, 2) ym <- 1e-18 yM <- 1e-13 matplot(x.s, pmax(pmin(abs(rx.s),yM),ym), type = "l", log = "y", axes=FALSE, ylim = c(ym,yM), col=cc, lty=lt, lwd=ll, xlab = "x", ylab = "") legend("topright", leg, col=cc, lty=lt, lwd=ll, bty="n") eaxis(1, at=pretty(range(x.s), n =12)); eaxis(2) draw.machEps(0.4) x12 <- c(18, 33.3) abline(v=x12, col=(ct <- adjustcolor("brown", 0.6)), lty=3) axis(1, at=x12, labels=formatC(x12), padj = -3.2, hadj = -.1, tcl = +.8, col=ct, col.axis=ct, col.ticks=ct) ################################################### ### code chunk number 24: exp-overflow ################################################### (eMax <- .Machine$double.max.exp * log(2)) exp(eMax * c(1, 1+1e-15)) ################################################### ### code chunk number 25: sessionInfo ################################################### toLatex(sessionInfo(), locale=FALSE) ################################################### ### code chunk number 26: finalizing ################################################### options(op.orig) Rmpfr/inst/doc/Maechler_useR_2011-abstr.Rnw0000644000176200001440000001227112174274363020060 0ustar liggesusers\documentclass[11pt, a4paper]{article} \usepackage{amsfonts, amsmath, hanging, hyperref, natbib, parskip, times} \usepackage[pdftex]{graphicx} \hypersetup{ colorlinks, linkcolor=blue, urlcolor=blue } \SweaveOpts{eps=FALSE,pdf=TRUE,width=7,height=4,strip.white=true,keep.source=TRUE} %\VignetteIndexEntry{useR-2011-abstract} %\VignetteDepends{Rmpfr} <>= options(SweaveHooks= list(fig=function() par(mar=c(5.1, 4.1, 1.1, 2.1))), width = 75) Sys.setenv(LANGUAGE = "en") if(.Platform$OS.type != "windows") Sys.setlocale("LC_MESSAGES","C") stopifnot(require("Rmpfr")) @ \let\section=\subsubsection \newcommand{\pkg}[1]{{\normalfont\fontseries{b}\selectfont #1}} \let\proglang=\textit \let\code=\texttt \renewcommand{\title}[1]{\begin{center}{\bf \LARGE #1}\end{center}} \newcommand{\affiliations}{\footnotesize} \newcommand{\keywords}{\paragraph{Keywords:}} \setlength{\topmargin}{-15mm} \setlength{\oddsidemargin}{-2mm} \setlength{\textwidth}{165mm} \setlength{\textheight}{250mm} \usepackage{Sweave} \DefineVerbatimEnvironment{Sinput}{Verbatim}{fontsize=\small,fontshape=sl} \DefineVerbatimEnvironment{Soutput}{Verbatim}{fontsize=\small} \DefineVerbatimEnvironment{Scode}{Verbatim}{fontsize=\small,fontshape=sl} % but when submitting, do get rid of too much vertical space between R % input & output, i.e. between Sinput and Soutput: \fvset{listparameters={\setlength{\topsep}{0pt}}}% !! quite an effect! %% % \newcommand*{\R}{\proglang{R}}%{\textsf{R}} \begin{document} \pagestyle{empty} \vspace*{-15ex} \begin{flushleft}\footnotesize Corrected abstract for ``late-breaking poster'' and ``Lightning talk'' to be held at ``UseR! 2011'', U.~Warwick, 16th Aug.~2011%, 17:00--18:00 \\[-1ex]\noindent\rule{\textwidth}{0.5pt}\\ % horizontal line \end{flushleft} \vspace*{+9ex} \title{Arbitrarily Accurate Computation with R: Package 'Rmpfr'} \begin{center} {\bf Martin M\"achler$^{1,2,^\star}$} \end{center} \begin{affiliations} 1. ETH Zurich (Seminar for Statistics), Switzerland \\[-2pt] 2. R Core Development Team \\[-2pt] $^\star$Contact author: \href{mailto:maechler@stat.math.ethz.ch}{maechler@stat.math.ethz.ch} \end{affiliations} \keywords Arbitrary Precision, High Accuracy, Multiple Precision Floating-Point, Rmpfr \vskip 0.8cm % Some suggestions: if you mention a programming language like % \proglang{R}, typeset the language name with the {\tt \textbackslash % proglang\{\}} command. If you mention an \proglang{R} function \code{foo}, % typeset the function name with the with the {\tt\textbackslash code\{\}} % command. If you mention an \proglang{R} package \pkg{fooPkg}, typeset % the package name with the {\tt\textbackslash pkg\{\}} command. % Abstracts should not exceed one page. The page should not be numbered. The \proglang{R}\ package \pkg{Rmpfr} allows to use arbitrarily precise numbers instead of \proglang{R}'s double precision numbers in many \proglang{R}\ computations and functions. This is achieved by defining S4 classes of such numbers and vectors, matrices, and arrays thereof, where all arithmetic and mathematical functions work via the (GNU) MPFR C library, where MPFR is acronym for ``\emph{\textbf{M}ultiple \textbf{P}recision \textbf{F}loating-Point \textbf{R}eliably}''\nocite{FousseHLPZ:2007}. MPFR is Free Software, available under the LGPL license\nocite{FousseHLPZ-MPFR:2011}, and itself is built on the free GNU Multiple Precision arithmetic library (GMP)\nocite{GMP:2011}. Consequently, by using \pkg{Rmpfr}, you can often call your \proglang{R}\ function or numerical code with mpfr--numbers instead of simple numbers, and all results will automatically be much more accurate. <>= options(digits = 17)# to print to full "standard R" precision .N <- function(.) mpfr(., precBits = 200) exp( 1 ) exp(.N(1)) <>= choose ( 200, 99:100 ) chooseMpfr( 200, 99:100 ) @ %% Applications by the package author include testing of Bessel or polylog functions and distribution computations, e.g. for stable distributions. %% In addition, the \pkg{Rmpfr} has been used on the \code{R-help} or \code{R-devel} mailing list for high-accuracy computations, e.g., in comparison with results from commercial software such as Maple, and in private communications with Petr Savicky about fixing \proglang{R} bug \href{https://bugs.R-project.org/bugzilla3/show_bug.cgi?id=14491}{\code{PR\#14491}}. We expect the package to be used in more situations for easy comparison studies about the accuracy of algorithms implemented in \proglang{R}, both for ``standard \proglang{R}'' and extension packages. %% references: \nocite{% MM-Rmpfr_pkg} %\bibliographystyle{chicago}%% how on earth do I get the URLs ??/ \bibliographystyle{jss}%% how on earth do I get the URLs ??/ \bibliography{Rmpfr} %% references can alternatively be entered by hand %\subsubsection*{References} %\begin{hangparas}{.25in}{1} %AuthorA (2007). Title of a web resource, \url{http://url/of/resource/}. %AuthorC (2008a). Article example in proceedings. In \textit{useR! 2008, The R %User Conference, (Dortmund, Germany)}, pp. 31--37. %AuthorC (2008b). Title of an article. \textit{Journal name 6}, 13--17. %\end{hangparas} \end{document} Rmpfr/inst/doc/Rmpfr-pkg.Rnw0000644000176200001440000006526114361031754015435 0ustar liggesusers%\documentclass[article]{jss} \documentclass[nojss,article]{jss} % ----- for the package-vignette, don't use JSS logo, etc % %__FIXME: use ..\index{} for a good "reference index" about the things we show! % \author{Martin M\"achler \\ ETH Zurich} \title{Arbitrarily Accurate Computation with \R: \\ The \pkg{Rmpfr} Package} % \def\mythanks{a version of this paper, for \pkg{nacopula} 0.4\_4, has been published % in JSS, \url{http://www.jstatsoft.org/v39/i09}.} %% for pretty printing and a nice hypersummary also set: \Plainauthor{Martin M\"achler} %% comma-separated \Plaintitle{Arbitrarily Accurate Computation with R---The Rmpfr Package} % \Shorttitle{} % % The index entry makes it into build/vignette.rds : %\VignetteIndexEntry{Arbitrarily Accurate Computation with R Package Rmpfr} %\VignetteDepends{Rmpfr} %\VignetteDepends{gmp} %\VignetteDepends{Bessel} \SweaveOpts{engine=R,eps=FALSE,pdf=TRUE,width=7,height=4,strip.white=true,keep.source=TRUE} %% an abstract and keywords \Abstract{ The \R\ package \pkg{Rmpfr} allows to use arbitrarily precise numbers instead of \R's double precision numbers in many \R\ computations and functions. %% This is achieved by defining S4 classes of such numbers and vectors, matrices, and arrays thereof, where all arithmetic and mathematical functions work via the (GNU) MPFR C library, where MPFR is acronym for ``\emph{\textbf{M}ultiple \textbf{P}recision \textbf{F}loating-Point \textbf{R}eliably}''. MPFR is Free Software, available under the LGPL license, and itself is built on the free GNU Multiple Precision arithmetic library (GMP). Consequently, by using \pkg{Rmpfr}, you can often call your \R\ function or numerical code with mpfr--numbers instead of simple numbers, and all results will automatically be much more accurate. %% see subsection{Applications} further below: Applications by the package author include testing of Bessel or polylog functions and distribution computations, e.g. for ($\alpha$-)stable distributions and Archimedean Copulas. %% In addition, the \pkg{Rmpfr} has been used on the \code{R-help} or \code{R-devel} mailing list for high-accuracy computations, e.g., in comparison with results from other software, and also in improving existing \R\ functionality, e.g., fixing \R\ bug \href{https://bugs.R-project.org/bugzilla3/show_bug.cgi?id=14491}{\code{PR\#14491}}. } \Keywords{MPFR, Abitrary Precision, Multiple Precision Floating-Point, R} %% at least one keyword must be supplied %% publication information %% NOTE: Typically, this can be left commented and will be filled out by the technical editor %% \Volume{13} %% \Issue{9} %% \Month{September} %% \Year{2004} %% \Submitdate{2004-09-29} %% \Acceptdate{2004-09-29} %% The address of (at least) one author should be given %% in the following format: \Address{ Martin M\"achler\\ Seminar f\"ur Statistik, HG G~16\\ ETH Zurich\\ 8092 Zurich, Switzerland\\ E-mail: \email{maechler@stat.math.ethz.ch}\\ URL: \url{http://stat.ethz.ch/people/maechler} } %% It is also possible to add a telephone and fax number %% before the e-mail in the following format: %% Telephone: +43/1/31336-5053 %% Fax: +43/1/31336-734 %% for those who use Sweave please include the following line (with % symbols): %% MM: this is "substituted" by jss.cls: %% need no \usepackage{Sweave.sty} %% Marius' packages \usepackage[american]{babel}%for American English % \usepackage{microtype}%for character protrusion and font expansion (only with pdflatex) \usepackage{amsmath}%sophisticated mathematical formulas with amstex (includes \text{}) \usepackage{mathtools}%fix amsmath deficiencies \usepackage{amssymb}%sophisticated mathematical symbols with amstex (includes \mathbb{}) % \usepackage{amsthm}%theorem environments % \usepackage{bm}%for bold math symbols: \bm (= bold math) % %NON-STANDARD:\RequirePackage{bbm}%only for indicator functions % \usepackage{enumitem}%for automatic numbering of new enumerate environments % \usepackage[ % format=hang, % % NOT for JSS: labelsep=space, % justification=justified, % singlelinecheck=false%, % % NOT for JSS: labelfont=bf % ]{caption}%for captions % \usepackage{tikz}%sophisticated graphics package % \usepackage{tabularx}%for special table environment (tabularx-table) % \usepackage{booktabs}%for table layout % This is already in jss above -- but withOUT the fontsize=\small part !! \DefineVerbatimEnvironment{Sinput}{Verbatim}{fontsize=\small,fontshape=sl} \DefineVerbatimEnvironment{Soutput}{Verbatim}{fontsize=\small} \DefineVerbatimEnvironment{Scode}{Verbatim}{fontsize=\small,fontshape=sl} % but when submitting, do get rid of too much vertical space between R % input & output, i.e. between Sinput and Soutput: \fvset{listparameters={\setlength{\topsep}{0pt}}}% !! quite an effect! %% % \newcommand*{\R}{\proglang{R}}%{\textsf{R}} \newcommand*{\Arg}[1]{\texttt{\itshape $\langle$#1$\rangle$}} \newcommand*{\eps}{\varepsilon} \newcommand*{\CRANpkg}[1]{\href{http://CRAN.R-project.org/package=#1}{\pkg{#1}}} %% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{document} %% include your article here, just as usual %% Note that you should use the \pkg{}, \proglang{} and \code{} commands. % \section[About Java]{About \proglang{Java}} %% Note: If there is markup in \(sub)section, then it has to be escape as above. %% Note: These are explained in '?RweaveLatex' : <>= options(SweaveHooks= list(fig=function() par(mar=c(5.1, 4.1, 1.1, 2.1))), width = 75, digits = 7, # <-- here, keep R's default! prompt = "R> ", continue=" ") Sys.setenv(LANGUAGE = "en") if(.Platform$OS.type != "windows") Sys.setlocale("LC_MESSAGES","C") <>= if(nzchar(Sys.getenv("R_MM_PKG_CHECKING"))) print( .libPaths() ) stopifnot(require("sfsmisc")) @ \section[Introduction]{Introduction}% \small~\footnote{\mythanks}} %% - Why did I want this in R : There are situations, notably in researching better numerical algorithms for non-trivial mathematical functions, say the $F$-distribution function, where it is interesting and very useful to be able to rerun computations in \R\ in (potentially much) higher precision. For example, if you are interested in Euler's $e$, the base of natural logarithms, and given, e.g., by $e^x = \exp(x)$, you will look into <>= exp(1) @ which typically uses 7 digits for printing, as \code{getOption("digits")} is 7. To see \R's internal accuracy fully, you can use <>= print(exp(1), digits = 17) @ With \pkg{Rmpfr} you can now simply use ``mpfr -- numbers'' and get more accurate results automatically, here using a \emph{vector} of numbers as is customary in \R: <>= require("Rmpfr") # after having installed the package ... (one <- mpfr(1, 120)) exp(one) @ In combinatorics, number theory or when computing series, you may occasionally want to work with \emph{exact} factorials or binomial coefficients, where e.g. you may need all factorials $k!$, for $k=1,2,\dots,24$ or a full row of Pascal's triangle, i.e., want all $\binom{n}{k}$ for $n=80$. With \R's double precision, and standard printing precision <>= ns <- 1:24 ; factorial(ns) @ the full precision of $24!$ is clearly not printed. However, if you display it with more than its full internal precision, <>= noquote(sprintf("%-30.0f", factorial(24))) @ it is obviously wrong in the last couple of digits as they are known to be \code{0}. However, you can easily get full precision results with \pkg{Rmpfr}, by replacing ``simple'' numbers by mpfr-numbers: <>= ns <- mpfr(1:24, 120) ; factorial(ns) @ Or for the 80-th Pascal triangle row, $\binom{n}{k}$ for $n=80$ and $k=1,\dots,n$, <>= chooseMpfr.all(n = 80) <>= capture.and.write(# <- in package 'sfsmisc': ~/R/Pkgs/sfsmisc/R/misc-goodies.R <> , 5, 2, middle = 4, i.middle = 13) @ %%% "FIXME:" drawback of the above is that it is *integer* arithmetic only ... \paragraph{S4 classes and methods:} % Why they are useful here: S4 allows ``multiple dispatch'' which means that the method that is called for a generic function may not just depend on the first argument of the function (as in S3 or in traditional class-based OOP), but on a \emph{``signature''} of multiple arguments. For example, \texttt{a + b} is the same as \code{`+`(a,b)}, i.e., calling a function with two arguments. ... \subsection{The engine behind: MPFR and GMP} The package \pkg{Rmpfr} interfaces \R\ to the C (GNU) library \begin{quote} MPFR, acronym for ``\emph{\textbf{M}ultiple \textbf{P}recision \textbf{F}loating-Point \textbf{R}eliably}'' \end{quote} MPFR is Free Software, available under the LGPL license, %\nocite{ see \url{http://mpfr.org/} and \cite{FouLHLPZ:2007} and the standard reference to MPFR, \cite{FousseHLPZ-MPFR:2011}. %% MPFR itself is built on and requires the GNU Multiple Precision arithmetic library (GMP), see \url{http://gmplib.org/} and \cite{GMP:2011}. It can be obtained from there, or from your operating system vendor. On some platforms, it is very simple, to install MPFR and GMP, something necessary before \pkg{Rmpfr} can be used. E.g., in Linux distributions Debian, Ubuntu and other Debian derivatives, it is sufficient (for \emph{both} libraries) to simply issue \begin{verbatim} sudo apt-get install libmpfr-dev \end{verbatim} \section{Arithmetic with mpfr-numbers} <>= (0:7) / 7 # k/7, for k= 0..7 printed with R's default precision options(digits= 16) (0:7) / 7 # in full double precision accuracy options(digits= 7) # back to default str(.Machine[c("double.digits","double.eps", "double.neg.eps")], digits=10) 2^-(52:53) @ In other words, the double precision numbers \R\ uses have a 53-bit mantissa, and the two ``computer epsilons'' are $2^{-52}$ and $2^{-53}$, respectively. Less technically, how many decimal digits can double precision numbers work with, $2^{-53} = 10^{-x} \Longleftrightarrow x = 53 \log_{10}(2)$, <>= 53 * log10(2) @ i.e., almost 16 digits. If we want to compute some arithmetic expression with higher precision, this can now easily be achieved, using the \pkg{Rmpfr} package, by defining ``\texttt{mpfr}--numbers'' and then work with these. Starting with simple examples, a more precise version of $k/7$, $k = 0,\dots, 7$ from above: <>= x <- mpfr(0:7, 80)/7 # using 80 bits precision x 7*x 7*x - 0:7 @ which here is even ``perfect'' -- but that's ``luck'' only, and also the case here for ``simple'' double precision numbers, at least on our current platform.\footnote{64-bit Linux, Fedora 13 on a ``AMD Phenom 925'' processor} \subsection[Mathematical Constants, Pi, gamma, ..]{% Mathematical Constants, Pi ($\pi$), gamma, etc} Our \pkg{Rmpfr} package also provides the mathematical constants which MPFR provides, via \code{Const(., \Arg{prec})}, currently the \Sexpr{length(eval(formals(Const)[["name"]]))} constants <>= formals(Const)$name @ are available, where \code{"gamma"} is for Euler's gamma, $\gamma := \lim_{n\to\infty} \sum_{k=1}^n \frac 1 k - \log(n) \approx 0.5777$, and \code{"catalan"} for Catalan's constant (see \url{http://en.wikipedia.org/wiki/Catalan\%27s_constant}). <>= Const("pi") Const("log2") @ where you may note a default precision of 120 digits, a bit more than quadruple precision, but also that 1000 digits of $\pi$ are available instantaneously, <>= system.time(Pi <- Const("pi", 1000 *log2(10))) Pi @ As nice example of using Mpfr arithmetic: On a wintery Sunday, Hans Borchers desired to have an exact $\pi$ constant in \pkg{Rmpfr}, and realized that of course \code{mpfr(pi, 256)} could not be the solution, as \code{pi} is the double precision version of $\pi$ and hence only about 53 bit accurate (and the \code{mpfr()} cannot do magic, recognizing ``symbolic'' $\pi$). As he overlooked the \code{Const("pi", .)} solution above, he implemented the following function that computes pi applying Gauss' spectacular AGM-based (AGM := Arithmetic-Geometric Mean) approach [Borwein and Borwein (1987), \emph{Pi and the AGM}]; I have added a \code{verbose} argument, explicit iteration counting and slightly adapted the style to my own: <>= piMpfr <- function(prec=256, itermax = 100, verbose=TRUE) { m2 <- mpfr(2, prec) # '2' as mpfr number ## -> all derived numbers are mpfr (with precision 'prec') p <- m2 + sqrt(m2) # 2 + sqrt(2) = 3.414.. y <- sqrt(sqrt(m2)) # 2^ {1/4} x <- (y+1/y) / m2 it <- 0L repeat { p.old <- p it <- it+1L p <- p * (1+x) / (1+y) if(verbose) cat(sprintf("it=%2d, pi^ = %s, |.-.|/|.|=%e\n", it, formatMpfr(p, min(50, prec/log2(10))), 1-p.old/p)) if (abs(p-p.old) <= m2^(-prec)) break if(it > itermax) { warning("not converged in", it, "iterations") ; break } ## else s <- sqrt(x) y <- (y*s + 1/s) / (1+y) x <- (s+1/s)/2 } p } piMpfr()# indeed converges *quadratically* fast ## with relative error relErr <- 1 - piMpfr(256, verbose=FALSE) / Const("pi",260) ## in bits : asNumeric(-log2(abs(relErr))) @ \subsection[{seqMpfr()} for sequences:]{\code{seqMpfr()} for sequences:} In \R, arithmetic sequences are constructed by \code{seq()}, the ``sequence'' function, which is not generic, and with its many ways and possible arguments is convenient, but straightforward to automatically generalize for mpfr numbers. Instead, we provide the \code{seqMpfr} function... \subsection[Rounding, {roundMpfr()}, {asNumeric()} etc:]{% Rounding, \code{roundMpfr()}, \code{asNumeric()} etc:} In \R, the \code{round()} and \code{signif()} functions belong to the \code{Math2} group, and we provide \code{"mpfr"}-class methods for them: <>= getGroupMembers("Math2") showMethods("Math2", classes=c("mpfr", "mpfrArray")) @ For consistency reasons, however the resulting numbers keep the same number of precision bits, \code{precBits}: <>= i7 <- 1/mpfr(700, 100) c(i7, round(i7, digits = 6), signif(i7, digits = 6)) @ If you really want to ``truncate'' the precision to less digits or bits, you call \code{roundMpfr()}, <>= roundMpfr(i7, precBits = 30) roundMpfr(i7, precBits = 15) @ Note that 15 bits correspond to approximately $15 \cdot 0.3$, i.e., 4.5 digits, because $1/\log_2(10) \approx 0.30103\dots$. \paragraph{asNumeric():} Often used, e.g., to return to fast (\R-internal) arithmetic, also as alternative to \code{roundMpfr()} is to ``round to double precision'' producing standard \R numbers from ``mpfr'' numbers. We provide the function \code{asNumeric()}, a generic function with methods also for \code{"mpfrArray"} see below and the big integers and big rationals from package \pkg{gmp}, <>= showMethods(asNumeric) @ see, e.g., its use above. \paragraph{Formatting:} For explicit printing or plotting purposes, we provide an \code{"mpfr"} method for \R's \code{format()} function, also as explicit utility function \code{formatMpfr(x, digits)} which provides results to \code{digits} \emph{significant} digits, <>= cbind( sapply(1:7, function(d) format(i7, digits=d)) ) @ There, \code{digits = NULL} is the default where the help has (``always'') promised \emph{The default, \code{NULL}, uses enough digits to represent the full precision, often one or two digits more than you would expect}. However, for large numbers, say $10^{20000}$, e.g., \Sexpr{x <- mpfr(10,80)^20000}, all of \code{formatMpfr(x)}, \code{format(x)}, and \code{print(x)} (including ``auto-printing'' of \code{x}), have shown all digits \emph{before} the decimal point and not at all taken into account the 80-bit precision of \code{x} (which corresponds to only \code{80 / log2(10)} $\approx 24$ decimal digits). This has finally changed in the (typically default) case \code{formatMpfr(*, maybe.full = FALSE)}: <>= x <- mpfr(2, 80) ^ ((1:4)*10000) cbind(x) # -> show() -> print.mpfr() -> formatMpfr(.. , digits = NULL, maybe.full = FALSE) nchar(formatMpfr(x)) nchar(formatMpfr(x, maybe.full = TRUE)) @ \section{``All'' mathematical functions, arbitrarily precise} %% see ../../man/mfpr-class.Rd %% but also .... %% {Math}{\code{signature(x = "mpfr")}: All the S4 ``\texttt{Math}'' group functions are defined, using multiple precision (MPFR) arithmetic, i.e., <>= getGroupMembers("Math") @ % \code{{abs}}, \code{{sign}}, \code{{sqrt}}, % \code{{ceiling}}, \code{{floor}}, \code{{trunc}}, % \code{{cummax}}, \code{{cummin}}, \code{{cumprod}}, % \code{{cumsum}}, \code{{exp}}, \code{{expm1}}, % \code{{log}}, \code{{log10}}, \code{{log2}}, % \code{{log1p}}, \code{{cos}}, \code{{cosh}}, % \code{{sin}}, \code{{sinh}}, \code{{tan}}, % \code{{tanh}}, \code{{acos}}, \code{{acosh}}, % \code{{asin}}, \code{{asinh}}, \code{{atan}}, % \code{{atanh}}, \code{{gamma}}, \code{{lgamma}}, % \code{{digamma}}, and \code{{trigamma}}. where currently, \code{trigamma} is not provided by the MPFR library, and hence not implemented yet. %% cumsum(), cumprod() now work! \code{factorial()} has a \texttt{"mpfr"} method; and in addition, \code{factorialMpfr()} computes ${n!}$ efficiently in arbitrary precision, using the MPFR-internal implementation. This is mathematically (but not numerically) the same as $\Gamma(n+1) = $\code{gamma(n+1)}. Similarly to \code{factorialMpfr()}, but more generally useful,the functions \code{chooseMpfr(a,n)} and \code{pochMpfr(a,n)} compute (generalized!) binomial coefficients $\binom{a}{n}$ and ``the'' Pochhammer symbol or ``rising factorial'' \begin{eqnarray*} a^{(n)} &:=& a(a+1)(a+2)\cdots(a+n-1) \\ &=& \frac{(a+n-1)!}{(a-1)!} = \frac{\Gamma(a+n)}{\Gamma(a)}. \end{eqnarray*} Note that with this definition, \[ \binom{a}{n} \equiv \frac{a^{(n)}}{n!}. \] \section{Arbitrarily precise matrices and arrays} %%% FIXME --> ~/R/Meetings-Kurse-etc/2011-Warwick/1_MM_/Poster/MM-poster.tex The classes \code{"mpfrMatrix"} and \code{"mpfrArray"} correspond to the classical numerical \R\ \code{"matrix"} and \code{"array"} objects, which basically are arrays or vectors of numbers with a dimension \code{dim}, possibly named by \code{dimnames}. As there, they can be constructed by \code{dim(.) <- ..} setting, e.g., <>= head(x <- mpfr(0:7, 64)/7) ; mx <- x dim(mx) <- c(4,2) @ or by the \code{mpfrArray()} constructor, <>= dim(aa <- mpfrArray(1:24, precBits = 80, dim = 2:4)) <>= aa <>= capture.and.write(aa, 11, 4) @ and we can index and multiply such matrices, e.g., <>= mx[ 1:3, ] + c(1,10,100) crossprod(mx) @ and also \code{apply} functions, <>= apply(7 * mx, 2, sum) @ \section{Special mathematical functions} \code{zeta(x)} computes Riemann's Zeta function $\zeta(x)$ important in analytical number theory and related fields. The traditional definition is \begin{equation*} \zeta(x) = \sum_{n=1}^\infty \frac{1}{n^x}. \end{equation*} \code{Ei(x)} computes the \textbf{e}xponential integral, \begin{equation*} \int_{-\infty}^{x} \frac{e^t}{t} \; dt. \end{equation*} <>= curve(Ei, 0, 5, n=2001); abline(h=0,v=0, lty=3) @ \code{Li2(x)}, part of the MPFR C library since version 2.4.0, computes the dilogarithm, \begin{equation*} \mathtt{Li2(x)} = \operatorname{Li}_2(x) := \int_{0}^{x} \frac{-log(1-t)}{t} \; dt, \end{equation*} which is the most prominent ``polylogarithm'' function, where the general polylogarithm is (initially) defined as \begin{equation*} \operatorname{Li}_s(z) = \sum_{k=1}^\infty \frac{z^k}{k^s}, \ \forall s \in \mathbb{C} \ \ \forall |z| < 1, z\in\mathbb{C}, \end{equation*} see \url{http://en.wikipedia.org/wiki/Polylogarithm#Dilogarithm}. Note that the integral definition is valid for all $x\in \mathbb{C}$, and also, $Li_2(1) = \zeta(2) = \pi^2/6$. <>= if(mpfrVersion() >= "2.4.0") ## Li2() is not available in older MPFR versions all.equal(Li2(1), Const("pi", 128)^2/6, tol = 1e-30) @ where we also see that \pkg{Rmpfr} provides \texttt{all.equal()} methods for mpfr-numbers which naturally allow very small tolerances \code{tol}. <>= if(mpfrVersion() >= "2.4.0") curve(Li2, -2, 13, n=2000); abline(h=0,v=0, lty=3) @ \code{erf(x)} is the ``error\footnote{named exactly because of its relation to the normal / Gaussian distribution} function'' and \code{erfc(x)} its \textbf{c}omplement, \code{erfc(x) := 1 - erf(x)}, defined as \begin{equation*} \operatorname{erf}(x) = \frac{2}{\sqrt{\pi}}\int_{0}^x e^{-t^2} dt, \end{equation*} and consequently, both functions simply are reparametrizations of the cumulative normal, $\Phi(x) = \int_{-\infty}^x \phi(t)\;dt = $\code{pnorm(x)} where $\phi$ is the normal density function $\phi(t) := \frac{1}{\sqrt{2\pi}}e^{-t^2}$=\code{dnorm(x)}. Namely, \code{erf(x) = 2*pnorm(sqrt(2)*x)} and \code{erfc(x) = 1 - erf(x) = 2* pnorm(sqrt(2)*x, lower=FALSE)}. <>= curve(erf, -3,3, col = "red", ylim = c(-1,2)) curve(erfc, add = TRUE, col = "blue") abline(h=0, v=0, lty=3); abline(v=c(-1,1), lty=3, lwd=.8, col="gray") legend(-3,1, c("erf(x)", "erfc(x)"), col = c("red","blue"), lty=1) @ \subsection{Applications} The CRAN package \CRANpkg{Bessel} provides asymptotic formulas for Bessel functions also of \emph{fractional} order which do work for \code{mpfr}-vector arguments as well. \section{Integration highly precisely} Sometimes, important functions are defined as integrals of other known functions, e.g., the dilogarithm $\operatorname{Li}_2()$ above. Consequently, we found it desirable to allow numerical integration, using mpfr-numbers, and hence---conceptionally---arbitrarily precisely. \R's \code{integrate()} uses a relatively smart adaptive integration scheme, but based on C code which is not very simply translatable to pure \R, to be used with mpfr numbers. For this reason, our \code{integrateR()} function uses classical Romberg integration \citep{Bauer-1961}. We demonstrate its use, first by looking at a situation where \R's \code{integrate()} can get problems: <>= integrateR(dnorm,0,2000) integrateR(dnorm,0,2000, rel.tol=1e-15) integrateR(dnorm,0,2000, rel.tol=1e-15, verbose=TRUE) @ Now, for situations where numerical integration would not be necessary, as the solution is known analytically, but hence are useful for exploration of high accuracy numerical integration: First, the exponential function $\exp(x) = e^x$ with its well-known $\int \exp(t)\;dt = \exp(x)$, both with standard (double precision) floats, <>= (Ie.d <- integrateR(exp, 0 , 1, rel.tol=1e-15, verbose=TRUE)) @ and then the same, using 200-bit accurate mpfr-numbers: <>= (Ie.m <- integrateR(exp, mpfr(0,200), 1, rel.tol=1e-25, verbose=TRUE)) (I.true <- exp(mpfr(1, 200)) - 1) ## with absolute errors as.numeric(c(I.true - Ie.d$value, I.true - Ie.m$value)) @ Now, for polynomials, where Romberg integration of the appropriate order is exact, mathematically, <>= if(require("polynom")) { x <- polynomial(0:1) p <- (x-2)^4 - 3*(x-3)^2 Fp <- as.function(p) print(pI <- integral(p)) # formally print(Itrue <- predict(pI, 5) - predict(pI, 0)) ## == 20 } else { Fp <- function(x) (x-2)^4 - 3*(x-3)^2 Itrue <- 20 } (Id <- integrateR(Fp, 0, 5)) (Im <- integrateR(Fp, 0, mpfr(5, 256), rel.tol = 1e-70, verbose=TRUE)) ## and the numerical errors, are indeed of the expected size: 256 * log10(2) # - expect ~ 77 digit accuracy for mpfr(*., 256) as.numeric(Itrue - c(Im$value, Id$value)) @ \section{Miscellaneous} For probability and density computations, it is known to be important in many contexts to work on the $\log$--scale, i.e., with log probabilities $\log P(.)$ or log densities $\log f()$. In \R{} itself, we (R Core) had introduced logical optional arguments \code{log} (for density) and \code{log.p} for probability (e.g., \code{pnorm()} and quantile (e.g., \code{qnorm}) functions. As our \code{pnorm()} is based on MPFR's \code{erf()} and \code{erfc()} which currently do \emph{not} have scaled versions, for \code{Rmpfr::pnorm(.., log.p=TRUE)} we do need to compute the logarithm (instead of working on the log scale). On the extreme left tail, \R{} correctly computes <>= pnorm(-1234, log.p=TRUE) @ i.e., \code{-761386.036955} to more digits. However, \code{erf()} and \code{erfc()} do not have a log scale or other scaled versions. Thanks to the large range of exponents compared to double precision numbers it does less quickly underflow to zero, e.g., <>= (p123 <- Rmpfr::pnorm(mpfr(-123, 66), log.p=TRUE)) # is based on (ec123 <- erfc(123 * sqrt(mpfr(0.5, 66+4))) / 2) # 1.95....e-3288 (p333 <- Rmpfr::pnorm(mpfr(-333, 66), log.p=TRUE)) exp(p333) stopifnot(p123 == log(roundMpfr(ec123, 66)), ## '==' as we implemented our pnorm() all.equal(p333, -55451.22709, tol=1e-8)) @ and indeed, the default range for exponent (wrt base 2, not 10) is given by <>= (old_erng <- .mpfr_erange() ) @ which shows the current minimal and maximal base-2 exponents for mpfr-numbers, by ``factory-fresh'' default, the number $-2^{30}$ and $2^{30}$, i.e., $\pm 1073741823$ which is much larger than the corresponding limits for regular double precision numbers, <>= unlist( .Machine[c("double.min.exp", "double.max.exp")] ) @ which are basically $\pm 2^{10}$; note that double arithmetic typically allows subnormal numbers which are even smaller than $2^{-1024}$, also in \R{}, on all usual platforms, <>= 2^(-1022 - 52) @ is equal to $2^{-1074}$ and the really smallest positive double precision number. Now, \emph{if} if the GMP library to which both \R{} package \pkg{gmp} and \pkg{Rmpfr} interface is built ``properly'', i.e., with full 64 bit ``numb''s, we can \emph{extend} the range of mpfr-numbers even further. By how much, we can read off <>= .mpfr_erange(.mpfr_erange_kinds) ## and then set # use very slightly smaller than extreme values: (myERng <- (1-2^-52) * .mpfr_erange(c("min.emin","max.emax"))) .mpfr_erange_set(value = myERng) # and to see what happened: .mpfr_erange() @ If that worked well, this shows \code{-/+ 4.611686e+18}, or actually $\mp 2^{62}$, \code{log2(abs(.mpfr_erange()))} giving \Sexpr{log2(abs(.mpfr_erange()))}. However, currently on Winbuilder this does not extend, notably as the GMP numbs, <>= .mpfr_gmp_numbbits() @ have \emph{not} been 64, there. \section{Conclusion} The \R\ package \pkg{Rmpfr}, available from CRAN since August 2009, provides the possibility to run many computations in R with (arbitrarily) high accuracy, though typically with substantial speed penalty. This is particularly important and useful for checking and exploring the numerical stability and appropriateness of mathematical formulae that are translated to a computer language like \R, often without very careful consideration of the limits of computer arithmetic. \bibliography{Rmpfr,log1mexp} FIXME: \textbf{Index} of all functions mentioned \dots \end{document} Rmpfr/inst/doc/Maechler_useR_2011-abstr.R0000644000176200001440000000164215075721223017506 0ustar liggesusers### R code from vignette source 'Maechler_useR_2011-abstr.Rnw' ################################################### ### code chunk number 1: preliminaries ################################################### options(SweaveHooks= list(fig=function() par(mar=c(5.1, 4.1, 1.1, 2.1))), width = 75) Sys.setenv(LANGUAGE = "en") if(.Platform$OS.type != "windows") Sys.setlocale("LC_MESSAGES","C") stopifnot(require("Rmpfr")) ################################################### ### code chunk number 2: ex-exp ################################################### options(digits = 17)# to print to full "standard R" precision .N <- function(.) mpfr(., precBits = 200) exp( 1 ) exp(.N(1)) ################################################### ### code chunk number 3: nice-but-does-not-fit-on-1-page (eval = FALSE) ################################################### ## choose ( 200, 99:100 ) ## chooseMpfr( 200, 99:100 ) Rmpfr/inst/NEWS.Rd0000644000176200001440000006535215075721164013403 0ustar liggesusers% Check from R: % news(db = tools:::.build_news_db_from_package_NEWS_Rd("~/R/Pkgs/Rmpfr/inst/NEWS.Rd")) \name{NEWS} \title{Rmpfr News} \encoding{UTF-8} %% -- not yet in tar ball -- %% \item Start vignette about \code{gamma()} inaccuracies and possible %% remedies (is \bold{unfinished}). \section{Changes in version 1.1-2 [2025-10-21, r437]}{ \subsection{NEW FEATURES}{ \itemize{ \item New \code{\link{.mpfrSizeof()}} providing the small integer sizes of the platform's MPFR library configuration. } } \subsection{BUG FIXES}{ \itemize{ \item For \code{mpfr(x, precBits=*)} it is now documented that \code{precBits} must not be larger than largest integer, i.e., \eqn{2^31 - 1 = 2147483648}. An error message for larger values is now easier to understand. \item Correct \file{configure.ac}, \file{Makevars}, etc needed when MPFR exponent size does not match limb size (as on r-universe Windows), fixing R-forge Rmpfr bug #6865 by \I{Mikael Jagan}. } } } \section{Changes in version 1.1-1 [2025-07-18, r430]}{ \subsection{NEW FEATURES}{ \itemize{ \item added \code{dchisq()} for completeness, simply calling \code{dgamma(x, df/2, scale = 2)}. } } \subsection{BUG FIXES}{ \itemize{ \item \code{dgamma()} accidentally used double precision instead of "mpfr" in some cases. } } } \section{Changes in version 1.1-0 [2025-05-08, r426]}{ \subsection{NEW FEATURES}{ \itemize{ \item New \code{pgamma()}, simply via \code{igamma()}, to become more visible to probability and statistics.\cr Note that in some regions of its domain, it is currently severely limited (both slow and inaccurate) as by its implementation in MPFR, see the \sQuote{Warning} in \code{?igamma}. } } \subsection{BUG FIXES}{ \itemize{ \item The default for our \code{dbinom()}'s \code{useLog} argument was determined alone by \code{any(abs(x) > 1e6)}; it is now also true, for smaller \code{x} and large \code{size} or extreme \code{prob}, e.g., in \code{dbinom(7L, mpfr(1e10, 96), prob = 1/4)}. Notably a bad thinko has been fixed which lead to only double precision accuracy results for \code{useLog = TRUE}. } } \subsection{Misc}{ \itemize{ \item Requiring MPFR >= 3.2.0 such that \code{gamma_inc()} is available for our \code{igamma()} and \code{pgamma()}. } } } \section{Changes in version 1.0-0 [2024-11-15, r422]}{ \subsection{USER-VISIBLE CHANGES}{ \itemize{ \item The low-level bug fix about conversion has slightly changed the ABI and the low-level \code{validity} method on Windows: Non-finite mpfr-numbers, e.g., \code{NA}, \code{Inf}, now have different mantissa slot \code{@ d}, now starting with \code{0L} instead of previously \code{-1L}. } } \subsection{NEW FEATURES}{ \itemize{ \item New \code{num2bigq(x)} finds \dQuote{small} denominator \code{bigq} / \sQuote{bigRational} approximation to numeric or \code{x}. Basically a \CRANpkg{MASS}\code{::fractions()} version for \CRANpkg{Rmpfr} and \CRANpkg{gmp}. } } \subsection{BUG FIXES}{ \itemize{ \item \code{format(mpfr())} no longer warns. \item in \code{formatDec()}: use \code{p*log(2, 10)} instead of \code{log(2^p, 10)}! \item low-level C fixes in \file{src/convert.c} thanks to analysis and proposition by Mikael Jagan. Entails update of \code{validity()} for \code{"mpfr1"}. \item add \code{\\link[pkg]{...}} where needed. } } \subsection{Misc}{ \itemize{ \item new \file{../tests/special-fun-dgamma.R} file; partly from \file{..../special-fun-ex.R}: accuracy checking for more accurate \code{stirlerr()} in \R 4.4.0 and later. } } } \section{Changes in version 0.9-5 [2024-01-20, r407]}{ \subsection{NEW FEATURES}{ \itemize{ \item New \code{.mpfr2bigq(m)} transforms -number vectors to big rational aka \code{bigq} ones (from package \CRANpkg{gmp}). \item New low-level utility functions \code{.mpfr2d()} and \code{.mpfr2i()}. } } \subsection{BUG FIXES}{ \itemize{ \item \code{x == y} and other comparisons of two \code{"mpfr"} operands now return \code{NaN} when an operand is \code{NaN} (mpfr numbers are never \code{NA}). \item \code{dbinom(x, *)} and \code{dnbinom(x, *)} now use the precision of \code{x} when it is an (integer valued) \code{"mpfr"} object, and then notice or even error when precision is lost as \code{x} is coerced to integer. \item (erange-related comments in examples) \item \code{chooseMpfr(a, n)} gives \code{0} when \code{n < 0}, as \R's \code{choose()} and when \code{a} is integer valued, may use the equivalent of \code{chooseMpfr(a, a-n)} when \code{a-n < n} to be more accurate and faster. \item \code{.mpfr2bigz(m)} now also works for really large \code{m}. } } } \section{Changes in version 0.9-4 [2023-12-04, r399]}{ \subsection{BUG FIXES}{ \itemize{ \item Fixed Windows-only (long = 32 bit) bug; adapt mpfr1-validity() check. \item allow `.Platform$endian != "little" to 'work' in validity(). \item format ("\%ld" etc) fixes in \file{src/utils.c} \item fix "lost braces" } } } \section{Changes in version 0.9-3 [2023-07-27, r394]}{ \subsection{BUG FIXES}{ \itemize{ \item \code{any()} and \code{all()} no longer damage \R's internal FALSE or TRUE, fixing R-forge Rmpfr bug #6764 by Andrew Manderson. } } } \section{Changes in version 0.9-2 [2023-04-21, r392]}{ \subsection{USER-VISIBLE CHANGES}{ \itemize{ \item \code{formatMpfr()} and hence the \code{format()} method for \code{"mpfr"} etc now uses a \code{scientific = } the same as \pkg{base} \code{format.default()}; accidentally it had the \emph{sign} of the number interpreted differently and failed to use e.g., \code{getOption("scipen")} correctly. } } \subsection{NEW FEATURES}{ \itemize{ \item \code{log(, base=10)} now works. } } \subsection{BUG FIXES}{ \itemize{ \item \code{igamma()}, \code{hypot()}, and \code{atan2()} no longer only return 53 bit (or more generally, mpfr default precision) results. \item New \code{max2_prec()} utility instead of \code{imax2()}, also curing compilation warning. \item Internal (exported) objects are now (somewhat) documented, as eventually required by \R. } } } \section{Changes in version 0.9-1 [2023-01-30, r386]}{ \subsection{BUG FIXES}{ \itemize{ \item \code{ldexpMpfr(f, E)} now returns an \code{"mpfr"} vector (instead of a \code{"mpfr1"}). } } } \section{Changes in version 0.9-0 [2023-01-16, r382]}{ \subsection{NEW FEATURES}{ \itemize{ \item Add the \code{extendInt="*"} option to \code{unirootR()} adopting its addition in base \R \code{uniroot()}. \cr Also add an optional \code{verbDigits} argument only used in case \code{verbose} is true. \item New \code{qnormI()}, the normal quantile function, computed via inversion of (our potentially arbitrarily accurate) \code{pnorm()}, using \code{unirootR()} root finding. \item \code{sapplyMpfr()} gets \code{drop_1_ = TRUE} option, \emph{changing} default behaviour to return an \code{"mpfr"} vector instead of a 1-column \code{"mpfrMatrix"}. } } \subsection{BUG FIXES}{ \itemize{ \item \code{sapplyMpfr()} now gets the correct dimension when it returns an \code{"mpfrMatrix"} (or \code{"*array"}). \item Fix \code{\\eqn{(\\gamma)}{}} - as requested by KH (June 9). \item \code{.mpfr_gmp_numbbits()} is documented now (notably as I see it is only 32 on Winbuilder (!)). } } } \section{Changes in version 0.8-9 [2022-06-02, r363]}{ \subsection{BUG FIXES}{ \itemize{ \item Embarrassing thinko in \code{dpois} (in \code{useLog=TRUE} case) fixed. } } } \section{Changes in version 0.8-8 [2022-06-01, r362]}{ \subsection{NEW FEATURES}{ \itemize{ \item Our \dQuote{mpfr-ized} \code{all.equal()} is now based on hidden \code{all.equalMpfr()} which uses a smart default \code{tolerance} for all methods, and shows much less digits if there are differences (compatibly to \code{all.equal.numeric()}). } } \subsection{BUG FIXES}{ \itemize{ \item Our \code{dpois(x, lambda, *)} now works \R-compatibly for \code{lambda=+Inf} giving 0 or \code{-Inf} when \code{log=TRUE}. \item \code{formatMpfr(x, scientific=FALSE)} now \dQuote{works}. % tweaking default of 'maybe.full': true also if(isFALSE(scientific)) } } \subsection{Misc}{ \itemize{ \item \file{man/*.Rd}: get rid of some \code{\\} escapes (needed in past; wrong now) } } } \section{Changes in version 0.8-7 [2021-10-27, r353]}{ \subsection{BUG FIXES}{ \itemize{ \item In \file{Ops.c}'s \code{R_mpfr_mod()}, no longer allocate but never use nor free \code{rr} - fixing YAL (yet another leak). } } } \section{Changes in version 0.8-6 [2021-10-08, r351]}{ \subsection{BUG FIXES}{ \itemize{ \item In \file{convert.c}'s \code{R_mpfr_frexp()}, do \code{mpfr_clear(*)}, fixing a valgrind-detectable leak. \item additionally use single mpfr_exp_t and its pointer (and assign to R allocated vector inside main loop, fixing a valgrind "unitialized value" case. } } } \section{Changes in version 0.8-5 [2021-10-05, r349]}{ \subsection{NEW FEATURES}{ \itemize{ \item New mpfr-ized \code{dt(x, df, ..)}; noncentrality \code{ncp} not yet supported. \item New arithmetic functions \code{frexpMpfr()} and \code{ldexpMpfr()}, corresponding to C's (and CRAN package \CRANpkg{DPQ}'s) \code{ldexp()} and \code{frexp()} functions. \item \code{sapplyMpfr()} now also returns \code{"mpfrMatrix"} or \code{"mpfrArray"} when appropriate. } } \subsection{BUG FIXES}{ \itemize{ \item Improved \code{`[.Ncharacter`} method for \code{formatHex()} etc. } } \subsection{Misc}{ \itemize{ \item No longer include \file{Rdefines.h} as it is somewhat deprecated. \item update both \file{configure\{,.ac\}} (for \command{autoconf 2.71}). } } } \section{Changes in version 0.8-4 [2021-03-24, r341]}{ \subsection{NEW FEATURES}{ \itemize{ \item \code{dpois(x, *)} now also gets an explicit optional argument \code{useLog} instead of just switching to log-scale by the same test as defines \code{useLog}'s default. \item The default method of \code{mpfr(r)} now also works when \code{r} is a \code{list} of \code{"mpfr1"} objects, e.g., resulting from \code{Vectorize(.)} or similar applied to mpfr-vectors. } } \subsection{BUG FIXES}{ \itemize{ \item fixed problem detected by clang-UBSAN testing in \file{src/Ops.c} (from arithmetic bug fix in 0.8-3). % ../tests/arith-ex.Rout_clang-UBSAN } } } \section{Changes in version 0.8-3 [2021-03-22, r340]}{ \subsection{NEW FEATURES}{ \itemize{ \item \code{dnbinom(x, *)} and \code{dbinom(x, *)} now also work when \code{x} is too large to be coerced to \code{integer} \emph{and} they get a new optional argument \code{useLog} (with a smart default) in order to choose log-scale computation also for \code{log=FALSE}. } } \subsection{BUG FIXES}{ \itemize{ \item For arithmetic (\code{`+`}, \code{`*`}, etc), the check to see if a numeric can be validly coerced to a long has been amended such that 9223372036854775808 is no longer accidentally coerced into \emph{negative}. \item \code{dpois(x, lambda)} now works via log-scale in case \code{exp(-lambda)} or \code{lambda^x} would under- or overflow even for mpfr-numnbers. Analogously, \code{dbinom()} and \code{dnbinom()} work via log-scale in case even mpfr-arithmetic would overflow. } } } \section{Changes in version 0.8-2 [2020-11-10, r337]}{ \subsection{NEW FEATURES}{ \itemize{ \item The workhorse for all matrix multiplication (\code{\%*\%}, \code{crossprod()}, and \code{tcrossprod()}), i.e., \code{.matmult.R(x, y, *)} (not exported), gets new optional arguments \code{fPrec = 1} and \code{precBits}, which defaults to the maximum of \code{getPrec(x)} and \code{getPrec(y)}. To get correct \code{crossprod()} and tcrossprod() generics (with a formal \code{\dots} argument), need a new \CRANpkg{gmp} release, as we get these two generics from \pkg{gmp}. \item \code{matmult(x,y)} is identical to \code{x \%*\% y}, but \code{matmult()} has further optional arguments \code{fPrec} and \code{precBits}, see above. \item New \code{is.mpfr(x)} function; simple, with fast pre-test. \item In \code{pbetaI(q, ..)}, when \code{q} is a bigrational, i.e., of class \code{"bigq"} (package \CRANpkg{gmp}), the computations are \emph{exact} now, using big rational arithmetic. \item New \code{dnbinom()} function (with corresponding new \code{\link{conflicts}()} with the \pkg{stats} package base \R function), providing an \code{"mpfr"}-number version of the negative binomial probabilities. \item \code{.mpfr_erange_set()} now can set \emph{both} exponent range limits simultaneously, and now returns invisibly \code{TRUE} if the change succeeded. \item New \code{log1mexp()} and \code{log1pexp()}, as "from" \CRANpkg{copula}, notably as the vignette has been here, and authored by me. } } \subsection{BUG FIXES}{ \itemize{ \item \code{mpfr(mm)} (and similar) now works for \code{"bigq"} or \code{"bigz"} matrices, thanks to a report by Jerry Lewis. \item Arithmetic and other \code{"\link{Ops}"} between \code{"mpfr"} and \code{"bigq"} aka bigrational numbers, now use the \dQuote{inherent} precision of the bigrational. \item \code{chooseMpfr(a, n)} and similar now \dQuote{work} when \code{n} is of length zero \emph{and} when an experimental version of \code{stopifnot(*, allow.logical0=FALSE)} is used. \item Our \code{cbind()} and \code{rbind()} methods with \code{signature = "mNumber"} now keep and construct column and row names as the corresponding base functions, obeying \code{deparse.level}. \item Fixed "not-yet"-as-cran \file{NOTE} \emph{Undeclared packages \pkg{dfoptim}, \pkg{pracma} in Rd xrefs}. } } } \section{Changes in version 0.8-1 [2020-01-14, r323]}{ \subsection{BUG FIXES}{ \itemize{ \item Provide dummy C function in the case MPFR library is older than 3.2.0, thanks to Brian Ripley. Should work around check \code{NOTE}s. } } } \section{Changes in version 0.8-0 [2019-12-05, r321]}{ \subsection{USER-VISIBLE CHANGES}{ \itemize{ \item Formatting incl \code{print()}ing by default uses a \code{"+"} after the exponential character (\code{"e"} by default). } } \subsection{NEW FEATURES}{ \itemize{ \item Provide new low-level utilities \code{.mpfr_formatinfo()}, \code{.mpfr2exp()}, and \code{.mpfr_erange_is_int()}. \item Renamed low-level utility functions to use \code{_} instead of \code{.} keeping initial \code{"."}, e.g., \code{.mpfr.gmp.numbbits()} to \code{.mpfr_gmp_numbbits()}. \item \code{formatMpfr()} gets a new optional \code{decimal.plus = TRUE} which adds a \code{"+"} before positive exponents when in exponential (aka \dQuote{scientific}) representation. The \code{mpfr} and \code{mpfrArray} \code{print()} methods get a corresponding \code{decimal.plus} argument with a default that can be set by \code{options(Rmpfr.print.decimal.plus = *)} to allow strict back compatibility where needed. \item For MPFR (C library) version >= 3.2.0 (not by default in Fedora 30!), provide the \emph{incomplete} gamma function \code{igamma(a,x)} which is closely related to \code{pgamma(x,a)}, see help page.% and DO % provide an MPFR pgamma() version, too % ==> then even MPFR pchisq() with *non*centrality maybe! \item Now also export S3 method of \code{unique()} for \code{"mpfr"}, such that \pkg{base} \code{factor()} \dQuote{works}.% -> ../man/mpfr-class.Rd } } \subsection{BUG FIXES}{ \itemize{ \item \code{formatMpfr()} and hence all \code{print()}ing suffered from an integer overflow bug with very large (base 2) exponents. \item \code{.mpfr2str(x, *)} is no longer dependent on the \emph{order} of the elements in \code{x}; consequently \code{format()} and \code{print()} may use less digits in case the precision decreases along \code{x}. \item adapt to new C compiler default behavior \code{-fno-common}, using \code{extern #include } in most \file{*.c} files. } } } \section{Changes in version 0.7-3 [2019-08-06, r305]}{ \subsection{USER-VISIBLE CHANGES}{ \itemize{ \item Decreased the default for \code{max.digits} to 999. } } \subsection{NEW FEATURES}{ \itemize{ \item Provide \code{dgamma(x, shape)} version, e.g., for small shape parameter where most of the mass is on very small \code{x} not representable as double precision numbers. \item Low-level formatting function \code{.mpfr2str()} --- called by \code{format()} and hence \code{print()} methods for \code{"mpfr"} objects --- now finally obeys its \code{maybe.full} argument when it is \code{FALSE}, internally in C's \code{mpfr2str()}. } } \subsection{BUG FIXES}{ \itemize{ \item \code{pnorm(, log.p=TRUE)} no longer underflows much too early, thanks to reports by Jerry Lewis. \item \code{print.mpfrArray()} now also uses a finite \code{max.digits} default, preventing, e.g., \code{cbind(x, y)} to use too many digits. } } } \section{Changes in version 0.7-2 [2019-01-18, r299]}{ \subsection{BUG FIXES}{ \itemize{ \item \code{str()} no longer calls \code{formatMpfr(x, digits, *)} with a \code{digits} \emph{vector} of the same length as \code{x} (which never worked correctly). \item \code{seqMpfr(1, length.out=8)} now works correctly. } } \subsection{NEW FEATURES}{ \itemize{ \item \code{unirootR()} gets an option to \emph{not} warn on non-convergence. \item Provide a \code{summary()} method for \code{"mpfr"} numbers closely modeled after \code{summary.default} for numeric. \item \code{mpfr(NULL)} now works, returning \code{mpfr(logical())}. \item a simple \code{sapplyMpfr()} function, showing how to work around the fact that \code{sapply()} does typically not work with \code{"mpfr"} numbers. } } } \section{Changes in version 0.7-1 [2018-07-24, r291]}{ \subsection{BUG FIXES}{ \itemize{ \item \code{formatMpfr()} for large low-precision numbers now uses scientific representation, fixing the bug RMH was reporting March 17 already. \item \code{outer()} is \dQuote{imported} from base, so it behaves as an \pkg{Rmpfr} function which dispatches e.g., when calling \code{\link{tcrossprod}()}. } } } \section{Changes in version 0.7-0 [2018-01-12, r284]}{ \subsection{NEW FEATURES}{ \itemize{ \item \code{.mpfr2list()} and \code{mpfrXport()} gain an option \code{names} (for nicer output). \item \code{formatMpfr()} and the \code{print()} method get a new option \code{max.digits} with default \code{9999} for the print methods, to limit the number of digits printed for high precision numbers. } } \subsection{BUG FIXES}{ \itemize{ \item For non-\dQuote{regular} mpfr numbers, the \code{d} slot in the \code{"mpfr1"} representation is now empty instead of \dQuote{random}. This also eliminates valgrind warnings about uninitialized values in C. } } } \section{Changes in version 0.6-2 [2017-05-29, r264], never on CRAN}{ \subsection{NEW FEATURES}{ \itemize{ \item The S3 classes \code{"Hcharacter"} and \code{"Bcharacter"} resulting from \code{formatHex()} and \code{formatBin()} now \dQuote{inherit from} \code{"character"} formally. \item They also got a \code{`[`} method, so subsetting should work, including for \code{array}s of these. \item The \code{"mpfr"} method of \code{str()} gains option \code{internal}. } } \subsection{BUG FIXES}{ \itemize{ \item when \code{print()}ing mpfr numbers, the result no longer sometimes loses the last digit. \item \code{dnorm()} now works correctly with mpfr numbers; similarly \code{dbinom()} and \code{dpois()} should work in all cases, now. \item in \file{NAMESPACE}, also \code{exportMethods(apply)}, so \pkg{SNscan} works. \item \code{print(formatHex(..))}, \code{formatBin()} and \code{formatDec()} now look better and are more correct; the first two get a new option \code{expAlign} indicating to use the same number of digits for exponents (in \dQuote{scientific} cases). Notably, \code{mpfr(formatBin(mpx))} works for more \code{mpx} objects (of class \code{"mpfr"}). \item \code{format(mpfr(3,7), digits = 1, base = 2)} no longer crashes (from inside MPFR). \item \code{formatDec(mpfr(NA, 7))} now works. \item For non-\dQuote{regular} mpfr numbers, the \code{d} slot in the \code{"mpfr1"} representation is now empty instead of \dQuote{random}. This also eliminates valgrind warnings about uninitialized values in C. } } } \section{Changes in version 0.6-1 [2016-11-15, r249]}{ \subsection{NEW FEATURES}{ \itemize{ \item \code{head()} and \code{tail()} methods for \code{"mpfrMatrix"}. } } \subsection{BUG FIXES}{ \itemize{ \item C-level \code{mpfr2str()} no longer calls S_realloc() with wrong "old size" (thanks to Bill Dunlap). \item \code{c()} now also works when its result is a length-0 \code{"mpfr"} object. } } } \section{Changes in version 0.6-0 [2015-12-04, r237]}{ \subsection{NEW FEATURES}{ \itemize{ \item \code{mpfr()} now is S3 generic with several methods, notably a \code{"mpfr"} method allowing to change precision or rounding mode. \item \code{mpfr()}, \code{formatMpfr()}, etc, now work with bases from 2 to 62 (using digits, upper and lower case ASCII letters, \code{62 == 10 + 2*26} characters), as this has been in MPFR since version 3.0.0 (see \code{\link{mpfrVersion}}), which is hence (implicitly) required for \code{base} greater than 36. \item \code{formatMpfr()} gets a new argument \code{base = 10} and can be used to produce in other bases, notably binary (\code{base = 2}) or hexadecimal (\code{base = 16}). \item \code{str(, ....)} is now based on \code{formatMpfr()} and nicely shows numbers also out of the double precision range. Further, it now chooses a smart default for optional argument \code{vec.len}. \item \code{matrix(mp, ..)} now also works when \code{mp} is of class \code{"mpfr"}. \item new matrix \code{norm()} for several \code{kind}s. \item new functions \code{formatHex()} and \code{formatBin()} thanks to Rich Heiberger. \item \code{mpfr(x)} also works as \emph{inverse} of \code{formatBin} and \code{formatHex}. \item \code{roundMpfr()} and mathematical functions such as \code{jn}, or \code{chooseMpfr()} get new optional argument \code{rnd.mode} passed to the corresponding MPFR function. \item \code{median(x)}, \code{mean(x, trim)} for \code{trim > 0} now work fine for \code{"mpfr"} x, and \code{quantile(x, *)} no longer needs \code{names=FALSE} to avoid a warning. } } \subsection{BUG FIXES}{ \itemize{ \item \code{pnorm(.)}, \code{j0()} and similar special functions now preserve \code{mpfrMatrix} and \code{mpfrArray} classes. \item similarly, \code{is.finite()} etc keep the \code{dim()}ensionality for \code{"mpfrArray"} arguments. \item \code{mpfr("0xabc", base=16)} and \code{mpfr("0b101", base=2)} and corresponding \code{getPrec()} now give the correct precBits instead of too many. \item \code{str(<0-length mpfr>)} now works correctly. } } } \section{Changes in version 0.5-7 [2014-11-27, r205]}{ \subsection{NEW FEATURES}{ \itemize{ \item . } } \subsection{BUG FIXES}{ \itemize{ \item \code{as.integer()} now rounds \dQuote{to zero} as for regular \R numbers (it accidentally did round \dQuote{to nearest} previously). } } } \section{Changes in version 0.5-6 [2014-09-05, r203]}{ \subsection{NEW FEATURES}{ \itemize{ \item experimental \code{mpfrImport()}, \code{mpfrXport()} utilities -- as we found cases, where save() \code{"mpfr"} objects were \emph{not} portable between different platforms. \item \code{as(*,"mpfr")} now also supports rounding mode \code{"A"} (\dQuote{\bold{A}way from zero}). \item Several hidden low level utilities also get a \code{rnd.mode} option. } } } \section{Changes in version 0.5-5 [2014-06-19, r190]}{ \subsection{NEW FEATURES}{ \itemize{ \item The result of \code{integrateR()} now prints even if a warning happened. \item \code{pbetaI(x, a,b)}, the arbitrarily accurate \code{pbeta()} computation for \emph{integer} \eqn{a} and \eqn{b}, now works for larger \eqn{(a,b)}. \item Newly providing \code{mpfr}-versions of \code{dbinom()}, \code{dpois()}, and \code{dnorm()}. \item New utility functions \code{mpfr_default_prec()}, \code{.mpfr.minPrec()}, etc, to get, check, set default exponent ranges and precision. \item New \code{sinpi()}, \code{cospi()} etc, notably for \R >= 3.0.1. } } } \section{Changes in version 0.5-4 [2013-10-22, r173]}{ \subsection{NEW FEATURES}{ \itemize{ \item . } } \subsection{BUG FIXES}{ \itemize{ \item . } } } %% The first CRAN release \section{Changes in version 0.1-5 [2009-08-06]}{ \subsection{NEW FEATURES}{ \itemize{ \item First CRAN release on 'Publication:' 2009-08-14 20:24:02 \item new \code{pmin()} and \code{pmax()}, improving \code{seqMpfr()}. \item new \code{"Math"} and \code{"Math2"} group methods, notably for \code{round()} and \code{signif()}. \item \code{as(. , "integer")} now works (via C \code{mpfr2i}). } } \subsection{More details for old versions up to Feb. 2015:}{ \itemize{ \item See file \file{ChangeLog} %% ../ChangeLog <<< } } } Rmpfr/inst/check-tools.R0000644000176200001440000000434414274665772014704 0ustar liggesusers#### Check tools -- notably for Rmpfr #### ================================ ## to be used as ## source(system.file("check-tools.R", package="Rmpfr"), keep.source=FALSE) ## Some of the Matrix package check tools {MM = ~/R/Pkgs/Matrix/inst/test-tools-1.R} ## ~~~~~~~~~~~~~~~~~~~~~~~~~~ assert.EQ <- function(target, current, tol = if(showOnly) 0 else 1e-15, giveRE = FALSE, showOnly = FALSE, ...) { ## Purpose: check equality *and* show non-equality ## ---------------------------------------------------------------------- ## showOnly: if TRUE, return (and hence typically print) all.equal(...) T <- isTRUE(ae <- all.equal(target, current, tolerance = tol, ...)) if(showOnly) return(ae) else if(giveRE && T) { ## don't show if stop() later: ae0 <- if(tol == 0) ae else all.equal(target, current, tolerance = 0, ...) if(!isTRUE(ae0)) writeLines(ae0) } if(!T) stop("all.equal() |-> ", paste(ae, collapse=sprintf("%-19s","\n"))) else if(giveRE) invisible(ae0) } ##' a version with other "useful" defaults (tol, giveRE, check.attr..) assert.EQ. <- function(target, current, tol = if(showOnly) 0 else .Machine$double.eps^0.5, giveRE = TRUE, showOnly = FALSE, ...) { assert.EQ(target, current, tol=tol, giveRE=giveRE, showOnly=showOnly, check.attributes=FALSE, ...) } showSys.time <- function(expr, ...) { ## prepend 'Time' for R CMD Rdiff st <- system.time(expr, ...) writeLines(paste("Time", capture.output(print(st)))) invisible(st) } ### ------- Part I -- do not need 'Rmpfr' `%=N=%` <- function(x,y) (x == y) | (is.na(x) & is.na(y)) all.eq.finite <- function(x,y, ...) { ## x = 'target' y = 'current' if(any(is.finite(y[!(fx <- is.finite(x))]))) return("current has finite values where target has not") if(any(is.finite(x[!(fy <- is.finite(y))]))) return("target has finite values where current has not") ## now they have finite values at the same locations all.equal(x[fx], y[fy], ...) } ### ------- Part II -- do not make sense or work outside of 'Rmpfr' : all.EQ <- function(x,y, tolerance = 2^-98, ...) # very small tol. for MPFR all.equal.finite(x, y, tolerance=tolerance, ...) Rmpfr/README.md0000644000176200001440000000264013735036657012640 0ustar liggesusers# Installation and Reference of the R package 'Rmpfr' Installation is non-trivial if you install from __source_ because of the `SystemRequirements` (listed in `./DESCRIPTION`): ## The package Rmpfr interfaces R to the C Library MPFR: __MPFR, the "Multiple Precision Floating-Point Reliably" library__ which is Free/Libre Software, available under the LGPL license. [MPFR Website](https://www.mpfr.org/) ## MPFR itself is built on and requires the GMP library __GNU Multiple Precision arithmetic library (GMP)__ Obtain that from [GMP Website](https://gmplib.org/) or from your operating system vendor / package system: + Under _Debian_, _Ubuntu_ (and other Debian derivative) Linux distributions, it is sufficient (for *both* libraries) to simply do ```sh sudo apt-get install libmpfr-dev ``` + In Fedora, Redhat, CentOS, opensuse, etc, you get these via ```sh sudo dnf install mpfr-devel ``` ## The standard reference to MPFR is ```bibtex @article{FouLHLPZ-2007, author = {Laurent Fousse and Guillaume Hanrot and Vincent Lef\`{e}vre and Patrick P\'{e}lissier and Paul Zimmermann}, title = {MPFR: A multiple-precision binary floating-point library with correct rounding}, year = {2007}, journal = {ACM Trans. Math. Softw.}, volume = {33}, number = {2}, issn = {0098-3500}, pages = {13}, doi = {http://doi.acm.org/10.1145/1236463.1236468}, publisher = {ACM}, address = {New York, NY, USA}, } ``` Rmpfr/build/0000755000176200001440000000000015075721237012450 5ustar liggesusersRmpfr/build/vignette.rds0000644000176200001440000000053115075721237015006 0ustar liggesusersRMO@JA?{Ck#p1&,4+KJoq)%&v߼y;/`l0=me8yt%ɝ>>8gR Mrq6V *MNLJREơmih ti(f\Q\{Il ӄZ0M|-~ BK$`Qf1Zg}{0`ņRY NM{l:S͸lTCW}m=֪F9 4(1Ilk+X_g#(._Sڠ nX6WE^ĥe\q{.xLV5Rmpfr/build/partial.rdb0000644000176200001440000002543215075721217014601 0ustar liggesusers}YwF&%YM^bIMY&)qf[lk,GdJv&@[Ps9gn//s(YXጕsj"``dpoE"HdZ h$Z䪒#SÑȅA˗KE"\x^Z|SUXW#_FE|FTG+C"QBI{Xd%|yXdvz"QXAD/ggO/<X6ǒO6[/WK;6mz5,0"u~ m4!0"2<~G7Ͽ{Uaic#ks&-gܻTEtcL%1Tf٧sՌD"h4QZv̜ku VhGL>=JI|ys[΁~UC]WHtnz.{?Y?̵>Ksg|:?Ja~:~q9Wnpc:ϥW4x4v]uo꒢,+Wc2VTILĊ1yRHx1 - %SwQBX`PL_eFgVWRޖR,ҹ\n:d\|.Lmo)&b%P%S( Vj>Z%2ıSK 23kBeQ_/bUI>J$Shr)4XHa^KuیZȨ?ٗ IӘC&2a(W*I!5"""Q$I+%am=U=")l+]o+˚$x + a^d_LrlC9,HXrS KG[bEOP L dI97=o QS^MPJkTK{Z ڪ;vP'{{)U)$K( )VUzz9E|րo@;wI"o5WϋרƗ:#鷷W)$+ +0)ѡרLe=\ɀH"QCG PC5>G M F~[:WH$2L{tURj8eE1 FҨ𹯡zkoO싚"5[y2J}2 UY鲱; aKa*JESnC&Q;G.D"c{ 27ߘBGƎpZnjyf-NUzlWy4'T̠U~G ]!n@Dt\agDX_Fn@dlA.&=huME/261 })/U !!qJ!OQ=Ms fy(qZG4xoqg6(b}s7U+[>u~`lwl|F"rŪ_5ހoCno\|ctu4zH; ,Koږqd_sF׊.ɴӪcuLO /bђ%;+Fm s;FQcUIۃp4av%KNgI8/̽+`sAWˍ#0 :^'Bشy݈_rHRUx8`4I v#Ek0|StY?@'! 6 ׀͖ l\Q d2q :m*4'a'xm `3\b뒤bQy W%t7>SJlVޱPx|dњ-P`%'(rXÊ@DFZd4v,bThJHd%EQ5Tn4rH_+ЖZ1Jڌ8 Rj^&  u &\D(4F}nXa Cn0LCBDQʵybH8b'wScZUGr 4*aY*=G*|XAXg-޸P }5w]"-2:eV{X) GS ՔW_c|Urh ƨHDC7LOPR>R}A'$3Mj 0 oDw>hmoVC8~Eު)K|8F,R]gxn7|.i: %$&$j=Ma]q!JK # T H$ jI%KDMeɉ4L?-жtdQ[uCnJ~d%6=*`)e^Y!F8V%b@PN& F%g2rTDFq 1bl92(?j+\-]+vr9P^ Fi@נYiHX όܧw~R剪KC8[Uއ}<\8bҤ^EVL3\q(4Y鑇P~tGJ'zj۽ ރisMf`4/Өc6~ G/f8M.`f\u밲$_}XԈAw!@IFj۫ d0BVvy)|?'C\r^G1e㚅㵻ٌ@U#O4N8y$ƀބ.wVz ~"IXi6 ]kwZv4M*qܠ%w7R}WK& Aҟs6 ~B =+E[]7[(H{0` !_;nc;=&Nu AŁ ewrcq9-C*ʿ{]m 2O!(}qLK+?걅L5יR e?<9/vs6@c0ڐkǸQ3m \r@3m fט33GgMF~q(W9Z) C;89Z}B s;rPv zԠFq@və <-8?ݑhnDZr1(Hn݅nFcxdb4:V]KM@B4:^OÇOX)la)8ްtpu.n&Չ`=w0Ns73M@M:NE7}ew X*ͮ i5+Q_aK ~:,l#Q$l#J $1Av#{š|EZ-u#8Pʁykz{mE*Dʮ2+!\P-Q[&!\P-V Q#x"lz4 0wM71- ^]0,LzJÆM]6IV33r@X`+9z۫^2;bXp++EUFhYO 2إEPN>`5)z/^l^=Pfm`)' s#BSd@y'(P)74hP-MK Kwea\Rb`W)@T+X*+ agHΤ(w4QLw'fI)YdRRgIgR},肹1gҀcipIGaZp, Ѽ!pI,iJҖ ?Z,+=Ep8^uK]F kŁ~=n@. ; ӐC.@. q=@rv?`7ɺ`o hYLYL8`3`Af$ 6Nn/v#8=([ XmV8e̲Vf̍ ze޲eٰXoYXoYI7$YGȲ# P.dY8ۤr^.8=LA XJQ6hAbmG7@E@,%y+d+Tt@XU6´)re'cLˁWϤ%_1-8r~v+y|g@!:26qL΀ƴ=Ċ֫Z Fp_˟giy.il:rHӐ4}LCYr0 L!0uL!33 SY\rC30)v&X7͜Ih~j׉v׈EUJFⱢ϶!yHrCFnqBנm}g`|91Q&'p|L+6DHff:泿ff9hfnhVC܏~Bb}r:fp6 6#+$IC_"%Q-6 6{fa#nj njpnshs KF/@\9`sisρ 9w&9@9_-+Rp5c誫$]'9smPդmg "5`6lx~l><|Xg8ږz%Iq5XEkX!Fp`DlZ %%#h+<Hdp| \2xkO/}/\.Zͼh3f7ڝ:7|S"LrZ53-QnW";nVem8ZtH:*-:Fq]uHf؏L *5U.g:IwVحialoX}}1cL ,SSp*/>rطxKwKOuLkq}KK1ě KD>dh^bhyA%Ƚ\c> -- rcYuI `ql7{]CxGנ/ [@SNciEن՝bq}^^ 4{6Io{UcEFш f{cgI(4(6/K0OtГj),@筴%I u$]4Y]f3Rڱnb({P :Կ& *l) a,QԄڤ:D9U,vxx3NU80j&nOt&5sc$(^Wqnb8\o?VIܟZ ]d+(rے_ eW9НV]re]î460<X΄C6;V `p,g2[pQXW[D{O@<l["݂l Q{/'Mt"؂-X!`boU G/Upzͯ2[m~:rג3b>3==1o]!|2;70WΩcfJ@ɳA{ձb+Zj渫FvuqX% [T,i^C#-s }'b)4K\j珁iXIs[`mFߓ hL.8R#t;`x덶_2\ڹdN%J4>!bx V\ntT:F 'G|i 18И_J EjEѓb X-[>Pw/_0pM x<hukM!2"OSC0n}aۘߡ)=6Z34G- |O`rYQc~>xzV-#F1_}w0޿dPdp65e׽@Ƥ7`W*o\=s}Q`XERiۡN UCO6khD7,/vRfx¨7.),=MⅎF˜˸k/DJj 7 vB*߸p؛OKKl'ӗjbֈ"4_euYIɷ'HٌS4_ғk#|vo8\۟ƺdKFv9wU[e}K_!Rżj;]\6D=US6ׯrEzӦ\{hDj0pSdᮁz kuc]E)zb\"G1+^6<㝺!Wy`Aof/>[S .yNvنN8+X2KYQsZBO 9fFZ<E8"/֠)]jRhjBeXr0сrEQK )K'vU@EMi'v,+a)t^cu̽iHRehi25pcpC]S }K4LϦ6/rgd*pYehLu`字%5RVOw/;I/0T2nZdw Jۼ|J:F{;ڎ}$tGˮsEXƟnp) {H 0㧆m3m|=\Ƃ\?Dr'( e[Slޭ2,׬ߠYw6vӹ]8\%"GkS5uIRFS* s$WJ`eVNBGU>оܺn w9_O//v~ B}7Zߣ:f{V3M֒ dYeKٵc.KY(8[ƺ42 r% gK k»lI|nZg,8 Y'.GTU+ݙhJLviO>:rvN{b{KCo>񌆏>֧OF ?dzzw6+b]~txG"|4cZ3t={#MIџ{4z^Pwk zgOAzK-~6773|P A{'ԫUC[OHxXFѫϝ<"C{t՛N3)rDUK"F2L|[jiswsgY0-<#26]5SC/p+ڷA{/dev/null 2>&1 then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case e in #( e) case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac ;; esac fi # Reset variables that may have inherited troublesome values from # the environment. # IFS needs to be set, to space, tab, and newline, in precisely that order. # (If _AS_PATH_WALK were called with IFS unset, it would have the # side effect of setting IFS to empty, thus disabling word splitting.) # Quoting is to prevent editors from complaining about space-tab. as_nl=' ' export as_nl IFS=" "" $as_nl" PS1='$ ' PS2='> ' PS4='+ ' # Ensure predictable behavior from utilities with locale-dependent output. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # We cannot yet rely on "unset" to work, but we need these variables # to be unset--not just set to an empty or harmless value--now, to # avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct # also avoids known problems related to "unset" and subshell syntax # in other old shells (e.g. bash 2.01 and pdksh 5.2.14). for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH do eval test \${$as_var+y} \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done # Ensure that fds 0, 1, and 2 are open. if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi if (exec 3>&2) ; then :; else exec 2>/dev/null; fi # The user is always right. if ${PATH_SEPARATOR+false} :; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac test -r "$as_dir$0" && as_myself=$as_dir$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as 'sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed 'exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case e in #( e) case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ) then : else case e in #( e) exitcode=1; echo positional parameters were not saved. ;; esac fi test x\$exitcode = x0 || exit 1 blah=\$(echo \$(echo blah)) test x\"\$blah\" = xblah || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 test \$(( 1 + 1 )) = 2 || exit 1" if (eval "$as_required") 2>/dev/null then : as_have_required=yes else case e in #( e) as_have_required=no ;; esac fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null then : else case e in #( e) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && as_run=a "$as_shell" -c "$as_bourne_compatible""$as_required" 2>/dev/null then : CONFIG_SHELL=$as_shell as_have_required=yes if as_run=a "$as_shell" -c "$as_bourne_compatible""$as_suggested" 2>/dev/null then : break 2 fi fi done;; esac as_found=false done IFS=$as_save_IFS if $as_found then : else case e in #( e) if { test -f "$SHELL" || test -f "$SHELL.exe"; } && as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null then : CONFIG_SHELL=$SHELL as_have_required=yes fi ;; esac fi if test "x$CONFIG_SHELL" != x then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed 'exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno then : printf "%s\n" "$0: This script requires a shell more modern than all" printf "%s\n" "$0: the shells that I found on your system." if test ${ZSH_VERSION+y} ; then printf "%s\n" "$0: In particular, zsh $ZSH_VERSION has bugs and should" printf "%s\n" "$0: be upgraded to zsh 4.3.4 or later." else printf "%s\n" "$0: Please tell bug-autoconf@gnu.org about your system, $0: including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi ;; esac fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null then : eval 'as_fn_append () { eval $1+=\$2 }' else case e in #( e) as_fn_append () { eval $1=\$$1\$2 } ;; esac fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null then : eval 'as_fn_arith () { as_val=$(( $* )) }' else case e in #( e) as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } ;; esac fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi printf "%s\n" "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' t clear :clear s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { printf "%s\n" "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } # Determine whether it's possible to make 'echo' print without a newline. # These variables are no longer used directly by Autoconf, but are AC_SUBSTed # for compatibility with existing Makefiles. ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac # For backward compatibility with old third-party macros, we provide # the shell variables $as_echo and $as_echo_n. New code should use # AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. as_echo='printf %s\n' as_echo_n='printf %s' rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both 'ln -s file dir' and 'ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; 'ln -s' creates a wrapper executable. # In both cases, we have to default to 'cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_sed_cpp="y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" as_tr_cpp="eval sed '$as_sed_cpp'" # deprecated # Sed expression to map a string onto a valid variable name. as_sed_sh="y%*+%pp%;s%[^_$as_cr_alnum]%_%g" as_tr_sh="eval sed '$as_sed_sh'" # deprecated test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='' PACKAGE_TARNAME='' PACKAGE_VERSION='' PACKAGE_STRING='' PACKAGE_BUGREPORT='' PACKAGE_URL='' ac_unique_file="Rmpfr" ac_unique_file="DESCRIPTION" # Factoring default headers for most tests. ac_includes_default="\ #include #ifdef HAVE_STDIO_H # include #endif #ifdef HAVE_STDLIB_H # include #endif #ifdef HAVE_STRING_H # include #endif #ifdef HAVE_INTTYPES_H # include #endif #ifdef HAVE_STDINT_H # include #endif #ifdef HAVE_STRINGS_H # include #endif #ifdef HAVE_SYS_TYPES_H # include #endif #ifdef HAVE_SYS_STAT_H # include #endif #ifdef HAVE_UNISTD_H # include #endif" ac_header_c_list= ac_subst_vars='LTLIBOBJS LIBOBJS MPFR_LDFLAGS MPFR_CPPFLAGS CPP OBJEXT EXEEXT ac_ct_CC CPPFLAGS LDFLAGS CFLAGS CC target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir runstatedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking with_mpfr_include with_mpfr_lib ' ac_precious_vars='build_alias host_alias target_alias CC CFLAGS LDFLAGS LIBS CPPFLAGS CPP' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -runstatedir | --runstatedir | --runstatedi | --runstated \ | --runstate | --runstat | --runsta | --runst | --runs \ | --run | --ru | --r) ac_prev=runstatedir ;; -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ | --run=* | --ru=* | --r=*) runstatedir=$ac_optarg ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: '$ac_option' Try '$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: '$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. printf "%s\n" "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && printf "%s\n" "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir runstatedir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: '$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but 'cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF 'configure' configures this package to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print 'checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for '--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or '..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, 'make install' will install all the files in '$ac_default_prefix/bin', '$ac_default_prefix/lib' etc. You can specify an installation prefix other than '$ac_default_prefix' using '--prefix', for instance '--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then cat <<\_ACEOF Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-mpfr-include=INCLUDE_PATH the location of MPFR header files --with-mpfr-lib=LIB_PATH the location of MPFR libraries Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory LIBS libraries to pass to the linker, e.g. -l CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory CPP C preprocessor Use these variables to override the choices made by 'configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to the package provider. _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for configure.gnu first; this name is used for a wrapper for # Metaconfig's "Configure" on case-insensitive file systems. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else printf "%s\n" "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF configure generated by GNU Autoconf 2.72 Copyright (C) 2023 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## # ac_fn_c_try_compile LINENO # -------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest.beam if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext then : ac_retval=0 else case e in #( e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 ;; esac fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_compile # ac_fn_c_try_cpp LINENO # ---------------------- # Try to preprocess conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_cpp () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } > conftest.i && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err } then : ac_retval=0 else case e in #( e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 ;; esac fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_cpp # ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists and can be compiled using the include files in # INCLUDES, setting the cache variable VAR accordingly. ac_fn_c_check_header_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 printf %s "checking for $2... " >&6; } if eval test \${$3+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO" then : eval "$3=yes" else case e in #( e) eval "$3=no" ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 printf "%s\n" "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_compile # ac_fn_c_try_link LINENO # ----------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_link () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest.beam conftest$ac_exeext if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || test -x conftest$ac_exeext } then : ac_retval=0 else case e in #( e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 ;; esac fi # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would # interfere with the next link command; also delete a directory that is # left behind by Apple's compiler. We do this before executing the actions. rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_link # ac_fn_c_try_run LINENO # ---------------------- # Try to run conftest.$ac_ext, and return whether this succeeded. Assumes that # executables *can* be run. ac_fn_c_try_run () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; } then : ac_retval=0 else case e in #( e) printf "%s\n" "$as_me: program exited with status $ac_status" >&5 printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=$ac_status ;; esac fi rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_run # ac_fn_c_compute_int LINENO EXPR VAR INCLUDES # -------------------------------------------- # Tries to find the compile-time value of EXPR in a program that includes # INCLUDES, setting VAR accordingly. Returns whether the value could be # computed ac_fn_c_compute_int () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if test "$cross_compiling" = yes; then # Depending upon the size, compute the lo and hi bounds. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main (void) { static int test_array [1 - 2 * !(($2) >= 0)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_lo=0 ac_mid=0 while :; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main (void) { static int test_array [1 - 2 * !(($2) <= $ac_mid)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_hi=$ac_mid; break else case e in #( e) as_fn_arith $ac_mid + 1 && ac_lo=$as_val if test $ac_lo -le $ac_mid; then ac_lo= ac_hi= break fi as_fn_arith 2 '*' $ac_mid + 1 && ac_mid=$as_val ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext done else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main (void) { static int test_array [1 - 2 * !(($2) < 0)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_hi=-1 ac_mid=-1 while :; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main (void) { static int test_array [1 - 2 * !(($2) >= $ac_mid)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_lo=$ac_mid; break else case e in #( e) as_fn_arith '(' $ac_mid ')' - 1 && ac_hi=$as_val if test $ac_mid -le $ac_hi; then ac_lo= ac_hi= break fi as_fn_arith 2 '*' $ac_mid && ac_mid=$as_val ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext done else case e in #( e) ac_lo= ac_hi= ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext # Binary search between lo and hi bounds. while test "x$ac_lo" != "x$ac_hi"; do as_fn_arith '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo && ac_mid=$as_val cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main (void) { static int test_array [1 - 2 * !(($2) <= $ac_mid)]; test_array [0] = 0; return test_array [0]; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_hi=$ac_mid else case e in #( e) as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext done case $ac_lo in #(( ?*) eval "$3=\$ac_lo"; ac_retval=0 ;; '') ac_retval=1 ;; esac else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 static long int longval (void) { return $2; } static unsigned long int ulongval (void) { return $2; } #include #include int main (void) { FILE *f = fopen ("conftest.val", "w"); if (! f) return 1; if (($2) < 0) { long int i = longval (); if (i != ($2)) return 1; fprintf (f, "%ld", i); } else { unsigned long int i = ulongval (); if (i != ($2)) return 1; fprintf (f, "%lu", i); } /* Do not output a trailing newline, as this causes \r\n confusion on some platforms. */ return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO" then : echo >>conftest.val; read $3 config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by $as_me, which was generated by GNU Autoconf 2.72. Invocation command line was $ $0$ac_configure_args_raw _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac printf "%s\n" "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Sanitize IFS. IFS=" "" $as_nl" # Save into config.log some information that might help in debugging. { echo printf "%s\n" "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo printf "%s\n" "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac printf "%s\n" "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then printf "%s\n" "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac printf "%s\n" "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then printf "%s\n" "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && printf "%s\n" "$as_me: caught signal $ac_signal" printf "%s\n" "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h printf "%s\n" "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. printf "%s\n" "#define PACKAGE_NAME \"$PACKAGE_NAME\"" >>confdefs.h printf "%s\n" "#define PACKAGE_TARNAME \"$PACKAGE_TARNAME\"" >>confdefs.h printf "%s\n" "#define PACKAGE_VERSION \"$PACKAGE_VERSION\"" >>confdefs.h printf "%s\n" "#define PACKAGE_STRING \"$PACKAGE_STRING\"" >>confdefs.h printf "%s\n" "#define PACKAGE_BUGREPORT \"$PACKAGE_BUGREPORT\"" >>confdefs.h printf "%s\n" "#define PACKAGE_URL \"$PACKAGE_URL\"" >>confdefs.h # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. if test -n "$CONFIG_SITE"; then ac_site_files="$CONFIG_SITE" elif test "x$prefix" != xNONE; then ac_site_files="$prefix/share/config.site $prefix/etc/config.site" else ac_site_files="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" fi for ac_site_file in $ac_site_files do case $ac_site_file in #( */*) : ;; #( *) : ac_site_file=./$ac_site_file ;; esac if test -f "$ac_site_file" && test -r "$ac_site_file"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See 'config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 printf "%s\n" "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 printf "%s\n" "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Test code for whether the C compiler supports C89 (global declarations) ac_c_conftest_c89_globals=' /* Does the compiler advertise C89 conformance? Do not test the value of __STDC__, because some compilers set it to 0 while being otherwise adequately conformant. */ #if !defined __STDC__ # error "Compiler does not advertise C89 conformance" #endif #include #include struct stat; /* Most of the following tests are stolen from RCS 5.7 src/conf.sh. */ struct buf { int x; }; struct buf * (*rcsopen) (struct buf *, struct stat *, int); static char *e (char **p, int i) { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* C89 style stringification. */ #define noexpand_stringify(a) #a const char *stringified = noexpand_stringify(arbitrary+token=sequence); /* C89 style token pasting. Exercises some of the corner cases that e.g. old MSVC gets wrong, but not very hard. */ #define noexpand_concat(a,b) a##b #define expand_concat(a,b) noexpand_concat(a,b) extern int vA; extern int vbee; #define aye A #define bee B int *pvA = &expand_concat(v,aye); int *pvbee = &noexpand_concat(v,bee); /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not \xHH hex character constants. These do not provoke an error unfortunately, instead are silently treated as an "x". The following induces an error, until -std is added to get proper ANSI mode. Curiously \x00 != x always comes out true, for an array size at least. It is necessary to write \x00 == 0 to get something that is true only with -std. */ int osf4_cc_array ['\''\x00'\'' == 0 ? 1 : -1]; /* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters inside strings and character constants. */ #define FOO(x) '\''x'\'' int xlc6_cc_array[FOO(a) == '\''x'\'' ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, int *(*)(struct buf *, struct stat *, int), int, int);' # Test code for whether the C compiler supports C89 (body of main). ac_c_conftest_c89_main=' ok |= (argc == 0 || f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]); ' # Test code for whether the C compiler supports C99 (global declarations) ac_c_conftest_c99_globals=' /* Does the compiler advertise C99 conformance? */ #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L # error "Compiler does not advertise C99 conformance" #endif // See if C++-style comments work. #include extern int puts (const char *); extern int printf (const char *, ...); extern int dprintf (int, const char *, ...); extern void *malloc (size_t); extern void free (void *); // Check varargs macros. These examples are taken from C99 6.10.3.5. // dprintf is used instead of fprintf to avoid needing to declare // FILE and stderr. #define debug(...) dprintf (2, __VA_ARGS__) #define showlist(...) puts (#__VA_ARGS__) #define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__)) static void test_varargs_macros (void) { int x = 1234; int y = 5678; debug ("Flag"); debug ("X = %d\n", x); showlist (The first, second, and third items.); report (x>y, "x is %d but y is %d", x, y); } // Check long long types. #define BIG64 18446744073709551615ull #define BIG32 4294967295ul #define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0) #if !BIG_OK #error "your preprocessor is broken" #endif #if BIG_OK #else #error "your preprocessor is broken" #endif static long long int bignum = -9223372036854775807LL; static unsigned long long int ubignum = BIG64; struct incomplete_array { int datasize; double data[]; }; struct named_init { int number; const wchar_t *name; double average; }; typedef const char *ccp; static inline int test_restrict (ccp restrict text) { // Iterate through items via the restricted pointer. // Also check for declarations in for loops. for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i) continue; return 0; } // Check varargs and va_copy. static bool test_varargs (const char *format, ...) { va_list args; va_start (args, format); va_list args_copy; va_copy (args_copy, args); const char *str = ""; int number = 0; float fnumber = 0; while (*format) { switch (*format++) { case '\''s'\'': // string str = va_arg (args_copy, const char *); break; case '\''d'\'': // int number = va_arg (args_copy, int); break; case '\''f'\'': // float fnumber = va_arg (args_copy, double); break; default: break; } } va_end (args_copy); va_end (args); return *str && number && fnumber; } ' # Test code for whether the C compiler supports C99 (body of main). ac_c_conftest_c99_main=' // Check bool. _Bool success = false; success |= (argc != 0); // Check restrict. if (test_restrict ("String literal") == 0) success = true; char *restrict newvar = "Another string"; // Check varargs. success &= test_varargs ("s, d'\'' f .", "string", 65, 34.234); test_varargs_macros (); // Check flexible array members. struct incomplete_array *ia = malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10)); ia->datasize = 10; for (int i = 0; i < ia->datasize; ++i) ia->data[i] = i * 1.234; // Work around memory leak warnings. free (ia); // Check named initializers. struct named_init ni = { .number = 34, .name = L"Test wide string", .average = 543.34343, }; ni.number = 58; int dynamic_array[ni.number]; dynamic_array[0] = argv[0][0]; dynamic_array[ni.number - 1] = 543; // work around unused variable warnings ok |= (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == '\''x'\'' || dynamic_array[ni.number - 1] != 543); ' # Test code for whether the C compiler supports C11 (global declarations) ac_c_conftest_c11_globals=' /* Does the compiler advertise C11 conformance? */ #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L # error "Compiler does not advertise C11 conformance" #endif // Check _Alignas. char _Alignas (double) aligned_as_double; char _Alignas (0) no_special_alignment; extern char aligned_as_int; char _Alignas (0) _Alignas (int) aligned_as_int; // Check _Alignof. enum { int_alignment = _Alignof (int), int_array_alignment = _Alignof (int[100]), char_alignment = _Alignof (char) }; _Static_assert (0 < -_Alignof (int), "_Alignof is signed"); // Check _Noreturn. int _Noreturn does_not_return (void) { for (;;) continue; } // Check _Static_assert. struct test_static_assert { int x; _Static_assert (sizeof (int) <= sizeof (long int), "_Static_assert does not work in struct"); long int y; }; // Check UTF-8 literals. #define u8 syntax error! char const utf8_literal[] = u8"happens to be ASCII" "another string"; // Check duplicate typedefs. typedef long *long_ptr; typedef long int *long_ptr; typedef long_ptr long_ptr; // Anonymous structures and unions -- taken from C11 6.7.2.1 Example 1. struct anonymous { union { struct { int i; int j; }; struct { int k; long int l; } w; }; int m; } v1; ' # Test code for whether the C compiler supports C11 (body of main). ac_c_conftest_c11_main=' _Static_assert ((offsetof (struct anonymous, i) == offsetof (struct anonymous, w.k)), "Anonymous union alignment botch"); v1.i = 2; v1.w.k = 5; ok |= v1.i != 5; ' # Test code for whether the C compiler supports C11 (complete). ac_c_conftest_c11_program="${ac_c_conftest_c89_globals} ${ac_c_conftest_c99_globals} ${ac_c_conftest_c11_globals} int main (int argc, char **argv) { int ok = 0; ${ac_c_conftest_c89_main} ${ac_c_conftest_c99_main} ${ac_c_conftest_c11_main} return ok; } " # Test code for whether the C compiler supports C99 (complete). ac_c_conftest_c99_program="${ac_c_conftest_c89_globals} ${ac_c_conftest_c99_globals} int main (int argc, char **argv) { int ok = 0; ${ac_c_conftest_c89_main} ${ac_c_conftest_c99_main} return ok; } " # Test code for whether the C compiler supports C89 (complete). ac_c_conftest_c89_program="${ac_c_conftest_c89_globals} int main (int argc, char **argv) { int ok = 0; ${ac_c_conftest_c89_main} return ok; } " as_fn_append ac_header_c_list " stdio.h stdio_h HAVE_STDIO_H" as_fn_append ac_header_c_list " stdlib.h stdlib_h HAVE_STDLIB_H" as_fn_append ac_header_c_list " string.h string_h HAVE_STRING_H" as_fn_append ac_header_c_list " inttypes.h inttypes_h HAVE_INTTYPES_H" as_fn_append ac_header_c_list " stdint.h stdint_h HAVE_STDINT_H" as_fn_append ac_header_c_list " strings.h strings_h HAVE_STRINGS_H" as_fn_append ac_header_c_list " sys/stat.h sys_stat_h HAVE_SYS_STAT_H" as_fn_append ac_header_c_list " sys/types.h sys_types_h HAVE_SYS_TYPES_H" as_fn_append ac_header_c_list " unistd.h unistd_h HAVE_UNISTD_H" # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' was set to '$ac_old_val' in the previous run" >&5 printf "%s\n" "$as_me: error: '$ac_var' was set to '$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' was not set in the previous run" >&5 printf "%s\n" "$as_me: error: '$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' has changed since the previous run:" >&5 printf "%s\n" "$as_me: error: '$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in '$ac_var' since the previous run:" >&5 printf "%s\n" "$as_me: warning: ignoring whitespace changes in '$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: '$ac_old_val'" >&5 printf "%s\n" "$as_me: former value: '$ac_old_val'" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: '$ac_new_val'" >&5 printf "%s\n" "$as_me: current value: '$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`printf "%s\n" "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run '${MAKE-make} distclean' and/or 'rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_config_headers="$ac_config_headers src/config.h" # Check whether --with-mpfr-include was given. if test ${with_mpfr_include+y} then : withval=$with_mpfr_include; mpfr_include_path=$withval fi if test -n "$mpfr_include_path" ; then MPFR_CPPFLAGS="-I${mpfr_include_path}" elif test -n "${mpfr_INCLUDE}" ; then MPFR_CPPFLAGS="-I${mpfr_INCLUDE}" fi # Check whether --with-mpfr-lib was given. if test ${with_mpfr_lib+y} then : withval=$with_mpfr_lib; mpfr_lib_path=$withval fi if test -n "$mpfr_lib_path" ; then MPFR_LDFLAGS="-L$mpfr_lib_path ${LDFLAGS}" elif test -n "${mpfr_LDFLAGS}" ; then MPFR_LDFLAGS="-L${mpfr_LDFLAGS} ${LDFLAGS}" fi : ${R_HOME=`R RHOME`} if test -z "${R_HOME}"; then echo "could not determine R_HOME" exit 1 fi CC=`"${R_HOME}/bin/R" CMD config CC` CFLAGS=`"${R_HOME}/bin/R" CMD config CFLAGS` CPPFLAGS=`"${R_HOME}/bin/R" CMD config CPPFLAGS` LDFLAGS=`"${R_HOME}/bin/R" CMD config LDFLAGS` ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then if test "$as_dir$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift if test $# != 0; then # We chose a different compiler from the bogus one. # However, it has the same basename, so the bogon will be chosen # first if we set CC to just the basename; use the full file name. shift ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@" fi fi fi ;; esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then for ac_prog in cl.exe do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in cl.exe do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$ac_ct_CC" && break done if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}clang", so it can be a program name with args. set dummy ${ac_tool_prefix}clang; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}clang" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "clang", so it can be a program name with args. set dummy clang; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else case e in #( e) if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="clang" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi ;; esac fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi fi test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH See 'config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion -version; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 printf %s "checking whether the C compiler works... " >&6; } ac_link_default=`printf "%s\n" "$ac_link" | sed 's/ -o *conftest[^ ]*//'` # The possible output files: ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" ac_rmfiles= for ac_file in $ac_files do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; * ) ac_rmfiles="$ac_rmfiles $ac_file";; esac done rm -f $ac_rmfiles if { { ac_try="$ac_link_default" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : # Autoconf-2.13 could set the ac_cv_exeext variable to 'no'. # So ignore a value of 'no', otherwise this would lead to 'EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. for ac_file in $ac_files '' do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) if test ${ac_cv_exeext+y} && test "$ac_cv_exeext" != no; then :; else ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not # safe: cross compilers may not add the suffix if given an '-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. break;; * ) break;; esac done test "$ac_cv_exeext" = no && ac_cv_exeext= else case e in #( e) ac_file='' ;; esac fi if test -z "$ac_file" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error 77 "C compiler cannot create executables See 'config.log' for more details" "$LINENO" 5; } else case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 printf %s "checking for C compiler default output file name... " >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 printf "%s\n" "$ac_file" >&6; } ac_exeext=$ac_cv_exeext rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 printf %s "checking for suffix of executables... " >&6; } if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : # If both 'conftest.exe' and 'conftest' are 'present' (well, observable) # catch 'conftest.exe'. For instance with Cygwin, 'ls conftest' will # work properly (i.e., refer to 'conftest.exe'), while it won't with # 'rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` break;; * ) break;; esac done else case e in #( e) { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link See 'config.log' for more details" "$LINENO" 5; } ;; esac fi rm -f conftest conftest$ac_cv_exeext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 printf "%s\n" "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { FILE *f = fopen ("conftest.out", "w"); if (!f) return 1; return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF ac_clean_files="$ac_clean_files conftest.out" # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 printf %s "checking whether we are cross compiling... " >&6; } if test "$cross_compiling" != yes; then { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } if { ac_try='./conftest$ac_cv_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error 77 "cannot run C compiled programs. If you meant to cross compile, use '--host'. See 'config.log' for more details" "$LINENO" 5; } fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 printf "%s\n" "$cross_compiling" >&6; } rm -f conftest.$ac_ext conftest$ac_cv_exeext \ conftest.o conftest.obj conftest.out ac_clean_files=$ac_clean_files_save { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 printf %s "checking for suffix of object files... " >&6; } if test ${ac_cv_objext+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF rm -f conftest.o conftest.obj if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : for ac_file in conftest.o conftest.obj conftest.*; do test -f "$ac_file" || continue; case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else case e in #( e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile See 'config.log' for more details" "$LINENO" 5; } ;; esac fi rm -f conftest.$ac_cv_objext conftest.$ac_ext ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 printf "%s\n" "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5 printf %s "checking whether the compiler supports GNU C... " >&6; } if test ${ac_cv_c_compiler_gnu+y} then : printf %s "(cached) " >&6 else case e in #( e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_compiler_gnu=yes else case e in #( e) ac_compiler_gnu=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; } ac_compiler_gnu=$ac_cv_c_compiler_gnu if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+y} ac_save_CFLAGS=$CFLAGS { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 printf %s "checking whether $CC accepts -g... " >&6; } if test ${ac_cv_prog_cc_g+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes else case e in #( e) CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : else case e in #( e) ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 printf "%s\n" "$ac_cv_prog_cc_g" >&6; } if test $ac_test_CFLAGS; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi ac_prog_cc_stdc=no if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5 printf %s "checking for $CC option to enable C11 features... " >&6; } if test ${ac_cv_prog_cc_c11+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_cv_prog_cc_c11=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c11_program _ACEOF for ac_arg in '' -std=gnu11 do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c11=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c11" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC ;; esac fi if test "x$ac_cv_prog_cc_c11" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else case e in #( e) if test "x$ac_cv_prog_cc_c11" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5 printf "%s\n" "$ac_cv_prog_cc_c11" >&6; } CC="$CC $ac_cv_prog_cc_c11" ;; esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11 ac_prog_cc_stdc=c11 ;; esac fi fi if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5 printf %s "checking for $CC option to enable C99 features... " >&6; } if test ${ac_cv_prog_cc_c99+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_cv_prog_cc_c99=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c99_program _ACEOF for ac_arg in '' -std=gnu99 -std=c99 -c99 -qlanglvl=extc1x -qlanglvl=extc99 -AC99 -D_STDC_C99= do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c99=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c99" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC ;; esac fi if test "x$ac_cv_prog_cc_c99" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else case e in #( e) if test "x$ac_cv_prog_cc_c99" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 printf "%s\n" "$ac_cv_prog_cc_c99" >&6; } CC="$CC $ac_cv_prog_cc_c99" ;; esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 ac_prog_cc_stdc=c99 ;; esac fi fi if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5 printf %s "checking for $CC option to enable C89 features... " >&6; } if test ${ac_cv_prog_cc_c89+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c89_program _ACEOF for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c89=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC ;; esac fi if test "x$ac_cv_prog_cc_c89" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else case e in #( e) if test "x$ac_cv_prog_cc_c89" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else case e in #( e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 printf "%s\n" "$ac_cv_prog_cc_c89" >&6; } CC="$CC $ac_cv_prog_cc_c89" ;; esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 ac_prog_cc_stdc=c89 ;; esac fi fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 printf %s "checking how to run the C preprocessor... " >&6; } # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if test ${ac_cv_prog_CPP+y} then : printf %s "(cached) " >&6 else case e in #( e) # Double quotes because $CC needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" cpp /lib/cpp do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO" then : else case e in #( e) # Broken: fails on valid input. continue ;; esac fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO" then : # Broken: success on invalid input. continue else case e in #( e) # Passes both tests. ac_preproc_ok=: break ;; esac fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of 'break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok then : break fi done ac_cv_prog_CPP=$CPP ;; esac fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 printf "%s\n" "$CPP" >&6; } ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO" then : else case e in #( e) # Broken: fails on valid input. continue ;; esac fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO" then : # Broken: success on invalid input. continue else case e in #( e) # Passes both tests. ac_preproc_ok=: break ;; esac fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of 'break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok then : else case e in #( e) { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "C preprocessor \"$CPP\" fails sanity check See 'config.log' for more details" "$LINENO" 5; } ;; esac fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu CPPFLAGS="${CPPFLAGS} ${MPFR_CPPFLAGS}" LDFLAGS="${LDFLAGS} ${MPFR_LDFLAGS}" ac_header= ac_cache= for ac_item in $ac_header_c_list do if test $ac_cache; then ac_fn_c_check_header_compile "$LINENO" $ac_header ac_cv_header_$ac_cache "$ac_includes_default" if eval test \"x\$ac_cv_header_$ac_cache\" = xyes; then printf "%s\n" "#define $ac_item 1" >> confdefs.h fi ac_header= ac_cache= elif test $ac_header; then ac_cache=$ac_item else ac_header=$ac_item fi done if test $ac_cv_header_stdlib_h = yes && test $ac_cv_header_string_h = yes then : printf "%s\n" "#define STDC_HEADERS 1" >>confdefs.h fi ac_fn_c_check_header_compile "$LINENO" "mpfr.h" "ac_cv_header_mpfr_h" "$ac_includes_default" if test "x$ac_cv_header_mpfr_h" = xyes then : else case e in #( e) as_fn_error $? "Header file mpfr.h not found; maybe use --with-mpfr-include=INCLUDE_PATH" "$LINENO" 5 ;; esac fi ac_fn_c_check_header_compile "$LINENO" "gmp.h" "ac_cv_header_gmp_h" "$ac_includes_default" if test "x$ac_cv_header_gmp_h" = xyes then : else case e in #( e) as_fn_error $? "Header file gmp.h not found; maybe use --with-mpfr-include=INCLUDE_PATH" "$LINENO" 5 ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for __gmpz_init in -lgmp" >&5 printf %s "checking for __gmpz_init in -lgmp... " >&6; } if test ${ac_cv_lib_gmp___gmpz_init+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_check_lib_save_LIBS=$LIBS LIBS="-lgmp $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char __gmpz_init (void); int main (void) { return __gmpz_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_gmp___gmpz_init=yes else case e in #( e) ac_cv_lib_gmp___gmpz_init=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gmp___gmpz_init" >&5 printf "%s\n" "$ac_cv_lib_gmp___gmpz_init" >&6; } if test "x$ac_cv_lib_gmp___gmpz_init" = xyes then : printf "%s\n" "#define HAVE_LIBGMP 1" >>confdefs.h LIBS="-lgmp $LIBS" else case e in #( e) as_fn_error $? "GNU MP not found, see README" "$LINENO" 5 ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for mpfr_init in -lmpfr" >&5 printf %s "checking for mpfr_init in -lmpfr... " >&6; } if test ${ac_cv_lib_mpfr_mpfr_init+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_check_lib_save_LIBS=$LIBS LIBS="-lmpfr $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char mpfr_init (void); int main (void) { return mpfr_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_mpfr_mpfr_init=yes else case e in #( e) ac_cv_lib_mpfr_mpfr_init=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpfr_mpfr_init" >&5 printf "%s\n" "$ac_cv_lib_mpfr_mpfr_init" >&6; } if test "x$ac_cv_lib_mpfr_mpfr_init" = xyes then : printf "%s\n" "#define HAVE_LIBMPFR 1" >>confdefs.h LIBS="-lmpfr $LIBS" else case e in #( e) as_fn_error $? "MPFR Library not found, see README" "$LINENO" 5 ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for mpfr_digamma in -lmpfr" >&5 printf %s "checking for mpfr_digamma in -lmpfr... " >&6; } if test ${ac_cv_lib_mpfr_mpfr_digamma+y} then : printf %s "(cached) " >&6 else case e in #( e) ac_check_lib_save_LIBS=$LIBS LIBS="-lmpfr $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. The 'extern "C"' is for builds by C++ compilers; although this is not generally supported in C code supporting it here has little cost and some practical benefit (sr 110532). */ #ifdef __cplusplus extern "C" #endif char mpfr_digamma (void); int main (void) { return mpfr_digamma (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_mpfr_mpfr_digamma=yes else case e in #( e) ac_cv_lib_mpfr_mpfr_digamma=no ;; esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpfr_mpfr_digamma" >&5 printf "%s\n" "$ac_cv_lib_mpfr_mpfr_digamma" >&6; } if test "x$ac_cv_lib_mpfr_mpfr_digamma" = xyes then : printf "%s\n" "#define HAVE_LIBMPFR 1" >>confdefs.h LIBS="-lmpfr $LIBS" else case e in #( e) as_fn_error $? "MPFR Library must be at least version 3.0.0, see README" "$LINENO" 5 ;; esac fi # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like 'int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of mp_limb_t" >&5 printf %s "checking size of mp_limb_t... " >&6; } if test ${ac_cv_sizeof_mp_limb_t+y} then : printf %s "(cached) " >&6 else case e in #( e) if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (mp_limb_t))" "ac_cv_sizeof_mp_limb_t" "#include " then : else case e in #( e) if test "$ac_cv_type_mp_limb_t" = yes; then { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (mp_limb_t) See 'config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_mp_limb_t=0 fi ;; esac fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_mp_limb_t" >&5 printf "%s\n" "$ac_cv_sizeof_mp_limb_t" >&6; } printf "%s\n" "#define SIZEOF_MP_LIMB_T $ac_cv_sizeof_mp_limb_t" >>confdefs.h # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like 'int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of mpfr_prec_t" >&5 printf %s "checking size of mpfr_prec_t... " >&6; } if test ${ac_cv_sizeof_mpfr_prec_t+y} then : printf %s "(cached) " >&6 else case e in #( e) if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (mpfr_prec_t))" "ac_cv_sizeof_mpfr_prec_t" "#include " then : else case e in #( e) if test "$ac_cv_type_mpfr_prec_t" = yes; then { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (mpfr_prec_t) See 'config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_mpfr_prec_t=0 fi ;; esac fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_mpfr_prec_t" >&5 printf "%s\n" "$ac_cv_sizeof_mpfr_prec_t" >&6; } printf "%s\n" "#define SIZEOF_MPFR_PREC_T $ac_cv_sizeof_mpfr_prec_t" >>confdefs.h # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like 'int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of mpfr_exp_t" >&5 printf %s "checking size of mpfr_exp_t... " >&6; } if test ${ac_cv_sizeof_mpfr_exp_t+y} then : printf %s "(cached) " >&6 else case e in #( e) if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (mpfr_exp_t))" "ac_cv_sizeof_mpfr_exp_t" "#include " then : else case e in #( e) if test "$ac_cv_type_mpfr_exp_t" = yes; then { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (mpfr_exp_t) See 'config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_mpfr_exp_t=0 fi ;; esac fi ;; esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_mpfr_exp_t" >&5 printf "%s\n" "$ac_cv_sizeof_mpfr_exp_t" >&6; } printf "%s\n" "#define SIZEOF_MPFR_EXP_T $ac_cv_sizeof_mpfr_exp_t" >>confdefs.h ac_config_files="$ac_config_files src/Makevars" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # 'ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* 'ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # 'set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # 'set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test ${\1+y} || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then if test "x$cache_file" != "x/dev/null"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 printf "%s\n" "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 printf "%s\n" "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' DEFS=-DHAVE_CONFIG_H ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`printf "%s\n" "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 printf "%s\n" "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case e in #( e) case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac ;; esac fi # Reset variables that may have inherited troublesome values from # the environment. # IFS needs to be set, to space, tab, and newline, in precisely that order. # (If _AS_PATH_WALK were called with IFS unset, it would have the # side effect of setting IFS to empty, thus disabling word splitting.) # Quoting is to prevent editors from complaining about space-tab. as_nl=' ' export as_nl IFS=" "" $as_nl" PS1='$ ' PS2='> ' PS4='+ ' # Ensure predictable behavior from utilities with locale-dependent output. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # We cannot yet rely on "unset" to work, but we need these variables # to be unset--not just set to an empty or harmless value--now, to # avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct # also avoids known problems related to "unset" and subshell syntax # in other old shells (e.g. bash 2.01 and pdksh 5.2.14). for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH do eval test \${$as_var+y} \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done # Ensure that fds 0, 1, and 2 are open. if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi if (exec 3>&2) ; then :; else exec 2>/dev/null; fi # The user is always right. if ${PATH_SEPARATOR+false} :; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac test -r "$as_dir$0" && as_myself=$as_dir$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as 'sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi printf "%s\n" "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null then : eval 'as_fn_append () { eval $1+=\$2 }' else case e in #( e) as_fn_append () { eval $1=\$$1\$2 } ;; esac fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null then : eval 'as_fn_arith () { as_val=$(( $* )) }' else case e in #( e) as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } ;; esac fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits # Determine whether it's possible to make 'echo' print without a newline. # These variables are no longer used directly by Autoconf, but are AC_SUBSTed # for compatibility with existing Makefiles. ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac # For backward compatibility with old third-party macros, we provide # the shell variables $as_echo and $as_echo_n. New code should use # AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. as_echo='printf %s\n' as_echo_n='printf %s' rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both 'ln -s file dir' and 'ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; 'ln -s' creates a wrapper executable. # In both cases, we have to default to 'cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_sed_cpp="y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" as_tr_cpp="eval sed '$as_sed_cpp'" # deprecated # Sed expression to map a string onto a valid variable name. as_sed_sh="y%*+%pp%;s%[^_$as_cr_alnum]%_%g" as_tr_sh="eval sed '$as_sed_sh'" # deprecated exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by $as_me, which was generated by GNU Autoconf 2.72. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac case $ac_config_headers in *" "*) set x $ac_config_headers; shift; ac_config_headers=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" config_headers="$ac_config_headers" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ '$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE --header=FILE[:TEMPLATE] instantiate the configuration header FILE Configuration files: $config_files Configuration headers: $config_headers Report bugs to the package provider." _ACEOF ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"` ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"` cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ config.status configured by $0, generated by GNU Autoconf 2.72, with options \\"\$ac_cs_config\\" Copyright (C) 2023 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) printf "%s\n" "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) printf "%s\n" "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --header | --heade | --head | --hea ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append CONFIG_HEADERS " '$ac_optarg'" ac_need_defaults=false;; --he | --h) # Conflict between --help and --header as_fn_error $? "ambiguous option: '$1' Try '$0 --help' for more information.";; --help | --hel | -h ) printf "%s\n" "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: '$1' Try '$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \printf "%s\n" "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX printf "%s\n" "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "src/config.h") CONFIG_HEADERS="$CONFIG_HEADERS src/config.h" ;; "src/Makevars") CONFIG_FILES="$CONFIG_FILES src/Makevars" ;; *) as_fn_error $? "invalid argument: '$ac_config_target'" "$LINENO" 5;; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test ${CONFIG_FILES+y} || CONFIG_FILES=$config_files test ${CONFIG_HEADERS+y} || CONFIG_HEADERS=$config_headers fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to '$tmp'. $debug || { tmp= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with './config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" # Set up the scripts for CONFIG_HEADERS section. # No need to generate them if there are no CONFIG_HEADERS. # This happens for instance with './config.status Makefile'. if test -n "$CONFIG_HEADERS"; then cat >"$ac_tmp/defines.awk" <<\_ACAWK || BEGIN { _ACEOF # Transform confdefs.h into an awk script 'defines.awk', embedded as # here-document in config.status, that substitutes the proper values into # config.h.in to produce config.h. # Create a delimiter string that does not exist in confdefs.h, to ease # handling of long lines. ac_delim='%!_!# ' for ac_last_try in false false :; do ac_tt=`sed -n "/$ac_delim/p" confdefs.h` if test -z "$ac_tt"; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done # For the awk script, D is an array of macro values keyed by name, # likewise P contains macro parameters if any. Preserve backslash # newline sequences. ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* sed -n ' s/.\{148\}/&'"$ac_delim"'/g t rset :rset s/^[ ]*#[ ]*define[ ][ ]*/ / t def d :def s/\\$// t bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3"/p s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p d :bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3\\\\\\n"\\/p t cont s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p t cont d :cont n s/.\{148\}/&'"$ac_delim"'/g t clear :clear s/\\$// t bsnlc s/["\\]/\\&/g; s/^/"/; s/$/"/p d :bsnlc s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p b cont ' >$CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 for (key in D) D_is_set[key] = 1 FS = "" } /^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { line = \$ 0 split(line, arg, " ") if (arg[1] == "#") { defundef = arg[2] mac1 = arg[3] } else { defundef = substr(arg[1], 2) mac1 = arg[2] } split(mac1, mac2, "(") #) macro = mac2[1] prefix = substr(line, 1, index(line, defundef) - 1) if (D_is_set[macro]) { # Preserve the white space surrounding the "#". print prefix "define", macro P[macro] D[macro] next } else { # Replace #undef with comments. This is necessary, for example, # in the case of _POSIX_SOURCE, which is predefined and required # on some systems where configure will not decide to define it. if (defundef == "undef") { print "/*", prefix defundef, macro, "*/" next } } } { print } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 fi # test -n "$CONFIG_HEADERS" eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag '$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain ':'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: '$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`printf "%s\n" "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is 'configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` printf "%s\n" "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 printf "%s\n" "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`printf "%s\n" "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 printf "%s\n" "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when '$srcdir' = '.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable 'datarootdir' which seems to be undefined. Please make sure it is defined" >&5 printf "%s\n" "$as_me: WARNING: $ac_file contains a reference to the variable 'datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; :H) # # CONFIG_HEADER # if test x"$ac_file" != x-; then { printf "%s\n" "/* $configure_input */" >&1 \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" } >"$ac_tmp/config.h" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 printf "%s\n" "$as_me: $ac_file is unchanged" >&6;} else rm -f "$ac_file" mv "$ac_tmp/config.h" "$ac_file" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 fi else printf "%s\n" "/* $configure_input */" >&1 \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ || as_fn_error $? "could not create -" "$LINENO" 5 fi ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi Rmpfr/man/0000755000176200001440000000000015075721202012114 5ustar liggesusersRmpfr/man/mpfrArray.Rd0000644000176200001440000000634114644764560014371 0ustar liggesusers\name{mpfrArray} \alias{mpfrArray} \title{Construct "mpfrArray" almost as by 'array()'}% <--> ./mpfrMatrix-class.Rd \description{ Utility to construct an \R object of class \code{\linkS4class{mpfrArray}}, very analogously to the numeric \code{\link{array}} function. } \usage{ mpfrArray(x, precBits, dim = length(x), dimnames = NULL, rnd.mode = c("N","D","U","Z","A")) } \arguments{ \item{x}{numeric(like) vector, typically of length \code{prod(dim)} or shorter in which case it is recycled.} \item{precBits}{a number, the maximal precision to be used, in \bold{\emph{bits}}; i.e., \code{53} corresponds to double precision. Must be at least 2.} \item{dim}{the dimension of the array to be created, that is a vector of length one or more giving the maximal indices in each dimension.} \item{dimnames}{either \code{NULL} or the names for the dimensions. This is a list with one component for each dimension, either \code{NULL} or a character vector of the length given by \code{dim} for that dimension.} %% ?array has more, about named dimnames etc... \item{rnd.mode}{a 1-letter string specifying how \emph{rounding} should happen at C-level conversion to MPFR, see details of \code{\link{mpfr}}.} } \value{ an object of class \code{"\linkS4class{mpfrArray}"}, specifically \code{"\linkS4class{mpfrMatrix}"} when \code{length(dim) == 2}. } \seealso{\code{\link{mpfr}}, \code{\link{array}}; \code{\link[gmp]{asNumeric}()} from \CRANpkg{gmp} as \dQuote{inverse} of \code{mpfrArray()}, to get back a numeric array. \code{\link{mpfr2array}(x)} is for \code{"mpfr"} classed \code{x}, only, whereas \code{mpfrArray(x)} is for numeric (\dQuote{non-mpfr}) \code{x}. } \examples{ ## preallocating is possible here too ma <- mpfrArray(NA, prec = 80, dim = 2:4) validObject(A2 <- mpfrArray(1:24, prec = 64, dim = 2:4)) ## recycles, gives an "mpfrMatrix" and dimnames : mat <- mpfrArray(1:5, 64, dim = c(5,3), dimnames=list(NULL, letters[1:3])) mat asNumeric(mat) stopifnot(identical(asNumeric(mat), matrix(1:5 +0, 5,3, dimnames=dimnames(mat)))) ## Testing the apply() method : apply(mat, 2, range) apply(A2, 1:2, range) apply(A2, 2:3, max) (fA2 <- apply(A2, 2, fivenum)) a2 <- as(A2, "array") stopifnot(as(apply(A2, 2, range), "matrix") == apply(a2, 2, range) , all.equal(fA2, apply(a2, 2, fivenum)) , all.equal(apply(A2, 2, quantile), apply(a2, 2, quantile)) , all.equal(A2, apply(A2, 2:3, identity) -> aA2, check.attributes=FALSE) , dim(A2) == dim(aA2) ) \dontshow{ for(nf in c("colSums", "colMeans", "rowSums", "rowMeans")) { FUN <- getFunction(nf) for(di in c(1,2)) { r <- FUN(a2, dims = di) R <- FUN(A2, dims = di) stopifnot(identical(dim(r), dim(R)), # possibly both NULL all.equal(as(R, if(is.array(r)) "array" else "numeric"), unname(r), tol = 1e-15)) } } ## with non-trivial dimnames: ma2 <- mat dimnames(ma2) <- list(row=paste0("r",1:5), col=colnames(mat)) stopifnot(identical(ma2, apply(ma2, 2, identity)), identical(ma2, t(apply(ma2, 1, identity))), identical(names(apply(ma2,2,sum)), colnames(ma2)) ) }%end{ dontshow } } \keyword{array} Rmpfr/man/pbetaI.Rd0000644000176200001440000001365114661042021013610 0ustar liggesusers\name{pbetaI} \alias{pbetaI} \title{Accurate Incomplete Beta / Beta Probabilities For Integer Shapes} \description{ For integers \eqn{a}, \eqn{b}, \eqn{I_x(a,b)}{I(x; a,b)} aka \code{pbeta(x, a,b)} is a polynomial in x with rational coefficients, and hence arbitarily accurately computable. TODO (\emph{not yet}): It's sufficient for \emph{one} of \eqn{a,b} to be integer such that the result is a \emph{finite sum} (but the coefficients will no longer be rational, see Abramowitz and Stegun, 26.5.6 and *.7, p.944). % \url{https://personal.math.ubc.ca/~cbm/aands/page_944.htm} } \usage{%% code --> ../R/special-fun.R pbetaI(q, shape1, shape2, ncp = 0, lower.tail = TRUE, log.p = FALSE, precBits = NULL, useRational = !log.p && !is.mpfr(q) && is.null(precBits) && int2, rnd.mode = c("N","D","U","Z","A")) } \arguments{ \item{q}{called \eqn{x}, above; vector of quantiles, in \eqn{[0,1]}; can be \code{\link{numeric}}, or of class \code{"\link{mpfr}"} or also \code{"\link[gmp]{bigq}"} (\dQuote{big rational} from package \CRANpkg{gmp}); in the latter case, if \code{log.p = FALSE} as by default, \emph{all computations} are exact, using big rational arithmetic.} \item{shape1, shape2}{the positive Beta \dQuote{shape} parameters, called \eqn{a, b}, above. \bold{Must} be integer valued for this function.} \item{ncp}{unused, only for compatibility with \code{\link{pbeta}}, must be kept at its default, 0.} \item{lower.tail}{logical; if TRUE (default), probabilities are \eqn{P[X \le x]}, otherwise, \eqn{P[X > x]}.} \item{log.p}{logical; if TRUE, probabilities p are given as log(p).} \item{precBits}{the precision (in number of bits) to be used in \code{\link{sumBinomMpfr}()}.} \item{useRational}{optional \code{\link{logical}}, specifying if we should try to do everything in exact \emph{rational arithmetic}, i.e, using package \CRANpkg{gmp} functionality only, and return \code{\link[gmp]{bigq}} (from \CRANpkg{gmp}) numbers instead of \code{\link{mpfr}} numbers.} \item{rnd.mode}{a 1-letter string specifying how \emph{rounding} should happen at C-level conversion to MPFR, see \code{\link{mpfr}}.} } \value{ an \code{"\linkS4class{mpfr}"} vector of the same length as \code{q}. } \note{For upper tail probabilities, i.e., when \code{lower.tail=FALSE}, we may need large \code{precBits}, because the implicit or explicit \eqn{1 - P} computation suffers from severe cancellation. %% FIXME: Indeed, we may want to %% 1) determine a smart default precBits there %% 2) produce a warning when cancellation is in the same order as precBits } \references{ Abramowitz, M. and Stegun, I. A. (1972) \emph{Handbook of Mathematical Functions}. New York: Dover. \url{https://en.wikipedia.org/wiki/Abramowitz_and_Stegun} provides links to the full text which is in public domain. } \author{Martin Maechler} \seealso{ \code{\link{pbeta}}, \code{\link{sumBinomMpfr}} \code{\link[gmp]{chooseZ}}. } \examples{ x <- (0:12)/16 # not all the way up .. a <- 7; b <- 788 p. <- pbetaI(x, a, b) ## a bit slower: system.time( pp <- pbetaI(x, a, b, precBits = 2048) ) # 0.23 -- 0.50 sec ## Currently, the lower.tail=FALSE are computed "badly": lp <- log(pp) ## = pbetaI(x, a, b, log.p=TRUE) lIp <- log1p(-pp) ## = pbetaI(x, a, b, lower.tail=FALSE, log.p=TRUE) Ip <- 1 - pp ## = pbetaI(x, a, b, lower.tail=FALSE) if(Rmpfr:::doExtras()) { ## somewhat slow system.time( stopifnot(exprs = { all.equal(lp, pbetaI(x, a, b, precBits = 2048, log.p=TRUE)) all.equal(lIp, pbetaI(x, a, b, precBits = 2048, lower.tail=FALSE, log.p=TRUE), tolerance = 1e-230) all.equal( Ip, pbetaI(x, a, b, precBits = 2048, lower.tail=FALSE)) }) ) # 0.375 sec -- "slow" ??? } rErr <- function(approx, true, eps = 1e-200) { true <- as.numeric(true) # for "mpfr" ifelse(Mod(true) >= eps, ## relative error, catching '-Inf' etc : ifelse(true == approx, 0, 1 - approx / true), ## else: absolute error (e.g. when true=0) true - approx) } cbind(x , pb = rErr(pbeta(x, a, b), pp) , pbUp = rErr(pbeta(x, a, b, lower.tail=FALSE), Ip) , ln.p = rErr(pbeta(x, a, b, log.p = TRUE ), lp) , ln.pUp= rErr(pbeta(x, a, b, lower.tail=FALSE, log.p=TRUE), lIp) ) a.EQ <- function(..., tol=1e-15) all.equal(..., tolerance=tol) stopifnot( a.EQ(pp, pbeta(x, a, b)), a.EQ(lp, pbeta(x, a, b, log.p=TRUE)), a.EQ(lIp, pbeta(x, a, b, lower.tail=FALSE, log.p=TRUE)), a.EQ( Ip, pbeta(x, a, b, lower.tail=FALSE)) ) ## When 'q' is a bigrational (i.e., class "bigq", package 'gmp'), everything ## is computed *exactly* with bigrational arithmetic: (q4 <- as.bigq(1, 2^(0:4))) pb4 <- pbetaI(q4, 10, 288, lower.tail=FALSE) stopifnot( is.bigq(pb4) ) mpb4 <- as(pb4, "mpfr") mpb4[1:2] getPrec(mpb4) # 128 349 1100 1746 2362 (pb. <- pbeta(asNumeric(q4), 10, 288, lower.tail=FALSE)) stopifnot(mpb4[1] == 0, all.equal(mpb4, pb., tolerance = 4e-15)) qbetaI. <- function(p, shape1, shape2, ncp = 0, lower.tail = TRUE, log.p = FALSE, precBits = NULL, rnd.mode = c("N", "D", "U", "Z", "A"), tolerance = 1e-20, ...) { if(is.na(a <- as.integer(shape1))) stop("a = shape1 is not coercable to finite integer") if(is.na(b <- as.integer(shape2))) stop("b = shape2 is not coercable to finite integer") unirootR(function(q) pbetaI(q, a, b, lower.tail=lower.tail, log.p=log.p, precBits=precBits, rnd.mode=rnd.mode) - p, interval = if(log.p) c(-double.xmax, 0) else 0:1, tol = tolerance, ...) } # end{qbetaI} (p <- 1 - mpfr(1,128)/20) # 'p' must be high precision q95.1.3 <- qbetaI.(p, 1,3, tolerance = 1e-29) # -> ~29 digits accuracy str(q95.1.3) ; roundMpfr(q95.1.3$root, precBits = 29 * log2(10)) ## relative error is really small: (relE <- asNumeric(1 - pbetaI(q95.1.3$root, 1,3) / p)) # -5.877e-39 stopifnot(abs(relE) < 1e-28) }%examples \keyword{arith} \keyword{distribution} Rmpfr/man/seqMpfr.Rd0000644000176200001440000000420413417136645014031 0ustar liggesusers\name{seqMpfr} %% This is to contain the "true" seq() methods --- once we can ! --- \Rdversion{1.1} \alias{seqMpfr} \title{"mpfr" Sequence Generation} \description{ Generate \sQuote{regular}, i.e., arithmetic sequences. This is in lieu of methods for \code{\link{seq}} (dispatching on all three of \code{from}, \code{to}, and \code{by}. } \usage{ seqMpfr(from = 1, to = 1, by = ((to - from)/(length.out - 1)), length.out = NULL, along.with = NULL, \dots) } \arguments{ \item{from, to}{the starting and (maximal) end value (numeric or \code{"\linkS4class{mpfr}"}) of the sequence.} \item{by}{number (numeric or \code{"\linkS4class{mpfr}"}): increment of the sequence.} \item{length.out}{desired length of the sequence. A non-negative number, which will be rounded up if fractional.} \item{along.with}{take the length from the length of this argument.} \item{\dots}{arguments passed to or from methods.} } \details{ see \code{\link[base]{seq}} (default method in package \pkg{base}), whose semantic we want to replicate (almost).% not seq(9:6) => seq(4) } \value{ a \sQuote{vector} of class \code{"\linkS4class{mpfr}"}, when one of the first three arguments was. } \author{Martin Maechler} \seealso{ The documentation of the \pkg{base} function \code{\link[base]{seq}}; \code{\link{mpfr}} } \examples{ seqMpfr(0, 1, by = mpfr(0.25, prec=88)) seqMpfr(7, 3) # -> default prec. \dontshow{ eq.test <- function(...) { args <- list(...) r <- do.call(seqMpfr, args) is(r, "mpfr") && all(r == do.call(seq, lapply(args, as.numeric))) } m <- mpfr(8, 60); m2 <- as(2, "mpfr") stopifnot(seqMpfr(7,3) == 7:3, seqMpfr(to=1) == 1, eq.test(pi), eq.test(1,12,3), eq.test(1, by= 2, length= 5), eq.test(1, by=m2, length= 5), eq.test(1, length.out = 8), eq.test(1, length.out = m), eq.test(1, 8, length.out=8), eq.test(1, 8, length.out=m), eq.test(1, m, length.out=m), eq.test(1, m, length.out=8), eq.test(to=17, by= 2, length=4), eq.test(to=17, by=m2, length=4), TRUE) }% {dontshow} -- but test } \keyword{manip} Rmpfr/man/igamma.Rd0000644000176200001440000000570615006632323013645 0ustar liggesusers\name{igamma} \alias{igamma} \title{Incomplete Gamma Function} \description{% >> ../R/special-fun.R <<< For MPFR version >= 3.2.0, the following MPFR library function is provided: \code{mpfr_gamma_inc(a,x)}, the \R interface of which is \code{igamma(a,x)}, where \code{igamma(a,x)} is the \dQuote{upper} incomplete gamma function %% fails in LaTeX (R "bug"): \deqn{γ(a,x) :=: Γ(a) - Γ(a,x),} \deqn{\Gamma(a,x) :=: \Gamma(a) - \gamma(a,x),}{Γ(a,x) :=: Γ(a) - γ(a,x),} where \deqn{\gamma(a,x) := \int_0^x t^{a-1} e^{-t} dt,}{γ(a,x) := ∫₀ˣ tᵃ⁻¹ e⁻ᵗ dt,} and hence \deqn{\Gamma(a,x) := \int_x^\infty t^{a-1} e^{-t} dt,}{Γ(a,x) := ∫ (x..∞) tᵃ⁻¹ e⁻ᵗ dt,} and \deqn{\Gamma(a) := \gamma(a, \infty).}{Γ(a) := γ(a, ∞).} As \R's \code{\link{pgamma}(x,a)} is \deqn{\code{pgamma(x, a)} := \gamma(a,x) / \Gamma(a),}{\code{pgamma(x, a)} := γ(a,x) / Γ(a),} we get \preformatted{ igamma(a,x) == gamma(a) * pgamma(x, a, lower.tail=FALSE)} } \usage{ igamma(a, x, rnd.mode = c("N", "D", "U", "Z", "A")) } %% MM FIXME: "Copy paste" from hypot() -- which strangely we have in >> ./mpfr-class.Rd << \arguments{ \item{a, x}{an object of class \code{mpfr} or \code{\link{numeric}}, where only one of \code{rate} and \code{scale} should be specified.} \item{rnd.mode}{a 1-letter string specifying how \emph{rounding} should happen at C-level conversion to MPFR, see \code{\link{mpfr}}.} } %% \details{ %% } \value{ a numeric vector of \dQuote{common length}, recyling along \code{a} and \code{x}. } \references{ NIST Digital Library of Mathematical Functions, section 8.2. \url{https://dlmf.nist.gov/8.2.i} Wikipedia (2019). \emph{Incomplete gamma function}; \url{https://en.wikipedia.org/wiki/Incomplete_gamma_function} %% .. arXiv paper TODO % see --> ../TODO } \section{Warning}{ The MPFR library documentation on \code{mpfr_gamma_inc()} \url{https://www.mpfr.org/mpfr-current/mpfr.html#index-mpfr_005fgamma_005finc} contains \subsection{Note}{the current implementation of \code{mpfr_gamma_inc(rop, op, op2, )} is slow for large values of \code{rop} or \code{op}, in which case some internal overflow might also occur. } } \author{\R interface: Martin Maechler} \seealso{ \R's \code{\link{gamma}} (function) and \code{\link{pgamma}} (probability distribution). Rmpfr's own \code{\link{pgamma}()}, a thin wrapper around \code{igamma()}. } \examples{ ## show how close pgamma() is : x <- c(seq(0,20, by=1/4), 21:50, seq(55, 100, by=5)) if(mpfrVersion() >= "3.2.0") { print( all.equal(igamma(Const("pi", 80), x), pgamma(x, pi, lower.tail=FALSE) * gamma(pi), tol=0, formatFUN = function(., ...) format(., digits = 7)) #-> 2.75e-16 (was 3.13e-16) ) ## and ensure *some* closeness: stopifnot(exprs = { all.equal(igamma(Const("pi", 80), x), pgamma(x, pi, lower.tail=FALSE) * gamma(pi), tol = 1e-15) }) } # only if MPFR version >= 3.2.0 } \keyword{math} Rmpfr/man/matmult.Rd0000644000176200001440000000507013637431043014073 0ustar liggesusers\name{matmult} \title{(MPFR) Matrix (Vector) Multiplication} %% Note : all the %*%, crossprod(), and tcrossprod() methods are documented in %% ---- ===> ./mpfrMatrix-class.Rd %% ^^^^^^^^^^^^^^^^^^^ \alias{matmult} \alias{.matmult.R}% hidden, not exported \description{ Matrix / vector multiplication of \code{\link{mpfr}} (and \dQuote{simple} \code{\link{numeric}}) matrices and vectors. \code{ matmult (x,y, fPrec = 2)} or \code{crossprod(x,y, fPrec = 2)} use higher precision in underlying computations. } \usage{ matmult(x, y, ...) %% .matmult.R(x,y, op = 0L, fPrec = 1, precBits = fPrec * max(getPrec(x), getPrec(y))) } \arguments{ \item{x, y}{\code{\link{numeric}} or \code{\linkS4class{mpfrMatrix}}-classed \R objects, i.e. semantically numeric matrices or vectors.} \item{\dots}{arguments passed to the hidden underlying \code{.matmult.R()} work horse which is also underlying the \code{\link{\%*\%}}, \code{\link{crossprod}()}, and \code{\link{tcrossprod}()} methods, see the \code{\linkS4class{mpfrMatrix}} class documentation: \describe{ \item{fPrec}{a multiplication factor, a positive number determining the number of bits \code{precBits} used for the underlying multiplication and summation arithmetic. The default is \code{fPrec = 1}. Setting \code{fPrec = 2} doubles the precision which has been recommended, e.g., by John Nash.} \item{precBits}{the number of bits used for the underlying multiplication and summation arithmetic; by default \code{precBits = fPrec * max(getPrec(x), getPrec(y))} which typically uses the same accuracy as regular \code{\link{mpfr}}-arithmetic would use.} }} } %% \details{ %% %% ~~ If necessary, more details than the description above ~~ %% } \value{ a (base \R) \code{\link{matrix}} or \code{\linkS4class{mpfrMatrix}}, depending on the classes of \code{x} and \code{y}. } %% \references{ %% } \author{Martin Maechler} \note{ Using \code{matmult(x,y)} instead of \code{x \link{\%*\%} y}, makes sense mainly \emph{if} you use non-default \code{fPrec} or \code{precBits} arguments. The \code{\link{crossprod}()}, and \code{\link{tcrossprod}()} function have the \emph{identical} optional arguments \code{fPrec} or \code{precBits}. } \seealso{ \code{\link{\%*\%}}, \code{\link{crossprod}}, \code{\link{tcrossprod}}. } \examples{ %% ## The function is currently defined as %% function (x, y, ...) %% .matmult.R(x, y, op = 0L, ...) ## FIXME: add example ## 1) matmult() <--> \%*\% ## 2) crossprod() , tcrossprod() %% <--> ./mpfrMatrix-class.Rd examples (!) } \keyword{arith} Rmpfr/man/formatMpfr.Rd0000644000176200001440000002273215057534534014540 0ustar liggesusers\name{formatMpfr} \title{Formatting and Printing MPFR (multiprecision) Numbers} \alias{formatMpfr} \alias{formatN.mpfr} \alias{print.mpfr} \alias{print.mpfrArray} \alias{.mpfr2str} \description{ Flexible formatting of \dQuote{multiprecision numbers}, i.e., objects of class \code{\linkS4class{mpfr}}. \code{formatMpfr()} is also the \code{mpfr} method of the generic \code{\link{format}} function. The \code{formatN()} methods for \code{\linkS4class{mpfr}} numbers renders them differently than their double precision equivalents, by appending \code{"_M"}. Function \code{.mpfr2str()} is the low level work horse for \code{formatMpfr()} and hence all \code{\link{print}()}ing of \code{"\linkS4class{mpfr}"} objects. } \usage{ formatMpfr(x, digits = NULL, trim = FALSE, scientific = NA, maybe.full = (!is.null(digits) && is.na(scientific)) || isFALSE(scientific), base = 10, showNeg0 = TRUE, max.digits = Inf, big.mark = "", big.interval = 3L, small.mark = "", small.interval = 5L, decimal.mark = ".", exponent.char = if(base <= 14) "e" else if(base <= 36) "E" else "|e", exponent.plus = TRUE, zero.print = NULL, drop0trailing = FALSE, ...) \S3method{formatN}{mpfr}(x, drop0trailing = TRUE, \dots) \S3method{print}{mpfr}(x, digits = NULL, drop0trailing = TRUE, right = TRUE, max.digits = getOption("Rmpfr.print.max.digits", 999L), exponent.plus = getOption("Rmpfr.print.exponent.plus", TRUE), \dots) \S3method{print}{mpfrArray}(x, digits = NULL, drop0trailing = FALSE, right = TRUE, max.digits = getOption("Rmpfr.print.max.digits", 999L), exponent.plus = getOption("Rmpfr.print.exponent.plus", TRUE), \dots) .mpfr2str(x, digits = NULL, maybe.full = !is.null(digits), base = 10L) } \arguments{ \item{x}{an MPFR number (vector or array).} \item{digits}{how many significant digits (in the \code{base} chosen!) are to be used in the result. The default, \code{NULL}, uses enough digits to represent the full precision, often one or two digits more than \dQuote{you} would expect. For \code{base}s 2,4,8,16, or 32, MPFR requires \code{digits} at least 2. For such bases, \code{digits = 1} is changed into \code{2}, with a message.} \item{trim}{logical; if \code{FALSE}, numbers are right-justified to a common width: if \code{TRUE} the leading blanks for justification are suppressed.} \item{scientific}{either a logical specifying whether MPFR numbers should be encoded in scientific format (\dQuote{exponential representation}), or an integer penalty (see \code{\link{options}("scipen")}). Missing values correspond to the current default penalty.} \item{maybe.full}{\code{\link{logical}}, passed to \code{\link{.mpfr2str}()}.} \item{base}{an integer in \eqn{2,3,..,62}; the base (\dQuote{basis}) in which the numbers should be represented. Apart from the default base 10, binary (\code{base = 2}) or hexadecimal (\code{base = 16}) are particularly interesting.} \item{showNeg0}{logical indicating if \dQuote{\bold{neg}ative} zeros should be shown with a \code{"-"}. The default, \code{TRUE} is intentially different from \code{\link{format}()}.} \item{exponent.char}{the \dQuote{exponent} character to be used in scientific notation. The default takes into account that for \code{base} \eqn{B \ge 15}{B >= 15}, \code{"e"} is part of the (mantissa) digits and the same is true for \code{"E"} when \eqn{B \ge 37}{B >= 37}.} \item{exponent.plus}{\code{\link{logical}} indicating if \code{"+"} should be for positive exponents in exponential (aka \dQuote{scientific}) representation. This used to be hardcoded to \code{FALSE}; the new default for \code{formatMpfr()}, i.e., the mpfr-\code{format} method, is compatible to \R's \code{\link{format}()}ing of numbers and helps to note visually when exponents are in use. For the \code{print()} methods, it has a different default and is simply passed to \code{\link{formatMpfr}()}; it was \code{FALSE} hardwired in Rmpfr versions before 0.8-0, and now is allowed to be tweaked by an \code{\link{options}()} setting. } \item{max.digits}{a (large) positive number (possibly \code{Inf}) to limit the number of (mantissa) digits, notably when \code{digits} is \code{NULL} (as by default). Otherwise, a numeric \code{digits} is \emph{preferred} to setting \code{max.digits} (which should not be smaller than \code{digits}). The \code{print()} and hence \code{\link{show}()} methods for \code{"mpfr"} (and \code{"mpfrArray"}) use a default of \code{getOption("Rmpfr.print.max.digits", 999L)} preventing accidental printing of too large strings of digits (whereas \code{formatMpfr()}, the \code{format()} method for \code{"mpfr"}, uses (slightly more than) the full precision of the respective numbers).} \item{drop0trailing}{logical indicating if trailing \code{"0"}s should be omitted.} \item{right}{logical indicating \code{print()}ing should right justify the strings; see \code{\link{print.default}()} to which it is passed.} \item{big.mark, big.interval, small.mark, small.interval, decimal.mark, zero.print}{% used for prettying decimal sequences, these are passed to \code{\link{prettyNum}} and that help page explains the details.} \item{\dots}{further arguments passed to or from other methods.} } \value{ a character vector or array, say \code{cx}, of the same length as \code{x}. Since Rmpfr version 0.5-3 (2013-09), if \code{x} is an \code{\linkS4class{mpfrArray}}, then \code{cx} is a character \code{\link{array}} with the same \code{\link{dim}} and \code{\link{dimnames}} as \code{x}. Note that in scientific notation, the integer exponent is always in \emph{decimal}, i.e., base 10 (even when \code{base} is not 10), but of course meaning \code{base} powers, e.g., in base 32, \code{"u.giE3"}is the same as \code{"ugi0"} which is \eqn{32^3} times \code{"u.gi"}. This is in contrast, e.g., with \code{\link{sprintf}("\%a", x)} where the powers after \code{"p"} are powers of \eqn{2}. } \details{ The \code{print} method is built on the \code{\link{format}} method for class \code{\linkS4class{mpfr}}. This, for \code{print.mpfrArray}, currently does \emph{not} format columns jointly which leads to suboptimally looking output. There are plans to change this. Note that \code{\link{formatMpfr}()} which is called by \code{print()} (or \code{show()} or \R's implicit printing) uses \code{max.digits = Inf}, differing from our \code{print()}'s default on purpose. If you do want to see the full accuracy even in cases it is large, use \code{\link{options}(Rmpfr.print.max.digits = Inf)} or \code{(.. = 1e7)}, say. } \note{ Currently, \code{formatMpfr(x, scientific = FALSE)} does \emph{not work correctly}, e.g., for \code{x <- Const("pi", 128) * 2^c(-200,200)}, i.e., it uses the scientific / exponential-style format. This is considered bogous and hopefully will change. } \references{ The MPFR manual's description of \samp{mpfr_get_str()} which is the C-internal workhorse for \code{.mpfr2str()} (on which \code{formatMpfr()} builds).% as we say in description{..} already } \author{Martin Maechler} \seealso{ \code{\link{mpfr}} for creation and the \code{\linkS4class{mpfr}} class description with its many methods. The \code{\link{format}} generic, and the \code{\link{prettyNum}} utility on which \code{formatMpfr} is based as well. The S3 generic function \code{\link[gmp]{formatN}} from package \pkg{gmp}. \code{\link{.mpfr_formatinfo}(x)} provides the (cheap) non-string parts of \code{.mpfr2str(x)}; the (base 2) \code{exp} exponents are also available via \code{\link{.mpfr2exp}(x)}. } \examples{ ## Printing of MPFR numbers uses formatMpfr() internally. ## Note how each components uses the "necessary" number of digits: ( x3 <- c(Const("pi", 168), mpfr(pi, 140), 3.14) ) format(x3[3], 15) format(x3[3], 15, drop0 = TRUE)# "3.14" .. dropping the trailing zeros x3[4] <- 2^30 x3[4] # automatically drops trailing zeros format(x3[1], dig = 41, small.mark = "'") # (41 - 1 = ) 40 digits after "." rbind(formatN( x3, digits = 15), formatN(as.numeric(x3), digits = 15)) (Zero <- mpfr(c(0,1/-Inf), 20)) # 0 and "-0" xx <- c(Zero, 1:2, Const("pi", 120), -100*pi, -.00987) format(xx, digits = 2) format(xx, digits = 1, showNeg0 = FALSE)# "-0" no longer shown ## Output in other bases : formatMpfr(mpfr(10^6, 40), base=32, drop0trailing=TRUE) ## "ugi0" mpfr("ugi0", base=32) #-> 1'000'000 \dontshow{ stopifnot( identical("ugi0", formatMpfr(mpfr(10^6, 40), base=32, drop0trailing=TRUE)), mpfr("ugi0", base=32) == 10^6) } ## This now works: The large number shows "as" large integer: x <- Const("pi", 128) * 2^c(-200,200) formatMpfr(x, scientific = FALSE) # was 1.955...e-60 5.048...e+60 i32 <- mpfr(1:32, precBits = 64) format(i32, base= 2, drop0trailing=TRUE) format(i32, base= 16, drop0trailing=TRUE) format(1/i32, base= 2, drop0trailing=TRUE)# using scientific notation for [17..32] format(1/i32, base= 32) format(1/i32, base= 62, drop0trailing=TRUE) format(mpfr(2, 64)^-(1:16), base=16, drop0trailing=TRUE) ## Printing of "MPFR" matrices is less nice than R's usual matrix printing: m <- outer(c(1, 3.14, -1024.5678), c(1, 1e-3, 10,100)) m[3,3] <- round(m[3,3]) m mpfr(m, 50) (mpfr2array(Bernoulli(1:6, 60), c(2,3), dimnames = list(LETTERS[1:2], letters[1:3]))) } \keyword{character} \keyword{print} Rmpfr/man/str.mpfr.Rd0000644000176200001440000000414113523036312014153 0ustar liggesusers\name{str.mpfr} \alias{str.mpfr} \title{Compactly Show STRucture of Rmpfr Number Object} \description{ The \code{\link{str}} method for objects of class \code{\linkS4class{mpfr}} produces a bit more useful output than the default method \code{\link{str.default}}. } \usage{ \method{str}{mpfr}(object, nest.lev, internal = FALSE, give.head = TRUE, digits.d = 12, vec.len = NULL, drop0trailing=TRUE, width = getOption("width"), \dots) } \arguments{ \item{object}{an object of class \code{\linkS4class{mpfr}}.} \item{nest.lev}{for \code{\link{str}()}, typically only used when called by a higher level \code{str()}.} \item{internal}{logical indicating if the low-level internal structure should be shown; if true (not by default), uses \code{str(object@.Data)}.} \item{give.head}{logical indicating if the \dQuote{header} should be printed.} \item{digits.d}{the number of digits to be used, will be passed \code{\link{formatMpfr}()} and hence \code{NULL} will use \dQuote{as many as needed}, i.e. often too many. If this is a number, as per default, less digits will be used in case the precision (\code{\link{getPrec}(object)}) is smaller.} \item{vec.len}{the number of \emph{elements} that will be shown. The default depends on the precision of \code{object} and \code{width} (since \pkg{Rmpfr} 0.6-0, it was \code{3} previously).} \item{drop0trailing}{logical, passed to \code{\link{formatMpfr}()} (with a different default here).} \item{width}{the (approximately) desired width of output, see \code{\link{options}(width = .)}.} \item{\dots}{further arguments, passed to \code{\link{formatMpfr}()}.} } \seealso{ \code{\link{.mpfr2list}()} puts the internal structure into a \code{\link{list}}, and its help page documents many more (low level) utilities. } \examples{ (x <- c(Const("pi", 64), mpfr(-2:2, 64))) str(x) str(list(pi = pi, x.mpfr = x)) str(x ^ 1000) str(x ^ -1e4, digits=NULL) # full precision str(x, internal = TRUE) # internal low-level (for experts) uu <- Const("pi", 16)# unaccurate str(uu) # very similar to just 'uu' } \keyword{utilities} Rmpfr/man/factorialMpfr.Rd0000644000176200001440000000341512561376373015213 0ustar liggesusers\name{factorialMpfr} \alias{factorialMpfr} \title{Factorial 'n!' in Arbitrary Precision} \description{ Efficiently compute \eqn{n!} in arbitrary precision, using the MPFR-internal implementation. This is mathematically (but not numerically) the same as \eqn{\Gamma(n+1)}{Gamma(n+1)}. %% FIXME: factorialZ() is not yet *vectorized* __ FIXME ___ \code{\link[gmp]{factorialZ}} (package \pkg{gmp}) should typically be used \emph{instead} of \code{factorialMpfr()} nowadays. Hence, \code{factorialMpfr} now is somewhat \bold{deprecated}. } \usage{ factorialMpfr(n, precBits = max(2, ceiling(lgamma(n+1)/log(2))), rnd.mode = c("N","D","U","Z","A")) } \arguments{ \item{n}{non-negative integer (vector).} \item{precBits}{desired precision in bits (\dQuote{binary digits}); the default sets the precision high enough for the result to be \emph{exact}.} \item{rnd.mode}{a 1-letter string specifying how \emph{rounding} should happen at C-level conversion to MPFR, see \code{\link{mpfr}}.} } \value{ a number of (S4) class \code{\linkS4class{mpfr}}. } \seealso{ \code{\link{factorial}} and \code{\link{gamma}} in base \R. \code{\link[gmp]{factorialZ}} (package \pkg{gmp}), to \emph{replace} \code{factorialMpfr}, see above. \code{chooseMpfr()} and \code{\link{pochMpfr}()} (on the same page). } \examples{ factorialMpfr(200) n <- 1000:1010 f1000 <- factorialMpfr(n) stopifnot(1e-15 > abs(as.numeric(1 - lfactorial(n)/log(f1000)))) ## Note that---astonishingly--- measurements show only ## *small* efficiency gain of ~ 10\% : over using the previous "technique" system.time(replicate(8, f1e4 <- factorialMpfr(10000))) system.time(replicate(8, f.1e4 <- factorial(mpfr(10000, prec=1+lfactorial(10000)/log(2))))) } \keyword{arith} Rmpfr/man/unirootR.Rd0000644000176200001440000002141014275412624014230 0ustar liggesusers\name{unirootR} \alias{unirootR} \title{One Dimensional Root (Zero) Finding -- in pure \R} \usage{ unirootR(f, interval, \dots, lower = min(interval), upper = max(interval), f.lower = f(lower, ...), f.upper = f(upper, ...), extendInt = c("no", "yes", "downX", "upX"), trace = 0, verbose = as.logical(trace), verbDigits = max(3, min(20, -log10(tol)/2)), tol = .Machine$double.eps^0.25, maxiter = 1000L, check.conv = FALSE, warn.no.convergence = !check.conv, epsC = NULL) } \arguments{% base R : ~/R/D/r-devel/R/src/library/stats/man/uniroot.Rd \item{f}{the function for which the root is sought.} \item{interval}{a vector containing the end-points of the interval to be searched for the root.} \item{\dots}{additional named or unnamed arguments to be passed to \code{f}} \item{lower, upper}{the lower and upper end points of the interval to be searched.} \item{f.lower, f.upper}{the same as \code{f(upper)} and \code{f(lower)}, respectively. Passing these values from the caller where they are often known is more economical as soon as \code{f()} contains non-trivial computations.} \item{extendInt}{character string specifying if the interval \code{c(lower,upper)} should be extended or directly produce an error when \code{f()} does not have differing signs at the endpoints. The default, \code{"no"}, keeps the search interval and hence produces an error. Can be abbreviated.} \item{trace}{integer number; if positive, tracing information is produced. Higher values giving more details.} \item{verbose}{logical (or integer) indicating if (and how much) verbose output should be produced during the iterations.} \item{verbDigits}{used only if \code{verbose} is true, indicates the number of digits numbers should be printed with, using \code{\link{format}(., digits=verbDigits)}.} \item{tol}{the desired accuracy (convergence tolerance).} \item{maxiter}{the maximum number of iterations.} \item{check.conv}{logical indicating whether non convergence should be caught as an error, notably non-convergence in \code{maxiter} iterations should be an error instead of a warning.} \item{warn.no.convergence}{if set to \code{FALSE} there's no warning about non-convergence. Useful to just run a few iterations.} \item{epsC}{positive number or \code{NULL} in which case a smart default is sought. This should specify the \dQuote{achievable machine precision} \emph{for} the given numbers and their arithmetic. The default will set this to \code{\link{.Machine}$double.eps} for double precision numbers, and will basically use \code{2 ^ - min(getPrec(f.lower), getPrec(f.upper))} when that works (as, e.g., for \code{\linkS4class{mpfr}}-numbers) otherwise. This is factually a lower bound for the achievable lower bound, and hence, setting \code{tol} smaller than \code{epsC} is typically non-sensical and produces a warning. } } \description{ The function \code{unirootR} searches the interval from \code{lower} to \code{upper} for a root (i.e., zero) of the function \code{f} with respect to its first argument. \code{unirootR()} is \dQuote{clone} of \code{\link{uniroot}()}, written entirely in \R, in a way that it works with \code{\linkS4class{mpfr}}-numbers as well. } \details{ Note that arguments after \code{\dots} must be matched exactly. Either \code{interval} or both \code{lower} and \code{upper} must be specified: the upper endpoint must be strictly larger than the lower endpoint. The function values at the endpoints must be of opposite signs (or zero), for \code{extendInt="no"}, the default. Otherwise, if \code{extendInt="yes"}, the interval is extended on both sides, in search of a sign change, i.e., until the search interval \eqn{[l,u]} satisfies \eqn{f(l) \cdot f(u) \le 0}{f(l) * f(u) <= 0}. If it is \emph{known how} \eqn{f} changes sign at the root \eqn{x_0}{x0}, that is, if the function is increasing or decreasing there, \code{extendInt} can (and typically should) be specified as \code{"upX"} (for \dQuote{upward crossing}) or \code{"downX"}, respectively. Equivalently, define \eqn{S := \pm 1}{S:= +/- 1}, to require \eqn{S = \mathrm{sign}(f(x_0 + \epsilon))}{S = sign(f(x0 + eps))} at the solution. In that case, the search interval \eqn{[l,u]} possibly is extended to be such that \eqn{S\cdot f(l)\le 0}{% S * f(l) <= 0} and \eqn{S \cdot f(u) \ge 0}{S * f(u) >= 0}. The function only uses \R code with basic arithmetic, such that it should also work with \dQuote{generalized} numbers (such as \code{\linkS4class{mpfr}}-numbers) as long the necessary \code{\link{Ops}} methods are defined for those. The underlying algorithm assumes a continuous function (which then is known to have at least one root in the interval). Convergence is declared either if \code{f(x) == 0} or the change in \code{x} for one step of the algorithm is less than \code{tol} (plus an allowance for representation error in \code{x}). If the algorithm does not converge in \code{maxiter} steps, a warning is printed and the current approximation is returned. \code{f} will be called as \code{f(\var{x}, ...)} for a (generalized) numeric value of \var{x}. } \value{ A list with four components: \code{root} and \code{f.root} give the location of the root and the value of the function evaluated at that point. \code{iter} and \code{estim.prec} give the number of iterations used and an approximate estimated precision for \code{root}. (If the root occurs at one of the endpoints, the estimated precision is \code{NA}.) } \source{ Based on \code{zeroin()} (in package \pkg{rootoned}) by John Nash who manually translated the C code in \R's \code{zeroin.c} and on \code{\link{uniroot}()} in \R's sources. } \references{ Brent, R. (1973), see \code{\link{uniroot}}. } \seealso{ \R's own (\pkg{stats} package) \code{\link{uniroot}}. \code{\link{polyroot}} for all complex roots of a polynomial; \code{\link{optimize}}, \code{\link{nlm}}. } \examples{ require(utils) # for str ## some platforms hit zero exactly on the first step: ## if so the estimated precision is 2/3. f <- function (x,a) x - a str(xmin <- unirootR(f, c(0, 1), tol = 0.0001, a = 1/3)) ## handheld calculator example: fixpoint of cos(.): rc <- unirootR(function(x) cos(x) - x, lower=-pi, upper=pi, tol = 1e-9) rc$root ## the same with much higher precision: rcM <- unirootR(function(x) cos(x) - x, interval= mpfr(c(-3,3), 300), tol = 1e-40) rcM x0 <- rcM$root stopifnot(all.equal(cos(x0), x0, tol = 1e-40))## 40 digits accurate! str(unirootR(function(x) x*(x^2-1) + .5, lower = -2, upper = 2, tol = 0.0001), digits.d = 10) str(unirootR(function(x) x*(x^2-1) + .5, lower = -2, upper = 2, tol = 1e-10 ), digits.d = 10) ## A sign change of f(.), but not a zero but rather a "pole": tan. <- function(x) tan(x * (Const("pi",200)/180))# == tan( ) (rtan <- unirootR(tan., interval = mpfr(c(80,100), 200), tol = 1e-40)) ## finds 90 {"ok"}, and now gives a warning \dontshow{stopifnot(all.equal(rtan$root, 90, tolerance = 1e-38))} ## Find the smallest value x for which exp(x) > 0 (numerically): r <- unirootR(function(x) 1e80*exp(x)-1e-300, c(-1000,0), tol = 1e-15) str(r, digits.d = 15) ##> around -745, depending on the platform. exp(r$root) # = 0, but not for r$root * 0.999... minexp <- r$root * (1 - 10*.Machine$double.eps) exp(minexp) # typically denormalized ## --- using mpfr-numbers : ## Find the smallest value x for which exp(x) > 0 ("numerically"); ## Note that mpfr-numbers underflow *MUCH* later than doubles: ## one of the smallest mpfr-numbers {see also ?mpfr-class } : (ep.M <- mpfr(2, 55) ^ - ((2^30 + 1) * (1 - 1e-15))) r <- unirootR(function(x) 1e99* exp(x) - ep.M, mpfr(c(-1e20, 0), 200)) r # 97 iterations; f.root is very similar to ep.M ## interval extension 'extendInt' -------------- f1 <- function(x) (121 - x^2)/(x^2+1) f2 <- function(x) exp(-x)*(x - 12) tools::assertError(unirootR(f1, c(0,10)), verbose=TRUE) ##--> error: f() .. end points not of opposite sign ## where as 'extendInt="yes"' simply first enlarges the search interval: u1 <- unirootR(f1, c(0,10),extendInt="yes", trace=1) u2 <- unirootR(f2, mpfr(c(0,2), 128), extendInt="yes", trace=2, verbose=FALSE, tol = 1e-25) stopifnot(all.equal(u1$root, 11, tolerance = 1e-5), all.equal(u2$root, 12, tolerance = 1e-23)) ## The *danger* of interval extension: ## No way to find a zero of a positive function, but ## numerically, f(-|M|) becomes zero : u3 <- unirootR(exp, c(0,2), extendInt="yes", trace=TRUE) ## Nonsense example (must give an error): tools::assertCondition( unirootR(function(x) 1, 0:1, extendInt="yes"), "error", verbose=TRUE) } \keyword{optimize} Rmpfr/man/mpfrMatrix-utils.Rd0000644000176200001440000000417014644764560015713 0ustar liggesusers\name{mpfrMatrix-utils} %\alias{det}% "the function" (our copy of base::det) \alias{determinant.mpfrMatrix} % \title{Functions for mpfrMatrix Objects} \description{ \code{determinant(x, ..)} computes the determinant of the mpfr square matrix \code{x}. May work via coercion to \code{"numeric"}, i.e., compute \code{determinant(\link[gmp]{asNumeric}(x), logarithm)}, if \code{asNumeric} is true, by default, if the dimension is larger than three. Otherwise, use precision \code{precBits} for the \dQuote{accumulator} of the result, and use the recursive mathematical definition of the determinant (with computational complexity \eqn{n!}, where \eqn{n} is the matrix dimension, i.e., \bold{very} inefficient for all but small matrices!) } \usage{ \S3method{determinant}{mpfrMatrix}(x, logarithm = TRUE, asNumeric = (d[1] > 3), precBits = max(.getPrec(x)), \dots) } \arguments{ \item{x}{an \code{\linkS4class{mpfrMatrix}} object of \emph{square} dimension.} \item{logarithm}{logical indicating if the \code{\link{log}} of the absolute determinant should be returned. } \item{asNumeric}{logical .. .. if rather \code{determinant(\link[gmp]{asNumeric}(x), ...)} should be computed. } \item{precBits}{the number of binary digits for the result (and the intermediate accumulations).} \item{\dots}{unused (potentially further arguments passed to methods).} } \value{ as \code{\link{determinant}()}, an object of S3 class \code{"det"}, a \code{\link{list}} with components \item{modulus}{the (logarithm of) the absolute value (\code{\link{abs}}) of the determinant of \code{x}.} \item{sign}{the sign of the determinant.} } %% \details{ %% } %% \references{ %% } \seealso{ \code{\link{determinant}} in base \R, which relies on a fast LU decomposition. \code{\linkS4class{mpfrMatrix}} } \author{Martin Maechler} \examples{ m6 <- mpfrArray(1:6, prec=128, dim = c(2L, 3L)) m6 S2 <- m6[,-3] # 2 x 2 S3 <- rbind(m6, c(1:2,10)) det(S2) str(determinant(S2)) det(S3) stopifnot(all.equal(det(S2), det(asNumeric(S2)), tolerance=1e-15), all.equal(det(S3), det(asNumeric(S3)), tolerance=1e-15)) } \keyword{array} Rmpfr/man/fr_ld_expMpfr.Rd0000644000176200001440000000475414365314231015205 0ustar liggesusers\name{frexpMpfr} \alias{frexpMpfr} \alias{ldexpMpfr} \title{Base-2 Representation and Multiplication of Mpfr Numbers}% ../DPQ/man/fr_ld_exp.Rd \description{ MPFR - versions of the C99 (and POSIX) standard C (and C++) mathlib functions \code{frexp()} and \code{ldexp()}. \code{frexpMpfr(x)} computes base-2 exponent \code{e} and \dQuote{mantissa}, or \emph{fraction} \code{r}, such that \eqn{x = r * 2^e}, where \eqn{r \in [0.5, 1)} (unless when \code{x} is in \code{c(0, -Inf, Inf, NaN)} where \code{r == x} and \code{e} is 0), and \eqn{e} is integer valued. \code{ldexpMpfr(f, E)} is the \emph{inverse} of \code{frexpMpfr()}: Given fraction or mantissa \code{f} and integer exponent \code{E}, it returns \eqn{x = f * 2^E}. Viewed differently, it's the fastest way to multiply or divide MPFR numbers with \eqn{2^E}. } \usage{ frexpMpfr(x, rnd.mode = c("N", "D", "U", "Z", "A")) ldexpMpfr(f, E, rnd.mode = c("N", "D", "U", "Z", "A")) } \arguments{ \item{x}{numeric (coerced to \code{double}) vector.} \item{f}{numeric fraction (vector), in \eqn{[0.5, 1)}.} \item{E}{integer valued, exponent of \code{2}, i.e., typically in \code{(-1024-50):1024}, otherwise the result will underflow to 0 or overflow to \code{+/- Inf}.} \item{rnd.mode}{a 1-letter string specifying how \emph{rounding} should happen at C-level conversion to MPFR, see \code{\link{mpfr}}.} } %% \details{ %% } \value{ \code{frexpMpfr} returns a \code{\link{list}} with named components \code{r} (of class \code{mpfr}) and \code{e} (integer valued, of type \code{integer} is small enough, \code{"double"} otherwise). } \references{ On unix-alikes, typically \command{man frexp} and \command{man ldexp} } \author{Martin Maechler} \seealso{ Somewhat related, \code{\link{.mpfr2exp}()}. \code{\link[DPQ]{frexp}()} and \code{ldexp()} in package \CRANpkg{DPQ}. } \examples{ set.seed(47) x <- c(0, 2^(-3:3), (-1:1)/0, sort(rlnorm(2^12, 10, 20) * sample(c(-1,1), 512, replace=TRUE))) head(xM <- mpfr(x, 128), 11) str(rFM <- frexpMpfr(xM)) d.fr <- with(rFM, data.frame(x=x, r=asNumeric(r), e=e)) head(d.fr , 16) tail(d.fr) ar <- abs(rFM$r) stopifnot(0.5 <= ar[is.finite(x) & x != 0], ar[is.finite(x)] < 1, is.integer(rFM$e)) ldx <- with(rFM, ldexpMpfr(r, e)) (iN <- which(is.na(x))) # 10 stopifnot(exprs = { all.equal(xM, ldx, tol = 2^-124) # allow 4 bits loss, but apart from the NA, even: identical(xM[-iN], ldx[-iN]) is.na(xM [iN]) is.na(ldx[iN]) }) } \keyword{arithmetic} \keyword{utilities} Rmpfr/man/Rmpfr-package.Rd0000644000176200001440000001033714460520411015062 0ustar liggesusers\name{Rmpfr-package} \alias{Rmpfr-package} \alias{Rmpfr} \docType{package} \title{R MPFR - Multiple Precision Floating-Point Reliable} \description{ Rmpfr provides S4 classes and methods for arithmetic including transcendental ("special") functions for arbitrary precision floating point numbers, here often called \dQuote{mpfr - numbers}. To this end, it interfaces to the LGPL'ed MPFR (Multiple Precision Floating-Point Reliable) Library which itself is based on the GMP (GNU Multiple Precision) Library. } \details{ % The DESCRIPTION file: \packageDESCRIPTION{Rmpfr} \packageIndices{Rmpfr} The following (help pages) index does not really mention that we provide \emph{many} methods for mathematical functions, including \code{\link{gamma}}, \code{\link{digamma}}, etc, namely, all of \R's (S4) \code{Math} group (with the only exception of \code{\link{trigamma}}), see the list in the examples. Additionally also \code{\link{pnorm}}, the \dQuote{error function}, and more, see the list in \code{\link{zeta}}, and further note the first vignette (below). %% MM: could try more systematically \bold{\emph{Partial} index}: \tabular{ll}{ \code{\link{mpfr}} \tab Create "mpfr" Numbers (Objects) \cr \code{\link{mpfrArray}} \tab Construct "mpfrArray" almost as by \code{\link{array}()} \cr \code{\link{mpfr-class}} \tab Class "mpfr" of Multiple Precision Floating Point Numbers \cr \code{\link{mpfrMatrix-class}} \tab Classes "mpfrMatrix" and "mpfrArray" \cr \tab \cr \code{\link{Bernoulli}} \tab Bernoulli Numbers in Arbitrary Precision \cr \code{\link{Bessel_mpfr}} \tab Bessel functions of Integer Order in multiple precisions \cr \code{\link{c.mpfr}} \tab MPFR Number Utilities \cr \code{\link{cbind}} \tab "mpfr" \code{...} - Methods for Functions cbind(), rbind() \cr \code{\link{chooseMpfr}} \tab Binomial Coefficients and Pochhammer Symbol aka \cr \tab Rising Factorial \cr \code{\link{factorialMpfr}} \tab Factorial 'n!' in Arbitrary Precision \cr \code{\link{formatMpfr}} \tab Formatting MPFR (multiprecision) Numbers \cr \code{\link{getPrec}} \tab Rmpfr - Utilities for Precision Setting, Printing, etc \cr \code{\link{roundMpfr}} \tab Rounding to Binary bits, "mpfr-internally" \cr \code{\link{seqMpfr}} \tab "mpfr" Sequence Generation \cr \code{\link{sumBinomMpfr}} \tab (Alternating) Binomial Sums via Rmpfr \cr \code{\link{zeta}} \tab Special Mathematical Functions (MPFR) \cr \tab \cr \code{\link{integrateR}} \tab One-Dimensional Numerical Integration - in pure R \cr \code{\link{unirootR}} \tab One Dimensional Root (Zero) Finding - in pure R \cr \code{\link{optimizeR}} \tab High Precisione One-Dimensional Optimization \cr \code{\link{hjkMpfr}} \tab Hooke-Jeeves Derivative-Free Minimization R (working for MPFR) \cr } Further information is available in the following vignettes: \tabular{ll}{ \code{Rmpfr-pkg} \tab Arbitrarily Accurate Computation with R: The 'Rmpfr' package (source, pdf)\cr \code{log1mexp-note} \tab Acccurately Computing log(1 - exp(.)) -- Assessed by Rmpfr (source, pdf)\cr } }%- end{details} \author{Martin Maechler} \references{ MPFR (MP Floating-Point Reliable Library), \url{https://www.mpfr.org/}% or http://mpfr.org/ (unfortunately the % http*s* needs the "www") GMP (GNU Multiple Precision library), \url{https://gmplib.org/} and see the vignettes mentioned above. } \seealso{ The \R package \CRANpkg{gmp} for big integer \pkg{\link[gmp:biginteger]{gmp}} and rational numbers (\code{\link[gmp]{bigrational}}) on which \pkg{Rmpfr} depends. } \examples{ ## Using "mpfr" numbers instead of regular numbers... n1.25 <- mpfr(5, precBits = 256)/4 n1.25 ## and then "everything" just works with the desired chosen precision:hig n1.25 ^ c(1:7, 20, 30) ## fully precise; compare with print(1.25 ^ 30, digits=19) exp(n1.25) ## Show all math functions which work with "MPFR" numbers (1 exception: trigamma) getGroupMembers("Math") ## We provide *many* arithmetic, special function, and other methods: showMethods(classes = "mpfr") showMethods(classes = "mpfrArray") } \keyword{package} Rmpfr/man/is.whole.Rd0000644000176200001440000000207011754461676014152 0ustar liggesusers\name{is.whole} \alias{is.whole.mpfr} \title{Whole ("Integer") Numbers} \description{ Check which elements of \code{x[]} are integer valued aka \dQuote{whole} numbers,including MPFR numbers (class \code{\linkS4class{mpfr}}). } \usage{ \S3method{is.whole}{mpfr}(x) } \arguments{ \item{x}{any \R vector, here of \code{\link{class}} \code{\linkS4class{mpfr}}.} } \value{ logical vector of the same length as \code{x}, indicating where \code{x[.]} is integer valued. } \author{Martin Maechler} \seealso{ \code{\link{is.integer}(x)} (\pkg{base} package) checks for the \emph{internal} mode or class, not if \code{x[i]} are integer valued. The \code{\link[gmp]{is.whole}()} methods in package \pkg{gmp}. } \examples{ is.integer(3) # FALSE, it's internally a double is.whole(3) # TRUE x <- c(as(2,"mpfr") ^ 100, 3, 3.2, 1000000, 2^40) is.whole(x) # one FALSE, only \dontshow{ xt <- c(x, as.bigz(2)^120, as.bigq(3,1:3)) stopifnot(identical(is.whole(x), (1:5)!=3), is(xt, "mpfr"), identical(is.whole(xt), is.na(match(1:9, c(3,8))))) }%dont } \keyword{math} Rmpfr/man/gmp-conversions.Rd0000644000176200001440000000562414600265440015543 0ustar liggesusers\name{gmp-conversions} \title{Conversion Utilities gmp <-> Rmpfr} \alias{.bigq2mpfr} \alias{.bigz2mpfr} \alias{.mpfr2bigz} \alias{.mpfr2bigq} \alias{coerce,bigq,mpfr-method} \alias{coerce,bigz,mpfr-method} \description{ Coerce from and to big integers (\code{\link[gmp]{bigz}}) and \code{\link{mpfr}} numbers. Further, coerce from big rationals (\code{\link[gmp]{bigq}}) to \code{\link{mpfr}} numbers. } \usage{ .bigz2mpfr(x, precB = NULL, rnd.mode = c('N','D','U','Z','A')) .bigq2mpfr(x, precB = NULL, rnd.mode = c('N','D','U','Z','A')) .mpfr2bigz(x, mod = NA) .mpfr2bigq(x) }% TODO as(x, "mpfr") \arguments{ \item{x}{an \R object of class \code{bigz}, \code{bigq} or \code{mpfr} respectively.} \item{precB}{precision in bits for the result. The default, \code{NULL}, means to use the \emph{minimal} precision necessary for correct representation.} \item{rnd.mode}{a 1-letter string specifying how \emph{rounding} should happen at C-level conversion to MPFR, see details of \code{\link{mpfr}}.} \item{mod}{a possible modulus, see \code{\link[gmp]{as.bigz}} in package \pkg{gmp}.} } \details{ Note that we also provide the natural (S4) coercions, \code{as(x, "mpfr")} for \code{x} inheriting from class \code{"bigz"} or \code{"bigq"}. } \value{ a numeric vector of the same length as \code{x}, of the desired class. } \seealso{ \code{\link{mpfr}()}, \code{\link[gmp]{as.bigz}} and \code{\link[gmp]{as.bigq}} in package \pkg{gmp}. } \examples{ S <- gmp::Stirling2(50,10) show(S) SS <- S * as.bigz(1:3)^128 stopifnot(all.equal(log2(SS[2]) - log2(S), 128, tolerance=1e-15), identical(SS, .mpfr2bigz(.bigz2mpfr(SS)))) .bigz2mpfr(S) # 148 bit precision .bigz2mpfr(S, precB=256) # 256 bit ## rational --> mpfr: sq <- SS / as.bigz(2)^100 MP <- as(sq, "mpfr") stopifnot(identical(MP, .bigq2mpfr(sq)), SS == MP * as(2, "mpfr")^100) ## New since 2024-01-20: mpfr --> big rational "bigq" Pi <- Const("pi", 128) m <- Pi* 2^(-5:5) (m <- c(m, mpfr(2, 128)^(-5:5))) ## 1 x large num/denom, then 2^(-5:5) as frac tail( Q <- .mpfr2bigq(m) , 12) getDenom <- Rmpfr:::getDenom stopifnot(is.whole(m * (d.m <- getDenom(m)))) stopifnot(all.equal(m, mpfr(Q, 130), tolerance = 2^-130)) # I see even all.equal(m, mpfr(Q, 130), tolerance = 0) # TRUE m <- m * mpfr(2, 128)^200 # quite a bit larger tail( Q. <- .mpfr2bigq(m) , 12) # large integers .. stopifnot(is.whole(m * (d.m <- getDenom(m)))) stopifnot(all.equal(m, mpfr(Q., 130), tolerance = 2^-130)) # I see even all.equal(m, mpfr(Q., 130), tolerance = 0) # TRUE m2 <- m * mpfr(2, 128)^20000 ## really huge stopifnot(is.whole(m2 * (d.m2 <- getDenom(m2)))) denominator(Q2 <- .mpfr2bigq(m2)) ## all 1 ! (all m2 ~~ 2^20200 ) stopifnot(all.equal(m2, mpfr(Q2, 130), tolerance = 2^-130)) # I see even all.equal(m2, mpfr(Q2, 130), tolerance = 0) # TRUE } \keyword{arith}% <- or better ? Rmpfr/man/Mnumber-class.Rd0000644000176200001440000000344511764636731015136 0ustar liggesusers\name{Mnumber-class} \Rdversion{1.1} \docType{class} \alias{Mnumber-class} \alias{mNumber-class} \alias{numericVector-class} \title{Class "Mnumber" and "mNumber" of "mpfr" and regular numbers and arrays from them} \description{ Classes \code{"Mnumber"} \code{"mNumber"} are class unions of \code{"\linkS4class{mpfr}"} and regular numbers and arrays from them.\cr Its purpose is for method dispatch, notably defining a \code{cbind(...)} method where \code{...} contains objects of one of the member classes of \code{"Mnumber"}. Classes \code{"mNumber"} is considerably smaller is it does \emph{not} contain \code{"matrix"} and \code{"array"} since these also extend \code{"character"} which is not really desirable for generalized numbers. It extends the simple \code{"numericVector"} class by \code{mpfr*} classes. } \section{Methods}{ \describe{ \item{\%*\%}{\code{signature(x = "mpfrMatrix", y = "Mnumber")}: ... } \item{crossprod}{\code{signature(x = "mpfr", y = "Mnumber")}: ... } \item{tcrossprod}{\code{signature(x = "Mnumber", y = "mpfr")}: ...} } etc. These are documented with the classes \code{\linkS4class{mpfr}} and or \code{\linkS4class{mpfrMatrix}}. } \seealso{ the \code{\linkS4class{array_or_vector}} sub class; \code{\link{cbind-methods}}. } \examples{ ## "Mnumber" encompasses (i.e., "extends") quite a few ## "vector / array - like" classes: showClass("Mnumber") stopifnot(extends("mpfrMatrix", "Mnumber"), extends("array", "Mnumber")) Mnsub <- names(getClass("Mnumber")@subclasses) (mNsub <- names(getClass("mNumber")@subclasses)) ## mNumber has *one* subclass which is not in Mnumber: setdiff(mNsub, Mnsub)# namely "numericVector" ## The following are only subclasses of "Mnumber", but not of "mNumber": setdiff(Mnsub, mNsub) } \keyword{classes} Rmpfr/man/utils.Rd0000644000176200001440000000560414644764560013567 0ustar liggesusers\name{mpfr.utils} \title{MPFR Number Utilities} \alias{c.mpfr} \alias{diff.mpfr} \alias{mpfrIs0} \alias{.mpfr.is.whole} \alias{mpfrVersion} %% next two are deprecated since Aug.2015 (for Rmpfr 0.6.0): \alias{mpfr.is.0} \alias{mpfr.is.integer} % \description{ \code{mpfrVersion()} returns the version of the MPFR library which \pkg{Rmpfr} is currently linked to. \code{\link{c}(x,y,...)} can be used to combine MPFR numbers in the same way as regular numbers \bold{IFF} the first argument \code{x} is of class \code{\linkS4class{mpfr}}. \code{mpfrIs0(.)} uses the MPFR library in the documented way to check if (a vector of) MPFR numbers are zero. It was called \code{mpfr.is.0} which is strongly deprecated now. \code{.mpfr.is.whole(x)} uses the MPFR library in the documented way to check if (a vector of) MPFR numbers is integer \emph{valued}. This is equivalent to \code{x == round(x)}, but \emph{not} at all to \code{is.integer(as(x, "numeric"))}.\cr You should typically rather use (the \code{"mpfr"} method of the generic function) \code{\link[gmp]{is.whole}(x)} from \CRANpkg{gmp} instead. The former name \code{mpfr.is.integer} is deprecated now. } \usage{ mpfrVersion() mpfrIs0(x) %% .mpfr.is.whole(x) \method{c}{mpfr}(\dots) \method{diff}{mpfr}(x, lag = 1L, differences = 1L, \dots) } \arguments{ \item{x}{an object of class \code{\linkS4class{mpfr}}.} \item{\dots}{for \code{diff}, further \code{\linkS4class{mpfr}} class objects or simple numbers (\code{\link{numeric}} vectors) which are coerced to \code{mpfr} with default precision of 128 bits.} \item{lag, differences}{for \code{diff()}: exact same meaning as in \code{\link{diff}()}'s default method, \code{\link{diff.default}}.} } % \details{ % ~~ If necessary, more details than the description above ~~ % } \value{ \code{mpfrIs0} returns a logical vector of length \code{length(x)} with values \code{TRUE} iff the corresponding \code{x[i]} is an MPFR representation of zero (\code{0}). \cr Similarly, \code{.mpfr.is.whole} and \code{is.whole} return a logical vector of length \code{length(x)}. \code{mpfrVersion} returns an object of S3 class \code{"\link{numeric_version}"}, so it can be used in comparisons. The other functions return MPFR number (vectors), i.e., extending class \code{\linkS4class{mpfr}}. } \seealso{ \code{\link{str.mpfr}} for the \code{\link{str}} method. \code{\link{erf}} for special mathematical functions on MPFR. The class description \code{\linkS4class{mpfr}} page mentions many generic arithmetic and mathematical functions for which \code{"mpfr"} methods are available. } \examples{ mpfrVersion() (x <- c(Const("pi", 64), mpfr(-2:2, 64))) mpfrIs0(x) # one of them is x[mpfrIs0(x)] # but it may not have been obvious.. str(x) x <- rep(-2:2, 5) stopifnot(is.whole(mpfr(2, 500) ^ (1:200)), all.equal(diff(x), diff(as.numeric(x)))) } \keyword{arith} Rmpfr/man/array_or_vector-class.Rd0000644000176200001440000000172714245753567016736 0ustar liggesusers\name{array_or_vector-class} \docType{class} \alias{array_or_vector-class} \title{Auxiliary Class "array_or_vector"} \description{ \code{"array_or_vector"} is the class union of \code{c("array", "matrix", "vector")} and exists for its use in signatures of method definitions. } \section{Objects from the Class}{A virtual Class: No objects may be created from it. } % \section{Methods}{ % \describe{ % \item{...}{.....} % } % } \details{ Using \code{"array_or_vector"} instead of just \code{"vector"} in a signature makes an important difference: E.g., if we had \code{setMethod(crossprod, c(x="mpfr", y="vector"), function(x,y) CPR(x,y))}, a call \code{crossprod(x, matrix(1:6, 2,3))} would extend into a call of \code{CPR(x, as(y, "vector"))} such that \code{CPR()}'s second argument would simply be a vector instead of the desired \eqn{2\times3}{2 x 3} matrix. } %\author{Martin Maechler} \examples{ showClass("array_or_vector") } \keyword{classes} Rmpfr/man/log1mexp.Rd0000644000176200001440000001025113751607232014143 0ustar liggesusers\name{log1mexp}% originally ~/R/Pkgs/copula/man/log1mexp.Rd __keep in sync !!__ \alias{log1pexp} \alias{log1mexp} \title{Compute f(a) = \eqn{\mathrm{log}}{log}(1 +/- \eqn{\mathrm{exp}}{exp}(-a)) Numerically Optimally} \description{ Compute f(a) = log(1 - exp(-a)), respectively g(x) = log(1 + exp(x)) quickly numerically accurately. } \usage{ log1mexp(a, cutoff = log(2)) log1pexp(x, c0 = -37, c1 = 18, c2 = 33.3) } \arguments{ \item{a}{numeric (or \code{\link{mpfr}}) vector of positive values.} \item{x}{numeric vector, may also be an \code{"\link{mpfr}"} object.} \item{cutoff}{positive number; \code{log(2)} is \dQuote{optimal}, %% see below, TODO but the exact value is unimportant, and anything in \eqn{[0.5, 1]} is fine.} \item{c0, c1, c2}{cutoffs for \code{log1pexp}; see below.} } \value{ \deqn{log1mexp(a) := f(a) = \log(1 - \exp(-a)) = \mathrm{log1p}(-\exp(-a)) = \log(-\mathrm{expm1}(-a))}{% log1mexp(a) := f(a) = log(1 - exp(-a)) = log1p(- exp(-a)) = log(- expm1(-a))} or, respectively, \deqn{log1pexp(x) := g(x) = \log(1 + \exp(x)) = \mathrm{log1p}(\exp(x))}{% log1pexp(x) := g(x) = log(1 + exp(x)) = log1p(exp(x))} computed accurately and quickly. } \author{Martin Maechler, May 2002; \code{log1pexp()} in 2012} \references{% ~/R/Pkgs/Rmpfr/vignettes/log1mexp-note.Rnw Martin \enc{Mächler}{Maechler} (2012). Accurately Computing \eqn{\log(1-\exp(-|a|))}; \url{https://CRAN.R-project.org/package=Rmpfr/vignettes/log1mexp-note.pdf}. % see also <> in ~/R/Pkgs/copula/inst/doc/Frank-Rmpfr.Rnw } \examples{ fExpr <- expression( DEF = log(1 - exp(-a)), expm1 = log(-expm1(-a)), log1p = log1p(-exp(-a)), F = log1mexp(a)) a. <- 2^seq(-58, 10, length = 256) a <- a. ; str(fa <- do.call(cbind, as.list(fExpr))) head(fa)# expm1() works here tail(fa)# log1p() works here ## graphically: lwd <- 1.5*(5:2); col <- adjustcolor(1:4, 0.4) op <- par(mfcol=c(1,2), mgp = c(1.25, .6, 0), mar = .1+c(3,2,1,1)) matplot(a, fa, type = "l", log = "x", col=col, lwd=lwd) legend("topleft", fExpr, col=col, lwd=lwd, lty=1:4, bty="n") # expm1() & log1mexp() work here matplot(a, -fa, type = "l", log = "xy", col=col, lwd=lwd) legend("left", paste("-",fExpr), col=col, lwd=lwd, lty=1:4, bty="n") # log1p() & log1mexp() work here par(op) aM <- 2^seqMpfr(-58, 10, length=length(a.)) # => default prec = 128 a <- aM; dim(faM <- do.call(cbind, as.list(fExpr))) # 256 x 4, "same" as 'fa' ## Here, for small 'a' log1p() and even 'DEF' is still good enough l_f <- asNumeric(log(-faM)) all.equal(l_f[,"F"], l_f[,"log1p"], tol=0) # see TRUE (Lnx 64-bit) io <- a. < 80 # for these, the differences are small all.equal(l_f[io,"F"], l_f[io,"expm1"], tol=0) # see 6.662e-9 all.equal(l_f[io,"F"], l_f[io, "DEF" ], tol=0) stopifnot(exprs = { all.equal(l_f[,"F"], l_f[,"log1p"], tol= 1e-15) all.equal(l_f[io,"F"], l_f[io,"expm1"], tol= 1e-7) all.equal(l_f[io,"F"], l_f[io, "DEF" ], tol= 1e-7) }) ## For 128-bit prec, if we go down to 2^-130, "log1p" is no longer ok: aM2 <- 2^seqMpfr(-130, 10, by = 1/2) a <- aM2; fa2 <- do.call(cbind, as.list(fExpr)) head(asNumeric(fa2), 12) tail(asNumeric(fa2), 12) matplot(a, log(-fa2[,1:3]) -log(-fa2[,"F"]), type="l", log="x", lty=1:3, lwd=2*(3:1)-1, col=adjustcolor(2:4, 1/3)) legend("top", colnames(fa2)[1:3], lty=1:3, lwd=2*(3:1)-1, col=adjustcolor(2:4, 1/3)) cols <- adjustcolor(2:4, 1/3); lwd <- 2*(3:1)-1 matplot(a, 1e-40+abs(log(-fa2[,1:3]) -log(-fa2[,"F"])), type="o", log="xy", main = "log1mexp(a) -- approximation rel.errors, mpfr(*, prec=128)", pch=21:23, cex=.6, bg=5:7, lty=1:2, lwd=lwd, col=cols) legend("top", colnames(fa2)[1:3], bty="n", lty=1:2, lwd=lwd, col=cols, pch=21:23, pt.cex=.6, pt.bg=5:7) ## -------------------------- log1pexp() [simpler] -------------------- curve(log1pexp, -10, 10, asp=1) abline(0,1, h=0,v=0, lty=3, col="gray") ## Cutoff c1 for log1pexp() -- not often "needed": curve(log1p(exp(x)) - log1pexp(x), 16, 20, n=2049) ## need for *some* cutoff: x <- seq(700, 720, by=2) cbind(x, log1p(exp(x)), log1pexp(x)) ## Cutoff c2 for log1pexp(): curve((x+exp(-x)) - x, 20, 40, n=1025) curve((x+exp(-x)) - x, 33.1, 33.5, n=1025) } \keyword{math} Rmpfr/man/roundMpfr.Rd0000644000176200001440000000234112561376373014373 0ustar liggesusers\name{roundMpfr} \title{Rounding to Binary bits, "mpfr-internally"} \alias{roundMpfr} \alias{setPrec}% <- so its found \description{Rounding to binary bits, not decimal digits. Closer to the number representation, this also allows to \emph{increase} or decrease a number's precBits. In other words, it acts as \code{setPrec()}, see \code{\link{getPrec}()}. } \usage{ roundMpfr(x, precBits, rnd.mode = c("N","D","U","Z","A")) } \arguments{ \item{x}{an mpfr number (vector)} \item{precBits}{integer specifying the desired precision in bits.} \item{rnd.mode}{a 1-letter string specifying how \emph{rounding} should happen at C-level conversion to MPFR, see \code{\link{mpfr}}.} } % \details{ % } \value{an mpfr number as \code{x} but with the new 'precBits' precision} \seealso{ The \code{\linkS4class{mpfr}} class group method \code{Math2} implements a method for \code{\link{round}(x, digits)} which rounds to \emph{decimal} digits. } \examples{ (p1 <- Const("pi", 100)) # 100 bit prec roundMpfr(p1, 120) # 20 bits more, but "random noise" Const("pi", 120) # same "precision", but really precise \dontshow{ stopifnot(120 == getPrec(roundMpfr(p1, 120)), 75 == getPrec(roundMpfr(p1, 75))) } } \keyword{arith} Rmpfr/man/bind-methods.Rd0000644000176200001440000000341012772467643014777 0ustar liggesusers\name{bind-methods} \title{"mpfr" '...' - Methods for Functions cbind(), rbind()} \docType{methods} \alias{cbind} \alias{rbind} \alias{cbind-methods} \alias{rbind-methods} \alias{cbind,ANY-method} \alias{cbind,Mnumber-method} \alias{rbind,ANY-method} \alias{rbind,Mnumber-method} \description{ \code{\link{cbind}} and \code{\link{rbind}} methods for signature \code{...} (see \code{\link[methods]{dotsMethods}} are provided for class \code{\linkS4class{Mnumber}}, i.e., for binding numeric vectors and class \code{"\linkS4class{mpfr}"} vectors and matrices (\code{"\linkS4class{mpfrMatrix}"}) together. } \usage{ cbind(\dots, deparse.level = 1) rbind(\dots, deparse.level = 1) } \arguments{ \item{\dots}{matrix-/vector-like \R objects to be bound together, see the \pkg{base} documentation, \code{\link[base:cbind]{cbind}}. } \item{deparse.level}{integer determining under which circumstances column and row names are built from the actual arguments' \sQuote{expression}, see \code{\link{cbind}}.} } \section{Methods}{ \describe{ \item{... = "Mnumber"}{is used to (c|r)bind multiprecision \dQuote{numbers} (inheriting from class \code{"\linkS4class{mpfr}"}) together, maybe combined with simple numeric vectors.} \item{... = "ANY"}{reverts to \code{\link[base]{cbind}} and \code{rbind} from package \pkg{base}.} } } \value{ typically a \sQuote{matrix-like} object, here typically of \code{\link{class} "\linkS4class{mpfrMatrix}"}. } % \references{ ~put references to the literature/web site here ~ } \author{Martin Maechler} \seealso{\code{\link{cbind2}}, \code{\link{cbind}}, Documentation in base \R's \pkg{methods} package% R <= 3.3.1 \code{\link[methods]{Methods}} } \examples{ cbind(1, mpfr(6:3, 70)/7, 3:0) } \keyword{methods} Rmpfr/man/pmax.Rd0000644000176200001440000000336211764636731013371 0ustar liggesusers\name{pmax} \Rdversion{1.1} \alias{pmax} \alias{pmin} \alias{pmax-methods} \alias{pmin-methods} \alias{pmax,ANY-method} \alias{pmax,mNumber-method} \alias{pmin,ANY-method} \alias{pmin,mNumber-method} \title{Parallel Maxima and Minima} \description{ Returns the parallel maxima and minima of the input values. The functions \code{pmin} and \code{pmax} have been made S4 generics, and this page documents the \dQuote{\code{...} method for class \code{"mNumber"}}, i.e., for arguments that are numeric or from \code{\link{class} "\linkS4class{mpfr}"}. } \usage{ pmax(\dots, na.rm = FALSE) pmin(\dots, na.rm = FALSE) } \arguments{ \item{\dots}{numeric or arbitrary precision numbers (class \code{\linkS4class{mpfr}}).} \item{na.rm}{a logical indicating whether missing values should be removed.} } \details{ See \code{\link[base:Extremes]{pmax}}, the documentation of the base functions, i.e., default methods. } \value{ vector-like, of length the longest of the input vectors; typically of class \code{\linkS4class{mpfr}}, for the methods here. } \section{Methods}{ \describe{ \item{... = "ANY"}{the default method, really just \code{\link[base:Extremes]{base::pmin}} or \code{base::pmax}, respectively.} \item{... = "mNumber"}{the method for \code{\linkS4class{mpfr}} arguments, mixed with numbers; designed to follow the same semantic as the default method.} } } \seealso{ The documentation of the \pkg{base} functions, \code{\link[base:Extremes]{pmin}} and \code{pmax}; also \code{\link{min}} and \code{max}; further, \code{\link{range}} (\emph{both} min and max). } \examples{ (pm <- pmin(1.35, mpfr(0:10, 77))) stopifnot(pm == pmin(1.35, 0:10)) } \keyword{methods} \keyword{univar} \keyword{arith} Rmpfr/man/formatHex.Rd0000644000176200001440000001634313220705115014342 0ustar liggesusers\name{formatHex} \title{Flexibly Format Numbers in Binary, Hex and Decimal Format} \alias{formatHex} \alias{formatBin} \alias{formatDec} %% \alias{formatHexInternal} \alias{print.Ncharacter}% not mentioned \description{ Show numbers in binary, hex and decimal format. The resulting character-like objects can be back-transformed to \code{"mpfr"} numbers via \code{\link{mpfr}()}. } \usage{ formatHex(x, precBits = min(getPrec(x)), style = "+", expAlign = TRUE) formatBin(x, precBits = min(getPrec(x)), scientific = TRUE, left.pad = "_", right.pad = left.pad, style = "+", expAlign = TRUE) %% FIXME: Currently needed mainly because decimal point alignment. %% ----- TODO: Allow formatMpfr(.) to do decimal alignment -- even by default formatDec(x, precBits = min(getPrec(x)), digits = decdigits, nsmall = NULL, scientific = FALSE, style = "+", decimalPointAlign = TRUE, \dots) %% ## not exported: %% formatHexInternal(x, precBits = min(Rmpfr::getPrec(x)), style = "+", expAlign=TRUE) %% formatAlign(x, leftpad=" ", rightpad=leftpad, \dots) %% sprintfMpfr(x, bits, style = "+", expAlign=TRUE) } \arguments{ \item{x}{a \code{numeric} or \code{\link{mpfr}} \R object.} \item{precBits}{integer, the number of bits of precision, typically derived from \code{x}, see \code{\link{getPrec}}. Numeric, i.e., double precision numbers have 53 bits. For more detail, see \code{\link[Rmpfr]{mpfr}}.} \item{style}{a single character, to be used in \code{\link{sprintf}}'s format (\code{fmt}), immediately after the "%". The default always sets a sign in the output, i.e., \code{"+"} or \code{"-"}, where as \code{style = " "} may seem more standard.} \item{expAlign}{\code{\link{logical}} indicating if for scientific (\dQuote{exponential}) representations the exponents should be aligned to the same width, i.e., zero-padded to the same number of digits.} \item{scientific}{\code{\link{logical}} indicating that \code{formatBin} should display the binary representation in scientific notation (\code{mpfr(3, 5)} is displayed as \code{+0b1.1000p+1}). When \code{FALSE}, \code{formatBin} will display the binary representation in regular format shifted to align binary points (\code{mpfr(3, 5)} is displayed \code{+0b11.000}).} \item{\dots}{additional optional arguments. %% \code{formatHexInternal}, \code{formatHex}, \code{formatBin}: \code{precBits} is the only \code{\dots} argument acted on. Other \code{\dots} arguments are ignored. \code{formatDec}: \code{precBits} is acted on. Any argument accepted by \code{\link[base]{format}} (except \code{nsmall}) is acted on. Other \code{\dots} arguments are ignored. } \item{left.pad, right.pad}{characters (one-character strings) that will be used for left- and right-padding of the formatted string when \code{scientific=FALSE}. \emph{Do not change these unless for display-only purpose !!}} \item{nsmall}{only used when \code{scientific} is false, then passed to \code{\link{format}()}. If \code{NULL}, the default is computed from the range of the non-zero values of \code{x}.} \item{digits}{integer; the number of decimal digits displayed is the larger of this argument and the internally generated value that is a function of \code{precBits}. This is related to but different than \code{digits} in \code{\link{format}}.} \item{decimalPointAlign}{logical indicating if padding should be used to ensure that the resulting strings align on the decimal point (\code{"."}).} } \details{ For the hexadecimal representation, when the precision is not larger than double precision, \code{\link[base]{sprintf}()} is used directly, otherwise \code{\link{formatMpfr}()} is used and post processed. For the binary representation, the hexadecimal value is calculated and then edited by substitution of the binary representation of the hex characters coded in the \code{HextoBin} vector. For binary with \code{scientific=FALSE}, the result of the \code{scientific=TRUE} version is edited to align binary points. For the decimal representation, the hexadecimal value is calculated with the specified precision and then sent to the \code{format} function for \code{scientific=FALSE} or to the sprintf function for \code{scientific=TRUE}. } \value{ a character vector (or matrix) like \code{x}, say \code{r}, containing the formatted represention of \code{x}, with a \code{\link{class}} (unless \code{left.pad} or \code{right.pad} were not \code{"_"}). In that case, \code{formatHex()} and \code{formatBin()} return class \code{"Ncharacter"}; for that, \code{\link{mpfr}(.)} has a method and will basically return \code{x}, i.e., work as \emph{inverse} function. Since \pkg{Rmpfr} version \command{0.6-2}, the S3 class \code{"Ncharacter"} extends \code{"character"}. (\code{class(.)} is now of length two and \code{class(.)[2]} is \code{"character"}.). There are simple \code{[} and \code{\link{print}} methods; modifying or setting \code{dim} works as well. } \references{ R FAQ 7.31: Why doesn't R think these numbers are equal? \code{system.file("../../doc/FAQ")} } \author{Richard M. Heiberger \email{rmh@temple.edu}, with minor tweaking by Martin M.} \seealso{ \code{\link[Rmpfr]{mpfr}}, \code{\link[base]{sprintf}} } \examples{ FourBits <- mpfr(matrix(0:31, 8, 4, dimnames = list(0:7, c(0,8,16,24))), precBits=4) ## 4 significant bits FourBits formatHex(FourBits) formatBin(FourBits, style = " ") formatBin(FourBits, scientific=FALSE) formatDec(FourBits) ## as "Ncharacter" 'inherits from' "character", this now works too : data.frame(Dec = c( formatDec(FourBits) ), formatHex(FourBits), Bin = formatBin(FourBits, style = " ")) FBB <- formatBin(FourBits) ; clB <- class(FBB) (nFBB <- mpfr(FBB)) stopifnot(class(FBB)[1] == "Ncharacter", all.equal(nFBB, FourBits, tol=0)) FBH <- formatHex(FourBits) ; clH <- class(FBH) (nFBH <- mpfr(FBH)) stopifnot(class(FBH)[1] == "Ncharacter", all.equal(nFBH, FourBits, tol=0)) ## Compare the different "formattings" (details will change, i.e. improve!)%% FIXME M <- mpfr(c(-Inf, -1.25, 1/(-Inf), NA, 0, .5, 1:2, Inf), 3) data.frame(fH = formatHex(M), f16 = format(M, base=16), fB = formatBin(M), f2 = format(M, base= 2), fD = formatDec(M), f10 = format(M), # base = 10 is default fSci= format(M, scientific=TRUE), fFix= format(M, scientific=FALSE)) ## Other methods ("[", t()) also work : stopifnot(dim(F1 <- FBB[, 1, drop=FALSE]) == c(8,1), identical(class( F1), clB), dim(t(F1)) == c(1,8), identical(class(t(F1)),clB), is.null(dim(F.2 <- FBB[,2])), identical(class( F.2), clB), dim(F22 <- FBH[1:2, 3:4]) == c(2,2), identical(class(F22), clH), identical(class(FBH[2,3]), clH), is.null(dim(FBH[2,3])), identical(FBH[2,3:4], F22[2,]), identical(FBH[2,3], unname(FBH[,3][2])), TRUE) TenFrac <- matrix((1:10)/10, dimnames=list(1:10, expression(1/x))) TenFrac9 <- mpfr(TenFrac, precBits=9) ## 9 significant bits TenFrac9 formatHex(TenFrac9) formatBin(TenFrac9) formatBin(TenFrac9, scientific=FALSE) formatDec(TenFrac9) formatDec(TenFrac9, precBits=10) } \keyword{ arith } Rmpfr/man/asNumeric-methods.Rd0000644000176200001440000000325414657140744016011 0ustar liggesusers\name{asNumeric-methods} \docType{methods} %% FIXME?? Should this migrate to base ?? --> have implicit generic and S3 generic there! %% ----- there, with semantic storage.mode(x) <- "numeric" \alias{asNumeric-methods} \alias{asNumeric,mpfr-method} \alias{asNumeric,mpfrArray-method} \title{Methods for \code{asNumeric()}} \description{% --> ~/R/Pkgs/gmp/man/asNumeric.Rd Methods for function \code{\link[gmp]{asNumeric}} (in package \pkg{gmp}). } \usage{ %\S4method{asNumeric}{mpfr}(x) \S4method{asNumeric}{mpfrArray}(x) } \arguments{ \item{x}{a \dQuote{number-like} object, here, a \code{\linkS4class{mpfr}} or typically \code{\linkS4class{mpfrArray}}one.} } \section{Methods}{ \describe{ \item{\code{signature(x = "mpfrArray")}}{this method also dispatches for \code{\linkS4class{mpfrMatrix}} and returns a numeric array.} \item{\code{signature(x = "mpfr")}}{for non-array/matrix, \code{asNumeric(x)} is basically the same as \code{as.numeric(x)}.} } } \value{ an \R object of type (\code{\link{typeof}}) \code{"numeric"}, a \code{\link{matrix}} or \code{\link{array}} if \code{x} had non-NULL dimension \code{\link{dim}()}. } \author{Martin Maechler} \seealso{ our lower level (non-generic) \code{\link{toNum}()}. Further, \code{\link[gmp]{asNumeric}} (package \CRANpkg{gmp}), standard \R's \code{\link{as.numeric}()}. } \examples{ x <- (0:7)/8 # (exact) X <- mpfr(x, 99) stopifnot(identical(asNumeric(x), x), identical(asNumeric(X), x)) m <- matrix(1:6, 3,2) (M <- mpfr(m, 99) / 5) ##-> "mpfrMatrix" asNumeric(M) # numeric matrix stopifnot(all.equal(asNumeric(M), m/5), identical(asNumeric(m), m))# remains matrix } \keyword{methods} Rmpfr/man/mpfr-utils.Rd0000644000176200001440000003046315075433454014524 0ustar liggesusers\name{mpfr-utils} \title{Rmpfr -- Utilities for Precision Setting, etc} \alias{getPrec} \alias{.getPrec} \alias{getD} \alias{mpfr_default_prec} \alias{mpfr2array} \alias{mpfrImport} \alias{mpfrXport} %\alias{.mpfr1tolist}% not exported % \alias{print.mpfr} ==> ./formatMpfr.Rd \alias{toNum} \alias{.mpfr2d} \alias{.mpfr2i} \alias{.mpfr2list} %- \alias{.mpfr_formatinfo} \alias{.mpfr2exp} %- \alias{.mpfr_erange} \alias{.mpfr_erange_set} \alias{.mpfr_erange_kinds} \alias{.mpfr_erange_is_int} \alias{.mpfr_maxPrec} \alias{.mpfr_minPrec} \alias{.mpfr_gmp_numbbits} \alias{.mpfrSizeof} \alias{.mpfrVersion} %- really internal \alias{..bigq2mpfr} \alias{..bigz2mpfr} \alias{.getSign} \alias{.mpfr_negative} \alias{.mpfr_sign} \alias{.mpfr} \alias{.mpfr.} \description{ This page documents utilities from package \pkg{Rmpfr} which are typically not called by the user, but may come handy in some situations. Notably, the (base-2) maximal (and minimal) precision and the \dQuote{erange}, the range of possible (base-2) exponents of \code{\link{mpfr}}-numbers can be queried and partly extended. } \usage{ getPrec(x, base = 10, doNumeric = TRUE, is.mpfr = NA, bigq. = 128L) .getPrec(x) getD(x) mpfr_default_prec(prec) toNum(from, rnd.mode = c('N','D','U','Z','A')) .mpfr2d(from) .mpfr2i(from) mpfr2array(x, dim, dimnames = NULL, check = FALSE) .mpfr2list(x, names = FALSE) mpfrXport(x, names = FALSE) mpfrImport(mxp) .mpfr_formatinfo(x) .mpfr2exp(x) .mpfr_erange(kind = c("Emin", "Emax"), names = TRUE) .mpfr_erange_set(kind = c("Emin", "Emax"), value) .mpfr_erange_kinds .mpfr_erange_is_int() .mpfr_maxPrec() .mpfr_minPrec() .mpfr_gmp_numbbits() .mpfrSizeof() .mpfrVersion() ## Really Internal and low level, no error checking (for when you know ..) .mpfr (x, precBits) .mpfr.(x, precBits, rnd.mode) .getSign(x) .mpfr_negative(x) .mpfr_sign(x) ..bigq2mpfr(x, precB = NULL, rnd.mode = c("N", "D", "U", "Z", "A")) ..bigz2mpfr(x, precB = NULL, rnd.mode = c("N", "D", "U", "Z", "A")) } \arguments{ \item{x, from}{typically, an \R object of class \code{"\linkS4class{mpfr}"}, or \code{"\linkS4class{mpfrArray}"}, respectively. For \code{getPrec()}, any number-like \R object, or \code{\link{NULL}}.} \item{base}{(only when \code{x} is \code{\link{character}}) the base with respect to which \code{x[i]} represent numbers; \code{base} \eqn{b} must fulfill \eqn{2 \le b \le 62}{2 <= b <= 62}.} \item{doNumeric}{logical indicating \code{\link{integer}} or \code{\link{double}} typed \code{x} should be accepted and a default precision be returned. Should typically be kept at default \code{TRUE}.} \item{is.mpfr}{logical indicating if \code{\link{class}(x)} is already known to be \code{"mpfr"}; typically should be kept at default, \code{NA}.} \item{bigq.}{for \code{getPrec()}, the precision to use for a big rational (class \code{"bigq"}); if not specified gives warning when used.} \item{prec, precB, precBits}{a positive integer, not larger than \code{\link{.Machine}$ integer.max}, or missing.} \item{rnd.mode}{a 1-letter string specifying how \emph{rounding} should happen at C-level conversion to MPFR, see details of \code{\link{mpfr}}.} \item{dim, dimnames}{for \code{"\linkS4class{mpfrArray}"} construction.} \item{check}{logical indicating if the mpfrArray construction should happen with internal safety check. Previously, the implicit default used to be true.} \item{names}{(for \code{.mpfr2list()}) \code{\link{logical}} or \code{\link{character}} vector, indicating if the list returned should have \code{\link{names}}. If character, it specifies the names; if true, the names are set to \code{format(x)}.} \item{mxp}{an \code{"mpfrXport"} object, as resulting from \code{mpfrXport()}.} \item{kind}{a \code{\link{character}} string or vector, specifying the kind of \dQuote{erange} value; must be an element of \code{.mpfr_erange_kinds}, i.e., one of \code{"Emin"}, \code{"Emax"}, \code{"min.emin"}, \code{"max.emin"}, \code{"min.emax"}, \code{"max.emax"}.} \item{value}{\code{\link{numeric}}, for \code{.mpfr_erange_set()} one number per \code{kind}. Must be in range specified by the \code{*."emin"} and \code{*."emax"} erange values.} } \details{ The \code{.mpfr_erange*} functions (and variable) allow to query and set the allowed range of values for the base-2 \emph{exponents} of \code{"mpfr"} numbers. See the examples below and GNU MPFR library documentation on the C functions \code{mpfr_get_emin()}, \code{mpfr_set_emin(.)}, \code{mpfr_get_emin_min()}, and \code{mpfr_get_emin_max()}, (and those four with \sQuote{_emin} replaced by \sQuote{_emax} above). } \value{ \code{getPrec(x)} returns a \code{\link{integer}} vector of length one or the same length as \code{x} when that is positive, whereas \code{getPrec(NULL)} returns \code{mpfr_default_prec()}, see below. % the current MPFR default precision, see \code{mpfr_default_prec()} If you need to \emph{change} the precision of \code{x}, i.e., need something like \dQuote{setPrec}, use \code{\link{roundMpfr}()}. \code{.getPrec(x)} is a simplified version of \code{getPrec()} which only works for \code{"mpfr"} objects \code{x}. \code{getD(x)} is intended to be a fast version of \code{x@.Data}, and should not be used outside of lower level functions. \code{mpfr_default_prec()} returns the current MPFR default precision, an \code{\link{integer}}. This is currently % ?? not made use of much in package \pkg{Rmpfr}, where functions have their own default precision where needed, and otherwise we'd rather not be dependent of such a \emph{global} setting. \cr \code{mpfr_default_prec(prec)} \emph{sets} the current MPFR default precision and returns the previous one; see above. \code{.mpfr_maxPrec()} and (less interestingly) \code{.mpfr_minPrec()} give the maximal and minimal base-2 precision allowed in the current version of the MPFR library linked to by \R package \pkg{Rmpfr}. The maximal precision is typically \eqn{2^{63}}, i.e., \preformatted{ all.equal(.mpfr_maxPrec(), 2^63) } is typically true. \code{toNum(m)} returns a numeric \code{\link{array}} or \code{\link{matrix}}, when \code{m} is of class \code{"\linkS4class{mpfrArray}"} or \code{"\linkS4class{mpfrMatrix}"}, respectively. It should be equivalent to \code{as(m, "array")} or \code{... "matrix"}. Note that the slightly more general \code{\link[gmp]{asNumeric}()} from \CRANpkg{gmp} is preferred now. \code{.mpfr2d()} is similar to but simpler than \code{toNum()}, whereas \code{.mpfr2i()} is an analogue low level utility for \code{\link{as.integer}()}. \code{mpfr2array()} a slightly more flexible alternative to \code{dim(.) <- dd}. \code{.mpfr2exp(x)} returns the base-2 (integer valued) exponents of \code{x}, i.e., it is the \R interface to MPFR C's \code{mpfr_get_exp()}. The result is \code{\link{integer}} iff \code{.mpfr_erange_is_int()} is true, otherwise \code{\link{double}}. Note that the MPFR (4.0.1) manual says about \code{mpfr_get_exp()}: \emph{The behavior for NaN, infinity or zero is undefined}. \code{.mpfr_erange_is_int()} returns \code{TRUE} iff the \code{.mpfr_erange(c("Emin","Emax"))} range lies inside the range of \R's \code{\link{integer}} limits, i.e., has absolute values not larger than \code{\link{.Machine}$integer.max} (\eqn{ = 2^{31} - 1}). \code{.mpfr_erange_set()} \emph{invisibly} (see \code{\link{invisible}()}) returns \code{TRUE} iff the change was successful. \code{.mpfr_gmp_numbbits()} returns the \file{GMP} library \dQuote{numb} size, which is either 32 or 64 bit (as \code{\link{integer}}, i.e., \code{64L} or \code{32L}). If it is \emph{not} 64, you typically cannot enlarge the exponential range of mpfr numbers via \code{.mpfr_erange()}, see above. \code{.mpfrSizeof()} may be more relevant (than \code{.mpfr_gmp_numbbits()}), returning a named integer vector of \code{\link{length}(.) == 3} with the sizes in bytes of the three \file{MPFR} library types named \code{c("mpfr_prec_t", "mpfr_exp_t", "mp_limb_t")}. \code{.mpfrVersion()} returns a string, the version of the \file{MPFR} library we are linking to. \code{.mpfr_formatinfo(x)} returns conceptually a subset of \code{\link{.mpfr2str}()}'s result, a list with three components \describe{ \item{exp}{the base-2 exponents of \code{x}, identical to \code{.mpfr2exp(x)}.} \item{finite}{\code{\link{logical}} identical to \code{\link{is.finite}(x)}.} \item{is.0}{\code{\link{logical}} indicating if the corresponding \code{x[i]} is zero; identical to \code{\link{mpfrIs0}(x)}.}} (Note that \code{\link{.mpfr2str}(x, .., base)$exp} is wrt \code{base} \emph{and} is not undefined but ...)% FIXME \code{.mpfr_sign(x)} only works for \code{mpfr} objects, then identical to \code{\link{sign}(x)}. Analogously, \code{.mpfr_negative(x)} is \code{-x} in that case. \code{.getSign(x)} is a low-level version of \code{\link{sign}(x)} returning -1 or +1, but not 0. \cr Finally, \code{..bigq2mpfr(x, ..)} and \code{..bigz2mpfr(x, ..)} are fast ways to coerce \code{bigz} and \code{bigq} number objects (created by package \CRANpkg{gmp}'s functionality) to our \code{"mpfr"} class. } \note{ \code{mpfrXport()} and \code{mpfrImport()} are \bold{experimental} and used to explore reported platform incompatibilities of \code{\link{save}()}d and \code{\link{load}()}ed \code{"mpfr"} objects between Windows and non-Windows platforms. In other words, the format of the result of \code{mpfrXport()} and hence the \code{mxp} argument to \code{mpfrImport()} are considered internal, not part of the API and subject to change. } \seealso{ Start using \code{\link{mpfr}(..)}, and compute with these numbers. \code{\link{mpfrArray}(x)} is for numeric (\dQuote{non-mpfr}) \code{x}, whereas \code{mpfr2array(x)} is for \code{"mpfr"} classed \code{x}, only. } \examples{ getPrec(as(c(1,pi), "mpfr")) # 128 for both (opr <- mpfr_default_prec()) ## typically 53, the MPFR system default stopifnot(opr == (oprec <- mpfr_default_prec(70)), 70 == mpfr_default_prec()) ## and reset it: mpfr_default_prec(opr) ## Explore behavior of rounding modes 'rnd.mode': x <- mpfr(10,99)^512 # too large for regular (double prec. / numeric): sapply(c("N", "D", "U", "Z", "A"), function(RM) sapply(list(-x,x), function(.) toNum(., RM))) ## N D U Z A ## -Inf -Inf -1.797693e+308 -1.797693e+308 -Inf ## Inf 1.797693e+308 Inf 1.797693e+308 Inf ## Ranges of (base 2) exponents of MPFR numbers: .mpfr_erange() # the currently active range of possible base 2 exponents: ## A factory fresh setting fulfills .mpfr_erange(c("Emin","Emax")) == c(-1,1) * (2^30 - 1) ## There are more 'kind's, the latter 4 showing how you could change the first two : .mpfr_erange_kinds .mpfr_erange(.mpfr_erange_kinds) eLimits <- .mpfr_erange(c("min.emin", "max.emin", "min.emax", "max.emax")) ## Typically true in MPFR versions *iff* long is 64-bit, i.e. *not* on Windows if(.Machine$sizeof.long == 8L) { eLimits == c(-1,1, -1,1) * (2^62 - 1) } else if(.Machine$sizeof.long == 4L) # on Windows eLimits == c(-1,1, -1,1) * (2^30 - 1) ## Looking at internal representation [for power users only!]: i8 <- mpfr(-2:5, 32) x4 <- mpfr(c(NA, NaN, -Inf, Inf), 32) stopifnot(exprs = { identical(x4[1], x4[2]) is.na(x4[1] == x4[2]) # <- was *wrong* in Rmpfr <= 0.9-4 is.na(x4[1] != x4[2]) # (ditto) identical(x4 < i8[1:4], c(NA,NA, TRUE,FALSE)) !is.finite(x4) identical(is.infinite(x4), c(FALSE,FALSE, TRUE,TRUE)) }) ## The output of the following depends on the GMP "numb" size ## (32 bit vs. 64 bit), *and* additionally ## on sizeof.long (mostly non-Windows <-> Windows, see above): str( .mpfr2list(i8) ) str( .mpfr2list(x4, names = TRUE) ) dput( .mpfrSizeof() ) # on (64-bit) Linux, now typically all '8', ## as 64 bit = 8 bytes -- nowadays probably more relevant than dput( .mpfr_gmp_numbbits() ) # typically 64 str(xp4 <- mpfrXport(x4, names = TRUE)) stopifnot(identical(x4, mpfrImport(mpfrXport(x4))), identical(i8, mpfrImport(mpfrXport(i8)))) B6 <- mpfr2array(Bernoulli(1:6, 60), c(2,3), dimnames = list(LETTERS[1:2], letters[1:3])) ## FIXME, need c(.), as dim(.) & dimnames(.) "get lost" in export/import: stopifnot(identical(c(B6), mpfrImport(mpfrXport(B6)))) } \keyword{utilities} Rmpfr/man/chooseMpfr.Rd0000644000176200001440000001314614026150166014515 0ustar liggesusers\name{chooseMpfr} \alias{chooseMpfr} \alias{chooseMpfr.all} \alias{pochMpfr} \title{Binomial Coefficients and Pochhammer Symbol aka Rising Factorial} \description{ Compute binomial coefficients, \code{chooseMpfr(a,n)} being mathematically the same as \code{\link{choose}(a,n)}, but using high precision (MPFR) arithmetic. \code{chooseMpfr.all(n)} means the vector \code{\link{choose}(n, 1:n)}, using enough bits for exact computation via MPFR. However, \code{chooseMpfr.all()} is now \bold{deprecated} in favor of \code{\link[gmp]{chooseZ}} from package \pkg{gmp}, as that is now vectorized. \code{pochMpfr()} computes the Pochhammer symbol or \dQuote{rising factorial}, also called the \dQuote{Pochhammer function}, \dQuote{Pochhammer polynomial}, \dQuote{ascending factorial}, \dQuote{rising sequential product} or \dQuote{upper factorial}, \deqn{x^{(n)}=x(x+1)(x+2)\cdots(x+n-1)= \frac{(x+n-1)!}{(x-1)!} = \frac{\Gamma(x+n)}{\Gamma(x)}. }{x^(n) = x(x+1)(x+2)...(x+n-1) = (x+n-1)! / (x-1)! = Gamma(x+n) / Gamma(x).} } \usage{ chooseMpfr (a, n, rnd.mode = c("N","D","U","Z","A")) chooseMpfr.all(n, precBits=NULL, k0=1, alternating=FALSE) pochMpfr(a, n, rnd.mode = c("N","D","U","Z","A")) } \arguments{ \item{a}{a numeric or \code{\linkS4class{mpfr}} vector.} \item{n}{an \code{\link{integer}} vector; if not of length one, \code{n} and \code{a} are recycled to the same length.} \item{rnd.mode}{a 1-letter string specifying how \emph{rounding} should happen at C-level conversion to MPFR, see \code{\link{mpfr}}.} \item{precBits}{integer or NULL for increasing the default precision of the result.} \item{k0}{integer scalar} \item{alternating}{logical, for \code{chooseMpfr.all()}, indicating if \emph{alternating sign} coefficients should be returned, see below.} } \note{ Currently this works via a (C level) \code{for(i in 1:n)}-loop which really slow for large \code{n}, say \eqn{10^6}, with computational cost \eqn{O(n^2)}. In such cases, if you need high precision \code{choose(a,n)} (or Pochhammer(a,n)) for large \code{n}, preferably work with the corresponding \code{\link{factorial}(mpfr(..))}, or \code{\link{gamma}(mpfr(..))} terms. } \value{ For \describe{ \item{\code{chooseMpfr()}, \code{pochMpfr()}:}{an \code{\linkS4class{mpfr}} vector of length \code{max(length(a), length(n))};} \item{\code{chooseMpfr.all(n, k0)}:}{a \code{mpfr} vector of length \code{n-k0+1}, of binomial coefficients \eqn{C_{n,m}}{C[n,m]} or, if \code{alternating} is true, \eqn{(-1)^m\cdot C_{n,m}}{(-1)^m * C[n,m]} for \eqn{m \in}{m in} \code{k0:n}.} } } \seealso{ \code{\link{choose}(n,m)} (\pkg{base} \R) computes the binomial coefficient \eqn{C_{n,m}}{C[n,m]} which can also be expressed via Pochhammer symbol as \eqn{C_{n,m} = (n-m+1)^{(m)}/m!}{C[n,m] = (n-m+1)^(m) / m!}. \code{\link[gmp]{chooseZ}} from package \pkg{gmp}; for now, %% as we "deprecate" it, in favor of factorialZ() : \code{\link{factorialMpfr}}. For (alternating) binomial sums, directly use \code{\link{sumBinomMpfr}}, as that is potentially % once we do it in C more efficient. } \examples{ pochMpfr(100, 4) == 100*101*102*103 # TRUE a <- 100:110 pochMpfr(a, 10) # exact (but too high precision) x <- mpfr(a, 70)# should be enough (px <- pochMpfr(x, 10)) # the same as above (needing only 70 bits) stopifnot(pochMpfr(a, 10) == px, px[1] ==prod(mpfr(100:109, 100)))# used to fail (c1 <- chooseMpfr(1000:997, 60)) # -> automatic "correct" precision stopifnot(all.equal(c1, choose(1000:997, 60), tolerance=1e-12)) ## --- Experimenting & Checking n.set <- c(1:10, 20, 50:55, 100:105, 200:203, 300:303, 500:503, 699:702, 999:1001) if(!Rmpfr:::doExtras()) { ## speed up: smaller set n. <- n.set[-(1:10)] n.set <- c(1:10, n.[ c(TRUE, diff(n.) > 1)]) } C1 <- C2 <- numeric(length(n.set)) for(i.n in seq_along(n.set)) { cat(n <- n.set[i.n],":") C1[i.n] <- system.time(c.c <- chooseMpfr.all(n) )[1] C2[i.n] <- system.time(c.2 <- chooseMpfr(n, 1:n))[1] stopifnot(is.whole(c.c), c.c == c.2, if(n > 60) TRUE else all.equal(c.c, choose(n, 1:n), tolerance = 1e-15)) cat(" [Ok]\n") } matplot(n.set, cbind(C1,C2), type="b", log="xy", xlab = "n", ylab = "system.time(.) [s]") legend("topleft", c("chooseMpfr.all(n)", "chooseMpfr(n, 1:n)"), pch=as.character(1:2), col=1:2, lty=1:2, bty="n") ## Currently, chooseMpfr.all() is faster only for large n (>= 300) ## That would change if we used C-code for the *.all() version ## If you want to measure more: measureMore <- TRUE measureMore <- FALSE if(measureMore) { ## takes ~ 2 minutes (on "lynne", Intel i7-7700T, ~2019) n.s <- 2^(5:20) r <- lapply(n.s, function(n) { N <- ceiling(10000/n) cat(sprintf("n=\%9g => N=\%d: ",n,N)) ct <- system.time(C <- replicate(N, chooseMpfr(n, n/2))) cat("[Ok]\n") list(C=C, ct=ct/N) }) print(ct.n <- t(sapply(r, `[[`, "ct"))) hasSfS <- requireNamespace("sfsmisc") plot(ct.n[,"user.self"] ~ n.s, xlab=quote(n), ylab="system.time(.) [s]", main = "CPU Time for chooseMpfr(n, n/2)", log ="xy", type = "b", axes = !hasSfS) if(hasSfS) for(side in 1:2) sfsmisc::eaxis(side) summary(fm <- lm(log(ct.n[,"user.self"]) ~ log(n.s), subset = n.s >= 10^4)) ## --> slope ~= 2 ==> It's O(n^2) nn <- 2^seq(11,21, by=1/16) ; Lcol <- adjustcolor(2, 1/2) bet <- coef(fm) lines(nn, exp(predict(fm, list(n.s = nn))), col=Lcol, lwd=3) text(500000,1, substitute(AA \%*\% n^EE, list(AA = signif(exp(bet[1]),3), EE = signif( bet[2], 3))), col=2) } # measure more }% example \keyword{arith} Rmpfr/man/special-math.Rd0000644000176200001440000000463514231543360014762 0ustar liggesusers\name{mpfr-special-functions} \alias{zeta} \alias{Ei} \alias{Li2} \alias{erf} \alias{erfc} \title{Special Mathematical Functions (MPFR)} \description{ Special Mathematical Functions, supported by the MPFR Library. Note that additionally, all the \code{\link{Math}} and \code{\link{Math2}} group member functions are \dQuote{mpfr-ified}, too; ditto, for many more standard \R functions. See see the methods listed in \code{\linkS4class{mpfr}} (aka \code{?`\link{mpfr-class}`}). % ./mpfr-class.Rd } \usage{ zeta(x) Ei(x) Li2(x) erf(x) erfc(x) } \arguments{ \item{x}{a \code{\link{numeric}} or \code{\linkS4class{mpfr}} vector.} } \details{ \code{zeta(x)} computes Riemann's Zeta function \eqn{\zeta(x)}{zeta(x)} important in analytical number theory and related fields. The traditional definition is \deqn{\zeta(x) = \sum_{n=1}^\infty \frac{1}{n^x}.}{Zeta(x) = sum[n=1..Inf; 1/(n^x)].} \code{Ei(x)} computes the \bold{e}xponential integral, \deqn{\int_{-\infty}^{x} \frac{e^t}{t} \; dt.}{Integral(-Inf,x; e^t/t dt).} \code{Li2(x)} computes the dilogarithm, \deqn{\int_{0}^{x} \frac{-log(1-t)}{t} \; dt.}{Integral(0,x; -log(1-t)/t dt).} \code{erf(x)} and \code{erfc(x)} are the error, respectively \bold{c}omplementary error function which are both reparametrizations of \code{\link{pnorm}}, \code{erf(x) = 2*pnorm(sqrt(2)*x)} and \code{erfc(x) = 2* pnorm(sqrt(2)*x, lower=FALSE)}, and hence \pkg{Rmpfr} provides its own version of \code{\link{pnorm}}. } \value{ A vector of the same length as \code{x}, of class \code{\linkS4class{mpfr}}. } \seealso{\code{\link[stats:Normal]{pnorm}} in standard package \pkg{stats}; the class description \code{\linkS4class{mpfr}} mentioning the generic arithmetic and mathematical functions (\code{sin}, \code{log}, \dots, etc) for which \code{"mpfr"} methods are available. Note the (integer order, non modified) Bessel functions \eqn{j_0()}, \eqn{y_n()}, etc, named \code{\link{j0}, \link{yn}} etc, and Airy function \eqn{Ai()} in \link{Bessel_mpfr}. } \examples{ curve(Ei, 0, 5, n=2001) ## As we now require (mpfrVersion() >= "2.4.0"): curve(Li2, 0, 5, n=2001) curve(Li2, -2, 13, n=2000); abline(h=0,v=0, lty=3) curve(Li2, -200,400, n=2000); abline(h=0,v=0, lty=3) curve(erf, -3,3, col = "red", ylim = c(-1,2)) curve(erfc, add = TRUE, col = "blue") abline(h=0, v=0, lty=3) legend(-3,1, c("erf(x)", "erfc(x)"), col = c("red","blue"), lty=1) } \keyword{math} Rmpfr/man/sapplyMpfr.Rd0000644000176200001440000000765014360044651014552 0ustar liggesusers\name{sapplyMpfr} \alias{sapplyMpfr} \title{Apply a Function over a "mpfr" Vector} \description{ Users may be disappointed to note that \code{\link{sapply}()} or \code{\link{vapply}()} typically do not work with \code{"mpfr"} numbers. This is a simple (but strong) approach to work around the problem, based on \code{\link{lapply}()}. } \usage{ sapplyMpfr(X, FUN, \dots, drop_1_ = TRUE) } \arguments{ \item{X}{a vector, possibly of class \code{"\linkS4class{mpfr}"}.} \item{FUN}{a \code{\link{function}} returning an \code{"\linkS4class{mpfr}"} vector or even an \code{"\linkS4class{mpfrArray}"}. May also be a function returning a \code{\link{numeric}} vector or array for numeric \code{X}, \emph{and} which returns \code{"mpfr(Array)"} for an \code{X} argument inheriting from \code{"\linkS4class{mpfr}"}.} \item{\dots}{further arguments passed to \code{\link{lapply}}, typically further arguments to \code{FUN}.} \item{drop_1_}{logical (with unusual name on purpose!) indicating if 1-column matrices (\code{"mpfrMatrix"}) should be \dQuote{dropped} to vectors (\code{"mpfr"}), the same as in base \R's own \code{\link{sapply}}. This has been implicitly \code{FALSE} in \pkg{Rmpfr} versions 0.8-5 to 0.8-9 (Oct 2021 to June 2022), accidentally. Since \pkg{Rmpfr} 0.9-0, this has been made an argument with default \code{TRUE} to be compatible by default with \R's \code{\link{sapply}}. } } \details{ In the case \code{FUN()} returns an \code{\link{array}} or \code{"mpfrArray"}, i.e., with two or more dimensions, \code{sapplyMpfr()} returns an \code{"mpfrArray"}; this is analogous to \code{\link{sapply}(X, FUN, simplify = "array")} (rather than the default \code{sapply()} behaviour which returns a \code{matrix} also when a higher array would be more \dQuote{logical}.) } \value{ an \code{"\linkS4class{mpfr}"} vector, typically of the same length as \code{X}. } \author{Martin Maechler} \note{ This may still not always work as well as \code{\link{sapply}()} does for atomic vectors. The examples seem to indicate that it typically does work as desired, since \pkg{Rmpfr} version 0.9-0. If you want to transform back to regular numbers anyway, it maybe simpler and more efficient to use \preformatted{ res <- lapply(....) sapply(res, asNumeric, simplify = "array") } instead of \code{sapplyMpfr()}. } \seealso{ \code{\link{sapply}}, \code{\link{lapply}}, etc. } \examples{ sapplyMpfr0 <- ## Originally, the function was simply defined as function (X, FUN, ...) new("mpfr", unlist(lapply(X, FUN, ...), recursive = FALSE)) (m1 <- sapply ( 3, function(k) (1:3)^k)) # 3 x 1 matrix (numeric) (p1 <- sapplyMpfr(mpfr(3, 64), function(k) (1:3)^k)) stopifnot(m1 == p1, is(p1, "mpfrMatrix"), dim(p1) == c(3,1), dim(p1) == dim(m1)) k.s <- c(2, 5, 10, 20) (mk <- sapply ( k.s, function(k) (1:3)^k)) # 3 x 4 " " (pm <- sapplyMpfr(mpfr(k.s, 64), function(k) (1:3)^k)) stopifnot(mk == pm, is(pm, "mpfrMatrix"), dim(pm) == 3:4, 3:4 == dim(mk)) ## was *wrongly* 4x3 in Rmpfr 0.8-x f5k <- function(k) outer(1:5, k+0:2, `^`)# matrix-valued (mk5 <- sapply ( k.s, f5k)) # sapply()'s default; not "ideal" (ak5 <- sapply ( k.s, f5k, simplify = "array")) # what we want (pm5 <- sapplyMpfr(mpfr(k.s, 64), f5k)) stopifnot(c(mk5) == c(ak5), ak5 == pm5, is(pm5, "mpfrArray"), is.array(ak5), dim(pm5) == dim(ak5), dim(pm5) == c(5,3, 4)) if(require("Bessel")) { # here X, is simple bI1 <- function(k) besselI.nuAsym(mpfr(1.31e9, 128), 10, expon.scaled=TRUE, k.max=k) bImp1 <- sapplyMpfr (0:4, bI1, drop_1_ = FALSE) # 1x5 mpfrMatrix -- as in DPQ 0.8-8 bImp <- sapplyMpfr (0:4, bI1, drop_1_ = TRUE ) # 5 "mpfr" vector {by default} bImp0 <- sapplyMpfr0(0:4, bI1) # 5-vector stopifnot(identical(bImp, bImp0), bImp == bImp1, is(bImp, "mpfr"), is(bImp1, "mpfrMatrix"), dim(bImp1) == c(1, 5)) }# {Bessel} } \keyword{manip} Rmpfr/man/base-copies.Rd0000644000176200001440000000070113325623111014567 0ustar liggesusers\name{Rmpfr-workarounds} \alias{outer} \title{Base Functions etc, as an Rmpfr version} \description{ Functions from \pkg{base} etc which need a \emph{copy} in the \pkg{Rmpfr} namespace so they correctly dispatch. } \usage{ outer(X, Y, FUN = "*", ...) } \arguments{ \item{X, Y, FUN, ...}{See \pkg{base} package help: \code{\link[base]{outer}}.} } \seealso{ \code{\link[base]{outer}}. } \examples{ outer(1/mpfr(1:10, 70), 0:2) } \keyword{misc} Rmpfr/man/atomicVector-class.Rd0000644000176200001440000000241511247771434016160 0ustar liggesusers%% almost straight copy of ../../Matrix/man/atomicVector-class.Rd \name{atomicVector-class} \docType{class} \alias{atomicVector-class} \title{Virtual Class "atomicVector" of Atomic Vectors} \description{ The \code{\link{class}} \code{"atomicVector"} is a \emph{virtual} class containing all atomic vector classes of base \R, as also implicitly defined via \code{\link{is.atomic}}. } \section{Objects from the Class}{A virtual Class: No objects may be created from it.} \section{Methods}{ In the \pkg{Matrix} package, the "atomicVector" is used in signatures where typically \dQuote{old-style} "matrix" objects can be used and can be substituted by simple vectors. } \section{Extends}{%% FIXME: promptClass() should show the direct subclasses ! The atomic classes \code{"logical"}, \code{"integer"}, \code{"double"}, \code{"numeric"}, \code{"complex"}, \code{"raw"} and \code{"character"} are extended directly. Note that \code{"numeric"} already contains \code{"integer"} and \code{"double"}, but we want all of them to be direct subclasses of \code{"atomicVector"}. } \author{Martin Maechler} \seealso{ \code{\link{is.atomic}}, \code{\link{integer}}, \code{\link{numeric}}, \code{\link{complex}}, etc. } \examples{ showClass("atomicVector") } \keyword{classes} Rmpfr/man/mpfr.Rd0000644000176200001440000001413015057547524013363 0ustar liggesusers\name{mpfr} \title{Create "mpfr" Numbers (Objects)} \alias{mpfr} \alias{is.mpfr} \alias{mpfr.default} \alias{mpfr.mpfr}% and more \alias{Const} \description{ Create multiple (i.e. typically \emph{high}) precision numbers, to be used in arithmetic and mathematical computations with \R. } \usage{ mpfr(x, precBits, \dots) \S3method{mpfr}{default}(x, precBits, base = 10, rnd.mode = c("N","D","U","Z","A"), scientific = NA, \dots) Const(name = c("pi", "gamma", "catalan", "log2"), prec = 120L, rnd.mode = c("N","D","U","Z","A")) is.mpfr(x) } \arguments{ \item{x}{a \code{\link{numeric}}, \code{\linkS4class{mpfr}}, \code{\link[gmp]{bigz}}, \code{\link[gmp]{bigq}}, or \code{\link{character}} vector or \code{\link{array}}.} \item{precBits, prec}{a number, the maximal precision to be used, in \bold{\emph{bits}}; i.e. \code{53} corresponds to double precision. Must be at least 2. If \code{\link{missing}}, \code{\link{getPrec}(x)} determines a default precision. In the \pkg{Rmpfr} package, the \code{\linkS4class{mpfr}} class is defined to have type \code{\link{integer}} slot \code{prec}, and hence, currently, \code{precBits} and \code{prec} may not be larger than \code{\link{.Machine}$ integer.max}, which is \eqn{2^31 - 1 = 2147483647} on all platforms.} \item{base}{(only when \code{x} is \code{\link{character}}) the base with respect to which \code{x[i]} represent numbers; \code{base} \eqn{b} must fulfill \eqn{2 \le b \le 62}{2 <= b <= 62}.} \item{rnd.mode}{a 1-letter string specifying how \emph{rounding} should happen at C-level conversion to MPFR, see details.} \item{scientific}{(used only when \code{x} is the result of \code{\link{formatBin}()}, i.e., of class \code{"Bcharacter"}:) logical indicating that the binary representation of \code{x} is in scientific notation. When \code{TRUE}, \code{mpfr()} will substitute \code{0} for \code{_}; when \code{NA}, \code{mpfr()} will guess, and use \code{TRUE} when finding a \code{"p"} in \code{x}; see also \code{\link{formatBin}}.} \item{name}{a string specifying the mpfrlib - internal constant computation. \code{"gamma"} is Euler's gamma (\eqn{\gamma}), and \code{"catalan"} Catalan's constant.} \item{\dots}{potentially further arguments passed to and from methods.} } \value{ an object of (S4) class \code{\linkS4class{mpfr}}, or for \code{mpfr(x)} when \code{x} is an array, \code{\linkS4class{mpfrMatrix}}, or \code{\linkS4class{mpfrArray}} which the user should just as a normal numeric vector or array. \code{is.mpfr()} returns \code{TRUE} or \code{FALSE}. } \details{ The \code{"\linkS4class{mpfr}"} method of \code{mpfr()} is a simple wrapper around \code{\link{roundMpfr}()}. MPFR supports the following rounding modes, %% the following is +- cut & paste from the MPFR manual \describe{ \item{GMP_RND\bold{N}:}{round to \bold{n}earest (roundTiesToEven in IEEE 754-2008).} \item{GMP_RND\bold{Z}:}{round toward \bold{z}ero (roundTowardZero in IEEE 754-2008).} \item{GMP_RND\bold{U}:}{round toward plus infinity (\dQuote{Up}, roundTowardPositive in IEEE 754-2008).} \item{GMP_RND\bold{D}:}{round toward minus infinity (\dQuote{Down}, roundTowardNegative in IEEE 754-2008).} \item{GMP_RND\bold{A}:}{round \bold{a}way from zero (new since MPFR 3.0.0).} } The \sQuote{round to nearest} (\code{"N"}) mode, the default here, works as in the IEEE 754 standard: in case the number to be rounded lies exactly in the middle of two representable numbers, it is rounded to the one with the least significant bit set to zero. For example, the number 5/2, which is represented by (10.1) in binary, is rounded to (10.0)=2 with a precision of two bits, and not to (11.0)=3. This rule avoids the "drift" phenomenon mentioned by Knuth in volume 2 of The Art of Computer Programming (Section 4.2.2). When \code{x} is \code{\link{character}}, \code{mpfr()} will detect the precision of the input object. %% FIXME examples } \references{ The MPFR team. (202x). \emph{GNU MPFR -- The Multiple Precision Floating-Point Reliable Library}; see \url{https://www.mpfr.org/mpfr-current/#doc} or directly \url{https://www.mpfr.org/mpfr-current/mpfr.pdf}. } \author{Martin Maechler} \seealso{The class documentation \code{\linkS4class{mpfr}} contains more details. Use \code{\link[gmp]{asNumeric}()} from \CRANpkg{gmp} to transform back to double precision ("\code{\link{numeric}}"). } \examples{ mpfr(pi, 120) ## the double-precision pi "translated" to 120-bit precision pi. <- Const("pi", prec = 260) # pi "computed" to correct 260-bit precision pi. # nicely prints 80 digits [260 * log10(2) ~= 78.3 ~ 80] Const("gamma", 128L) # 0.5772... Const("catalan", 128L) # 0.9159... x <- mpfr(0:7, 100)/7 # a more precise version of k/7, k=0,..,7 x 1 / x ## character input : mpfr("2.718281828459045235360287471352662497757") - exp(mpfr(1, 150)) ## ~= -4 * 10^-40 ## Also works for NA, NaN, ... : cx <- c("1234567890123456", 345, "NA", "NaN", "Inf", "-Inf") mpfr(cx) ## with some 'base' choices : print(mpfr("111.1111", base=2)) * 2^4 mpfr("af21.01020300a0b0c", base=16) ## 68 bit prec. 44833.00393694653820642 mpfr("ugi0", base = 32) == 10^6 ## TRUE ## --- Large integers from package 'gmp': Z <- as.bigz(7)^(1:200) head(Z, 40) ## mfpr(Z) by default chooses the correct *maximal* default precision: mZ. <- mpfr(Z) ## more efficiently chooses precision individually m.Z <- mpfr(Z, precBits = frexpZ(Z)$exp) ## the precBits chosen are large enough to keep full precision: stopifnot(identical(cZ <- as.character(Z), as(mZ.,"character")), identical(cZ, as(m.Z,"character"))) ## compare mpfr-arithmetic with exact rational one: stopifnot(all.equal(mpfr(as.bigq(355,113), 99), mpfr(355, 99) / 113, tol = 2^-98)) ## look at different "rounding modes": sapply(c("N", "D","U","Z","A"), function(RND) mpfr(c(-1,1)/5, 20, rnd.mode = RND), simplify=FALSE) symnum(sapply(c("N", "D","U","Z","A"), function(RND) mpfr(0.2, prec = 5:15, rnd.mode = RND) < 0.2 )) } \keyword{classes} Rmpfr/man/integrateR.Rd0000644000176200001440000001232712402301607014506 0ustar liggesusers\name{integrateR} \title{One-Dimensional Numerical Integration - in pure R} \alias{integrateR} \alias{print.integrateR} \alias{show,integrateR-method} \description{ Numerical integration of one-dimensional functions in pure \R, with care so it also works for \code{"mpfr"}-numbers. Currently, only classical Romberg integration of order \code{ord} is available. } \usage{ integrateR(f, lower, upper, \dots, ord = NULL, rel.tol = .Machine$double.eps^0.25, abs.tol = rel.tol, max.ord = 19, verbose = FALSE) } \arguments{ \item{f}{an \R function taking a numeric or \code{"mpfr"} first argument and returning a numeric (or \code{"mpfr"}) vector of the same length. Returning a non-finite element will generate an error. } \item{lower, upper}{the limits of integration. Currently \emph{must} be finite. Do use \code{"mpfr"}-numbers to get higher than double precision, see the examples.} \item{\dots}{additional arguments to be passed to \code{f}.} \item{ord}{integer, the order of Romberg integration to be used. If this is \code{NULL}, as per default, and either \code{rel.tol} or \code{abs.tol} are specified, the order is increased until convergence.} \item{rel.tol}{relative accuracy requested. The default is 1.2e-4, about 4 digits only, see the Note.} \item{abs.tol}{absolute accuracy requested.} \item{max.ord}{only used, when neither \code{ord} or one of \code{rel.tol}, \code{abs.tol} are specified: Stop Romberg iterations after the order reaches \code{max.ord}; may prevent infinite loops or memory explosion.} \item{verbose}{logical or integer, indicating if and how much information should be printed during computation.} } \details{ Note that arguments after \code{\dots} must be matched exactly. For convergence, \emph{both} relative and absolute changes must be smaller than \code{rel.tol} and \code{abs.tol}, respectively. \code{rel.tol} cannot be less than \code{max(50*.Machine$double.eps, 0.5e-28)} if \code{abs.tol <= 0}. } \note{ \code{f} must accept a vector of inputs and produce a vector of function evaluations at those points. The \code{\link{Vectorize}} function may be helpful to convert \code{f} to this form. If you want to use higher accuracy, you \emph{must} set \code{lower} or \code{upper} to \code{"\link{mpfr}"} numbers (and typically lower the relative tolerance, \code{rel.tol}), see also the examples. Note that the default tolerances (\code{rel.tol}, \code{abs.tol}) are not very accurate, but the same as for \code{\link{integrate}}, which however often returns considerably more accurate results than requested. This is typically \emph{not} the case for \code{integrateR()}. } \value{ A list of class \code{"integrateR"} (as from standard \R's \code{\link{integrate}()}) with a \code{\link{print}} method and components \item{value}{the final estimate of the integral.} \item{abs.error}{estimate of the modulus of the absolute error.} \item{subdivisions}{for Romberg, the number of function evaluations.} \item{message}{\code{"OK"} or a character string giving the error message.} \item{call}{the matched call.} } \references{ Bauer, F.L. (1961) Algorithm 60 -- Romberg Integration, \emph{Communications of the ACM} \bold{4}(6), p.255. } \author{Martin Maechler} \seealso{ \R's standard, \code{\link{integrate}}, is much more adaptive, also allowing infinite integration boundaries, and typically considerably faster for a given accuracy. } \note{ We use practically the same \code{print} S3 method as \code{\link{print.integrate}}, provided by \R,% 'stats' package with a difference when the \code{message} component is not \code{"Ok"}. } \examples{ ## See more from ?integrate ## this is in the region where integrate() can get problems: integrateR(dnorm,0,2000) integrateR(dnorm,0,2000, rel.tol=1e-15) (Id <- integrateR(dnorm,0,2000, rel.tol=1e-15, verbose=TRUE)) Id$value == 0.5 # exactly ## Demonstrating that 'subdivisions' is correct: Exp <- function(x) { .N <<- .N+ length(x); exp(x) } .N <- 0; str(integrateR(Exp, 0,1, rel.tol=1e-10), digits=15); .N ### Using high-precision functions ----- ## Polynomials are very nice: integrateR(function(x) (x-2)^4 - 3*(x-3)^2, 0, 5, verbose=TRUE) # n= 1, 2^n= 2 | I = 46.04, abs.err = 98.9583 # n= 2, 2^n= 4 | I = 20, abs.err = 26.0417 # n= 3, 2^n= 8 | I = 20, abs.err = 7.10543e-15 ## 20 with absolute error < 7.1e-15 ## Now, using higher accuracy: I <- integrateR(function(x) (x-2)^4 - 3*(x-3)^2, 0, mpfr(5,128), rel.tol = 1e-20, verbose=TRUE) I ; I$value ## all fine ## with floats: integrateR(exp, 0 , 1, rel.tol=1e-15, verbose=TRUE) ## with "mpfr": (I <- integrateR(exp, mpfr(0,200), 1, rel.tol=1e-25, verbose=TRUE)) (I.true <- exp(mpfr(1, 200)) - 1) ## true absolute error: stopifnot(print(as.numeric(I.true - I$value)) < 4e-25) ## Want absolute tolerance check only (=> set 'rel.tol' very high, e.g. 1): (Ia <- integrateR(exp, mpfr(0,200), 1, abs.tol = 1e-6, rel.tol=1, verbose=TRUE)) ## Set 'ord' (but no '*.tol') --> Using 'ord'; no convergence checking (I <- integrateR(exp, mpfr(0,200), 1, ord = 13, verbose=TRUE)) } \keyword{math} \keyword{utilities} Rmpfr/man/distr-etc.Rd0000644000176200001440000002012015036244353014300 0ustar liggesusers\name{mpfr-distr-etc} \title{Distribution Functions with MPFR Arithmetic} \alias{dnorm} \alias{dbinom} \alias{dnbinom} \alias{dchisq} \alias{dgamma} \alias{dpois} \alias{dt} \alias{pgamma} \alias{pnorm} \alias{mpfr-distr}% <- alternative for \link \usage{% >>>> ../R/special-fun.R <<<< dpois (x, lambda, log = FALSE, useLog = ) dbinom (x, size, prob, log = FALSE, useLog = , warnLog = TRUE) dnbinom(x, size, prob, mu, log = FALSE, useLog = any(x > 1e6)) dchisq(x, df, log = FALSE) dnorm (x, mean = 0, sd = 1, log = FALSE) dgamma(x, shape, rate = 1, scale = 1/rate, log = FALSE) dt (x, df, ncp, log = FALSE) pgamma(q, shape, rate = 1, scale = 1/rate, lower.tail = TRUE, log.p = FALSE, rnd.mode = c('N','D','U','Z','A')) pnorm(q, mean = 0, sd = 1, lower.tail = TRUE, log.p = FALSE) } \description{ For some \R standard (probability) density, distribution or quantile functions, we provide MPFR versions. } \arguments{ \item{x,q, lambda, size,prob, mu, mean,sd, shape,rate,scale, df,ncp}{% \code{\link{numeric}} or \code{\linkS4class{mpfr}} vectors. % for the function call. All of these are \dQuote{recycled} to the length of the longest one. For their meaning/definition, see the corresponding standard \R (\pkg{stats} package) function.} \item{log, log.p, lower.tail}{logical, see \code{\link[stats:Normal]{pnorm}}, \code{\link[stats:Poisson]{dpois}}, etc.} \item{useLog}{\code{\link{logical}} with default depending on \code{x} etc, indicating if log-scale computation should be used even when \code{log = FALSE}, for performance or against overflow / underflow.} \item{warnLog}{\code{\link{logical}} indicating if the \dQuote{mismatch} \code{log = TRUE, useLog = FALSE} should be warned about.}% somewhat experimental \item{rnd.mode}{a 1-letter string specifying how \emph{rounding} should happen at C-level conversion to MPFR, see details of \code{\link{mpfr}}.} } \details{ \code{pnorm()} is based on \code{\link{erf}()} and \code{erfc()} which have direct MPFR counter parts and are both reparametrizations of \code{pnorm}, \code{erf(x) = 2*pnorm(sqrt(2)*x)} and \code{erfc(x) = 2* pnorm(sqrt(2)*x, lower=FALSE)}. \code{pgamma(q, sh)} is based on our \code{\link{igamma}(sh, q)}, see the \sQuote{Warning} there! } \note{E.g., for \code{pnorm(*, log.p = TRUE)} to be useful, i.e., not to underflow or overflow, you may want to extend the exponential range of MPFR numbers, using \code{\link{.mpfr_erange_set}()}, see the examples. } \value{ A vector of the same length as the longest of \code{x,q, ...}, of class \code{\linkS4class{mpfr}} with the high accuracy results of the corresponding standard \R function. } \seealso{\code{\link[stats:Normal]{pnorm}}, \code{\link[stats]{dt}}, \code{\link[stats]{dbinom}}, \code{\link[stats]{dnbinom}}, \code{\link[stats]{dgamma}}, \code{\link[stats]{dpois}} in standard package \pkg{stats}. \code{\link{pbetaI}(x, a,b)} is a \code{\link{mpfr}} version of \code{\link{pbeta}} only for \emph{integer} \code{a} and \code{b}. } \examples{ x <- 1400+ 0:10 print(dpois(x, 1000), digits =18) ## standard R's double precision (px <- dpois(mpfr(x, 120), 1000))## more accuracy for the same px. <- dpois(mpfr(x, 120), 1000, useLog=TRUE)# {failed in 0.8-8} stopifnot(all.equal(px, px., tol = 1e-31)) dpois(0:5, mpfr(10000, 80)) ## very small exponents (underflowing in dbl.prec.) print(dbinom(0:8, 8, pr = 4 / 5), digits=18) dbinom(0:8, 8, pr = 4/mpfr(5, 99)) -> dB; dB print(dnorm( -5:5), digits=18) dnorm(mpfr(-5:5, prec=99)) ## For pnorm() in the extreme tails, need an exponent range ## larger than the (MPFR and Rmpfr) default: (old_eranges <- .mpfr_erange()) # typically -/+ 2^30: log2(abs(old_eranges)) # 30 30 .mpfr_erange_set(value = (1-2^-52)*.mpfr_erange(c("min.emin","max.emax"))) log2(abs(.mpfr_erange()))# 62 62 *if* setup -- 2023-01: *not* on Winbuilder, nor ## other Windows where long is 4 bytes (32 bit) and the erange typically cannot be extended. tens <- mpfr(10^(4:7), 128) pnorm(tens, lower.tail=FALSE, log.p=TRUE) # "works" (iff ...) ## "the" boundary: pnorm(mpfr(- 38581.371, 128), log.p=TRUE) # still does not underflow {but *.372 does} ## -744261105.599283824811986753129188937418 (iff ...) .mpfr_erange()*log(2) # the boundary ## Emin Emax ## -3.196577e+18 3.196577e+18 (iff ...) ## reset to previous .mpfr_erange_set( , old_eranges) pnorm(tens, lower.tail=FALSE, log.p=TRUE) # all but first underflow to -Inf ## dnbinom(x, size, ..) for large (x, size): .. already after fixing R-devel dnbinom() xx <- 6e307 sz <- 1e308 dnb <- curve(dnbinom(xx, sz, prob = x, log=TRUE), 0, 1, n = 1024 + 1, xlab = quote(prob), main = sprintf("dnbinom(\%s, \%s, prob=prob, log=TRUE)", xx, sz), col = 2, lwd=2) x <- dnb$x dnbM <- dnbinom(mpfr(xx, 128), mpfr(sz, 128), prob = x, log=TRUE) lines(x, asNumeric(dnbM), col = adjustcolor(4, 1/3), lwd=5) ## dnbinom(x, size, ..) for large (x, size): .. for(x.n in list(c(7e305, 1e306), c(7e306, 1e307), c(7e307, 1e308))) { xx <- x.n[[1]] ; sz <- x.n[[2]] # ============ here, we saw big jumps dnb <- curve(dnbinom(xx, sz, prob = x, log=TRUE), 0, 1, n = 1024 + 1, col = 2, lwd = 2, xlab = quote(prob), main = sprintf("dnbinom(\%s, \%s, prob=prob, log=TRUE)", xx, sz)) x <- dnb$x; mtext(sfsmisc::shortRversion(), adj=1, cex = 3/4) dnbM <- dnbinom(mpfr(xx, 128), mpfr(sz, 128), prob = x, log=TRUE) lines(x, asNumeric(dnbM), col = adjustcolor(4, 1/3), lwd=5) if(dev.interactive()) Sys.sleep(1.5) } ## pgamma() {and when igamma() is available}: x <- c(10^(-20:-1), .5, 1:20, 10^(2:20)) xM <- mpfr(x, precBits = 128) ## CAREFUL --- some of these take *infinite* time ... ## subset , as "... infinite time ..." iOk <- 1e-3 <= abs(x) & abs(x) <= 100 ## x = 1e-3 is where our pgamma() {from igamma()} becomes very inaccurate xm <- xM <- xM[iOk]; x <- x[iOk] ## sh.v <- c(1e-100, 1e-20, 1e-10, .5, 1,2,5, 10^c(1:10, 100, 300)) ## sh.v <- c(1e-100, 1e-11, 1e-4, .5, 1,2,5, 10^c(1:5, 10, 100)) # less extreme .. sh.v <- c(1e-100, 1e-11, 1e-4, .5, 1,2,5, 10^c(1:5,7)) # much less extreme than above .. FT <- c("F", "T") # for printing for(scale in c(1/2, 2)) for(sh in sh.v) { cat(sprintf("scale = \%4.3g, shape= \%9g: ", scale, sh)) stim <- system.time( for(ltail in c(FALSE, TRUE)) for(lg in c(FALSE,TRUE)) { ae <- all.equal(pgamma(xM, sh, scale=scale, lower.tail=ltail, log.p=lg), pgamma(x , sh, scale=scale, lower.tail=ltail, log.p=lg)) if(!isTRUE(ae)) cat(sprintf(" ltail=\%s, lg=\%s: NOT eq.: \%s", FT[1+ltail], FT[1+lg], ae)) } ) cat(" user.time: ", stim[["user.self"]], "\n") } # for (sh ..) ## scale = 0.5, shape= 1e-100: user.time: 0.292 ## scale = 0.5, shape= 1e-11: user.time: 0.081 ## scale = 0.5, shape= 0.0001: user.time: 0.051 ## scale = 0.5, shape= 0.5: user.time: 0.05 ## scale = 0.5, shape= 1: user.time: 0.031 ## scale = 0.5, shape= 2: user.time: 0.032 ## scale = 0.5, shape= 5: user.time: 0.031 ## scale = 0.5, shape= 10: user.time: 0.032 ## scale = 0.5, shape= 100: ltail=T, lg=T: NOT eq.: Mean abs diff: Inf user.time: 0.029 ## scale = 0.5, shape= 1000: ltail=T, lg=T: NOT eq.: Mean abs diff: Inf user.time: 0.02 ## scale = 0.5, shape= 10000: ltail=T, lg=T: NOT eq.: Mean abs diff: Inf user.time: 0.019 ## scale = 0.5, shape= 100000: ltail=T, lg=T: NOT eq.: Mean abs diff: Inf user.time: 0.022 ## scale = 0.5, shape= 1e+10: ltail=F, lg=F: NOT eq.: Numeric: lengths (0, 24) differ ## ltail=F, lg=T: NOT eq.: Mean absolute difference: Inf ## ltail=T, lg=F: NOT eq.: 'is.NA' ...: 0 in current 24 in target ## ltail=T, lg=T: NOT eq.: 'is.NA' ...: 0 in current 24 in target ## user.time: 0.021 ## scale = 0.5, shape= 1e+100: gamma_inc.c:290: MPFR assertion failed: ## !(__builtin_expect(!!((flags) & (2)), 0)) ## On Windows (erange etc): alread shape = 1e10 leads to the above MPFR assertion fail !! } \keyword{distribution} Rmpfr/man/qnormI.Rd0000644000176200001440000001526715057534534013675 0ustar liggesusers\name{qnormI} \alias{qnormI} \title{Gaussian / Normal Quantiles \code{qnorm()} via Inversion} \description{ Compute Gaussian or Normal Quantiles \code{\link{qnorm}(p, *)} via inversion of our \dQuote{mpfr-ified} arbitrary accurate \code{\link[Rmpfr]{pnorm}()}, using our \code{\link{unirootR}()} root finder. } \usage{%--> ../R/unirootR.R qnormI(p, mean = 0, sd = 1, lower.tail = TRUE, log.p = FALSE, trace = 0, verbose = as.logical(trace), tol, useMpfr = any(prec > 53), give.full = FALSE, \dots) } \arguments{% ~/R/D/r-devel/R/src/library/stats/man/Normal.Rd <<<<< \item{p}{vector of probabilities.} \item{mean}{vector of means.} \item{sd}{vector of standard deviations.} \item{log.p}{logical; if TRUE, probabilities p are given as log(p).} \item{lower.tail}{logical; if TRUE (default), probabilities are \eqn{P[X \le x]} otherwise, \eqn{P[X > x]}.} %%-- \item{trace}{integer passed to \code{\link{unirootR}()}. If positive, information about a search interval extension will be printed to the console.} \item{verbose}{logical indicating if progress details should be printed to the console.} \item{tol}{optionally the desired accuracy (convergence tolerance); if missing or not finite, it is computed as \eqn{2^-{pr+2}} where the precision \eqn{pr} is basically \code{max(\link{getPrec}(p+mean+sd))}.} \item{useMpfr}{logical indicating if \code{\link{mpfr}} arithmetic should be used.}% Its default is derived from \code{tol} when that is specified.} \item{give.full}{logical indicating if the \emph{full} result of \code{\link{unirootR}()} should be returned (when applicable).} \item{\dots}{optional further arguments passed to \code{\link{unirootR}()} such as \code{maxiter}, \code{verbDigits}, \code{check.conv}, \code{warn.no.convergence}, and \code{epsC}.} } \value{ If \code{give.full} is true, return a \code{\link{list}}, say \code{r}, of \code{\link{unirootR}(.)} results, with \code{length(r) == length(p)}. Otherwise, return a \dQuote{numeric vector} like \code{p}, e.g., of \code{class "mpfr"} when \code{p} is. } \author{Martin Maechler} \seealso{ Standard \R's \code{\link[stats]{qnorm}}. } \examples{ doX <- Rmpfr:::doExtras() # slow parts only if(doX) %-- NB: 1.1-1 submission gave Win? Result: NOTE % % Examples with CPU ...... time > 5s : user system elapsed % % qnormI 6.757 0.004 6.767 % cat("doExtras: ", doX, "\n") p <- (0:32)/32 lp <- -c(1000, 500, 200, 100, 50, 20:1, 2^-(1:8)) if(doX) { tol1 <- 2.3e-16 tolM <- 1e-20 tolRIlog <- 4e-14 } else { # use one more than a third of the points: ip <- c(TRUE,FALSE, rep_len(c(TRUE,FALSE,FALSE), length(p)-2L)) p <- p[ip] lp <- lp[ip] tol1 <- 1e-9 tolM <- 1e-12 tolRIlog <- 25*tolM } f.all.eq <- function(a,b) sub("^Mean relative difference:", '', format(all.equal(a, b, tol=0))) for(logp in c(FALSE,TRUE)) { pp <- if(logp) lp else p mp <- mpfr(pp, precBits = if(doX) 80 else 64) # precBits = 128 gave "the same" as 80 for(l.tail in c(FALSE,TRUE)) { qn <- qnorm (pp, lower.tail = l.tail, log.p = logp) qnI <- qnormI(pp, lower.tail = l.tail, log.p = logp, tol = tol1) qnM <- qnormI(mp, lower.tail = l.tail, log.p = logp, tol = tolM) cat(sprintf("Accuracy of qnorm(*, lower.t=\%-5s, log.p=\%-5s): \%s || qnI: \%s\n", l.tail, logp, f.all.eq(qnM, qn ), f.all.eq(qnM, qnI))) stopifnot(exprs = { all.equal(qn, qnI, tol = if(logp) tolRIlog else 4*tol1) all.equal(qnM, qnI, tol = tol1) }) } } ## useMpfr, using mpfr() : if(doX) { p2 <- 2^-c(1:27, 5*(6:20), 20*(6:15)) e2 <- 88 } else { p2 <- 2^-c(1:2, 7, 77, 177, 307) e2 <- 60 } system.time( pn2 <- pnorm(qnormI(mpfr(p2, e2))) ) # 4.1 or 0.68 all.equal(p2, pn2, tol = 0) # 5.48e-29 // 5.2e-18 2^-e2 stopifnot(all.equal(p2, pn2, tol = 6 * 2^-e2)) # '4 *' needed ## Boundary -- from limits in mpfr maximal exponent range! ## 1) Use maximal ranges: (old_eranges <- .mpfr_erange()) # typically -/+ 2^30 (myERng <- (1-2^-52) * .mpfr_erange(c("min.emin","max.emax"))) (doIncr <- !isTRUE(all.equal(unname(myERng), unname(old_eranges)))) # ==> ## TRUE only if long is 64-bit, i.e., *not* on Windows if(doIncr) .mpfr_erange_set(value = myERng) log2(abs(.mpfr_erange()))# 62 62 if(doIncr) i.e. not on Windows (lrgOK <- all(log2(abs(.mpfr_erange())) >= 62)) # FALSE on Windows ## The largest quantile for which our mpfr-ized qnorm() does *NOT* underflow : cM <- if(doX) { "2528468770.343293436810768159197281514373932815851856314908753969469064" } else "2528468770.34329343681" ## 1 3 5 7 9 1 3 5 7 9 1 3 5 7 9 1 3 5 7 9 1 3 5 7 9 1 3 5 7 9 1 3 5 7 9 1 3 ## 10 20 30 40 50 60 70 (qM <- mpfr(cM)) (pM <- pnorm(-qM)) # precision if(doX) 233 else 70 bits of precision ; ## |--> 0 on Windows {limited erange}; otherwise and if(doX) : ## 7.64890682545699845135633468495894619457903458325606933043966616334460003e-1388255822130839040 log(pM) # 233 bits: -3196577161300663205.8575919621115614148120323933633827052786873078552904 if(lrgOK) withAutoprint({ %% FIXME : here, the internal qnInt() gives (-Inf, -Inf) : try( qnormI(pM) ) ## Error: lower < upper not fulfilled (evt. TODO) ## but this works print(qnI <- qnormI(log(pM), log.p=TRUE)) # -2528468770.343293436 all.equal(-qM, qnI, tol = 0) # << show how close; seen 1.084202e-19 stopifnot( all.equal(-qM, qnI, tol = 1e-18) ) }) if(FALSE) # this (*SLOW*) gives 21 x the *same* (wrong) result --- FIXME! qnormI(log(pM) * (2:22), log.p=TRUE) %% 21 'mpfr' numbers of precision 233 bits --- actually see *2* slightly differing: %% [1] -2528468770.34329343681076815919728151437393281585185631490875396946906388 %% [2] -2528468770.34329343681076815919728151437393281585185631490875396946906388 %% ............... %% [20] -2528468770.34329343681076815919728151437393281585185631490875396946906419 << %% [21] -2528468770.34329343681076815919728151437393281585185631490875396946906388 if(doX) ## Show how bad it is (currently ca. 220 iterations, and then *wrong*) str(qnormI(round(log(pM)), log.p=TRUE, trace=1, give.full = TRUE)) if(requireNamespace("DPQ")) new("mpfr", as(DPQ::qnormR(pM, trace=1), "mpfr")) # as(*, "mpfr") also works for +/- Inf # qnormR1(p= 0, m=0, s=1, l.t.= 1, log= 0): q = -0.5 # somewhat close to 0 or 1: r := sqrt(-lp) = 1.7879e+09 # r > 5, using rational form R_3(t), for t=1.787897e+09 -- that is *not* accurate # [1] -94658744.369295865460462720............ ## reset to previous status if needed if(doIncr) .mpfr_erange_set( , old_eranges) } \keyword{distribution} \keyword{math} Rmpfr/man/mpfr-class.Rd0000644000176200001440000004736615057534534014504 0ustar liggesusers\name{mpfr-class} \docType{class} \title{Class "mpfr" of Multiple Precision Floating Point Numbers} % \alias{mpfr-class} \alias{mpfr1-class} \alias{summaryMpfr-class} % \alias{[[,mpfr-method} \alias{[,mpfr,ANY,missing,missing-method} \alias{[<-,mpfr,missing,missing,ANY-method} \alias{[<-,mpfr,ANY,missing,ANY-method} \alias{[<-,mpfr,ANY,missing,mpfr-method} % FIXME: many of these are just \alias{}ed, but *NOT* documented: \alias{as.numeric,mpfr-method} \alias{as.vector,mpfrArray-method} \alias{as.integer,mpfr-method} \alias{beta,ANY,mpfr-method} \alias{beta,ANY,mpfrArray-method} \alias{beta,mpfr,ANY-method} \alias{beta,mpfr,mpfr-method} \alias{beta,mpfr,numeric-method} \alias{beta,numeric,mpfr-method} \alias{beta,mpfrArray,ANY-method} \alias{beta,mpfrArray,mpfrArray-method} \alias{lbeta,ANY,mpfr-method} \alias{lbeta,ANY,mpfrArray-method} \alias{lbeta,mpfr,ANY-method} \alias{lbeta,mpfr,mpfr-method} \alias{lbeta,mpfr,numeric-method} \alias{lbeta,numeric,mpfr-method} \alias{lbeta,mpfrArray,ANY-method} \alias{lbeta,mpfrArray,mpfrArray-method} \alias{atan2,ANY,mpfr-method} \alias{atan2,ANY,mpfrArray-method} \alias{atan2,mpfr,ANY-method} \alias{atan2,mpfr,mpfr-method} \alias{atan2,mpfr,numeric-method} \alias{atan2,numeric,mpfr-method} \alias{atan2,mpfrArray,ANY-method} \alias{atan2,mpfrArray,mpfrArray-method} \alias{hypot} % \alias{coerce,mpfr,character-method} \alias{coerce,mpfr,numeric-method} \alias{coerce,mpfr,bigz-method} \alias{coerce,mpfr,integer-method} \alias{coerce,mpfr1,numeric-method} \alias{coerce,mpfr1,mpfr-method} \alias{coerce,integer,mpfr-method} \alias{coerce,logical,mpfr-method} \alias{coerce,raw,mpfr-method} \alias{coerce,numeric,mpfr-method} \alias{coerce,numeric,mpfr1-method} \alias{coerce,array,mpfr-method} \alias{coerce,character,mpfr-method} \alias{coerce,mpfr,mpfr1-method} % \alias{Ops,mpfr,ANY-method} \alias{Ops,ANY,mpfr-method} \alias{Ops,mpfr,bigq-method} \alias{Ops,bigq,mpfr-method} \alias{Ops,mpfr,bigz-method} \alias{Ops,bigz,mpfr-method} \alias{Ops,array,mpfr-method} \alias{Ops,mpfr,array-method} \alias{Ops,mpfr,vector-method} \alias{Ops,vector,mpfr-method} \alias{Arith,mpfr,array-method} \alias{Arith,mpfr,missing-method} \alias{Arith,mpfr,mpfr-method} \alias{Arith,mpfr,integer-method} \alias{Arith,mpfr,numeric-method} \alias{Arith,integer,mpfr-method} \alias{Arith,numeric,mpfr-method} \alias{Arith,array,mpfr-method} % \alias{Compare,mpfr,mpfr-method} \alias{Compare,mpfr,integer-method} \alias{Compare,mpfr,numeric-method} \alias{Compare,integer,mpfr-method} \alias{Compare,numeric,mpfr-method} \alias{Compare,mpfr,array-method} \alias{Compare,array,mpfr-method} % \alias{Logic,mpfr,mpfr-method} \alias{Logic,mpfr,numeric-method} \alias{Logic,numeric,mpfr-method} \alias{Summary,mpfr-method} \alias{Math,mpfr-method} \alias{Math2,mpfr-method} \alias{abs,mpfr-method} \alias{log,mpfr-method} \alias{factorial,mpfr-method} \alias{sign,mpfr-method} % "Complex" (cheap methods for "real"s): \alias{Re,mpfr-method} \alias{Im,mpfr-method} \alias{Mod,mpfr-method} \alias{Arg,mpfr-method} \alias{Conj,mpfr-method} \alias{format,mpfr-method} \alias{is.finite,mpfr-method} \alias{is.infinite,mpfr-method} \alias{is.na,mpfr-method} \alias{is.nan,mpfr-method} \alias{is.finite,mpfrArray-method} \alias{is.infinite,mpfrArray-method} \alias{is.na,mpfrArray-method} \alias{is.nan,mpfrArray-method} \alias{unique,mpfr-method}% <--- wanted by R CMD check \alias{unique,mpfr,ANY-method}% not sufficient for R CMD .. \alias{unique.mpfr} % \alias{all.equal,mpfr,mpfr-method} \alias{all.equal,mpfr,ANY-method} \alias{all.equal,ANY,mpfr-method} \alias{mean,mpfr-method} \alias{median,mpfr-method} \alias{quantile,mpfr-method} \alias{summary,mpfr-method} \alias{dim<-,mpfr-method} \alias{t,mpfr-method} \alias{\%*\%,array_or_vector,mpfr-method} \alias{\%*\%,mpfr,array_or_vector-method} \alias{crossprod,array_or_vector,mpfr-method} \alias{crossprod,mpfr,array_or_vector-method} \alias{tcrossprod,array_or_vector,mpfr-method} \alias{tcrossprod,mpfr,array_or_vector-method} \alias{which.min,mpfr-method} \alias{which.max,mpfr-method} \alias{show,mpfr-method} \alias{show,mpfr1-method} \alias{show,summaryMpfr-method} \alias{print.mpfr1} \alias{print.summaryMpfr} % \description{ \code{"mpfr"} is the class of \bold{M}ultiple \bold{P}recision \bold{F}loatingpoint numbers with \bold{R}eliable arithmetic. For the high-level user, \code{"mpfr"} objects should behave as standard \R's \code{\link{numeric}} \emph{vectors}. They would just print differently and use the prespecified (typically high) precision instead of the double precision of \sQuote{traditional} \R numbers (with \code{\link{class}(.) == "numeric"} and \code{\link{typeof}(.) == "double"}). \code{hypot(x,y)} computes the hypothenuse length \eqn{z} in a rectangular triangle with \dQuote{leg} side lengths \eqn{x} and \eqn{y}, i.e., \deqn{z = hypot(x,y) = \sqrt{x^2 + y^2},}{z = hypot(x,y) = sqrt(x^2 + y^2),} in a numerically stable way. } \usage{ hypot(x,y, rnd.mode = c("N","D","U","Z","A")) } \arguments{ \item{x,y}{an object of class \code{mpfr}.} \item{rnd.mode}{a 1-letter string specifying how \emph{rounding} should happen at C-level conversion to MPFR, see \code{\link{mpfr}}.} } \section{Objects from the Class}{ Objects are typically created by \code{\link{mpfr}(, precBits)}. \code{summary()} returns an object of class \code{"summaryMpfr"} which contains \code{"mpfr"} but has its own \code{\link{print}} method. } \section{Slots}{ Internally, \code{"mpfr"} objects just contain standard \R \code{\link{list}}s where each list element is of class \code{"mpfr1"}, representing \emph{one} MPFR number, in a structure with four slots, very much parallelizing the C \code{struc} in the \code{mpfr} C library to which the \pkg{Rmpfr} package interfaces. An object of class \code{"mpfr1"} has slots \describe{ \item{\code{prec}:}{\code{"integer"} specifying the maxmimal precision in \bold{bits}.} \item{\code{exp}:}{\code{"integer"} specifying the base-\bold{2} exponent of the number.} \item{\code{sign}:}{\code{"integer"}, typically \code{-1} or \code{1}, specifying the sign (i.e. \code{\link{sign}(.)}) of the number.} \item{\code{d}:}{an \code{"integer"} vector (of 32-bit \dQuote{limbs}) which corresponds to the full mantissa of the number.} }% desc } % \section{Extends}{ % Class \code{"\linkS4class{list}"}, from data part. % Class \code{"\linkS4class{vector}"}, by class "list", distance 2. % } \section{Methods}{ \describe{ \item{abs}{\code{signature(x = "mpfr")}: ... } \item{atan2}{\code{signature(y = "mpfr", x = "ANY")}, and} \item{atan2}{\code{signature(x = "ANY", y = "mpfr")}: compute the arc-tangent of two arguments: \code{atan2(y, x)} returns the angle between the x-axis and the vector from the origin to \eqn{(x, y)}, i.e., for positive arguments \code{atan2(y, x) == \link{atan}(y/x)}.} \item{lbeta}{\code{signature(a = "ANY", b = "mpfrArray")}, is \eqn{\log(|B(a,b)|)}{log(abs(B(a,b)))} where \eqn{B(a,b)} is the Beta function, \code{beta(a,b)}.} \item{beta}{\code{signature(a = "mpfr", b = "ANY")},} \item{beta}{\code{signature(a = "mpfr", b = "mpfr")}, \dots, etc: Compute the beta function \eqn{B(a,b)}, using high precision, building on internal \code{\link{gamma}} or \code{\link{lgamma}}. See the help for \R's base function \code{\link[base]{beta}} for more. Currently, there, \eqn{a,b \ge 0}{a,b >= 0} is required. Here, we provide (non-\code{\link{NaN}}) for all numeric \code{a, b}. When either \eqn{a}, \eqn{b}, or \eqn{a+b} is a negative \emph{integer}, \eqn{\Gamma(.)} has a pole there and is undefined (\code{NaN}). However the Beta function can be defined there as \dQuote{limit}, in some cases. Following other software such as SAGE, Maple or Mathematica, we provide finite values in these cases. However, note that these are not proper limits (two-dimensional in \eqn{(a,b)}), but useful for some applications. E.g., \eqn{B(a,b)} is defined as zero when \eqn{a+b} is a negative integer, but neither \eqn{a} nor \eqn{b} is. Further, if \eqn{a > b > 0} are integers, \eqn{B(-a,b)= B(b,-a)} can be seen as \eqn{(-1)^b * B(a-b+1,b)}. } \item{dim<-}{\code{signature(x = "mpfr")}: Setting a dimension \code{\link{dim}} on an \code{"mpfr"} object makes it into an object of class \code{"\linkS4class{mpfrArray}"} or (more specifically) \code{"mpfrMatrix"} for a length-2 dimension, see their help page; note that \code{t(x)} (below) is a special case of this.} \item{Ops}{\code{signature(e1 = "mpfr", e2 = "ANY")}: ... } \item{Ops}{\code{signature(e1 = "ANY", e2 = "mpfr")}: ... } \item{Arith}{\code{signature(e1 = "mpfr", e2 = "missing")}: ... } \item{Arith}{\code{signature(e1 = "mpfr", e2 = "mpfr")}: ... } \item{Arith}{\code{signature(e1 = "mpfr", e2 = "integer")}: ... } \item{Arith}{\code{signature(e1 = "mpfr", e2 = "numeric")}: ... } \item{Arith}{\code{signature(e1 = "integer", e2 = "mpfr")}: ... } \item{Arith}{\code{signature(e1 = "numeric", e2 = "mpfr")}: ... } \item{Compare}{\code{signature(e1 = "mpfr", e2 = "mpfr")}: ... } \item{Compare}{\code{signature(e1 = "mpfr", e2 = "integer")}: ... } \item{Compare}{\code{signature(e1 = "mpfr", e2 = "numeric")}: ... } \item{Compare}{\code{signature(e1 = "integer", e2 = "mpfr")}: ... } \item{Compare}{\code{signature(e1 = "numeric", e2 = "mpfr")}: ... } \item{Logic}{\code{signature(e1 = "mpfr", e2 = "mpfr")}: ... } \item{Summary}{\code{signature(x = "mpfr")}: The S4 \code{\link[methods:S4groupGeneric]{Summary}} group functions, \code{\link{max}}, \code{\link{min}}, \code{\link{range}}, \code{\link{prod}}, \code{\link{sum}}, \code{\link{any}}, and \code{\link{all}} are all defined for MPFR numbers. \code{\link{mean}(x, trim)} for non-0 \code{trim} works analogously to \code{\link{mean.default}}.} \item{median}{\code{signature(x = "mpfr")}: works via}% quantile(*, probs = 0.5) : \item{quantile}{\code{signature(x = "mpfr")}: a simple wrapper of the \code{quantile.default} method from \pkg{stats}.} \item{summary}{\code{signature(object = "mpfr")}: modeled after \code{\link{summary.default}}, ensuring to provide the full "mpfr" range of numbers.} \item{Math}{\code{signature(x = "mpfr")}: All the S4 \code{\link[methods:S4groupGeneric]{Math}} group functions are defined, using multiple precision (MPFR) arithmetic, from \code{\link{getGroupMembers}("Math")}, these are (in alphabetical order): % keep in sync w/ >> ../R/Math.R << \code{\link{abs}}, \code{\link{sign}}, \code{\link{sqrt}}, \code{\link{ceiling}}, \code{\link{floor}}, \code{\link{trunc}}, \code{\link{cummax}}, \code{\link{cummin}}, \code{\link{cumprod}}, \code{\link{cumsum}}, \code{\link{exp}}, \code{\link{expm1}}, \code{\link{log}}, \code{\link{log10}}, \code{\link{log2}}, \code{\link{log1p}}, \code{\link{cos}}, \code{\link{cosh}}, \code{\link{sin}}, \code{\link{sinh}}, \code{\link{tan}}, \code{\link{tanh}}, \code{\link{acos}}, \code{\link{acosh}}, \code{\link{asin}}, \code{\link{asinh}}, \code{\link{atan}}, \code{\link{atanh}}, \code{\link{cospi}}, \code{\link{sinpi}}, \code{\link{tanpi}}, \code{\link{gamma}}, \code{\link{lgamma}}, \code{\link{digamma}}, and \code{\link{trigamma}}. Currently, \code{trigamma} is not provided by the MPFR library and hence not yet implemented. \cr Further, the \code{cum*()} methods are \emph{not yet} implemented.} \item{factorial}{\code{signature(x = "mpfr")}: this will \code{\link{round}} the result when \code{x} is integer valued. Note however that \code{\link{factorialMpfr}(n)} for integer \code{n} is slightly more efficient, using the MPFR function \samp{mpfr_fac_ui}.} \item{Math2}{\code{signature(x = "mpfr")}: \code{\link{round}(x, digits)} and \code{\link{signif}(x, digits)} methods. Note that these do not change the formal precision (\code{'prec'} slot), and you may often want to apply \code{\link{roundMpfr}()} in addition or preference.} \item{as.numeric}{\code{signature(x = "mpfr")}: ... } \item{as.vector}{\code{signature(x = "mpfrArray")}: as for standard \code{\link{array}}s, this \dQuote{drops} the \code{dim} (and \code{dimnames}), i.e., transforms \code{x} into an \sQuote{MPFR} number vector, i.e., class \code{\linkS4class{mpfr}}.} \item{[[}{\code{signature(x = "mpfr", i = "ANY")}, and} \item{[}{\code{signature(x = "mpfr", i = "ANY", j = "missing", drop = "missing")}: subsetting aka \dQuote{indexing} happens as for numeric vectors.} \item{format}{\code{signature(x = "mpfr")}, further arguments \code{digits = NULL, scientific = NA}, etc: This method is identical to the (exported) \code{\link{formatMpfr}()} function, see its help page for details.}% ./formatMpfr.Rd \item{is.finite}{\code{signature(x = "mpfr")}: ... } \item{is.infinite}{\code{signature(x = "mpfr")}: ... } \item{is.na}{\code{signature(x = "mpfr")}: ... } \item{is.nan}{\code{signature(x = "mpfr")}: ... } \item{log}{\code{signature(x = "mpfr")}: ... } \item{show}{\code{signature(object = "mpfr")}: The \code{\link{show}} method for \code{"mpfr"} classed objects calls the S3 method \code{\link{print.mpfr}(object)} with several optional arguments, itself based on the \code{format()} method which calls \code{\link{formatMpfr}()}.} \item{sign}{\code{signature(x = "mpfr")}: ... } \item{Re, Im}{\code{signature(z = "mpfr")}: simply return \code{z} or \code{0} (as \code{"mpfr"} numbers of correct precision), as mpfr numbers are \sQuote{real} numbers.} \item{Arg, Mod, Conj}{\code{signature(z = "mpfr")}: these are trivial for our \sQuote{real} mpfr numbers, but defined to work correctly when used in \R code that also allows complex number input.} \item{all.equal}{\code{signature(target = "mpfr", current = "mpfr")},} \item{all.equal}{\code{signature(target = "mpfr", current = "ANY")}, and} \item{all.equal}{\code{signature(target = "ANY", current = "mpfr")}: methods for numerical (approximate) equality, \code{\link[base]{all.equal}} of multiple precision numbers. Note that the default \code{tolerance} (argument) is taken to correspond to the (smaller of the two) precisions when both main arguments are of class \code{"mpfr"}, and hence can be considerably less than double precision machine epsilon \code{\link{.Machine}$double.eps}.} \item{coerce}{\code{signature(from = "numeric", to = "mpfr")}: \code{\link{as}(., "mpfr")} coercion methods are available for \code{\link{character}} strings, \code{\link{numeric}}, \code{\link{integer}}, \code{\link{logical}}, and even \code{\link{raw}}. Note however, that \code{\link{mpfr}(., precBits, base)} is more flexible.} \item{coerce}{\code{signature(from = "mpfr", to = "bigz")}: coerces to biginteger, see \code{\link[gmp]{bigz}} in package \pkg{gmp}.} \item{coerce}{\code{signature(from = "mpfr", to = "numeric")}: ... } \item{coerce}{\code{signature(from = "mpfr", to = "character")}: ... } \item{unique}{\code{signature(x = "mpfr")}, and corresponding S3 method (such that \code{unique()} works inside \pkg{base} functions), see \code{\link{unique}}. Note that \code{\link{duplicated}()} works for \code{"mpfr"} objects without the need for a specific method.} \item{t}{\code{signature(x = "mpfr")}: makes \code{x} into an \eqn{n \times 1}{n x 1} \code{\linkS4class{mpfrMatrix}}.} \item{which.min}{\code{signature(x = "mpfr")}: gives the index of the first minimum, see \code{\link{which.min}}.} \item{which.max}{\code{signature(x = "mpfr")}: gives the index of the first maximum, see \code{\link{which.max}}.} } } \author{Martin Maechler} \note{Many more methods (\dQuote{functions}) automagically work for \code{"mpfr"} number vectors (and matrices, see the \code{\linkS4class{mpfrMatrix}} class doc), notably \code{\link{sort}}, \code{\link{order}}, \code{\link{quantile}}, \code{\link{rank}}. } \seealso{ The \code{"\linkS4class{mpfrMatrix}"} class, which extends the \code{"mpfr"} one. \code{\link{roundMpfr}} to \emph{change} precision of an \code{"mpfr"} object which is typically desirable \emph{instead} of or in addition to \code{signif()} or \code{round()}; \code{\link[gmp]{is.whole}()} from \CRANpkg{gmp}, etc. Special mathematical functions such as some Bessel ones, e.g., \code{\link{jn}}; further, \code{\link{zeta}(.)} \eqn{(= \zeta(.))}, \code{Ei()} etc. \code{\link{Bernoulli}} numbers and the Pochhammer function \code{\link{pochMpfr}}. } \examples{ ## 30 digit precision (x <- mpfr(c(2:3, pi), prec = 30 * log2(10))) str(x) # str() displays *compact*ly => not full precision x^2 x[1] / x[2] # 0.66666... ~ 30 digits ## indexing - as with numeric vectors stopifnot(exprs = { identical(x[2], x[[2]]) ## indexing "outside" gives NA (well: "mpfr-NaN" for now): is.na(x[5]) ## whereas "[[" cannot index outside: inherits(tryCatch(x[[5]], error=identity), "error") ## and only select *one* element: inherits(tryCatch(x[[2:3]], error=identity), "error") }) ## factorial() & lfactorial would work automagically via [l]gamma(), ## but factorial() additionally has an "mpfr" method which rounds f200 <- factorial(mpfr(200, prec = 1500)) # need high prec.! f200 as.numeric(log2(f200))# 1245.38 -- need precBits >~ 1246 for full precision ##--> see factorialMpfr() for more such computations. ##--- "Underflow" **much** later -- exponents have 30(+1) bits themselves: mpfr.min.exp2 <- - (2^30 + 1) two <- mpfr(2, 55) stopifnot(two ^ mpfr.min.exp2 == 0) ## whereas two ^ (mpfr.min.exp2 * (1 - 1e-15)) ## 2.38256490488795107e-323228497 ["typically"] ##--- "Assert" that {sort}, {order}, {quantile}, {rank}, all work : p <- mpfr(rpois(32, lambda=500), precBits=128)^10 np <- as.numeric(log(p)) (sp <- summary(p))# using the print.summaryMpfr() method stopifnot(all(diff(sort(p)) >= 0), identical(order(p), order(np)), identical(rank (p), rank (np)), all.equal(sapply(1:9, function(Typ) quantile(np, type=Typ, names=FALSE)), sapply(lapply(1:9, function(Typ) quantile( p, type=Typ, names=FALSE)), function(x) as.numeric(log(x))), tol = 1e-3),# quantiles: interpolated in orig. <--> log scale TRUE) m0 <- mpfr(numeric(), 99) xy <- expand.grid(x = -2:2, y = -2:2) ; x <- xy[,"x"] ; y <- xy[,"y"] a2. <- atan2(y,x) stopifnot(identical(which.min(m0), integer(0)), identical(which.max(m0), integer(0)), all.equal(a2., atan2(as(y,"mpfr"), x)), max(m0) == mpfr(-Inf, 53), # (53 is not a feature, but ok) min(m0) == mpfr(+Inf, 53), sum(m0) == 0, prod(m0) == 1) ## unique(), now even base::factor() "works" on : set.seed(17) p <- rlnorm(20) * mpfr(10, 100)^-999 pp <- sample(p, 50, replace=TRUE) str(unique(pp)) # length 18 .. (from originally 20) ## Class 'mpfr' [package "Rmpfr"] of length 18 and precision 100 ## 5.56520587824e-999 4.41636588227e-1000 .. facp <- factor(pp) str(facp) # the factor *levels* are a bit verbose : # Factor w/ 18 levels "new(\"mpfr1\", ...........)" ... # At least *some* factor methods work : stopifnot(exprs = { is.factor(facp) identical(unname(table(facp)), unname(table(asNumeric(pp * mpfr(10,100)^1000)))) }) ## ((unfortunately, the expressions are wrong; should integer "L")) # ## More useful: levels with which to *invert* factor() : ## -- this is not quite ok: ## simplified from 'utils' : deparse1 <- function(x, ...) paste(deparse(x, 500L, ...), collapse = " ") if(FALSE) { str(pp.levs <- vapply(unclass(sort(unique(pp))), deparse1, "")) facp2 <- factor(pp, levels = pp.levs) } } \keyword{classes} Rmpfr/man/Bessel_mpfr.Rd0000644000176200001440000000463214134764740014662 0ustar liggesusers\name{Bessel_mpfr} \title{Bessel functions of Integer Order in multiple precisions} \alias{Bessel_mpfr} \alias{Ai} \alias{j0} \alias{j1} \alias{jn} \alias{y0} \alias{y1} \alias{yn} \description{ Bessel functions of integer orders, provided via arbitrary precision algorithms from the MPFR library. Note that the computation can be very slow when \code{n} \emph{and} \code{x} are large (and of similar magnitude). % e.g. on nb-mm3, jn(4e4, 4e4) takes 14 sec [1.1. 2015] } \usage{ Ai(x) j0(x) j1(x) jn(n, x, rnd.mode = c("N","D","U","Z","A")) y0(x) y1(x) yn(n, x, rnd.mode = c("N","D","U","Z","A")) } \arguments{ \item{x}{a \code{\link{numeric}} or \code{\linkS4class{mpfr}} vector.} \item{n}{non-negative integer (vector).} \item{rnd.mode}{a 1-letter string specifying how \emph{rounding} should happen at C-level conversion to MPFR, see \code{\link{mpfr}}.} } \value{ Computes multiple precision versions of the Bessel functions of \emph{integer} order, \eqn{J_n(x)}{J[n](x)} and \eqn{Y_n(x)}{Y[n](x)}, and---when using MPFR library 3.0.0 or newer---also of the Airy function \eqn{Ai(x)}. Note that currently \code{Ai(x)} is very slow to compute for large \code{x}. } \seealso{\code{\link{besselJ}}, and \code{\link{besselY}} compute the same bessel functions but for arbitrary \emph{real} order and only precision of a bit more than ten digits. %% Connection Formulas https://dlmf.nist.gov/10.27 [ J,Y <--> I,K ] but %% via *complex* args } \examples{ x <- (0:100)/8 # (have exact binary representation) stopifnot(exprs = { all.equal(besselY(x, 0), bY0 <- y0(x)) all.equal(besselJ(x, 1), bJ1 <- j1(x)) all.equal(yn(0,x), bY0) all.equal(jn(1,x), bJ1) }) mpfrVersion() # now typically 4.1.0 if(mpfrVersion() >= "3.0.0") { ## Ai() not available previously print( aix <- Ai(x) ) plot(x, aix, log="y", type="l", col=2) stopifnot( all.equal(Ai (0) , 1/(3^(2/3) * gamma(2/3))) , # see https://dlmf.nist.gov/9.2.ii all.equal(Ai(100), mpfr("2.6344821520881844895505525695264981561e-291"), tol=1e-37) ) two3rd <- 2/mpfr(3, 144) print( all.equal(Ai(0), 1/(3^two3rd * gamma(two3rd)), tol=0) ) # 1.7....e-40 if(Rmpfr:::doExtras()) withAutoprint({ # slowish: system.time(ai1k <- Ai(1000)) # 1.4 sec (on 2017 lynne) stopifnot(all.equal(print(log10(ai1k)), -9157.031193409585185582, tol=2e-16)) # seen 8.8..e-17 | 1.1..e-16 }) } # ver >= 3.0 } \keyword{math} Rmpfr/man/num2bigq.Rd0000644000176200001440000000323614644764560014152 0ustar liggesusers\name{num2bigq} \alias{num2bigq} \title{BigQ / BigRational Approximation of Numbers} \description{ \code{num2bigq(x)} searches for \dQuote{small} denominator \code{bigq} aka \sQuote{bigRational} approximations to numeric or \code{"mpfr"} \code{x}. It uses the same continued fraction approximation as package \CRANpkg{MASS}' \code{\link[MASS]{fractions}()}, but using big integer, rational and mpfr-arithmetic from packages \CRANpkg{Rmpfr} and \CRANpkg{gmp}. } \usage{ num2bigq(x, cycles = 50L, max.denominator = 2^25, verbose = FALSE) } \arguments{ \item{x}{numeric or mpfr-number like} \item{cycles}{a positive integer, the maximal number of approximation cycles, or equivalently, continued fraction terms to be used.} \item{max.denominator}{an \emph{approximate} bound on the maximal denominator used in the approximation. If small, the algorithm may use less than \code{cycles} cycles. } \item{verbose}{a logical indicating if some intermediate results should be printed during the iterative approximation.} } %% \details{ %% } \value{ a big rational, i.e., \code{\link[gmp]{bigq}} (from \CRANpkg{gmp}) vector of the same length as \code{x}. } %% \references{ %% } \author{Bill Venables and Brian Ripley, for the algorithm in \code{\link[MASS]{fractions}()}; Martin Maechler, for the port to use \pkg{Rmpfr} and \code{gmp} arithmetic.} \seealso{ \code{\link{.mpfr2bigq}()} seems similar but typically uses much larger denominators in order to get full accuracy. } \examples{ num2bigq(0.33333) num2bigq(pi, max.denominator = 200) # 355/113 num2bigq(pi) # much larger num2bigq(pi, cycles=10) # much larger } \keyword{arith} \keyword{math} Rmpfr/man/optimizeR.Rd0000644000176200001440000001337613752457464014417 0ustar liggesusers\name{optimizeR} \alias{optimizeR} \title{High Precision One-Dimensional Optimization} %% Compare with ~/R/D/r-devel/R/src/library/stats/man/optimize.Rd \description{ \code{optimizeR} searches the interval from \code{lower} to \code{upper} for a minimum % TODO ? or maximum of the function \code{f} with respect to its first argument. } \usage{ optimizeR(f, lower, upper, ..., tol = 1e-20, method = c("Brent", "GoldenRatio"), maximum = FALSE, precFactor = 2.0, precBits = -log2(tol) * precFactor, maxiter = 1000, trace = FALSE) } \arguments{ \item{f}{the function to be optimized. \code{f(x)} must work \dQuote{in \pkg{Rmpfr} arithmetic} for \code{optimizer()} to make sense. The function is either minimized or maximized over its first argument depending on the value of \code{maximum}.} \item{\dots}{additional named or unnamed arguments to be passed to \code{f}.} \item{lower}{the lower end point of the interval to be searched.} \item{upper}{the upper end point of the interval to be searched.} \item{tol}{the desired accuracy, typically higher than double precision, i.e., \code{tol < 2e-16}.} \item{method}{\code{\link{character}} string specifying the optimization method.}% \item{maximum}{logical indicating if \eqn{f()} should be maximized or minimized (the default).} \item{precFactor}{only for default \code{precBits} construction: a factor to multiply with the number of bits directly needed for \code{tol}.} \item{precBits}{number of bits to be used for \code{\link[Rmpfr]{mpfr}} numbers used internally.} \item{maxiter}{maximal number of iterations to be used.} \item{trace}{integer or logical indicating if and how iterations should be monitored; if an integer \eqn{k}, print every \eqn{k}-th iteration.} } \details{ \describe{ \item{\code{"Brent"}:}{Brent(1973)'s simple and robust algorithm is a hybrid, using a combination of the golden ratio and local quadratic (\dQuote{parabolic}) interpolation. This is the same algorithm as standard \R's \code{\link{optimize}()}, adapted to high precision numbers. In smooth cases, the convergence is considerably faster than the golden section or Fibonacci ratio algorithms. } \item{\code{"GoldenRatio"}:}{The golden ratio method, aka \sQuote{golden-section search} works as follows: from a given interval containing the solution, it constructs the next point in the golden ratio between the interval boundaries. } }% end{describe} } \value{ A \code{\link{list}} with components \code{minimum} (or \code{maximum}) and \code{objective} which give the location of the minimum (or maximum) and the value of the function at that point; \code{iter} specifiying the number of iterations, the logical \code{convergence} indicating if the iterations converged and \code{estim.prec} which is an estimate or an upper bound of the final precision (in \eqn{x}). \code{method} the string of the method used. } % \references{ % } \author{ \code{"GoldenRatio"} is based on Hans Werner Borchers' \code{\link[pracma]{golden_ratio}} (package \CRANpkg{pracma}); modifications and \code{"Brent"} by Martin Maechler. } % \note{ % } \seealso{ \R's standard \code{\link{optimize}}; for multivariate optimization, \pkg{Rmpfr}'s \code{\link{hjkMpfr}()}; for root finding, \pkg{Rmpfr}'s \code{\link{unirootR}}. } \examples{ ## The minimum of the Gamma (and lgamma) function (for x > 0): Gmin <- optimizeR(gamma, .1, 3, tol = 1e-50) str(Gmin, digits = 8) ## high precision chosen for "objective"; minimum has "estim.prec" = 1.79e-50 Gmin[c("minimum","objective")] ## it is however more accurate to 59 digits: asNumeric(optimizeR(gamma, 1, 2, tol = 1e-100)$minimum - Gmin$minimum) iG5 <- function(x) -exp(-(x-5)^2/2) curve(iG5, 0, 10, 200) o.dp <- optimize (iG5, c(0, 10)) #-> 5 of course oM.gs <- optimizeR(iG5, 0, 10, method="Golden") oM.Br <- optimizeR(iG5, 0, 10, method="Brent", trace=TRUE) oM.gs$min ; oM.gs$iter oM.Br$min ; oM.Br$iter (doExtras <- Rmpfr:::doExtras()) if(doExtras) {## more accuracy {takes a few seconds} oM.gs <- optimizeR(iG5, 0, 10, method="Golden", tol = 1e-70) oM.Br <- optimizeR(iG5, 0, 10, tol = 1e-70) } rbind(Golden = c(err = as.numeric(oM.gs$min -5), iter = oM.gs$iter), Brent = c(err = as.numeric(oM.Br$min -5), iter = oM.Br$iter)) ## ==> Brent is orders of magnitude more efficient ! ## Testing on the sine curve with 40 correct digits: sol <- optimizeR(sin, 2, 6, tol = 1e-40) str(sol) sol <- optimizeR(sin, 2, 6, tol = 1e-50, precFactor = 3.0, trace = TRUE) pi.. <- 2*sol$min/3 print(pi.., digits=51) stopifnot(all.equal(pi.., Const("pi", 256), tolerance = 10*1e-50)) if(doExtras) { # considerably more expensive ## a harder one: f.sq <- function(x) sin(x-2)^4 + sqrt(pmax(0,(x-1)*(x-4)))*(x-2)^2 curve(f.sq, 0, 4.5, n=1000) msq <- optimizeR(f.sq, 0, 5, tol = 1e-50, trace=5) str(msq) # ok stopifnot(abs(msq$minimum - 2) < 1e-49) ## find the other local minimum: -- non-smooth ==> Golden ratio -section is used msq2 <- optimizeR(f.sq, 3.5, 5, tol = 1e-50, trace=10) stopifnot(abs(msq2$minimum - 4) < 1e-49) ## and a local maximum: msq3 <- optimizeR(f.sq, 3, 4, maximum=TRUE, trace=2) stopifnot(abs(msq3$maximum - 3.57) < 1e-2) }#end {doExtras} ##----- "impossible" one to get precisely ------------------------ ff <- function(x) exp(-1/(x-8)^2) curve(exp(-1/(x-8)^2), -3, 13, n=1001) (opt. <- optimizeR(function(x) exp(-1/(x-8)^2), -3, 13, trace = 5)) ## -> close to 8 {but not very close!} ff(opt.$minimum) # gives 0 if(doExtras) { ## try harder ... in vain .. str(opt1 <- optimizeR(ff, -3,13, tol = 1e-60, precFactor = 4)) print(opt1$minimum, digits=20) ## still just 7.99998038 or 8.000036655 {depending on method} } } \keyword{optimize} Rmpfr/man/hjkMpfr.Rd0000644000176200001440000001165614365710754014030 0ustar liggesusers\name{hjkMpfr} \alias{hjkMpfr} \title{Hooke-Jeeves Derivative-Free Minimization R (working for MPFR)} \description{ An implementation of the Hooke-Jeeves algorithm for derivative-free optimization. %% TODO: hjkb() A bounded and an unbounded version are provided. --> ~/R/Pkgs/dfoptim/R/ This is a slight adaption \code{\link[dfoptim]{hjk}()} from package \CRANpkg{dfoptim}. } \usage{ hjkMpfr(par, fn, control = list(), ...) } \arguments{ \item{par}{Starting vector of parameter values. The initial vector may lie on the boundary. If \code{lower[i]=upper[i]} for some \code{i}, the \code{i}-th component of the solution vector will simply be kept fixed.} \item{fn}{Nonlinear objective function that is to be optimized. A scalar function that takes a real vector as argument and returns a scalar that is the value of the function at that point.} \item{control}{\code{\link{list}} of control parameters. See \bold{Details} for more information.} \item{\dots}{Additional arguments passed to \code{fn}.} } \details{ Argument \code{control} is a list specifing changes to default values of algorithm control parameters. Note that parameter names may be abbreviated as long as they are unique. The list items are as follows: \describe{ \item{\code{tol}}{Convergence tolerance. Iteration is terminated when the step length of the main loop becomes smaller than \code{tol}. This does \emph{not} imply that the optimum is found with the same accuracy. Default is 1.e-06.} \item{\code{maxfeval}}{Maximum number of objective function evaluations allowed. Default is Inf, that is no restriction at all.} \item{\code{maximize}}{A logical indicating whether the objective function is to be maximized (TRUE) or minimized (FALSE). Default is FALSE.} \item{\code{target}}{A real number restricting the absolute function value. The procedure stops if this value is exceeded. Default is Inf, that is no restriction.} \item{\code{info}}{A logical variable indicating whether the step number, number of function calls, best function value, and the first component of the solution vector will be printed to the console. Default is FALSE.} } If the minimization process threatens to go into an infinite loop, set either \code{maxfeval} or \code{target}. } \value{ A \code{\link{list}} with the following components: \item{par}{Best estimate of the parameter vector found by the algorithm.} \item{value}{value of the objective function at termination.} \item{convergence}{indicates convergence (\code{TRUE}) or not (\code{FALSE}).} \item{feval}{number of times the objective \code{fn} was evaluated.} \item{niter}{number of iterations (\dQuote{steps}) in the main loop.} } \references{ C.T. Kelley (1999), Iterative Methods for Optimization, SIAM. Quarteroni, Sacco, and Saleri (2007), Numerical Mathematics, Springer. } \note{ This algorithm is based on the Matlab code of Prof. C. T. Kelley, given in his book \dQuote{Iterative methods for optimization}. It has been implemented for package \pkg{dfoptim} with the permission of Prof. Kelley. This version does not (yet) implement a cache for storing function values that have already been computed as searching the cache makes it slower. } \author{Hans W Borchers \email{hwborchers@googlemail.com}; for \pkg{Rmpfr}: John Nash, June 2012. Modifications by Martin Maechler.} % \note{ % } \seealso{ Standard \R's \code{\link{optim}}; \code{\link{optimizeR}} provides \emph{one}-dimensional minimization methods that work with \code{\linkS4class{mpfr}}-class numbers. } \examples{ ## simple smooth example: ff <- function(x) sum((x - c(2:4))^2) str(rr <- hjkMpfr(rep(mpfr(0,128), 3), ff, control=list(info=TRUE))) doX <- Rmpfr:::doExtras(); cat("doExtras: ", doX, "\n") # slow parts only if(doX) ## Hooke-Jeeves solves high-dim. Rosenbrock function {but slowly!} rosenbrock <- function(x) { n <- length(x) sum (100*((x1 <- x[1:(n-1)])^2 - x[2:n])^2 + (x1 - 1)^2) } par0 <- rep(0, 10) str(rb.db <- hjkMpfr(rep(0, 10), rosenbrock, control=list(info=TRUE))) if(doX) { ## rosenbrook() is quite slow with mpfr-numbers: str(rb.M. <- hjkMpfr(mpfr(numeric(10), prec=128), rosenbrock, control = list(tol = 1e-8, info=TRUE))) } %% Once we have it: *bounded* version: %% hjkbMpfr(c(0, 0, 0), rosenbrock, upper = 0.5) ## Hooke-Jeeves does not work well on non-smooth functions nsf <- function(x) { f1 <- x[1]^2 + x[2]^2 f2 <- x[1]^2 + x[2]^2 + 10 * (-4*x[1] - x[2] + 4) f3 <- x[1]^2 + x[2]^2 + 10 * (-x[1] - 2*x[2] + 6) max(f1, f2, f3) } par0 <- c(1, 1) # true min 7.2 at (1.2, 2.4) h.d <- hjkMpfr(par0, nsf) # fmin=8 at xmin=(2,2) if(doX) { ## and this is not at all better (but slower!) h.M <- hjkMpfr(mpfr(c(1,1), 128), nsf, control = list(tol = 1e-15)) } %% --> ../demo/hjkMpfr.R : ## --> demo(hjkMpfr) # -> Fletcher's chebyquad function m = n -- residuals } \keyword{optimize} Rmpfr/man/Bernoulli.Rd0000644000176200001440000000327013735036657014356 0ustar liggesusers\name{Bernoulli} \alias{Bernoulli} \title{Bernoulli Numbers in Arbitrary Precision} \description{ Computes the Bernoulli numbers in the desired (binary) precision. The computation happens via the \code{\link{zeta}} function and the formula \deqn{B_k = -k \zeta(1 - k),} and hence the only non-zero odd Bernoulli number is \eqn{B_1 = +1/2}. (Another tradition defines it, equally sensibly, as \eqn{-1/2}.) } \usage{ Bernoulli(k, precBits = 128) } \arguments{ \item{k}{non-negative integer vector} \item{precBits}{the precision in \emph{bits} desired.} } \value{ an \code{\linkS4class{mpfr}} class vector of the same length as \code{k}, with i-th component the \code{k[i]}-th Bernoulli number. } \references{\url{https://en.wikipedia.org/wiki/Bernoulli_number} } \author{Martin Maechler} \seealso{\code{\link{zeta}} is used to compute them. The next version of package \CRANpkg{gmp} is to contain %\code{\link[gmp]{BernoulliQ}()} \code{BernoulliQ()}, providing exact Bernoulli numbers as big rationals (class \code{"bigq"}). } \examples{ \dontshow{sessionInfo() .libPaths() packageDescription("gmp")} Bernoulli(0:10) plot(as.numeric(Bernoulli(0:15)), type = "h") curve(-x*zeta(1-x), -.2, 15.03, n=300, main = expression(-x \%.\% zeta(1-x))) legend("top", paste(c("even","odd "), "Bernoulli numbers"), pch=c(1,3), col=2, pt.cex=2, inset=1/64) abline(h=0,v=0, lty=3, col="gray") k <- 0:15; k[1] <- 1e-4 points(k, -k*zeta(1-k), col=2, cex=2, pch=1+2*(k\%\%2)) ## They pretty much explode for larger k : k2 <- 2*(1:120) plot(k2, abs(as.numeric(Bernoulli(k2))), log = "y") title("Bernoulli numbers exponential growth") Bernoulli(10000)# - 9.0494239636 * 10^27677 } \keyword{arith} Rmpfr/man/mpfrMatrix-class.Rd0000644000176200001440000002463713637431043015656 0ustar liggesusers\name{mpfrMatrix} \title{Classes "mpfrMatrix" and "mpfrArray"}% <--> ./mpfrArray.Rd \docType{class} \alias{mpfrMatrix-class} \alias{mpfrArray-class} % \alias{Arith,mpfrArray,mpfr-method} \alias{Arith,mpfrArray,mpfrArray-method} \alias{Arith,mpfr,mpfrArray-method} \alias{Arith,mpfrArray,numeric-method} \alias{Arith,numeric,mpfrArray-method} \alias{Compare,mpfrArray,mpfr-method} \alias{Compare,mpfrArray,numeric-method} \alias{Compare,mpfr,mpfrArray-method} \alias{Compare,numeric,mpfrArray-method} % \alias{apply,mpfrArray-method} \alias{colSums,mpfrArray-method} \alias{colMeans,mpfrArray-method} \alias{rowSums,mpfrArray-method} \alias{rowMeans,mpfrArray-method} \alias{as.vector,mpfrArray,missing-method} \alias{coerce,mpfrArray,array-method} \alias{coerce,array,mpfrArray-method} \alias{coerce,mpfrArray,matrix-method} \alias{coerce,mpfrMatrix,matrix-method} \alias{coerce,matrix,mpfrMatrix-method} %% the following two from the same setAs(); the 2nd one is auto-produced %% *and* needed by codoc(). Behavior seems a bit bogous : \alias{coerce,mpfrArray,vector-method} \alias{coerce<-,mpfrArray,vector-method} \alias{diag,mpfrMatrix-method} \alias{diag<-,mpfrMatrix-method} % \alias{[<-,mpfrArray,ANY,ANY,ANY-method} \alias{[<-,mpfrArray,ANY,ANY,mpfr-method} \alias{[<-,mpfrArray,ANY,missing,ANY-method} \alias{[<-,mpfrArray,ANY,missing,mpfr-method} \alias{[<-,mpfrArray,missing,ANY,ANY-method} \alias{[<-,mpfrArray,missing,ANY,mpfr-method} \alias{[<-,mpfrArray,missing,missing,ANY-method} \alias{[<-,mpfrArray,missing,missing,mpfr-method} \alias{[<-,mpfrArray,matrix,missing,ANY-method} \alias{[<-,mpfrArray,matrix,missing,mpfr-method} % \alias{[,mpfrArray,ANY,ANY,ANY-method} \alias{[,mpfrArray,ANY,missing,missing-method} \alias{[,mpfrArray,matrix,missing,missing-method} \alias{\%*\%,Mnumber,mpfr-method} \alias{\%*\%,mpfrMatrix,mpfr-method} \alias{\%*\%,mpfrMatrix,mpfrMatrix-method} \alias{\%*\%,mpfr,Mnumber-method} \alias{\%*\%,mpfr,mpfr-method} \alias{\%*\%,mpfr,mpfrMatrix-method} \alias{crossprod,mpfr,missing-method} \alias{crossprod,mpfrMatrix,mpfr-method} \alias{crossprod,mpfrMatrix,mpfrMatrix-method} \alias{crossprod,mpfr,Mnumber-method} \alias{crossprod,mpfr,mpfr-method} \alias{crossprod,mpfr,mpfrMatrix-method} \alias{crossprod,Mnumber,mpfr-method} \alias{tcrossprod,mpfr,missing-method} \alias{tcrossprod,mpfrMatrix,mpfr-method} \alias{tcrossprod,mpfrMatrix,mpfrMatrix-method} \alias{tcrossprod,mpfr,Mnumber-method} \alias{tcrossprod,mpfr,mpfr-method} \alias{tcrossprod,mpfr,mpfrMatrix-method} \alias{tcrossprod,Mnumber,mpfr-method} \alias{dim,mpfrArray-method} \alias{dimnames<-,mpfrArray-method} \alias{dimnames,mpfrArray-method} \alias{norm,ANY,missing-method} \alias{norm,mpfrMatrix,character-method} \alias{show,mpfrArray-method} \alias{sign,mpfrArray-method} \alias{t,mpfrMatrix-method} \alias{aperm,mpfrArray-method} % \description{The classes \code{"mpfrMatrix"} and \code{"mpfrArray"} are, analogously to the \pkg{base} \code{\link{matrix}} and \code{\link{array}} functions and classes simply \dQuote{numbers} of class \code{\linkS4class{mpfr}} with an additional \code{Dim} and \code{Dimnames} slot. } \section{Objects from the Class}{ Objects should typically be created by \code{\link{mpfrArray}()}, but can also be created by \code{new("mpfrMatrix", ...)} or \code{new("mpfrArray", ...)}, or also by \code{t(x)}, \code{dim(x) <- dd}, or \code{\link{mpfr2array}(x, dim=dd)} where \code{x} is a an \code{\linkS4class{mpfr}} \dQuote{number vector}. A (slightly more flexible) alternative to \code{dim(x) <- dd} is \code{\link{mpfr2array}(x, dd, dimnames)}. } \section{Slots}{ \describe{ \item{\code{.Data}:}{as for the \code{\linkS4class{mpfr}} class, a \code{"list"} of \code{\linkS4class{mpfr1}} numbers.} \item{\code{Dim}:}{of class \code{"integer"}, specifying the array dimension.} \item{\code{Dimnames}:}{of class \code{"list"} and the same length as \code{Dim}, each list component either \code{\link{NULL}} or a \code{\link{character}} vector of length \code{Dim[j]}.} } } \section{Extends}{ Class \code{"mpfrMatrix"} extends \code{"mpfrArray"}, directly. Class \code{"mpfrArray"} extends class \code{"\linkS4class{mpfr}"}, by class "mpfrArray", distance 2; class \code{"\linkS4class{list}"}, by class "mpfrArray", distance 3; class \code{"\linkS4class{vector}"}, by class "mpfrArray", distance 4. } \section{Methods}{ \describe{ \item{Arith}{\code{signature(e1 = "mpfr", e2 = "mpfrArray")}: ... } \item{Arith}{\code{signature(e1 = "numeric", e2 = "mpfrArray")}: ... } \item{Arith}{\code{signature(e1 = "mpfrArray", e2 = "mpfrArray")}: ... } \item{Arith}{\code{signature(e1 = "mpfrArray", e2 = "mpfr")}: ... } \item{Arith}{\code{signature(e1 = "mpfrArray", e2 = "numeric")}: ... } \item{as.vector}{\code{signature(x = "mpfrArray", mode = "missing")}: drops the dimension \sQuote{attribute}, i.e., transforms \code{x} into a simple \code{\linkS4class{mpfr}} vector. This is an inverse of \code{t(.)} or \code{dim(.) <- *} on such a vector.} \item{atan2}{\code{signature(y = "ANY", x = "mpfrArray")}: ... } \item{atan2}{\code{signature(y = "mpfrArray", x = "mpfrArray")}: ... } \item{atan2}{\code{signature(y = "mpfrArray", x = "ANY")}: ... } \item{[<-}{\code{signature(x = "mpfrArray", i = "ANY", j = "ANY", value = "ANY")}: ... } \item{[}{\code{signature(x = "mpfrArray", i = "ANY", j = "ANY", drop = "ANY")}: ... } \item{[}{\code{signature(x = "mpfrArray", i = "ANY", j = "missing", drop = "missing")}: \code{"mpfrArray"}s can be subset (\dQuote{indexed}) as regular \R \code{\link{array}}s.} \item{\%*\%}{\code{signature(x = "mpfr", y = "mpfrMatrix")}: Compute the matrix/vector product \eqn{x y} when the dimensions (\code{\link{dim}}) of \code{x} and \code{y} match. If \code{x} is not a matrix, it is treated as a 1-row or 1-column matrix (aka \dQuote{row vector} or \dQuote{column vector}) depending on which one makes sense, see the documentation of the \pkg{base} function \code{\link[base:matmult]{\%*\%}}.} \item{\%*\%}{\code{signature(x = "mpfr", y = "Mnumber")}: method definition for cases with one \code{\linkS4class{mpfr}} and any \dQuote{number-like} argument are to use MPFR arithmetic as well.} \item{\%*\%}{\code{signature(x = "mpfrMatrix", y = "mpfrMatrix")},} \item{\%*\%}{\code{signature(x = "mpfrMatrix", y = "mpfr")}, etc. Further method definitions with identical semantic.} \item{crossprod}{\code{signature(x = "mpfr", y = "missing")}: Computes \eqn{x'x}, i.e., \code{t(x) \%*\% x}, typically more efficiently.} \item{crossprod}{\code{signature(x = "mpfr", y = "mpfrMatrix")}: Computes \eqn{x'y}, i.e., \code{t(x) \%*\% y}, typically more efficiently.} \item{crossprod}{\code{signature(x = "mpfrMatrix", y = "mpfrMatrix")}: ... } \item{crossprod}{\code{signature(x = "mpfrMatrix", y = "mpfr")}: ... } \item{tcrossprod}{\code{signature(x = "mpfr", y = "missing")}: Computes \eqn{xx'}, i.e., \code{x \%*\% t(x)}, typically more efficiently.} \item{tcrossprod}{\code{signature(x = "mpfrMatrix", y = "mpfrMatrix")}: Computes \eqn{xy'}, i.e., \code{x \%*\% t(y)}, typically more efficiently.} \item{tcrossprod}{\code{signature(x = "mpfrMatrix", y = "mpfr")}: ... } \item{tcrossprod}{\code{signature(x = "mpfr", y = "mpfrMatrix")}: ... } \item{coerce}{\code{signature(from = "mpfrArray", to = "array")}: coerces \code{from} to a \emph{numeric} array of the same dimension.} \item{coerce}{\code{signature(from = "mpfrArray", to = "vector")}: as for standard \code{\link{array}}s, this \dQuote{drops} the \code{dim} (and \code{dimnames}), i.e., returns an \code{\linkS4class{mpfr}} vector.} \item{Compare}{\code{signature(e1 = "mpfr", e2 = "mpfrArray")}: ... } \item{Compare}{\code{signature(e1 = "numeric", e2 = "mpfrArray")}: ... } \item{Compare}{\code{signature(e1 = "mpfrArray", e2 = "mpfr")}: ... } \item{Compare}{\code{signature(e1 = "mpfrArray", e2 = "numeric")}: ... } \item{dim}{\code{signature(x = "mpfrArray")}: ... } \item{dimnames<-}{\code{signature(x = "mpfrArray")}: ... } \item{dimnames}{\code{signature(x = "mpfrArray")}: ... } \item{show}{\code{signature(object = "mpfrArray")}: ... } \item{sign}{\code{signature(x = "mpfrArray")}: ... } \item{norm}{\code{signature(x = "mpfrMatrix", type = "character")}: computes the matrix norm of \code{x}, see \code{\link[base]{norm}} or the one in package \pkg{Matrix}.} \item{t}{\code{signature(x = "mpfrMatrix")}: tranpose the mpfrMatrix.} \item{aperm}{\code{signature(a = "mpfrArray")}: \code{aperm(a, perm)} is a generalization of \code{t(.)} to \emph{perm}ute the dimensions of an mpfrArray; it has the same semantics as the standard \code{\link{aperm}()} method for simple \R \code{\link{array}}s.} } } \author{Martin Maechler} \seealso{ \code{\link{mpfrArray}}, also for more examples. } \examples{ showClass("mpfrMatrix") validObject(mm <- new("mpfrMatrix")) validObject(aa <- new("mpfrArray")) v6 <- mpfr(1:6, 128) m6 <- new("mpfrMatrix", v6, Dim = c(2L, 3L)) validObject(m6) m6 which(m6 == 3, arr.ind = TRUE) # |--> (1, 2) ## Coercion back to "vector": Both of these work: stopifnot(identical(as(m6, "mpfr"), v6), identical(as.vector(m6), v6)) # < but this is a "coincidence" S2 <- m6[,-3] # 2 x 2 S3 <- rbind(m6, c(1:2,10)) ; s3 <- asNumeric(S3) det(S2) str(determinant(S2)) det(S3) stopifnot(all.equal(det(S2), det(asNumeric(S2)), tol=1e-15), all.equal(det(S3), det(s3), tol=1e-15)) ## 2-column matrix indexing and replacement: (sS <- S3[i2 <- cbind(1:2, 2:3)]) stopifnot(identical(asNumeric(sS), s3[i2])) C3 <- S3; c3 <- s3 C3[i2] <- 10:11 c3[i2] <- 10:11 stopifnot(identical(asNumeric(C3), c3)) AA <- new("mpfrArray", as.vector(cbind(S3, -S3)), Dim=c(3L,3:2)) stopifnot(identical(AA[,,1] , S3), identical(AA[,,2] , -S3)) aa <- asNumeric(AA) i3 <- cbind(3:1, 1:3, c(2L, 1:2)) ii3 <- Rmpfr:::.mat2ind(i3, dim(AA), dimnames(AA)) stopifnot(aa[i3] == new("mpfr", getD(AA)[ii3])) stopifnot(identical(aa[i3], asNumeric(AA[i3]))) CA <- AA; ca <- aa ca[i3] <- ca[i3] ^ 3 CA[i3] <- CA[i3] ^ 3 ## scale(): S2. <- scale(S2) stopifnot(all.equal(abs(as.vector(S2.)), rep(sqrt(1/mpfr(2, 128)), 4), tol = 1e-30)) ## norm() : norm(S2) stopifnot(identical(norm(S2), norm(S2, "1")), norm(S2, "I") == 6, norm(S2, "M") == 4, abs(norm(S2, "F") - 5.477225575051661) < 1e-15) } \keyword{classes} Rmpfr/man/sumBinomMpfr.Rd0000644000176200001440000001032413546047111015022 0ustar liggesusers\name{sumBinomMpfr} \alias{sumBinomMpfr} \title{(Alternating) Binomial Sums via Rmpfr} \concept{Rice integral} \concept{Forward Difference} \description{ Compute (alternating) binomial sums via high-precision arithmetic. If \eqn{sBn(f, n) :=}\code{sumBinomMpfr(n, f)}, (default \code{alternating} is true, and \code{n0 = 0}), \deqn{sBn(f,n) = \sum_{k = n0}^n (-1)^(n-k) {n \choose k}\cdot f(k) = \Delta^n f,}{% sBn(f,n) = sum(k = n0:n ; (-1)^(n-k) choose(n,k) * f(k)) = \Delta^n f,} see Details for the \eqn{n}-th forward difference operator \eqn{\Delta^n f}. If \code{alternating} is false, the \eqn{(-1)^(n-k)} factor is dropped (or replaced by \eqn{1}) above. Such sums appear in different contexts and are typically challenging, i.e., currently impossible, to evaluate reliably as soon as \eqn{n} is larger than around \eqn{50--70}. } \usage{ sumBinomMpfr(n, f, n0 = 0, alternating = TRUE, precBits = 256, f.k = f(mpfr(k, precBits=precBits))) } \arguments{ \item{n}{upper summation index (integer).} \item{f}{\code{\link{function}} to be evaluated at \eqn{k} for \code{k in n0:n} (and which must return \emph{one} value per \code{k}).} \item{n0}{lower summation index, typically \code{0} (= default) or \code{1}.} \item{alternating}{logical indicating if the sum is alternating, see below.} \item{precBits}{the number of bits for MPFR precision, see \code{\link{mpfr}}.} \item{f.k}{can be specified instead of \code{f} and \code{precBits}, and must contain the equivalent of its default, \code{f(mpfr(k, precBits=precBits))}.} } \details{ The alternating binomial sum \eqn{sB(f,n) := sumBinom(n, f, n0=0)} is equal to the \eqn{n}-th forward difference operator \eqn{\Delta^n f}, \deqn{sB(f,n) = \Delta^n f,} where \deqn{\Delta^n f = \sum_{k=0}^{n} (-1)^{n-k}{n \choose k}\cdot f(k),}{% Delta^n f = sum(k = n0:n ; (-1)^(n-k) choose(n,k) * f(k)),} is the \eqn{n}-fold iterated forward difference \eqn{\Delta f(x) = f(x+1) - f(x)} (for \eqn{x = 0}). The current implementation might be improved in the future, notably for the case where \eqn{sB(f,n)=}\code{sumBinomMpfr(n, f, *)} is to be computed for a whole sequence \eqn{n = 1,\dots,N}{n = 1,...,N}. } %% Now (2012-05-15) have the first version (hidden) as sumBinomMpfr.v1() \value{ an \code{\linkS4class{mpfr}} number of precision \code{precBits}. \eqn{s}. If \code{alternating} is true (as per default), \deqn{s = \sum_{k = n0}^n (-1)^k {n \choose k}\cdot f(k),}{% s = sum(k = n0:n ; (-1)^k choose(n,k) * f(k)),} if \code{alternating} is false, the \eqn{(-1)^k} factor is dropped (or replaced by \eqn{1}) above. } \references{ Wikipedia (2012) The N\"orlund-Rice integral, \url{https://en.wikipedia.org/wiki/Rice_integral} Flajolet, P. and Sedgewick, R. (1995) Mellin Transforms and Asymptotics: Finite Differences and Rice's Integrals, \emph{Theoretical Computer Science} \bold{144}, 101--124. } \author{Martin Maechler, after conversations with Christophe Dutang.} \seealso{ \code{\link{chooseMpfr}}, \code{\link[gmp]{chooseZ}} from package \pkg{gmp}. } \examples{ ## "naive" R implementation: sumBinom <- function(n, f, n0=0, ...) { k <- n0:n sum( choose(n, k) * (-1)^(n-k) * f(k, ...)) } ## compute sumBinomMpfr(.) for a whole set of 'n' values: sumBin.all <- function(n, f, n0=0, precBits = 256, ...) { N <- length(n) precBits <- rep(precBits, length = N) ll <- lapply(seq_len(N), function(i) sumBinomMpfr(n[i], f, n0=n0, precBits=precBits[i], ...)) sapply(ll, as, "double") } sumBin.all.R <- function(n, f, n0=0, ...) sapply(n, sumBinom, f=f, n0=n0, ...) n.set <- 5:80 system.time(res.R <- sumBin.all.R(n.set, f = sqrt)) ## instantaneous.. system.time(resMpfr <- sumBin.all (n.set, f = sqrt)) ## ~ 0.6 seconds \dontshow{ stopifnot( all.equal(resMpfr[1:10], res.R[1:10], tolerance=1e-12), all.equal(resMpfr[1:20], res.R[1:20], tolerance=1e-9 ), all.equal(resMpfr[1:30], res.R[1:30], tolerance=1e-6 )) } matplot(n.set, cbind(res.R, resMpfr), type = "l", lty=1, ylim = extendrange(resMpfr, f = 0.25), xlab = "n", main = "sumBinomMpfr(n, f = sqrt) vs. R double precision") legend("topleft", leg=c("double prec.", "mpfr"), lty=1, col=1:2, bty = "n") } \keyword{arith} Rmpfr/DESCRIPTION0000644000176200001440000000477615077606366013104 0ustar liggesusersPackage: Rmpfr Title: Interface R to MPFR - Multiple Precision Floating-Point Reliable Version: 1.1-2 VersionNote: Last CRAN: 1.1-1 on 2025-07-18; 1.1-0 on 2025-05-08; 1.0-0 on 2024-11-15 Date: 2025-10-21 Type: Package Authors@R: c(person("Martin","Maechler", role = c("aut","cre"), email = "maechler@stat.math.ethz.ch", comment = c(ORCID="0000-0002-8685-9910")) , person(c("Richard", "M."), "Heiberger", role = "ctb", email="rmh@temple.edu", comment = "formatHex(), *Bin, *Dec") , person(c("John", "C."), "Nash", role = "ctb", email="nashjc@uottawa.ca", comment = "hjkMpfr(), origin of unirootR()") , person(c("Hans", "W."), "Borchers", role = "ctb", email="hwborchers@googlemail.com", comment = "optimizeR(*, \"GoldenRatio\"); origin of hjkMpfr()") , person("Mikael", "Jagan", role = "ctb", comment = c("safer convert.c; configure.ac etc", ORCID = "0000-0002-3542-2938")) ) Description: Arithmetic (via S4 classes and methods) for arbitrary precision floating point numbers, including transcendental ("special") functions. To this end, the package interfaces to the 'LGPL' licensed 'MPFR' (Multiple Precision Floating-Point Reliable) Library which itself is based on the 'GMP' (GNU Multiple Precision) Library. SystemRequirements: gmp (>= 4.2.3), mpfr (>= 3.2.0), pdfcrop (part of TexLive) is required to rebuild the vignettes. SystemRequirementsNote: 'MPFR' (MP Floating-Point Reliable Library, https://www.mpfr.org/) and 'GMP' (GNU Multiple Precision library, https://gmplib.org/), see >> README.md Depends: gmp (>= 0.6-1), R (>= 3.6.0) Imports: stats, utils, methods Suggests: DPQmpfr, MASS, Bessel, polynom, sfsmisc (>= 1.1-14) SuggestsNote: MASS, polynom, sfsmisc: only for vignette; Enhances: dfoptim, pracma, DPQ EnhancesNote: mentioned in Rd xrefs | used in example URL: https://rmpfr.r-forge.r-project.org/ BugReports: https://r-forge.r-project.org/tracker/?group_id=386 License: GPL (>= 2) Encoding: UTF-8 NeedsCompilation: yes Packaged: 2025-10-21 15:11:29 UTC; maechler Author: Martin Maechler [aut, cre] (ORCID: ), Richard M. Heiberger [ctb] (formatHex(), *Bin, *Dec), John C. Nash [ctb] (hjkMpfr(), origin of unirootR()), Hans W. Borchers [ctb] (optimizeR(*, "GoldenRatio"); origin of hjkMpfr()), Mikael Jagan [ctb] (safer convert.c; configure.ac etc, ORCID: ) Maintainer: Martin Maechler Repository: CRAN Date/Publication: 2025-10-27 06:11:02 UTC