Merge pull request #18 from psolymos/fpCompare

Accurate floating point comparisons with fpCompare

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: intrval
 Type: Package
 Title: Relational Operators for Intervals
-Version: 0.1-3
+Version: 1.0-0
 Date: 2024-05-19
 Author: Peter Solymos [cre, aut] (<https://orcid.org/0000-0001-7337-1740>)
 Maintainer: Peter Solymos <psolymos@gmail.com>
@@ -11,6 +11,7 @@ Description: Evaluating if values
   intervals overlap (`c(a1, b1) %[]o[]% c(a2, b2)`).
   Operators for negation and directional relations also implemented.
 License: GPL-2
+Imports: fpCompare
 URL: https://github.com/psolymos/intrval
 BugReports: https://github.com/psolymos/intrval/issues
 LazyLoad: yes

NAMESPACE

@@ -11,6 +11,9 @@ export(
     "%()o[]%", "%()o[)%", "%()o(]%", "%()o()%",
     "%ni%", "%nin%", "%notin%",
     "%[c]%",  "%[c)%",  "%(c]%",   "%(c)%",
-    "intrval_types")
+    "intrval_types",
+    "intrval_options")
 
 importFrom("graphics", "lines", "par", "plot", "points", "text")
+# importFrom("fpCompare", "%>=%", "%>>%", "%<=%", "%<<%", "%==%", "%!=%")
+

NEWS.md

@@ -1,3 +1,13 @@
+# Version 1.0-0 -- Sep 21, 2024
+
+* Fixing floating point number comparisons (#17).
+* Added global package options via `intrval_options()`.
+* The `"use_fpCompare"` option controls the use of fpCompare for
+  numeric-to-numeric comparisons, default is `TRUE`;
+  this is potentially a breaking change, use 
+  `intrval_options(use_fpCompare = FALSE)` for the mostly undesirable
+  base R behavior.
+
 # Version 0.1-3 -- May 19, 2024
 
 * Maintainer email changed to personal.

R/intrnals.R

@@ -27,15 +27,15 @@ function(x, interval, type)
     type_b <- substr(type, 2L, 2L)
     ab <- .get_intrval(interval)
     A <- switch(type_a,
-        "[" = x >= ab$a,
-        "]" = x <= ab$a,
-        "(" = x > ab$a,
-        ")" = x < ab$a)
+        "[" = x %>=% ab$a,
+        "]" = x %<=% ab$a,
+        "(" = x %>>% ab$a,
+        ")" = x %<<% ab$a)
     B <- switch(type_b,
-        "[" = x >= ab$b,
-        "]" = x <= ab$b,
-        "(" = x > ab$b,
-        ")" = x < ab$b)
+        "[" = x %>=% ab$b,
+        "]" = x %<=% ab$b,
+        "(" = x %>>% ab$b,
+        ")" = x %<<% ab$b)
     list(A=A, B=B)
 }
 
@@ -53,17 +53,17 @@ function(x, interval, type)
 {
     ab <- .get_intrval(interval)
     switch(match.arg(type, c("[", "(")),
-        "[" = x < ab$a,
-        "(" = x <= ab$a)
+        "[" = x %<<% ab$a,
+        "(" = x %<=% ab$a)
 }
 
 .greatrthan <-
 function(x, interval, type)
 {
     ab <- .get_intrval(interval)
     switch(match.arg(type, c("]", ")")),
-        "]" = x > ab$b,
-        ")" = x >= ab$b)
+        "]" = x %>>% ab$b,
+        ")" = x %>=% ab$b)
 }
 
 ## a1 %[]% c(a2, b2) | b1 %[]% c(a2, b2)
@@ -103,14 +103,14 @@ function(interval1, interval2, type1, type2)
     type1 <- match.arg(type1, c("[]", "[)", "(]", "()"))
     type2 <- match.arg(type2, c("[]", "[)", "(]", "()"))
 
-    b1 <- ifelse(iv1$a < iv2$a, iv1$b, iv2$b)
-    a2 <- ifelse(iv1$a < iv2$a, iv2$a, iv1$a)
-    type1v <- ifelse(iv1$a < iv2$a, substr(type1, 2L, 2L), substr(type2, 2L, 2L))
-    type2v <- ifelse(iv1$a < iv2$a, substr(type2, 1L, 1L), substr(type1, 1L, 1L))
+    b1 <- ifelse(iv1$a %<<% iv2$a, iv1$b, iv2$b)
+    a2 <- ifelse(iv1$a %<<% iv2$a, iv2$a, iv1$a)
+    type1v <- ifelse(iv1$a %<<% iv2$a, substr(type1, 2L, 2L), substr(type2, 2L, 2L))
+    type2v <- ifelse(iv1$a %<<% iv2$a, substr(type2, 1L, 1L), substr(type1, 1L, 1L))
 
     ifelse(type1v == "]" & type2v == "[",
-        b1 >= a2,
-        b1 > a2)
+        b1 %>=% a2,
+        b1 %>>% a2)
 }
 
 ## cut the number line into 3 intervals: -Inf, a, b, +Inf
@@ -124,3 +124,47 @@ function(x, interval, type)
     out[i$A & !i$B] <- +1L
     out
 }
+
+## fpCompare functions
+# "%>=%" <- fpCompare::`%>=%`
+# "%>>%" <- fpCompare::`%>>%`
+# "%<=%" <- fpCompare::`%<=%`
+# "%<<%" <- fpCompare::`%<<%`
+# "%==%" <- fpCompare::`%==%`
+# "%!=%" <- fpCompare::`%!=%`
+
+# "%>=%" <- base::`>=`
+# "%>>%" <- base::`>`
+# "%<=%" <- base::`<=`
+# "%<<%" <- base::`<`
+# "%==%" <- base::`==`
+# "%!=%" <- base::`!=`
+
+.use_fpc <- function() {
+    isTRUE(getOption("intrval_options")$use_fpCompare[[1L]])
+}
+
+"%>=%" <- function(e1, e2) {
+    if (.use_fpc() && is.numeric(e1) && is.numeric(e2))
+        fpCompare::`%>=%`(e1, e2) else base::`>=`(e1, e2)
+}
+"%>>%" <- function(e1, e2) {
+    if (.use_fpc() && is.numeric(e1) && is.numeric(e2))
+        fpCompare::`%>>%`(e1, e2) else base::`>`(e1, e2)
+}
+"%<=%" <- function(e1, e2) {
+    if (.use_fpc() && is.numeric(e1) && is.numeric(e2))
+        fpCompare::`%<=%`(e1, e2) else base::`<=`(e1, e2)
+}
+"%<<%" <- function(e1, e2) {
+    if (.use_fpc() && is.numeric(e1) && is.numeric(e2))
+        fpCompare::`%<<%`(e1, e2) else base::`<`(e1, e2)
+}
+"%==%" <- function(e1, e2) {
+    if (.use_fpc() && is.numeric(e1) && is.numeric(e2))
+        fpCompare::`%==%`(e1, e2) else base::`==`(e1, e2)
+}
+"%!=%" <- function(e1, e2) {
+    if (.use_fpc() && is.numeric(e1) && is.numeric(e2))
+        fpCompare::`%!=%`(e1, e2) else base::`!=`(e1, e2)
+}

R/zzz.R

@@ -0,0 +1,33 @@
+.options_set <- FALSE
+
+.onLoad <- function(libname, pkgname) {
+    if (is.null(getOption("intrval_options"))) {
+        .options_set <<- TRUE
+        options("intrval_options" = list(
+            use_fpCompare = TRUE
+        ))
+    }
+    invisible(NULL)
+}
+
+.onUnload <- function(libpath) {
+    if (.options_set) {
+        options("intrval_options" = NULL)
+    }
+    invisible(NULL)
+}
+
+intrval_options <- function(...) {
+    opar <- getOption("intrval_options")
+    args <- list(...)
+    if (length(args)) {
+        if (length(args) == 1L && is.list(args[[1L]])) {
+            npar <- args[[1L]]
+        } else {
+            npar <- opar
+            npar[match(names(args), names(npar))] <- args
+        }
+        options("intrval_options" = npar)
+    }
+    invisible(opar)
+}

README.md

@@ -272,6 +272,34 @@ dt1 %[]o()% dt2
 # [1] 0 4 4 0 0
 ```
 
+### Floating point number comparisons
+
+The intrval package used [fpCompare](https://CRAN.R-project.org/package=fpCompare)
+to reliable numeric-to-numeric comparisons. The behavior can be turned off
+to use the less reliable base R implementation:
+
+```R
+x1 <- 0.5 - 0.3
+x2 <- 0.3 - 0.1
+
+op <- intrval_options(use_fpCompare = FALSE)
+
+## this is the base R behavior
+x1 %[]% c(0.2, 0.6)
+# [1] TRUE
+x2 %[]% c(0.2, 0.6)
+# [1] FALSE
+
+## reset defaults
+intrval_options(op)
+
+## using fpCompare
+x1 %[]% c(0.2, 0.6)
+# [1] TRUE
+x2 %[]% c(0.2, 0.6)
+# [1] TRUE
+```
+
 ### Truncated distributions
 
 ![](https://github.com/psolymos/intrval/raw/master/extras/dtrunc.png)
@@ -298,7 +326,6 @@ curve(dtrunc(x, distr="norm", lwr=-1, upr=1), add=TRUE, col=2, n=n)
 
 ### Shiny example 1: regular slider
 
-
 ![](https://github.com/psolymos/intrval/raw/master/extras/regular_slider.gif)
 
 ```R

man/opts.Rd

@@ -0,0 +1,43 @@
+\name{intrval-options}
+\alias{intrval-options}
+\alias{intrval_options}
+\title{Global options for the intrval package}
+\usage{
+intrval_options(...)
+}
+\arguments{
+\item{...}{Options to set.}
+}
+\value{
+When parameters are set by \code{intrval_options}, their former values are
+returned in an invisible named list. Such a list can be passed as an
+argument to \code{intrval_options} to restore the parameter values.
+Tags are the following:
+\itemize{
+\item \code{use_fpCompare}: use the fpCompare package for the reliable comparison of floating point numbers.
+}
+}
+\description{
+Options store and allow to set global values for the intrval functions.
+}
+\examples{
+str(intrval_options())
+
+x1 <- 0.5 - 0.3
+x2 <- 0.3 - 0.1
+
+# save old values and set the new one
+op <- intrval_options(use_fpCompare = FALSE)
+
+# this is the base R behavior
+x1 %[]% c(0.2, 0.6) # TRUE
+x2 %[]% c(0.2, 0.6) # FALSE
+
+# reset defaults
+intrval_options(op)
+
+# using fpCompare
+x1 %[]% c(0.2, 0.6) # TRUE
+x2 %[]% c(0.2, 0.6) # TRUE
+
+}

tests/tests.R

@@ -1,6 +1,7 @@
 #devtools::install_github("psolymos/intrval")
 
 library(intrval)
+library(fpCompare)
 
 ## run examples with \dontrun sections