Nothing
#### 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(<bigz>) --> .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(<bigq>) --> .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<exp>"; 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[+-]?<n>+ :
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))
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.