1#' Does an object inherit from a set of classes? 2#' 3#' @description 4#' 5#' * `inherits_any()` is like [base::inherits()] but is more explicit 6#' about its behaviour with multiple classes. If `classes` contains 7#' several elements and the object inherits from at least one of 8#' them, `inherits_any()` returns `TRUE`. 9#' 10#' * `inherits_all()` tests that an object inherits from all of the 11#' classes in the supplied order. This is usually the best way to 12#' test for inheritance of multiple classes. 13#' 14#' * `inherits_only()` tests that the class vectors are identical. It 15#' is a shortcut for `identical(class(x), class)`. 16#' 17#' @param x An object to test for inheritance. 18#' @param class A character vector of classes. 19#' 20#' @export 21#' @examples 22#' obj <- structure(list(), class = c("foo", "bar", "baz")) 23#' 24#' # With the _any variant only one class must match: 25#' inherits_any(obj, c("foobar", "bazbaz")) 26#' inherits_any(obj, c("foo", "bazbaz")) 27#' 28#' # With the _all variant all classes must match: 29#' inherits_all(obj, c("foo", "bazbaz")) 30#' inherits_all(obj, c("foo", "baz")) 31#' 32#' # The order of classes must match as well: 33#' inherits_all(obj, c("baz", "foo")) 34#' 35#' # inherits_only() checks that the class vectors are identical: 36#' inherits_only(obj, c("foo", "baz")) 37#' inherits_only(obj, c("foo", "bar", "baz")) 38inherits_any <- function(x, class) { 39 if (is_empty(class)) { 40 abort("`class` can't be empty") 41 } 42 inherits(x, class) 43} 44#' @rdname inherits_any 45#' @export 46inherits_all <- function(x, class) { 47 if (is_empty(class)) { 48 abort("`class` can't be empty") 49 } 50 51 idx <- inherits(x, class, which = TRUE) 52 cummax <- cummax(idx) 53 54 cummax[[1]] != 0L && all(idx == cummax) 55} 56#' @rdname inherits_any 57#' @export 58inherits_only <- function(x, class) { 59 identical(class(x), class) 60} 61 62#' Box a value 63#' 64#' `new_box()` is similar to [base::I()] but it protects a value by 65#' wrapping it in a scalar list rather than by adding an attribute. 66#' `unbox()` retrieves the boxed value. `is_box()` tests whether an 67#' object is boxed with optional class. `as_box()` ensures that a 68#' value is wrapped in a box. `as_box_if()` does the same but only if 69#' the value matches a predicate. 70#' 71#' @name box 72#' @param x,.x An R object. 73#' @param class For `new_box()`, an additional class for the 74#' boxed value (in addition to `rlang_box`). For `is_box()`, a class 75#' or vector of classes passed to [inherits_all()]. 76#' @param ... Additional attributes passed to [base::structure()]. 77#' @export 78#' @examples 79#' boxed <- new_box(letters, "mybox") 80#' is_box(boxed) 81#' is_box(boxed, "mybox") 82#' is_box(boxed, "otherbox") 83#' 84#' unbox(boxed) 85#' 86#' # as_box() avoids double-boxing: 87#' boxed2 <- as_box(boxed, "mybox") 88#' boxed2 89#' unbox(boxed2) 90#' 91#' # Compare to: 92#' boxed_boxed <- new_box(boxed, "mybox") 93#' boxed_boxed 94#' unbox(unbox(boxed_boxed)) 95#' 96#' # Use `as_box_if()` with a predicate if you need to ensure a box 97#' # only for a subset of values: 98#' as_box_if(NULL, is_null, "null_box") 99#' as_box_if("foo", is_null, "null_box") 100new_box <- function(.x, class = NULL, ...) { 101 structure( 102 list(.x), 103 class = c(class, "rlang_box"), 104 ... 105 ) 106} 107#' @rdname box 108#' @export 109is_box <- function(x, class = NULL) { 110 inherits_all(x, c(class, "rlang_box")) 111} 112#' @rdname box 113#' @param box A boxed value to unbox. 114#' @export 115unbox <- function(box) { 116 if (!inherits(box, "rlang_box")) { 117 abort("`box` must be a box") 118 } 119 box[[1]] 120} 121print.box <- function(x, ...) { 122 cat_line("<box>") 123 print(unbox(x)) 124} 125 126#' Convert object to a box 127#' 128#' @description 129#' 130#' * `as_box()` boxes its input only if it is not already a box. The 131#' class is also checked if supplied. 132#' 133#' * `as_box_if()` boxes its input only if it not already a box, or if 134#' the predicate `.p` returns `TRUE`. 135#' 136#' @inheritParams box 137#' @param class,.class A box class. If the input is already a box of 138#' that class, it is returned as is. If the input needs to be boxed, 139#' `class` is passed to [new_box()]. 140#' 141#' @export 142as_box <- function(x, class = NULL) { 143 if (is_box(x, class)) { 144 x 145 } else { 146 new_box(x, class) 147 } 148} 149#' @rdname as_box 150#' @param .p A predicate function. 151#' @param ... Arguments passed to `.p`. 152#' @export 153as_box_if <- function(.x, .p, .class = NULL, ...) { 154 .p <- as_predicate(.p) 155 if (is_box(.x, .class) || !.p(.x, ...)) { 156 .x 157 } else { 158 new_box(.x, .class) 159 } 160} 161 162#' Box a final value for early termination 163#' 164#' @description 165#' 166#' A value boxed with `done()` signals to its caller that it 167#' should stop iterating. Use it to shortcircuit a loop. 168#' 169#' @param x For `done()`, a value to box. For `is_done_box()`, a 170#' value to test. 171#' @return A [boxed][new_box] value. 172#' 173#' @examples 174#' done(3) 175#' 176#' x <- done(3) 177#' is_done_box(x) 178#' @export 179done <- function(x) { 180 new_box( 181 maybe_missing(x), 182 class = "rlang_box_done", 183 empty = missing(x) 184 ) 185} 186#' @rdname done 187#' @param empty Whether the box is empty. If `NULL`, `is_done_box()` 188#' returns `TRUE` for all done boxes. If `TRUE`, it returns `TRUE` 189#' only for empty boxes. Otherwise it returns `TRUE` only for 190#' non-empty boxes. 191#' @export 192is_done_box <- function(x, empty = NULL) { 193 if (!inherits(x, "rlang_box_done")) { 194 return(FALSE) 195 } 196 197 if (is_null(empty)) { 198 return(TRUE) 199 } 200 201 attr(x, "empty") == empty 202} 203#' @export 204print.rlang_box_done <- function(x, ...) { 205 cat_line("<done>") 206 print(unbox(x)) 207} 208 209#' Create zap objects 210#' 211#' @description 212#' 213#' `zap()` creates a sentinel object that indicates that an object 214#' should be removed. For instance, named zaps instruct [env_bind()] 215#' and [call_modify()] to remove those objects from the environment or 216#' the call. 217#' 218#' The advantage of zap objects is that they unambiguously signal the 219#' intent of removing an object. Sentinels like `NULL` or 220#' [missing_arg()] are ambiguous because they represent valid R 221#' objects. 222#' 223#' @param x An object to test. 224#' 225#' @export 226#' @examples 227#' # Create one zap object: 228#' zap() 229#' 230#' # Create a list of zaps: 231#' rep(list(zap()), 3) 232#' rep_named(c("foo", "bar"), list(zap())) 233zap <- function() { 234 `zap!` 235} 236#' @rdname zap 237#' @export 238is_zap <- function(x) { 239 inherits(x, "rlang_zap") 240} 241 242`zap!` <- structure(list(), class = "rlang_zap") 243 244#' @export 245print.rlang_zap <- function(x, ...) { 246 cat_line("<zap>") 247} 248