Stubbing destroys package methods

[zappingseb]

@jimhester I experienced issues with S3 methods and stubbing.

So in detail, mocking a function in a package, destroys all S3 method assignments. It does not crash the generic, but the single assignment. I guess this is an S3 feature, not bug. As in your code you run

# stub.R :87
locked <- exists(where_name, parent_env, inherits = FALSE) && bindingIsLocked(where_name, parent_env)
if (locked) {
  baseenv()$unlockBinding(where_name, parent_env)
}
assign(where_name, func, parent_env)
if (locked) {
  lockBinding(where_name, parent_env)
}

which due to Stackoverflow unassignes s3 assignments.

To give you a test, I prepared this reprex:

library(withr)
library(methods)
library(mockery)
#> Warning: package 'mockery' was built under R version 4.2.3
library(testthat)
#> Warning: package 'testthat' was built under R version 4.2.3

package_env <- new.env()

withr::with_environment(
    package_env,
    {
        methods::setGeneric(
            name = "count_it",
            def = function(obj, questions) {
                standardGeneric("count_it")
            }
        )

        methods::setMethod(
            f = "count_it",
            signature = list(obj = "data.frame"),
            definition = function(obj) {
                nrow(obj)
            }
        )

        function1 <- function(x) {
            function2(x)
        }
        function2 <- function(x) {
            names(x)
        }

        function_to_stub <- function() {
            y <- data.frame(
                a = c("a", "b"),
                b = c("c", "d")
            )
            function2(y)
        }

        function_not_to_stub <- function() {
            y <- data.frame(
                a = c("a", "b"),
                b = c("c", "d")
            )
            count_it(y)
        }
    }
)

test_that("Count works", {
    y <- data.frame(
        a = c("a", "b"),
        b = c("c", "d")
    )
    expect_equal(count_it(y), 2)
})
#> Test passed
test_that("Stub works", {
    mockery::stub(function_to_stub, "function2", 5, 2)

    expect_equal(function_to_stub(), 5)
})
#> Test passed

test_that("Stub should not influence other functions", {
    expect_equal(function_not_to_stub(), 2)
})
#> -- Error: Stub should not influence other functions ----------------------------
#> Error in `(function (classes, fdef, mtable) 
#> {
#>     methods <- .findInheritedMethods(classes, fdef, mtable)
#>     if (length(methods) == 1L) 
#>         return(methods[[1L]])
#>     else if (length(methods) == 0L) {
#>         cnames <- paste0("\"", vapply(classes, as.character, 
#>             ""), "\"", collapse = ", ")
#>         stop(gettextf("unable to find an inherited method for function %s for signature %s", 
#>             sQuote(fdef@generic), sQuote(cnames)), domain = NA)
#>     }
#>     else stop("Internal error in finding inherited methods; didn't return a unique method", 
#>         domain = NA)
#> })(list("data.frame"), new("nonstandardGenericFunction", .Data = function (obj, 
#>     questions) 
#> {
#>     standardGeneric("count_it")
#> }, generic = structure("count_it", package = ".GlobalEnv"), package = ".GlobalEnv", 
#>     group = list(), valueClass = character(0), signature = c("obj", 
#>     "questions"), default = NULL, skeleton = (function (obj, 
#>         questions) 
#>     stop(gettextf("invalid call in method dispatch to '%s' (no default method)", 
#>         "count_it"), domain = NA))(obj, questions)), <environment>)`: unable to find an inherited method for function 'count_it' for signature '"data.frame"'
#> Backtrace:
#>     x
#>  1. +-testthat::expect_equal(function_not_to_stub(), 2)
#>  2. | \-testthat::quasi_label(enquo(object), label, arg = "object")
#>  3. |   \-rlang::eval_bare(expr, quo_get_env(quo))
#>  4. \-function_not_to_stub()
#>  5.   \-count_it(y)
#>  6.     \-methods (local) `<fn>`(`<list>`, `<nnstndGF>`, `<env>`)
#> Error:
#> ! Test failed

^{Created on 2024-05-14 with reprex v2.1.0}