1 2structure2 <- function(.x, ...) { 3 exec("structure", .Data = .x, ...) 4} 5 6set_class <- function(x, class) { 7 attr(x, "class") <- class 8 x 9} 10 11#' Is object named? 12#' 13#' `is_named()` checks that `x` has names attributes, and that none of 14#' the names are missing or empty (`NA` or `""`). `is_dictionaryish()` 15#' checks that an object is a dictionary: that it has actual names and 16#' in addition that there are no duplicated names. `have_name()` 17#' is a vectorised version of `is_named()`. 18#' 19#' @param x An object to test. 20#' @return `is_named()` and `is_dictionaryish()` are scalar predicates 21#' and return `TRUE` or `FALSE`. `have_name()` is vectorised and 22#' returns a logical vector as long as the input. 23#' @export 24#' @examples 25#' # A data frame usually has valid, unique names 26#' is_named(mtcars) 27#' have_name(mtcars) 28#' is_dictionaryish(mtcars) 29#' 30#' # But data frames can also have duplicated columns: 31#' dups <- cbind(mtcars, cyl = seq_len(nrow(mtcars))) 32#' is_dictionaryish(dups) 33#' 34#' # The names are still valid: 35#' is_named(dups) 36#' have_name(dups) 37#' 38#' 39#' # For empty objects the semantics are slightly different. 40#' # is_dictionaryish() returns TRUE for empty objects: 41#' is_dictionaryish(list()) 42#' 43#' # But is_named() will only return TRUE if there is a names 44#' # attribute (a zero-length character vector in this case): 45#' x <- set_names(list(), character(0)) 46#' is_named(x) 47#' 48#' 49#' # Empty and missing names are invalid: 50#' invalid <- dups 51#' names(invalid)[2] <- "" 52#' names(invalid)[5] <- NA 53#' 54#' # is_named() performs a global check while have_name() can show you 55#' # where the problem is: 56#' is_named(invalid) 57#' have_name(invalid) 58#' 59#' # have_name() will work even with vectors that don't have a names 60#' # attribute: 61#' have_name(letters) 62is_named <- function(x) { 63 nms <- names(x) 64 65 if (is_null(nms)) { 66 return(FALSE) 67 } 68 69 if (any(nms_are_invalid(nms))) { 70 return(FALSE) 71 } 72 73 TRUE 74} 75#' @rdname is_named 76#' @export 77is_dictionaryish <- function(x) { 78 if (!length(x)) { 79 return(!is.null(x)) 80 } 81 82 is_named(x) && !any(duplicated(names(x))) 83} 84#' @rdname is_named 85#' @export 86have_name <- function(x) { 87 nms <- names(x) 88 if (is.null(nms)) { 89 rep(FALSE, length(x)) 90 } else { 91 !nms_are_invalid(nms) 92 } 93} 94 95nms_are_invalid <- function(x) { 96 x == "" | is.na(x) 97} 98 99#' Does an object have an element with this name? 100#' 101#' This function returns a logical value that indicates if a data 102#' frame or another named object contains an element with a specific 103#' name. Note that `has_name()` only works with vectors. For instance, 104#' environments need the specialised function [env_has()]. 105#' 106#' Unnamed objects are treated as if all names are empty strings. `NA` 107#' input gives `FALSE` as output. 108#' 109#' @param x A data frame or another named object 110#' @param name Element name(s) to check 111#' @return A logical vector of the same length as `name` 112#' @examples 113#' has_name(iris, "Species") 114#' has_name(mtcars, "gears") 115#' @export 116has_name <- function(x, name) { 117 name %in% names2(x) 118} 119 120#' Set names of a vector 121#' 122#' @description 123#' 124#' \Sexpr[results=rd, stage=render]{rlang:::lifecycle("stable")} 125#' 126#' This is equivalent to [stats::setNames()], with more features and 127#' stricter argument checking. 128#' 129#' 130#' @section Life cycle: 131#' 132#' `set_names()` is stable and exported in purrr. 133#' 134#' @param x Vector to name. 135#' @param nm,... Vector of names, the same length as `x`. 136#' 137#' You can specify names in the following ways: 138#' 139#' * If you do nothing, `x` will be named with itself. 140#' 141#' * If `x` already has names, you can provide a function or formula 142#' to transform the existing names. In that case, `...` is passed 143#' to the function. 144#' 145#' * If `nm` is `NULL`, the names are removed (if present). 146#' 147#' * In all other cases, `nm` and `...` are coerced to character. 148#' 149#' @export 150#' @examples 151#' set_names(1:4, c("a", "b", "c", "d")) 152#' set_names(1:4, letters[1:4]) 153#' set_names(1:4, "a", "b", "c", "d") 154#' 155#' # If the second argument is ommitted a vector is named with itself 156#' set_names(letters[1:5]) 157#' 158#' # Alternatively you can supply a function 159#' set_names(1:10, ~ letters[seq_along(.)]) 160#' set_names(head(mtcars), toupper) 161#' 162#' # If the input vector is unnamed, it is first named after itself 163#' # before the function is applied: 164#' set_names(letters, toupper) 165#' 166#' # `...` is passed to the function: 167#' set_names(head(mtcars), paste0, "_foo") 168set_names <- function(x, nm = x, ...) { 169 mold <- x 170 .Call(rlang_set_names, x, mold, nm, environment()) 171} 172 173#' Get names of a vector 174#' 175#' @description 176#' 177#' \Sexpr[results=rd, stage=render]{rlang:::lifecycle("stable")} 178#' 179#' This names getter always returns a character vector, even when an 180#' object does not have a `names` attribute. In this case, it returns 181#' a vector of empty names `""`. It also standardises missing names to 182#' `""`. 183#' 184#' 185#' @section Life cycle: 186#' 187#' `names2()` is stable. 188#' 189#' @param x A vector. 190#' @export 191#' @examples 192#' names2(letters) 193#' 194#' # It also takes care of standardising missing names: 195#' x <- set_names(1:3, c("a", NA, "b")) 196#' names2(x) 197names2 <- function(x) { 198 .Call(rlang_names2, x, environment()) 199} 200 201# Avoids `NA` names on subset-assign with unnamed vectors 202`names2<-` <- function(x, value) { 203 if (is_null(names(x))) { 204 names(x) <- names2(x) 205 } 206 names(x) <- value 207 x 208} 209 210length_ <- function(x) { 211 .Call(rlang_length, x) 212} 213 214#' How long is an object? 215#' 216#' This is a function for the common task of testing the length of an 217#' object. It checks the length of an object in a non-generic way: 218#' [base::length()] methods are ignored. 219#' 220#' @param x A R object. 221#' @param n A specific length to test `x` with. If `NULL`, 222#' `has_length()` returns `TRUE` if `x` has length greater than 223#' zero, and `FALSE` otherwise. 224#' @export 225#' @keywords internal 226#' @examples 227#' has_length(list()) 228#' has_length(list(), 0) 229#' 230#' has_length(letters) 231#' has_length(letters, 20) 232#' has_length(letters, 26) 233has_length <- function(x, n = NULL) { 234 len <- .Call(rlang_length, x) 235 236 if (is_null(n)) { 237 as.logical(len) 238 } else { 239 len == n 240 } 241} 242 243poke_attributes <- function(x, attrs) { 244 .Call(rlang_poke_attrib, x, attrs) 245} 246 247#' Zap source references 248#' 249#' @description 250#' 251#' There are a number of situations where R creates source references: 252#' 253#' - Reading R code from a file with `source()` and `parse()` might save 254#' source references inside calls to `function` and `{`. 255#' - [sys.call()] includes a source reference if possible. 256#' - Creating a closure stores the source reference from the call to 257#' `function`, if any. 258#' 259#' These source references take up space and might cause a number of 260#' issues. `zap_srcref()` recursively walks through expressions and 261#' functions to remove all source references. 262#' 263#' @param x An R object. Functions and calls are walked recursively. 264#' 265#' @export 266zap_srcref <- function(x) { 267 if (is_closure(x)) { 268 body(x) <- zap_srcref(body(x)) 269 return(x) 270 } 271 if (!is_call(x)) { 272 return(x) 273 } 274 275 x <- duplicate(x, shallow = TRUE) 276 277 if (!is_null(sexp_attrib(x))) { 278 attr(x, "srcref") <- NULL 279 attr(x, "wholeSrcref") <- NULL 280 attr(x, "srcfile") <- NULL 281 } 282 if (is_call(x, "function")) { 283 node <- node_get(x, 3) 284 if (!is_null(node)) { 285 node_poke_cdr(node, NULL) 286 } 287 } 288 289 node <- x 290 while (!is_null(node)) { 291 node_poke_car(node, zap_srcref(node_car(node))) 292 node <- node_cdr(node) 293 } 294 295 x 296} 297