diff --git a/DESCRIPTION b/DESCRIPTION index 6417402..5c0a1e4 100644 --- a/DESCRIPTION +++ b/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] () Maintainer: Peter Solymos @@ -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 diff --git a/NAMESPACE b/NAMESPACE index a64cc23..d158741 100644 --- a/NAMESPACE +++ b/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", "%>=%", "%>>%", "%<=%", "%<<%", "%==%", "%!=%") + diff --git a/NEWS.md b/NEWS.md index 25585c7..0b2e97a 100644 --- a/NEWS.md +++ b/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. diff --git a/R/intrnals.R b/R/intrnals.R index 3eed15e..25359b1 100644 --- a/R/intrnals.R +++ b/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,8 +53,8 @@ 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 <- @@ -62,8 +62,8 @@ 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) +} diff --git a/R/zzz.R b/R/zzz.R new file mode 100644 index 0000000..8a2d833 --- /dev/null +++ b/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) +} diff --git a/README.md b/README.md index 0e49331..ef188fc 100644 --- a/README.md +++ b/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 diff --git a/man/opts.Rd b/man/opts.Rd new file mode 100644 index 0000000..ff7ed22 --- /dev/null +++ b/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 + +} diff --git a/tests/tests.R b/tests/tests.R index 3c5bab9..1ba3285 100644 --- a/tests/tests.R +++ b/tests/tests.R @@ -1,6 +1,7 @@ #devtools::install_github("psolymos/intrval") library(intrval) +library(fpCompare) ## run examples with \dontrun sections