From 0b21f03bd3dc528376ee991ebfcd12e7d3ba7dec Mon Sep 17 00:00:00 2001 From: Tomasz Kalinowski Date: Mon, 4 Nov 2024 11:39:50 -0500 Subject: [PATCH] test external classes with actual packages --- R/class-spec.R | 11 +++++++ tests/testthat/_snaps/constructor.md | 8 ----- tests/testthat/_snaps/external-generic.md | 38 +++++++++++++++++++++++ tests/testthat/t0/NAMESPACE | 1 + tests/testthat/t0/R/t0.R | 3 ++ tests/testthat/t2/NAMESPACE | 2 ++ tests/testthat/t2/R/t2.R | 11 +++++++ tests/testthat/test-constructor.R | 13 -------- tests/testthat/test-external-generic.R | 33 ++++++++++++++++++++ 9 files changed, 99 insertions(+), 21 deletions(-) diff --git a/R/class-spec.R b/R/class-spec.R index acf70d20..ba8885ce 100644 --- a/R/class-spec.R +++ b/R/class-spec.R @@ -100,6 +100,17 @@ class_construct_expr <- function(.x, envir = NULL, package = NULL) { } else { # namespace the pkgname::classname() call cl <- as.call(list(quote(`::`), as.name(f@package), as.name(f@name))) + + # check the call evaluates to f. + # This will error if package is not installed or object is not exported. + f2 <- eval(cl, baseenv()) + if (!identical(f, f2)) { + msg <- sprintf( + "`%s::%s` is not identical to the class with the same @package and @name properties", + f@package, f@name + ) + stop(msg, call. = FALSE) + } return(as.call(list(cl))) } } diff --git a/tests/testthat/_snaps/constructor.md b/tests/testthat/_snaps/constructor.md index 199b5dcd..dc728506 100644 --- a/tests/testthat/_snaps/constructor.md +++ b/tests/testthat/_snaps/constructor.md @@ -79,11 +79,3 @@ new_object(foo(...), y = y) -# package exported classes are not inlined in constructor formals - - Code - args(Bar) - Output - function (foo = pkgname::Foo()) - NULL - diff --git a/tests/testthat/_snaps/external-generic.md b/tests/testthat/_snaps/external-generic.md index 0b14fcff..88f1f9bc 100644 --- a/tests/testthat/_snaps/external-generic.md +++ b/tests/testthat/_snaps/external-generic.md @@ -5,3 +5,41 @@ Output foo::bar(x) +# new_method works with both hard and soft dependencies + + Code + args(Foo) + Output + function (bar = t0::AnS7Class()) + NULL + Code + args(t2::AnS7Class2) + Output + function (bar = t0::AnS7Class()) + NULL + Code + args(t2:::AnInternalClass) + Output + function (foo = t0::AnS7Class(), bar = AnS7Class2()) + NULL + +--- + + Code + new_class("Foo", properties = list(bar = new_class("MadeUpClass", package = "t0"))) + Condition + Error: + ! 'MadeUpClass' is not an exported object from 'namespace:t0' + Code + new_class("Foo", properties = list(bar = new_class("MadeUpClass", package = "MadeUpPackage"))) + Condition + Error in `loadNamespace()`: + ! there is no package called 'MadeUpPackage' + Code + modified_class <- t0::AnS7Class + attr(modified_class, "xyz") <- "abc" + new_class("Foo", properties = list(bar = modified_class)) + Condition + Error: + ! `t0::AnS7Class` is not identical to the class with the same @package and @name properties + diff --git a/tests/testthat/t0/NAMESPACE b/tests/testthat/t0/NAMESPACE index 5647257c..6cf9dd84 100644 --- a/tests/testthat/t0/NAMESPACE +++ b/tests/testthat/t0/NAMESPACE @@ -1,4 +1,5 @@ # Generated by roxygen2: do not edit by hand +export(AnS7Class) export(an_s3_generic) export(an_s7_generic) diff --git a/tests/testthat/t0/R/t0.R b/tests/testthat/t0/R/t0.R index cf5b6843..efbaad27 100644 --- a/tests/testthat/t0/R/t0.R +++ b/tests/testthat/t0/R/t0.R @@ -3,3 +3,6 @@ an_s7_generic <- S7::new_generic("an_s7_generic", "x") #' @export an_s3_generic <- function(x) UseMethod("an_s3_generic") + +#' @export +AnS7Class <- S7::new_class("AnS7Class") diff --git a/tests/testthat/t2/NAMESPACE b/tests/testthat/t2/NAMESPACE index b5d51e48..1f52c1ab 100644 --- a/tests/testthat/t2/NAMESPACE +++ b/tests/testthat/t2/NAMESPACE @@ -1,5 +1,7 @@ # Generated by roxygen2: do not edit by hand +export(AnS7Class2) export(an_s7_class) +importFrom(t0,AnS7Class) importFrom(t0,an_s3_generic) importFrom(t0,an_s7_generic) diff --git a/tests/testthat/t2/R/t2.R b/tests/testthat/t2/R/t2.R index a98bd7b7..0a98fe61 100644 --- a/tests/testthat/t2/R/t2.R +++ b/tests/testthat/t2/R/t2.R @@ -10,6 +10,16 @@ S7::method(an_s7_generic, an_s7_class) <- function(x) "foo" S7::method(an_s3_generic, an_s7_class) <- function(x) "foo" +#' @importFrom t0 AnS7Class +#' @export +AnS7Class2 <- S7::new_class("AnS7Class2", properties = list(bar = AnS7Class)) + +AnInternalClass <- S7::new_class("AnInternalClass", properties = list( + foo = AnS7Class, + bar = AnS7Class2 +)) + + another_s7_generic <- S7::new_external_generic("t1", "another_s7_generic", "x") S7::method(another_s7_generic, S7::class_character) <- function(x) "foo" S7::method(another_s7_generic, an_s7_class) <- function(x) "foo" @@ -17,6 +27,7 @@ S7::method(another_s7_generic, an_s7_class) <- function(x) "foo" another_s3_generic <- S7::new_external_generic("t1", "another_s3_generic", "x") S7::method(another_s3_generic, an_s7_class) <- function(x) "foo" + .onLoad <- function(libname, pkgname) { S7::methods_register() } diff --git a/tests/testthat/test-constructor.R b/tests/testthat/test-constructor.R index 03e860fe..323f14b2 100644 --- a/tests/testthat/test-constructor.R +++ b/tests/testthat/test-constructor.R @@ -191,16 +191,3 @@ test_that("Dynamic settable properties are included in constructor", { expect_equal(foo@dynamic_settable, 1) }) - -test_that("package exported classes are not inlined in constructor formals", { - # https://github.com/RConsortium/S7/issues/477 - Foo := new_class(package = "pkgname") - Bar := new_class(properties = list(foo = Foo)) - - expect_identical( - formals(Bar)$foo, - quote(pkgname::Foo()) - ) - - expect_snapshot(args(Bar)) -}) diff --git a/tests/testthat/test-external-generic.R b/tests/testthat/test-external-generic.R index fb9ce61f..f3bb5089 100644 --- a/tests/testthat/test-external-generic.R +++ b/tests/testthat/test-external-generic.R @@ -86,6 +86,39 @@ test_that("new_method works with both hard and soft dependencies", { 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::AnS7Class)) + expect_identical(formals(Foo) , as.pairlist(alist(bar = t0::AnS7Class()))) + expect_identical(formals(t2::AnS7Class2), as.pairlist(alist(bar = t0::AnS7Class()))) + expect_identical(formals(t2:::AnInternalClass), as.pairlist(alist( + foo = t0::AnS7Class(), bar = AnS7Class2() + ))) + + expect_snapshot({ + args(Foo) + args(t2::AnS7Class2) + args(t2:::AnInternalClass) + }) + + # 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("MadeUpClass", package = "t0") + )) + new_class("Foo", properties = list( + bar = new_class("MadeUpClass", package = "MadeUpPackage") + )) + + modified_class <- t0::AnS7Class + 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)