tests/testthat/test-external-generic.R

In S7: An Object Oriented System Meant to Become a Successor to S3 and S4

test_that("can get and append methods", {
  external_methods_reset("S7")
  on.exit(external_methods_reset("S7"), add = TRUE)

  expect_equal(S7_methods_table("S7"), list())

  bar <- new_external_generic("foo", "bar", "x")
  external_methods_add("S7", bar, list(), function() {})
  expect_equal(
    S7_methods_table("S7"),
    list(
      list(
        generic = bar,
        signature = list(),
        method = function() {}
      )
    )
  )
})

test_that("displays nicely", {
  bar <- new_external_generic("foo", "bar", "x")
  on.exit(external_methods_reset("S7"), add = TRUE)

  expect_snapshot({
    print(bar)
  })
})

test_that("can convert existing generics to external", {
  foo_S7 <- new_generic("foo_S7", "x")
  env <- new.env()
  env$.packageName <- "test"
  environment(foo_S7) <- env

  expect_equal(
    as_external_generic(foo_S7),
    new_external_generic("test", "foo_S7", "x")
  )

  foo_ext <- new_external_generic("pkg", "foo", "x")
  expect_equal(as_external_generic(foo_ext), foo_ext)

  expect_equal(
    as_external_generic(as_S3_generic(sum)),
    new_external_generic("base", "sum", "__S3__")
  )

  methods::setGeneric("foo_S4", function(x) {})
  expect_equal(
    as_external_generic(foo_S4),
    new_external_generic("S7", "foo_S4", "x")
  )
})

test_that("new_method works with both hard and soft dependencies", {
  # NB: Relies on installed S7

  skip_if(getRversion() < "4.1" && Sys.info()[["sysname"]] == "Windows")
  skip_if(quick_test())


  on.exit({
    .libPaths(old_libpaths)
    try(detach("package:t2", unload = TRUE), silent = TRUE)
    try(detach("package:t1", unload = TRUE), silent = TRUE)
    try(detach("package:t0", unload = TRUE), silent = TRUE)
    unlink(tmp_lib, recursive = TRUE)
    # remove.packages(c("t1", "t0", "t2"))
  })

  tmp_lib <- tempfile()
  dir.create(tmp_lib)
  old_libpaths <- .libPaths()
  .libPaths(c(tmp_lib, old_libpaths))

  # t2 has a hard dependency on t0
  # t2 has a soft dependency on t1

  # First, ensure that t2 can install and run successfully without t1 installed
  quick_install(test_path("t0"), tmp_lib)
  quick_install(test_path("t2"), tmp_lib)

  library("t2")
  library("t0")
  expect_equal(an_s3_generic(t2::an_s7_class()), "foo")
  expect_equal(an_s7_generic("x"), "foo")

  # test that new_class() will construct a property default as a namespaced call
  # to t0::AnS7Class() (and not inline the full class object).
  # As these tests grow, consider splitting this into a separate context like:
  #   test_that("package exported classes are not inlined in constructor formals", {...})
  Foo <- new_class("Foo", properties = list(bar = t0::`An S7 Class`))
  expect_identical(formals(Foo)                , as.pairlist(alist(bar = t0::`An S7 Class`())))
  expect_identical(formals(t2::`An S7 Class 2`), as.pairlist(alist(bar = t0::`An S7 Class`())))
  expect_identical(formals(t2:::`An Internal Class`), as.pairlist(alist(
    foo = t0::`An S7 Class`(), bar = `An S7 Class 2`()
  )))

  expect_snapshot({
    args(Foo)
    args(t2::`An S7 Class 2`)
    args(t2:::`An Internal Class`)
  })

  # test we emit informative error messages if a new_class() call with an
  # external class dependency is malformed.
  # https://github.com/RConsortium/S7/issues/477
  expect_snapshot(error = TRUE, {
    new_class("Foo", properties = list(
      bar = new_class("Made Up Class", package = "t0")
    ))
    new_class("Foo", properties = list(
      bar = new_class("Made Up Class", package = "Made Up Package")
    ))

    modified_class <- t0::`An S7 Class`
    attr(modified_class, "xyz") <- "abc"
    new_class("Foo", properties = list(bar = modified_class))
  })

  # Now install the soft dependency
  quick_install(test_path("t1"), tmp_lib)

  library("t1")
  expect_equal(another_s3_generic(t2::an_s7_class()), "foo")
  expect_equal(another_s7_generic("x"), "foo")


  ## Check again in a fresh session, with everything installed
  expect_no_error(callr::r(function() {
    library(t2)

    stopifnot(exprs = {
      t0::an_s3_generic(an_s7_class()) == "foo"
      t0::an_s7_generic("x") == "foo"
    })

    if(isNamespaceLoaded("t1"))
      stop("Prematurely loaded {t1}")

    stopifnot(exprs = {
      t1::another_s3_generic(an_s7_class()) == "foo"
      t1::another_s7_generic("x") == "foo"
    })

    NULL
  }))

})