1#' Does code return an object inheriting from the expected base type, S3 class,
2#' or S4 class?
3#'
4#' @description
5#' See <https://adv-r.hadley.nz/oo.html> for an overview of R's OO systems, and
6#' the vocabulary used here.
7#'
8#' * `expect_type(x, type)` checks that `typeof(x)` is `type`.
9#' * `expect_s3_class(x, class)` checks that `x` is an S3 object that
10#'   [inherits()] from `class`
11#' * `expect_s3_class(x, NA)` checks that `x` isn't an S3 object.
12#' * `expect_s4_class(x, class)` checks that `x` is an S4 object that
13#'   [is()] `class`.
14#' * `expect_s4_class(x, NA)` checks that `x` isn't an S4 object.
15#'
16#' See [expect_vector()] for testing properties of objects created by vctrs.
17#'
18#' @param type String giving base type (as returned by [typeof()]).
19#' @param class Either a character vector of class names, or
20#'  for `expect_s3_class()` and `expect_s4_class()`, an `NA` to assert
21#'  that `object` isn't an S3 or S4 object.
22#' @inheritParams expect_that
23#' @family expectations
24#' @examples
25#' x <- data.frame(x = 1:10, y = "x", stringsAsFactors = TRUE)
26#' # A data frame is an S3 object with class data.frame
27#' expect_s3_class(x, "data.frame")
28#' show_failure(expect_s4_class(x, "data.frame"))
29#' # A data frame is built from a list:
30#' expect_type(x, "list")
31#'
32#' # An integer vector is an atomic vector of type "integer"
33#' expect_type(x$x, "integer")
34#' # It is not an S3 object
35#' show_failure(expect_s3_class(x$x, "integer"))
36#'
37#' # Above, we requested data.frame() converts strings to factors:
38#' show_failure(expect_type(x$y, "character"))
39#' expect_s3_class(x$y, "factor")
40#' expect_type(x$y, "integer")
41#' @name inheritance-expectations
42NULL
43
44#' @export
45#' @rdname inheritance-expectations
46expect_type <- function(object, type) {
47  stopifnot(is.character(type), length(type) == 1)
48
49  act <- quasi_label(enquo(object), arg = "object")
50  act_type <- typeof(act$val)
51
52  expect(
53    identical(act_type, type),
54    sprintf("%s has type %s, not %s.", act$lab, format_class(act_type), format_class(type))
55  )
56  invisible(act$val)
57}
58
59#' @export
60#' @rdname inheritance-expectations
61#' @param exact If `FALSE`, the default, checks that `object` inherits
62#'   from `class`. If `TRUE`, checks that object has a class that's identical
63#'   to `class`.
64expect_s3_class <- function(object, class, exact = FALSE) {
65  act <- quasi_label(enquo(object), arg = "object")
66  act$class <- format_class(class(act$val))
67  exp_lab <- format_class(class)
68
69  if (identical(class, NA)) {
70    expect(
71      isS3(object) == !is.na(class),
72      sprintf("%s is an S3 object", act$lab)
73    )
74  } else if (is.character(class)) {
75    if (!isS3(act$val)) {
76      fail(sprintf("%s is not an S3 object", act$lab))
77    } else if (exact) {
78      expect(
79        identical(class(act$val), class),
80        sprintf("%s has class %s, not %s.", act$lab, act$class, exp_lab)
81      )
82    } else {
83      expect(
84        inherits(act$val, class),
85        sprintf("%s inherits from %s not %s.", act$lab, act$class, exp_lab)
86      )
87    }
88  } else {
89    abort("`class` must be a NA or a character vector")
90  }
91
92  invisible(act$val)
93}
94
95#' @export
96#' @rdname inheritance-expectations
97expect_s4_class <- function(object, class) {
98  act <- quasi_label(enquo(object), arg = "object")
99  act_val_lab <- format_class(methods::is(object))
100  exp_lab <- format_class(class)
101
102  if (identical(class, NA)) {
103    expect(
104      isS4(object) == !is.na(class),
105      sprintf("%s is an S4 object", act$lab)
106    )
107  } else if (is.character(class)) {
108    if (!isS4(act$val)) {
109      fail(sprintf("%s is not an S4 object", act$lab))
110    } else {
111      expect(
112        methods::is(act$val, class),
113        sprintf("%s inherits from %s not %s.", act$lab, act_val_lab, exp_lab)
114      )
115    }
116  } else {
117    abort("`class` must be a NA or a character vector")
118  }
119
120  invisible(act$val)
121}
122
123isS3 <- function(x) is.object(x) && !isS4(x)
124
125#' Does an object inherit from a given class?
126#'
127#' @description
128#' `r lifecycle::badge("superseded")`
129#'
130#' `expect_is()` is an older form that uses [inherits()] without checking
131#' whether `x` is S3, S4, or neither. Instead, I'd recommend using
132#' [expect_type()], [expect_s3_class()] or [expect_s4_class()] to more clearly
133#' convey your  intent.
134#'
135#' @section 3rd edition:
136#' `r lifecycle::badge("deprecated")`
137#'
138#' `expect_is()` is formally deprecated in the 3rd edition.
139#'
140#' @keywords internal
141#' @inheritParams expect_type
142#' @export
143expect_is <- function(object, class, info = NULL, label = NULL) {
144  stopifnot(is.character(class))
145  edition_deprecate(3, "expect_is()",
146    "Use `expect_type()`, `expect_s3_class()`, or `expect_s4_class()` instead"
147  )
148
149
150  act <- quasi_label(enquo(object), label, arg = "object")
151  act$class <- format_class(class(act$val))
152  exp_lab <- format_class(class(class))
153
154  expect(
155    inherits(act$val, class),
156    sprintf("%s inherits from `%s` not `%s`.", act$lab, act$class, exp_lab),
157    info = info
158  )
159  invisible(act$val)
160}
161
162
163format_class <- function(x) {
164  paste0(encodeString(x, quote = "'"), collapse = "/")
165}
166