Rmpfr/0000755000176200001440000000000014716575412011354 5ustar liggesusersRmpfr/tests/0000755000176200001440000000000014715653116012513 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.R0000644000176200001440000003577014600266076015470 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,]) ## 80.3 {cmath-5, 2009} summary(1000*C2[1,]) ## 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))# .27 system.time(for(i in 1:100) b2 <- B(x1, x2))# .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/MD50000644000176200001440000001236114716575412011667 0ustar liggesusers0b5984091a73dc9f4f47019c39d8860f *ChangeLog 506112b5d87f8c80e57d639791141bcf *DESCRIPTION d370f82e0dc9baba854607898e69dd53 *NAMESPACE d361667e85ddc84312b2723b1fa8ccbe *R/AllClasses.R a9b1cf4ae85149ce3b63dca1fda41645 *R/Arith.R af49ae22a3abb7623dda7f03d3210404 *R/Consts.R 0b59ce51ca091397216461688d2a3e2e *R/Math.R f33439938db1458476c1d0059ab68519 *R/Summary.R 9328dcb3e02ba2059a078c7180cbe938 *R/array.R 11670dafdcbe26fab9803f87fa7ab5be *R/as.R 69a7ec9c3b497dc0b1056ee4acb2d03e *R/formatHex.R ccc6c0f5f2719c193544dfa88222f5f0 *R/gmp-convert.R db13b4c1aa1fe454796ccd137f47df10 *R/hjk.R 9fa5c27a196f7ed45ab20d42796cff0e *R/integrate-Romberg.R d2b8c1d082bc7ef3e987c7c90efebd20 *R/mpfr.R c03fa36a103dafa851e2ba55a80aa9d1 *R/optimizers.R b12d6c7be33015ed3c4bf6f1f4b2fb1c *R/special-fun.R f42559cfe95d168afeac7a8d53b5dfa5 *R/unirootR.R cdd3f87c191a69a297eace37919cb1b1 *R/zzz.R 9af43e4aadaee883c22b38917ce2dc12 *README.md 4f1b7d6b14d0b477476fe22d39efe720 *TODO e674f25f36eb0752e0460058175f4dad *build/partial.rdb 9ede3447f8cafea973e753165b7089fa *build/vignette.rds 2d92b8ce8343ac4b6029d6a1d03059f7 *cleanup ed70fa826c918fc4369b0e84d016904c *configure f454873d082736b6180bb76ced47a93b *configure.ac 9e1c8d825bd0b9cb799e9dea92c672b7 *demo/00Index da3fe1f9afd8af15f7f8c2291231501c *demo/hjkMpfr.R 30777ddb9c9766da729d4acca3a83b3f *inst/NEWS.Rd 587b6767ddb29e687006d8dd425e920f *inst/check-tools.R 167db203ff72ac5de5263a7f99f4c399 *inst/doc/Maechler_useR_2011-abstr.R ca4d6c443c917a2b41766aa538ac5987 *inst/doc/Maechler_useR_2011-abstr.Rnw ac7f620d0926cab9d30be10a2facef96 *inst/doc/Maechler_useR_2011-abstr.pdf 0ca5c84debbabe691d0bb3be74e7c3e3 *inst/doc/Rmpfr-pkg.R e445ed0eb9d6f2cb9b5c22f9c14e6d87 *inst/doc/Rmpfr-pkg.Rnw b823a1f13b9d4f4cd131df69b5ca8dd9 *inst/doc/Rmpfr-pkg.pdf 3291df1b02b765417c0c756cf8a41c7e *inst/doc/log1mexp-note.R 2ee39564c6d2a048c36bdc7ea7e9d8ab *inst/doc/log1mexp-note.Rnw 99ac51dd84adb2c0468cc28acaddb772 *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 85b8f680605b1809d46356347d114bb8 *man/distr-etc.Rd 0b6d3ceccb5aa1640d6a3efba0301094 *man/factorialMpfr.Rd 8b0811229b0f62bf40fd1d358f35a4ad *man/formatHex.Rd c9316ba74127d7d1a8e91b68b2698fc4 *man/formatMpfr.Rd de337497be555732ed4924d166445811 *man/fr_ld_expMpfr.Rd f9bede01ca1128755edcbde06dbeac79 *man/gmp-conversions.Rd a998d1b6dc750347f0728e895ac929ef *man/hjkMpfr.Rd f55782a7f6831b8df45e07a1882f5355 *man/igamma.Rd 24b40df99950fba5e4c18d4058061802 *man/integrateR.Rd 83b62f162e8b73fd4c35e1709ae2db1b *man/is.whole.Rd ae9a6e22a52311b484492e0618994402 *man/log1mexp.Rd b59967ffab6946d1e4808d22a005b967 *man/matmult.Rd cd66d9c746e4fca71c6712f15aa57389 *man/mpfr-class.Rd 2051f31ba43c52eacf2d266ca668621f *man/mpfr-utils.Rd 6957aba10ecb39e988ab534c25842fdb *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 bd69a96bd44202b14949e1e8877da7ae *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 6fff990d99e1480017be2dceeb6268a3 *src/Makevars.in 8b0bc00798e2d4a494e180fb4c79e7df *src/Makevars.win 38a4bfeeb97fdd47207ab1db54d08247 *src/Ops.c a4b655021cc6a376c3465e8d52b8dd42 *src/Rmpfr_utils.h 1d32b2911bd1640c603a10a613a04cf0 *src/Summary.c 06cecf8dbebd8a36734d820d1f4336c9 *src/Syms.h 27c723f73391700193cb9e71cc74fa3b *src/convert.c 2037196bbfd0965135f21a59334759f8 *src/init.c 52d732ad926e6cd9462d9c99192893af *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 77d666f00431b5d675895ecbf589b2fb *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/R/0000755000176200001440000000000014715653036011553 5ustar liggesusersRmpfr/R/as.R0000644000176200001440000003370014600265440012273 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(precBits >= 2, ## libmpfr exits (after good error message) for precBits == 1 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.R0000644000176200001440000003021014547462101012555 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")) 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.R0000644000176200001440000006061314661042021014074 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) ## 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) 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: max(x*log(prob), (size-x)*log1p(-prob)) >= .mpfr_erange("Emax")*log(2)) { 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(!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) ## 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 { C.nx <- chooseMpfr(size, x) 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 (size == Inf) return( dpois(x, lambda=mu, log) ) else 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)) || 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) { prec <- pmax(53, getPrec(shape), getPrec(scale), getPrec(x)) if(!sh.mp) shape <- mpfr(shape, prec) else ## !sc.mp : scale <- mpfr(scale, 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} ## 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, (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 <- 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.R0000644000176200001440000007455314360044651012651 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())) 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.R0000644000176200001440000001555314715213763013734 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) { gmp.numb <- .mpfr_gmp_numbbits() # 32 or 64 if(length(pr <- object@prec) != 1 || is.na(pr) || pr < 2) "invalid 'prec' slot" else if((lex <- length(ex <- object@exp)) != 2 && gmp.numb == 64) "invalid 'exp' slot for 64-bit gmp.numbbits: must have length 2" else if(lex != 1 && gmp.numb == 32) "invalid 'exp' slot for 32-bit gmp.numbbits: 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" 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(gmp.numb == 64) { ## 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.R0000644000176200001440000007701514245753567013036 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) { 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.R0000644000176200001440000001477414600265440014143 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(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/cleanup0000755000176200001440000000010114715653117012717 0ustar liggesusers#! /bin/sh rm -f src/Makevars # as we create it from Makevars.in Rmpfr/demo/0000755000176200001440000000000014715653041012272 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/0000755000176200001440000000000014715653116012140 5ustar liggesusersRmpfr/src/utils.c0000644000176200001440000005355614644765014013464 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_GMP_numb_bits(void) {// for diagnosing return ScalarInteger((int)GMP_NUMB_BITS); } /* 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/convert.c0000644000176200001440000006636014661042021013762 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 GMP_NUMB_BITS == 32 # define R_mpfr_nr_ints nr_limbs # define R_mpfr_exp_size 1 #elif GMP_NUMB_BITS == 64 # define R_mpfr_nr_ints (2*nr_limbs) # define R_mpfr_exp_size 2 #else # error "R <-> C Interface *not* implemented for GMP_NUMB_BITS=" ## GMP_NUMB_BITS #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 GMP_NUMB_BITS == 32 /* ---- 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); } // 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 = (mpft_exp_t) CAST_SIGNED(ex[0], unsigned int, int); } /*------------------------*/ #elif GMP_NUMB_BITS == 64 /* ---- 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); } // 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"); Rboolean maybe_full = asLogical(maybeFull); if(maybe_full == NA_LOGICAL) // cannot happen when called "regularly" error("'maybe.full' must be TRUE or FALSE"); 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/Makevars.win0000644000176200001440000000060111253364553014423 0ustar liggesusers# -*- Makefile -*- # Link with GMP (GNU Multiple Precision) # and with MPFR (Multiple Precision Floating point Reliable) Libraries # # lines below suggested by Uwe Ligges PKG_CPPFLAGS=-I$(LIB_MPFR)/include PKG_LIBS=-L$(LIB_MPFR)/lib -lmpfr -lgmp ## or rather ? # PKG_CPPFLAGS=-I$(LIB_MPFR)/include -I$(LIB_GMP)/include # PKG_LIBS=-L$(LIB_MPFR)/lib -lmpfr -L$(LIB_GMP)/lib -lgmp 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.h0000644000176200001440000001356414644765014014632 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 #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_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.c0000644000176200001440000001107514107223103013233 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_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.in0000644000176200001440000000140213565172775014247 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_CFLAGS=$(CFLAGS) PKG_LIBS=$(PKG_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/NAMESPACE0000644000176200001440000001577614600265440012600 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 ) 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 , .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" , "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" , "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/TODO0000644000176200001440000003257414644765014012056 0ustar liggesusers -*- org -*--> Emacs [Tab] key + [Org] menu; C-c C-o follows links * Very Short Term ** TODO 67) BUG: igamma() [incomplete gamma] always returns 53-bit ??????? ** 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) *** 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 Change Macros to static R_INLINE Functions Tomas K: "Macros were outdated even when I was a CS student .." * 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) BUG: igamma() [incomplete gamma] always returns 53-bit ??????? Rmpfr/configure.ac0000644000176200001440000000430214127016751013631 0ustar liggesusers# autoconf this file --> configure AC_INIT AC_CONFIG_SRCDIR([Rmpfr]) AC_CONFIG_SRCDIR([DESCRIPTION]) 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}" PKG_CPPFLAGS=$CPPFLAGS PKG_CFLAGS=$CFLAGS PKG_LDFLAGS=$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_SUBST(PKG_CPPFLAGS) AC_SUBST(PKG_CFLAGS) AC_SUBST(PKG_LDFLAGS) AC_CONFIG_FILES(src/Makevars) AC_OUTPUT Rmpfr/inst/0000755000176200001440000000000014715653035012326 5ustar liggesusersRmpfr/inst/doc/0000755000176200001440000000000014715653115013072 5ustar liggesusersRmpfr/inst/doc/log1mexp-note.pdf0000644000176200001440000043073014715653116016274 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 5032 /Filter /FlateDecode /N 88 /First 748 >> stream xo㳗yv*,[Yzl6<^eˀE:_Ï?VV|?LɄs5 Vpnsn22z&97s3h*#E"o/PQ#;oߖ m>yq7_"| b\Ãe{s#\|f=bT&YY^T}S{Uߚf̹S|-([7«X].٨o>/C:Xv: L5( |mR Mʼ\b|.{:轠GYGpxojiʺ,hk71 ކbGr06TTG{lj;ϊlV,m|Nq7RVYfEErZ% /Wa ,|>+h/{1]dK`{Z~ޯNT_Eu^tYx`mt)m=2 _W߽=9ߦ31|ϮbYݤ ¡Y$Jަe!\"4LcElc>.nhta$?%]88AQèٸ6U% OU@Gd`ieC y`J (^#f"2|%[%+Xq2V|g_F(N@?$ >8CN2De>HV-Gl+4̮p`'rϮpELBejءW/|ۓr{5.?;ϮWtQ#p'ޥo-Gnz|aHB'"Su lwVJ#Lo@ x廓a)K*tz.X>䳼¦rKPv5al,1ٸ|rJalcCH5E㋳W'6>Ȱ:7ɒ}A 0ԱM-c̢WJўZz$Vv@XL,,;4g?]߬˔i/ShڂUYsֲ GW5DOb^:.^夔jG1wNX!-wAШ7$Zx6de>ԠcEl z^ݩ8+՝0zFyI|Oϥ Ir~;]TgWR:dG9{^W5;foOmNY޳gڕhu;f*Ʋqa,G6H]Q?26`XKa| >OlIi5/42񋐋Iݖٌ-OǕ,Zw$;'3[qgH&+l7=˪-ӷná p&K]-])ճAv uW6#KpU}WT`s0J=D: `o;]Im@D|70%rkzrAoiV|,2(^$.꓍9>x\J~1@tYuٷYbW%'NK h6F=,HRd۬92z[+d(/YZbqƲeN\a®5YEP6،Zb)a˨%@SmS@𵃁G߽58V2dWl5,SPP*؋jw!:}T E[ȦR`QG!-Z߳"e:.mkx>4񁧑*)DlڮVqXl#ZqlK<-yti[ڔp+a"OG߽=Hg=B Um ٍ2_i6I}u<΃sCW.?k"-?l]5o7ʿ WCbĚx 饥Ȓ6#2tv(7`{}XipPU8(m?]{bW/oIc|XQ"s*1Kd{EG9~ځ=嫷+uzN|W*9aj[}"o"Ӿ5kC ِ 3-}G"Cѥ^>x*P۸ao/Ϊv}l WwvI[7Nj~Q0 w,[n=v]Lr07%֥).RAi *\ 826[\~ P\7J5F Mm&UQ R !]`j1ڊ_,P?,U^Dt{o3,d6{ܯ{75oZ Am]Qۚ>̉*?;[Wvkݮ)Fn;>m0Զν*|1ցy-`@^+hXaǨCntJe_;8}!J E@Kgo=H +66^":y6.H6aFj]7ϛa7/מi:+^] <= ǡZrǘ7|w|24,LCDFK 9&niGƝtV$pU+BzM>^F[kQ2$ 6788=9l^MO>Qb\Orwt~>=x0yڨ*5TsS#5M+ a 2XcTxv 0Xh^8{s֌(vdF>"V[3ךh.ɉ6-(>~{vb0U՘t<0<']k_<<^P -Qm~ֺ[ӥ8{5Ql-<#,gz?6/['<38٤ cE:/C;0`ɇ:tWTw +|eBѮIN޿Ͷs[ƨÍ<*< z<#=*G*~i^"V:^²Vg۫l̯(imw7K%<~=~a;4a`cx] );:?x?[iw2_PP:ۻ`> ؁^YL(I pI4Gv(?fɢ9&[g?K[.Fltݧf /4y:4&\<%0zt~H4R<tHC2t80$|p8;ٹRPm>WeZsJoJ@ʴ!:-턩dU* U)ԺnHN<+D*:lNW-M=m<9'PU_uR@x6PZx X/F)`WSԐSDzC/-6aYA'JӔ^&R u:zCO0Z-mM׍-I L&E;\:)gK3txN029!J0"˿Q!ZJ2r!S:Hk͌| V2C#_o .Xv]7Pd[]-]6^WwAf$z8+=f%ί.)nZ4&:>'hJc]> stream GPL Ghostscript 10.02.1 Accuracy, Cancellation Error, R, MPFR, Rmpfr 2024-11-15T15:10:22+01:00 2024-11-15T15:10:22+01:00 LaTeX with hyperref Accurately Computing log(1 - exp(.)) – Assessed by RmpfrMartin Mächler endstream endobj 91 0 obj << /Type /ObjStm /Length 3534 /Filter /FlateDecode /N 87 /First 801 >> stream x[Yo9~_Q3d(A8I1I0ܲ%α~Qn/)-G, Yn뤢р -OA<bWJzD@G@A ʀ6/,h縏t<k, `\Ԁ* QUF"k K.;;p(@$p.x@༵ED d5YKZty%+&U;|T9@Pu4  !x4"i_Fq0묂h!:H2b$wz~<6% p^1A# /xFkc:&=cȳ03i S I |sAs6( pHl7 )1+Xe14SF6gi:z\Sio;q0'ź}slXosE1=jph=eiW#|N-ֵX\0/|H߀wuBb<_V3y]LGG/(VE"(9UJYZ. x_Q%U:/yR%_/|W2k#[88ھ-aJ>_DkoIV>+5d]bpPlo`h^8hY Sbƣ*Kg]lQVQk=648vąl I6W%O2r&r1䍼a|g$/;?qbL?S`,XJOGjWjnK#Qe&S9+93yf|˥\\Oj-=ϐ/^%-[fdz;T2_<~Iο^\V}NOْ>W t#`cV4ט]O緫>flb(ݼ|COO`_TV(a_wXWLumvss zax볳گ{{աĶÝ;;:&Es墩vYX~$-L\| K/YMc+|G\mf*o S\6e͟OvCynd}C܌:#]/ܴ&gvyժ]QA.V^hpb.0uS<:P>OTsJ#9l1H^LNdq 9t펩ntqQje2H&M~O1,D"U" ⷕ^o"[.05hS 9#%9m}OVn?zW.^o%YaRF(Rb/9HX|}da̞~q맫esk9-1}GKt hzcJ'x_][ {D*mQH[be7scB7o  ˑKVW[]pSTt[4jZ4<>}4ˆoFvkօL7뢛Y}׬ 4 De 6@|CPJ?v^[eM`>C:G7!d|ÐN-q"` " a q6\8ƒ51xQz:I} 9ǘ(:PVaLQ/u<QX>wvxeVß6mq3`QXe U"n[7B:!Wb:&Wt rmFTF5&z kr8d9O_p|452Aw miX^1͜lldφm^#8E:Ph Zc)?AЮ_-Aү;Ԙd.i~~ߞTQ.\OX(7DYjTsϋΙƷ]%Ck (<mJFaC ӃÈk$SLAv+Q۴ MFGQ4γ(|8+yc;(@P80zOT^8ܭ'ؒ.Mu4^AGIחk]΅)i5,Kg,Llix;eZ դ)Z s@f;?6t ery <¤R]P: Bp 0t'< F`E6 A>U[ 6jaGkF5X36w:P D$D<_Ԗ |z/8PDS B餆5 ÿKZQbp CSU7Ԍt2ɖٜ|Hg}'ƻ4MULfiiMa@T+:8Z.t׷|z3ɉV;endstream endobj 179 0 obj << /Filter /FlateDecode /Length 5385 >> stream x<]}J1O\DƧTJ9NlեN{]jE\nHW{?w%++=h84}$_gog_Ϟ;/5X3;} Jof^+ f볗Y V\^mbRf}{_\w}7Pcњ_n:m溛C1X >t/Ax)0@r (. Jje'Jy]3> :CMlZaYkMF9V0k\H$bGV1&=ТX?W|UDq8E!66JZ;ŚxbMm:\(nт-#_/ i0-5|sǨPdd xZ총QEl9&d?O&qoR(.m݃b촓(+*s$: x[A.WO2\0OIb^/18肸Yw~JFB|P0E3%] x<҇lތ<3?F+v"}R>'~/ͤ9-#FZ:MUú=a[Pe#ƈ}}6ovŪcѷjl8(]]پ^Dtw͡.3Q5n/ۋH~b80A\MWd!X)i&y;)<.bѐIAv@  {D%we5]N6+ uJ 6>[ŞdרzF RlXY=a5'3OaK҉%碓ܐA#!C ;lhϟLm96ds9IeYjK= ctAk}hK9cŋ&m]k}lID$oVʐB=%h;|bPNܓ )+R(zٿIzoE.;% Q+ yM0ƃ5؂kLϒGfa+ N`ڌj6Hk~Ӳ]sX8iї;2sPp!κ1T۠v~-N5=@ EJ욣R(n!p%*{1X2&'ng26jx{R`S%5E; g]1茴΅ټEI^z\pL4IIiho<&  IXnG]Ԁ 2*R,#˖Yo7Z9ŞEVr@NQ̵hf6Yw9mgA*(vcqz9 q`v#*YGN[ MhV9 Њ_dcQNmB!PJV>I0egb$yHn!l@JZpF>)sū} 1()pFCu 2":ۊ[kźW3 [N/vGAP,HuM]d+MYk͏T 6,4; ShXE:ޞP!J"BMu5 jWe#Ѧ۾C3"4͡x' ѯ!(gsT4[TQPpRס*Q*y]Fjv:fJ>8b &*QoC>˓|tPbu"τg>  D/c2~9>-"MJE(KZTxv[~-9JLo[T,ŤѪL$l܈M?-:f:]#OVqRAΏԑ7t2SOzh-۬xQWՁՇ@Esuc jզXfM%PqN!A$8 DkME ^a6dD#@*ϴiv\5;h؋S@3U5Zf|A3SiH+8!z\)ZI7utsA*Qe%!36T H͏[%}Wd4xccQQ!{@jr)ˆ 6#IgNlٟ#8l´&X5\צʘ&~vD+rIMړ8RySMevZzv.ȃ68\UMF"TU8vhx7jlpSmOw/CJ8Ctz\ȡ}#A tEG!2QC}*˼ %6Nru(Dj)8|YCAۢIAО+uد6כڙe}H~6'`(|c5eIu4&DQ1n\d(Sŵ-1 * I7PȨncO[C{M,Kƌ)/z\ 8ŀfn.>9uxQ9 dyQR !'U껇e aJkXjCB* 7dQ2cl}#KyH=h꣋k:R9b,O>|t:G҅-#*U=HԪ:GnjVkuAGۉ|?$ M4~4C!tr*JfG9#P fZf jPUm1- m]d⮎Z~]kjf.W0{U%&:3Ρ;zͰLS'i rݾ?&6rVKllq27Oݹ&)fYgi%{ JmdFG8\z4{m0''WiBzU`&}ӲjF+F* olu92pˋr\C㞐 0Mħnf+MsΙi_tm^] =yPWu[}}㤎gu@vGWFrj7ӎ>|} Mȡ )08{o\JfSOylKrlB}˒r r>cCs7o>t͞{{WH&놔"pdNDz8۔Uhs$u^׿[1IޤF~Ű'W3ݔ뽮THKݾU*^\7ǺY7?l 9ؤ$A!Eˠ׼ΰCr&QJz=n!wckKHQ9OiN mcOTшUϻKcT --obpЌ7#z\lS]nF8@sF{& ҡʳL}TF'QJ]yd?:W'-ᱷ=nBUw:Kc?mn6]˧NE?,7kr7`lFkJ@_)%,Ĩ?JoABlA}1m%V'X4]_nac:eX,yV>m^^W)F\C:ۧ:v7YlIUTڡ<Һy1O|W,E Mg*4t//UKKZ'W S6L%m5;]w-~NJOʄ7p)]JKf3m=Û4RNi3 O_X3>9 XE'ͮXnJ证̍JFˎ/Entl^.4t{+guպW(5j`$CUS Ϧ^T^X?t$cE\2IyԺ^Z&C AXe;$}~YWWr~߬wOՅ힋*4TEkBry2:|\ųY9ks  }Au@ ^nEU~ARn2+#jL d婴<@|8婪X4endstream endobj 180 0 obj << /Filter /FlateDecode /Length 4384 >> stream x[Io$N6 w ͩcDI))sQefm0n<AFFTˌ1 ||||]q_:3 OzU}wuvq)tVj@*^]ݜd ɮg5ڕ7oftm"0aݬ3slٟ߮p Dpl(l0}>FUhpM(wc2[6g5X~L* J4r> Q_XتP(>SOhw+v<J޶7{HtM9F7-O"`B($G>ht#yl䵜UrPJк>vxi#'ڤEܡoxvHv;$C8:>+xL IWXP\l%^DhPZxFIh7H73lV;Ma<*iyA ;@G>ag:Ny$t洨^At\]׋y/Y أ&Ē\2o) l_lv́Ea5X~5wa'ȫ9X # ){Uyf?>Խd֣01XB նʷqv&ʂtoU|/6$Do(x{i,8T`ZI X?9mI iY/|,H@:'+ =ã"t@ҝ4|-?Q969S0vcmJTYz[nW\@`0% YZ2UMM*٬3l(}Cd[6} .y?GrލBMĜJM6]&ck\̃7VجqV@d>f՛9cE.\ [PQ7:]iovEGvyIߊb[{4ٖ>7- UQkv5x5ܹ7!a=$JJ~gbQSWۏ-fJr2+t_{GJ@'},d66c$sڧYϬv]V J&J;BH󨍒Y6S@Qآl0Dx^MMr܇YgmI;6@BUKiTR֡>G;1΀gh iU'A3I9jlwBh,)GQYiR ҢeǐvR$S*7 8Ev>Kخ]fL'G3%1_B 45|.%Pt2)J !:])Z].nl)%#h Br{cA! =RR}.2j-AxJw9\-s Hf5{Y(gOXi^ (gGBQ h;Qlj#N2} RjzlXf> cP Bi gZc>_WA^ s ngKc/), ,F% 8ɐ>yR*ڮ-) !AwC-+Fd#XX T4EY-SwTL, VNv h&̊(dW3G>+YUR>ZP'V+8,UWH5"r$5o~'!qqc"ʿ89`t'nl-FU銷i8H߉_~^v1j ~2AH˃N(cx +@HWGj\ZC޻+xزa9poRw#fG=HQ/C/'(zGUJ)2L.!a6vX$}=35yuoo%nDO EfS 0N@qlZGqsNpz:v @P0Fj~}R;Qh/>W55@S.FJ ^.F[?7  !H"$<=⪹/}D!h{)*Q]v(.}i̥af..Y)XVƹ4ۇeMZ Zъ٢"\=%ٻj[Zy/{ ddϛ {pvKvkX]9'ݦ>Rlqj^ݽfû7k"gΚn"pjqƛ3W@JQe!I%9YjVvYa_ëM|ž~t(׋ȧ$&T 3JˆDN$RT[tT~엉* ],}{nC;F2΂}: ެDH2>b;͑S>rao2!*4)'-Inyhoכ;XY-u{Ö>Yax>\R2Qna̧kΞ=ټy5Bie7o˸zZwuÚݷw+Y|=0ͮ] A$l}fcfvΚoJf mn15(*aoot6హP4?vraݬIotydpP惎A-Xm Ϥ>Ѩܤ#ab]j~2 #Cw >gGb 7^>׎c jǶ O(j.$ +WEKdfI_S-,v.Ŗ]gnؐ)7(vgُP#]nN4|J!==hTT'{zr3c3#%o;fv"/1OOAq=*+ŹTSÝCiM('qDWnqD:< ѣXb" *@p8*e:\ }Z2烣d@/dnZÂAs1gaaND pj_j7ކ5s,l amw=loak[ "5bJ*aK:I;.}it†~=p_> ʺE~㩆׷Ƨi> stream xXiT׺*P6ĀMrM4*8q852442 _729L6S#2 Hh7z%jBWxx˷Hbw[oZj{{P2J"XJ1ioiS@r^ /u/<HzLY;v|@vw ^:4,O:mg(jܩjj ZGMޢ6R wtjIyS>bj 5ZJ͢S۔+eKQ({j8@)E)%è6QiTm-U6+ݒ)+.L4ckeW1l2CCGz\82hT/\p|ѱ-Ϥ+%[$}NT9Jb@ ]1 zMVtV&V7}5`Pg:v0;L.tr2%%Vԛz ;3*f(ImU'BmqD)Jp+J|I#7B8(دr5aco5]aP=B7ɲ79b-l^NIcKE3j gDs4z/P%q.m[Nh<9aL:5J04c'H>D7&KxtTH1pid*QKafKM9o?*ۀkBSZ>SJ# Ȏ-Xݱr>~2x$'IGox>9Y'EdMc/J0ّDn}!.t;wf{?xbOE {'`2=<qH ~ąwx&beh-ho8c7EZٹzӟB9Ju2緕 PwRp)NLSt{ 쩪mI:t 1Wj%Mp58 y%tDYJBr,+\Q̕PE&Θt idW_ҥ/]i̬]F `d Npdl]oΰ@KZK43oxv#=.-d Mǃp ㎗~J@u_(Bs%m8͙p=$<"l|Ta Wӆ&Nbv;Nvw[H+*Wͼ(Y  [ߞ;/Ǻ?i"~wA #H%tN=( A&F"SӍGm5T%,8֠/wZl*WA"G0jb1ۿ>\[ST+SY+k;^e2sz!wwN ;ATrG[ XoplVvY)T7E4jdPUX P >Ԡ1tiY2z~֤8\&(v} a-hL*D&$'ts@6@TU=`;?B9J_4}P ]Pg &2,ӱ b;(11{62A?mңGu; rOOJ bvmڜ >#jѽْ6W ]"A6[+%R}&\4t@RVV!'s"F?214{d$'Fd$[CA&$CJX[M%,<,Fw߻u!A f7΍&Gh,JԽCr\ qz9> zJьÞ]KoR,*W+VA,Y" lcKxCƍIƒsf~=QƚߐJFWM|  ,۬>) v1]wY)лsA61 &̪4 'Ƥq"Qp,dT[wh(7甘K!$+F\]oX<OXU{ YI\%M=CE.TnoiVxAp N9(*%ISZe'q#L~-`EHT-"!@]l/~{h+q9v[Y]m\3!AQpx#<s~ј\9jʄ$F{(Ce1YgqAj\?sxoQ?Bpt%8̣Bq`Z;"\"/ͯw[m[ůפ>cdVlYE739}ޭ5ou < 'qiq=f=؎nm[3}n773K'W^ؼx͉3 k }GDw qL}z ٓ ǸM[P% x!p25h-W?#'xQ1Ǻʷ}0=dq>]eȉNþd$QB#4Ck^%YI@nmOϭz g2Id~]I(GFRb aٔbh:/O [Z 9BI^5Xb35o*i!KSO3\$cE %8;mM1;h2+moOQF'endstream endobj 182 0 obj << /Filter /FlateDecode /Length 221 >> stream x]An! E>7p#!oM`D, 2YxHñU m _Kl|]n- T1 _aؿ}PEN> h^lDVrfpZKK4m9A4Hഡ =$ ˉDe q =Cag ZDFOֻ 9zsWnqY!i/ X]Kqmendstream endobj 183 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1006 >> stream x_L[e-*6{ID!$h&l,S6Q!vRZ?_-mm"Kàqa[UFE'L'_'oƷy8< k+~|5*ԌP3Zf[dGK!Q41 q8t joiڸJժTqt<>܎ޞQPqDp')È^ &Ϛ4D08O]OT" 3mgqjqY\^q3 /$N? |A~L`f.eymO qmgƭgt1#= |MV5z-lzړAP{s$r TqCي/[NjX|0qm:Yj5$p^fL,@"Hǜ@fٴ|bvFd=*Ÿ|?ޫgE^:P )La0 P1*Bg5nW0b RZE=xQ|Hm^=v|Hj_W߹"P.6&:+Yo.ܲxF<0$'%!%&/5fJZh%di'J|^!o;L.p` p |A&8ޠEH |L,J3E IaOJ$~n$/endstream endobj 184 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 710 >> stream xukHSqgsY;RYET (.^벚8+2D˵׎d5HŬv)"Nԇ!Fj?XT< Q0ik啗ڳe{3󬻫J +xܤԊqHRʊʒ2B6M$, +# QdYDd&!#jpj0HvYG]:?.ֆ=Μ*vKf+-\X ZDCZRl>*L.N7oY9<:ו[wCkhA` H<D2tS.l/tܣ,屢O[@NgtMb.^r5@ )&Q +'$/P+M7Z9oze-io`4,ᘷMB]Cm Sv^: $DENhLqWDY uƝՕ`#'As^_TC!!nJ2k`-4Tyx Rl>da Y>G0r |䛭ҵadqKiRrϩ<8Bp~\"`%l-oPWmPZs^\m0UÞ8a6VHQl.W,67onji9wV&+cBendstream endobj 185 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7866 >> stream xzw|WȲ5C3AX2&zKXj(cz1{/ؖlIG{;'RLH dJBBΈwy#n~\iy9y3#(Dh _71G q  'ktBW~C;=qX=(+f~NAs]^E.\m;\W\ẅ́' 7~>_-vrdmlxiAԠAg|!ӆX_  :^.##>VEr.#AI!?*"zZg|_LHkxz]d6UAv45u·n0}{!0KNBeh7 7Q vW3[#5 p x"0 6n_FWIfz)]0 lͯW\jGb^Z%>* xl1cVB?mUxSp$"9!c߫ZUAZsL̑:V2L9x͡\p(\hS.-[`9x2ONByH^r[j1lȈU&^%A 0K=xO=P6^2ƀ6B00. uJ %rfnkX{l8(R2#[N$cp N*dTgLV8,(+XG~pf^lVoq^&tCgiͫzɽIw',ŔJ ^k{8 ģ{3A*Ry,"F2A!<d( 5εIEY$Aʨ4(7S;=UKu!>Z`W8Lup(.S4b_$Ҷø1,2 U+ 1ԡ |^$A[rf S^Se-1ډtzL0*0z.Ahv/27rZ}x2eŖZaNدͣ˶ 8mYk0߀4hޛfWzo?e?bRpn7;*a`q)$Tfc0ĩ 9Nv%rkfeσsL}[h6rɃ϶MA\,MOHzV.`|Ujͧ1 {͜M>k{LuNO&"UDAGARNPR`,.9vP_ ҇>TT0c / 65$}O-v8&(+AcqfC~6h%=s|S!x2Hld)LaBiHV_uNj-KH,9 7}{a/|Z3OW YY}ާE3}LM8B/ fMJ9|c4 ЎUa4#XÍJv{Nqڤx7H})KR-JKӳȴw@q_^h/y*;Lx1R!M,>ƛ>t>'" AB2k5y lbD_҇<LPcL΃R=j_f!wڏ [:_L] ƁI@߇[\Vs@ s ;DR;'tGf 3.m'pL0FXFχK\G$|/)ΔZ]l0J Ao?Ѐ.9v4R ڔ\ҔUMP /u4MoFɹ`kD;C\mNt"+bL""A iLUy`Q_+yFT#( o1;^G+,l&?B/ҨSqfhjڴp0Sn\[UY]\Z\ɠ?S ѳ[Ǫkj63z꽠K-.YUn]ZE>.g #fp]^ts+NIJ;)!yz ̓ǿ6(y:P VCӧ@D'&rBW?Kq6 R qJ߭"#5Lr3z4lDCjHؽwъJaaӁ:_} jce>Y4R*h)ʅfۚ,hEc3{v{M۲12Of,tłuF3ank*`mUS&(fН069Y!³ݴG.}֒~(|i!1';C4@\/cjF{߭0 Y˞)7sM0 y?/ ^'z9%[ F('>:%KABW]Jz2@D1iB20$<4׵إgVp8G^y鸡O%GFVw&ܕ 㰋<; ^6`V{'oOf]{իܵ_eë+Kv5[,,yQƂjZDFIĿ gZ%B i8X]LIpJh0ШشlP)35n CUBk4} MA"2KNRa.Ḧ́t!/tʱ^^"DrLM&8Xd鿔40(n jA2&J8lSrO+8B^)J/%4T=M"'(|pOEfg"Abئ [Weڳk{NA=4]s@MUtPZ0Zj:iI'Ut< rP T_/ ܋d>U#hȊ33ɇpÏ [lgB˳ K4&'4:n1cwHhkef=Xu$[IOaHARNeM`e[UZileGR'ޕ2'<2' G88]rRL^p{\|p%n34KоwRZխ~w\s2G0@R ALHaxUMAib[xGp]9[ky_4FcW~{#Xoay|&q0` r\q`ya9By\>ϝYZ-D CEq[7k8L}G͝fOK*vW7l|i-~o_[ͭ^K @agj EM%pƠrUÞb`Xg5@d51Qyq%C(9w J f<<,2XTeunfy!*k"_5gݛ=~&- Ym>F{1zYAhCE׮зD}I38jx̖XCNf Xc~Jyy}ʒ{7. '"IG/e<LWmχtBh{{ߓa{?F7** JrD2(\)XF2DT"?Q>(yS[Y Bo^֤4{10K^E/3Cn^*V ?˫B*}wSZm:&wy_qj.R!o&^bqSpԅLvM <PqmK㒸+|k%N7`Y7T9)>JڝT,09fOvt5AsFۜa0dpԺ^m`*{!/hqfm䂚&#DHgiӟvM09|b*#K#ל?w8u :YI% lL:SX+E|PPá*![Wja+37:} (O!,lSɷM5gv.xaw?QdDiii,|oXP3W'n#SJQ1q}"?ȏ C´a}>o;khlH|@/hu2]A T]:)wJRDP^wD>Lz>L\|sHM݆ۭ S)>S4NmO︨ʰEY|&P: j?יѹafSӱam͙CXeCBm݋54˔iJjbOkӒTl' @ a(ؔ,є"sޡ"GHH0SS_ lʌ,f `;, v ޺-p̂'>`3&>o]"=i-SL2 'd9GGqY-[G4gs1&egEUqq-vpug6$wYovan#;'"mptpYW]YM7LzDNI)2s~PQ_QcXtSr,37j.<yxn] R!Ҫq]^J $&0R^nF =dĞCz QƃCp0;NiS\ľB%-e3jy,֑Ho}a!1`J31Md&/8ϯ".kwX1 94z6GEg/i{vSg46or,Q&Pf/C[/rXuWMS@s.͕3g2as=ai}aIG4ܽY~wqexxemgIa~#G3?r}5 f0oʹ4iy*@fM\훰u)oQw޺+c8uVG&(eU!Qʰ 3uѦ>Eǒ[Rp#pP%'#p"A&Š )Tʡc A>Or:RGK# kI%P*+(RYm_vuW ?{Ƈ*['nAA0C]6dGqQ k] w)`]E\UtqR3Hc\.V .ʨ*xtzqڌO/]Tylb2SՓK+\߯/)YN"Þ <8'ś$I&0FgawRL1[K&4q8Oz/TS<% pcәe?^qw{3; y\'oj8ߌ1y b8乂f`P-jX`v[q#AY\= tj}%&̨*-khC翢_IMrn+a)va<0t%Cϒq@AAe!U|ùpe%?:^O68MLϘFqb 5@H`qÖpOS ZCIx8Dp1KH,"JK$:Q/mkXhqfO̥)SB^,*NVB־CJ9wؒl9tYK$!5J:eĺH?YG,) ?=;3dFF/~%a𡶰Z{/7KzCQ3 $A]-̐o?|q3ݚUPH#ū(\zNRsx9(h1,!EH3PEunf,ijV䯶)nf97y 3RkbWn\9̀yꅻFu<܅2d*.gYZ"KftX$Fr> z;1ڜFpcx8)zd h/mn,}`|g{d-''b~李v7>V,y,7is /{G#w}tosD _j9vqі`[Ya6H%A>I:oIۼeFUɼ2 ~;c6aJΝ_8؇B%x9.o%En&&N'm ~GD+CIt=0,AS @XqY3%ktI faߖĶW< vW$F z!*A @7YٻufѫEj=YmL)ƭɅԻf$鴖H)?`3rWU ]̐"ik>ٿs 5 /',;_u_ߵ`eXhе+E/Ouendstream endobj 186 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2413 >> stream x{PSWo{mh{#]@mVlX]QX^byB$ !7J*>ZK][YKwmbWk[wa'>ݙי339WBQo)\is*eks2QxK۽ GQA_XCaM_:m#fϡ0*zZLͤP(E *b)OjGS$%( N H~'q=V.}B*~m3ƏgUv)k>RM4- ѫB6 *s[ z4(MJ"3d!4NCɼ ,,0YL^V ЯL\̜Z]C Gߞj+*8  {L$ڠֲ*)AMrlȡ((*(;Cvgm$J%ʝc#xyD*~[dGܑ"$H EzaϨ2%s;zzutvoFh(@@=@NY*Iψ$+%`;@Rt;3xBa.}l%HoIKx%s[EZēl6*B {]{kɶȕ`7ԩp>.Ȯ++jq&~]cf}ZG(;1C̡@Q dCfeAR<>tL GzFN1#fo4X8>>w{KSi7]= iqAȁ\hԃl` ,F3y$"]@18&Ik9/$jW:hL`rL1H\ qb%flX1 'KNڠtln~n9^y4% ٝt|#-B2~=Ba3Jap;fq'+˾p]H]$BR ceP]U %4>cgճ=G<.ID>w%Umn.r&-'O൷",S-IjM&Pǃ> *:Һt^=@·"\L;Ξ_$3bFG{}ׁ2P 쉳YTM-ao4Ln֤1A_{V!BY-iy)-9v{6'"<@<7ؑk4xrg,Cg_v^)i(y ;_2G>Q70nk W 2=fjT-Aoo 5endstream endobj 187 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2036 >> stream xe{PTﲸ^-f4H3fc[EcWD>@@XpAv}޽gs(*c&%1ii&5meJgI:N>3|~KMD"3 +Oyӡ3š'3o7-41&=OcfrT+e(./)=ccA,;vanl{#UX)a)Kn)Y)CUH%'$˟Yh }1H6fM=|(?Fk-&@7RDEQu@g#cWP ?:5KG_S꽢pꋍچ\ @ylm^QKoyBhU%׆M`G8]qo@弜#t]7(Un8EԎf0*4E„7%|~]1GCGf^.8vXA=^Dfjh\ 6).햓 o6@c%`6M _ȐlphZO B7p3A:mȇ(#e aL_MY1K> O.s^iм[|pa!l־0ۗ: \e;z#BC W@xF Bmk-ϢWHB}zej!S>46(6 CA :# 씖d b9:7!A/A j5.%C!~ww%-gI;fL2,5Tݮn|C 9ݣ G2 PP&zS%:1!Iak ~mntw$ |<ܢS5j44V\X!d un{v)tt&BB)-PZ7'5T^t~1FM3b1}W[9CC1m>S:vu톳6ݒd0#g$;H틺o5P:;sJMɉQ#S[:*oݑݓ,+ ξnzX4n膘X9.&|3{<'-"1<[ rFh˺O.HL!Kن۹wP2|OA^ gUB(~ThO t?5zyR8Z3A\{{ 3e:ldxmKIx rx9^X9k h;X„6Pf X² l >H!h< (,@n0 &5l!yNp.pBY$7L,_'P=/Ә1'B81:\*VTU܁q8MT(Ha3~͉̉Ii\թTTJe*<-hk4։y4b4!_9(%z ͓xyf qa=;&W}!Rn+Eh;ѤV i일}hC'7)-JIuPP5Bfx( \#,/JԸi2WQ!{_GhbwowF ܎V Op,Bg9 rGUi+8aagęa:?endstream endobj 188 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5421 >> stream xXy\WD,Wh$.1h+(. , pMfW\\5Ii$fDƌ32y~MWVݺs27d2͊+ޜ2uW}$R*a{F>L6 A{/Q99wDxܹ2jת{]}>홳fLmd79uZ[5ZMKR㨵xʍZG^6PE&jZLMPK7('j)rQ.[rj:AVQ#(%eGSHʂDDYR/Ss!Pj>eEYS0ʆXj8Aq3JFS1$%;a6,o3-,tbNm!a|eH9CZj N _zۑ:gl0h᷹ኸoGxP9ZLR)(ڕ؏;TxJ jY=~R0*U%fC DCn2N 1L@O7KΠXx?ʄti27rĎ?; n۟Et )O5 @ csDD %;Et X8A:=G8.Kl[Ϟ/Z.EϼzI=+*ـdDsh311'_%6i"OЖw&t\p?^vӫ.Sx+ ?1\ėD%k'iKYO-><1x,n{m;%4BVp1a˒yN7ܺ-s +b("ߚ{x^"TukGIdbMIFbO0zD)JRzץ(*oWNPCPU?}%zl# P TV7M>| Z F[ڀ~$f5 0D𭒝"EKgn\?`?Y׀Nta1]bk0h"G}G8)USUx˞8J}k|(0\ 8Sd]9feʯZ(Tz'^7o}utX7c0m';N8Yj&N Z=nCZlcfGOCn7VJ(yB3ϸRidi঻I.JpdP?h"# o[4 Cz=QAT@%ؗC5D>L7n3"y#C ʅvz9kN頋9y%!Rv~I7YvBy%ˤ++4SsBf^^FqfAgoh% ʠZ!SUu&WDѢtM^ٙ<+n},, )ik@FF"s$Xo tikgn)u:~xdC4 doBH-rđ+=if=gzLpyLVf%4ӑW-}a T -բ - Gi$adN}whE-zzv͟[0~1G'˟ܝC!TA&{lHP pމ$KEg[$ 8DVAbMd]tMJ'92>N)OL*Iv/}Y `z;FŰIn^itֱ6LųFE8 + iEn!]riʸ@HOS'1[3?n@< Bwƛc8&!Ǣ- ~)E, :w|ف:w(j)K5/i `¯=a6!xqJLdSӰ0-'FZ`xJ`+*aN~lZ<8CQ*qˊ9Z;;)'0̜o1<Lq&?zA.b(ڸ5y7R5lȄRCaobM~FeSdMW@0}IY;TڷS"0I;ޯolU^=r4oslZW׺Awȥ$s_VmwP:MVH5{~i?Dk2h\ѝZK{}aaAʩU .vlٽҮ^E&F$a%#8te9"2 0X l+urhwZ~1H9]|҇t^a6^.9Kp@׏/qJQMh5 ٬Nw>=/oWKEGF^ƅ> .\m!L O\sQɎhZ9gZRFNZ8c{oIʨ脰.V2lҰ4aU8?gg6z%t"@~ $Cl1Î+N_v87?ةOhj,*[Liua@9aݎSyZ}E2i"ED} E?&llܲcm썱?M^h *x@d>3Om/o`sgR "ƉrTc,p:@~yÆ.C=acXƓ'Gk/P^^2:'Gtk 7``{o%./SϘ]APP/A6$aҧ!rJxO ^gr8x Twj.rVG$0/܉Mn1]K:bɣ+& hϪhߤ?+"!,+;_Vv'Y> B $4G?ܔh։8`{/pD%{JuӺن Q|1=8씔ddBuv^'ā %$=P78Dp1]5_g>åq(BNEB"0>!͘Ki!{1Zm)--h䳱'"å1lln"V_OP\mK +?3dsgE0p _ ޿3?r+=E+Ot8ŝ [6v&Ϻt xŠUՉ"Y|C>D.N$q3PBߛfΕɰyNeeg@)SYRG-hhysn\g^ot|z!TYyW^b#F[Fw$s5o>pmSO.陕Tu*Pv(pgp3ZĔXaBK+k [?wX=\h~,_ !$P8ן!{glNVfBJ ^ͼ88~P+Ъwp!1.皿=8 Ogp~[1(;l4Fry%IYd7F~fA s "8l'v$ >f&kkˮ8CO$ή/.*ٗ$O)kU}OVWkj4ե ))9Bmé#<=/s`*dvAQ}~!TtmԵ69^Zr|8~>cG0du );UDVB C2r&>14Lb~5p ;c.K_r A 8`:R8_o 'WU qN,o?z^&(2(2=7vwݾu;ߜ6Z0 U\RM≿\G 5e. <cBhX!&cXniBhEa &?Nk9î#;Cv7f5+FOL5)*m~ _+{U8_cc獶|7~Soa1);F2Ǹ U=4$ML2OSRt:@}dITEUnIQ_8`'dgD<"ʥ@᪱$f|tC %=FM"?b Ԍo^RلZ9cY֟+c%Y*|jaW S h84w 2.'xeWd BQendstream endobj 189 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 201 >> stream xALMSans10-RegularJ  ,R3TvZҋ#J2PwDKP $$PDuPW  To MPendstream endobj 190 0 obj << /Filter /FlateDecode /Length 183 >> stream x]O1 y? KthU;bA }tpb^1.yq/(CeSL*+fn6? pw;x*PK"xXumMczD Q F<6[mQַPc[3Ԩ*C@6NM|nb(vM">OK*ѳ/#_0endstream endobj 191 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1077 >> stream xmmLSwᅲqX/ #dnoŗFe '. *B)-sm~-ds| Kfd3˲e攱mߞ$?RtclYaQQr)dM߰;˝3 =KF=a)<+ţ4җjQ;'ܵN{MR*G,?f:p̹lt٪nLG}6b?5UsUq\ڢk8a޶c~`2S0YY;P1. 0ttټeL[8)- aݔ/ ,czua16Њq . A;kfZ}u[ɴe墍@f \:3Tq iqd@"j'x합 x†G:dh?ʦ+(tQ(P$˲B;hGU\MŌi>'IλW= 'JSTl2E-&"n'n'}nt#+ko# }b\Qeh56P)N-.0~tVVs֧(pU%rC92SQ̟6 4ĸM축(R= ׍ZDOi^{7|4 P?c=p٘Ch%*Lkb8\97M 'R&nvh|ӵcOiJx Vr)8!bk/{c֋Ӭa ژ 6&DŽ&pƌi}N{Ұ/ZkܟZ(u& ԩʐ!U4=qsD65gz`G܅E2oI"K bo%U0;,%4~ȅquy|67RRč3 z߼j$bxn4 (ؔJ'HAVI˼f`2p. oL[ٮb!5u4m|1-~A7ةvPgeMJ%endstream endobj 192 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1020 >> stream xmkL[uiFvYFhB")۔XqJ7tRR-k 3Fc)3Mԡ%d5 }|x޼/I8I2IJ3Ge⚳{Kq:5iol$.$F?y/yy˧[r AIb/API% 2@#(|=@s>yCLR<8sʵ:5)y̬& 7Jn[g0uuR},= }ಸ,|bl{ |mZS>Ofk' C+(U^nc;>hD+1RD ?f+acA5ri?ap%M5NhwQiXWz܍UhAu:}ƶp4b)bwtsR5- ϐ> stream x5}TSoɽH%Ev\ v]9@ZmÊT]K@4!%$  `Ph)˦;@کK/;p:?9L ~aa΂;#aO$ X'!>)y:…؜w$;cbW[ [m~a B1 Fb/bRlA&Z8vQ8!DңFYm#鼃 F; ["Ϭ(/A_=1qkwoo)u{m*,u@;VSɼ룾N\cq|U7q;pVJ(료..]C1*Y@ XN 0OJKQOU,l"X<[ot8ɠ0rpHZ4X3aH~:oJa8 xo,3)ǽf+e8'X\[X lv潈;8`H3r3 By&p Z ^k½5㔓 }u)_1{%.U9BȝFFVEπp|sD9n2!,c,6T;#0EpTr1ZbGL Q߃'ԒYddd890x ]9ڊ7<]  |tvEn+$ÎFҢB L)ᥠ;Rk>Tklg'.9[ 3n-(R{~*A2f`-hP$f irbh!=nnS+ ԆpP< $mѓm?sЧwwk:^/by1$"3? 4>;}&V 2ԹEiy roG3\nЍfE鰍?$!M3 fɤg*RBqݾLlSzX 8JDd\RyLKi+8Z.-i +F_/nQpƊR 4vp*P(NP\Sȏv'y=랐Ӡ)\_f3x 3 Fr(?|;bW6)$CnK9G0pQ?f]+t2G-,w -!%ã6/ m*3+u_4r B1[h*O.1>У~~JgLdWޕ*zuv]ɟ~E#{;=q>"51+wt4vӤ|`;ok\.мV8Z> stream xXy\Sg־!r)(א`u׺֥Rn-uWEd¾ BBpKXd.eQXնXZ[;qZZ;ewA̴3}99s+!F8duC}>?0V%8iw@Rp< ]Ϗ&ϼW¶G,Z*nuož~_*tN?̚3wsOSB‹xLl Mfb:Al%Ob;*M,'f+\5b,XK#^'܉xBA#FND(F`ĉxց#Ura;G:NuLsL"[ ّ+F;=t{T3rO\]pgf9Bǹ/rDyGo<:ț%1|"4yv?@)t\n$>## Tchu\ -9O7&PylSv)\uyzx1\*0T#u)Pmɶi(PǚTD?1 bT]:H0&C}R!!+f&OcS+bdoF ߹3-pdAܬZ돽S g5|_q+.%G3m^'>93Ux dm_Ӧm{ Osӓ[9osl h4 9Ar|wL|Eh6LPFqzTyۓ C"p}zIomV Tzn%ݰijR*+@%6JE/A;%hD`É8a6/J2 v@8&ZEHH535Ol&Q GM3<[cAfZEuA)rr<ȃ\ TTk6SGˈXD IR!|`Vqj~,iU#u۬PzSl]v(=YU <][ Z__qNk̅fPp^,+97?`dn(xHgp鳱Y1 fTNn$ DorCAr8]b! 3Y%\0>Bu)b({-,M1x9?+B+*ϷfU- <ۅ[v9#dܐHi`[` tȓ3w6,]H-+iemMw^? 6^ ~4Ymć_:e/beuO._Ueem];v5390TGz^"yB!֎EEz>67ol>/JXa]/LxHjtk^V,.=OoX U>^WLNL1z}(yuZh04eB>1YQ zMjJ(zmjc;Ü(KbCm='V1S+wEDCjX uj9z'$x:FG|:%좠 %GKA;m1ڕU,dWܰv%zm nNX>fZUE svORGw+vM 0© C d&353m2*TQF!,8X{Ew@ R(a+WG$r&>hmWP?)§-f*᥂֋&;jYg4]4Jf}bbCV,<9WG(2!,8ȿгx x ݟ=v&p2KS1@$j,NDdν4AAZ=']'L2<毓ѨO:+Jk(f*#`?phƼG3Wٮ? ЕsHeC+H\5 S9 ^XK"HsCq{\BBi/dwM:(ĪS"QbI&AwR(Erِ %[Z'b.⡾4L.Gʥg}7쩍i >j8m4:DVfCnh,q rA.GT)Wq2IY%v8|xFD/8(!uCL\d2-˪/gUE4G!G{hG;<$5Dёeme51܎v=93 2dM,?MKd*yq:duih>ZW(4;I>,*;$ZG9xO-Z{j-Ju;}%4KYY2 b#*=s[K( Jk$^n=\ ciAE ~% Gblůxq|oVk^/-q;i];N]{?3HI m!W nD:ca5CxoO b6^xq|0/#K*w$L,5Z JE1b?hX\0gշuWY*XM ^ZKt/͜$6qj9FR=]4ZDruB6!Bް!O d#|"""" Xd]R8ѺtKO3v '|u!^Vߒ  6 B'̪=]h|E@rcwRz tvۅQ ДJD& 6~xDMn%D!9*&dj5^7}PCi2͐MggXY"yMo[SYmp~vx q/}2,CN{k<ͮG^h\VIʢJWĒM艀Gg&Oa2+Ж,˯7G Rt eOjIO@8+݂x?$͙$}@4zAϕzC0 8P]d7!h4:mcff@MV'VVlxi v4Ŏj*~K34I٣ĕ/"I᥏P&E~&G-{CV\p' ؟|3_9w* 1졲$&ޘ;x)áȁUJ69]+&[JGZJ!N]G=cDH)zRVm dpI>>\_ЧYR&KwY{j<އ^{| WV^q|%5 B(9>8 K\/UG_+RUw>Y[if0E* z Գl =*w/9v|-pR敒]@wߠSO=Dͼ]1hΜmJC&[s$f-Jo׈CIBlkIv, j!YUf>i*c@6\ RK~za C-/;27]b`܀%͘~lԆ;QL!wH;#Geh`1W'rѩTs|U*-iL}޷6YJ +ȩ$yQӈ#&ɘc4Zuv&e-|endstream endobj 195 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4210 >> stream xXiT׶DD᮪D})qFA#84 B-2 nFedP& 4jpј+ziUN}VPf(Ba10 pژ^ZM[e's0K%XP.YSA[joؼS+.[&M:mz#>=fgOHQSN3ZN ZAPHj%VS1|ʞZ@-Q)sj15L9RK@j5BEQ<՛RVT?ʚK&CFVqfC f ̫9Q0n{rB ?'}R,׾Q}Y oiellS=^FSe{.l[K@|)RjAo\ &>O, nA[y* ՂPc̽W]o2WpĆ.GU-Mmd trhZC<ӱ8NΒ-{LW߀OkMs[ɳ+7k~nd:j6\ǝC--9!< Sm?J㼑+$Aī✄RAD̉ĚXfh5Zs3NvvvN=9NU"^ܾAeQ@}&%fn"yu]TZo/w4n; *_B0w/{|b_ ?eQ ar6Z$] ~Grrⱶ,*c,b_{MYN)M"8ZjVJIG*R=هVyBD}=:ExDi0ƺjz}WU÷&4vm@HhWm枃BHɖ'd+ql%!.kj{#1Htш@؇f?z{R|2~0x H RZӺ 3bVӮt𚈂*D$ڀjZCroM)}Q635?5Ɂ#cATB_hŽ]gӏ tm ' Lx+OQK݋/Eفh 4\CPMnNF(=o," W( ;-ZvA; Ѻ~IZ`Bk8Qd\[̘HDO}K 'c/Qɖw? ͶLgTUXTz໇4-EP0{Q֊ JJٵT:H J3]#TP=ͦKd(.culb Q[rK$ѫ5xT ȣ (A͐{C!1)|P%p ,Z+aZɖuj{ #G/={uaN@ɶ|eJdsRM =wgB퐎U80pZC76=ֆc;;MxTP&Ss @tv/ʠ}Yd(CƛӺ6'< ypȇ:䲈DEG+Pp"=eD_%\Ue D H=5՞N ӺV׮ɖtM _(e *b}6j;hcx}&{`&/t~N E I<`**n72w)2XcO}OFLMQ]Ѳ*z4-t/u(G"6O=Ա:G&uY?}kWo]:$$]ƾ=̺=:=x!%XW LayNHe'/e(9~(ٲt?Wv ݰ3@d{3fD>!V 80yM@L YT,~>͞(KA"DܵA*MˬWVR&2\(ٛcH.L Dlܸjӧ7s8S5Ogz@%0zD'Ny] ]PB;MʕlWr+` os~+h e|Tm@ib L?͓S֮ au&=nePT̰/J" t`X ~ /*ݡ!V|,)4_Mk-ٲ;] hI+L!p - , ,-4VF(>sola8&Fn^{Rg{Qĉk5OݒL*Fm]SCR!p vd֮`تᅫ|yAIIyIEޝރp$s߁ }dڞ<(pQou/mx|io&ǯE]oiɀ[[>} ic˶tTyQMY 7S#@(3Um)h HYؖ7ȓHUl@'o~0Op&D/[8ɖ*r/^޾y\=i1٧bCiiY{urZ~W5k!#ːwRRË#wxN03T7&RCM. lwTy9W8b(3SQ \‚deLKq>*9IOrlr(٭K ._=יSKb9i ٛsWLFphϳNNsmCEKγ˧/9囯/=~ri ZvD) oxhBṄM!x4;vvߑ>_LQ`MMKM|՗FGlYW4~J~}nUf^?v |~6)w4[dYEVe%W_ TWTk}g%9by'6}D,U-w'}Y%ۊzU)d5<5u-LgA@F{A4Od: 4#k:9VFGA^Lzlx3 )K5i9|:#-=EAS}:5ṙ/sF_2~`*ҋ:c_P`_WZjMK&htY;a'0;A}nq;b M(}xyOPb J|S]4yl⫩06U-VX,1ۊ8 U:4Wtv ug=^JYP4"w[HlDLO] ~Ph, ;{d cJJ9/pt3b> &d-F~n6G93g:avm$)V N 淚M.2.6j'oK [eME|gTׄz)G3/֙nEwe#\UaAyu--kR݊oɸW9h-%/.*ܕV̍ćQ= ےvy7ߨ<+_d٩'LHN!z/ x+*:[3sR h!-VZn2S {,-)@endstream endobj 196 0 obj << /Filter /FlateDecode /Length 1201 >> stream xVMDNc{gD6R Tk+X#٪ hl(>R>Ț~^k<:|e?Zd +|qE έuv /ʮVH)K/~_2a+`IKv0Kϋ\4n)_\gMV(BjtƄK8|*'񿰤 ] 5ia +/I;hpӮ=$HW蕀+D!+#lfXqEx;EqܙQ|) N]/՗NWmlG4~G^K3 WI]`S q鑸cm.@ʥU\*v.ip~~>P$*\V^ēkV(DH" e9C¶G" Ր}B Wb!q ?ΟeFwW_Z>P l6~c[5=ֳV*l̈! [1A 7fφ>যtD7B>) J/rlctB|ܜRH$푆1*챴.!]}"`b4>x蝂mo, 9Z>qK謞=?cTpka@,\MglKHêyWuLzMjq<ܴ] Ze D@E6%((c-!UֻC_5먄@D WY; 3IP = ^BW0xœ@=*Ntr\$d+Bͱ쫡pNq[ WA|x[?`$BN&I9V:BhuZn0k. {\n\GRgAggx{9s6 Gܳߦbjendstream endobj 197 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2831 >> stream xVyPWflQQiGÖ(z$Q#(&ވ"p 930G3LialNA/@hhWH7k}>v㕭Ҫݿ}p#D"Ϛ"d罼)&N!|p?bc=Z5M HLZ,ߗʈ^+&.~^YAL%?b#Dl&-rbBI%"Vjmb XG\$h7BDx"H&}e%I*'G_xLΘq25< ;EÑ-8Crm&1,2- @#)" :}CoK-Wl4]F>4I=~FA t2\X!Au} UNo4~Bd `>4QV$Vmkm45t+`0ؑ@`t2$;kA]!FL5TyE0mڅs_od4pb/U"HhҢ_8¢4Zh! /{;"_![x4)0|N c>,IZr{?lOUT<]%t`3?yu1TP=Ȕ0h q?8|}r:paDC|U\UG> Wc1u_k^ ƔX;r@o4 U諓Q\v4 5'Zw>d` .ETJ+6:0*.d'ot&IҢ3CƘ¨ˊ߷4 22hsS*~*.rtPJ^cGA6`/ TiK)uځOY"\}/ era3L,`4VM&09m]QQǮ5 U Zy&1PRSUC_iQX.6+bcb oL'Oi /$tnc9dz*%Ӧoj o}(AXHMj`!X= -h-ZPu"GRoF\]ʻP C$udeR_vD'y"=h^,"^^7tk,}0n iks >$#iV)='u Z9xyЇڥ>qݏOb\,56 kfa $K|QN$L vĄ("|`om#>k[֮:hYhL(`3P@˝"!&E-o>a;jS,鷶Q8Gݘ;.H"4<104 ;g'#j fޮi{ľ]jjjw{:]ֳ_KM8%̐r]aڐ(M4Fq ߹xeR҄8Ҳd5hR-_z3E<ˮ[[tݡ$J|̜[fsuUUsϭmym6K%؀3JFUd3KP WM-ꓵ{jerR4x j&)k6kK;+><92FdL뻋ΐԲe]m8ZwNr , G+r祫^G$ԝ`9 yV/u:UP5&[Zl]L}tP„a瓚\ 44\QA)j5b(OG>Mp$afUj0<_Zxat IL9F U,e/^ !UL5<7 Sqνf0 740`=hsBՆ\=>|}Oxf)+y_%akny^ԞGў;7.|+LI3A ^Ws5VN~晗)@%V3csd4E&رoendstream endobj 198 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 833 >> stream xmlSeǟy̦kMH%Ą0:6`Ccl00F--[ioN -sӵ1yF2A HD$2a Y?6Iկ$|:%b2I +loko-kjٿ5綆wt6GVR0l:)f>ыܷ*d+a"KV)n3%gXQዩ5*sJÂ9,XqU{5z_.} F #7ru~cHS=v"ή# _IHuMk؞RF0*+x{&Z/mWA ܔoxJE0M!f'|%.H=}x0=Z w$S,}X\N_Fz>#@s ܠ^ 51?Y}+v'.y YwJYp< iv'I@M-}ě(]?pLW.&<ȥ?0IaXrol7Tszamw |\cw?-(v V6Fjh&EW\w46-8NKۺ&_PKo,S9=cZ|<6)5 GBf3!oۣendstream endobj 199 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 470 >> stream x4LMMathItalic6-Regular?  9xLY-T$y}n4Dkaep|hn|kPXIcXx~e@G hϲkjlt.u0|egiaotwwomubRvĴaoċ NJ~^Y,Hx|sqs8Ftqt{r|{g@t~r|\vCp  To Uendstream endobj 200 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 324 >> stream x9LMMathSymbols8-Regularte   asteriskmath,:fwtu}}uttBa1%$˕h%(+oy}|},~y{|x$L$K~xr%|0t}+;y  W/ Rendstream endobj 201 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1309 >> stream xUTmLSW s@&9b3(V u@v sòJ[q1". W:تA? ;9sޜy?$`Rϊ[EDFSP>BH36a2 ̧@ݙQa-4L] +=s,4hݓ4O'y5$\p!\Ԭg]U.GEe# YV"m! Wf/(Y wCkW^lwl (`t5Vwף }.`py?R<kEFb!qӀ Z)k-lfTnCle38]nMy E<+2>rƺ {0,a;F/xs&؄y]݇_?\ L]p)T;X*'DCa{# /ٸxpuZj>z80M+kE: [,6z]s!D @o}bR+7;50>0eFMz mO$el!nxOU mqs|(E1T{$fZ{8\!/M:ͳ$Frr.`0 r:]S,G'DT=\:r uK5!*H "rIù 7+=oCzz?r+:5FKp(cnec;xqFju&nƌnF|ojZXmZ^mB8)R N7V`%endstream endobj 202 0 obj << /Filter /FlateDecode /Length 551 >> stream x]͎WE9O RkO$/PTݲF=GgA ymk}{o?<^p*L~\-˧ߖ<_͗?N?/Z߶ܿ+uu/+[KA):*Rsl2(-!2r<ˠsȠ\r\dP2(W5Meqʠw]׊ *9dPO9,U5jA͢eP{!9g쭋 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ɯ[%ӯut\<%%v#:v9endstream endobj 203 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6915 >> stream xyyXS CڪUkZǖR'ZQPpb S$$L$!IfġZڨ=8z;H[vݧw{{N@skwko;֮[I;-OoK~8{pD:폞D9qYIi yYWg*+;'L"ݝgmu7&mJޜ"N]EO_2c/~rNS;|:f^_˞yV\1xND3 FbD"6["FۉW(b1XI"Vk09"xxX@%ID AKBb2(1J!2bxxODL B? h"x%DĚQ%􂙂QVk'!¯HhѿRIc4~\E=tgD-t+Lt=pa&i~$ߜ39bϏ.{L>%u{J><թ =;mvpzՃq=z͇3LzҪ5ZpHQ"4<ݭc ZCV]d(Х6CP?6k?NO)AFߩfQx2& EtγOmfVMdmPa$)e%R4a52H|N;|=GVx ҭ?V8t248ҋ^Rfg==5`ăb<?,h JRQOrs]q%2@7A%Pw# 3t<µntTٳ+lP3.#D$%%Sa:**y0MB!BңPu oփ>8@bQ̖` ?F|_ե"e/e8.Opv[pLd% 4iYO.aoMhNz%SK6sMe̕TMV/C~fZmE#8<ڏAQS~qAy,AV λ ?<OL3V+Txn˟B5D5d9e,ٍt> $${UP)ْAz~ugO oʟޫOX$dX=Hk8,gx"os >)8ڸ͕`Z'^Fp&a)mOՉyx۟&T.^ />7nE/*A|:h;w9Q\cOD(襅\KB9BHjezsMm\cOD04{(HvX!21V}nqNu\XۋI@CQ nڼO} nd'8N u^^ 6JʵpnsɔvWqd7;K^`@z6w+2^_`M^Z[CbgR05ܣ7ld+H [d(C!!=o׾GʥMP $Oe7H8ue3Aw;&y07ADQMch,轡< @hS LJF`:5ŤY\-=#՘a7``Y,*=u x)$,&K~zj6~W|[ SjCY K6ˊ3%=o$6zi{P nfot DjK]"$NW(ʆqDѻ -$:/"i`A/K):BXx=X/{\ pRZ5y~]dmP1{`3 8IH|QaJ2uZ;B oSf]h EI)+d%Dq rև &"b> 9Dx# ~ƯP%L٥_ P]j(1KJjM%Op^vS\<sp/=N!C-P/"gKvQ2_ Abw= t(< EYQ+a{əhf p|i=3+ myO½$:/4f?cȍ{\z=vm v7M7ms@zbuO++xP?iM$01 <}(:H5;n'oEF=@36FRC&:3~ +>c+C2.i#ibT,)ևE% "R.ؿeX?F``T UVue:x9)(Txs {PGNB/pH 7{@Pd1L^"M{X rmL7 y:`]1Ss.)!;;fS%4΢4.(bC4՝Jȥw3 1|̣?2Hˇ/9ָ۟]}yHJ@/}AQVne#7Y8v8FdiPo%D#(2EJB.WrYn GMtf.Q6( = 3\ŗ;;P}TChLrBQ\@b9)1ԕ}";򲻟4-%%5N&G [ 4E4}7O ];T[4w͂Y7ږJ\&| A`0Z^ -l?m#NB݀]Z86WrݷEA-$RjU|>mp7u ܺ²=ң_+3yhp\ezu@z8G e."Lu5ɺCGY:j@2IE|]c2?,kO{@wi#@]C#T={ W/էC:dҫsZ|fzD伐`rkQ_^eA <n5Õ b419h#4#:z*]J,ayP Vf p%Ξ(5Z[䐢S,D~S|MuC=n"Adh?9?r!8"nނ.PZtZV+rKWmߝ~GX!q~~#owEm;”Qs;FpDeevAuIeOnZk2ܕ_5ȗ~+2(E؉ԇ\n&Ґ F )\CMР8)W:Ⱦ} uC* N_ :8g"[w2>/AK;dk_%:+2kT$c @RX-S;5ȉ܇ 5}AUKh/U5^Y.dZd.<,T|~oǹ4)́GC?T38j׬7 բoJxodBԨ6ĂB@?5<ϙ_FIT+ b@d!%UJ$j]gV;˔VkJ,ֽ'ؚ]Y[KdmF.(̐ya HAsZN" 4 ^d,֥42C+a4JGamu~djMJ=Qf;BetK:ThӅh 6X!1WR {@DƾTҷoCξ@u O#iM7 R mӅxp4 n^YM.kDӅh=FA-*;uU9 |}Qm*2i߫s5j\=sKI9 {!=UkM \^:W|ޭF{ -B]a#\t!;b<>7 9pGKn;"s>ӘUݑ= CxxTJUн:I/p1߭|Y"suarH.߫"j}+鶗s~_8+K` MztFԎ/ExoSKX_@#m(ZS&ijbb_݈f~u*\OfYGY[3KTͶhcivS]o,MG,CnA9V)HyΠUoץ˟a zyl|1 gRNh6"Bٲ/atciQ4^^4$_sUU&(ԅȅ[RE2ĠK/άҹ^<ff2Lsz>QY.n̡J[ Zl gendstream endobj 204 0 obj << /Filter /FlateDecode /Length 3542 >> stream xZ[o$9O4BZ߽"-""^JiNvWv T]ssB/,Xqn~6ůWcEx %eRF*6kMe%NhͿV%I'QH۔:/ GJ]Q^uq~)Y\J FpE%ZkrϾ-+e 5uT}wT:ft ߣH(W_\\SHPkɔyEP=IN@ L1ʀyS1$uNIn n0Nij@)#Pq26ۤ,e'YjsMD(wD<݈*E`VvAh6<20SCHwOQ1AdRtO+HǓ6zh1+rҔq>P#9%J m&O6OmR* S5:%q[g&?ԚCW!sJ˝#~CdHo w9%ߗ)C]?$,+-uΐ?d]WdTd}-++r,T2I]Es芜.yx lzHwrZoD3q1+ Bq ݦq-+ök"#s]8*x-Ny>L!h:nbCIQ B{&U0 1I`{1qY!xzbڐnT q ׏*5fxf̑rW:aZm{MhC͵f4NDI7 w;dwL51X$J}Q|aY,4\#ȃEs1A侏Od-aglyq8䩻:JP5q>CBN͙vƑК2d9uZ J!80,HtqyZJmm/W10g.fwu!ռx7C/˳ |>)ozF)+! eeMO6WT<^@F3N]4B I>*2:깇• fBK96ڀ6uf)^^TR}qT)LigpbI{@xQaBH4-1BxPq:z,i(šZL_Ew#Yod?AZ:Ɲ"9. 3kf {ʸf7_? lv4’K5qkc:qX{ <L1#aEl'h*THGHY51!Gu>SVyHnGCˆ(pH֛ 5;.X³SǣPWr@SE/46滞߅yT0%/Vb:g=_ݰIwSmМDu*m.&H.~uDNw y]wv7}~f7ŻwQɭE*@7׻W㎻LJ%ލ'sK\դն #gl0ۼb QKAaYly:IC8x難 [4;j-/8, B,һ>\TGeD  :D;Y?{Ҋ02B19㺜X˳ =wg^  t89Gu/myHe9PoYwYmh-zUNnUײi綯38\ZUjI݄5X0m;]_wzV:^N InBD&qN8GXYY  Cul|}b0K(/5o(8r$_hM(N-8#3Cši\R2,Ϲү}=O[C۵ψXoگLTNpYߞNʦ]jC$m6#H-3L͏ a(y áϫ%\1* >{DF^fܷWEW$kuZ{hѐ61yXrt%!|ON%3r0m).,\I({?_ ( b Vfao>+Og E1:T #+ARb//((flQ ju|usض~a1WhvǸh1 G9HωOԫ7 ۋ1Ɵ9a QD( MRx7 UlAx9'kzj@-1_gEkc&s]r|x웘r)$^?6_0]GD~u00?KZYyG63L3Й^oH JWsf1o,'Y*d"|#oV`F@{%"zz]od]ބr-B!OqٯsrHL=nZAc~4@?. 䡴endstream endobj 205 0 obj << /Filter /FlateDecode /Length 9399 >> stream x}MoeGqճʛ@Ѱ lV PU{HdT^'"ǒT@A2fFFF^ƿ/ogQevg*CߞORn=J_7_`X_X<խחa s?SKWw7/rN[oe۷?NߛOo>}F{nޜ_ļzoRْ`;}أ4ϙ(yǷJu\O'~w-OeiJ㭖fty 9Q Fl[Њَ>mir_B[5>ꨤRRՇ\VS5Z\~T o^%Vzs\DmƼy@*)lu=ӖjJ(p=˟†U~sl[Km-gUԸ1-7g1S"/SAF@JJ^Ja"H-[Ki!l9 q)=" AU$-f$$R&RR Z:TthKISy# \@Z8`%ր`Ȗ_QWRQm)&e"^bKRi+4L㍥k_I80RФ$$72o]JTޗ3 y3 .4:G*:”ЋvTbIqmRv 9Kw -HI#wcZ _2pi4 UH $^SIE@pKi[4aȔԒQܹ+N6täĽvl~H8-E .H9X66@]{*[UgKzhS%+ROikyſ@rEĤpo4p-0H-&MCRyx^ xސ:$JIg pSbqkUGK ;"/ (ɡ&X80tAdU}eM0%<-9(%brcbqԁh[$!bV$N,cjDKUޘh(Ȉe N̹d31"(.yQm9ϚH:JC+cR5Q"a@Ib *IsDLQMӘ}oR#N*8ޚ0 <ERGǵ7˵HpiAbCknz-R "aH4Mar+,QB9 yi"$+yf@Hg#RS7DCD F@uy#[$NɊI" p%,Qot'wѿsp"eAb]bx"aJPbː) E2NCCOC|ԌS@S3)@q@'*Fbh Pr‘ P{hq P$32u8(:N1R=gPRaJS260(\CgzQJAa X zI#!AQkCb@q;E(!u*Pb2*gEL2 T:'@Ik PPE]AR tF3()U@ɯt=(iE uvN(PR1*PMYe@sOZhCDQJb-*P zcB;(yS^G?(j}HP[׀wJP[̔Īc64)AIjE*TWS JS)BQYdPu؈P"#"C4"8!\E(4(*A tPٴ EwS(N5BQGѳQ8YC7T(fNP3*JɨP)H.VB^dU(kP=U(c=C2:egP҅U2XJ}v2P0d@S )i2LоP!٪P+r*SsbU(;WB٪PUɮBDU(q* JJSݩB٪P GU(e EX2*X  P9 uѩB1*ѨP2hNCTe`P{w*PVPC3bB5V2"fYCAiNS a,0""jU(jU}=U(mzSm~P|*Lj E}  {S*T1U(fmWzP7+B!@͈Py-NJ/C%J!oE++BI#tBC=IU(CN YUDFIBIdT̮B0B)CI/>5d(T(a22Td(b5:%9E^7:DvZd+gS<5!"D,ҩ9YPQu2"$DZ}ckS153+k1z4cI1d:J]5iLs{ #O=-*6)>J焵mVA^)55KX"لCz0eKNnt/ޗ /8=x&娴Z$p`ǖˬd~牉q=a|S=WSk }V٧ vNbM=ݝسAcu7O_W'=O,9C/%Jt%]wTGMOODVe_ᘳܚ m2f N#ț4G ;HMf, {Dݡ} $8R]4CJ?Dc@#ḁ4G+ ;ْ`I1c,iTe! Rh~'Mrmvl 8RސH͆}ݛ Xv u۴p^E:`I"#ea i .#K iTE48R$؞mFp$hZ'`I%ȹ*3 #p$l*p8$;HE֩ iTYtiT)p&Hit 2 G?; l}OT78Rɾ'`IX{ z,G?;Jc'`HQ$-g$;H$ iz@%Eyt M8i 򖣟'w%)'u#vpH(;/[=p$7SbY!ۄ&X X,C;V"Ģs y(^d.~*5*R=Rs߻tɾŕl- l4}`IOҦ:jS}hS^E?[}HI ~RnXa[53Շw笟rj8,1;p;E6) #'Xس-7(Y8?YxVo' f0xg$D4$r9cuݬkY$ ,Ir˲ZװYtGi=HηX/Mɱ"gf,KϪ|"GAǰ,E+%QͰY, -KVmGs$$E<˙[R852gx@Xm;S@<ײ=$gP# 9%y/9uvxV>gq9fqyʂq Ղ9bX]M[vB^ k qʐ I} 8f W_a8{&YQN[V-+ɱzJ~rr$jʑhRijpCag>gORijhgSȞ$yӁxVRıjSxɕΖEg*G,cȲCK yװՓWwk}qkzO,:\P^` rU)kϮ&FB l)pt}PB?T!Wߣ&:6EY*1ӉJ}}}W(qN}uҸ;+b!Fj([7f}ɽ'd7=(yk+ ?JnJbÕkT>cjm|&9TVN6{ }ѸwRsy W~S/ֿyՋ;?z8MIީjي/={n??ŸojHHӫmz/onvӪߜ_$[Z+mm#hg=vUk8xw}$u}s%Hu}' y!e'|WR룳q(7W1Ih}s}~׹?<}9{uCzjڳ$Ēj|Fvp3!=lR ;_W1s{ "l!zVRZi ׮opnPWlRDаqxHՏR'WB,4 Ws V:%Œc31;3nfׇwGA=Cr”8ȵw[2fjBq=0~s˻/qΩF1 o֚zW^;_>κ{)(iKۂw=3#X?]M]ߪW/q=3mV8#G_{#v .M:B0mO28_]-~9Dܳ}1^=lon__WI$Q |ow)?ǜo^C6pTyԐQ~c F!Gr1ۧyu?M^on9ԉ=yݗ[O~/>Z&ڣ\~ͷ^_۫/wD=I.vky%ѓ&cr*_zp{x-Yַw?ާd;!W\9n/͂{dk=eZ4/տ_f~Zr{ГJ>C<݃y}{n{x{s˃ LWQka6vNWHC|L1zRt4wo > OC9}{`Uy:˕wR\ tB{^хazgIQ&<|nd:~UwBJv>ے%%:2ʐ,ʋE䄭:<py33֑OΩ.3|z6J9q?~)z]E(,O¢YUߚjN~1aw#X>Wh 1p;jLb:rs]W?6dtlznB.'Q^ .n(5džMź_,#&%_g:Q65WO*ppv.괳$Dl !p*U[.}܄Hy9ʉFZ_loؐ}x|Dz:5<"6'?KQ9[rHQYLO8NcI_`bgm2r'9a{[;3AEY{zw*r^)́kx~ \۩BMm<o ^@ՁZf&t{|nR3^wnoOr_/bRBALʆ/n|Ey^}ys> stream x}M&q' b/j]ʏM2`/lȇ.3#tK$wOx#+}{EZ2 X|2####y*ߗ%_~E|?Ud^O mx\yŗ?_y{ysz.?l:\-p1ez*7_~x~LBKXxuz_T*^[+ \ysyʼn9g&i~z?|hz߿\qr}:_uzo_Xp^W1{lB18nԖDo˿,o/\"o9䰕uWu+)|{˿^\̴QYkrY\\By}&fg[ skx.$=l/L-oo.m!ABm/rH!iA⭷B㍥[ʴ:Vߔ*5oEവVI[ SMB5-MjJ\8g"SX, JK D["o$-fH(o\(m[ -ɤ-lҶ^N)nA愵jM?aIڜ1ߤ!_PI[Bg"Hi$7N S̰4H(l\.[N*Ņљ.t弰L1%-AljP+ fmj[ <+vhGQMakmV)p&HXshDխsf ʡǭk; vj%"b ^[ި/T(n]B3"Ǚ--/ĽZ[J H[~[j[ ?ʲk8*[:b:/mj=uպ&X``Gr ; SPHVЦ顇qoq{o1P Ifl--`rmYߣ %]^,:zƅ3W$-f N![#覫·SgUy 9o5/L=o5V`9oE+ܪ.B %@K(@"sJ*UFuM3G,f 6S[h=R#UN`e\jW'bLTtsx+V [gI)RAsh *_TRjaj}4ѝǤ^ 7 IL` Ax:,jSb RH`@qB(8.$`L P\EJ-?1Ǣn4DnCpɑr p,p8$t9rY IX}T&3TD8Eypl qUk5㤢Jϖ1sV ۋD!@k̍YϭDAij2$QwxB ( !c =D ̝tT8gRI7ͅ}Q3s.(M02^lP"G7΄ImMm3sQ]db(3'80NE($E%S6qATq HjR KN%PL:= %YWkiT挫7Hmh :<Ħ㜛猳d֖H%؟j+\Ε䤂_s:vrO*zu"|1Am҄q@%x\S;4RYN\DY-3ֹ@´58j!m s gPWIMpAK&W+jLpjҎL$]|PM>B,-}i8V9ph?xۗ<3KWmB$hp3)rp+3\ffF?!}@ЫS1P6H%SFQ9RU[r894K!:Ŧ߂dRv ˈiSR̨TIM0.l]^z.㠎eɈje5Rx\ԩⰗ^jJ1khIUIלE$MΩHHU{[RBNtd^ lHEJ*I*<%{ԑ3FRklk\vo`lpp2:Za Sը2*wun⺌]!8[aX3Ber^M 2cEJxcc5\;,$a`ղ_^K;B⏓sYMSzE( GbTV֛):;p("IbL3$ubmDiC贳/+zSQ$%.zKაWhI$-a鯐kHЛf.BP r^$ I,>q3iꢌ~(C.MM"'qX?%H&#>"B8JWCahRI*U` ²-Eh)A lM\cI)qXPJYF\q6*UsXّP..43]JI՝CRU4y)A-raj:9u8$iu[rxM g7=L&v:ΧiCOzI35^( {KY!ڂ#bj !'J=, Jrg'\I~xy.Lz#"KI~CgJ,-<5ꕽ4D 9jˆh'4qBjOf`کslr^X lܑ}n%yQ{Ӄ7OIݭs BTbd-pE&IAtH/:&u(H64Yh ze/1RX a<&d!i+K xNr\UiRmk. ?SarsTC )9LD=h!ALv"R7P)qU%Vw=r fgZ2 8m(A8EMg9p ~Z dTUI#h)ᴂ $ Sb ]6z"LHƉ%&jEKCZe9ph_%t61`3 yT~iv $}Kï $[ K7e@-Mn/Z8#/[KUZB?_X \*,S(8K\AWhe0ӂ{"?W;YE~,iD1͆Θ& ڏaYuEi& 44).r䖋Hi6D}4قaP |YD;Obb[=j"Iշ5[,[0M\98==r im` jG5[5ɑj"!4ˏQM jlPM|4TqVgT93*3ӤNr֍g\6Ú?3\\(3[)5 kb'`͂KaM\5[zהĕO5k9D!Y@5?\T⚵U,Ty)fXUkpM q\s6gqF@#6{`6di3 Ol6rȑM5t5j2ρ5ClPϸ&_E 4q\ uf 9= D l 诉h6J ÀMB lqM.Eo6cR?Mo,جlSC~̹(qD&Vg&^E8GpM g\nSu~,!f(l&y;94i`3tCO M\6~O `+p=ˀ͊4܎k2D]b5k\ kzaMb 'aMkb>Ošܣ-ÚP=, 1M&n硚ҮA5UXP(Ʌq=$P<`Z g*@y֬dvawX &M LݸkJl҄k"U8Ŏ85%գXy\kRHP\4H؄w`' l"f%6;~z䐫C l"(;l6)ڀD0+n)1;l"Y;<\_[x{QNI,)`q< WLgx*!N2$Zruq7 h.XFSǰ56VRm\__RCwD{kѳ L?;aq>a9BV,\#oホNoǦC!Dڇ:"q*Z~'W$}O(r([$7yc2G!urͣO[8&m'j˫Jl[^? 0><GGu=n3@dt`jByW F*{#̍p]a4rܨ#֚ؿ&b_?g 4I삹^ܠ<5rԈ̍ `n7ڴC05zӺklh!)Hu @s+Za%j[dnpjV`.[z~KlSIܣd$p]EI7k _ X|&nɟJb4yz{ƣ՚Ƹ>_VYG5bݧGw5=_ֺYOAۙ{IxZ/Rb %VyU xy,keC+TV&9*B蔇/Cf7˩UTԪyonU:vo}2๑ 6t%V+Zت]r VMت > X"Jss+L2 ,tK<2ɹsZ:焏Trh{8F[ϭ].ZMZ.>-[og.c)8!CP($? ?OBQ+haO_P(bPI?Zi*a[`QerXӜ޷eOkI!+b5J66SaH+kz/PFΚN5ZeMsYNfM\V&r4PAi C)(0 uFNF^g4JAnOrt^Ǚ@ܕԍiN3MjPwg<s R9 ,̜WW33 ifNM 4iHjPHr)؉ӐZAYl"NCv$1iH OiX*#NC Y'Nc@)ԙ8 8 I>!`d'N8qzq4G)qZ$J;6>Q*4#+qs0~\K]'Nˋe&NtcM+Gt،rPmii~HQwàMTӦqhf6-]iiMtM# ̛DiΛ&:HΛD˼oMCPMCmMOm8 ЙӐsOWN1EiBNDӔDgaiѡ*;{]iHid:Bz3yR'ON6JA.q19viH*3:sZTiqfNC5XwnpΜ223xƒCM(IgӠq4-^H:M(P'4/5N<\nmig44֝iP;MӰzNe:5HNSaNW{zN7{#|p;Ԫ> ,2Uu_N+;ipuɝ=K/E=GgOs4`O#RX= ~B:9EdΞf=&4'{kgOg{wgO FY(l}t|( %F(3{v]f;{G:{AR?NxV Ѷ2,m'Ofy)n4^\ mfMWb]Q 9g4=XF]A]%ke M#F4je;iՠ@n3i^ft-viԦ7s5-5]eƝ2m:P{c'LK}fLC}fLCe1-#=01cUc:_54KWU@eK̖v4FP'Kzu)ʘ(Y^gJג1SYR'FaK4w r>0P N9ԨL7ƽLi˘ƔJLr4_ 7ҍaS"֟=։H+׈ҸdZu'#JWىҵ[AFqRQyA]U=(T[ jˉ(|'J}6י(j݉Mj  MDiP t ("?s4JL( rWq4mIKU>[y{(HLFeQuND'4iHԐ&ݬ`IC8KiPO@k&(\[76>0h)rGZ0!zq yo$#y6!yxOG>!y@ Hn[{$MNPt`Qak}&P g(OOg( ;yF{< H_/!U/1j b#y5؛!fe |P FxCy(UHCyr(Gl+̀*:P*~PJp< @(5AyƵdCyU +)xjwCf55}b@y8jCyxkj qwp١<\"-;fmpkuF`@y:=< ^3(;CJq(o1@yp:C\wcy8cynWC4UUq,D<xAy/d ( J_]k8fi3ǹP^5F $MLPҀPơyh^muWUKh^qGTybCq#my9e};̃?BB1M0/v|d`ޝ>`yѳ+^yvAypCVȰ< u,O )<ɏ<8c$ȇ2HԼ(,:P> Rg(Ua87h4CyTŠ<)GȯʃXCy(aXK֭yUg{BHՋO9GCQ$<9zf0# ABHBuT|ˀ mJ3Gj8A%C$Xd<18ycG9ops<ݪy)NXEu,O}ՌGCṿEy8P¡Ҩ9AjV_뒫b2XJ=F#26$Tf\GǨ~Du[\Vߗ|yj U}U.7>J" %l- ԳԛJo_;y*rT? i617ek% 9.sO_\J^^CK% Tjh^r{"y4^.X8ç*qzK_޼\ThwKFW(iۗZ߅^߿}ruLiIG=8/P7_l1+Ckɛi/LxM|Kzwyzf۩ֻ9z(b+mP&SyzEu?it' v4Ku)&O>s{Q10(:|))G͋aϐ2TD9Kkm}s8+F"$ FT?=FaV"}i͎: \KG+Ϩ'תYB"}}uywz>tFbg']Ooo^ʲr-7pR;w&e=ܼzl!{,IJ~{]U!7+@Lh/kf}^>`#~4H:Gvy6ww::?]P{U@{is}{+KxϐuYW#CKR$A&+Bεx\{CߝZ>.yaokp}{x -[-YnI"dSZ !jj㥽c nqHZNퟯ_~s_WOu9& Wd3e6b9fU̦v a:Nv8Gj쿝<1qu~#*yp<x 7{b{Q#'Ig렞zsf!:tw]G@#C-r?荻vd$,nm[`IRcltߩkx `삳0|0vjGv|=*¦ZvM{ơHcg-%t+=qbw^F؏*J?$X~e!*<xk0{P|kgvv}vrWQ>}'#F}젘8/͞O2|=GBySEl!X]Rj#ESOGx!V:\@{%: ȓo$p<Sң<.Ap"S3gl/n7?0r.!Տߓ`{c 0Qa@54>1~zQ],m+엎k}r`z:oJ`TBl!5.Җ![^=) v92XKc0H167.2cț˴]\ۃZ>Bi>߯S@ h?*~Ӭ\ u̹yY1x!*<_kty*x)|nw?} Aٌ3PtM`N:؀M~ON 6>B_<܏bQ;#x`ۯ>ܼ" cZ37o_~8߾zb+z2"t! q/?&h0u 7&;&s͏#t.GAOFwtmq/ w{oχwLUDptB>ի80iFuzҬwqެC6N'R gnѫD}4)> stream x[[EOza%$}SEdXfhef<LXթ˞nw]; oF0ڤί>}&t<؜^l6V[R7#fƧ>}fy>Vj@ޜ^Wca;!\fL zƭ3lhrmjwL S=eոE `i|0 Ndvg-(wc/›2[6a[48_h$H9HNk (F.9OR`d\UnfSzt$ͥgAo8wlcLZlXa%ǹ:h| Aix 5pG3*KBVǚ?Sǫ+첄7gKk {B;{2󷚬[/@+V(¾vz,MF;[lz+y"R *؊=߇.k(; R3ק+F5F$ <&p*|*-tܰ)=9H'g>|<1z.fHeӋ!*-5ػuW6wЪp3q\$"ws@!gaTtH ; d KDAҳy:uAh^#3Ks.v A8pLI>{ ηzGTh }Q6W?烊u J~&oWadWi8GHtdo:g`iwAJtapֳ‘4}dhיd0I)]z^xtx5&B. 9Uf} R͒p m Q"DȒT=Mcnbզk0F[ x)PD9-Re<<҅M=pґutso& QpU# o6/%p76wz^SMuP)GP dvAqYJ?vLٔW?vxlX|H9'@l_=mw'aqg:17M8],pH*VITh gN6ԑ3eiEBZjB YKmS\˱-ݼ rBI7Uc|Zo$wk!isN?)9m"G=6>?00M1 rN&g:m]Z?qlԗkoH*-;a|2~75qyaɣ1@Way=rxͰnƺռ6^O~(w֠p(WLd@r| f0 }0ŝqEiA:dt )9s_HwL?dxz8*`uXbPJ(6CNΑM.78FP3lѯ5Ԅ!oPpH.m˱ f#KPb/jJ3G<\GCoՐcMPTd,X'6 Q MR#B{'.859Сp*= ,!U*?f"@x5 BHn#M?J7 #;“xLyRup 9Cߋ@%q!(ԏbPFwLXO|oz 0/N(cta;tKKsTnԅv.=qiٌ!qӎeˊ7B;Ú/Bӝy>BD}&OCf|t?(F蛔lv qgPһU}w Eho2m?P⡭R+yТnIד |8 +|ڋo#Y,r(lfͭFQZendstream endobj 208 0 obj << /Filter /FlateDecode /Length 14279 >> stream x}]%qwia6,OWdFz5V h~薁ROMO1Ѵ{,3.OtuH2{*O3f&yoOiͧ}"^^"?<d|VTԵ^ųwo.JK[~^\J[z]LkseZ]]/>RtAXS:=bOs5|& %jͧBϖ}wykey5,:~CW))*gY3Y޾*8R*݊<>狧G^VE*oB=zeoρ| nޯWY{T?pk7o_ݼqVjkjVU{%BV!_\qO'Ϟ_WG}odo/~ؗyrnIx5?=k{~pY%qhmI/_>~n/?y|:֫/ϗQ=>-YOp [|!˿?E_}s|3_j?r\qUi}vqǧ˒O/ߍ.5Sm:eS]{?dtwsӛR|E>""'1^ rRk pY3RzRugD,qeʵ#}m Z_K.= W ɫ1 k6\ÎU3k\F#HgFlUDֲ!FHNkvF,"ֶ#eH]3tFښ#!}!\ "Ue9#'GHY[8uUt-rjy;֬qc5K^3ȚZD)kF*X+6˴Uk el!OHMk5ψ9GI*[m2>#um!eڠ/ h+3bᾒmOe4 Oe4ψ/:#k\:>#ja Hobk'jvA iiP}FZT3!pmeFWŷ6>\KaF|5ӠdP=wu@g T?5FtmH\U #>f>4ZʌV2Yka H\Vjk :#Α=&)#2!uO^"uP}*@ hsr [K!WJJ:e{ ^3P'@ &Mx nO%27>} ((Z(#3RFMȦfdX;`Fl!fOU8lF# f4~s e0{.S!k":=#s ܛ[I^Woo\ %mm\lj|H:3i5!=NA 2q\BEj%D@&R%؄tg#hgDZYi^ aځHF1 SũL JꐴXNպiCePz4-!,q,2 : dk $'A qz^ G' GH%DW"CQɩaJ\ؐyH$hK*S0v%texNe:,AHtBo.C!h t/xPb!'{۠\qzb%%^ Ɂ )3Ri!B!1HZB|P}Br 3K] )k{8Վjݎu|.3Ҡf J4I@ϒh^DaF#d>BtL1|[+aFz z D/HI@Ao ^+5  Qk /ψ0j#ë O'yxMS̓z+\Dv"DG NjŤ"0[ `udv4ژIԛlRoFгI=Y$vۤ"{^tM@^"{Rq*S>8=ʛ_Yl›lUiWzxcb ӕTEAY/~^C5з!>'mwN)L1JeVMZe,-٘ ZJc*AWم PqP׮Jcު1dcڪ8ZӒLjqi?#2o8G1b6 ' (1Enu4Ӆ4>LE2W0q&:[AZjc8x)LC)U D2f "A*W5WU{ Z :-0-0m)(R j6 mRs{90 |F [ nLc A~䗚8k5p֔17x0ccz ȁ..^h^y\Y{٘c)-O!sHRpzh买\ 1a&=g8ձJ`-Ĥ @K[.An4֒.m\%$?{g/!Ka:ӳ)|Ҙu:KH{^^ Vb8f֐a5- \C³kHx \50V[`X b qPmej&X|m5) 0_:;Sw |!yR˻(;Ox7iXGAZ5 ܂@bMg-9f恳恳x=-w 8g0ih@Zr=$9;VRJ|DrKRb%)q Β-II0͂u3a%% +)9VRf5S27K{ VRf%)+ Q-pj42-I3%Ii8LT $I%J%J^}6~Ӛ%aA-$[p Z$4rKRa%(1VR8XII*CfIޒTYoI,i͇^%tQ`l5Iڂ5%Ng3͚7;ޒ<fZ`ޒXoIj,Il@Ve[ mLRk4q'cޞc3II9(fg5.P_w)y3]Z tjLҲ0]bm=ebus2$ρ.v[I;g2 :݇VnVee~VX[aG7f)09A r"̯1(~DW5 ?+}DXaGJ,SZ0ʫAmHJšI9VڂS_ʉW>*sVU^C&k|ԙXO1b6^C6l+| jc >l%dA=s&I%K m/XOϧk moX/`b<@ZK\Ʃ`Z 28Y`Ǥ5 5H$^iA[ @ZgɅcs2go(F{yg/Icr.gO8.쑘^ fIXg7O 8 ǽA9YGc? c kzDYFGP{ǞqHdU ^9&ӣ.<_-ApI '=R0Neq|rPeArSzDWU$r8v]ktZt p鸲eU[<[Sꁯ׌ -6c1_[ |mZ+i,(&͋=y$&.% `|,p=tܽv |,0cZ|5 |5 |wz:V_M_Ɲ9šAn <8h 8ʩ<[[;Ғ#8 ;,㠜,;iP?:[#rPNc%sP^4&0q 鈵0#X X :qPc R q `HG tZt4q8(/)LfpPds `GGc?iaGGsPNeqsjL`G!]м蘴$HM‹I5VIArrL Uՠ`NǤm,x՘IV 쁳g[P] ۃ]ᐜ #:&ly0cy٘DDŽ`MDŽ5^7&04d2Ì knLNi蘰Dr8&= {:K૗WWuc7| 8iWec7:+舯-$蔃4fQ 7`41ÍqА 7:",舰HOž~$4fULXe /:R[#‹$脎yHmq̐ 3:+脃ec3:+舯0#Œn$%N9hHc-  yh&t43:",舰0#1 3:b,舱3:0c֐ 3:l z ft$&aFǔՐ 3:@Y pAnGʙ̰cƶ`GGRvtQ蘱-d2Ìx՘)2g=aO[SvzْU1%3.2]/9A@GضG C\F ~.TflX=:*[*TjG~Sţ3 7M7tyUt\χu~@ln3NǟMO.J ".U/ X< hy7{"aR{~tsȮrk!ro_>}P^BH'!d8Ȗ1BVAȰ&dqlb7ex6)F 8pFv AF_f ^BslOgKm2!+n2]b#c1>#0fԕ܆k-MӦ2yt\BoTd>ٍ&dx@MHFNNXW?ZO7ʌ҄PXµ쓜糐&M}NȾQ.8r?NH b> !afkT"ECc N~XSµ5$H .4\{քJmHs}X\{>,>0Ū s8r~XE*?,kEZ=DwXELBu ґ?e=X^#|_L;!=X,P)2Vpc5\@v1ґC>Hg!?ΑmCv=9}H:"{s}.ґwwbґC:W:Rҙ~A.9H.)uꟐ)dt37+_&Z/VCPmOsC+iW|Bi$ S'J7+s`>"#B` ].2>[l} :c )E/wHB#gpddFJt2sBd CN-׺HLH>$LZcS 1u*F* D-c ֏-ΈX*5N 4XN.I(9Λ鱩Hcӂ XǮΏ&DBP禑 cg XhB$oJg5VH> so|nʑOȇd&&_? 'F0upR E\FRq==.8h ʌX }GzC)GzE#%#W >rn8r>ЄZG ߅XȒ0ǃ$PC;\nھ{B$TzS<#KXB{qgdpdMtb-,l5Vi: "9$mD}Ahs$]=:I Y ]..{ GF:cfD, fk1m:ca[:t&9N"\ n*E < qo[p` [T|8OHgiڝ@=Ŗ1OVt`?uXOH8%:& iCKo;|9,|>" ȾG}BJsds=DvpuldR)~p2 @?l4•EN" oSBΑU1izH,g%Lh>'$|RCd jpc=C6&ZzΨ})Rg^l_{.K#JaQ\*^|RdEM Hhp$*8*ǿ)q='E?$&ѱu)Tjl2sK)6Nk2:*RR;B\jG,ZͥvJaѡ΅6f*4=?4iT\]N<~eaVeH9*?5#%3ZrrN?]sjLu2wS'}%cW}w#&|yyy8|5swS__^s`r N|;pwBI ///Im}w3,wLg3o_̇O_K\otL/_\x궃書$Pnq:.ěrsWZrͲܿ=*~=">'9]aҾ[>=b74Ͽ,unWpC)2B/Bryt݋<_ Gܶ"ϖ痗WMy,.Y@퉔j =ߎ;/#qCT{~>ICy|VOXhHnhINOb^ SZ8輪{ROs/ђ?nVSzn~~2яOfDP W)G%Q~]h# շ;t).}J}ןeH"\{]n_C$ ;/o\B1r2@4_ǃpZqx/Oۖ| 3˻qxe9jR-<߭z>\y4:FyWSۗ=2jmLN㏼xLi1ݾDohyAbKO`yu}{ ;T8^o'`;ۻGZ1(߮nַ ՜+ Ғio_y=ba^5lSi7`&Pv=.I~4}3W1oҤ2: +'~+2{yʶc+O7on櫷zYS<1xȃ_B.7iLjlyIjc?*~5_ +>.%?9_f,sq½JRG?: 1}zm|k[ m9>!V=>՝Oۏn(H> Xj^`rbf.P[3OZ؇n꣪aw4>U_^_c8VK]ey|ߧߒ>/AM/y~=&dl vt#^^a~|ūލ9i ƑUREU;)Q3Bwu˘8>A-xAc@/VO؏Iѧrt(/ǾMv7_Q5h%8yOC^-=|\fm9G f_vhxe,h tqgH'o<#%Q_M@XhAJ^Nm$ȧ`:zm52֢g=ON*_I<4UY-kS]}xT{{=w7r{/WM%y$=9r>7_|+/^_iG'I^6vSx8^Bׯn߼td-חc{/73K8,_w4LR7|z3 [εM't5=j.~Ðendstream endobj 209 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1224 >> stream xUmLSwmKn7M%D2#Neʦ[% L۵EWioOo[(-o"LL0t˲1CDg=e# x><0 ޸)hU K;g@0Cb`˜ 7,]NHd &2)"o[rbB~4sCI^wOCɸ[Q)C4' 㧨֦5KH5m3n_9l` xY<9 p8Pԗ_SM3o)J/>H~1lᗄ̨נ:FmEgUt l!Ekfb$`')S;ϙƀ{$ӥ4TpA{ a6 m9x#S'F޾!UT̃2$LHj{4 EKlT{h<}\3ޠ=Nb?L}b6]Sj.]lm VgWȅb0(93ZdXQp+XWWؒc183A q˧w4{' sWV@}TVՕ8vp[rIKVx1٫NHN͋-rEt~Mu6ʢ-ِM&Bnԏ8\𼒟tbNل ?97;Up>xmG6|!jcx e4{|xZ>7 =ٰiuzFw !̞S!K~({6ΣK-zA]*=A3twWIuC>ݱg=FpY-Z sBvwgu{hUjʀ+IG Jʴ^s[kOw˫+|=9.*!Q&S=Yh oyNOb{sHfz2aPԪձQ7ol/p :hh-e벨H&J5?8(:u FcP^5pUǷZl `,TQt6峳l 58mvmHA (c+PTd`W -ufI,XlMJrP{`ZY0U76RF(2Gv.HB-_lendstream endobj 210 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 284 >> stream xLMMathItalic12-RegularyM  aBvWwS z}xuo_`\btªѺ͘9}@||PxLbnװ*|khpW&((QºPzȋvCp  To Zuendstream endobj 211 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 253 >> stream x LMRoman5-Regular!`  `A"ԒUw!qM|sywuYUY_Ҋ`Sw  sRn_66!uCn  To $cendstream endobj 212 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2534 >> stream x}yTT0`ľV%j $&n!.pCp,ʾ wdDa6AvK5$*$jMmBH}G=#iy9{$ #HTBKrr`@LjOې7tp * P.*=eh_ej/:. ,T'G965}9$-qAt&<蘻2ξ3<>;oV НUmU*]2t-:ЛP˱S O'_#3%\ C4bCE^f2ȄEp!ڞ{q7ZM}hµKhF> LPŢpPe2Y]oeKܬpNw@Мz " 32Uyfuڅ[ׅ(#\?}IjzivA%WɕzT| ][Z2ZlbXrѷ9Ds՗Ӊ/%dصoD7),9{T]o_u76ۀHd0.O*ov'}]Nmz6`AZ@ROo͇=>UM%D*- 'ނjP5s3xkaWfx \#=p&,KIZp@'J )\3v? wҮͷgp;rH}t?tE~Jۈ5!s gy2㴯v8TIxZ*I6$COC yjR3AvV1*74}_(M.2PUaa_BBgc$OP $0,+KЃ u r:@]2U4]m * P)%}Վހc8yMi{3 |Rh.X mV0YgQmxGXȟp,s>ӫr #&]!ϸd1.Ep?~ǝK5sdaLY#AR75U| qJ$h!63!pr~tQ7AcQ Akf5IWO_Q/IqVzPCr aКf+LB;}Znu:$'o_Ab-.W23o\q4 7oR9U/=mSeMM KG#J]t'`'mO*IVg[,mC3gO ?}{5w<-"Uah0ttfWd}%*"塯Eeշ4t QeFPUz/LњMyYK6A~md#IC{ 5DЗ!%tOjpROt`34r8gzR7?^腇pĿÑ6\j>){bц+! Xtpd> bɏ@&PVQ塢b~wntl]p+]J1q7.Kze@wc5GxEqE n>"Q>ww]vl6 LKE7yendstream endobj 213 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 160 >> stream xcd`ab`ddM,M)6 JM/I,IItw\}9k7s7\B`Fe L,:gl%DtyV[]T{wl3w/kyO-ù|bOOԞIxx6endstream endobj 214 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 488 >> stream x"LMMathItalic7-RegularM  KaxBYfk#~}p[xPaq啰y{ztovi[!$*FOŁċ:=\Oouwuxck`fg۾ў?K癧#~}vFOWScvظ}koyu|KcYcjeuy]SKm~ʶy[wYiiijUXmvztonsfYtVywCp  To _endstream endobj 215 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 229 >> stream x%LMRoman7-Regularw,  H0p9qw~]lM;|CC||0AA~Lw0Guc]Nw}Ƌ݋Ջԋך ˠjQUC4wCn  To ?\ endstream endobj 216 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5038 >> stream xXyxSe>!4Dua@Ȱ)6,E,-]HfNKNf钴M;mY"Eтȸ}T;>z޹7/s}]~omўȏ`o& &aD1ho|欐̋/(,*^+-ٳ,uCn~1gsO.$&b31B"ۈċģDxK$Vxwjb xXG,$~Cl =Ľb*C!8G'y/[8W*Ax«Ή&ܓ4i[S'߾qʢ)gMMz5&+65iO3OD+afz]t0ϷB;CܮЧYj2Qa9hfe QW#%?l42h<XhBƴiA[2J C^URLV)T.:C@:*d]=nBy\y>{ЭLFJ7g RsuU@םEah[pҗ6*(dȀ"YNib#vgrx&dLQF?Of0"[ 8tۃ" jx= I $y*b4 %wdcon?4q42^sq>,3𬙯m= k*[3ś$v$2-=te Nӝ珵vyef:Y8Go'˅6n5@_|iKM"p bK:Q(оcn5:2O]OA3.4'qy[-7#Zر!4wMo9'uM;3$r([3ƭ.Ƃ$mI34J( ,mp Ap&[ ݁f9SN$4͡F,H ka.(:t+ p ޓ'IG|BB~x%G l.P[0? $dtnZn yXg !@ͶUr@-0RiɨE򻣿&X{F ă'ĨŅ*WsCw6|kY@CsWPa+hKrtzQJs%9L<aUo9/}::%J@( ^6gW %pڪ) jsT^Q{HS MR%PΘfjik@$@irf>Ht4<6WA?sjn]):jg %swa]5xpf^3^T v.9>)/.BOqVTq@&zWZųx)m!WRVa6 wi϶Da^ YgѷcB4TETt8jx݉@$ﲃ!jz+[z^o8=uu`42ڵlVkˁ^00tct:%Q#:ܹn}vдW8ߞ懯w' B9 UbBVn4A!Hp:m+ߺWdiU2qb!DAWgQ/XMMP ,8l5HĵYGD>;nbgG^O:Y袻 =ѡ/ 2t4TouwtdEpGһO[QK0^ (-uٳ?/+2*׸A}Wp]vc})StZDj๑ TR$dJYUu`[VPP'w8G}$ui -ruzNu&, /دilk\ {"V VqHeVbZ<?wOzt2Q/J P@6y\z%}@~Y<-w^Vq6 kEҍ }fCYQ 蕦H^#ۍvQoS׹@G !xhex?\[j `E:5xuAFRfVt=R@NgҘuHQ? "h)N'4sJ/yPAWdme 5ؠ \{\. @~_A ʹIugVRѷ, y_㣃c$1P= ^xc6JBbGFU^:譎Y^⡽_\xLUaTc%@PrLטtP UQZOYUB&=Td4D+}ndZj1Ԁ vǏފyɺ,}Ĺs8׷Oܽ;^J$&ع/ `Q4:Ol\ӷ H?s1\j^+,x3yHhjR" XrRgc4C4&ơ! Jgh-B|>*:*<(odJu5m]J FauN?Es<@<4utCK_t!c@cʧva&jdـi__][+,ޕ#Hqr_;=<doG#yXPxJ M@U PnQXYa"67#Ko %ۙ: cxI9(hZriG ~8m룧 "ouyhi+Dh+3R5k \2[+2T1̃7?HH O/dzu%䁫.]7"H[LCiS?Q\|mFѽG_-\<{3pOBbժ1Zr;Z ZJ˛B=@ Gsg+ AA/?W|%xnzl+B0LC{uǗIf, H:;T!ed)p+Ĺ}/ylL7t v(׀TZE2-+NDf\jzjFUSôlM7P M{պBVBW%~9>'^ trЁ ~;ѕ% -L>H˞kUHܢtO9L0B+}xn> stream x}M$utI:1R;;@ِYv{Za&KYլ/ϖ=wD3=lei4Ng@ ڿtsyu?ճ1Ok^|yeIJyzq5݋?]={.O/|xi~{s%>kO퉢_?ܿD\S)/~ Bp%={9J_Ρ]jMd6ؓ6dy V_.nX4fR30:cro0ܽܝ]B-*N~ֈG:뺑O_ڐ_qdbY(ˍk>?)zK+D*cUlHpb{eC*z9})&KH̓tBw\'bJWU$gTT GS$m צ),uY Rj`֠H= g5lLlw*7M.5DTrMJf1c63[RPr1`0IgdVEʑax0" D*`S3E,[藒p@jtF!眪ˊTd{( j S718/jj,098aV.a5C,a۠{ֻ ܥ9 1','L> 'g.`W}񾹩Z2Z}sS u(N= 5D@XU]$`aT"1:lV*Vt9eSy,0GDѝ4'a,٬ũ,%zf2s]ڕj&m ɤųF_FY5+td)rV6#C$U$x*ȫ"q*}c 11Y)ĝlnBHD _ 4}:c\:y6ER6Cj21jpbQM&51zk8I9AH CxPL_ 1RP/Tԍbgc2ضՌV-btP@ /z Lˢu#H176CiC,d{1RW"gx<,qJ65LHUUIIĎL2Y8uXcs!. [9e#â>ݢIUTS6'8}]`1V3W1;SP;7SdLDf2%o&3,&D38cI5 `"XẄ́ٷfRrb!FuH,Tib3}V[Т$2j`Mg`/1slhFZha-Cjkt9gӡZ,d&Eg#"=-)x>'!R継S ؈'S`qIIJD(G4k[STR]څ^U8),Yt_tg:E-bf훕0QZG#yH%qu9/d,Q6]Z8Y+UE"Ńݨ$ޠclxox`ZP"ϖQl' UDћ ,aBi8ܪTՁ6$JUxټ7jdX=$h& cskD%k^&o1VvWxwEjX)b3o;;ᣵBFR" ;H1CX)#R5vH5hC7G*R:$*EFu;*Rdz(a:DԒHQ%ꐪyv aD1C4 5VфCRV!YJ^$uR:)j:fx6D uL7K)O$V C&lDQQ!26RF=RO]DR@픠[u@(hDQE=PO$9(6Gʉ2'TJ#6*QrKx5Q#FuH4CNt&K5󉉫0W+lh#% !5({E$EˀD?h!ԕwH {+̣'ϤOL7S?=DCPy@E=btQ PGBzi)R4*£Lh=S)ŐGbL1QR$>ѧhTsgV%HgBy)2Qdȇѧ'B8tP"(<T.J}S'N(7v;ŏ>=y )2iB8t4d;Ɉ ;$)#وaczDI"nH 'j7<ϔ=!b(@g13e' ~wEO|*9tKѱ$SOrcPPcQQ{ Npq-SOrA>JPBo莠7tGR8QwID%odІ7vaj=R%U9 )OF Q* ) H=1%ˉ,1 )'ڎJh< *~Cw'ThS x9hgO>%)W(3M '|Q !Oru$P/9鉹pJYC}>vS\&?}q%Q!McGcGcGcGcGcGcGcGcGcGcGcGcGcGcGcGcGcGcGcGcG~.ǎzrG.ǎ:r!cGr9v#cGr9v#cG+r9v!cGp9v!cGñ'dhTzaH=!8ӷW( KKԿQH^kYzAN VBC˔ VVmoiAN´ʡK_Aui8xZŭ.- b_u)/uiT[եkKuI۰4dC_2]۩2]r^j2J4|LcyLZ*KeZlARdLkYFei F ]җ,})K_ӥ,})K_җ,})K_ӥ,!\r)K/_/e;RސKYC.e7RKYz.e 7_AYO 0oX[Eڻ2m ; աW"6t_3>1*-F׽ǿotO7w67g7>;#"ȄYӀW饪oi* Ts~Z^ omZ^`* ET":ez?+K`)* VÊRxD#UjAz5V  ǦgRa|λ}TO 29vp\`:riN~Iy~];u 6agԊ + +@R Ր^|WnE)oR gueEz)D% ;!ҫRxyƸ 7RżԂRuߐN*-_/" 2HIpjH/! aA)V;R)(Z^ /2XRxs|zqI5Zp@7 \ނR!DˀV I5UjAb&d@/GFs?+KetEz)`j ! R Ԃ RۋFn Q0?#5 ~qǤ 4% xMB9/h+"ڕn-.ҏl77ZӮmOhȰqsBq|Fc{!j?`K%BK2HQзTtR aK2J&-`T՗LR!otR Tl'z)!饖@Tf[r\iM*롲^*cfT!{)CFOg!TZS/e(EP!h o(Kv{R'ՐQK2J}H*x=I5dz(l/Edw4d7)0ʰ H0 g*6d8M慳\b8(0)0ʤ<;vAF)|R R'MR88ܱ!q<0BLXQӸ[d2/Km~8aʄĩҰB )?=yV )J_5I;y?%9)=!O] \wc ^DlEqh.pn}!Aoj?Cא^_~v8Xe1S~/9]<'$Vw3s<} C7`w>bw{y.3rO8F^d~~ϕ|.],"<<>><|_Z1p׭Z"y~̗9T\> KrG=tSB᭟)F=O}Ev]7ckUE |b-wmaCoM"GWئo>O˽.|J?:?=l_,չx۽>?^]W'=6fS*7<~bӮ5 `H#/l/<ː\Fr ~>>d#Oߵ) WΥ~7{@=Ҵ73k;iBx߼IGv9ӳ3R?>ݾ0wU/c7y[tv%ce2nx$>F>OcGusQ'V84ݩ.&3裕E>ww,wM#-s-}Y,Xc臻辶>NiJ9etLh=fvn*۞Ooí e~ьA/KٗI(~)#C/w-CCbRMYEs?*݁uO)E\7AO=$p/簜rýJg~q7q'vnz3].jVKo0i,Z=M F#ߘh^pw|h ~fpDzvF4-JLņ w" AC ",ˍ{Y^RUZ+i3fxSkcs)j(.1Gj(l2mN#ox&T:Jg{a\2$f˂UVhлa~n`~mmgq?M8Ce_bN7^Ov2E x[0 ՚]:S%<M!Eɂ|NU77e۟Nx h~96~p2볱^r)Y.qu)+mo^cPⱿ8N޺ 1yTx_>^?S @((x?g[ܯgx/iEp1 rK..yg*Ti><橌-+3#1C@"Da_o^n_׍gdi?`B4 i7Tc&i/ώKX7'_<<SL5KU'O߿KaxuOw6T}\?a} 6cOGxJҹ19˃:=ctK?xtϺΞ_<~ώ_}p꫻gϟW_<$=ӳ?xw8yE9ea|]O#Ϳǐ:Gt{wxsxgw|p`2񺩏[a,>N\VXqɎ~Y20OǏڮ-<%_wn;XAxx[CK' Wc^̖.J4ӷGqXs*Cfqa>jW*V'0`q0SZ{P"[緣O>N}-{}3ߟqE.+WhֳIP7|싇[wxuoBHY+ڲ  $zHN_ endstream endobj 218 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1629 >> stream x}PSgK½Wd%ckUDN]ŭ--Vȇ@$ AHr>" ")؂:-S):p.eg3safmY/MNg ڧƦNC]Go٧:Xq߮&$l'{+UB"9$'ADG$idB1OKT n%e_`Mx^5|IL>9˜ǮqUSͳ`:rTT kj۳ga$zszz{/_W'PK-yrԚ1ppV-}16,F tܹ68a])|j\g=RkazI0Xyk.0cU3̇4̣ y:ʪOK˭¡[ `h;yxzzyi0 \Σ U-\l FN4`'h0z kҶsC9 pΡPM0eRRf)5M8>J>"jˆԆbJx8ԐږkRpOWn侗v"PbϬmhK}s@VgK|Pf.)PQ}\c &Hp+7VsE>oFF^%jitmqHjF!EPs\dN^1n=ӓl&YW#4t9 ?F0P/ʓlܳQWvkGy0 -T+N:⫀Qϵc VV+wU.aʜ Q5T;*;Fx+"ۍTG~Q|\f7;Jkя.z蒣t]JYPƛ%Ή| \yRzTyw] 9§[o+_)[ ~qC;}1zi8 (rq6d@+a(u6}N#;a#l}-}ddx[!oҹH[8՞-l{9|OsQc* 2*[:ݬ01WP mv[eHȿfjendstream endobj 219 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1055 >> stream x-mLuZ( a.tsGq!YfI&q0'2@GQ(+GӯJ)8a.c-n"}Aq q?8"'|q,E8~担՚J5$H=吞2=y28]ԪNbQ]{+bi2 RGS'ېh2cW`-NVجDFmP;qhsq3mWyy@0V`;=ܢMG|SÚ7; $^Zl5~Oz 軏*֢v4. q`,@F_3A2 ۬v2ԶuC4Np0$:g8hGwRfģ>\eYNE/ku$`k@4?3fI1ӚJ $BRJ+ɾ?͕|^1zdk(OY&u2maHUUMc-eo}׀X{]f}>Q^W!GowГu8 lV5L$$J*\`r rF{C_M16Tcrڡ\TF0m`b F]]ٲqnH%޵;pşIB쉨@< &Zߔ+[BEe@?7H|cA~8sRrV0l! § Ms,ƨU,7Ewk6M@<Kn:02PY{h@_%RU{fMIg|  R{pc0>IKZ ӪzU0ڧ Dy$xSЬfkʾl 0'#elË_^_A)k&V#~G<"+4^[x)ٿw 4w۹H o 3q ajJ6}#`41?iZ Pendstream endobj 220 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 163 >> stream xcd`ab`ddM,M) JM/I,IItwew. gO 0#2&FFk3'0|3{Šj?j˺Juϖqm|S7O)|Bm\۸帘y8M8w 6dendstream endobj 221 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 206 >> stream x<LMSans9-RegularJ  1R3Zv^#J4RxJNM''SCuPU  To RUendstream endobj 222 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 239 >> stream xLMRoman6-Regular-  R2zcOf}I|:}O˪16-X~_ȱЋ=:D\BEKmlGvCo  To m)^endstream endobj 223 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 156 >> stream xcd`ab`dd M34 JM/I,JtwXew&ӂ' 0cC ##5|93<{-?V~u׭[gܒ+]yi-ùgRoo s5endstream endobj 224 0 obj << /Type /XRef /Length 208 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 225 /ID [<298ad71577b83807c304605b8e3fafd4>] >> stream x;Qsc2Sxd DA't4 Bb*(=+؀F P(ŗ8QP#Q,H_ثH޸;QoD+AE0V:g`  čg0wa7tbmyAwb%0?iV l}2m D5{wBʉ:2}]4!OS~NP endstream endobj startxref 143349 %%EOF Rmpfr/inst/doc/log1mexp-note.Rnw0000644000176200001440000006606414355605130016267 0ustar liggesusers\documentclass[article,nojss]{jss}%-- the LONGER version %% NOTA BENE: More definitions --> 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.pdf0000644000176200001440000044273514715653116015452 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 4622 /Filter /FlateDecode /N 78 /First 660 >> stream xǏCGr2_7l4\ 97ȹ[Ź񜛌s㽌$qnMm;Yf)A$-3xkBD_qxX/U>&r6qhpbP#8 ns^W0SlFոYT{5<7`jL~UOmjX4|> p5ȖMEY   >vzlPƒ^4k[!k`52e{:̇lLJˢ< ,J*j{VMpA|ck(boa9 U҅%Jd8%Mr (U ƛ`ȼ I=y<J^+fhUݥzERa&H<׿0s[ŀjNFY'uq.#vN{dWKY:̳eV{l0gl0Nِe,hQkFՒلM>/&ٌk6cs6elĔlTƫex"[!44 ͒~f?e㜭G!0!#4r7IH|=*֒:tfiy^l@-7u[wuGOl 䳣Y+֒Ĵ% (A=Eb$GX HuDLPJ8^ioѬqff%؈-F7t E8{}z!.fW61]EObskŮVV?ƌ O3MG=DҪ-·.H}Q=Qi]!M`Dzzr'u|q2Bm P4"t%0Sk6rk! C@3?[o-(9Fm1;aOӠRRjsKv.&y_QCVuU]Gmա+X6^֚3ńexeNYi0MRjZ~峬]LWņ=rCiS^qTAͯ#>oryr~x.v~[Ca }utZdu'/f?U6[Z)&:̺٘lEd=%MS7d5CB#ƳT. SV*B7nOsbJذQئ C4_}"bX%=Tӗ~p`RzW/ίYqkKӉ6jum ՖƫU{1(1Z3du,Y؋\_C雫w;-+`oŶ@n+=Dޜ &>4z$mDËvAkNֿOO^oDY##DKc_Qy8:]WDgC -,.uP,[E`1`"7&:l |y[3>@CONxcƬ\CB|h| Qe|-2Vڻh켴31 ftjG8(٪T06w<:F#vw2^dGD7%:gr{vUec11I5W.mvڛ=zӯv2I m4D72s6P _[LC*irAoYu~){.ϙ.&8xI17͊"XLrO7SO/^e[&ɭ.ޜ#s>ͻ)[RTmnotBG}ovZLwAecr_`3:PkWA`u҂KKQ|:MM`=FB ~-||s~0$׌φٲ̗!_4MmC=-˅cNO7K]@튀]_goniZVnkPAn_>YT03U e"-%Sܓ <(j[Emz]6 sxhV-532!u3txFTFcJ"˖V/Anh-mzI](d\{}~R U&e(fj\$9%嘪~˧Tb2q2̇Jy|R]abi&? 3`)f@y2Rɛ:SD&*`C/ه`Y'9>HJ~QFϿ_|U;wڵ?gq K?Z[gwJrn,Ys]a7 u?ZO]: 6D}95Y a# n,x{*ų( DG߯/O_V/XttFkg/>d?}yx'rdo,o9vR.( my4ٝyێvRlk)0Mռ#A* RV'U>zbMk^g6::Q8wS,>4K8oы+ iE(ӗ޾=;?{S9O?٬{pwVڋ|jwA4"VEynvґޣ\mYI6a^,\fʵq|Ꭼ",VaoM֦^t#cy^[' ~ ;*CUwI[l}h\umh\uڣ.5ak\V6 6u;_'`:,])ϔviZAxI9fߊmЯ^wiE"(-H$d>x.@)jX/r$+j{;228Otfr&͗ReWIU[8TeT"SoFb}x9@*SR$?$׉ԺN Pqf`)]b `AICDY;bRhO;|҆ϹhF%;ш\$c#$D(/\Ф@~ lJ%.mۥjd"öEvefcX Jm HºP!ɮqm#'}822^0<12r%A +,/P)nGOg+l|V鬼=gtQ8&AT2Q'z lPq9K\"_Ճ(٥sS*xR/P=kc;* yf*P iI<;9-.& ͊&]BOWkR&2l}D"_ɴ2{lAXԠIi#uOi6L忊2-봜$Y9-L G'Zy&wxt0f3p+H"/r0"I * D>ClujXxF2JC v//lGf0l؍`Nqڻ 7a;R~h}ipL PoHf[$1Wb}>#c4{C8 h荓E?nO6F#`h"͗ku/uvendstream endobj 80 0 obj << /Subtype /XML /Type /Metadata /Length 1524 >> stream GPL Ghostscript 10.02.1 MPFR, Abitrary Precision, Multiple Precision Floating-Point, R 2024-11-15T15:10:22+01:00 2024-11-15T15:10:22+01:00 LaTeX with hyperref Arbitrarily Accurate Computation with R—The Rmpfr PackageMartin Mächler endstream endobj 81 0 obj << /Type /ObjStm /Length 3367 /Filter /FlateDecode /N 77 /First 693 >> stream x[Ys8~_U2S5*fGN&3;FmndRC9o5HJ EɔԖA@ r`(V X (u`-0*5XKVcd80'8SR8@pS1`Pph`To$H*0@RmQ 31 5* ҆*"Yc !pFL8* i0446`6XX`9> `bk@f880Gd NIl΁ H L0p,8'&2)TJ;)>Yo;(z40q#!Ϥe--QH99 L*w5΋a;$ZS` ) e NSgc*3xpK H3B~ IqW`U0rPzmr[-ܯٳէ ȩ_U',!xb.a=Fh o 5&#M<~JG" T_R^QE\֒;*.l&X cKVrZ"!476sJjJoavi=[*qm[vy?@a4o^uxQoL]RaoXgD_x;[ijf5lwJjh&55-nڢdš1q:$W>VZOO^~rv<}r6HO|V̳ ,?WA0'iTլ̖UQTڐ]~ G=l^]2TvVl5yk'W>ni|L -)jZ)mΏ7rJ?5/loޤ7~7^W"W M*˯v\T7Dk4+ͤ> N )֘)&8L{٩^g.{ }WQhǩ8-pwz$/|,+tniS5'0=l`j8,A0Û|ߏjK (A]\+AZŗkH_fyV}#7Y~"e:f"RNVOdOGBTzF=#g{5fvO&&͇0R!45 FDb)^AFlD\"ݦ r}䲸-I{DǰU}W`?.'՗חE Po4P()G(_19ASdG"F]͊]_&*N]O&6_&z>^Cn{?c>*wSA.e|0n󏋺aS}LK*H9]|Y2+H/೎y$yٗtC"rl*dcA=}=j@Q6e%veRuq enx)^ @p;FqxE^0`rn@jRɱ^nKtdb)͈'KRv| 筬`w*2.tՓKlNJJ=ϖ&?~=j]>4\?E+8JnpmꬆBq- /56 d'kJdt7y{tOAVc;YxHn5Su~]tݢ a YUmX$H^߇O0ʬEMaҖbtx־AAR2A JpQPS$gdBIJ>77)O.\[^ddAnHN,]mQ6h u PUyWtuM(%_ɷﶉRC^li.ubWܻ1Rn'ܣ%AIYQuL5ѶDr8rrr| C͡?ޏlbtLqCz۵oonzv[]i6 & Iɬ,(gAKп>Sք\dVvn'Fꝱw]c_NkH /_7K4d%H óCnv䱲CB{B6ǃ$ Q04EGSщ CD"y "]kgGsq~3%;T'gXAGZӓћdtY*e:^/A*ƀv&163(0ƌ')n(J$6b~{FuHЀNx=./};qrkYݧ3O~0C糡~QhK [UACvAf6x?.:r9Ss~~;e$endstream endobj 159 0 obj << /Filter /FlateDecode /Length 4079 >> stream x[Koޫf]"œQvI* ꂖeּBRCsfw!^rg;;Fnξ?v\v__\TpvS_+w7y(*e𶝆fhǪVSf y[% a0;2&mt)#-W4בPI8vRPb5TIg[jLLP:#ϔI j,5F`|/[ BRXM:@bt8Y @ɡ BR\l܀Vz'8eƐv9Z06A]0d_1tGnNgc ¢7Z7$5Xl V%Mxֆ[JF8izZҰYGNC㳪ɡ71 'wk~Jks͌1ÓYt4C[zؗ*}83 3ߜ] p߃om"MWR ʸ]q Xj퐇aaI?|0K>MWJKY߾ƁFD/yڷ٘+S !p-vaT]0}yT~Z)IӍ Q[_+gFY[pa#ǕC.*s#Rw %FO3iv4]ԙ̋ԟ|̓qsg cQt'[mb3wcRaa'eVus2Ūt=eZ2#kcJs|iθٿUYUސŴ\9=yyS3?. Bw6#bqgX? آXkCZlz)^Yٞp( bu&ɔx 9G큎RSfRG:|# =zE2hI+Ks;=:ލപ5<p iWX5-\scpZHQdѷN a+ahGv&eq'r.$!c) !.vm,rMS翯j>HK/j=\ 7L A-w‰ͰS0꼝އ<"he(`9w"Ad!Zqܘxbq|} iyUa1 ,t`f/*^ @;_8ܚTIIv⫌6s]ŮCB]0y%x,EEY Ge-cT8 .H򤡕jT(Yкl)} t9ٳ9r1?'XJ{4?mƧ%\c'8Xq}E\j^Rk2p.$!p*I%cH(X:әF|sΛc$W%*Jqnt)r5'NPo͌[Xwҝ?/0hFhh e(\lPW-NrT WBuendstream endobj 160 0 obj << /Filter /FlateDecode /Length 3327 >> stream xZKsdS-`L4rRb/!U!wkP2oɿH5N*j_?Иf -O~8~tYϾ89;8Bs|vq{В2fF@.'U uɫTBS'$wL̑բb 8zs񷓳sP9d@uٹ3Gg5fVVk?]+*1;9GJ'\KoZh(D[*nTڂ18Z+s1+Ҏ$_\7a W mUz1,W) $󦪹2rFqkmcZ[iYzopSf֎ w|.ƕK.H+T 5ӝiL/GManbX5Pyԉ f1hl2ji e\UU#0eI>tf3?4uVbV5ʘ0d? +-NAKE6 ("jcGBR h-HޗVAx糚q| Ӆ3.NQlǤd 0qKqIliU-,e\|s:i@6(9V\8F8tݛګUz9imFfq ),}RJ3M6HiQYҵ7qbVrZkPD$ Y7ׄv1eP,q#81-e! jPM(I ^D%o.9InzOʔv$x{?D5"9C5k0AJbpdJH-NR\SffʄrEx1*+>N9ju"c@e&U c̟eW!>p qϹ ?K:LWΌ6FLEt@6a9} Tr =uӅ=(ʌ#]2n3413)%ET8HKI)j;1lvAV)j)rE^۫*y&6]=FY-$Պu)XtߤNjIt!ʝ* :e*x95 ƸG{*2NGPS<,U֊1\b,*1rH??Pa=2o=/-iv_G/`5ٶaV <KY*KlӾ,iclpTh#`1U-$zW"-<{3)Ӫb9Jj|,kW 69őw8W]5{SH,ѪluQV&>7@^x~_pCVmMִeE6p=ˋOUo)9Jf&;!;%no;ghKm(3mH`G}h3GYC%>m67{KPIՒiO,E0IpZRrxY`:pڣE;ھeU;K1)aOX v]ݺ4<0A910"p~Ai Jtc a)7ӥX룊}GsO' Om߷VD6O"2:"5Zd)~-K3_U =E=:Kڡ [|}C˂4X7]a7~Ƌ[_!CX[CQW*A4XVIgWi$/ J72H4][D$dma *[1WӒLf4b_O*,7+(B$P*ؽ $o6㡗p5Nh0I"f{ڱBëQs\<6)j58A]}j@-ץq}V_hMd[M]ګn94EW#Hʶq]GևwŇy_Z-QH)f6*ٚ?C1wd՘̇٩ Ѿ>j[ߊdʷ"i3=5x!b"<^LȽ1Mҷ_oW`*nÜ/P 1Ϗ%5d颸To2\1LֈoO576yww7[6UDi/+>YoWu)k4x+6п̄KH:JiN^ q{7C%)jD?|}[ ɷfeՂ : ǔ&ۈ xtQ&}ɏ'}Wb-ޅfP=<{K t>u-\ouN]VY[4v"*oCT`R}+Ȧ+5bا m?M$N)o2)~!.i71U{zxW âA" Td"5'Ċx/&{1!)8S IWo*dǻk YtnzF8=+lۄ? rE3Yz#R3s[y n0'Rvߵa1zd:;i<@&КpKX}mVÎ}(WNp z~ӷ3M" Xh(*!? ! d> !C~p_CL6>6ȍP_ylD)O&*c}Ƣ#\:y2hIÍ?h7q{ iF6`GIJb jg/ { w x߀ eg\'Ќɸ۝cܹ݄r]k7˛+I? "|r^uzY,i$YD?L}}(iendstream endobj 161 0 obj << /Filter /FlateDecode /Length 3318 >> stream xZoCz`Yjw[ iRHPGJ ZzX呶 w(zj vgg73bW ^mWYmVX UqFsx [xeyeNb"\|jXuqzI>eJC{6FJu : \ .t)jKfݒ27]cX w -}7NK2%P+#|n2)˝Ս2YgcdAyqM븻@(ʌJ_`) Ry4h &riHQdEց]?ԍEd%u( 1[5S>,W5nO- )H}AI*iJw S`}d ˺ 1 t I qD ~ٶ)2t}z]uΒvm%se{4uNBҴdӀpLpA6\I8A !(4ܢ>g69I{Xǐm,7k+CaA' (0S ̒_9TYdTELɈ<,&쀦ZkQh!;bK fxfn[Βgޅ*djhF`Jq1%gu#ۆ١1䶷TɽÎ׳uu$x*F]Ç`m7qŞ9Ujw.>\AЖuQ ,-A'@; |9p*Xt Ԙ0K(PYL GY[&nd+Dug $}~ZH RdwBف6XL1P Cu8TÔ 9[DB%$1x?_L/ ;3'wM,OM[Mmn_,K8y{MkuwX_tZ*z@lt3R'3#_3(<d;(5-)zWC%Eon1:eÕA6>HCu!1&Y3%XeT_ 1Kn AL9)+& * */Y~f)s2_.AiԨɤӣG==%%,I~lYH?Gr9#-Mvu.L*_:H1,;]ɓcL={9`|E)*x#O&aM8Th9|!5Q׋~Xpm`?8Y'!k10P y3'tN˫44q7K2h˰T>46gt6#z+o!65 6'SYo;a*o/V?”WUE) w4Qڮ>L \f KӺQ`C#nvB6oߑ3%  A CIjp*ۭf^lɜ;`>c 4bl ntd=\-AVRjQ!6>b^y|di6<5؏jH1_كJ؂뮳h򅤸89HTmazRܨ[6hh'xqbs'fg|A‘^dK;O٣ˣH_Fkte{BwZqL(6.)G "%Byۄt# ieT*j@8*bn>CYc( }HDj"Pߏv’d 2e8{zض2j|n׿P b$g'l{c+M{*]ɳmG!TbWze:VʃCnӾʤ)3rh~%K#qja;.Y 5Z+LWomX})/U6T2^ƙMznlm2b*(NƷna@(&AҠ0!GA ^9*D3WRL'*(j6'=\R*xɄ}~z.LuӯgV+Ve%AJ #l]IpXo6< ~o,4#GF|G-:КDJG`l܊a;;=]}[_w-nNx߃uL{ ^ʋ SG> 0/\ASmŹ_<_5)ZPm ~.`7ΏsJaxO?FzΙ|YFPa+NIHw_Dtj[Cv>i/p$-> stream xy\WǫiDDlhX% j܍%ƸD(.7싀4¾udEdiDB jbnuMü I<ߧdן{s25$+VN}k ƩI's)%zE C(Av8:swܾbNO/>k:cw}񄉓5m:GQ# eOVSj 5ZKQnBjZLMP5ZJ9SӨrjeES֔l)jeF]Q`ʒbaB2fBI(S*| eC(ixkFg0_X98䁾Ǚt"! 7ReyȦ s2аa¬WtpIw0&9 4B&4I $2a/hRBR! H=܄2 #arӲAKoG+%/)*y~ CblYt@@P/,Q܊k6[41Y{E9w27^/f|樢t_Q8 C7~DI<[1TbAr 1ͥh;)JfNEuD3y1Q>,JN#Ut &tB -_81\\D;1I}X?އi\/y-/~ Wźl t<e_ں|ؐx28Oo7QH2N@A]( 4f_aI[v vgO"9`pp4O̭"e*Ui?4;D{a .D[2YNߺVR昁5Y=u6V; FMFQf-lxUK/0V^@[ז wNx%cW4#2qH+~NR9{-4(T}(0t|f2q$HðPY29?xJ㐠=*qZhv]+yzaWP']5J`9YMX._m<+qA|2x%im FR%{K7W@k!GOڜe+sJP$DǥFe(2k2%j nTLj$ ; {S@3K%vR&MkDHz^4Yq7[n̝\qc|j,=Z[p_Rߑ[3A; BT؉cKǨдZ3h&x~)TIw@MxDOC&9Id P {RuN? Iydظj vl@Ğ ` yu9R>'aƟ6y2(-c0GTa^nD)zXW(T(2鎅+1K^,+N8'3dC10w-2mNA&Ɨ'ɵK'qbHSC'2m\fՅFѧ'>!9 lc~]Dn[w.?D*`+ߴ9u)cAg5 * ^$F"M2x:VJIIԦd9@a1>N:Fu=Im[@2DCL.*ChIgs'j>̡螑ul,Ĕڟ% ͤ7P@^6:Kصt20p h֙4Ih|JJ>akTly@茵q aMdS!Y2?xL؅fҗ9V\ > NMz+Ix<$`C|T{!L NԄk#٭ ҳM LצB)#KŁ")XmLS.O]̀k_ůI^fׂNa*!#GO##Ȩ3\K_O_ݢl@j |XZ;! 9Ұ͈d%Xh/Fw@5 q6%* ~Y E/'u%Kx }恶'<')h98P3fMܬ~j-a Vi#.ne#rN?5uՆzG 8O ]4=pk" Ï)ǖ|LBg7u mqB^kTCJ6ԏ2jT"YZ9?fĮ4QAƨil\Ujjv}-zύӨ JJiw\XY<%Y=ߒ*90@#x{4Clb 4cAY5{nfo>>=~ثz1|_%}/cb:z^n#e0֯Pobz?\^G3NKO>ǡpn(i Dݴe- }S7i֔C-+#xI(c@^4@R,^m߻ecjؔ(AK&b𤙎9Ԝ,./00E0 \ώ6l;U ($hvֲY¢-PYk 1 fl4|vҦ+P )!;.Kퟎ$Cܹ$)؏Q6U1Zr6+o{3œ1ϓYu][ ^ oօkr59ܗIYQnvWP : C&n*ldAVEL`!A3|4tǡ2;t`q~rO*r90?Nn&bx޸vpD!3~J=d8Hj_22<7 ̽G[sŜ9!ƺ߽yTC]C n6Y8%^"h=cp#[QD{\.OL8_QR90r_|78 q .abEiL^?t_AL.Kp?ʤb@J q eeX~32=WѸN'ߍfxmyA&up\'̅}rǁ(zF|ND6nلu¾c%KӹS%t4_4w"OHxlh f89CqXQ @z4!&F{Fb\tRdO/]K']PHSe53cp HkvjdMb $@2'sr4Qi5x!T10=0}8g3EyacmlfV8w t6=$R9ٳRDN$Fj1⁛ZR~&)3a͖ǼI4Y$cW$g4,!«8بPfX6SZñc GmxQkyU q>d?]kApė_BWdhyrW{mq꬈f2yF?]sZ,Dlv8'O.d gf&|@eZjZZ.5+39E9endstream endobj 163 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1358 >> stream xukLgǟ޾ K5*:Ö-FEy\**ȭ)=0Tr)*dyNl()19% Ku$HD$[#*q~ǶDR]oCa2𐀇IrϞWjoHAN$+,"I %(1)=b?Y/ &cbD|՗رNPSQ2U[^;`aBIB|/@p$й "  p<õ[@j}lOؓYR<3n~nؠY+!U[]-)⻔58hPᔙ42*'q Fν!2 PUj5Bb䨴("?f{Xt NPqt7%^y|r֧k)(FD.27 $ٕJsy1R)+0-}qFgQ@:NST7譢+nkقg>/NHsEͶh l J9:lє'.}sL|^aN;3ZO nHqSV%ȣD͉3jΎ3n4h̺$::,dfkL[&!Ƹ!lxk"VEx?7CpO=8ep&, }pڞy;4UהŐǦeYt ZXµE ]UDr Hql'h|\{oߙ3|uZOL1"YʵXpҥ~?2Vs-nR kgs, kW %yzdɻD#"#T1;ݥ+<:,rseeC *endstream endobj 164 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 8045 >> stream xzwxʲK3EXB %ދmw ۲%$^e˅BJp P2k{VBn=̙y eoGI$yz>dGKx1?6:@{)10 c;~މHdmfx{,ںS}VMf{3g:O6?|[yl]m˽Vxy^{OxI; xA=~wuӝBjՇZDSPoRK~R?@-ޢVP*jN P3Z=j5N͢FP9(}j45CͣRqj<Օ )eG)))ՍN8QmM<5jOyS(]ʑDROΔX %$JtvJ;JBSjꉤn]XJ;,w8%.7͈6ֶkW~\C;$9pةcRǧtySo' rKJNw"]Im[;t~xt }sdϥ=&ݮ3z>Uu7~jXq5/4tBJTfEB>5"@M"n-?(ԫ"/g3:^`-33&tv@#C&-$*Eך?..'2ǫ)^cqB~љJNp xڨ|Ϣ0 mJI/iZ)7h`6EEfk` l/N^8| G^yp6/6{vLozKծF%O ւYE1X!v"#D4HRB%魺iYUHB_GxOBRsZˡI(p$3%AMbk̗:>;-X; Oߟș߬¹rfDuf ҕk*]1iZef6 rt0"hMRa;zʱK'(ʫr4ٛ8qL:AأS!T}f 쀇 L5 1GZ YU3;у<mnXՙ~m2h ]1'. 5*4ܢxq;<qc0Eƾ2֥ycI b*z:U}̎"c;c<6-͜ .y3f ɅlhN#6Q^ GK+E1eK⍈Vmu40NmHL4īUDAC|fXXșL`*(e33iT0Q Wޖ6b ƂYUE1kĞ556Y]}添#H"oe{@Id$q!.8%}K-tHU4>)c$[JcwB1yN\ b73ob'eTo-n>!%SKm? aZE >}BpUY$+롈>:oie3ީacHb0%d ^B=nuQ`]i(cf^ijK\KqlvCC Zُky3t&3 c2.epp&=G?Ssb),Fީkgv_7C0bHђO$eYS}HΜ JJAXf<,,/(48{C{O*p0c(I(]}_Vޓ =ӆ#qeqR~.C;`P&#U-b5eT*r$ `W6:BF By$4}j7--"'(WU5fԠׄ3lZ o{u`/ԙT/wWh7d{T*͛{!1SL!/6` %y׫R E\Ch0_=NN0!H-T r8{`86X6>ϰ8SB^;`5 * ' 3/L:it܏BTY u03H" js .ko9fw'Md%YdM\ %q&pnIycܰA۷Yo .?PNHо7Rln(R⽱+zqu\x? \L:ܢR%]yp>vfk%op_ATbqꑪou@(2c= % GA5K\Kp%y%%1%N8 pfic6nԺp,T9ݍwk*:R [+۝]}1.CGlˑ5QGVUp+*MoܞC$AI~Q^]!0]x..DU6Y f&1A1LxvL^Faj GfJ~q1AnG%ƪ\J+Bv3Vocv}`>B{z)( voqqacd/6/՚<ك ,xu3[<25o3` .B}aMWUG"?^E>Ԛ/pmz)Hy5v{̆m;{B*, | dPYsM3LkIx5ntf]yzNbrJ)S5*by鿝j JVLI^T-7箢 +׺6OX )Q /CL]02@b[gRTT}v60SBq}+vospj`1$WŴIo37!ܤ(gEP'}O}q]u!4^\KjvӬ*y8,&jPD@RJoޜlg811rv )T 3a^N ŪyEc}3$u- SB !ҙGL"E/x|SH< Шxҋ8* y}]IhN\հʰ0F&+PW:69`p8cek#^;&3xik%̄h "HeajorhD֡VwQyoRvkiK J}lz @d"!< NHU%?V_mQNFJ g4 O7_z1ɉəM_b[Wto^ER]twթN{Ǚm&9#$Y[V JiLNGJ,\l*L? Nğ!3;{?| p`xu(`V=w\XkDQ"ܺR*Y!'2B&@I\2s^Ԕ Ɉ=9t$*xS683#40H;Tss(Ey-O$yگOշ5F@dc>SO+K}|}|J++KK+[*i8\|uz(Z~∌{>;t{#O ԡjӆu\fL]5|Ϙ0_ᇦ߸l^p+t]~g.g~pӹ|ꔕL?t̓vTvcfJX5VI{ɌZVǤiU88:8 :LH@H4%1~I lk:a@]hiOq0:eB [I}5IMxYo|\`!Lw}f$x$;yۗC6e?T]L טYr4s#/aU ܃4/v_[Յ2d'5:B> :p.S7(.nfGpiɥ=t1# =mim1FHF{D0-~+8ןxÿ>:O8M K߸#2>nCf˞<ȝ9(q8F.= e겭qz0踒ם'؏'ˈB#J΁@K`l9ރ{pOzpc>7O טN7ydOKX%_d<"9Pcv-0{O/ߨ^M`3!o&d7fEzٸiJG[U5 v3~E>ۣ6nJݟ9[/J% 9_XKAJDNR&gZ9xahQƜʅrQh8f#K3x9P'qmءU8 P9 v@(U6 @<ҝy! * A'^rn·t/Dv bN Wpaf zj)MD/JG[RQty= {ج9I,~?1g2WNzsp4q`&2W #{AjFpEg=1"As#4Bi(ݺk颍 Od?`f%-n7J6͓з?dXd|ۋ|۷M"YN5g۷aendstream endobj 165 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2784 >> stream xViPaqDqQ K1;* QEd 3sQ@@@vdU%Y Ӹ1DK^x5LJ?T{}GBQdגۂ§N5tb2QVwmp.XSO5/K}D-)ʃZH-<j),(KʖRR( eNKJ'ffIߑƘKSeaGZI0LEEhK_KaÐsV,+#)p <0&e) "`oڞby&ILZ8G o~~_)*RE2I欖7hh2&Qx9ʱV0K1'ltr{Z$vпnqfO$sdjR6䒇F#henQrX7 uM6IV*`Gw{q>|L a H=8'wnoc[E )@NTسť|vp(n2/I7×ФufG T<ຸVN1`vt}eq8Z>W\܊Y/j>8'%pLD'xyiS8_,1r|?<@,L_8HišDUM5u͞g%t5 ˚l|KFsw&gH2s2t &A|?4k0[@7<ȷ6kn~ڤ ˙.36c^ <8;r338$^1 =Jӊyr=+ڠڇ8,:b|Ya5N$\&O2h.ys_ws9}]AIM4^hV,?s'pC+$m(ćpvQ.Z'p`#FyC"WmƟ:'h2 ijpZMZ`jaey2$sK  .8$3jJk⋴ܑ:C07- d"æLE+2Ý*)zC$b-æhuڮsEiL|ӬW$2z1!ZL'cvUU[΋7h(3x8fÔ&5Y/hT܍xHOԥp~++6pz|,g{<;E js]){[%#͞'Mw~[*2vO񻤧!/{JTJ@;%db  ȥ6Qܾh .~iciz}j >`Eg8珦/Ok؃"mY쁤(g<ƻC!3f<_ZnFFvǚ6p/,^|i'x^)>Bp4S[7jSAWGb@܁LC3"MJ!I-*] ~3i@JGNsk)-qtsm!G۳\*+>X{uP"qδߴ SP+Lߧtz}.ҿH6"!jzz xYHҼ|`!wEh0d3dg7\-endstream endobj 166 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 201 >> stream xALMSans10-RegularJ  ,R3TvZҋ#J2PwDKP $$PDuPW  To MPendstream endobj 167 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 806 >> stream xohweuUF۬l{ C6AKvfm\T2jD zMkaN 11.wv/}<,aX nڼukZ|ǻF]nEw ]{ne:f=S[ðNE 52p)< ;t[EBE'l㸔#i$*x0dP^p]D>4282=caZoYpGG1B$-zD{MA,v 4H,!+KӺEy&IOOG&EeI!pYfj4!/g8/{Uif&҉V>_wOve)GF7Y>c*# /qQn BS+]$VYOc9#Ngܕoixbeڄz\H&E?1ʽeLs4qmcRoţن%-oMl>-9^qjp+ihS\IB2Aǃխ;о5%-Tp|?**x;{>+?xXpwDuG0~&~RB[ny> stream xXy|Suih,FzAaQ`DqQ"BBtMӦٚInf钶{ҽZlZPGQ罙yOd~7s>}e@pk'={Q!Ǜ~֌=gojr\ӲbBa<Əj{|Zd}w&bWg~u\quq7&ۜ5yԴIO||` lma,{v`/chl6ۉ-Vc^`װױ%Zl) ۀmiX2=cal^FaxCZ3l(pAEpߍ2.z<>>a7qĻZ';g x)[D9uĩ6U$>xx#tAEdL@`)RiJ1/J!EFH&-ntAmD*M@{>4o"FL{d+-[]ࡸWPKfh`|С:R9w bCYi^CUFv$M1y94I|#rm4z-jquZk @J{aVi#RZm`h,!Mpdq<.1!-h  >>R8 \W|e)7r3Y3/nMDB4&Ww !&whSw:kxÞT`%xF f h@YD_seKy4\,'r93sX5M^&[K΢jѢ(#nKE@SA<7|hpO6gmSM7ILN'vn-H5'حNUHV@ .vaՙ˩64VP qhKqׄ;ߢmgNE[-nDZU7 0}yc2vw3\)<_/h7QAO@Tɒqy+$C炢;CG| %@%TCz"i+k|Wƌ|Y4 >b [McՐ5Yx.̍Th>Rn-{RRm]KAUʝuEgoG6!N4 67J%a zLI41e7Vݧ~UZhqȂLH'gVwɲ}]@nz-S/| GpKI.6Crf-;z]sg-HjцKN 9H՞?rõQ{kA>)/@tUEdQaS)oh=w0BnY4lr$H`A,1XRd_P(sqG"n~"%qjLX8e?C hd7m@'t'6xoPh&;Zz QAQ@Ҧu2N6nn. *?~/-t- i1Lt^2]5C=Q[( B,N /'ҷ씨ܾlgGrSrr Uiog9q;Q9 k/lPPd/2NlggS9TAVm=ۓhjuOhA6|YŢd*j62&QeԴ`9jAi t@1FE2 PZ ij\CM>8ֳS.imDVƮ7C?{=;(d@+ DCp8جhlwIG f]4E^&a8tVv FC$}`^/ZDh_S]B ’FyTi3WnQkEu'oZ;IqgxS{&ZN`Pɕ 9wcT=}YlbpSzq<}ݽv;oe1tS \Filt | sz!ܿߔG\m zB4Yi[S >C{ <.QAm5 6D5 7XlV';&0 N:ۇO=`CJʹZC'N^ˬ kb:u ?fv8`d8tmon}ׁëSJpuA2 x񰛖Pz{Hѫu&B[n0&'ӠiE ˶z"d]H4Ш/ f=Q~,hb^􂗇WPqǏvG4{̱~ 6Ⱦu3'gq[a p:b![xׁ`J|hG^^-t=;7{,YC׃X)PF]<0FAdyT"@(˚,5P{켤݇wѾ6yq *#"xQGSm@ءZCQV]}~58ɝ1<#J~#@ѴDc%B+')>Z pn՗٠OWOf v(h쌠ٱ녈Ǯ5 C"G#e 1snkSx-))-zRܜ zPVV+ y Jڌ&-P( ^d6Z^HJh[rC& ROuL SG1,&A3?kpH'֪L';) S츌C&8+]%d(. $xx󢋷y>!hu "#ңs>Kpۚ&P  5ѳGL g>pX_nvSKF*3 'ss̒溯fq~eFB-7GSB_M3zLMVzDTQn*XCo=| Qӝ)y KjI)7 kVf4\ 3nbAYD+< q.^m,NW;e\H8{mwX'i:@! 46a':yp4T4y$BxhU`?PΦ ,`&$9 ܚb9p 4FGQ4 oF/k)EKQRj 8IiPNQTA!U(B AZ؍vS=T~l$͔^9TQ[-^o_v<=Z"|=B?!W )A7}|jj.㡸5vПTwO]F#qi$Dn7Fl{1X/x 6׆'o6m7_޾D2!zh5 HN-|]o( 8Jf)΍l_M$燮O]Rٚ,@dMiaI뗇,v=i^]+#EE{ۊa">6DZZU4[ERA{7o!}EOXA3& P,`J"¯+ pj+"&@2[Ľ`*:5<ŐkTTI=I4 &`A\dS,FB.OXIYdoACJeF+\/* i 0,Sd[Mj\ Œ`m * > stream xytTeoQXж ^QThZV@#[CB=JU%[[KjMeBB6ք%` Zဍ؎=|S{9ssyGDCDgWY\HJ7w]%9)EOq Æ8(c;^$d*N$LHtJNAfʮܔ̬,M")yˊ)՚]Ys |2EW Fj Mm>Q˩y jZC@S"YE6PύDXѷcr.{=!Y"9'+ǟ0i Y~ߟP%<y!q(tQO +g~ HcE ^8 w鼏';ے TizuY֞D }g np'"[*>b֑2ܬV2p%m}F+[p H,6ofd<]1(lZСm3w=tCݣ;YI)d FͼX4~^#i2mJ#ֱ&L` tuZ&cm  D0~BG*$z(yk/-`e 4Ӭƅ @ 2~cv٭`spN:yٷ?xL52Vf@FG>s~!_eZH~ \E\ow9IHbXZV0yvw[J' 3 "|oPHSը s%{wyR+ji8w)-DJK BCMϑ%ɋn:؀  =a@AwE\[=8Hl~ǒJEJ 2#X 6N;o*5/ ׃/\apO2 t7;*ReрmN?QBL<&3qleGkVw*f:ʽSS\^Rꮼ82B^}zqgC'ev?H3x=U\#Oް,Ж={IL#].Ulmlw,N)wrO5=VjZLV:{݀;?tM{WAgKUB{mĪuZF_뉴(ILǃˍhVdLٚ̔d0FP{Qsْ=`]oZ\Ktj@]@,CfrD3iG`aj^TqZ2eC6j1_-M45_Ptu"p@\ERe4X&V*JAVVf˝JP;u o|:g5tVeY16T^hـKzC:^/rL3vC)b-Cڱ`l(=>}iVwe6"2L%/4;{媷YjYb7;ᙻ?8ixO@UiFZiUE:WwU}rOUu- h=]t@ح4)-zXŠlPm o얠P  ]98Z ƘF8Ng5A|̾};0hx9Q,^U*ɥu. pW/: zұFrzX?=AdA@~E:Dx^)q]z'-( \/tz}x۞3fg3:ݣdrY\?ba@RܐW\PB'D9VX^*&Ic"M&o?a+QY7?.v Ox8F*VfǙ8Zq:P/VONw%Oyo{@dd:yw~ZtpӾ#NW3dytźT@ks\|p; .ʀu&vo)I5QVpf0qGR_I}f8\yƯ.<?x " <_Ȝoro -2M2>:Ge0 T-|gD1qbuiT4#)tHޖV,<㦏<a@$~#Ok,+l UGp$4P,_ 7W1y셁SK$NAPKrJU*'tUFNN \*OA<'vVkm| U"@{XI Iơ6_@6y/׊[u> stream xYwTT׷+땢7&FX*(Joޛ;Mhhbb/yCzkdKYoÙ߷3dml|}|ߚ75kzrR2 օrW7ģjX[U~-C:o~`FMn[eN,(ʐCx֍dEIP3GMttnޠU͊gLHA#{.Rjѷ,?ݥo}\ȸq Ev<5G8=.=HhLLL44=c*M>'N>i$S_J+)|fN[7=fBfxFD30PU)(:ﰤ؄$>5R=TpDku)N@j_o@NhKjg]a^<)OoGl8ѝNĵGV0kenwaϕ޽mX.ʥ0÷Lb h4zBr9?KR>Qfصj|Y#ʥn |tTA3ɩ3m6aɸf;ji?,fć̗&pKXX|ٽS˭nA*tԤxJ-Ki\bTpoI*1N~+p:l'nC!:EK!w$ ͛Z?H͎ho8Q.WF<)BUF_c]z;ّ"ska1]D DN<1|z@YH0Օ <_D$RȽ]Z-ŸiζSǟ'DjhqTPG4;Kz*Y-|;R4u H-i"# 6jAFiQAWBT@ 3nOJV]r)[5@OtXx{@E$uѝaA,BLPJ~'0iv<5 *z4 WI_V`f109媺GřL:̊/ /BҬg\5JMn ω!Ri օ}ٙ2#bSCĨ,zgQBVp ɤdw? i KUv֍v5RV3 T3] vdeZ`äѱg`ajNl?(٢6yUA+߯TxQf? ~銂=׈]VT^`svBN|aB!Aq^^qfWSxI[h>&d]"vrɷdgRUU e& 'OixabH1CA7q ^ҧsJIC em)oX{>T"5I=[F c GǶoqX|[}n^ykO1[.%,R_7&륔̃`F Ѻ~v۰TMq}J[iZ=4f:dp8^e ,,>%4ڱ5\ *u? dԬD_`;؟#gp2G*;=nϟ "6r px<9^ump}u-9U1[cχ_}.<|n.i)|=Įp7%,@%%+=ofhg;}j5q:a< chW֔6UTQ.JSDh@#sSr¶07 mR /]W6] mE\+]I7_1bQRdՄlOsózTA[ŞsV/[Q*2*&".܊6a1]g-^s;rUj: >#!a'U)degL=̓;v9457VfI8LYMa@9g}3yz'/|p|6)B8G3f8YZו`P"b' %j?=5FD+qX)KO 4>>%N_j*eQGOVOPv]˰WC>S 2ƈ|Xpm{rrӮ!!R4bUҮA$![1PxvcR5T[X]&I /\ψ(׍X/ 8z;ڠ"2[8za͓gwqysGr0 Fvu)R2iѿ,p'pJH4Q.y-cB0ɫ=<RCy|Ckg`Zi˻+dgB%Xw`Q ?F@b^%*ËV}ɟn3'n^GFlk=|4&;))))˜ʲ.fSbJ:+c%,',}@*ͨbO>BmPtE%;)^(`MAK w  fLE#e4 A #%x4؁sp<#d3TGexRS?̨$gK{=U5E(2fw~dz̃m27tG?gk㸒gVڜ}wmQjb]l-|7C$H׸3yQ >1E8=23 }1CGqą eX2n \ӃKs  ,_e9Ͷ}|[ݷO4,z ?tX*߹oD{ y+랥 ۡ]=!8Ũ8 &^IOtC1Fk'D̦ ?A fhũ9:@@$û˥ٯH]K Ozt27Vr GPvMά9E[9ehb˂j ;&zx #֭ !.bH!ǩ:|N֡N858^L)ߺ{,]e|-g\cs<,$ !4:'NMM҈,^: &¢cӹs=wy'qѡ';˛ʽxlWm8y⠣ڛ۷TDcheЪ (*LjB #R05t~M.r.sZnnmP(tau= '֡tqkVJ ɸ/ t4 7 JJ?|2[;+m>2OpԞn1?1$> !;EDVB5p!8/26> "&܋Ƙ?v^ͪ*oqu\ kfwDtrlJX0%e|#x/^հjSac%Ғ"ޢ_MqO2 !ń-vugYG^p+3A}>u+1ws./fh#(!2*'_aoV^Y[R/,sKv%'Spʀ,ζچ4!?"CPmωxTK>&|44"# ͏I~!F8u~BS- 85[u.>{d3X a(6 V2ZMӡI1i'Tt9Shۣ,-Bn+bbQP !hjB>"yur?> stream xU]LSwϡPS.z}d^,9#|u h)-kK?hO[B+)TQ&.,.w#9ev\X0˒]7/Idg$IH9F^_Jʖzz%́\fo!^{{VBQS-A5r) A%D)QHH@YIdɽ,@W -gY & {}|_bY3yP{/|thbkrEeY86zִ7W22dހoCqsi@#nu[UGkwV5M+ qrIP ΐo ^{|llnfrD.u崱`Dҙ̳KL>=D0xÉ7ai[S_4:qS4Vj猱9ԝE[0L5Rq}g9o΀ TF]Msyo;4×}ꋗKMS SɁ;'0צW(L/-Ç[Ikg/aZ+ʾHk E~g~39QA#xK_v_[h'U//Ag@^ | +oqe~gqAL6JJtj@s4O?|)L:O u^c~@M-X,~}4' Cd~n*Mz~$4&Vͪ`c&ZEK9􋈏d{5҃xě3S q uڪE-X,\7PSP-Wdrqu9[.DStP *@q}AS]8bӚY@'mLgB "V=K+U{*3;ã#T, WR˔Ze3gceeǤRTn/`w8:Ķؘ^K Afj[v@4D`5 EH% 6h3@7:0yFz\4@N ('~-._,wjhZP@yRXdx}Mݿ q@7  Z:V0#mM<7kwNq2 uEӞ^Ok;f!zW>/wVC.ߏĉPKs_q8>rxtendstream endobj 172 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7466 >> stream xzy|61tb ;HAYe-PhJM&ilMr,MҴ,ZS6EP^S4Z_{_Of999s?׬]1awRƳ;fBξ3j!Q&LNC`,.MZRJ+32C$Y{d]o] 7oNؒ8{yO^0e8O󩈧#%{Vb*1% Tb#1DL'6[DXFl#^""/OrbxXEbK#C ?aŸ"$F0 z{ 6o?<2xS&>G^~z'QfOJ=y0کTjՀ1 zՏ3 K NUg9rU @(W( tFNg'6@9P +-V)DÑ2hi R'uPS `mU@^y&O,\iښ2"CH^s@ ffQ4f5-#eނR yaEJDC_ A$GHzPLۧ=P{6LqL2 P+D򧃃R~}G_pz|=oX+9"=T &?1'}̂գ_c;L,1ZՖZ41Y!y:!9iIM'Չ^0{_/i}cMcZW6KpӍYc(z lҨ?65%(ZKZ@DWEhO#6# ՈVO^7]Wz AWe'# zZoY[ym'oqo J&6( 9 !1Si {}©Z=QPC-$P7^ްf|X [z_~ = 5Ӄ"y:h}kĂ8%rȃ(SI:Rc,Ř+5Fv)DF>bq'XU+5 T܇pE}}1pM$ᰶQe@z:w)2W_[aUv[C|gl6#yپ`JI  h]ٵЃAi=@mgA v#O`@D+'|v?[e/FЇPMk-^p,ekQxeqq d q4t~G)՘ci_`Xt) =Ցx!DE˞%Wq\s=WEW,)c8!di-ףO=o~?Q='E6vY[]?rph^#[`GD=V 2L0X Ъ$-ݻqH^sH8Zj)?3 ~SMhQԂU=( e7@C"s:@/1ֆe8e]Z '4Uz0H RU0z tMr6Ȟ<}Whn!֡kӁt WutÇ?eh+xV>Olֶ7P]]!{+ >;4QjBGj>-a0Ǎ op !"0`v#KoL Y>{C|@)w"~`06H<_ۄ ?@ c[ȳ- A\ PގwL8¿C~eq%l~D}B-TuO M$4\0@d"S]J)iD''Md ڦZ{ >lux9|\ZTCaB#\2{ P/>{p@y vڪ5@ L񥽟) 2}b(*T>c ʗrfɞh թ EZ):8`P32%)Z/4Ak!vq.e !xU%`,(ҡAyQmAs i2"X:K; 9dq/4p<GC8 c;>9B@b mApa@dUT# "q(y;𚿝m uP40jh+jMGYZb;YٷWyD.Gך<#@ Yb?mhh&ހ~48, [`㩊2R<3?'*4,ʹo2 QߧsCS4d~1KpBkC%~be" :M冮xNtߟ9o32hFwJ* iօn4\E#HϘ*$®ܘ}ꎴ8xEr&EbBvPLO>zŚoقV2^cGj8GzV0Ykz{?nMwZ=hGdATmDf fgZ+Cv~FTp8 7}jbWB2gc:Ufi(9īu./G"D~>SG|[q6*0ؔ z 7nB,z^3d移 P7-)o ? i`,؋~Zv^FQ++f/y]y}# ^[7)z{4eb!?ӐN0WZ(TN]x8%3*tqPS F.(,4NYA;=WX-62QɵW Ǚ/](H@k۵TH,47X6eEŠâ +"E.o8; \0*V,8(z<]:=o[xsM:(:&rDc\ȂU~G2F9Hr Guyh v"UEn:;/$x<)~0 WCS~H;s2f3[U@AF>Qo{] )h\;NXʆyv_,ZgݗupIٲ/TK4͑ J]d%P!kh8Nuv4+)q  3]}TB bt1"OnxcLzCvqN5:F3 6 [N'4qnV\s27 rAfrʡ~};&Gh$ϧ݁zRw8l 8~uB"s\ 鐗U1,gtyIk*UE[ [1'9ւ"j[o)6T1-x s]4JO om)(IЖ>H%(ڏ6M$N\a' aP qJ6%5L255,cMТ8)QP.K/a=7z1.@dw6^ G"]c6:x&J]>[oN}e蜨DW.'Qt 2?ÐUqj0(}re8Rvp8mvs@ ,*t,2y:W""k†ت d`*(ܙpI[JL 3Yf!j?^a P}Z ={vVi$B ӣQItoSKp ZM*sŰ"Јz4MUHݏ/&6mh6cf}uoa-E-`js6,Q٦O? (>6S@O'֙`BA9/`􉚈cI3/Dwۚ4Z^qE~ŕWLqhZe؜*YIb'秕P N|o3kpr?R{"DY2Gc cTcVfqGDVDĵ_>^ɧUhh#9 r[ ]MQ͛[;ϫބx/=(=qnti  -d,M7v4G6@NoZ_ oF]>.f{20'>I}QJr ~jf0r/~m\-E[l ܮKϭk9풫k/^\QTy`m*,w]ԇp4ZO$fOM3FA$ W[j, lV\ 4Ȁ4>^W@[^W2e TktI2֡rTB $r2ql%+v[gSSY)8H],-t@#5׸k|σ7i;{g;գ]LCuX'7Ha/Fk28#+I[1!\;W$wp:?UKhq`G>2S b5 $endstream endobj 173 0 obj << /Filter /FlateDecode /Length 2763 >> stream xZon_.En 'wEkѢ@{8F\bH.)W6p8Q.A7[vvqt\-x2K f'2ˋߋ/_X(%,/^-.7$X_o>6R$⛆ nZ?| }wXj-}2M4A{/afEVieéd u\ۛuasϚV+E!Y ӳ]ɨM&,PF36%(4$tK֒KB - ,hi@/[e6[5e$w~u%\5G鱻9 Ev6իa+`$u26 X!F\^mqڲ++P[z%|\5WMvK KB`l ciJha9`J12}wrti0bw3_]1 cϊ>NS691$űW?G_ϻO g|Fҡ' ),wڡ2|tp!=6Fz9xQv9h4 3Xb[F J%}6qx ĮX%^`$mƋ.yݪ k/eJ3|^o85ԤaPZ%EhC HD{ CqDf&|x&`i7լr*/|QnO`[WiQq b]uQ }LUBūl&m8Gr"IwZUA4:ܑZ GE)<2l9֘<8]?SCÔK5㇏lr9Id 3PZyӢGʌ ah4=>E`Ғ4Y4U|K:JlZȹ)!sR1Dҩςݾ>+ ZuW!&¨hq>Vb-?Ϛ€,Q\NHK/8P@~ LRZ%u|[^/[/-pT{Hwq/K %V]VT8!lLJLCcL$UIcݲE+ 5ul0M<Ŝ\GC,pxU" KXތ5e2WY̒)v{XĴ)EJՖc?H)I9$E Ɗu DgK#XZh$:8\a(0OMwJlx X^<$ `P͎GaQ4RQDFr(HyTMZ4Q%-^MTU%DWgQ=SX!.Qӫ3maIDerGXe ⨩6:CW:Ct 8$ 3RXQGkb0M[/12!6TN= ڟ82IJ&H2F"p~GxD)7쮏m#UvhS)K1 6rEE.O22%Vo+}ib}nJUBݮMU[ -&ЙKݪyxښ#crG(d4#r?mwo+͕xV'cǖMA'ZAn'mUN)RAC\XЏb|v >$n24zW^=GxZŇ-)ʶyDtQ=UjcRXpyO{˽QA7>bw]_({STq4t|c}(Z40ČtdPy0b"A.a Fa}[@$کyrg2hnNr۪s^I4`S'y\e83*)0a8P5wNSCt VS}]xh/s}zEI֠dïl[NOO7{$~EDEgivMA0SU>ޖ6gsn?#}> ԅ\F]I4W}PW tvEdU-?cb51Lïь#-\ d n}ӆ; BEߴA&3|@Di(B'Ʂu_'T-aXDb+9GA}ֺHP 冦Վer`N;KYg@jZiXMDOb@67n t 贊C8r9 . ޠk Nyu /1RAQ'a}JNr <Ǝv2S;-%D?)rfZh\G [b%Ɲ-1鎘B:b٨*L6{":Rk*Ӊ27?> stream xV{Teqde&iC8Ic9FShkH[<.OYww^ +h4hO$mmڳ1iG9wTTpR—XN?֦uIyPDI~4Q!j ִIa5Tc RVNؾ~.sEERTZGQMj)r7%YwGBZtțhAj0Cs`,f^\9 8tn-ӸiB͖(la6zΙy# ߉ty=|YCVXqV4cɓAw\Ɗ-VL0@,i բCTr ^H w㐖4h)/xUwh=d*@&U'[? ̯֚+Ⲷf&l }hg}F>zx^}SbSbS*z/K^}NVzt=hm5VW)bw'I|@u@?b|@<ŔXV#=~m 6x3ly I ddv`+waCN6W_U?Goӕ3z}s a|}F 6J]r+ϊ 2_,fo1]׎?m{~V؄AK4;'IGC1Ξ6|o6YDL5g7{9;oQ\2./ Wk}p6t&f*֗Ť 5@'i!O2._,> dzG^5'e|[1]S;O~XbYVկ.~OT2,s?~pX,7&d6iv4;lu@m'm/2W3۷o4neXÂy#'vq؜t"ΐZl [ Puggo|^w֧¤AW-а6.:9Cbgwm~+]c՚V'wAl-{@17u_g[t66'L;O$oGUaU o)'<*Ӓ|$d˾=mym=PJLu'{#.Bs+‵}v*7g].) gUՔ ESei^~ qHipûtQhȬ*r,l6hipdc.]A* ȣ c0!&2*Y/+M_WCX~E9{: \Ky;ϑ9+B>d!-4SKc"'TG/2Cң?RZW;koS9+={)lX.Zރ^{#>*ӃK*%bH=SMd+7D́r 'k= v^@4|i*'<C&f+ZRN-_7܁2aPQG`A6(x;эI[ټ[_~X+w&PD>0\n!s=.1p?1Q3+ECaKr~ƹPD@\c---e-ao]Mi0apU\p68H9J mP - Օ,#J1l>SP\k)CйR II40aҲ߯ <0ΰ\k`eD$ѪV;- nÇ>p+n\ Y2PU&-l ֜cYW^ ~0Etpv6jۏ`ɱ)ڊ7? Oi]uİޡoCI4⽘X)\7yJX5_Lc KҞu}vxypև0!_P$ ~զ-|>|S-n φW(j˄퐗mrrB7 {7aa܈eՇp6Ԫl6^3Z0Ӆ]1W k;*lK"O]8qG N#Af[J,ou8;JI/s9pR=!Nix_?_W}emꐹL!VJkTJͅ{*$r*k9 P;;Otxqwy85*-UFUiN gq_vk P 0G|vZ6/:w>n8;JQؚYKwu@::8rm"Ȱ[A'a럆64AQi{Zr@<ޜאd- .PWYڀYN/-O!xVfm҅7[dendstream endobj 175 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 220 >> stream x.LMSans10-ObliquebJ  ?R3gvuҜ1#(J2 |D>P $$P|DuPW  To Œ Wendstream endobj 176 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 833 >> stream xmlSeǟy̦kMH%Ą0:6`Ccl00F--[ioN -sӵ1yF2A HD$2a Y?6Iկ$|:%b2I +loko-kjٿ5綆wt6GVR0l:)f>ыܷ*d+a"KV)n3%gXQዩ5*sJÂ9,XqU{5z_.} F #7ru~cHS=v"ή# _IHuMk؞RF0*+x{&Z/mWA ܔoxJE0M!f'|%.H=}x0=Z w$S,}X\N_Fz>#@s ܠ^ 51?Y}+v'.y YwJYp< iv'I@M-}ě(]?pLW.&<ȥ?0IaXrol7Tszamw |\cw?-(v V6Fjh&EW\w46-8NKۺ&_PKo,S9=cZ|<6)5 GBf3!oۣendstream endobj 177 0 obj << /Filter /FlateDecode /Length 163 >> stream x]1 EwN@,QtЪj{bLz t`K_~xgEgh [BfϢ`=cn&?@%w|RW`i)ItJs m_K)Vh8on)JZI g=C,) .dS1endstream endobj 178 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 212 >> stream xcd`ab`dd74 JM/I, Jtw?ew+;7  KKR3sRJ YDzʅ>?+. +tstUUupOSܞcySمzpgr| ~8On; r\,!<gO '00M~endstream endobj 179 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1189 >> stream x]{LSw-kn>:\[|Mht$dcs:cB*h=-K&Ή]9cH.plHfs"n3;|99Fb!/6J]fӺ>cxi ?+6Ld5$k6׼o2!:~rµ-&^jʵZ,a"gfrY7]fjw-SXoun)5m#YjaK_r5C%>"*0&D҉JQՒ9 S3 ~ȩk{}JCS#HS L 򼳲'aU~A. oI6U\*Τgy',AўQ,sfѿx^ZC5W-_yzkat|8zn&g|DkԈ%y-D?s]ʈ >. -H\3 clN71՗ODUG`/\򞽪c'cPD @p$Ecޕ tYʆt)g3&&EK2QDʧ:Q3duNQqw[\'Sϳ.XNNaG)n*,KqԀ-PP0-ܡ5ϕ|qacx*(`^{4Ds۽l챚_vi $>kt>iӋN]?n:V4pC|$MiUFkՔcA`?`\Wp9(k Z+"U-StFjܖ[Dgq+io Q]:f\vuh=kQl;OaލBe98֣iJ0K-GAAEgtpa+V$A.o5 4e] tla*͎\0Rۥƫ=XT̮۵6W}Ǝs3ۦG4x~Bd3MϟrY}=x8OHhnte tB@'ec4gOjɃc{?ONf?Pn8endstream endobj 180 0 obj << /Filter /FlateDecode /Length 163 >> stream x]1 EwN@%ʒ.ZUm/@b!Co_Alr# (laKH0Y4|Lb'hnO\C, %3NsO:;k)?-M-%\I+ILgb%V|-(S/endstream endobj 181 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 204 >> stream xcd`ab`ddI+14 JM/I,HtwòC{@r%řy9z%ņ L,.Xc]?4~]X3˫ٻ1mSNv`z'M0-ùq0"Kendstream endobj 182 0 obj << /Filter /FlateDecode /Length 1942 >> stream xXryؓ44~y (HLR)9 ;;١ysH!]Z%QQ.ݍnূ!/O3Ϣ-NHcYQb΀rɕfbeQ*X1]Y[2d gfKY tVY) :+eZnyL4Rkd\zh͸& .2/@+mfIiYI"D3,mdCvRq9pzZҙ5I-EFCT~W-&*IjT !ZGSXe43ErX_~Pn?M%.-2k m:%u0lOONE]: 9ꄴV8yYL2̚tkRR".B$SIbikC  J< 3W蜃n0Lnŋ8$8ﻡp,>g ii{y3#W~vMQ)x[Z2AhvY2tзƋ;)q'dc&2Wom gP@[ ONRdl=4GRֆ* ghv aFzyl6XB duxSUN&zmdT;=7.֟mV'~CSr0`x?'zqzf}~VsLͽ+"rb{IY"k`^ȇ9ԛzxÐC~.e:N&.PI'n@ܔ//KBf:ƜH1DHrf#S&䂴Ԅ>8lȅSPЉ.cv ב eŅxE. Ʌ#lr. t#me3.U 0!}QIHLNVëj=gɝC}\'& vpȥPq ۾The1g`1ѡҡ!m6 }ݕg7[4< f*ђrc zo>"/ fsGO=$׈~,d^LJWOA/oզs\u+ʩ*j"t$1PtF698:;ș(*аI8 wӣA%/} ?,XGVf_w?X#5A?tii H8kk74?>y\ƘI¿MƩɴ4') ?6},HN“G=:˜0GCԗkzѺ>GU[7/\0TR,xyna[/_q ^ +ѨX_]~P;i,>}]vdrlgendstream endobj 183 0 obj << /Filter /FlateDecode /Length 2731 >> stream xZoG_>EXm-5Z˵\pmCUnLϨ(yUįTE(PѠ*c@p`B)u,K`쬯S+,ZZc8ՂPu)KZ1OLEx;*9QUJ Iۻ6R*akwov8=HGsL瀢)t`e<(-55SۢD Av.k$w: ϣ9*Z.Jnnld"K\t 9NŅS`ځxd[doVn*RI?&&ad dd+9@N|>ӹkECxQ+kKn\ \{.#"AXR-@8AnF0TԌSk$'6HRE*1>Aw-$I66AwYCCR8ID#<-Hv2,o %BI-Uo(lɾ뚴q=!HծS'xJPQ¤ԝz3N9f2c\OSk\U0ẏt}[5 Ba~-V7y]ma~?^TsWP |dajN1LjsrF0aHAb(hcUtzpeێwjfr5gn2In:M779zu2&EZZuV  ϓޯJl@^`ጤ(Ңt Bdiv(n-P[7Ԯ4U8"L4aDfEj\`_=3o QP6{n?3A(YOl^D*5OeF('=iLzܞ\Pat3ydq>³(O4v9gpp߫ s;ENٸuOO]$L.,(Xk ST A]y>AQa^馔9 l \Mijt iy@B@y 糅Zg]nwjWwKr{ܟP(<9jto^A7aQr`!פ(JRyDd4q?k] Zr\=D4p9eHWmHuZ/륨F̘ =ks=&q1SKB3u M]׍׮[>4"q#~r}ZD϶hf&6Ւ4pXcO)rӬcGS3ղW1s=Ąb&gi;ײ{I2,;3~BTԏmaHm̵8>ͫBpaS(+z~<)7"o &?jc[CG$~Q5/xcu7xDNBpvC ΖAZ'lfa tysw Q[ p+Y sˑoJ~6Hkrl#Cm> *s9oW{sCs?L񼨨> stream xZsO^dw:gltkOi2Ӊ;7+gʑpGv 9wU-Fy{a.Yn{6Qhζl^K#5;ƇŲ]۳f4*8gga8 ^G|C5:>\k,C7/?܏.?w".X79,7l?^mny_mnMh]\0lK6bnk&h"]&>iBakJCZ6iۮiJW(v:f/1vb j'nD" . "\!Yb瓰l}槐Yyf-&הİu#QnxK0ڄ-eק2lkd|% {L26H͏.[y7I>"cMcNe7%_Q>'4mCV< 6asQ=kR{aV;4aYMVnnӷ]_Ѡs\Hv^KCL# (1;o)[Cl knu+8WEv]B֮ Ys]32W!!8i[A;tba)A  Q(\ci.sbdV1>$eCRWHWi4Sr1uٓ9'NfTdnAHXC۴Ct7}N@ÁV2ֈEyEp%oNNT(%r5 pa{wbDzT!x]P^IrL*h<.0mI/Ižb/4ǧ߁5&#iIGG BB[-}\[v 4Zz넸ϹWtIMb,6 VTF#* +vudݞDHoNкJL|Ed|pf]F6i֨52C<*xR,`Gִvnޖ8Ď(؁S]}/h$G= 5xo *JM׆w=&2 aDRA&r@ EoyeSabȂk(9 j&ȐŔ@']EY fu-%#Wo'P%{vߟY^e!!RޘҊ+SBA(>v)'ĨlJ-mjg}{ՠy0bϧ]jԥR`ݫu+|u&t I6e8$ЎiWV+lWę%RvXoXH%STeE;576xORuީcrxySr1`q"YVbk邔B_LUrZHoZJ"ÐtԻGs8G {T}_Ф^~3^}?8PB4pWu3v|g0ThHAg3 KceA9^B ~1͝6'8SJ/WJo1WA`*O0h{C\&398WTCovCaaMY~4TpOYKJ%%m((ú~>ĎI5%:!ڃE84f0fMh/~ CX瓺"%❊ܤw/(t+qi '|Qd*8y5X@0W(N'|_LP!w&5ܬSZX1ᠶ uw:M].dVG^Æ5}̑l;K$QޱH.-TYbM4nFDUvI%k.c:نXoٿņ8=M?|y'x3>JqxGI"5OwdM@=uMfl6Lsuul1lmޓWt0&E\u N'KtyOZХDIνNP||][PixG|!c>v5 ;d5i=P#o 3EKIc?'/ȩ w}^=^.t+{>l0/-m7B:֊u#(pa&x3DϘ|'_}|" NSژ!SdBc_bnq W$TA19 qؘQtMnX<@$9^\N?p<,_Pv,& մq/&kC }⊩}[ Cj8q͈S>, 1p̕NR?HRsfO:g-FU7 96i/M܋WRJ -ez7{s|1!$_yOT~ xendstream endobj 185 0 obj << /Filter /FlateDecode /Length 1706 >> stream xXKoG07d9宪~@b}CR1E GH j3-l$ ꪯ_J XjMWB_ lWo-9/^\;Y#E%9[m9 97f&*rM4}A[[W"9ŋkc7$f-u9-T?/M(#DGN$jcBpNj7Umɂ֤H ĀGYYBoI>jCyuU]= !==xl>v[s/y5I`Nbon7ۥeկXQ1Y V=]6=]I~%ͮe'C^uzkE1hCjU"Y IتnDqX^$Zw(kP[qØ4ϛd:V6;ĨI .AuN?4fi1LQ~10P6< ggzn;~~߾O%`pyD\ufd ˃i)3Fob̎gǘC֣$jxv5=陝ЎH55Ⱥ!oD)7K4QhpRXj[?'jU5g9oVi5Ae>VӰ4࢛>7K%7S`)\`Ap= 'J C')39>Ӳ- Vmyͮ͡RPgFվR˳*Kcs:GΑPUJ܈-mWx91%][u~hM~Ǐ}|.6zMX%kBztr Yk!@VW@[ઌ,lzD-vo](痗`/~kendstream endobj 186 0 obj << /Filter /FlateDecode /Length 3259 >> stream xZY~77e# 60y$uAg={ ]U_UW/%a¿ܜr&wu P+g ll,[5o.o`u.7f'Fm.^ݫJIڂkwZkޑx^ޡWU:pƕ?FazTԐ=9'fhwy"vx35_p,VQ:r XZ㸸r6Πi5nXJܻ@Y*cUDs7QmnƠMHόaZ,1i0 JxݮTJ@ 7?]Ÿ@R^<){1_tNOا3%9`w%kJI> ͶWcYl qkQb@V|hg=BwMhυ ʟ  nMfƣ}a7%K3E_OD+Pf'`4l04Fz8hb%w,0G;_֞vSLΥquqKF.&]EKM,&q=L9ފQwo3i[&܏VN'pR3.ёaxw;ҥI}ZTE6wV*6^ "MB[NjLҀ T%9LXH4 ~t$:1lo-Kx޼"f+u۫6f0b~. @KQKJ'XЎVD^դD{#F ]r^ U}Xo\Jv>dmӳb](Y+s:0@UFi7]q83=aE hA Ab\݈bdSh"b^BVi{NH>l ntcV&%6W+UQ錓65HSc\2bV5|!^UE*ihMAހh0Rm#6uRVa'WN4]Q#clX Z][hZ-T5yZ5xgϴofn`؈X0X@tuqYE 3I{̧ˀXS[\/ 2/tʡUuXϻ6ϪuZ\hV_{D%6X :Ђ<1< 쓁rIf7-ڻX L\}B&?*]Qmy55 *>sVK\d6`<'{,E.ϳۨUҢ5Qs:E(55*ׇYq hUm1+B0(Smj0#nȳ"ܑ,HrDŽs86x8G<7_@F~RB}>y-o o\j59L&" Zx){ }BHzÌم4xOl|jA6~I|D澞3r6{bbFCN>$x" ۼbS``JiD]g]`tݿmZw3vF.zȢo9Q䡓9:ɗ*t;b4gX@I{t,`$3fa5͸.ҢӜDEZIhWAn30nB&.%:.RՌp}w{Q)j6SRHDWs^ m;-<> Z">4=m =Pݫ}}vysl ΧgwB288g(Qa3 kI1MvԘ9J\EIO@i0$s +KCiPRtO@dm4V{m{J }h/6fʡ3 0:Ϗ,5:E10^ do q2=vB6ؚE`f'zKhI)UiCU/ƍF7 u !i||D ̭C6nBe-j,K=5h!nNBe'A%A<Pj&T 49@T̨xCOe~&nU`= +fA`,HyD\Jhr1+Dx[-Xe^Њ5#<K%Nv*CShM_䑴_JWL &@Ze{-iP51˭Ϋ%u Jm܊e&1bC50zs`b ,Jh瓢/RkمuŭBA@B1.!?**i?ORE1]Fz7}:.Bd"?񔹿<26oˣn- 7KO8+5u^i3@Tx )'n54];IdtR&A\s hv^m>R ӂ\pQ [<[r).*⭂ 4:O3i!+hN*@;f澊O@%OE{؅hJEXU{& w} ʅ\Xt$fZ̗*)vtj߷]?ǜptJ;  |UAkr*W|C0+0 pXs 2e s%>-&d81 $-JcmyrJ5)nY1-u)t?~[[H<Ԗ`=$fSZx$PMİ4Q&cIp^ԥ^'X!ly:hGZ3Ӟ`3b44^s*|D+|I bË~hn=~7]ww &o|5??@zb3)^KV^ςz9-t8) J>Ule,|?@endstream endobj 187 0 obj << /Filter /FlateDecode /Length 2831 >> stream xYK= lS&Y|.c ;{09 Cۭi+Qk<>ERQg}tvӒb_}U_1W ǿ[6o>:*W2ԁZ>,],Vlu|ѽ)e g4}Wu}Q$_PgMQB˭C"ߖ)ElaXUߴǸ?OK*.S:AAsrt6CN {YD262!vq.=i4EQRj y[ Zh-LQF%hErZGMVJH /^L/eLz8>TjRw]۝5T渭 H{7d Sacȹ~-9uJ?n?JO}:hɾq&b]L_Lgx#c&eͮVY fUNs8uk) EtoI7t"c(Ӡmӹ)3Yo^<.>m.u|?cl8%@˺*n%?q*%PPBZ186ı$i>98S ɦc>$79rS̆=*9nJS%IklI+#UzI2fHuLm>&& @Ƀsid`p u뢔P@GdmdsCަ/H8; }OaySx/(N뫣m0'SN]>e\S#s!?Qgy/2I۽EdfXI ӫvW\P8':G0eIϼU'qC'? Pmx-x,\UY7}?/0&N]I|JX*K$H*$ %)@p1!VMYR4Ms`|Ԝ6RrK+G}ɺEi<~}s3]E f@#FJO~?gG%x]5R8A&7|v 4p4%6WAZ }n2`-AlXQ65-]!gB褱퀲8XXp`㓟JU8PFVtIdj[Ae|RS+jGD Lfc%;%&Eh:?=E[=sc0N" 3S:,O#RkѳV1 #ߣzaR;x]_NMc\+_ Jn(7&B,N!u@S>ȱ/iF,$0 md Wd99!"n |ŹT{X* gJfx0߶z嵬쓵yǶ_қ#?Ѓ@k8`.xjC"E5r(rf *=+MQct!Cl" C|6(Pi2(WS`e ^Z ˘Gc(_#-AP Px ݳ lVR8m{Bq_jg16%9j$:|@+y-1dVJqg19ѻRSH3PEe*L|y18jS֑_Sgv&PVJf59q,jaff,6@^eZ{ѺMG؉ C7y[QP/>:=rj>?-EQ&#uHLhl7u71s 0L1uQreMGĴU9~@ 8e-iԛɛNe E%>"|̨Y%Z&ћ?&O/O(|RZ #9ְX|3 JJiEf c3ROSJ*N01&9cJԫߝw,Zk01FץsySswl@)մ`֤ko}{仞r={E@j=3eNx*,Ʉ,z2*)9>Nq'Kꘞi}PC8hKvץM0`C#MnUК09qM>i}lg?80c\ӧ3*oaB8^V{*{톙|B=E8u'XD\B;0sB &8cl۟[Z(OuWw֑I,C#hprd^3_^wWA_rfHn)(Sendstream endobj 188 0 obj << /Filter /FlateDecode /Length 3242 >> stream xZIo)tϹ4Ɨ-k_1Ȃ r%Z̰mI7?$xUlsV6z{+ڜzB]*w]}~홂l?Rc|{rUPs-W V`"Ģf]l'ߞq.`Z)Wdu~s,sR AW%(O* 2 kQlE}Ql f[h f0T>6 khgHa"-'ҠO׭G;7+9&m]nFU&Kc2tT2O  5ʠ}Q97Mzj+ݦbD}1 M;uH* ۷BQ4_O ۏ*G "]NmdFOs$ʱyrEb8>=/R e昡]> E)ְr =u4X;(l3,B1:o :d0B.wdXHWVudi*ʱlU&=/\^)XpXXa_V)2_Xck5qf|h f1†@h5w1_B|XQݻ$U&;_?DtDSu'8lъ)4|ɸ_M0uT~~Ñ eSπk`JsBa(]|Mjl^Wy$C{bML6J}hJGCJʻd+ +ShdAĄUwn}q}ܴWo^?ߜLǴ.a-hl;ȧBcq$.SRXQJ%.JXL8bA-}1 ~*p A-$YN#i1†[RqK38G,J7JCۉy(,4MQqNJ.ac"d.μb- Ϟq/qJnCPJcT5O_BVSb z۬=. %!1 o!QJ>~Ct*0)1*#\?͒s4zӼ \@LVP %AO9ߌ:G?qJf80:_MkXlwPǓn}_6+#0}@ڰ 57۠aӶKg.r3:4M.Vx`U.gh]R˘oD a)V\-. f yQ{DE?hRuS$ cn,U&Ma/|J%ԍl 8Xd +%W%I=oI*3kb'sn:DP߁sM!G:#^ C4j8c#_ 8[P[>eOQ+KMO7X,7'K%7c 'LQψ6f(d|,GłA&kŚbM{W]T"@J3;›3s/5BJ7=*dRH.&?NIXc.)s/I`Kb+V`bjcv^}X'B**/bAA-kTM5Wט|v g8DYs 4k51B8sݬȏQT L+|}&EM=]È Jo@tB! Uq:<9Yk PgBa ʐnh-: ? zG|p.0' ~"f<S<+ʧ424YݏlDO?̢o.ղ"W3ﺙo)˨aTzM@ q9X^`=3Po|l֐?\SFB%G-ɖ?"Ƿ pjt+If~_%j49D~L}CK7M-09i&v8 SJT(c&p+}&A̠mFxm5̣2gEٹɖ)CI [!գ> SSGfxNi2wx0~'F!EA^njevàX#<u:;o|cl!Й[?KfKz_ =}5Dݳ郏|1HU݋1L<ȿ=?䧓Hendstream endobj 189 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 242 >> stream xLMSans10-Bold!J  TR3vu$$,!>ʚ걋Ym^gfg8s+fP}Uu]Iu^i   To _endstream endobj 190 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 560 >> stream x%LMMathSymbols8-RegularO   arrowrightinfinityradical!1p,-:fwtu}}utt&vwvBw}8uz0;V|?VW;z0& Ƨ l;$/G(JGۊmQLT7 ;s_x‹ o&>C62K1 %7wtfO9! Q;um ~}UP$C}˸fE{x?  W/ endstream endobj 191 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1383 >> stream xUiPSgo@$aSEաV8(,',7D-D ,ZYje-*a~:Lˏ9spSyc! G{l 0=W*5bE,O}zڏ š!l 0# !!"hmBLLaJ rB8,79f2V0! I$5>[3xͽz$h^4͓''m c<'FԺ<`_ZaWwdu㏴<ȇlPzl@6ZU*),ᧀD}h'Gh *M>^ L'.89&4흒Qꖶ iʑ\Sd.vF4;(a)LyM}1I| (Pkg.6w5УE/ȏ9K>U+-H{a!?K"R+N=pf_s|I6 ?oAH2޹*!)Q3g+dD W*h2ZBmʒ E1,:w5L/c=2??GPu<=@Kz{gdn/wźDHg6#A"-;'$5cqN t)H$ k9ϩ^Kҥ\ gRY#q$#@-𤋮P*/J a=v^%S -*рH1EZ iF恓.wSRCF"l׊p23JȣԹeU}% GzHI9s=1=3И^G.?r, 猸Ma/lSYדh(v'ܒ*iV> S0Wڙ[e pָh|.`l5\r6׸wRhX@u9T .OMԛ2~BDD :a? YYd=mC7Vq4Ȓ4-EU.CUݥ!BB .ngs+k[,52Ե_wúU<9^b29$Yrk_!.4l|R5S҆Z`C Sw[?rP*a i-5uڎTS1]C7@ѢǯbC2ؘhIde2R8vd ~Y3iXzȳU;r4.5isfqsdc0&H9hר@ņF?~ $e*Y {ʋB߭)IQ3Hm}aJTl,j(4[0榾q3jAEE’a endstream endobj 192 0 obj << /Filter /FlateDecode /Length 250 >> stream x]1n0 EwB7 \%Cd uRvoۚ>xR%_bm^LXMwzEyn5޸{Gzm)5&b Qg2\? mc djɋ&IA@ b/. 2j@v"UC$a p?GR(2Odw Bp_|fc۸ڶ)%.?U,l}+endstream endobj 193 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1279 >> stream xTmLSWIȚ.fc/$bpqSP9s*ĂwV @ RAKo[|L2bbܗYM\2g~lS7Gs˹-hggqN<=F辅_H7k [ fo|RPaq;=Oȍ +~b]@!a0]*oj%YyR8?tx'tc\+H1OUZ~AB^pb1`$n}@Mx ܌%Btf=\0>bRŮŮPlD?"s>Cp-6/ڹ] ^SFNfk'/7ƾ0U}ŧuO?&mAGii=?V+2NSUQܒX'2q^lh#ny:i y8{ XDB4QH1^A"5ޘɾ8'1oiO'UT򔂦Ȟ/+^{69x['V mHX<dz෾M;ŕ,>QtY\]r{ʗTV .wyt ~ig |}RU F1> stream xLMMathItalic12-RegularC  upi+ovܹ-xyti]ZqnkVݿu@r49C{vvpzB;}pЋዒҠvCp  To Hkendstream endobj 195 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 606 >> stream xu]HSaN:.N`9EE0$7d [-̣5M 5 dόJ窷ƪkNT7l;.mO> &zٞ(Ih9j\:' @R 88v_|5 Pw;O],G#.x=o6z%6pG1ȔҒU) lL597]"ƔP@ED >;Ab+>'Cσlw/rt@7 ĆRx`kV1!f+OPXl r{nhmG4zqqA8S2^>,@&a^z?_C mA0RhTv̈́?L> stream x5LMRoman6-Regular-  12Qcw`$mIK%gd͋ǧj~$`dًËËً‡cOf}I|:}O˪16-X~_ȱЋ=:D\BEKmlGvCo  To $endstream endobj 197 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4093 >> stream xXiXgTliIb[DY (q!wADQhZ>l" P%JD3&̘uI4bSciLL2y~USw~yP6D"c:obT~ևdԯ{)6KF?@YoT4=:/~;TasG[0}Ƌ2EMVQ{+zZKMQE&j15ަfRK;5ZF- g,%ӲR:Hw [>yZ!Θ /U@am0Kj]" 0P>m (3w5c/ckNE_KIE8}Tj<ЮgzZy\Ny˙KzHʟHnS8,bG=TsW}GqIe`Riv ʚ}9P~ ʼnxG ]7i :PYEDFo'.8v%0m6b#`==݇΍5AW0rq2\&_{7%)au><9#{LLMӀYxJQh!1]EuMi'lq|7t#e%C?-z+c7>+Ov""1:Fge4ٝݲx e4S٘-{Z(:p?4fBpNKEQr::rG8c2srK{AKNCrki U Y1@De ߠ:zZ{:堮bx`^ {\#nMt 9쁽 <CmAXZefg7okՙQ-^O5TI8It Prv LWDNCنMXo<э̫LIB`!ǤUt4n[dp!|2_| o L>FʾɟHpe߻Ԗ.(o[tPtoށpXqŕjJ:&f?Mjevr5^.^4v͒A>wmnHizΦ秷7A7'SiX~qShdeCa;Afcvԋu}jQ>byZZT1iぇ6]5e->TʫtGK|NN ϰï8rrce3_*'(XT6|qǟqFpj9 $1WS} FFwa'@g2*H_ QIO[R&uJk|> ?T2lӪXpQѵ5P Po*Vd L8PTR%Tי뾘\zHMJRu4-YEScoMf l<[A={b98<+\>pB7]~> .?kQGDŽnSjSF6n mGEUU;R^¯)*m!tc6G%/WE4G?z8^}p,&  o+[A …O *9]j:Ga[MtCH<"Ȇ|KQ 1M`ms#*}7yhǞnpB<&k4}wubC^$d̆DC~݉^5ؖ_jOX74#xW)Y38 주(2ɺ4/? S}(fh1.*,,**,*j<mNC;Af=pڬnL{yYo%e܆_t6XBvTUqO>#W51|'c-'Kt+پZ 1|7n0F}#ap[[rqnVȹ+1(MtVHf;yiYZ~s~ >dI]<9I*48h>ɫk>Uu@fCÇoOx)aR--lbJc"J9v;tO$ݷ)qN,CJ̸,`rD_p|xxxi¬|d20i:39o9I{>]|1cKϬƞY={(ܪ@{no*5}5gʎ}eКQİ%qKiIǟoE䏄%Q |ñn J3?˨odXjq!drm (f?2WG=W^3Mw6߼.MEE%*blB$Jޝvko)bh#REpY2}N(S–vjn]Ţ3b(>?m)H飅pjfz|!8sBy<#Qd?jEM|MpRRVz}NuNMLfrS9|c ̡a.EGvqڌc1&NE(Wы.da#Sa\:PqbTK\ȆOJݬ~ Cev qAܙS!wۮU2&cVј=EZendstream endobj 198 0 obj << /Filter /FlateDecode /Length 3437 >> stream xZKo$GrdF@Pt1Y@Z,5v`>MK@lRAKoCzf9|5vUeF;s_ù?;{yz}`o_ޞ[מ#5[νc5:%tn{v|6X'! "_A} R#y݊]TAD=je-vSwDaq}iZG#$1h&R˜ģ*NmֳԴvW;΃ԹC"ERb!"B d4?Ċ)E5Ռ}PڷIЭCm&=DbtM5#Mun&kCAAC~NmG HhL:QP*e3L[fcnyؿf9'rWe='z;j aM ս00=s7r_n( u" c'U?P-C]Maۄ"j^dZHPfXF]zVq7Mw jY톔،00Et(<.~ۑ9>ښ}G\Sa>V"Yc}-ZMvc<Ӝcv{{HWfz%`) Vx\Tb]0;Yu^{a r+w2OJdk||['cZMF},3 Q l a4!y>=B3) xQ)rbB`PzMI'Vb>Ĥ^ @"8DʦY$W@evBdU } P' BԄ<e;E!)$5VFDI YFM\BhRIB$UY D J qLJ"Q@f$&#@I9R䣷1F/"Ā ({"+؟ga{/A#` ^1FĨ)(P2I4'V1< Il$ `)x $)P#ۡ>4)1EzP! Cbaa"!y%Qɛ۩x <%VJUh"J >*Mk+Lm魣|n +SHMcjԠR+q;1CC(0ZД1 z ]Aͤn_M_M$9j_dWynQ*Iw)MR+J/᛹_C 2,uSJO)7XKs7N)bz2 3Cc5^ݺ+Nn#]Ww^?C#}*eRKByUW3fOxun; d.bifRrtۿˏzWQ|S͹닶 qGW?UkiWRQ͢m, ]C)4b5OډϑP|-q( Q)4ޘ|PqZu\dxW\&aRBRNdcQ,/پ竜޵YoP6J#tf%+ס)Vͮ#}۪}fv5ە2mPH7ˀ#E?~QZ\AfdƜWkumZn3q wmw*RZʬD0wWn&>={ iWwμs?]V3j+=gKe~[I˖9\qRe 㶢MyilWe8N&վ0|\쮶ũT8%IUqvN|.](CkN6Q3 9`i*Oͣ7Va]?bǮۯw?g22f=(x3@AiC? t matҠXI4 oNڴԕntT~asmkUn|lpljw>2GJ/M2r-Y>j;gFwG b -ЅzFLvEAæз'i [҈=t#@-̳j57f4AKw?ȗ80wp zG'!ԑӗ7 0b'ToѾj @p xq0wkl]T ǟ6{J/뺽 9k4o-o4:/p1&?>b^2qOqknqheno2vft)Sg./a< O^> stream x}{Tw''EpdLwVl݂ʂUPLH &.1F!4sjvZڕ=[vqvw?3{?"D"߫ Z^GuiIZπRZ>b\^BHUt6CtPqh#)ǂ b;K"El"6į"!syEoM)$uMF|{М9wȍdWOͧ^^upx?2r%'J_u!?L4ًإBd}8'Y%&iDŽ9KjЋ;'ܦUs$uhyʘ[^3ebU ֒Z\ E*1[KÙ]}K{ſ}`D.'zy)LC F0J:p")ߨQy콦T4^YJ* .1v`'v,J+/eZ,TS\0Ԥ3wtC'XB4B%2Qٳ _R>-[y[ CG$Aޅ'eݽ#q}Ddk'v73s8ptX8!|MHxmRŽWqߣ@Ő9)1I# C@S 3Y^Pi- XۖsPk̂t\CB-7gi*L'sL6.a}Csc?Lb_,&-@w`#7<+P3-D(X(\]__ ص|LrB?+[@͡6ٙ7<*Eɣ1PPL-4Ea&:=ˣWbVhVVjzj?e;~BCȄ4Hl$dIgL s{a?YWq8pS :Y쒼r[&U &y'g+ЬWx/'+r03wى 8M5fh7$2;~B/ovʦ9x1@ Hc@e 󫋚YB?^ xR@$(XyTaUV63 7"DZІr3ay'}:jefl!Qendstream endobj 200 0 obj << /Filter /FlateDecode /Length 3237 >> stream xZKodpYkzF`" "DQ4Y%GߛT?fɡ `NOuuu=/3Fa_>c۳_g|ԸBs09 [`ƵLQ:fK M>kQqMtU2% 0GVˊQǵAvէ?}Ql1?$0Vk$rV5S,d^ +SYN%N$J˝#2gjn%u}v2;\goΫ;AR[_I@C2ɮ1Ik./d")cd6>9I$jWFԂ )v?F*1Im2ռ[M]V_kQs!2iV.]4xMpYųxvw~)T 2=AP‹], 8RCTή\Џ5iZ/ ,eɋ]wT.up ;܇ծ8 GHAzBݷ]8ᎼGQ C5#6򦙵vӔr%(ӿEJЅ4FPVۏ@z|bk {CQ`"zP<`(B<Ӫ֚Sg-ke9²%(š;N>zGb Ӻ)Gh6L' Wh!%/Ns^Ւ &H#63S`J 7ju<` Bf< ){(&3/ӥWje2YZoovvӫiH 7-$ 4Um 9+y@Z,+4yne]( VHMmX*kx?G)ҳ0q'/ZJ\ >`fU &?7yAY*L$aTdr,ahouaK̀ ?ò,ыFv`vF.ޟ]|}I,PCo#7,ω4'fn ,@9woU{ Z$8|:,lH"FW1'nkuR!7n=L$ŔGƎrH-0)ygI:`8 HcYs CIFr|!$}PehiݺnnfS0r8Kt:JYY%$}xY0 eBҷ`faH3tV1d(|qx6ZMҸV|nzȓI}T]c?eJj*#KP&D ZC Eɰ;9@!y?3%0yxOg&*bTe3 ?'Dy+.z㾃\y,TXX[BZf} ̥U.(3 4ڐ1;_m?!{PW$Џ9^C Д2PPɩ•"~uMբR@`'58S㮲PjyP/Evzxk}Ǣ<'7e;Mh~w=iX\{}h/N0Y"}pm)!\ex\/oUֺfh[`҉9Z_&?妻6 % ##B"#r~;IO)̒UU?hEVnTAZ#җEI~I633XI(x9xHؓ5L>["e 6.T6TGA'*VR?"!1e?-€fMіόY^d ? ,۱ΰ-UN2u9cM9Tk:3 6ƠܤɿЧ'9sɧ&n*SsO@e0Lfa>E/S"w9Z kl^mEcc( ܃"M` ~'9A%zgI Y!uگ eiqRpisR#vFLK @>biho$GL98ȔR3|NU@ED;Ѐ@:5%8ݵ'JGauZ&Cw1kɋh,ki=GeU |rn*Ho񪏓:Ux[p^O =CTaK]>qA6QXŃ 0*5I4ub*k 6|!J1󽡕dzE#H{tBh3`I䡓8PEI{]UBꠣ 3.8ȐYe.n-ҸzhC,lv_U*hD/9T+|o8VJbѺSCvNPqX?" d4$A~7cn@Nj;![,EUV*އm$mI:S͇ :IEߔ%'Oҁ2P*uEh[р5Y)'|M̎>;ut7YҜoS%odp^0 ax@򘼙 ɇ q26q"׀4F1&f2?P#;ZzB@ t$ 2MsJ)~HGan|@' UP#^^WDrXxMkc:-)N@ܱnFu^9:U50Gs"s #d> stream xߏ7}\`.f^n+Alؘk׆[@T]=UR4q~0+S鵡=HF0"!)z)݋r߿D/.Ͽqˮz"ey1./߽r/>2Ǻry͋_\݇_ޕ[1k7?#m~wwmjqr=Gok2o޿ݣ?Z׏>y?q|z_-*ޞrK5~\i_y}׏'h' ޹ĸ9N鿿kVb뫯ّ]կUlm%]mgK>rؗhw~߿72ʵ|ѿR/߾W|Q> Ro?5_%l-nm_Fqv[YJ^>˷/ƭR//?q헑9om^[+o_d[oB.ce0o#.cָ!dVYDz}[Ž-66Oڸ ]{m, 6mW Ym)5mO 6h74-$'DƭVL 5hֈodZ5 ؈2I19F:5m9nz+~ĿvkMcfK^S* nmQ9oO!yB[m-4k[u}orU{V!q?nA/[ȘBR˭6!^+8&Qo67~lӺ5C\D?V^k _VXLk殷XBCRZcI$o j6o t=%aQn 4<* R0GhRP cH;=S֮ǺEqGľ%5 2U$ͽV9Yau~(UNϸ%qkULrUtq@',7֘:ED *4V Q  śB$a [ = "s7J2`")VlIދ^iUi0j0^һNd6!)aiS1dD?bDBhne1ZX'A)D1fUWL'OdֈʈehXXXXșB)zSļ- Xf^lFtq@4Fx B2}2^"=Q5<[Q֡D Lj`qA)yq9d {7Ij"[JZލ ڐ tdD؏6#iXXx֛ &|,qJs8 3-u3ƀf$* Xj>v ;p%]$Ψgʐf%2]3dY!TJ^.ޛ!HeEX x d 3ZerdȲ{'X Yp3MtʐeaDKu,@K yVSatlfZ/n,֋l!K A&'iH e"ӆ PS55k%0%zB95 "XL3BK,DWv!d ֓iiWIVj*b}Ԥ7~lCűwkDT Mɳ3<$`vfQЂڙUA M>ќhN,=C2S1KpDb2Trq;&Y$Ur6,Ĥ&c3.gIFiy -,}*Yz¤Yzz3w-<ʴbcTe$تy3E֥<ĕjR3:"rEC1K_}|>I!LE,};R3۟ȰM!ga6 ,$fYFq49R2k-'7k*qb횊څcvYFv͚rrZF"ڊYFzVf[5[e2Ml!'7Nb*!"S55Nrp"Bdf[.UL!TL9R"!)ȠetG*D  0Sň܄pr($2hAe [)3AD֋E#c#(5H;٧–V\(!XXF@({1ƍeL۳91©8Uf,xmd2Q, ZI2؄(bBnn,GLH7n#SϴTĂV"'u<"}*EZ#)1mOW 14XUgeqC/Lz+bbD#d%4,Y=mB.U#2nȸuF 5,`83V#vCD@9FFKWRCK.䙪QŬ" +R=X[BdQDr+&R*ǜ9}Hfа!5Aڷ81ȓCf H8gu(Xt&Dr"ÌJU{Z1de=+&w*t2|ʅ)f\ӥ4ì TjAs^(m|%e@ qˣ[-fVp[ԶcjDq_ ˇxm5R>Z Vr2ACņDI?@>R oI߆u 5a4sV[>.D+ 0TYq ʰLP\v[`TRf4)kB 9'3î:(3QU Br:f]AE-@ЈZnM*tZМYp7'dV3X !r ;h%<8e!: D"g.!"X{p#ЄpB$ْ íoM`| Vq %rVjfMGx8e<ǬasS.Xi䊷VC鵕G1+p:fƲk(REN'cɅt2i8n٥}D}eo1k2D}2D}WvG5Y'1k[E?yDXF]-gbZT-gbvTO}cMgRhvJۙ}k:Fd6t+t,vto;L_+H0SHUj %)N!k8ˢT*J$%T}+eIS`MR< U0ۉVjPۉVBߒJ!Juf;Juf+ s >ݪj Ӊ4);x[iNm9 S6-̔m-vf&0VYd+T [ԋӄl};Nl[r3*tب-ek; $JWf{E>%} ˟ތRഭiCI ִ$ ksX-oCe`XհcĺYb]ZvT-THÈu-Bĺ6 THjI}}r[#,c,[+S M5.d{‹ `"ˏ]Re/*$i#Oc-g `Uʿ VPonq&ln!Ue,PV=hXӪU D8hV-yV0@E[V%^2-%/j"[_bm*}JrVewҬZuo04UuBߡ iVfUfU䠑Zj"Ҭڔ7nU٪2VreV# T$2PTcdXa;jժ̮Zuh5 UBīvm"2[ 9]V٪X X;%VB;("]a Jت.qxɡU$DPuXr0@ĬTV sMBFl &aG)bEBRZGi1bEBc {X)BHS9LHU&d$]!"˥y JYH.f(Ҫi"RfVWʷ!%`I*ܒ-ol (=9̐,ZݜF+x)M+DZQ.J0Cw.n`ɕ֊R0@F2Zwհcdq[ӅHoZ&T`[j0HkZW S Z[aJ"AkM) R֪EECHTWҦYk.5ڸq^Ȳ8=Y"kӰ#@ƦESҼ[P fmӰ~cDE*Ri^h-"Eb+Ri^h:@kIQT(ZT;Q[J w~~[M4-M*P&d4*ю` Qg!iF;Z՛!j2 D5Mb5&a”woXIR  Vl}k$pYsa )iȊ!ӥ\x԰,֤ͩ0E "KaJI[aJ8;Gj87jS!}B%┘@m)Oq)ķR(NA&]@UoB]-UbrSaJX݋5boE)Iʱ8xc@(He(HΨ(IS~W([;%U!!*Fܢb[ g[Tl.1`l(ݙpoMCmT$8g\b NmN" :, peDcW? !(ebW 7M"n7(s분Xp+DQ֕Hʩ͓$gR |38|IB$9qT{8:?q_QIB@ơW[OYF1G2ڹ8*tx 4jg%A3W8.Pm 0HY'G7/XUw.d"g8`!'_IC%8Fd.ġ<ڍ *~Yy6uk`Pw8 QɥB,.r3V"-.aCO\.D\U'+F*NAE*Nq*]<= TaDRqB⠝9,:Nu{ Dq 8*urZt!~PJ*:a~P DA 8SV`̮8u;5E&N \\ULN"S7Č&b,mOÂDn"O*J#lkཧL.D^Sa>I%2qh">$qxf Ƕ펑\V60D,eH!RP3$T!KiEb$\9%MH͜L#dd`458iDL&Db g'!9S#\% 7;dѺȁ*Nl!8*5cD '(g=8Mpq@.s.!j2^U2B+:2L~dI8 *B(6RqB%Kca[Pzpt?U~"Vmy8M{3C:Nd / .NDRuPs."lLbwwp٤@`_&v0){NB`K.-) F(M!K?qHiB uymlI1-8c і-2qتЂL.D8ql=pΘVrUHI#@šg *NNa Yٗr^#Ljurq͓ei! g*]A sI&8X.#q6ӄa[J .#qfUã\.DPhTXĶ5 8d&aLl{BDUfj6q 2rج3#! Ɓ߳ &#HQBB4+CE=3NNq+ $)OHlœӄhПPiD4\͏'\*<@6N8py&dnq_pWaA:/q<]%qbk`S3" = !d.!-1J[ [yra% g*E2ɘe6;9 8GD09Y'!ǘeA2rЬ=ȡ;FFMbV2Y};4Gؖg*dh{)#on9yBY7m4!y+,L> b`ǭLNY*Othc;w+7XAV!a}-oj&ࡶbq-leQF,а1:˫T!HW̲j#:,#S\gݔ}YY%%'h`a .XgdPв4kWCF'τhY). ;l3Z<ˈ>n D]E"ލk1DUȲz-tq\$S +!5oHURp^fU ?$!Gv!eeXkD. &ϵGcC+qY54"K2HO*<8%^w"2X6Dx Cprk$DJZTZVqu٘u"ĶfL'L#Ěr:@եP6|v"!]Ҭe"2YIӄف&|vXS% !D#{8ɩBh@b 򷖄y6Zm)Ͳ6΀nsYYώ`V{bJ瑩EYŚZBH# 2ٓL~|Ħ7XNdIO9@z!S<'-*;e=#aMjw%Eĝ$d<;WI3 fY?;$2pΘ$7I[s( sT#L}WD߲vx Iilݙ ;άfw$[ɵ"jxro!wB_$γ*H/![ i_$T!˗)H+fS%boap(~)\Isk~EM(ArNfե%iV Xf9jUm:X sӬ X^=g2)h9.pۧW9FhRy"HvNg.fT`Ѓy0=OVQ6=" D sHvNbgA&9.b*5q)E3+b3[9Nj98•VL tX':e AG6d+y J;˹7 ^ W4[1u$HB0dZ sP;/9]2lL; Ґe;˧ArN0sh8_*=.e ?94~ ?',X9*mA~N0IO}޴69M|Dsv6% ID HJ{ۣ޲5oUD=HB䇚CU=r '=QNt2?g Р?7HA;AG 9'V푒g .d--yzjBtrU:YяCúz0'bHcYS 2tLu5*% dT!V]jE4 y4#)qi7D$Qg]'"9[g警Bۡ9:l;<2Rtq&(:q-ɴ!mF~4`WiG6 (D#as&t Fy:h6&Bz=n[ Jɴ}y:D]$A!Xs;J`DNG (ÐCҁY:cY:CTN&$p Y:|MZ<$1^bZASQ{k="҉Kr<"1ҭK >U$ҁsؗl.bm`1zf/gx:pn4ͽ -7As,uȭV&h:HI!r,d/#y:hUMCAռ("5M'HHA3'dMbNQF&Ҋ.Rǐ&E4%d",,$d|.Y8]x^TiB_ED * 1u"6HҏIQ >6:H ![c Q u~7{{iVaZޕaqDx=G:ZCwc`5AU`c/u3 Q-'pQa l2$$˱T~I$E魆R10RC̰iQ5RPu721<8PdM~z x.& A7X:j0SK(~U}&MXt+`yeڀ`ޓCdaxd<[Ki_nd 4r@& 'AD:hemZ^|►Iw%|A#JӁgSItte aebGA>SaHH!{T%z h DŽFܑYWQQ |:hTA|nFgx d«?c ^zͤQa hS`L\>:κy:hgw;ۈ(~fK A'Q |$ꠂ֬TH4"'?1tfɄĊM IϤ&iv9c2NJ5s'Qm:/A<œW8Y{tqUI0< ߪg_WY0 ϷӄD'KKA!Z3tFK-%}VuA;w O ܣ{0{xDw;*d MHQHxR8 2>DtЪm6Ӂ$N!s4+xkTӀMta ܥ4Aći:v$JNg Q}j$s%Y:Lt 9'?Bsj ܨy:@Z9Jy'\^L$& )A;SKq 4D+C."h@ GIc6҇8:eI tIA{`,)}Lk D9͟ tyv0LԘ N#\HTItXhzFEs$4s Xg*X:VAX>8n˱,|\S%|ԑ,Tp`#!a3|- W% pI l:9pfdig)9h\;UJN2DOCpL]bԈ&%𖊹Ȍ9 >.e*H8GO3d1ueB9z"s.E2dfN:?eۦNO'/.,&So_MxGMPrІ,}l- !OR Vw,OBwOBwNRV P&p60::3Ϣ9fg ">-$b<9\B gGD <8<˥yNNVtI4+"b8)^:x6oP'U3` 2F6|\dTO'}#e8L(~ϒ0AF.3LSs3`ȁ/k$8i;rsSt׈8|xYՏW9K% 9xO56Y8^RKiG@&jrgt|,8ĩ]y9E.x2b8sh_kڔ#ɬ);cL]'o\Bswc,m_yO ^N9tX$A"ꂃ9$ss]TnM1d⠑Û5}}vTe S#at)⠂ 5܆dApE:[Aāk:z]ŹLA*!Lj8x>趶FڦƖ]I!~:qX% ` Pe.uvݑsIs>!RBeV bƻ omήrRqN7H lozM$FwN.pn#f{;8/⨐}@[ܝMʽJvRqXȩ^D} X*F?Ꭸ`/V-Qk,e\xNˇחr^ʺ^EE 8˻Oӧ#Թ~SyùO= 2SyYQ=U.~\˿/k˺A^T=s:}w/~q-wZ?\?_틟|/*7Ơ4ɻ$9??nOĬ:ȓZSF<: SF<>zQ̎F'ߣAh8χI^+ }_Uk|k/U.5t؇~%64&2C^\o?5en99'~?uX1 rп !J?^囟)uHS~rOVlץ.>U/׻?M{h_x\̼(~vwa:}}#W7N׏S}L}+gʸ}Gzͷ^ׯc#جԯܖ?=7u3o3^޿{?<'4&? VG߼}WQa> ǽBzzzr!@\IbI_]ȏo8@so|q=7_wo\].8 (oFU7l ~٪bi+qyqW/Q̨L W3{Z86wnqkX`=v>O}l.rO?d\H\1s6-_m.$_C~W+@HN6i#$c3P{c/9&+xX`tu`X=pISgU{e{cFM]c#;ٯޮoÿqԟ4Hwzj?\=1k%#{ۑ3VJ\'JĨ}7`>V o矾әf^ِԞ"uyw/^_\s-o^}GXGLmwزgrw`=} cU؝O~5쵗<~ϰ++Qǥx֖o.ƅǹ%ۑ'~?jKoUcOS1W,-_OTUR_g W NzIQ'`_j98;57~7V/^֦gt(Sx"O_|2֣J>l<ǃ3ޅ Y+cbاn'?Q!F]zӛ߽ͫ>G_񻇑/%~$@W;]wYO*qAr_yb_\'TſEɟμSG_a hzOFwc\_}O3Wo=7wSe>' O*S@Ywhq={\qb׿窜ħqp޼}˷ϳ!߼Oq`z^ThG4z۷׿ë_F>oǯ7٩кֶ٧~|S#}J<\!y1Bx^Ԯ/t[w'#`ڃVIsr4wOb5]xj3pVIzW&/o<}?eowzh=Oau DWݓ|} }н~J)_옸q}˷o}7_Ͼ|`~o;xendstream endobj 202 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 535 >> stream xE_HSaƿ3wNc9 FB!(]d^@I!owyfLpZM4 ۃyP8OoQ/{"u+@[ghҫaqmRIx(KPztU4U5uC%0o$e X!q*K~R%6E7_ϵOu53]}y)ܛ׎\,.ɎCR9I"?7gsdn2MO:y>7}TarZ w hendstream endobj 203 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 266 >> stream xMSBM10xAT  C$fx-%3z|yothhwX`{;M"I AҖ|QI2c2/d1/Y B!h~rttI5X(C8\L 7 2^oendstream endobj 204 0 obj << /Filter /FlateDecode /Length 17832 >> stream x]e7r%؏4`pP/}ҨxR.41.4|bnH$nm"y # k4o}BFy0nGDZ0ntF$o@V[n ֍[i@m r@j9%g'%;vS^SفSE. tuz9 r:y[EZ=<ۭY-fP#9(m@<cNmnȦ@w3V@w3%0v5`hDmY1nȐ@cԧkRS%^nȾmWt$]9v[S&~Kh[UZ-ΝxzNYVrj訨ŻK@G܆v+hhSX=8Ǿ2%,U/6Ѩl`ez-F%MJ9nBę.c\ α1cϊN"$n_O@ZsDkVy }mUs.qA[JRME4 uh&d6Ԥ%35 #\cz*6-ѤnoLrwSǾM4r;:bYR4{2 Ɗ2KPzGq+>,%]Υ1KYzKcϰR6#nu`rș+}L2KAfR6E(뭡EaLi, 1Kc6[ImѤ(r!,YP``GcX30A@~-uL1 Ug铫d q*&uˉ4 /l*D$9X,zDFA%AbSMY`r3IQUYXݲ`CSmv03];%g:q% w4 `A2N嬷%I Q:V,sG7Tx;}e.Ȓ8W6ʖ8WШG" S6ި!qy30$HJPPcɲQ76>|"iv*i HXd-^@gg-^̤4+?(Z hFEZiT[_4k={Ġ4km:O.}ľۭQi/fm]K>G ޡgdmDYo8 m(}C̊Qse2gF4k{Ni^<ϲV䬽{jvfel-ivNZ Y$MTKo%kVz 3A:u)qy4 uo-=Y(YhVW1ęëfvimSy1tLt[٬$ysK=U9 :-X :gUbxȺ1VJ&k1`"IcڰgǮ%&!YxdֽN3[)6'EJMQ6ij5[Yx3t=?e2(&͎HU,l%3k4[; YJi6DGl-&-kYy:)k@EY螽Y7lv*j-5ln٤_ 80ϖF>1LS)62*v>p&6Ι 3O 8B$2%^2fJ<{v9){yҔCKMP陘=teȢ0ۚ-ynU;G< &.fѵVI Κ9V[ٌMiCTO8{@T#S{,;!dgrEGE}wp%΅:Q%UH!Q+G9qXs5tN$^D%LRjCVܗˉ' o3H&NLڐ8 yFeR8ĨlP5wܧ>kS8ĪX2Ӯ(Qn;J'TbR~iJ6"K *'EͪU*߂~Q,B}7IXkcB7n - ˏ,jЩd^ZUfTJ4a{BjgƶpK0<(ԏS@Zh]S;ϳȯV9k/,E PTO;0St9 ;".ML+*,gphT</Zrʠ/ERXƚKjs2R\5}aj0pjpgRiV;s IS]$UNmi_m+> "Lj>US<BolSDيę [i!qfF"4>Ld?۔4K`QQ4VE"UU z04œrO4AOD I5:xDz,mbl7h/mVjӲ|Fe, z_ t`<~k4 M alg %@T} IsJנD̢yY(JڐE>MͬEDՋ.)yEgyԃFiJp:/@44647:S,;{BQm5%ξtj(ٗ7dYj5w!~iHyHIVSUgLJhm ì-AT=0)OdHGClT"=I[zZ'6$U0꤇&0=:CfH 3:N:TϰMM ^blO󎾽dv68uջ O7UX8y8'F;Z>6 a߅h#g{5.d.<@tۦYmm$H<~EY Z Y]¬yDCsn-TڽnOOm ?eYkzC vC97h&B"Ӗ[z}(R=1XQ%˲@Yy5eA!ճd iDS"U&ĉ!ͳ4dZ!icKcpY"'  R"[UYNuCtϢ$Bw[\Ub@ )BTzH i6M;ZT0hda^^HD)JgwW Is%#Z4u!2xhb8)R-iΣ>DJ31!ck}aII3c~HğEVLo4sxf#Z;á0Bd>{?9hٲtS$ď4Yl1ĉ@q#CāD)qGt0r @Cq$q$hf!J{_dʌ3 9}1DӾ m-D*aA%`8ZtK?E3'XUIOD5'+%g)q#,>+ѫ?! 3D > x0 L$O/#[D/ۍp 3bxATO Z`zrL} !9f-Ζ .D-9L@̡0q!נ0CaB52jEn YgQ!ևYH?P=aF:uO*# )FRmf 4pz%>PsjԎG5Ps(j|C\L*Wķ9ʂ#:nZޏ@Y]C4Oچthml.nj`~j6Ql =ڠp '(o%O1%r>g,i'|x!rSѧ-428c VJSorKB2f,ݱ!kS }O*ȋ ISqrM8=<@^ ]_:bڗtO}H3mʸ{Q ύgrASQ( `  EjSKPsc_٘0L #^-#D6df2cT#K /rOQ`$RLc\Ӟ28RpM#DC圞YCXӞ h`s 9<6D\LxꃜCINE5si Ox')1ԆH45F՚pvC /{$u!H00#^3M& +g;D|EcwPs&wCƼwK"HFDy0qVu'bHۍd rh^ QMpsoKDnCav0yGVIs8N!$#`Jps8rucGNnE !G03}B7oua#[H3:G(s(>n  0g5gXbI!H«6`DhTN,ѤxEMq }7Ciik < ω|h<9<і0"d Ij.RB9R;REF4#bHQʿ͡$TLa4s&Ps97&؋LEoi"ST!b/3݋ SFȑb,q}@56{q6QKeFđB^mD}n9u ZCh)y7h@`Z5!T/X-^Ҍha}^jD)Fq׳'@:^݈XRnDXB4FiP'B-aD2wCZŭ}7\D6Db G!,ΣE f.輖f.2[S|-헢g@1"~yF] e"햹XelU9xJ7뫴%"`M"-nM&.V̹N4N-N%P:cT!GaKQt6oM\)_15Iǹk Q76XQœ悶m"t+&IjC"͖<9fm"6\@GD'lt264ZE nDK s.,lC;mht+t]$(na.Urw˯ExA{lBqbKyp8_Br:IR mɍ]D0S)V19Bг I{,u:/Ҩg3ynޤ<>X{$Nи5~n scڶ S-@ymW5a0ُɋ@nXُa[9ǡWlhMrrF8^ؤ #{U 4uuu^*UzBUvODE 2Aivs$> f$QV{1R@{9f?`8ܬJÙT٪D@T^%iva8Cp썢/"ܠ;J3A|C-QĺK݉ d1B4D3&8bnՐ 'NU؋DWUjR*&SիtsQi`DlIӀlvF3qD*(j4UA1' Gb%Rn:+俘M_aNERO=TOUDB(HSguaHUS>DIM7K!:&BQ)3)J'DVjȯJńFCx+yxdwxdhA#+VHo|H/K DYQ."3mh)L>6@t,"d,(頟;Ҝ 's$4'd]NEnPb0L2V(@S6PmXROUpl }z4?9yJܥ&@?Yg,s63g@VD"ZIhJі,QKy} 2yKBo1+Ҟet7AS)]*tFƱP8RY юE^$ [.F qKNe]4ȋDy qn`psVR\$ŰCEzn e @7j'9#C$#G|?LjG*v7ɓ2b.p3\-M>F n&(r\*6H@-&o RCF ncȑN,xDȐ$(5RHs90B<*'򞧑-&d1;D[$Fv91N#bs11N1hnb X[yAC9MHT@'bHr1{6]\)bf5wC\$5Ȋ@b.ܷo)CE"~DFLb)д};"16 1 )ݐY0oWSF~h|ɷm;6 9 ŞY Yӛ0m/`0mdEIδE ňT&NOP>YcױXFY.e|L˿$pFDWvc$O be/6M^$Os DD~6 ÓrHT3A009%fmcDً`R#7#8PIoDg]v5_a;ZM%X~#[45g  y_"2U0`BVs!6GBD3ZjƩQ!zF*Sۦ@!ԛkĉHNU,}ײ5[h)-)-G# n9SZ8}g P }G8 ňN/:*` Y蒯 bt#Lgqze'DpDx(1`P,Ǜ YU8dΧ6L$KωͶy$LnADOϷDѥm碉X1mTmG-Q'h/6k4 #ZSIejf3J.hD2tc8b ]tbNB\@@<'2u;ѕHqcM\ǦEdӽxBCH1B#Ik Deƴ3b$VYU":k-E^n&,N]FU"MMfL3"c3-8I#8Qu@~k0Z&Ҍ9g"Ȑ^BЪytsssiyH}3UC"HK9f65ՙfӣ5G?2*Dϭ$P3)OnF`M; ,t'də\xUDo!N0e sLrd0O*f3܂xI(~!09MgdJ Oᗎ@!J@V'>C _ZgdsklhUں1$msf(^E-8JBLj@F *v2HAϡƷEf~m2#/&3F?~~T^XVH͈0 m@1Q/˛Z^IʯM_yۧ8􂾴f9(Ǟ…y2)S'x~^>BFGUƷ CJW'^RJ f}m?#EK ]ZGtL(뿼z :֚|oi_\WxULWחr\D/{!OΏ}~WWv}U/pUڷso> ȈQ\|7?zK\?6־׷AhE.hnEAeD]8?7_^ ڋ^7 ~-\z=<N״뗏F?X(I ꓢ@ ˏ~?R~櫏Ho顮>6{_XK`>VR Fv;~X~$>g;%:K|JfAiW~r03_c:_xUݗcRӭ}߼z[ ˸~q=/7Q4+J~"A-t~= ȥi oAl?: D6t2f ^s=QOnJgT@ia Fvsqi^^#D(kkVmD+,zGUEG\Z|q{ŽHľAb6Jկ#u1k 'jocO6qsKan y+O~?l/"#.XZot F?g/᧓Lڲݟ^SraçYJmg~wYk]ߟ[pQ{^+Jx' [@v}b?._7/?| A_&{u5lUecwo_U@}_匸٢] ijѮ~Nk;.o￸O?0'>'\0B`Qh{Y*Lp!GgѸa|Ќy/K3h4V~d5[֋ 90lP8ſ~ s O' g6ߺ[ nHiO}bޔB~VYѡ _kf>~ 1a8^`,*>ZYG'a \%٥O΋5LSU|ϱ#?+t5j{8+<J^?;gvm߿ŵ}/>yB@9 {O^J|xK\+Q/uرjz߾?bBBb=쬯kRKW??\ݮ_?-u2ׯwZ֮\ۯq-zͷ?5=WoJƛT}~xE_|o_ûo{w/wY|?? ϟqWzgnϯ~_Szo +Г8A _"?#(;]翡lKA;0z0\/X`&ӛ|M{ 2Ğ.1A"L2WUË+.t./!IsU .ڊLZPD@ YpXgQ)d Qtl;\+^[Y*M8_taLI*L}X>y1yWjK=?+XWR_U&3TmUUi**'<,Jkd$(' Γ z!}Ю!)2p_[*f$yib"^ϭo$ ;@_qȺw_~eK o-+ʼTkL otp^\ⴕJ=C^4֋HyZ:7g='ǭ»!‹=^{J˛hF?3.|dQtbIu=-Y^Cĥ!ߓ@mZ ><;-{lF3?ӉYsthvp&Lwfwn ͔^ []s~޼v7\ Ndjy' mL-/&]6Im\DH~MX!7Zo NO0r4"ddq$D(@0#(`>ۅ86^r?"r:?#EJ$ iŝF}3v 'Oݑ4K| /:Sgy<>ᩃ<<;PSyx~艇-;.܄pW2^#6u{w}ľg;O:&/O>e{,#W+y<78~-wHS6ΏV*>^#O+빒>Le8cz7ݪɃ ϒ9z7ֻBڃH&2n"45wz25DM)nyn"e?Lw+|ֻ&w3ßu8Wѻ,=/؟wzwnѻ2QjG^jH uVyƣpGbn&'[fƲu1Zwߒz׺  <DڣX~@vߑ41Y-:!U~ZeBʾ_@Q)_VJAdrTU|R~,z8X@d㺵2/H[׏^l\Òګ tH>:y92^> stream xLMRoman6-Regular-  R2zcOf}I|:}O˪16-X~_ȱЋ=:D\BEKmlGvCo  To m)^endstream endobj 206 0 obj << /Filter /FlateDecode /Length 1679 >> stream xXmo#5_qHxK73Q> THT-t{,&Mng{fywS8W/ LNM|: OݤS2Ze+,?̋]bHze,"2kůH`eXHOQ"e f0NhvS/!Z4V,1ab&-']C& (p(ꚗ]"ɔmҢsYÞ\iVEQӟ5\bX NgOfgCt~.Lrd-[z&e:mt: =Z^4^z/d ()cY?f)X34FE؏Eq*85J*pp~*8N?"NJTlkcB.mHb]4XuƷʪɂub+vUҎi^;QV7ЃA9y^OqumC"[:8< oz]ٮ5_ ~]oJJYq"rN˧hb/fUg҃j7.qʼVm|t'sHyEӘΉfM/fW?DIT Z^$ނfi݃LR1IEshfO nObFB&Ϊ@RhYG݉[aK@/: Z`ٞѮ%aR '~2 cHc8CXMErY}Ʝ6L.I?%>Qea[4V1sHLBKrW7>@)op$|j Aj>|6raI #j >frDՈ7buߤE]M.m^x2ULl-k+i\V˴ 1 'm+gV{c~,a|kD۱t[o>OlA #~O/ҨS8;vzh *qgɣ[imc܉XI T^2v~\b-H|+AeZb X/Ku͗J/z2USիuIo.R:%vAAQ[Զ͍oTΕozb=U;,탕V(ٶvp5߅3L|~W$-E2_.\pX?Sgw(wY&M:)|!4HMƇ)d~M ee"\Jc3>7ZwЯZ>v[oj2$DVDl.1rVYڝ@'^u8E^Q/cS٢Уnca:Te0~7^Hm[O:f;da@c=(חzp_YUc2a۳5u={:_9 CI8(qG4m7IMOA(:씳23hC`GWXIaMWϻ#6ᆡL2)w5@嶒/mg^twn@~lm$h4TG}s.PR/sM³>'? 9UFilM r!Ryf6i_23aendstream endobj 207 0 obj << /Type /XRef /Length 212 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 208 /ID [] >> stream x Q^fLc ,-ԔX[X+)Iy vRGl4u;}s6> stream xYko:bE4|ͣy4q$mEPl֭,$$[T-r]3gfH8PBA |$<iJ }PL 'Tڞ*U@50H`"p WB |T$H3` d (P, ($@g$9(EpJi .A>@Sk 0|0>_F|f un.8JL^ ʦW aN+7<{v~d JO}J}AoVߜWF f efߦ8w}񏺻rd2xvtqG4/Q- #̣/7QẼTt@OqszI+[1YęuiRȁE80(K 4hA=ې<]f#]qtYX08.M +!.sKS'C+sgwիBu셹q_y4Yt~g;C3]NF8JV*YbfLtAu ΀)~ۗ_}8\<2OR][=b TuiJ|mھ(\jEuu@Unw=rfuJ)Z#f̎XE5<5FO=+uGV斷&,̬<]}`d7ɣuZcsS?pލM~k]vw&-xRwr}g][`< kE{Cxb08ib.[]ۈ.-)+tql5 x^Am]?m- zBY_Ox^6!]%߄Xv ۜ:F6zt&evz^6y _QqitHk/ǧnHMՆD^w叿Ű= t@-̓/Dݲ㐇Z7huFPF4Axז;zkᆩmxm2jxPj{,ʮ@ {KZ[ԁã-YSE6eԆr׏j2jk7lԲaK <ݼ{T_p&fu]>أe[~.b6f=^۝ Tۢ!lE{x\Q3x cOɚ$FT%wu'؈*_PP$w x=q.CTǀ'Jad(S^ 5H-<v1N=T<Ѭ,Je?zO|V%r{ÝEK/ͦ{!|f9F_T%9 <bpE/Id88AG&x"n~qTOڋ@z$񄽠$SڙflgfSe-I^ PI> stream GPL Ghostscript 10.02.1 2024-11-15T15:10:21+01:00 2024-11-15T15:10:21+01: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"8# 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]ה߳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^aendstream endobj 40 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6319 >> stream xxixS i^4.ڀ&( "n t(SG:)M3IMۤIM:йt-CQQJnZ\;߾\{~;k#$[ee&oI] $&.sa)\%BC>蘅xAY&em꺴Ȁ^ؐ1윽}7+l Ivp{RXW{ugWO{~wx ?+dVJK<-n+g.N=8}/Ư5&i904yOƂÏa.nIoN+~9bz`J>͋**0FjLJ8'Bs5itPKᐲ (Ni!mHhț/'?1 sU&k H[*RNXѩË lxz aOk2ڜưQFxp%ގ>fWrg<27A-O=}>EX8*u9S` baF_L$ &\k;>'a$w0=5/g "I:;:_kdpWE$2Z΁gWHuuza.`vFĒ$d/E-^@moM^ѹ=>s7 ӇTn#T{̓3y5dޓ/G_mH c([l@>LNXI4X鐷EK_5o$4B{&}($wx>uLAYAg/ě/u\Lwo|2Y㾒j @;S,邌D Yzvu|IlC/| \Cۣ7Xcx6:>*\ngHơG0Ss2ECP9J"ڏ97~Kl3zz'{o_$M {+ BS .dOP)6+RejN t!UUpEШ{6L^7հحWIcq 19Le5@WE˩ad7N@0>ZU]j6H;۝7%3 R7<,+Nzo /30CU&]Z>)SR.}= :!bWV|T5o^oԺnM˸C_>^aN\Ro(--J"deU}-$|]h[Q=9u$>doTȲ7i.<.6[+kHQd$:c[kQ^TF^9eMUV`g  dޓAAAGNF䊇kk UW؃[ѥP[n};2*>Q@\Gjm-I\q,Q=rͻ,Н :yu 43C0j+7v3|XH7Jn$'0>nv*Rv.vutǟ)4!n:>+y8wlx.f%Jrq"ղZVҲ@<2$gi5{ء]V oU6<,g%%ܽgx\^.Bd=kF(]fswa .zJ޺'|Ϳ|G*qWS З(v@mqp_bgAr`*ʭ**0۝}^ka"{|bPʘK{[`B|L4Z *w{E+XPc9RAtm*q.ޯ&٢JkZ ~R#XR3TV 2UzA !yf_3_J[jm H1",)lW5gqY&20ӝn(,5KK-`&])e[Xp`OLV:$~_ WkGmWI؎ԠfJ*4js59j_Pn(#N_Uv@smeb rJ{iw?Vˍ`B(ScW!.\UHS DylUY VOղI?G On# 8{ԛ 6-۱ 4|o)ZNT)lQVS#Yp|VI\_UDR_:{ؓc6i-S=w Xet&zy8>5RT(QLKL䶈8PIALVg)`r}¬PH:4ty|ۻlfCxQ !8.eYsd9w^.*ʲ6t~9qѩ5Bgk;{eͮ֎?g1~B8 !7VjRc7]ۯWbiT9E4R!Юdj> OF@GŔM3X1uB{A\.Ba(jeB~8*c#IbtQcm (SԳ"?<6A8 =Έj(W`;.e ˣMJik) j>9]tB*Ӈ>YOobQV9Os|E?}stg{2Vϐ:obmk:*=P`E|:6 ; ]`p'J Y2uB҅lU{R6AiOo.DPWrﮆ;scvK e>z?y !sG.%hN/! Ҽ.&eL=~Oզ4z[nKە.O.+]N^Zv'?ٝ2={8< x$܍#\KI]i ܄添z/{0Ok?mZ')Vih~_3<#I⳽ZV{y"(.+ϔݝ }c@eC̻&y?n`%*S9fMLpͺE1%Jcab&r F{4'`GZ"Ēre茬 Ρ5&UZpwZKͥ&pKm8M.B SsnQ vkWGSJ{xg2VV_ Д][^#v|<[Ƅ"ᆎw 9u8nFA 6ދۭF |@0޳غKBSPAh4ͳc+LP dRG>u$'\j<19Řr)G>jnjq ot],9`?) kW{bWVj/|zI/%SQ8f ⬋{DdSv+8;p;{8s+c:O}aHZje mkU,^Rdߨ,zކl.-3351-)EͿrh8ثI.[\)A Hs@21%>)w/#Q̙}c5ِA6FZ8zG24^(jι6+r[?X08ٯ?mW5Yrn!E\#65C4OJʋˋMRdBo*LqMI koQ^{R[ _GhS ']_'yk8J\T`ok`M,l0%EmJZ ٜv"ϟ{shZBtp% >y@G*u y4m27%᷉4S .le2.;ZP/ҩ~N1/vf4I']9#@W&班(9Ԧ -%*uB~9.Z.roچ<:c~J _8{/빫.T̄*sYY\PRe,8=VF'^GÊo|jYD@֗#f\2|h6[9B_l!tO[ֿ6pvj;{ /))CzFі3zmzkG(g^%gf$%7fut55vtdN{cXB>GsɇғRjl9ޙޒ,߮y]D7 8Pbj]nf [`+ 9t+g4eR *Kw[>9fq|IONskcw,>gѨ3kjړIUݧe]$<ƅt=wdGKk}ľ;y~Ʒnh[ ږu 801μM|̭lBWRo|~{[ѫq6}>;/pgJ~͢*[qNp]osHgܻtn/G0 ʛkn& qdҟlM\WaP:(Ă̼|UxG۝keyV8I<>囮 q!pMn1_7)ܔ'+;: h({o@.,]kr: i9wy+>x$⃣ThY7pn|1;͇q[1J>c'; endstream endobj 41 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3149 >> stream xyTTW_ ԻQP^bh֎:*D@ ()z@@m\*b) j$.ɠ&O:,;13G.3g΃Oѧ~sϽ}}D J$ICRlh:$c+RL?셽=g:̬Gݙ.+[pPx8I KN9z2Mc ¨uN+AEQoQqjK LBS[!0BPA+(IQEkWVGs>/AZIu<ʘ6^OP#YPb:E {]L8 w + ;2D8ج/6k EfYq7nwuzAM8)XWYX4p^,ʾ'e^~;yd]`AtR FL'L'4[;kh<ƒR+ueN16Q+Cc3”2 _^\^P˫" \K֐|1܋ V1;d6H]{/ϰeDazĄ>M׫J2~|h rtměc$j`'r.S\b0b.n sF[1"9l$ q+ٮ.%$IBg~d+ +h,/2E!9覥N:"xӭ<5K:Jc\`kjw90 %duFQUcaɿ,|&86G8XU qE'Ro3Зc} VYGfn9VDj_ۊ}12 _Ͽ'dxCtIAI`cuYeͪ?}y 4OG=X;=/XahaG.eN[O 蘱Vg:?WocI,G_*kxDiJce+M魗"?<`t]&YP`h!R=Ypio$S˛rjݸ5It}c%/n:;J[3>2XENڒ)^1lۆ>.gY_啥ؿB DBvF;5GfMfj,` td҇׻3Cطh*VWx2uI+2kTWE<{m{yL99=#GGJ:kASBT̺VrAD G.2*[*͕EXK҈󭶻f"_j蹲siU]4ݐߌ/"{\ph;8 T%.D|) gASl&y DpIS 'M'W'??| /h$%{Գmnhw%2 X _N"ೄ ȉ*1 &&w1Umsv[-u2 puU [e2Zt*3O)bGT4uv:G_hcco aЧ{/Q&*cjX_go\,ل1N:ޞ5h̾ [ɚϓuDE wuVeݰca̢ E5x!4zGL4çyF|ĦˠqN$xs-.U4 &]v+BMJL63u3~:F׌G҆bA:~RmňYJȚaviJVK:mV! }E: 4x<-/'E}esLVcDH6 }Vz[,iL x\nܑ_fέΨBc'8D_c}^'Z߄o!}0*H+]b}YyqQf*(3`#J\oeʲS5t4N,;xv._iUk?7|!|,NhJZ^B:mLI96V4xl45;Hz:ښ>#!TӪ`$D_~$ҦM>߿ ς(?P|&?_S KbYmf#:tS738nf!鷆C&F̑Sv\/; k.K_58? ѿF\`w uVņ דּEsLu(6oM|ch};B'-< Ipꊰ-Mr85Iѵ S;JHۯq^Wzo!aLbaWu6'Ё7'n-m)zh 2! |ɇ^ F-ebi]}5`A❕HK1l °=$9Њe|(.5 tY߂0)) 'T}c˒. #`=F$UZXYS,c6 SS?~7 X$tRA|R B ί3m:=.’JāIpiD@w?tߨ_YH`QNc3 6BvL"Dr\ s ʼn SÓSV3Ux}4' }[:}&mlUYMU5Zo+R~[0 701wƝJ@IUSSΨϸ擄JV)CkɬDkiVYkuqendstream endobj 42 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 273 >> stream xCMR8q-  12OpbcVs,jŦf,hjዸ⋴ #h,t`‹ ' <02ZYΤ<7#B? rGlwYx?{F 7 oeendstream endobj 43 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 136 >> stream xcd`ab`ddds$~2;@њGݿ|w9wY^Am͓['Mw;7,5GO|>'?+endstream endobj 44 0 obj << /Filter /FlateDecode /Length 162 >> stream x]10 E7b CQqP(C[.|D/J`H"L4;0S d  }Bymʦ3 A#E3N?Lp^lWJ)lTr43'S- 1~ >#\Sendstream endobj 45 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 231 >> stream x#CMMI6  gstar?M)Juuvd~py<~&w{D~tL~}{tLX~>;yiq]ylhM 7 8Xendstream endobj 46 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4225 >> stream xEytSվbJ&8O s)-VґҴM49_c&-g(-P" 3^}zݷﭷ{뻾3SgUizeճiyەGS8go ~O#JFo< g;%J˗U5۳WisVO-ؑV,~U,o-//7-{77o9y ދռ5Y^i<>^>gJҧd ~'Iahh\x/q?{ԌKI$ <g7CCC1>4O?˝:[969Fę~Z# b8mu[&^≌5~<n\'>]7Pat-Զd, 6+_{ pM܂XU,myLLH[DpmUk~l>z^bb4e775l=7.^ud0f=r[(y($.S QR:j*uŬS7)bot^#/<|!89ĸ'b|41ftQ鷄t!G hcwwU|WEޞJ dP1Yd:n@4Yj*> OIl锃ki(ܮ3ȴkt?"^@ 3H%t5Ͱl` AD+ d.`XK~>ipFeMq,c8LKU,?>x#E@OJ5yaDPΘ(Q&2oܿ$7JuC;uQ$)4lvxD*{Y6eW fFw@ h[rw"i2_;M44szN&:A$+ .x3.]ֹdty4.\m9"'"|D7QZ^&b-]w26I3mK]C)ha$u<0z<]["eJFF͇ѯ=|t{[''Sy:hъYmvDeZl6Bv|sVa n\EQȭt n>%VX('%O7oH2hz 4]%o1;4.}GUZ+bGE4r:93|NvGMHO ʘh]r ⊉i*z-{K+PZz}`-߳(ǥ#;7,|4u5UR_rk{% pSlPgYg[ OewK;t @Uj wH4[pOĥrCCqi7讁qh(?ߎ؍(kٚ2Rmךf :#梍G^D3;aҫ!s̨h2`7DwףW@8E,'XzC>C/\F G)kq/- 6pZIe+j0nn_Gg>LI ML1eI,BavlN=u9S2uΞ"d?5'jcDBTQt/DaTNbNjF.P[D,` @7D=u~pMƘXrhIҌf-\S߃z4_l^I:qWJ0!s~YfFr8]>2yN}~D"x4 v^cڴ5ŰVTlVVlR_~8ݍ {뛓C{oO5"oNt(mY,xT` sVh5Xz~QSݴVŶ4 -mu^EUφշ܌01:FI~+w{SҌe&3WGFnb=wy t?36^حe Ϛ ˮм?ݺx:sJ0ˢTO+~GgQDͫVC.D~q/ y(~Xݔh#`3*{j[ 1P @ys4O徖u >ݗΜArʈ_r$6Y֧Pl" zBGEϓU&Scl51لȨu4D~Dup;$-T5UvttVڊq'g$0SktC(z%ǏORTrB#έА5 꼵>Drq՞FVґQ0A?~) o<0ծZ[54'67FQ]QP.Cь "=AO__ F/5 71Sˊ1ϸr^QʧWOў=!LD]JYUH&\+/ DMbvL-*ȋ멶׎)AǎHG); U)KZ;{ZwwuKCJݪuOy28yM Uܜg_S$}ܣR[cV/,)UPJ7i:wrJA_3v?yvp.bXCdp&CH}W7k=/ݞ2x.~!23U;*%.flj6j * /u{tOĴQҪ z|yhݰ:+ HWA7],8I NKeXFVOHQ? I.a41nq mZy?endstream endobj 47 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 613 >> stream xOaߣ!IMc tQCԠ@s(TB(PV~okK!H< 1*`!h⠓ &:8Yy򡐶QU^qQk;}nk{N\% z \eK´j:JtEBZ4B1TȄq_JMV-Tpr-MH+` Yg*#]`Iy/Lr,1GDoH/)8 xMYB!*qX؂.sy8^3T!H&5*yaPbv.V-rԙ0XViS~c )˷:>$>(F!@22s0.U7ldP1~9UEg :%HA,Z7eoX|fo['f3YapWq)@(,i`ߦԷ 6Vsw=y0QpƆ.CO_+W>$FaY)yn!?h|Sa,'ۈ+L|6ٟgWɉdBQZi`-]eo2n/A71endstream endobj 48 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3005 >> stream x}W{Tg!0*b@3>jJַ(Ul@+( y I!>:]*>hvSGwqmNٳ'AMڳgww#$A$u%[_\:13'dM9W~sN@++^N[_d.7N9\z׿fT|H?oW|^aOȪ6 r(x>ڴmY0kNя6 _ަ޹maMRH_eR48c? $8׬c~l @'Hp 8]NC㈁*+ ,nn*$4]t&R(PpP e>L\V`!X go?\>cDLO]z֏?.&Q8 ISXյۃ 9< p M<\ ۠W83l!֭@ie;-hzGNeb{jO:Cq0SB>d0鐑Ѻt.bJѾR7#1avrf " p]d<A#% KS6fq!3\:gmuаfZwkMZT<M7j`uN`0 ܚm3QivGAQG'qEҒBݗOߒ)E^3m”5.d8pݖcaiڡZ|yߙ>kDPz2>`׺U9˫rAEƩsYf[tu 撿hL_5oYs}5Ran$^a^rr.s:h?ξub9~):~\94 6 &SP,8"Q7_±!:f 8iœq1^@iºL;tH8Zf YzLa?NqUꖢټΕ!'a%É uߑ^ݷˇƭtu:--kyϥCQUKݠi+@!Wi NԈֻJl {#bATq?GJUn'CgdB*Xcn̾O.duJ~9y̌i@Կzp,K%")cA&Ra('?q`=^%у!"7PBMALu65?/Ufj成$E=*z f݋?^Ip L`.^o9lG [uFAý%IJ;ryvsbt#Lf" h22ʠ?>ڃD =Bx<^XP2z՜4gjbXB8MM<818?±Wܻ{fnOY<0F($6{CnQ$|+%P=,&Њxn٬W0#f,?sߏ(Z$%_`cAE_k:2{tv5_@1=n2a ]/W{l`"}ԚI41A RO( 1-6.K҃lI)KgqraeQs>ͰZiz|xtJ>?0 )E{߳m$B|>ς#{ o)u#ىyGVX.ڳEk lVOER:)Y{Nk:un{BW4 &Tuv8a R}R?[TmT񴹹Nņ;K_d Ii#H`f]'ZУUXѪ.Ph\B/\,ChߦSq!dPi:wb.@ u71Mu5"P_ӾA g󰜚Dy08`%F+RّfsXJbG60ZuvJi4d{'rMUit62"7L_")}  &g&F'} `1 tuhP F=Cz)@V;zҪFAiȂ5ʝ^tAgb2ǯQǢU:|%iEVq[JPs\|I5\:auTLOšdž@sendstream endobj 49 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3222 >> stream x}WkTS׶1dg"j[P;"ԪT T(*)XCM@HR+*Q >Xrܹ{G@H܌3k͹7FI$Q!;Do_q쇯z?|#؋=$~6S!D>7* A4 ngȣFG xwq`7ZwϮ+\}WoI/?x) lэ# JۓK+:HdmtDU(?f°+)BMNV!bbmzQbMEv;ZE+$8¤|2WXq~a!2ALԴ]I?d=zxwy̮qCg|[KҴ{5~O(Tj ^ ;}1e<_N]>p6='a;s|>'PS}MΎ1j))i| Ib)nɍE|eSOѩu̬4>t{LC>@ PH q+6T\4*i+/4[te@l>uQ+S,m$տVtJ#3c >E [+ݦd-qP@&[a<hە0Q sW6hvݐE͞[p9xP(9 b ?sIz{<|) [IaUTp!ǃ!&O!dTPio@ŌNUi2/91D2OÞiUX)yGn9;Ld:@o`xCށ fj{*jo;s c:Ps;h^q?{Lj'wg'χQ\ .X"z5d{|?1d+ND szVw_FؼmnD(і'm CAʦ >HR8(*8Bub}mktr̅\TK/ܓ+l+-1,Z5Wa[rwrݠA_zr Xb&xgā Ϟ;7hP Lt$iH\p?hY;om70>b 92ש!̳) {wQVpr~nل&z ~#hRMTp}~d LIFjhR'rdσV }S05GэkHWͶӔׅ!"DNT_slK@V넉>уS{lO?M.l[Ǟv+İ6 żC XRX.6snյkIR+O!K<g ½9IUS.nt1`P Sǭ^g*x$RX\1k?Ң?V\'2"C.(#/+1"^…1W >!0dcb=Ozd͟Az㧾C̝kn}?!djQvsY&cɟb/>]ެt96Uy%ZF"1L4j$v`{D;h~:~ 1y'U_ s#BWsy=Vl7s+/ XR櫝<?MAiYI$qb *]Yywϴ(eVDbdi=ZȐXY7detz4e 6Prfkh-(KnIBŽn?)G+OEU *hB[GꢎT!1Tk@Z}(p48,j,v뱚_[d꼹T\̱&7m$-r8DznJGx!ً=b\^Qvct*J7YÓ_ZWU:]~^i!+tuiڤP>.)9V/)Gj."~ӺC7%qIT vGZ8m &jUJIJup)\Ā?z7,Gc ,9GF{Y 7Gט~Ig$QA1Gv 5n&PL&-;PP\endstream endobj 50 0 obj << /Type /XRef /Length 79 /Filter /FlateDecode /DecodeParms << /Columns 4 /Predictor 12 >> /W [ 1 2 1 ] /Info 3 0 R /Root 2 0 R /Size 51 /ID [<09b00312fc547f861a012db62577cafc>] >> stream xcb````bd.>&H&INk9cx"^& L < u5 . endstream endobj startxref 29523 %%EOF Rmpfr/inst/doc/Rmpfr-pkg.R0000644000176200001440000002650514715653073015075 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.R0000644000176200001440000003075614715653115015727 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.R0000644000176200001440000000164214715653063017514 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.Rd0000644000176200001440000006135614715653016013403 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-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. } } \subsection{BUG FIXES}{ \itemize{ \item . } } } \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. } } %% \subsection{BUG FIXES}{ %% \itemize{ %% \item . %% } %% } } \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/0000755000176200001440000000000014715653115012447 5ustar liggesusersRmpfr/build/vignette.rds0000644000176200001440000000053014715653115015004 0ustar liggesusersRMO@JE?{C1HxFQ%7b[)%&v߼y;/`4 M뢀67N2$1[KrfáR ۉ3:QV+MÈ6'vCrWH%œ\w-"DZq$1drw}bZ\ \KgabI`,$)c\<`-y8tqY٨jyz744j4G$uAsTW4㉾6cJ)./^)ڠH2->'vUr)k:W^ Rmpfr/build/partial.rdb0000644000176200001440000002536214715653055014607 0ustar liggesusers}vF'%Y E^bIMY&)qٖ,-GdJv%@[Pwc3/3pas $B89pD]]]H?rRoE"Hd?_H4\-rYI HRáAc*H'mV[TVHd*ɨ(2 oհec2!-=L?iyoҾ/Ֆ٨C?[ #ȑ5ʿOkfgTflg5SVZjF0(o-j-hzVֶR JBɱ噅ޓYM})p-s-Lm-dRWbַ (|Ӡ#K&=C6n[(<.8lg1X}=(PZ Oզ>3; O=3Q @/PzWJBj=Bf#_%6LQ3 :'#ENbONv zP|oZ(<>l7 (5^#2ѾYIDhD%"jy”x=8#E(/84o%(/g  !σctE"`NV#rHZUTT(D X#SMOP~kԫDˆ*EãDL1K>DjDV0ʩF㔾 ύX@H2 \$W %)T FRY"br{kkeo5 4 tz!dJ!C J/Co7\$Ea\ح$g%Uȥ5HaǜaN5qڗQ ʯ<`}٪%)񌎫"/#bIӶX> MmI!][}}n[qS)"UV!2Qgq `_IIqq^ٹx ov ,ځ^>ۉ1*JBn6fl#&:zT%fpjxOd75^S.jL/?iī̳>X6Œ27=(W {6mz)5(0"~m4p"2<~G7ϿyUaib#osэ&-#jܹƔ:WI Y%0AD9B5# 6jT^u3Z3}QzCn.3$FZg 5B<33s\.8F+]$GDh Â3OH Υg.6,JHEĚՋx} ^h}ܷi ɸ\j.f IdF">TH2OJF+RH*l72J5$e,rf~c݌Ogҹd /d/mA S1j 4«)3J|:zPTzsh} upR(rpBXU1BğBjY긛ҹ ._3ubN"DTkΞB)QG7*#駷WWCSHVV`RC)QYzfxD!"N\V@5>ahbN(e5΅F" d=ʧ˒R%-+ҟY(5Z/b []};*0Gd_T& 쓅Pk莑Wpά=0s_G^(Yά $F1v\覞DhlfAVSRU(t$%t <,Y1O (A7V+6[(B=72n0¶pk~ sق}k~S~8qn<,#d@S-Bl+r&ѷTb^F$V]1a~(FI}8Zl'rWan[( s" tӍ&5?dioGC#$l.jAR>aV`vBxB1AˋpQwkV6/0-s/%Qz-F¾k=BQeoyMGMHp4f+5`EMDD(hg286m֍lj.@b8H1 ت$8ߦ)DBu^2a c[}VA :8JL8ZEy# 6:@I e[kXȈ>X󌦐p0NM5F{% (yQ6E:8 d<>!%m/XgSDBиq;eZ,fW c~Jq 1kXf|"2*NϠ\h֡y겺hK&Go\Rv d\=fPlLX!q^I|_!'šz9J>kֱB1.^GK줞8vP 8C* 0 oDS57L!|g@UFÅfD^'dxT7{.ijgvj!j*uB %J t JN'r\$AiL-#^$rh*FDNd7I\%f#{4&<|>zUF$[{ƟU_J5 wU:Ʀ`Dsy8Z)lbek!ΫXcQH%hteSRUF óF (r:X $."t`|BJ5{chU#D88-Yo15U%hxƈ᱊%qtDB#*YSuc%H8,yAHLse%+רa@Vc:D!mU_#UE-,b%D)WLa5TctpXZM2/,4spZ־H)LzPTIXE!y.Ҫ1p)6}:F(hk Wm} ʇ㑍`7%XC̖ ? (g@o@M@oBf ۣmPeb#nU"4D0*qh`TI(OzV;)#Fd̟tEOL} 嗾;łM+@WY.#q%_NXʯt`<{}Ee(_/H?%]oi',=]F4eވ9U(Rog G`& t랕fi [P}z&UZ~ W]<~ PǛ+GXëux<ۋ\q(~4Y鑇P~tGJ'؊{Pr0,tʮrgB{t ʮF3@4픃.Og^e:+FzQTZ%KIڢ[Tڤ=NL|~R琦 F| lz=0&Ō:fGr:bnjDnU+@އ}M + z" {(2R6"(I|\To^}Ǻއrq˃M ?AbmByŔk r|^3UAkRu9vgc@oBϐKEe?ƥBp45@c@Kp&`n`8nP}q)Ł+ߥd`ҟs> ~B =)E]7[({H{0`_;nc;=&t AŁ ewm1ȸ@\ f߽[.v 2O!(ʸQLB JK@9(s[ZZ=Px1Z F.z~<y͋yh ̫i\ƭ1AĚYXטSϥr#8KA`lsm=Źmr }(JpvpzԠFq@ɹ <-8?nnDr>(H݇~Fcxdc(FeM/P}K4!:O<ƍ'|)!%ױR>ka)8ްtpu.`nD 0Mf\"wP٩ߠF\qoθ M캚Vrk.[ntg=9I=Ā/I`dG<X(YGX[rxR7eX4fo4is48)  m 7PvY jqH2 jqش2`PqCI\f3m06wo(toP-xtKB^In#}XbT<%IXbuVnr菠j: !9A=g$$Ktx7SS=5Ww.]E)Svx l כsc`L(|MdMjȂ[qA8@F)H뙂} jSpIsRd,X\ Z P,"( vfKbfa9f)ߙM/ cyDD@Y<2)RgͤHAD3)epk `n m(gii4naZp, ynᚓX܇`JҖ ?Z,+=Ep8ڲH '똗B X7‹eW{ ݀\v![]<\"&e]Gƽ^fou`3m``3mpdf̜Kl-+ȥ^F`qPv7!sl(}w 'p`e{.(eʲa޲s޲fY_n7$YGȲ#7/٠ yՀ/HYN ԰'bdŷ$i(+V$$ʖtD;M sa|75F9_758Gy@.KF/<@|i.͇cq~|sYDݲ"j#ys{Z՚8¸B6\'hT5) @5$Kx j~(뉍' 'JcynL%5"!T=/ȷ p=ׇ@e@eYa_r 902)<LnX9`spXcv4\FKS3ľ*kDa}xm/$ ' ^ln}Ꮆj,(QlNC/@piUz ]PϗUTǝV9LՎ[>{cgI(4/K0O)ѓj),B6%Ku%]4Y]f3Rڱnj{PKŚ:Կ' *l.5j,ѸԄڤ:D9U]8fu580j &nOt &-us$NWqnb8h>߉6mϫ@p7v^2I(!W3ϑƆ! łM@G)U (phj$ObT@.Z_mI7݅ݜ4нV]re]ï460<X΄Cv7zfTLV]08 ts=_c{G(urq-'PQ6;"݁l Q{/'M@LCjb"qFA{ o;i. o;`LwkZl9,cSObyHs8ֱ֑1ëL9ΊwseV|ئGAGi8zb&֯V5p\WRQ&cMCG[^{~\efѳ4'SDS2_Hfs{}~9uL(x?xS1z|\w*Q aTCT wȎA?Db=͋URqܠChġp^{nЂDl"8fShv:Q4^B$Ȍ9f-0yG`v:8R!{t;`Dz_2\ڹdV_%SGU1<FZ]7U:A !|b}F4TA` Wh̯uXږ"Zveu}`N/wv]aTd-m8'U_5Plzz&C SR܂mػU U|g3-lve"0?Z7 R5ZW&IX>S,V9Œ; -}Wy_r뼍n-p3pC W+-M3rx`=ʦ5$?Zl-+ַl!U2Ue7 siU.kLOꩪa!cN/~dVlA׳-R\1^19<쀮aUaa`J{bp/ҫr[ڴIsg \G] q(SW*glwCл:O<ϟQϟ?mCd^#)?A;7Mh1"Ux4c5|e=93Cgu8Y1G]Xw۽dz.DGڸdڒenۛ{x9.̰?BZeYœ{h )?zsGٻqV?G.d  dx͔  "0‹-~м^*r3D[i9z>>iq!kY`/pP_C>c˴:臶jd̳Y8ѐm}2nd8/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 `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; 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 # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # 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 test -z "$as_dir" && as_dir=. 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 $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # 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'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 as_fn_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 -n \"\${ZSH_VERSION+set}\" && (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 \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; 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 exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || 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 as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else 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 test -z "$as_dir" && as_dir=. 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_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS 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'. $as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$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 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=`$as_echo "$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 || $as_echo 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 as_fn_append () { eval $1=\$$1\$2 } 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 as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } 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 $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$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 || $as_echo 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 ' 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" || { $as_echo "$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 } 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 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_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" 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_SYS_TYPES_H # include #endif #ifdef HAVE_SYS_STAT_H # include #endif #ifdef STDC_HEADERS # include # include #else # ifdef HAVE_STDLIB_H # include # endif #endif #ifdef HAVE_STRING_H # if !defined STDC_HEADERS && defined HAVE_MEMORY_H # include # endif # include #endif #ifdef HAVE_STRINGS_H # include #endif #ifdef HAVE_INTTYPES_H # include #endif #ifdef HAVE_STDINT_H # include #endif #ifdef HAVE_UNISTD_H # include #endif" ac_subst_vars='LTLIBOBJS LIBOBJS PKG_LDFLAGS PKG_CFLAGS PKG_CPPFLAGS EGREP GREP 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 # Accept the important Cygnus configure options, so we can diagnose typos. 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=`$as_echo "$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=`$as_echo "$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=`$as_echo "$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=`$as_echo "$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. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$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" ;; *) $as_echo "$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 || $as_echo 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=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$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 guested configure. 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 $as_echo "$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.69 Copyright (C) 2012 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 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\"" $as_echo "$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 $as_echo "$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 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 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\"" $as_echo "$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 $as_echo "$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 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 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_mongrel LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists, giving a warning if it cannot be compiled using # the include files in INCLUDES and setting the cache variable VAR # accordingly. ac_fn_c_check_header_mongrel () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if eval \${$3+:} false; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 $as_echo_n "checking $2 usability... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_header_compiler=yes else ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 $as_echo_n "checking $2 presence... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include <$2> _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : ac_header_preproc=yes else ac_header_preproc=no fi rm -f conftest.err conftest.i conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( yes:no: ) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} ;; no:yes:* ) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=\$ac_header_compiler" fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_mongrel # ac_fn_c_try_run LINENO # ---------------------- # Try to link 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\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$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\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then : ac_retval=0 else $as_echo "$as_me: program exited with status $ac_status" >&5 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=$ac_status 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_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 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else 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 eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$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$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\"" $as_echo "$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 $as_echo "$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 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 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 cat >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.69. Invocation command line was $ $0 $@ _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 test -z "$as_dir" && as_dir=. $as_echo "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=`$as_echo "$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=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## 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_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$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 $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$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 $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$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 { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # 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,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$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 { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$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=`$as_echo "$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 { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`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 # Check whether --with-mpfr-include was given. if test "${with_mpfr_include+set}" = set; 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+set}" = set; 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 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else 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 test -z "$as_dir" && as_dir=. 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" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "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 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else 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 test -z "$as_dir" && as_dir=. 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" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$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 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else 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 test -z "$as_dir" && as_dir=. 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" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "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 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else 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 test -z "$as_dir" && as_dir=. 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" $as_echo "$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 fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "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 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else 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 test -z "$as_dir" && as_dir=. 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" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "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 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else 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 test -z "$as_dir" && as_dir=. 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" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "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:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$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. $as_echo "$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; 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\"" $as_echo "$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 $as_echo "$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 () { ; 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. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 $as_echo_n "checking whether the C compiler works... " >&6; } ac_link_default=`$as_echo "$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\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? $as_echo "$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+set}" = set && 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 ac_file='' fi if test -z "$ac_file"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$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 { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 $as_echo_n "checking for C compiler default output file name... " >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 $as_echo "$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 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 $as_echo_n "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\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$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 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$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; } fi rm -f conftest conftest$ac_cv_exeext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 $as_echo "$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 () { FILE *f = fopen ("conftest.out", "w"); 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. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 $as_echo_n "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\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$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\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$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 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details" "$LINENO" 5; } fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 $as_echo "$cross_compiling" >&6; } rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 $as_echo_n "checking for suffix of object files... " >&6; } if ${ac_cv_objext+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; 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\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? $as_echo "$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 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$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; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 $as_echo "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 $as_echo_n "checking whether we are using the GNU C compiler... " >&6; } if ${ac_cv_c_compiler_gnu+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_compiler_gnu=yes else ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 $as_echo "$ac_cv_c_compiler_gnu" >&6; } if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 $as_echo_n "checking whether $CC accepts -g... " >&6; } if ${ac_cv_prog_cc_g+:} false; then : $as_echo_n "(cached) " >&6 else 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 () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes else CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; 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.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 $as_echo "$ac_cv_prog_cc_g" >&6; } if test "$ac_test_CFLAGS" = set; 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 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } if ${ac_cv_prog_cc_c89+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include struct stat; /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) 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; } /* 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 don't provoke an error unfortunately, instead are silently treated as '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's necessary to write '\x00'==0 to get something that's 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 **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int main () { return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; ; return 0; } _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 test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c89" in x) { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c89" { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 $as_echo "$ac_cv_prog_cc_c89" >&6; } ;; esac if test "x$ac_cv_prog_cc_c89" != xno; then : 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 { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 $as_echo_n "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 ${ac_cv_prog_CPP+:} false; then : $as_echo_n "(cached) " >&6 else # Double quotes because CPP needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-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. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # 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. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue 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 # Passes both tests. ac_preproc_ok=: break 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 fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 $as_echo "$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. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # 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. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue 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 # Passes both tests. ac_preproc_ok=: break 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 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details" "$LINENO" 5; } 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}" PKG_CPPFLAGS=$CPPFLAGS PKG_CFLAGS=$CFLAGS PKG_LDFLAGS=$LDFLAGS { $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 $as_echo_n "checking for grep that handles long lines and -e... " >&6; } if ${ac_cv_path_GREP+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$GREP"; then ac_path_GREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in grep ggrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_GREP" || continue # Check for GNU ac_path_GREP and select it if it is found. # Check for GNU $ac_path_GREP case `"$ac_path_GREP" --version 2>&1` in *GNU*) ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'GREP' >> "conftest.nl" "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_GREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_GREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_GREP"; then as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_GREP=$GREP fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 $as_echo "$ac_cv_path_GREP" >&6; } GREP="$ac_cv_path_GREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 $as_echo_n "checking for egrep... " >&6; } if ${ac_cv_path_EGREP+:} false; then : $as_echo_n "(cached) " >&6 else if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 then ac_cv_path_EGREP="$GREP -E" else if test -z "$EGREP"; then ac_path_EGREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in egrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" as_fn_executable_p "$ac_path_EGREP" || continue # Check for GNU ac_path_EGREP and select it if it is found. # Check for GNU $ac_path_EGREP case `"$ac_path_EGREP" --version 2>&1` in *GNU*) ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'EGREP' >> "conftest.nl" "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_EGREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_EGREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_EGREP"; then as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_EGREP=$EGREP fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 $as_echo "$ac_cv_path_EGREP" >&6; } EGREP="$ac_cv_path_EGREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } if ${ac_cv_header_stdc+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_stdc=yes else ac_cv_header_stdc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "memchr" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "free" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : : else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) return 2; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : else ac_cv_header_stdc=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then $as_echo "#define STDC_HEADERS 1" >>confdefs.h fi # On IRIX 5.3, sys/types and inttypes.h are conflicting. for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ inttypes.h stdint.h unistd.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default " if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done ac_fn_c_check_header_mongrel "$LINENO" "mpfr.h" "ac_cv_header_mpfr_h" "$ac_includes_default" if test "x$ac_cv_header_mpfr_h" = xyes; then : else as_fn_error $? "Header file mpfr.h not found; maybe use --with-mpfr-include=INCLUDE_PATH" "$LINENO" 5 fi ac_fn_c_check_header_mongrel "$LINENO" "gmp.h" "ac_cv_header_gmp_h" "$ac_includes_default" if test "x$ac_cv_header_gmp_h" = xyes; then : else as_fn_error $? "Header file gmp.h not found; maybe use --with-mpfr-include=INCLUDE_PATH" "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for __gmpz_init in -lgmp" >&5 $as_echo_n "checking for __gmpz_init in -lgmp... " >&6; } if ${ac_cv_lib_gmp___gmpz_init+:} false; then : $as_echo_n "(cached) " >&6 else 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. */ #ifdef __cplusplus extern "C" #endif char __gmpz_init (); int main () { return __gmpz_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_gmp___gmpz_init=yes else ac_cv_lib_gmp___gmpz_init=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_gmp___gmpz_init" >&5 $as_echo "$ac_cv_lib_gmp___gmpz_init" >&6; } if test "x$ac_cv_lib_gmp___gmpz_init" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBGMP 1 _ACEOF LIBS="-lgmp $LIBS" else as_fn_error $? "GNU MP not found, see README" "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mpfr_init in -lmpfr" >&5 $as_echo_n "checking for mpfr_init in -lmpfr... " >&6; } if ${ac_cv_lib_mpfr_mpfr_init+:} false; then : $as_echo_n "(cached) " >&6 else 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. */ #ifdef __cplusplus extern "C" #endif char mpfr_init (); int main () { return mpfr_init (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_mpfr_mpfr_init=yes else ac_cv_lib_mpfr_mpfr_init=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpfr_mpfr_init" >&5 $as_echo "$ac_cv_lib_mpfr_mpfr_init" >&6; } if test "x$ac_cv_lib_mpfr_mpfr_init" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBMPFR 1 _ACEOF LIBS="-lmpfr $LIBS" else as_fn_error $? "MPFR Library not found, see README" "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mpfr_digamma in -lmpfr" >&5 $as_echo_n "checking for mpfr_digamma in -lmpfr... " >&6; } if ${ac_cv_lib_mpfr_mpfr_digamma+:} false; then : $as_echo_n "(cached) " >&6 else 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. */ #ifdef __cplusplus extern "C" #endif char mpfr_digamma (); int main () { return mpfr_digamma (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_mpfr_mpfr_digamma=yes else ac_cv_lib_mpfr_mpfr_digamma=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpfr_mpfr_digamma" >&5 $as_echo "$ac_cv_lib_mpfr_mpfr_digamma" >&6; } if test "x$ac_cv_lib_mpfr_mpfr_digamma" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBMPFR 1 _ACEOF LIBS="-lmpfr $LIBS" else as_fn_error $? "MPFR Library must be at least version 3.0.0, see README" "$LINENO" 5 fi 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_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$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+set}" = set || &/ 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 { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$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 { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$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}' # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. ac_script=' :mline /\\$/{ N s,\\\n,, b mline } t clear :clear s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g t quote s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g t quote b any :quote s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g s/\[/\\&/g s/\]/\\&/g s/\$/$$/g H :any ${ g s/^\n// s/\n/ /g p } ' DEFS=`sed -n "$ac_script" confdefs.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=`$as_echo "$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" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$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 -n "${ZSH_VERSION+set}" && (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 `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; 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 # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # 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 test -z "$as_dir" && as_dir=. 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 $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # 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 $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$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 as_fn_append () { eval $1=\$$1\$2 } 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 as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } 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 || $as_echo 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 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 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=`$as_echo "$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 || $as_echo 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_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" 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.69. 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 cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" _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 Configuration files: $config_files Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ config.status configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 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 ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --he | --h | --help | --hel | -h ) $as_echo "$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 \$as_echo "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 $as_echo "$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/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+set}" = set || CONFIG_FILES=$config_files 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" eval set X " :F $CONFIG_FILES " 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=`$as_echo "$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 '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$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 || $as_echo 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=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$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@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$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"; } && { $as_echo "$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 $as_echo "$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 ;; 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 { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi Rmpfr/man/0000755000176200001440000000000014715653040012120 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.Rd0000644000176200001440000000465214371453423013652 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}}.} \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 } \author{\R interface: Martin Maechler} \seealso{ \R's \code{\link{gamma}} (function) and \code{\link{pgamma}} (probability distribution). } \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.Rd0000644000176200001440000001616014245753567014545 0ustar liggesusers\name{formatMpfr} \title{Formatting MPFR (multiprecision) Numbers} \alias{formatMpfr} \alias{formatN.mpfr} \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) .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 is compatible to \R's \code{\link{format}()}ing of numbers and helps to note visually when exponents are in use.} \item{max.digits}{a (large) positive number 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}).} \item{big.mark, big.interval, small.mark, small.interval, decimal.mark, zero.print, drop0trailing}{% 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}. } \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) } \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.Rd0000644000176200001440000003344314644764560014533 0ustar liggesusers\name{mpfr-utils} \title{Rmpfr -- Utilities for Precision Setting, Printing, etc} \alias{getPrec} \alias{.getPrec} \alias{getD} \alias{mpfr_default_prec} \alias{mpfr2array} \alias{mpfrImport} \alias{mpfrXport} %\alias{.mpfr1tolist}% not exported \alias{print.mpfr} \alias{print.mpfrArray} \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{.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) \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) \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) 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() .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, or missing.} \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{digits, \dots}{further arguments to print methods.} \item{max.digits}{a number (possibly \code{Inf}) to limit the number of (mantissa) digits to be printed, simply passed to \code{\link{formatMpfr}()}. The default is finite to protect from printing very long strings which is often undesirable, notably in \code{\link{interactive}} use.} \item{exponent.plus}{logical, simply passed to \code{\link{formatMpfr}()}. Was \code{FALSE} hardwired in Rmpfr versions before 0.8-0, and hence is allowed to be tweaked by an \code{\link{options}()} setting.} \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{print} method is currently built on the \code{\link{format}} method for class \code{\linkS4class{mpfr}}. This, 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. 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{.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 ## 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) B6 <- mpfr2array(Bernoulli(1:6, 60), c(2,3), dimnames = list(LETTERS[1:2], letters[1:3])) B6 ## 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) ) str(xp4 <- mpfrXport(x4, names = TRUE)) stopifnot(identical(x4, mpfrImport(mpfrXport(x4))), identical(i8, mpfrImport(mpfrXport(i8)))) ## FIXME, need c(.), as dim(.) "get lost": 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.Rd0000644000176200001440000001342614644764560013374 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.} \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.Rd0000644000176200001440000000754614533575120014321 0ustar liggesusers\name{mpfr-distr-etc} \title{Distribution Functions with MPFR Arithmetic} \alias{pnorm} \alias{dnorm} \alias{dbinom} \alias{dnbinom} \alias{dgamma} \alias{dpois} \alias{dt} \alias{mpfr-distr}% <- alternative for \link \usage{% >>>> ../R/special-fun.R <<<< dpois (x, lambda, log = FALSE, useLog = ) dbinom (x, size, prob, log = FALSE, useLog = ) dnbinom(x, size, prob, mu, log = FALSE, useLog = any(x > 1e6)) dnorm (x, mean = 0, sd = 1, log = FALSE) dgamma(x, shape, rate = 1, scale = 1/rate, log = FALSE) dt (x, df, ncp, log = FALSE) 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. } \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)}. } \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. } \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.} } \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 } \keyword{distribution} Rmpfr/man/qnormI.Rd0000644000176200001440000001473214533561037013665 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) 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.Rd0000644000176200001440000004712414644764560014501 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. sFor 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: returns \code{\link{character}} vector of same length as \code{x}; when \code{digits} is \code{NULL}, with \emph{enough} digits to recreate \code{x} accurately. For details, see \code{\link{formatMpfr}}.} \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")}: ... } \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/DESCRIPTION0000644000176200001440000000463614716575412013073 0ustar liggesusersPackage: Rmpfr Title: Interface R to MPFR - Multiple Precision Floating-Point Reliable Version: 1.0-0 Date: 2024-11-15 DateNote: Previous CRAN version 0.9-5 on 2024-01-20 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", 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.1.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: 2024-11-15 14:10:23 UTC; maechler Author: Martin Maechler [aut, cre] (), 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, ) Maintainer: Martin Maechler Repository: CRAN Date/Publication: 2024-11-18 08:30:02 UTC