#' @title Convert vector to labelled class
#' @name as_labelled
#'
#' @description Converts a (labelled) vector of any class into a \code{labelled}
#' class vector, resp. adds a \code{labelled} class-attribute.
#'
#' @param x Variable (vector), \code{data.frame} or \code{list} of variables
#' that should be converted to \code{\link[haven:labelled]{labelled()}}-class
#' objects.
#' @param add.labels Logical, if \code{TRUE}, non-labelled values will be
#' labelled with the corresponding value.
#' @param add.class Logical, if \code{TRUE}, \code{x} preserves its former
#' \code{class}-attribute and \code{labelled} is added as additional
#' attribute. If \code{FALSE} (default), all former \code{class}-attributes
#' will be removed and the class-attribute of \code{x} will only
#' be \code{labelled}.
#' @param skip.strings Logical, if \code{TRUE}, character vector are not converted
#' into labelled-vectors. Else, character vectors are converted to factors
#' vector and the associated values are used as value labels.
#' @param tag.na Logical, if \code{TRUE}, tagged \code{NA} values are replaced
#' by their associated values. This is required, for instance, when writing
#' data back to SPSS.
#'
#' @return \code{x}, as \code{labelled}-class object.
#'
#' @examples
#' data(efc)
#' str(efc$e42dep)
#'
#' x <- as_labelled(efc$e42dep)
#' str(x)
#'
#' x <- as_labelled(efc$e42dep, add.class = TRUE)
#' str(x)
#'
#' a <- c(1, 2, 4)
#' x <- as_labelled(a, add.class = TRUE)
#' str(x)
#'
#' data(efc)
#' x <- set_labels(efc$e42dep,
#' labels = c(`1` = "independent", `4` = "severe dependency"))
#' x1 <- as_labelled(x, add.labels = FALSE)
#' x2 <- as_labelled(x, add.labels = TRUE)
#'
#' str(x1)
#' str(x2)
#'
#' get_values(x1)
#' get_values(x2)
#' @importFrom stats na.omit
#' @export
as_labelled <- function(x, add.labels = FALSE, add.class = FALSE, skip.strings = FALSE, tag.na = FALSE) {
UseMethod("as_labelled")
}
#' @export
as_labelled.data.frame <- function(x, add.labels = FALSE, add.class = FALSE, skip.strings = FALSE, tag.na = FALSE) {
data_frame(lapply(x, FUN = as_labelled_helper, add.labels, add.class, skip.strings, tag.na))
}
#' @export
as_labelled.list <- function(x, add.labels = FALSE, add.class = FALSE, skip.strings = FALSE, tag.na = FALSE) {
lapply(x, FUN = as_labelled_helper, add.labels, add.class, skip.strings, tag.na)
}
#' @export
as_labelled.default <- function(x, add.labels = FALSE, add.class = FALSE, skip.strings = FALSE, tag.na = FALSE) {
as_labelled_helper(x, add.labels, add.class, skip.strings, tag.na)
}
as_labelled_helper <- function(x, add.labels, add.class, skip.strings, tag.na) {
# do nothing for labelled class
if (is_labelled(x)) return(x)
if (is.character(x) && skip.strings) return(x)
# if factor, convert to numeric
if (is.factor(x)) x <- as_numeric(x, keep.labels = TRUE)
# return atomics
if (is.null(get_labels(x, attr.only = TRUE))) return(x)
# fill up missing attributes
if (add.labels) x <- fill_labels(x)
# reset missings
if (!tag.na) {
xna <- get_na(x)
if (!isempty(xna)) {
x <- set_na(x, na = xna)
}
} else {
if (!requireNamespace("haven", quietly = TRUE)) {
stop("Package 'haven' required for this function. Please install it.")
}
xna <- get_na(x, as.tag = TRUE)
if (!isempty(xna)) {
labels <- attr(x, "labels", exact = TRUE)
new_tags <- unname(gsub("NA\\((.*)\\)", "\\1", xna))
names(new_tags) <- new_tags
# convert to numeric, if character
numeric_na <- which(is.na(suppressWarnings(as.numeric(new_tags))))
if (any(numeric_na)) {
names(new_tags)[numeric_na] <- match(new_tags[numeric_na], letters) * -1
}
tagged_missing <- haven::na_tag(x)
for (i in 1:length(xna)) {
x[which(tagged_missing == new_tags[i])] <- as.numeric(names(new_tags[i]))
}
labels[is.na(labels)] <- stats::setNames(attr(x, "na.values"), names(labels[is.na(labels)]))
attr(x, "labels") <- labels
}
}
# is type of labels same as type of vector? typically, character
# vectors can have numeric labels or vice versa, numeric vectors
# have "numeric" labels as character strings. in this case,
# harmonize types of vector and labels, so haven doesn't complain
lt <- as.vector(attr(x, "labels", exact = TRUE))
if (!is.null(lt) && typeof(lt) != typeof(x)) {
lab.at <- attr(x, "labels", exact = TRUE)
nlab <- names(lab.at)
if (is.integer(x) && !is.integer(lt)) {
lab.at <- as.integer(lab.at)
} else if (is.num.chr(lt, na.rm = TRUE)) {
lab.at <- as.numeric(lab.at)
} else {
lab.at <- as.character(lab.at)
}
names(lab.at) <- nlab
attr(x, "labels") <- lab.at
}
# get former class attributes
xc <- class(x)
if (add.class)
class(x) <- c(xc, "haven_labelled", "vctrs_vctr")
else
class(x) <- c("haven_labelled", "vctrs_vctr")
# add haven labelled SPSS class
if (tag.na) {
class(x) <- c("haven_labelled_spss", class(x))
}
x
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.