Provide mocking for S3/S4 methods and R6 classes

NAMESPACE

@@ -158,6 +158,9 @@ export(it)
 export(local_edition)
 export(local_mock)
 export(local_mocked_bindings)
+export(local_mocked_r6_class)
+export(local_mocked_s3_method)
+export(local_mocked_s4_method)
 export(local_on_cran)
 export(local_reproducible_output)
 export(local_snapshotter)

NEWS.md

@@ -1,5 +1,6 @@
 # testthat (development version)
 
+* New `local_mocked_s3_method()`, `local_mocked_s4_method()`, and `local_mocked_r6_class()` allow you to mock S3 and S4 methods and R6 classes (#1892, #1916)
 * `expect_snapshot_file(name=)` must have a unique file path. If a snapshot file attempts to be saved with a duplicate `name`, an error will be thrown. (#1592)
 * `test_dir()`, `test_file()`, `test_package()`, `test_check()`, `test_local()`, `source_file()` gain a `shuffle` argument uses `sample()` to randomly reorder the top-level expressions in each test file (#1942). This random reordering surfaces dependencies between tests and code outside of any test, as well as dependencies between tests. This helps you find and eliminate unintentional dependencies.
 * `snapshot_accept(test)` now works when the test file name contains `.` (#1669).

R/mock-oo.R

@@ -0,0 +1,131 @@
+#' Mock S3 and S4 methods
+#'
+#' These functions allow you to temporarily override S3 and S4 methods that
+#' already exist. It works by using [registerS3method()]/[setMethod()] to
+#' temporarily replace the original definition.
+#'
+#' @param generic A string giving the name of the generic.
+#' @param signature A character vector giving the signature of the method.
+#' @param definition A function providing the method definition.
+#' @param frame Calling frame which determines the scope of the mock.
+#'   Only needed when wrapping in another local helper.
+#' @export
+#' @examples
+#' x <- as.POSIXlt(Sys.time())
+#' local({
+#'   local_mocked_s3_method("length", "POSIXlt", function(x) 42)
+#'   length(x)
+#' })
+#'
+#' length(x)
+local_mocked_s3_method <- function(
+  generic,
+  signature,
+  definition,
+  frame = caller_env()
+) {
+  check_string(generic)
+  check_string(signature)
+  check_function(definition)
+
+  old <- getS3method(generic, signature, optional = TRUE)
+  if (is.null(old)) {
+    cli::cli_abort(
+      "Can't find existing S3 method {.code {generic}.{signature}()}."
+    )
+  }
+  registerS3method(generic, signature, definition, envir = frame)
+  withr::defer(registerS3method(generic, signature, old, envir = frame), frame)
+}
+
+#' @rdname local_mocked_s3_method
+#' @export
+local_mocked_s4_method <- function(
+  generic,
+  signature,
+  definition,
+  frame = caller_env()
+) {
+  check_string(generic)
+  check_character(signature)
+  check_function(definition)
+
+  old <- getMethod(generic, signature, optional = TRUE)
+  if (is.null(old)) {
+    name <- paste0(generic, "(", paste0(signature, collapse = ","), ")")
+    cli::cli_abort(
+      "Can't find existing S4 method {.code {name}}."
+    )
+  }
+  setMethod(generic, signature, definition, where = topenv(frame))
+  withr::defer(setMethod(generic, signature, old, where = topenv(frame)), frame)
+}
+
+
+#' Mock an R6 class
+#'
+#' This function allows you to temporarily override an R6 class definition.
+#' It works by creating a subclass then using [local_mocked_bindings()] to
+#' temporarily replace the original definition. This means that it will not
+#' affect subclasses of the original class; please file an issue if you need
+#' this.
+#'
+#' @export
+#' @param class An R6 class definition.
+#' @param public,private A named list of public and private methods/data.
+#' @inheritParams local_mocked_s3_method
+local_mocked_r6_class <- function(
+  class,
+  public = list(),
+  private = list(),
+  frame = caller_env()
+) {
+  if (!inherits(class, "R6ClassGenerator")) {
+    stop_input_type(class, "an R6 class definition")
+  }
+  if (!is.list(public)) {
+    stop_input_type(public, "a list")
+  }
+  if (!is.list(private)) {
+    stop_input_type(private, "a list")
+  }
+
+  mocked_class <- mock_r6_class(class, public, private)
+  local_mocked_bindings("{class$classname}" := mocked_class, .env = frame)
+}
+
+mock_r6_class <- function(class, public = list(), private = list()) {
+  R6::R6Class(
+    paste0("Mocked", class$classname),
+    inherit = class,
+    private = private,
+    public = public
+  )
+}
+
+# For testing ------------------------------------------------------------------
+
+TestMockClass <- R6::R6Class(
+  "TestMockClass",
+  public = list(
+    sum = function() {
+      self$public_fun() +
+        self$public_val +
+        private$private_fun() +
+        private$private_val
+    },
+    public_fun = function() 1,
+    public_val = 20
+  ),
+  private = list(
+    private_fun = function() 300,
+    private_val = 4000
+  )
+)
+
+TestMockPerson <- methods::setClass(
+  "TestMockPerson",
+  slots = c(name = "character", age = "numeric")
+)
+methods::setGeneric("mock_age", function(x) standardGeneric("mock_age"))
+methods::setMethod("mock_age", "TestMockPerson", function(x) x@age)

R/mock2.R

@@ -23,6 +23,9 @@
 #'
 #' They are described in turn below.
 #'
+#' (To mock S3 & S4 methods and R6 classes see [local_mocked_s3_method()],
+#' [local_mocked_s4_method()], and [local_mocked_r6_class()].)
+#'
 #' ## Internal & imported functions
 #'
 #' You mock internal and imported functions the same way. For example, take

_pkgdown.yml

@@ -68,8 +68,10 @@ reference:
 
 - title: Mocking
   contents:
-  - with_mocked_bindings
-  - starts_with("mock_")
+  - local_mocked_bindings
+  - local_mocked_s3_method
+  - local_mocked_r6_class
+  - mock_output_sequence
 
 - title: Custom expectations
   contents:

tests/testthat/_snaps/mock-oo.md

@@ -0,0 +1,64 @@
+# validates its inputs
+
+    Code
+      local_mocked_s3_method(1)
+    Condition
+      Error in `local_mocked_s3_method()`:
+      ! `generic` must be a single string, not the number 1.
+    Code
+      local_mocked_s3_method("mean", 1)
+    Condition
+      Error in `local_mocked_s3_method()`:
+      ! `signature` must be a single string, not the number 1.
+    Code
+      local_mocked_s3_method("mean", "bar", 1)
+    Condition
+      Error in `local_mocked_s3_method()`:
+      ! `definition` must be a function, not the number 1.
+    Code
+      local_mocked_s3_method("mean", "bar", function() { })
+    Condition
+      Error in `local_mocked_s3_method()`:
+      ! Can't find existing S3 method `mean.bar()`.
+
+---
+
+    Code
+      local_mocked_s4_method(1)
+    Condition
+      Error in `local_mocked_s4_method()`:
+      ! `generic` must be a single string, not the number 1.
+    Code
+      local_mocked_s4_method("mean", 1)
+    Condition
+      Error in `local_mocked_s4_method()`:
+      ! `signature` must be a character vector, not the number 1.
+    Code
+      local_mocked_s4_method("mean", "bar", 1)
+    Condition
+      Error in `local_mocked_s4_method()`:
+      ! `definition` must be a function, not the number 1.
+    Code
+      local_mocked_s4_method("mean", "bar", function() { })
+    Condition
+      Error in `local_mocked_s4_method()`:
+      ! Can't find existing S4 method `mean(bar)`.
+
+---
+
+    Code
+      local_mocked_r6_class(mean)
+    Condition
+      Error in `local_mocked_r6_class()`:
+      ! `class` must be an R6 class definition, not a function.
+    Code
+      local_mocked_r6_class(TestMockClass, public = 1)
+    Condition
+      Error in `local_mocked_r6_class()`:
+      ! `public` must be a list, not the number 1.
+    Code
+      local_mocked_r6_class(TestMockClass, private = 1)
+    Condition
+      Error in `local_mocked_r6_class()`:
+      ! `private` must be a list, not the number 1.
+

tests/testthat/test-mock-oo.R

@@ -0,0 +1,75 @@
+# S3 --------------------------------------------------------------------------
+
+test_that("can mock S3 methods", {
+  x <- as.POSIXlt(Sys.time())
+
+  local({
+    local_mocked_s3_method("length", "POSIXlt", function(x) 42)
+    expect_length(x, 42)
+  })
+
+  expect_length(x, 1)
+})
+
+test_that("validates its inputs", {
+  expect_snapshot(error = TRUE, {
+    local_mocked_s3_method(1)
+    local_mocked_s3_method("mean", 1)
+    local_mocked_s3_method("mean", "bar", 1)
+    local_mocked_s3_method("mean", "bar", function() {})
+  })
+})
+
+# S4 --------------------------------------------------------------------------
+
+test_that("can mock S4 methods", {
+  jim <- TestMockPerson(name = "Jim", age = 32)
+
+  local({
+    local_mocked_s4_method("mock_age", "TestMockPerson", function(x) 42)
+    expect_equal(mock_age(jim), 42)
+  })
+
+  expect_equal(mock_age(jim), 32)
+})
+
+
+test_that("validates its inputs", {
+  expect_snapshot(error = TRUE, {
+    local_mocked_s4_method(1)
+    local_mocked_s4_method("mean", 1)
+    local_mocked_s4_method("mean", "bar", 1)
+    local_mocked_s4_method("mean", "bar", function() {})
+  })
+})
+
+# R6 --------------------------------------------------------------------------
+
+test_that("can mock R6 methods", {
+  local({
+    local_mocked_r6_class(TestMockClass, public = list(sum = function() 2))
+    obj <- TestMockClass$new()
+    expect_equal(obj$sum(), 2)
+  })
+
+  obj <- TestMockClass$new()
+  expect_equal(obj$sum(), 4321)
+})
+
+test_that("can mock all R6 components", {
+  local_mocked_r6_class(
+    TestMockClass,
+    public = list(public_fun = function() 0, public_val = 0),
+    private = list(private_fun = function() 0, private_val = 0)
+  )
+  obj <- TestMockClass$new()
+  expect_equal(obj$sum(), 0)
+})
+
+test_that("validates its inputs", {
+  expect_snapshot(error = TRUE, {
+    local_mocked_r6_class(mean)
+    local_mocked_r6_class(TestMockClass, public = 1)
+    local_mocked_r6_class(TestMockClass, private = 1)
+  })
+})