attr.R

structure2 <- function(.x, ...) {
  exec("structure", .Data = .x, ...)
}

set_class <- function(x, class) {
  attr(x, "class") <- class
  x
}

#' Is object named?
#'
#' `is_named()` checks that `x` has names attributes, and that none of
#' the names are missing or empty (`NA` or `""`). `is_dictionaryish()`
#' checks that an object is a dictionary: that it has actual names and
#' in addition that there are no duplicated names. `have_name()`
#' is a vectorised version of `is_named()`.
#'
#' @param x An object to test.
#' @return `is_named()` and `is_dictionaryish()` are scalar predicates
#'   and return `TRUE` or `FALSE`. `have_name()` is vectorised and
#'   returns a logical vector as long as the input.
#' @export
#' @examples
#' # A data frame usually has valid, unique names
#' is_named(mtcars)
#' have_name(mtcars)
#' is_dictionaryish(mtcars)
#'
#' # But data frames can also have duplicated columns:
#' dups <- cbind(mtcars, cyl = seq_len(nrow(mtcars)))
#' is_dictionaryish(dups)
#'
#' # The names are still valid:
#' is_named(dups)
#' have_name(dups)
#'
#'
#' # For empty objects the semantics are slightly different.
#' # is_dictionaryish() returns TRUE for empty objects:
#' is_dictionaryish(list())
#'
#' # But is_named() will only return TRUE if there is a names
#' # attribute (a zero-length character vector in this case):
#' x <- set_names(list(), character(0))
#' is_named(x)
#'
#'
#' # Empty and missing names are invalid:
#' invalid <- dups
#' names(invalid)[2] <- ""
#' names(invalid)[5] <- NA
#'
#' # is_named() performs a global check while have_name() can show you
#' # where the problem is:
#' is_named(invalid)
#' have_name(invalid)
#'
#' # have_name() will work even with vectors that don't have a names
#' # attribute:
#' have_name(letters)
is_named <- function(x) {
  nms <- names(x)

  if (is_null(nms)) {
    return(FALSE)
  }

  if (any(nms_are_invalid(nms))) {
    return(FALSE)
  }

  TRUE
}
#' @rdname is_named
#' @export
is_dictionaryish <- function(x) {
  if (!length(x)) {
    return(!is.null(x))
  }

  is_named(x) && !any(duplicated(names(x)))
}
#' @rdname is_named
#' @export
have_name <- function(x) {
  nms <- names(x)
  if (is.null(nms)) {
    rep(FALSE, length(x))
  } else {
    !nms_are_invalid(nms)
  }
}

nms_are_invalid <- function(x) {
  x == "" | is.na(x)
}

#' Does an object have an element with this name?
#'
#' This function returns a logical value that indicates if a data
#' frame or another named object contains an element with a specific
#' name. Note that `has_name()` only works with vectors. For instance,
#' environments need the specialised function [env_has()].
#'
#' Unnamed objects are treated as if all names are empty strings. `NA`
#' input gives `FALSE` as output.
#'
#' @param x A data frame or another named object
#' @param name Element name(s) to check
#' @return A logical vector of the same length as `name`
#' @examples
#' has_name(iris, "Species")
#' has_name(mtcars, "gears")
#' @export
has_name <- function(x, name) {
  name %in% names2(x)
}

#' Set names of a vector
#'
#' @description
#'
#' \Sexpr[results=rd, stage=render]{rlang:::lifecycle("stable")}
#'
#' This is equivalent to [stats::setNames()], with more features and
#' stricter argument checking.
#'
#'
#' @section Life cycle:
#'
#' `set_names()` is stable and exported in purrr.
#'
#' @param x Vector to name.
#' @param nm,... Vector of names, the same length as `x`.
#'
#'   You can specify names in the following ways:
#'
#'   * If you do nothing, `x` will be named with itself.
#'
#'   * If `x` already has names, you can provide a function or formula
#'     to transform the existing names. In that case, `...` is passed
#'     to the function.
#'
#'   * If `nm` is `NULL`, the names are removed (if present).
#'
#'   * In all other cases, `nm` and `...` are coerced to character.
#'
#' @export
#' @examples
#' set_names(1:4, c("a", "b", "c", "d"))
#' set_names(1:4, letters[1:4])
#' set_names(1:4, "a", "b", "c", "d")
#'
#' # If the second argument is ommitted a vector is named with itself
#' set_names(letters[1:5])
#'
#' # Alternatively you can supply a function
#' set_names(1:10, ~ letters[seq_along(.)])
#' set_names(head(mtcars), toupper)
#'
#' # If the input vector is unnamed, it is first named after itself
#' # before the function is applied:
#' set_names(letters, toupper)
#'
#' # `...` is passed to the function:
#' set_names(head(mtcars), paste0, "_foo")
set_names <- function(x, nm = x, ...) {
  mold <- x
  .Call(rlang_set_names, x, mold, nm, environment())
}

#' Get names of a vector
#'
#' @description
#'
#' \Sexpr[results=rd, stage=render]{rlang:::lifecycle("stable")}
#'
#' This names getter always returns a character vector, even when an
#' object does not have a `names` attribute. In this case, it returns
#' a vector of empty names `""`. It also standardises missing names to
#' `""`.
#'
#'
#' @section Life cycle:
#'
#' `names2()` is stable.
#'
#' @param x A vector.
#' @export
#' @examples
#' names2(letters)
#'
#' # It also takes care of standardising missing names:
#' x <- set_names(1:3, c("a", NA, "b"))
#' names2(x)
names2 <- function(x) {
  .Call(rlang_names2, x, environment())
}

# Avoids `NA` names on subset-assign with unnamed vectors
`names2<-` <- function(x, value) {
  if (is_null(names(x))) {
    names(x) <- names2(x)
  }
  names(x) <- value
  x
}

length_ <- function(x) {
  .Call(rlang_length, x)
}

#' How long is an object?
#'
#' This is a function for the common task of testing the length of an
#' object. It checks the length of an object in a non-generic way:
#' [base::length()] methods are ignored.
#'
#' @param x A R object.
#' @param n A specific length to test `x` with. If `NULL`,
#'   `has_length()` returns `TRUE` if `x` has length greater than
#'   zero, and `FALSE` otherwise.
#' @export
#' @keywords internal
#' @examples
#' has_length(list())
#' has_length(list(), 0)
#'
#' has_length(letters)
#' has_length(letters, 20)
#' has_length(letters, 26)
has_length <- function(x, n = NULL) {
  len <- .Call(rlang_length, x)

  if (is_null(n)) {
    as.logical(len)
  } else {
    len == n
  }
}

poke_attributes <- function(x, attrs) {
  .Call(rlang_poke_attrib, x, attrs)
}

#' Zap source references
#'
#' @description
#'
#' There are a number of situations where R creates source references:
#'
#' - Reading R code from a file with `source()` and `parse()` might save
#'   source references inside calls to `function` and `{`.
#' - [sys.call()] includes a source reference if possible.
#' - Creating a closure stores the source reference from the call to
#'   `function`, if any.
#'
#' These source references take up space and might cause a number of
#' issues. `zap_srcref()` recursively walks through expressions and
#' functions to remove all source references.
#'
#' @param x An R object. Functions and calls are walked recursively.
#'
#' @export
zap_srcref <- function(x) {
  if (is_closure(x)) {
    body(x) <- zap_srcref(body(x))
    return(x)
  }
  if (!is_call(x)) {
    return(x)
  }

  x <- duplicate(x, shallow = TRUE)

  if (!is_null(sexp_attrib(x))) {
    attr(x, "srcref") <- NULL
    attr(x, "wholeSrcref") <- NULL
    attr(x, "srcfile") <- NULL
  }
  if (is_call(x, "function")) {
    node <- node_get(x, 3)
    if (!is_null(node)) {
      node_poke_cdr(node, NULL)
    }
  }

  node <- x
  while (!is_null(node)) {
    node_poke_car(node, zap_srcref(node_car(node)))
    node <- node_cdr(node)
  }

  x
}