zapsmall() gets more flexible w/ mFUN, min.d

git-svn-id: https://svn.r-project.org/R/trunk@85877 00db46b3-68df-0310-9c12-caf00c1e9a41

doc/NEWS.Rd

@@ -260,6 +260,10 @@
 
       \item The default and \code{numeric} methods of \code{all.equal()}
       get a \code{check.class} option.
+
+      \item \code{zapsmall()} gets new optional arguments, function
+      \code{mFUN} and \code{min.d}, for extra flexibility; fulfills a wish
+      in \PR{18199}.  It also becomes implicit S4 generic in \pkg{methods}.
     }
   }
 

src/library/base/R/zapsmall.R

@@ -1,7 +1,7 @@
 #  File src/library/base/R/zapsmall.R
 #  Part of the R package, https://www.R-project.org
 #
-#  Copyright (C) 1995-2018 The R Core Team
+#  Copyright (C) 1995-2024 The R Core Team
 #
 #  This program is free software; you can redistribute it and/or modify
 #  it under the terms of the GNU General Public License as published by
@@ -16,12 +16,15 @@
 #  A copy of the GNU General Public License is available at
 #  https://www.R-project.org/Licenses/
 
-zapsmall <- function(x, digits = getOption("digits"))
+
+zapsmall <- function(x, digits = getOption("digits"),
+                     mFUN = function(x, ina) max(abs(x[!ina])), min.d = 0L)
+    ## NB: keep in sync w/ implicit generic in ../../methods/R/makeBasicFunsList.R !
 {
     if (length(digits) == 0L)
         stop("invalid 'digits'")
     if (all(ina <- is.na(x)))
         return(x)
-    mx <- max(abs(x[!ina]))
-    round(x, digits = if(mx > 0) max(0L, digits - as.numeric(log10(mx))) else digits)
+    mx <- mFUN(x, ina)
+    round(x, digits = if(mx > 0) max(min.d, digits - as.numeric(log10(mx))) else digits)
 }

src/library/base/man/zapsmall.Rd

@@ -1,36 +1,61 @@
 % File src/library/base/man/zapsmall.Rd
 % Part of the R package, https://www.R-project.org
-% Copyright 1995-2018 R Core Team
+% Copyright 1995-2024 R Core Team
 % Distributed under GPL 2 or later
 
 \name{zapsmall}
 \alias{zapsmall}
 \title{Rounding of Numbers: Zapping Small Ones to Zero}
 \usage{
-zapsmall(x, digits = getOption("digits"))
+zapsmall(x, digits = getOption("digits"),
+         mFUN = function(x, ina) max(abs(x[!ina])),
+         min.d = 0L)
 }
 \description{
   \code{zapsmall} determines a \code{digits} argument \code{dr} for
   calling \code{round(x, digits = dr)} such that values close to
-  zero (compared with the maximal absolute value) are \sQuote{zapped},
-  i.e., replaced by \code{0}.
+  zero (compared with the maximal absolute value in the vector) are
+  \sQuote{zapped}, i.e., replaced by \code{0}.
 }
 \arguments{
   \item{x}{a numeric or complex vector or any \R number-like object
     which has a \code{\link{round}} method and basic arithmetic methods
     including \code{\link{log10}()}.}
   \item{digits}{integer indicating the precision to be used.}
+  \item{mFUN}{a \code{\link{function}(x, ina)} of the numeric (or complex)
+    \code{x} and  the \code{\link{logical}} \code{ina := is.na(x)}
+    returning a positive number in the order of magnitude of the maximal
+    \code{abs(x)} value.  The default is back compatible but not robust,
+    and e.g., not very useful when \code{x} has infinite entries.}
+  \item{min.d}{an integer specifying the minimal number of digits to use in
+    the resulting \code{\link{round}(x, digits=*)} call when \code{mFUN(*) > 0}.}
 }
 \references{
   Chambers, J. M. (1998)
   \emph{Programming with Data.  A Guide to the S Language}.
   Springer.
 }
 \examples{
-x2 <- pi * 100^(-1:3)
-print(x2 / 1000, digits = 4)
-zapsmall(x2 / 1000, digits = 4)
+x2 <- pi * 100^(-2:2)/10
+   print(  x2, digits = 4)
+zapsmall(  x2) # automatical digits
+zapsmall(  x2, digits = 4)
+zapsmall(c(x2, Inf)) # round()s to integer ..
+zapsmall(c(x2, Inf), min.d=-Inf) # everything  is small wrt  Inf
 
-zapsmall(exp(1i*0:4*pi/2))
+(z <- exp(1i*0:4*pi/2))
+zapsmall(z)
+
+zapShow <- function(x, ...) rbind(orig = x, zapped = zapsmall(x, ...))
+zapShow(x2)
+
+## using a *robust* mFUN
+mF_rob <- function(x, ina) boxplot.stats(x, do.conf=FALSE)$stats[5]
+## with robust mFUN(), 'Inf' is no longer distorting the picture:
+zapShow(c(x2, Inf), mFUN = mF_rob)
+zapShow(c(x2, Inf), mFUN = mF_rob, min.d = -5) # the same
+zapShow(c(x2, 999), mFUN = mF_rob) # same *rounding* as w/ Inf
+zapShow(c(x2, 999), mFUN = mF_rob, min.d =  3) # the same
+zapShow(c(x2, 999), mFUN = mF_rob, min.d =  8) # small diff
 }
 \keyword{arith}

src/library/methods/R/makeBasicFunsList.R

@@ -1,7 +1,7 @@
 #  File src/library/methods/R/makeBasicFunsList.R
 #  Part of the R package, https://www.R-project.org
 #
-#  Copyright (C) 1995-2023 The R Core Team
+#  Copyright (C) 1995-2024 The R Core Team
 #
 #  This program is free software; you can redistribute it and/or modify
 #  it under the terms of the GNU General Public License as published by
@@ -288,6 +288,17 @@ utils::globalVariables(".addBasicGeneric")
     setGenericImplicit("svd", where, FALSE)
 
 
+    ## zapsmall(): signature  only  "x"
+    setGeneric("zapsmall", function(x, digits = getOption("digits"),
+                                    mFUN = function(x, ina) max(abs(x[!ina])), min.d = 0L, ...)
+        standardGeneric("zapsmall"),
+        useAsDefault = function(x, digits = getOption("digits"),
+                                mFUN = function(x, ina) max(abs(x[!ina])), min.d = 0L, ...)
+            base::zapsmall(x, digits=digits, mFUN=mFUN, min.d=min.d), # swallow '...'
+        signature = "x", where = where)
+    setGenericImplicit("zapsmall", where, FALSE)
+
+
     ## not implicitGeneric() which is not yet available "here"
     registerImplicitGenerics(where = where)
 }