Behavior of s3_get_method with all.equal

[tvatter]

Is the fact that the second line generates an error a bug or a feature? I'm not sure how to interpret this...

ftype(all.equal)
s3_get_method(all.equal(1, 1))

[Zedseayou]

I think you're calling it wrong; s3_get_method takes a function name as string or symbol, specifically the full method name. This is different from s3_dispatch, which may cause the confusion. Here's an example:

library(sloop)
s3_methods_generic("all.equal")
#> # A tibble: 11 x 4
#>    generic   class       visible source
#>    <chr>     <chr>       <lgl>   <chr> 
#>  1 all.equal character   TRUE    base  
#>  2 all.equal default     TRUE    base  
#>  3 all.equal environment TRUE    base  
#>  4 all.equal envRefClass TRUE    base  
#>  5 all.equal factor      TRUE    base  
#>  6 all.equal formula     TRUE    base  
#>  7 all.equal language    TRUE    base  
#>  8 all.equal list        TRUE    base  
#>  9 all.equal numeric     TRUE    base  
#> 10 all.equal POSIXt      TRUE    base  
#> 11 all.equal raw         TRUE    base
s3_get_method(all.equal.numeric)
#> function (target, current, tolerance = sqrt(.Machine$double.eps), 
#>     scale = NULL, countEQ = FALSE, formatFUN = function(err, 
#>         what) format(err), ..., check.attributes = TRUE) 
#> {
#>     if (!is.numeric(tolerance)) 
#>         stop("'tolerance' should be numeric")
#>     if (!is.numeric(scale) && !is.null(scale)) 
#>         stop("'scale' should be numeric or NULL")
#>     if (!is.logical(check.attributes)) 
#>         stop(gettextf("'%s' must be logical", "check.attributes"), 
#>             domain = NA)
#>     msg <- if (check.attributes) 
#>         attr.all.equal(target, current, tolerance = tolerance, 
#>             scale = scale, ...)
#>     if (data.class(target) != data.class(current)) {
#>         msg <- c(msg, paste0("target is ", data.class(target), 
#>             ", current is ", data.class(current)))
#>         return(msg)
#>     }
#>     lt <- length(target)
#>     lc <- length(current)
#>     cplx <- is.complex(target)
#>     if (lt != lc) {
#>         if (!is.null(msg)) 
#>             msg <- msg[-grep("\\bLengths\\b", msg)]
#>         msg <- c(msg, paste0(if (cplx) "Complex" else "Numeric", 
#>             ": lengths (", lt, ", ", lc, ") differ"))
#>         return(msg)
#>     }
#>     target <- as.vector(target)
#>     current <- as.vector(current)
#>     out <- is.na(target)
#>     if (any(out != is.na(current))) {
#>         msg <- c(msg, paste("'is.NA' value mismatch:", sum(is.na(current)), 
#>             "in current", sum(out), "in target"))
#>         return(msg)
#>     }
#>     out <- out | target == current
#>     if (all(out)) 
#>         return(if (is.null(msg)) TRUE else msg)
#>     if (countEQ) {
#>         N <- length(out)
#>         sabst0 <- sum(abs(target[out]))
#>     }
#>     else sabst0 <- 0
#>     target <- target[!out]
#>     current <- current[!out]
#>     if (!countEQ) 
#>         N <- length(target)
#>     if (is.integer(target) && is.integer(current)) 
#>         target <- as.double(target)
#>     xy <- sum(abs(target - current))/N
#>     what <- if (is.null(scale)) {
#>         xn <- (sabst0 + sum(abs(target)))/N
#>         if (is.finite(xn) && xn > tolerance) {
#>             xy <- xy/xn
#>             "relative"
#>         }
#>         else "absolute"
#>     }
#>     else {
#>         stopifnot(all(scale > 0))
#>         xy <- xy/scale
#>         if (all(abs(scale - 1) < 1e-07)) 
#>             "absolute"
#>         else "scaled"
#>     }
#>     if (cplx) 
#>         what <- paste(what, "Mod")
#>     if (is.na(xy) || xy > tolerance) 
#>         msg <- c(msg, paste("Mean", what, "difference:", formatFUN(xy, 
#>             what)))
#>     if (is.null(msg)) 
#>         TRUE
#>     else msg
#> }
#> <bytecode: 0x7fc213926558>
#> <environment: namespace:base>

^{Created on 2019-11-27 by the reprex package (v0.3.0)}