#' @name get_label
#' @title Extract Label Attribute From a Labelled Vector
#'
#' @description Retrieve the label attribute of a labelled vector. If the
#' vector has no label, the vector name is returned as a string.
#'
#' @param x An atomic vector.
#' @param ... Arguments to pass to other methods.
#' @param vars A character vector of variable names in \code{x} for which
#' to retrieve labels. If \code{NULL}, all labels are returned.
#' @param return_vector \code{logical}. When \code{TRUE}, a vector of
#' the variables is returned. Otherwise, a named list mapping
#' variable names to labels is returned. The named list can be useful
#' for restoring labels after various transformations that may
#' drop attributes.
#'
#' @seealso \code{\link{set_label}}
#'
#' @examples
#' x <- 1:10
#' x <- set_label(x, "Integers")
#'
#' get_label(x)
#'
#' y <- letters
#' attr(y, "label") # NULL
#' get_label(y) # "y"
#'
#' # Set labels for variables in a data frame
#'
#' mtcars2 <-
#' set_label(mtcars,
#' am = "Automatic / Manual",
#' mpg = "Miles per Gallon",
#' gear = "Number of gears")
#'
#' get_label(mtcars2)
#'
#' @export
get_label <- function(x, ...){
UseMethod("get_label")
}
#' @rdname get_label
#' @export
get_label.default <- function(x, ...){
if (!is.atomic(x)){
stop("`x` must be an atomic vector")
}
lbl <- attr(x, "label")
if (is.null(lbl)){
deparse(substitute(x))
}
else{
lbl
}
}
#' @rdname get_label
#' @export
get_label.data.frame <- function(x, vars = NULL, ..., return_vector = TRUE){
if (!inherits(x, "data.frame")){
stop("`x` must inherit class 'data.frame'")
}
if (is.null(vars)){
vars <- names(x)
}
not_in_data <- vars[!vars %in% names(x)]
if (length(not_in_data)){
stop("The following are not variables in `x`: ",
paste0(not_in_data, collapse = ", "))
}
is_atomic <-
vapply(x[vars],
is.atomic,
logical(1))
if (any(!is_atomic)){
stop("The following variables in `x` are not atomic: ",
paste0(vars[!is_atomic], collapse = ", "))
}
has_label <-
vapply(X = x[vars],
FUN = function(x) !is.null(attr(x, "label")),
FUN.VALUE = logical(1))
lbl <- vars
lbl[has_label] <-
vapply(X = x[vars][has_label],
FUN = get_label.default,
FUN.VALUE = character(1))
if (return_vector){
lbl
} else {
lbl <- lapply(lbl, identity)
names(lbl) <- vars
lbl
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.