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