|
| 1 | +# Standalone file: do not edit by hand |
| 2 | +# Source: https://github.com/r-lib/rlang/blob/HEAD/R/standalone-obj-type.R |
| 3 | +# Generated by: usethis::use_standalone("r-lib/rlang", "obj-type") |
| 4 | +# ---------------------------------------------------------------------- |
| 5 | +# |
| 6 | +# --- |
| 7 | +# repo: r-lib/rlang |
| 8 | +# file: standalone-obj-type.R |
| 9 | +# last-updated: 2024-02-14 |
| 10 | +# license: https://unlicense.org |
| 11 | +# imports: rlang (>= 1.1.0) |
| 12 | +# --- |
| 13 | +# |
| 14 | +# ## Changelog |
| 15 | +# |
| 16 | +# 2024-02-14: |
| 17 | +# - `obj_type_friendly()` now works for S7 objects. |
| 18 | +# |
| 19 | +# 2023-05-01: |
| 20 | +# - `obj_type_friendly()` now only displays the first class of S3 objects. |
| 21 | +# |
| 22 | +# 2023-03-30: |
| 23 | +# - `stop_input_type()` now handles `I()` input literally in `arg`. |
| 24 | +# |
| 25 | +# 2022-10-04: |
| 26 | +# - `obj_type_friendly(value = TRUE)` now shows numeric scalars |
| 27 | +# literally. |
| 28 | +# - `stop_friendly_type()` now takes `show_value`, passed to |
| 29 | +# `obj_type_friendly()` as the `value` argument. |
| 30 | +# |
| 31 | +# 2022-10-03: |
| 32 | +# - Added `allow_na` and `allow_null` arguments. |
| 33 | +# - `NULL` is now backticked. |
| 34 | +# - Better friendly type for infinities and `NaN`. |
| 35 | +# |
| 36 | +# 2022-09-16: |
| 37 | +# - Unprefixed usage of rlang functions with `rlang::` to |
| 38 | +# avoid onLoad issues when called from rlang (#1482). |
| 39 | +# |
| 40 | +# 2022-08-11: |
| 41 | +# - Prefixed usage of rlang functions with `rlang::`. |
| 42 | +# |
| 43 | +# 2022-06-22: |
| 44 | +# - `friendly_type_of()` is now `obj_type_friendly()`. |
| 45 | +# - Added `obj_type_oo()`. |
| 46 | +# |
| 47 | +# 2021-12-20: |
| 48 | +# - Added support for scalar values and empty vectors. |
| 49 | +# - Added `stop_input_type()` |
| 50 | +# |
| 51 | +# 2021-06-30: |
| 52 | +# - Added support for missing arguments. |
| 53 | +# |
| 54 | +# 2021-04-19: |
| 55 | +# - Added support for matrices and arrays (#141). |
| 56 | +# - Added documentation. |
| 57 | +# - Added changelog. |
| 58 | +# |
| 59 | +# nocov start |
| 60 | + |
| 61 | +#' Return English-friendly type |
| 62 | +#' @param x Any R object. |
| 63 | +#' @param value Whether to describe the value of `x`. Special values |
| 64 | +#' like `NA` or `""` are always described. |
| 65 | +#' @param length Whether to mention the length of vectors and lists. |
| 66 | +#' @return A string describing the type. Starts with an indefinite |
| 67 | +#' article, e.g. "an integer vector". |
| 68 | +#' @noRd |
| 69 | +obj_type_friendly<-function(x,value=TRUE) { |
| 70 | +if (is_missing(x)) { |
| 71 | +return("absent") |
| 72 | + } |
| 73 | + |
| 74 | +if (is.object(x)) { |
| 75 | +if (inherits(x,"quosure")) { |
| 76 | +type<-"quosure" |
| 77 | + }else { |
| 78 | +type<- class(x)[[1L]] |
| 79 | + } |
| 80 | +return(sprintf("a <%s> object",type)) |
| 81 | + } |
| 82 | + |
| 83 | +if (!is_vector(x)) { |
| 84 | +return(.rlang_as_friendly_type(typeof(x))) |
| 85 | + } |
| 86 | + |
| 87 | +n_dim<- length(dim(x)) |
| 88 | + |
| 89 | +if (!n_dim) { |
| 90 | +if (!is_list(x)&& length(x)==1) { |
| 91 | +if (is_na(x)) { |
| 92 | +return(switch( |
| 93 | + typeof(x), |
| 94 | +logical="`NA`", |
| 95 | +integer="an integer `NA`", |
| 96 | +double= |
| 97 | +if (is.nan(x)) { |
| 98 | +"`NaN`" |
| 99 | + }else { |
| 100 | +"a numeric `NA`" |
| 101 | + }, |
| 102 | +complex="a complex `NA`", |
| 103 | +character="a character `NA`", |
| 104 | + .rlang_stop_unexpected_typeof(x) |
| 105 | + )) |
| 106 | + } |
| 107 | + |
| 108 | +show_infinites<-function(x) { |
| 109 | +if (x>0) { |
| 110 | +"`Inf`" |
| 111 | + }else { |
| 112 | +"`-Inf`" |
| 113 | + } |
| 114 | + } |
| 115 | +str_encode<-function(x,width=30,...) { |
| 116 | +if (nchar(x)>width) { |
| 117 | +x<- substr(x,1,width-3) |
| 118 | +x<- paste0(x,"...") |
| 119 | + } |
| 120 | + encodeString(x,...) |
| 121 | + } |
| 122 | + |
| 123 | +if (value) { |
| 124 | +if (is.numeric(x)&& is.infinite(x)) { |
| 125 | +return(show_infinites(x)) |
| 126 | + } |
| 127 | + |
| 128 | +if (is.numeric(x)|| is.complex(x)) { |
| 129 | +number<- as.character(round(x,2)) |
| 130 | +what<-if (is.complex(x))"the complex number"else"the number" |
| 131 | +return(paste(what,number)) |
| 132 | + } |
| 133 | + |
| 134 | +return(switch( |
| 135 | + typeof(x), |
| 136 | +logical=if (x)"`TRUE`"else"`FALSE`", |
| 137 | +character= { |
| 138 | +what<-if (nzchar(x))"the string"else"the empty string" |
| 139 | + paste(what, str_encode(x,quote="\"")) |
| 140 | + }, |
| 141 | +raw= paste("the raw value", as.character(x)), |
| 142 | + .rlang_stop_unexpected_typeof(x) |
| 143 | + )) |
| 144 | + } |
| 145 | + |
| 146 | +return(switch( |
| 147 | + typeof(x), |
| 148 | +logical="a logical value", |
| 149 | +integer="an integer", |
| 150 | +double=if (is.infinite(x)) show_infinites(x)else"a number", |
| 151 | +complex="a complex number", |
| 152 | +character=if (nzchar(x))"a string"else"\"\"", |
| 153 | +raw="a raw value", |
| 154 | + .rlang_stop_unexpected_typeof(x) |
| 155 | + )) |
| 156 | + } |
| 157 | + |
| 158 | +if (length(x)==0) { |
| 159 | +return(switch( |
| 160 | + typeof(x), |
| 161 | +logical="an empty logical vector", |
| 162 | +integer="an empty integer vector", |
| 163 | +double="an empty numeric vector", |
| 164 | +complex="an empty complex vector", |
| 165 | +character="an empty character vector", |
| 166 | +raw="an empty raw vector", |
| 167 | +list="an empty list", |
| 168 | + .rlang_stop_unexpected_typeof(x) |
| 169 | + )) |
| 170 | + } |
| 171 | + } |
| 172 | + |
| 173 | + vec_type_friendly(x) |
| 174 | +} |
| 175 | + |
| 176 | +vec_type_friendly<-function(x,length=FALSE) { |
| 177 | +if (!is_vector(x)) { |
| 178 | + abort("`x` must be a vector.") |
| 179 | + } |
| 180 | +type<- typeof(x) |
| 181 | +n_dim<- length(dim(x)) |
| 182 | + |
| 183 | +add_length<-function(type) { |
| 184 | +if (length&&!n_dim) { |
| 185 | + paste0(type, sprintf(" of length %s", length(x))) |
| 186 | + }else { |
| 187 | +type |
| 188 | + } |
| 189 | + } |
| 190 | + |
| 191 | +if (type=="list") { |
| 192 | +if (n_dim<2) { |
| 193 | +return(add_length("a list")) |
| 194 | + }elseif (is.data.frame(x)) { |
| 195 | +return("a data frame") |
| 196 | + }elseif (n_dim==2) { |
| 197 | +return("a list matrix") |
| 198 | + }else { |
| 199 | +return("a list array") |
| 200 | + } |
| 201 | + } |
| 202 | + |
| 203 | +type<-switch( |
| 204 | +type, |
| 205 | +logical="a logical %s", |
| 206 | +integer="an integer %s", |
| 207 | +numeric= , |
| 208 | +double="a double %s", |
| 209 | +complex="a complex %s", |
| 210 | +character="a character %s", |
| 211 | +raw="a raw %s", |
| 212 | +type= paste0("a",type," %s") |
| 213 | + ) |
| 214 | + |
| 215 | +if (n_dim<2) { |
| 216 | +kind<-"vector" |
| 217 | + }elseif (n_dim==2) { |
| 218 | +kind<-"matrix" |
| 219 | + }else { |
| 220 | +kind<-"array" |
| 221 | + } |
| 222 | +out<- sprintf(type,kind) |
| 223 | + |
| 224 | +if (n_dim>=2) { |
| 225 | +out |
| 226 | + }else { |
| 227 | + add_length(out) |
| 228 | + } |
| 229 | +} |
| 230 | + |
| 231 | +.rlang_as_friendly_type<-function(type) { |
| 232 | +switch( |
| 233 | +type, |
| 234 | + |
| 235 | +list="a list", |
| 236 | + |
| 237 | +NULL="`NULL`", |
| 238 | +environment="an environment", |
| 239 | +externalptr="a pointer", |
| 240 | +weakref="a weak reference", |
| 241 | +S4="an S4 object", |
| 242 | + |
| 243 | +name= , |
| 244 | +symbol="a symbol", |
| 245 | +language="a call", |
| 246 | +pairlist="a pairlist node", |
| 247 | +expression="an expression vector", |
| 248 | + |
| 249 | +char="an internal string", |
| 250 | +promise="an internal promise", |
| 251 | +...="an internal dots object", |
| 252 | +any="an internal `any` object", |
| 253 | +bytecode="an internal bytecode object", |
| 254 | + |
| 255 | +primitive= , |
| 256 | +builtin= , |
| 257 | +special="a primitive function", |
| 258 | +closure="a function", |
| 259 | + |
| 260 | +type |
| 261 | + ) |
| 262 | +} |
| 263 | + |
| 264 | +.rlang_stop_unexpected_typeof<-function(x,call= caller_env()) { |
| 265 | + abort( |
| 266 | + sprintf("Unexpected type <%s>.", typeof(x)), |
| 267 | +call=call |
| 268 | + ) |
| 269 | +} |
| 270 | + |
| 271 | +#' Return OO type |
| 272 | +#' @param x Any R object. |
| 273 | +#' @return One of `"bare"` (for non-OO objects), `"S3"`, `"S4"`, |
| 274 | +#' `"R6"`, or `"S7"`. |
| 275 | +#' @noRd |
| 276 | +obj_type_oo<-function(x) { |
| 277 | +if (!is.object(x)) { |
| 278 | +return("bare") |
| 279 | + } |
| 280 | + |
| 281 | +class<- inherits(x, c("R6","S7_object"),which=TRUE) |
| 282 | + |
| 283 | +if (class[[1]]) { |
| 284 | +"R6" |
| 285 | + }elseif (class[[2]]) { |
| 286 | +"S7" |
| 287 | + }elseif (isS4(x)) { |
| 288 | +"S4" |
| 289 | + }else { |
| 290 | +"S3" |
| 291 | + } |
| 292 | +} |
| 293 | + |
| 294 | +#' @param x The object type which does not conform to `what`. Its |
| 295 | +#' `obj_type_friendly()` is taken and mentioned in the error message. |
| 296 | +#' @param what The friendly expected type as a string. Can be a |
| 297 | +#' character vector of expected types, in which case the error |
| 298 | +#' message mentions all of them in an "or" enumeration. |
| 299 | +#' @param show_value Passed to `value` argument of `obj_type_friendly()`. |
| 300 | +#' @param ... Arguments passed to [abort()]. |
| 301 | +#' @inheritParams args_error_context |
| 302 | +#' @noRd |
| 303 | +stop_input_type<-function(x, |
| 304 | +what, |
| 305 | +..., |
| 306 | +allow_na=FALSE, |
| 307 | +allow_null=FALSE, |
| 308 | +show_value=TRUE, |
| 309 | +arg= caller_arg(x), |
| 310 | +call= caller_env()) { |
| 311 | +# From standalone-cli.R |
| 312 | +cli<- env_get_list( |
| 313 | +nms= c("format_arg","format_code"), |
| 314 | +last= topenv(), |
| 315 | +default=function(x) sprintf("`%s`",x), |
| 316 | +inherit=TRUE |
| 317 | + ) |
| 318 | + |
| 319 | +if (allow_na) { |
| 320 | +what<- c(what,cli$format_code("NA")) |
| 321 | + } |
| 322 | +if (allow_null) { |
| 323 | +what<- c(what,cli$format_code("NULL")) |
| 324 | + } |
| 325 | +if (length(what)) { |
| 326 | +what<- oxford_comma(what) |
| 327 | + } |
| 328 | +if (inherits(arg,"AsIs")) { |
| 329 | +format_arg<-identity |
| 330 | + }else { |
| 331 | +format_arg<-cli$format_arg |
| 332 | + } |
| 333 | + |
| 334 | +message<- sprintf( |
| 335 | +"%s must be %s, not %s.", |
| 336 | + format_arg(arg), |
| 337 | +what, |
| 338 | + obj_type_friendly(x,value=show_value) |
| 339 | + ) |
| 340 | + |
| 341 | + abort(message,...,call=call,arg=arg) |
| 342 | +} |
| 343 | + |
| 344 | +oxford_comma<-function(chr,sep=",",final="or") { |
| 345 | +n<- length(chr) |
| 346 | + |
| 347 | +if (n<2) { |
| 348 | +return(chr) |
| 349 | + } |
| 350 | + |
| 351 | +head<-chr[seq_len(n-1)] |
| 352 | +last<-chr[n] |
| 353 | + |
| 354 | +head<- paste(head,collapse=sep) |
| 355 | + |
| 356 | +# Write a or b. But a, b, or c. |
| 357 | +if (n>2) { |
| 358 | + paste0(head,sep,final,"",last) |
| 359 | + }else { |
| 360 | + paste0(head,"",final,"",last) |
| 361 | + } |
| 362 | +} |
| 363 | + |
| 364 | +# nocov end |