Commit cf620d68 authored by Martin Maechler's avatar Martin Maechler
Browse files

gmp version 0.6-0: *.big() methods for *both* "bigz" and "bigq" ->

S3method()s works correctly
parent 469ff923
2020-06-06 Martin Maechler <maechler@stat.math.ethz.ch>
* NAMESPACE: use *same* S3method(<op>, <class>, <method_fn>) for bigz and bigq,
* R/bigq.R (add.big): so now "mixed" arithmetic and comparisons work
2020-06-06 Martin Maechler <maechler@stat.math.ethz.ch>
* DESCRIPTION (Version): 0.6-0 (not yet released)
* R/biginteger.R (as.bigz): now as.bigz(<bigz>) keeps a modulus
2020-05-11 Martin Maechler <maechler@stat.math.ethz.ch>
* R/AllClasses-etc.R (.diff.big): diff.big[zq]() methods
......
Package: gmp
Version: 0.5-15
Date: 2020-05-31
Version: 0.6-0
Date: 2020-06-06
Title: Multiple Precision Arithmetic
Author: Antoine Lucas, Immanuel Scholz, Rainer Boehme <rb-gmp@reflex-studio.de>,
Sylvain Jasson <Sylvain.Jasson@inrae.fr>,
......
......@@ -56,6 +56,7 @@ export(
## "sign.bigq", "sign.bigz",
"sizeinbase",
"solve.bigq", "solve.bigz",
.sub.bigq,
"sub.bigq", "sub.bigz",
"sum.bigq", "sum.bigz",
## "t.bigq", "t.bigz",
......@@ -73,19 +74,26 @@ S3method(gcd,default)
#S3method(lcm,default)
S3method(is.whole,default)
S3method("+",bigz)
S3method("-",bigz)
S3method("*",bigz)
S3method("/",bigz)
S3method("%%",bigz)
### S3methods : NB use the *same* method for the 'Arith' and 'Compare' group
# --------- -- only then, group method dispatch will work for <bigz> op <bigq>
## Arith --
S3method("+",bigz, add.big)
S3method("-",bigz, sub.big)
S3method("*",bigz, mul.big)
S3method("/",bigz, div.big)
S3method("^",bigz, pow.big)
## bigz only:
S3method("%%", bigz)
S3method("%/%",bigz)
S3method("^",bigz)
S3method("<",bigz)
S3method("<=",bigz)
S3method("==",bigz)
S3method(">=",bigz)
S3method(">",bigz)
S3method("!=",bigz)
## Compare
S3method("<", bigz, lt.big)
S3method("<=",bigz, lte.big)
S3method("==",bigz, eq.big)
S3method(">=",bigz, gte.big)
S3method(">", bigz, gt.big)
S3method("!=",bigz, neq.big)
##
S3method("[<-",bigz)
S3method("[",bigz)
S3method("[[<-",bigz)
......@@ -123,21 +131,24 @@ S3method(all.equal,bigz)
S3method(modulus, bigz)
S3method("modulus<-", bigz)
S3method("+",bigq)
S3method("-",bigq)
S3method("*",bigq)
S3method("/",bigq)
S3method("^",bigq)
S3method("<",bigq)
S3method("<=",bigq)
S3method("==",bigq)
S3method(">=",bigq)
S3method(">",bigq)
S3method("!=",bigq)
S3method("[<-",bigq)
S3method("[",bigq)
## Arith :
S3method("+",bigq, add.big)
S3method("-",bigq, sub.big)
S3method("*",bigq, mul.big)
S3method("/",bigq, div.big)
S3method("^",bigq, pow.big)
## Compare :
S3method("<", bigq, lt.big)
S3method("<=",bigq, lte.big)
S3method("==",bigq, eq.big)
S3method(">=",bigq, gte.big)
S3method(">", bigq, gt.big)
S3method("!=",bigq, neq.big)
##
S3method("[<-", bigq)
S3method("[", bigq)
S3method("[[<-",bigq)
S3method("[[",bigq)
S3method("[[", bigq)
##S3method(add,bigq)
S3method(c,bigq)
S3method(cbind,bigq)
......
......@@ -18,22 +18,23 @@ setGeneric("asNumeric", useAsDefault = function(x) {
#
#----------------------------------------------------------
"+.bigz" <- add.bigz <- function(e1, e2) {
add.bigz <- function(e1, e2) {
if(inherits(e2, "bigq"))
.Call(bigrational_add, e1, e2)
else .Call(biginteger_add, e1, e2)
}
"-.bigz" <- sub.bigz <- function(e1, e2=NULL)
sub.bigz <- function(e1, e2=NULL)
{
if(is.null(e2))
.Call(biginteger_sub, 0, e1)
else if(inherits(e2, "bigq"))
.Call(bigrational_sub, e1, e2)
else .Call(biginteger_sub, e1, e2)
.Call(biginteger_sub, 0, e1)
## else if(inherits(e2, "bigq"))
## .Call(bigrational_sub, e1, e2)
else
.Call(biginteger_sub, e1, e2)
}
"*.bigz" <- mul.bigz <- function(e1, e2) {
mul.bigz <- function(e1, e2) {
if(inherits(e2, "bigq"))
.Call(bigrational_mul, e1, e2)
else .Call(biginteger_mul, e1, e2)
......@@ -42,7 +43,7 @@ setGeneric("asNumeric", useAsDefault = function(x) {
## divq : integer division
"%/%.bigz" <- divq.bigz <- function(e1, e2) {
if(inherits(e2, "bigq")) {
if(is.whole(e2))
if(!all(is.whole(e2[is.finite(e2)])))
e2 <- as.bigz(e2)
else
stop("In 'n %/% d', d must be integer")
......@@ -51,7 +52,7 @@ setGeneric("asNumeric", useAsDefault = function(x) {
}
## div : division of integers -> either rational or (mod) integer division
"/.bigz" <- div.bigz <- function(e1, e2) {
div.bigz <- function(e1, e2) {
if(inherits(e2, "bigq"))
.Call(bigrational_div, e1, e2)
else .Call(biginteger_div, e1, e2)
......@@ -59,7 +60,7 @@ setGeneric("asNumeric", useAsDefault = function(x) {
"%%.bigz" <- mod.bigz <- function(e1, e2) {
if(inherits(e2, "bigq")) {
if(is.whole(e2))
if(!all(is.whole(e2[is.finite(e2)])))
e2 <- as.bigz(e2)
else
stop("In 'n %% d', d must be integer")
......@@ -67,7 +68,7 @@ setGeneric("asNumeric", useAsDefault = function(x) {
.Call(biginteger_mod, e1, e2)
}
"^.bigz" <- pow.bigz <- function(e1, e2,...) {
pow.bigz <- function(e1, e2,...) {
if(inherits(e2, "bigq"))
pow.bigq(e1, e2)
else .Call(biginteger_pow, e1, e2)
......@@ -108,12 +109,15 @@ print.bigz <- function(x, quote = FALSE, initLine = is.null(modulus(x)), ...)
as.bigz <- function(a, mod = NA)
{
if(isZ <- missing(mod) && inherits(a, "bigz"))
mod <- modulus(a) # possibly NULL
if(is.null(mod)) mod <- NA
if(inherits(a, "bigq"))
if(!isZ && inherits(a, "bigq"))
as.bigz.bigq(a, mod)
else
.Call(biginteger_as, a, mod)
}
## the .as*() functions are exported for Rmpfr
.as.bigz <- function(a, mod = NA) {
if(inherits(a, "bigq")) as.bigz.bigq(a, mod) else .Call(biginteger_as, a, mod)
......@@ -172,12 +176,52 @@ modulus.bigz <- function(a) attr(a, "mod")
powm <- function(x,y, n) .Call(biginteger_powm, x,y,n)
"<.bigz" <- function(e1, e2) .Call(biginteger_lt, e1, e2)
">.bigz" <- function(e1, e2) .Call(biginteger_gt, e1, e2)
"<=.bigz" <- function(e1, e2) .Call(biginteger_lte, e1, e2)
">=.bigz" <- function(e1, e2) .Call(biginteger_gte, e1, e2)
"==.bigz" <- function(e1, e2) .Call(biginteger_eq, e1, e2)
"!=.bigz" <- function(e1, e2) .Call(biginteger_neq, e1, e2)
## <op>.bigz(): *not* used
lt.bigz <- function(e1, e2) .Call(biginteger_lt, e1, e2)
gt.bigz <- function(e1, e2) .Call(biginteger_gt, e1, e2)
lte.bigz <- function(e1, e2) .Call(biginteger_lte, e1, e2)
gte.bigz <- function(e1, e2) .Call(biginteger_gte, e1, e2)
eq.bigz <- function(e1, e2) .Call(biginteger_eq, e1, e2)
neq.bigz <- function(e1, e2) .Call(biginteger_neq, e1, e2)
lt.big <- function(e1, e2) {
if(!is.bigq(e1) && !is.bigq(e2)) # try integer
.Call(biginteger_lt, e1, e2)
else
.Call(bigrational_lt, e1, e2)
}
gt.big <- function(e1, e2) {
if(!is.bigq(e1) && !is.bigq(e2)) # try integer
.Call(biginteger_gt, e1, e2)
else
.Call(bigrational_gt, e1, e2)
}
lte.big <- function(e1, e2) {
if(!is.bigq(e1) && !is.bigq(e2)) # try integer
.Call(biginteger_lte, e1, e2)
else
.Call(bigrational_lte, e1, e2)
}
gte.big <- function(e1, e2) {
if(!is.bigq(e1) && !is.bigq(e2)) # try integer
.Call(biginteger_gte, e1, e2)
else
.Call(bigrational_gte, e1, e2)
}
eq.big <- function(e1, e2) {
if(!is.bigq(e1) && !is.bigq(e2)) # try integer
.Call(biginteger_eq, e1, e2)
else
.Call(bigrational_eq, e1, e2)
}
neq.big <- function(e1, e2) {
if(!is.bigq(e1) && !is.bigq(e2)) # try integer
.Call(biginteger_neq, e1, e2)
else
.Call(bigrational_neq, e1, e2)
}
is.whole <- function(x) UseMethod("is.whole")
is.whole.default <- function(x) {
......@@ -214,19 +258,28 @@ lg2.invFrexp <- function(L) {
###------------------------- 'Math' S3 group ------------------------------
## Most 'Math' group would be hard to implement --- [TODO via Rmpfr -- or stop("...via Rmpfr")?
## Fall-back: *not* implemented {or use as.double() ??}
Math.bigz <- function(x, ...) { .NotYetImplemented() }
## o 'abs', 'sign', 'sqrt',
## 'floor', 'ceiling', 'trunc',
## 'round', 'signif'
## o 'exp', 'log', 'expm1', 'log1p',
## 'cos', 'sin', 'tan',
## 'acos', 'asin', 'atan'
## 'cosh', 'sinh', 'tanh',
## 'acosh', 'asinh', 'atanh'
## o 'lgamma', 'gamma', 'digamma', 'trigamma'
## o 'cumsum', 'cumprod', 'cummax', 'cummin'
## o 'abs', 'sign', 'sqrt',
## 'floor', 'ceiling', 'trunc',
## 'round', 'signif'
## o 'exp', 'log', 'expm1', 'log1p',
## 'cos', 'sin', 'tan',
## 'acos', 'asin', 'atan'
## 'cosh', 'sinh', 'tanh',
## 'acosh', 'asinh', 'atanh'
## o 'lgamma', 'gamma', 'digamma', 'trigamma'
## o 'cumsum', 'cumprod', 'cummax', 'cummin'
## Most 'Math' group functions should go via CRAN package 'Rmpfr' :
Math.bigz <- function(x, ...) {
if(requireNamespace("Rmpfr", quietly=TRUE)) {
NextMethod(Rmpfr::.bigz2mpfr(x)) # FIXME use ..bigz2mpfr (two '.') in future
}
else
stop("Math group method ", dQuote(.Generic),
"is available via CRAN R package 'Rmpfr'.\n",
"Install it and try again")
}
abs.bigz <- function(x) .Call(biginteger_abs,x)
sign.bigz <- function(x) .Call(biginteger_sgn,x)
......
......@@ -9,25 +9,64 @@
#
#----------------------------------------------------------
add.bigq <- function(e1, e2) .Call(bigrational_add, e1, e2)
add.big <- function(e1, e2) {
if(!is.bigq(e1) && !is.bigq(e2)) # try integer
.Call(biginteger_add, e1, e2)
else
.Call(bigrational_add, e1, e2)
}
add.bigq <- `+.bigq` <- function(e1, e2) .Call(bigrational_add, e1, e2)
sub.bigq<- `-.bigq` <- function(e1, e2=NULL) {
if(is.null(e2))
.Call(bigrational_sub,0,e1)
else
.Call(bigrational_sub,e1,e2)
## the 'e2=NULL' has been documented forever
sub.bigq <- function(e1, e2=NULL) {
if(is.null(e2))
.Call(bigrational_sub, 0,e1)
else
.Call(bigrational_sub,e1,e2)
}
## simple version:
.sub.bigq <- function(e1, e2) .Call(bigrational_sub,e1,e2)
mul.bigq <- `*.bigq` <- function(e1, e2) .Call(bigrational_mul, e1, e2)
sub.big <- function(e1, e2=NULL) {
if(!is.bigq(e1) && !is.bigq(e2)) # try integer
sub.bigz(e1, e2)
else if(is.null(e2))
.Call(bigrational_sub, 0,e1)
else
.Call(bigrational_sub,e1,e2)
}
"/.bigq" <- div.bigq <- function(e1, e2) .Call(bigrational_div, e1, e2)
mul.bigq <- function(e1, e2) .Call(bigrational_mul, e1, e2)
mul.big <- function(e1, e2) {
if(!is.bigq(e1) && !is.bigq(e2)) # try integer
.Call(biginteger_mul, e1, e2)
else
.Call(bigrational_mul, e1, e2)
}
"^.bigq" <- pow.bigq <- function(e1, e2) {
if(!is.whole(e2))
div.bigq <- function(e1, e2) .Call(bigrational_div, e1, e2)
div.big <- function(e1, e2) {
if(!is.bigq(e1) && !is.bigq(e2)) # try integer
.Call(biginteger_div, e1, e2)
else
.Call(bigrational_div, e1, e2)
}
pow.bigq <- function(e1, e2) {
if(!all(is.whole(e2[is.finite(e2)])))
stop("<bigq> ^ <non-int> is not rational; consider require(Rmpfr); mpfr(*) ^ *")
.Call(bigrational_pow, e1, as.bigz(e2))
}
pow.big <- function(e1, e2) {
if(!all(is.whole(e2[is.finite(e2)])))
stop("<bigq> ^ <non-int> is not rational; consider require(Rmpfr); mpfr(*) ^ *")
if(!is.bigq(e1))
.Call(biginteger_pow, e1, as.bigz(e2))
else
.Call(bigrational_pow, e1, as.bigz(e2))
}
print.bigq <- function(x, quote = FALSE, initLine = TRUE, ...)
{
......@@ -115,12 +154,13 @@ length.bigq<- function(x) .Call(bigrational_length, x)
`length<-.bigq` <- function(x, value) .Call(bigrational_setlength, x, value)
"<.bigq" <- function(e1,e2) .Call(bigrational_lt, e1, e2)
">.bigq" <- function(e1,e2) .Call(bigrational_gt, e1, e2)
"<=.bigq" <- function(e1,e2) .Call(bigrational_lte, e1, e2)
">=.bigq" <- function(e1,e2) .Call(bigrational_gte, e1, e2)
"==.bigq" <- function(e1,e2) .Call(bigrational_eq, e1, e2)
"!=.bigq" <- function(e1,e2) .Call(bigrational_neq, e1, e2)
## <op>.bigq(): *not* used
lt.bigq <- function(e1, e2) .Call(bigrational_lt, e1, e2)
gt.bigq <- function(e1, e2) .Call(bigrational_gt, e1, e2)
lte.bigq <- function(e1, e2) .Call(bigrational_lte, e1, e2)
gte.bigq <- function(e1, e2) .Call(bigrational_gte, e1, e2)
eq.bigq <- function(e1, e2) .Call(bigrational_eq, e1, e2)
neq.bigq <- function(e1, e2) .Call(bigrational_neq, e1, e2)
is.na.bigq <- function(x) .Call(bigrational_is_na, x)
is.whole.bigq <- function(x) .Call(bigrational_is_int, x)
......@@ -141,9 +181,17 @@ setMethod("Ops", signature(e1 = "bigz", e2 = "bigq"),
###------------------------- 'Math' S3 group ------------------------------
## Most 'Math' group would be hard to implement --- [TODO via Rmpfr -- or stop("...via Rmpfr")?
## Fall-back: *not* implemented {or use as.double() ??}
Math.bigq <- function(x, ...) { .NotYetImplemented() }
## Most 'Math' group functions should go via CRAN package 'Rmpfr' :
Math.bigq <- function(x, ...) {
if(requireNamespace("Rmpfr", quietly=TRUE)) {
NextMethod(Rmpfr::.bigq2mpfr(x), ...) # FIXME use ..bigq2mpfr (two '.') in future
}
else
stop("Math group method ", dQuote(.Generic),
"is available via CRAN R package 'Rmpfr'.\n",
"Install it and try again")
}
abs.bigq <- function(x) {
......
......@@ -37,6 +37,19 @@ stopifnot(isEQ(x, as.integer(x)), isEQ(x, xI), isEQ(x, xQ),
isEQ(x, as.numeric(xQ)),
TRUE)
## Finally (2020-06-06): mixed arithmetic works :
stopifnot(exprs = {
isEQ(xI - xQ, c(NA, rep(0, 9)))
isEQ(xI + xQ, 2*xI)
isEQ(xI * xQ, x^2)
all.equal(xQ^xI, x^x)
## as do mixed comparisons
(xI == xQ)[-1]
!(xI < xQ)[-1]
!(xI > xQ)[-1]
(xI >= xQ)[-1]
})
## double precision factorial() is exact up to n=22
stopifnot(factorialZ(0:22) == factorial(0:22))
......@@ -232,7 +245,7 @@ eqQ <- lapply(sapply(ops$Compare, get),
function(op) opEQ(op, x, xQ, eq=FALSE))
lapply(eqQ, symnum)## <- symnum, for nice output
Fn <- gmp:::`^.bigq`; q <- 2.3
Fn <- gmp:::pow.bigq; q <- 2.3
stopifnot(inherits(e1 <- tryCatch(Fn(q,q), error=identity), "error"),
inherits(e2 <- tryCatch(q ^ as.bigq(1,3), error=identity), "error"),
grepl("Rmpfr", e1$message),
......
......@@ -72,6 +72,7 @@ mx <- as.matrix(x) ## used to "bomb" badly:
## (terminate called after throwing an instance of 'std::bad_alloc')
lx <- as.list(x)
stopifnot(5*x == (5*i) %% 3,
identical(as.bigz(x), x), # was not the case in gmp 0.5-14
identical(mx, as.array(x)),
is(mx, "bigz"), dim(mx) == c(9,1),
is.list(lx),
......
......@@ -51,7 +51,7 @@ allfunctionid <- c("as.bigz","add.bigz","sub.bigz","mul.bigz",
"divq.bigz","div.bigz","mod.bigz","pow.bigz",
"inv.bigz", "gcd.bigz", "gcdex", "lcm.bigz",
"as.bigq",
"add.bigq","sub.bigq","div.bigq", "mul.bigq", "^.bigq",
"add.bigq","sub.bigq","div.bigq", "mul.bigq", "pow.bigq",
"chooseZ",
"max.bigq","max.bigz","min.bigq","min.bigz")
unaryfunctionid <- c("log.bigz","log2.bigz","log10.bigz","c.bigz",
......@@ -176,4 +176,4 @@ stopifnot(identical(D.D, tcrossprod(D,Dm)),
factorize("33162879029270137")
factorize(15959989)
\ No newline at end of file
factorize(15959989)
This diff is collapsed.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment