new all.equal.function() checks environment(.)

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

doc/NEWS.Rd

@@ -159,6 +159,12 @@
       pipe implementation as a syntax transformation was motivated by
       suggestions from Jim Hester and Lionel Henry. These features are
       experimental and may change prior to release.
+
+      \item \code{all.equal(f, g)} for \code{function}s now by default also
+      compares their \code{environment(.)}s, notably via new
+      \code{all.equal} method for class \code{function}.  Comparison of
+      \code{nls()} fits, e.g., may now need \code{all.equal(m1, m2,
+	check.environments=FALSE)}.
     }
   }
 

src/library/base/R/all.equal.R

@@ -22,28 +22,51 @@ all.equal.default <- function(target, current, ...)
 {
     ## Really a dispatcher given mode() of args :
     ## use data.class as unlike class it does not give "integer"
-    if(is.language(target) || is.function(target))
+    if(is.language(target))
 	return(all.equal.language(target, current, ...))
+    if(is.function(target)) {
+        .Deprecated("all.equal(*)", old="all.equal.default(<function>)")
+	return(all.equal.function(target, current, ...))
+    }
     if(is.environment(target) || is.environment(current))# both: unclass() fails on env.
 	return(all.equal.environment(target, current, ...))
     if(is.recursive(target))
 	return(all.equal.list(target, current, ...))
     msg <- switch (mode(target),
-                   integer = ,
-                   complex = ,
-                   numeric = all.equal.numeric(target, current, ...),
+                   integer   = ,
+                   complex   = ,
+                   numeric   = all.equal.numeric  (target, current, ...),
                    character = all.equal.character(target, current, ...),
-                   logical = ,
-                   raw = all.equal.raw(target, current, ...),
+                   logical   = ,
+                   raw       = all.equal.raw      (target, current, ...),
 		   ## assumes that slots are implemented as attributes :
-		   S4 = attr.all.equal(target, current, ...),
+		   S4        = attr.all.equal(target, current, ...),
                    if(data.class(target) != data.class(current)) {
                        gettextf("target is %s, current is %s",
                                 data.class(target), data.class(current))
                    } else NULL)
     if(is.null(msg)) TRUE else msg
 }
 
+all.equal.function <- function(target, current, check.environments = TRUE, ...)
+{
+    msg <- all.equal.language(target, current, ...)
+    if(check.environments) {
+        ## pre-check w/ identical(), for speed & against infinite recursion:
+        ee <- identical(environment(target),
+                        environment(current), ignore.environment=FALSE)
+        if(!ee)
+            ee <- all.equal.environment(environment(target),
+                                        environment(current), ...)
+        if(isTRUE(msg))
+            ee
+        else
+            c(msg, if(!isTRUE(ee)) ee)
+    } else
+        msg
+}
+
+
 all.equal.numeric <-
     function(target, current, tolerance = sqrt(.Machine$double.eps),
              scale = NULL, countEQ = FALSE,
@@ -257,8 +280,7 @@ all.equal.formula <- function(target, current, ...)
     ## the misquided one in package Formula
     if(length(target) != length(current))
 	return(paste0("target, current differ in having response: ",
-                      length(target) == 3L,
-                      ", ",
+                      length(target ) == 3L, ", ",
                       length(current) == 3L))
     ## <NOTE>
     ## This takes same-length formulas as all equal if they deparse
@@ -277,7 +299,7 @@ all.equal.language <- function(target, current, ...)
     mc <- mode(current)
     if(mt == "expression" && mc == "expression")
 	return(all.equal.list(target, current, ...))
-    ttxt <- paste(deparse(target), collapse = "\n")
+    ttxt <- paste(deparse(target ), collapse = "\n")
     ctxt <- paste(deparse(current), collapse = "\n")
     msg <- c(if(mt != mc)
 	     paste0("Modes of target, current: ", mt, ", ", mc),
@@ -434,7 +456,7 @@ all.equal.POSIXt <- function(target, current, ..., tolerance = 1e-3, scale,
             if(is.null(tz <- attr(dt, "tzone"))) "" else tz[1L]
         }
         ## FIXME: check_tzones() ignores differences with "" as time zone,
-        ## regardless of whether that other time zone is the current one. 
+        ## regardless of whether that other time zone is the current one.
         ## However, this code does not handle "" at all, so that it is
         ## treated as "inconsistent" even with the current time zone,
         ## leading to surprising results, e.g.

src/library/base/R/zzz.R

@@ -256,7 +256,7 @@ assign("trunc", function(x, ...) UseMethod("trunc"), envir = .GenericArgsEnv)
 assign("as.numeric", get("as.double", envir = .GenericArgsEnv),
        envir = .GenericArgsEnv)
 
-## Keep this in sync with
+## Keep this in sync with ../../tools/R/utils.R
 ##   tools:::.make_S3_methods_table_for_base()
 ## for computing the methods table and
 ##   tools:::.deparse_S3_methods_table_for_base()
@@ -338,6 +338,7 @@ matrix(c("!", "hexmode",
          "all.equal", "environment",
          "all.equal", "factor",
          "all.equal", "formula",
+         "all.equal", "function",
          "all.equal", "language",
          "all.equal", "list",
          "all.equal", "numeric",

src/library/base/man/all.equal.Rd

@@ -13,6 +13,7 @@
 \alias{all.equal.envRefClass}
 \alias{all.equal.factor}
 \alias{all.equal.formula}
+\alias{all.equal.function}
 \alias{all.equal.list}
 \alias{all.equal.language}
 \alias{all.equal.POSIXt}
@@ -35,6 +36,8 @@ all.equal(target, current, \dots)
 
 \method{all.equal}{environment}(target, current, all.names=TRUE, \dots)
 
+\method{all.equal}{function}(target, current, check.environments=TRUE, \dots)
+
 \method{all.equal}{POSIXt}(target, current, \dots, tolerance = 1e-3, scale,
           check.tzone = TRUE)
 
@@ -60,7 +63,7 @@ attr.all.equal(target, current, \dots,
   \item{formatFUN}{a \code{\link{function}} of two arguments,
     \code{err}, the relative, absolute or scaled error, and
     \code{what}, a character string indicating the \emph{kind} of error;
-    maybe used, e.g., to format relative and absolute errors differently.}
+    may be used, e.g., to format relative and absolute errors differently.}
   \item{check.attributes}{logical indicating if the
     \code{\link{attributes}} of \code{target} and \code{current}
     (other than the names) should be compared.}
@@ -70,6 +73,10 @@ attr.all.equal(target, current, \dots,
     be specified by its full name.}
   \item{all.names}{logical passed to \code{\link{ls}} indicating if
     \dQuote{hidden} objects should also be considered in the environments.}
+  \item{check.environments}{logical requiring that the
+    \code{\link{environment}()}s of functions should be compared, too.
+    You may need to set \code{check.environments=FALSE} in unexpected
+    cases, such as when comparing two \code{\link{nls}()} fits.}
   \item{check.tzone}{logical indicating if the \code{"tzone"} attributes
     of \code{target} and \code{current} should be compared.}
   \item{check.names}{logical indicating if the \code{\link{names}(.)}

src/library/base/man/dput.Rd

@@ -79,7 +79,7 @@ fil <- tempfile()
 dput(base::mean, fil)
 ## ... read it back into 'bar' and confirm it is the same
 bar <- dget(fil)
-stopifnot(all.equal(bar, base::mean))
+stopifnot(all.equal(bar, base::mean, check.environments = FALSE))
 
 ## Create a function with comments
 baz <- function(x) {

src/library/stats/tests/nls.R

@@ -245,11 +245,12 @@ t1$with.start
 ## finally worked in 2.4.0
 ##__no.start: failed in 3.0.2
 ## 2018-09 fails on macOS with Accelerate framework.
-stopifnot(all.equal(.n(t1[[1]]), .n(t1[[2]])))
+stopifnot(all.equal(.n(t1[[1]]), .n(t1[[2]]), check.environments = FALSE))
 rm(a,b)
 t2 <- test(FALSE)
 stopifnot(all.equal(lapply(t1, .n),
-		    lapply(t2, .n), tolerance = 0.16))# different random error
+		    lapply(t2, .n), tolerance = 0.16, # different random error
+                    check.environments = FALSE))
 
 
 ## list 'start'

src/library/stats/tests/nls.Rout.save

@@ -1,5 +1,5 @@
 
-R Under development (unstable) (2020-11-21 r79452) -- "Unsuffered Consequences"
+R Under development (unstable) (2020-12-04 r79554) -- "Unsuffered Consequences"
 Copyright (C) 2020 The R Foundation for Statistical Computing
 Platform: x86_64-pc-linux-gnu (64-bit)
 
@@ -632,11 +632,12 @@ Nonlinear regression model
 > ## finally worked in 2.4.0
 > ##__no.start: failed in 3.0.2
 > ## 2018-09 fails on macOS with Accelerate framework.
-> stopifnot(all.equal(.n(t1[[1]]), .n(t1[[2]])))
+> stopifnot(all.equal(.n(t1[[1]]), .n(t1[[2]]), check.environments = FALSE))
 > rm(a,b)
 > t2 <- test(FALSE)
 > stopifnot(all.equal(lapply(t1, .n),
-+ 		    lapply(t2, .n), tolerance = 0.16))# different random error
++ 		    lapply(t2, .n), tolerance = 0.16, # different random error
++                     check.environments = FALSE))
 > 
 > 
 > ## list 'start'
@@ -788,4 +789,4 @@ List of 2
 > 
 > proc.time()
    user  system elapsed 
-  1.130   0.159   1.374 
+  0.910   0.067   1.033 

tests/eval-etc-2.Rout.save

@@ -1,5 +1,5 @@
 
-R Under development (unstable) (2020-10-23 r79362) -- "Unsuffered Consequences"
+R Under development (unstable) (2020-12-04 r79554) -- "Unsuffered Consequences"
 Copyright (C) 2020 The R Foundation for Statistical Computing
 Platform: x86_64-pc-linux-gnu (64-bit)
 
@@ -337,7 +337,7 @@ check_EPD: function (obj, show = !hasReal(obj), oNam = deparse(substitute(obj)),
     noLdbl <- (.Machine$sizeof.longdouble <= 8)
     if (!identical(obj, ob2, ignore.environment = TRUE, ignore.bytecode = TRUE, 
         ignore.srcref = TRUE)) {
-        ae <- all.equal(obj, ob2, tolerance = eq.tol)
+        ae <- all.equal(obj, ob2, tolerance = eq.tol, check.environments = FALSE)
         if (is.na(match(oNam, not.identical.ldouble))) {
             ae.txt <- "all.equal(*,*, tol = ..)"
             cat("not identical(*, ignore.env=T),", if (isTRUE(ae)) 
@@ -379,7 +379,7 @@ quote({
     noLdbl <- (.Machine$sizeof.longdouble <= 8)
     if (!identical(obj, ob2, ignore.environment = TRUE, ignore.bytecode = TRUE, 
         ignore.srcref = TRUE)) {
-        ae <- all.equal(obj, ob2, tolerance = eq.tol)
+        ae <- all.equal(obj, ob2, tolerance = eq.tol, check.environments = FALSE)
         if (is.na(match(oNam, not.identical.ldouble))) {
             ae.txt <- "all.equal(*,*, tol = ..)"
             cat("not identical(*, ignore.env=T),", if (isTRUE(ae)) 
@@ -619,5 +619,5 @@ Length  Class   Mode
      0   NULL   NULL 
 > ## at the very end
 > cat('Time elapsed: ', proc.time(), "\n")
-Time elapsed:  1.537 0.11 1.659 0.002 0.004 
+Time elapsed:  0.801 0.103 1.226 0.002 0.001 
 > 

tests/eval-etc.Rout.save

@@ -1,5 +1,5 @@
 
-R Under development (unstable) (2020-10-23 r79362) -- "Unsuffered Consequences"
+R Under development (unstable) (2020-12-04 r79554) -- "Unsuffered Consequences"
 Copyright (C) 2020 The R Foundation for Statistical Computing
 Platform: x86_64-pc-linux-gnu (64-bit)
 
@@ -516,7 +516,7 @@ check_EPD: function (obj, show = !hasReal(obj), oNam = deparse(substitute(obj)),
     noLdbl <- (.Machine$sizeof.longdouble <= 8)
     if (!identical(obj, ob2, ignore.environment = TRUE, ignore.bytecode = TRUE, 
         ignore.srcref = TRUE)) {
-        ae <- all.equal(obj, ob2, tolerance = eq.tol)
+        ae <- all.equal(obj, ob2, tolerance = eq.tol, check.environments = FALSE)
         if (is.na(match(oNam, not.identical.ldouble))) {
             ae.txt <- "all.equal(*,*, tol = ..)"
             cat("not identical(*, ignore.env=T),", if (isTRUE(ae)) 
@@ -558,7 +558,7 @@ quote({
     noLdbl <- (.Machine$sizeof.longdouble <= 8)
     if (!identical(obj, ob2, ignore.environment = TRUE, ignore.bytecode = TRUE, 
         ignore.srcref = TRUE)) {
-        ae <- all.equal(obj, ob2, tolerance = eq.tol)
+        ae <- all.equal(obj, ob2, tolerance = eq.tol, check.environments = FALSE)
         if (is.na(match(oNam, not.identical.ldouble))) {
             ae.txt <- "all.equal(*,*, tol = ..)"
             cat("not identical(*, ignore.env=T),", if (isTRUE(ae)) 
@@ -989,6 +989,7 @@ Warning messages:
 8: In dput(x, control = control) : deparse may be incomplete
 9: In deparse(expr, backtick = backtick, ...) : deparse may be incomplete
 10: In deparse(expr, backtick = backtick, ...) : deparse may be incomplete
+> ##=============
 > 
 > summary(warnings())
 Summary of (a total of 10) warning messages:
@@ -1000,5 +1001,5 @@ Summary of (a total of 10) warning messages:
 > 
 > ## at the very end
 > cat('Time elapsed: ', proc.time() - .proctime00,'\n')
-Time elapsed:  0.358 0.018 0.383 0 0 
+Time elapsed:  0.205 0.032 0.449 0 0 
 > 

tests/eval-fns.R

@@ -57,7 +57,8 @@ check_EPD <- function(obj, show = !hasReal(obj), oNam = deparse(substitute(obj))
     noLdbl <- (.Machine$sizeof.longdouble <= 8) ## TRUE typically from  --disable-long-double
     if(!identical(obj, ob2, ignore.environment=TRUE,
                   ignore.bytecode=TRUE, ignore.srcref=TRUE)) {
-        ae <- all.equal(obj, ob2, tolerance = eq.tol)
+        ae <- all.equal(obj, ob2, tolerance = eq.tol, # in case of functions:
+                        check.environments=FALSE)
         if(is.na(match(oNam, not.identical.ldouble))) {
             ae.txt <- "all.equal(*,*, tol = ..)"
             ## differs for "no-ldouble": sprintf("all.equal(*,*, tol = %.3g)", eq.tol)

tests/reg-tests-1d.R

@@ -4598,6 +4598,7 @@ x <- c(1)
 xx <- `class<-`(x, "foo")
 stopifnot(identical(class(x), "numeric"))
 
+
 ## Can splice expression vectors with attributes -- PR#17869
 local({
     exprs <- structure(expression(1, 2, 3), attr = TRUE)
@@ -4633,6 +4634,16 @@ TCB <- addTaskCallback(function(...) { length(list(...)); TRUE},
 removeTaskCallback(TCB)
 
 
+## all.equal(<functions>) should check environments (Kevin Van Horn, R-devel)
+f <- function(x) function(y) x+y
+dif <- all.equal(f(5), f(0))
+stopifnot(is.function(f(5)),
+          is.character(dif), grepl("difference", dif))
+## all.equal() gave TRUE in  R <= 4.0.x
+
+
+
+
 ## keep at end
 rbind(last =  proc.time() - .pt,
       total = proc.time())