all.equal - cut three

[Paul Gilbert]

Below is a third cut at all.equal and the generic function test.equal which
is intended to return a T/F value. There was a suggestion that "is.equal" rather
than "test.equal" might be considered as a name. I have mixed feelings about
this. I associate the  "is" functions with inheritance rather than comparisons,
but the "equal" part of the name makes it clear. How do others feel about this?

The default method for all.equal now tries to recursively extract all numeric
elements and compare using tolerance. It also tries to do a relative comparison
rather than an absolute comparison, except for very small numbers. I hope
someone with more experience than I have will examine this part carefully!

Paul Gilbert
_______

test.equal <-function (obj1, obj2, ...)  UseMethod("test.equal")

 test.equal.default <-function (obj1, obj2, ...)
{ if (is.array(obj1))    test.equal.array(obj1, obj2, ...)
   else                         is.logical(all.equal(obj1, obj2, ...))
}


all.equal <- function(obj1, obj2,...) {UseMethod("all.equal")}

all.equal.default <- function(obj1, obj2, tolerance=.Machine$double.eps)
  {if(mode(obj1)      != mode(obj2) )               return("modes differ.")
   if (length(obj1) != length(obj2) )               return("lengths differ")

   if(is.null(class(obj1)) != is.null(class(obj2))) return("classes differ.")
   else if(!is.null(class(obj1))
           && any(class(obj1) != class(obj2)) )     return("classes differ.")


   if(is.null(attributes(obj1)) != is.null(attributes(obj2)))
                                                    return("attributes differ.")

   else if(!is.null(attributes(obj1))
           && any(unlist(attributes(obj1)) != unlist(attributes(obj2))))
                                                    return("attributes differ.")

   cull.numeric  <- function(obj, r=NULL) {
      if (is.null(obj) | (length(obj) == 0)) return(r)
      else if (is.numeric(obj)) return(c(r,obj))
      else if (is.list(obj))
           return( c(cull.numeric(obj[[1]], r), cull.numeric(obj[-1])) )
      else return(r)
     }

   z1 <- cull.numeric(obj1)
   if(! is.null(z1))
      {z2 <- cull.numeric(obj2)
       if (length(z1) != length(z2) )  return("length of numeric parts differ")
       M <- pmax(abs(z1), abs(z2))
       # next line results in absolute rather than relative comparison for
       # very small numbers.
       M[ M < 100 *tolerance] <- 1
       if (any(abs(z1 -z2) > tolerance * M))
                       return("numeric value differences exceed tolerance.")
      }
  # next comparison is really for non-numeric values but also compares
  # numeric values to the tolerance of the character representation in unlist.
   if (! all(unlist(obj1) == unlist(obj2)))     return("values differ.")
   T
  }





-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
r-devel mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
Send "info", "help", or "[un]subscribe"
(in the "body", not the subject !)  To: r-devel-request@stat.math.ethz.ch
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._