R/labels.R

In declared: Functions for Declared Missing Values

# Copyright (c) 2022 - 2026, Adrian Dusa
# All rights reserved.
# 
# Redistribution and use in source and binary forms, with or without
# modification, in whole or in part, are permitted provided that the
# following conditions are met:
#     * Redistributions of source code must retain the above copyright
#       notice, this list of conditions and the following disclaimer.
#     * Redistributions in binary form must reproduce the above copyright
#       notice, this list of conditions and the following disclaimer in the
#       documentation and/or other materials provided with the distribution.
#     * The names of its contributors may NOT be used to endorse or promote
#       products derived from this software without specific prior written
#       permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL ADRIAN DUSA BE LIABLE FOR ANY
# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

#' @name labels
#' @family labelling functions
#' @title Get / Declare value labels
#'
#' @description
#' Functions to extract information about the declared variable / value labels,
#' or to declare such values if they are present in the data.
#'
#' @details
#' The function `labels()` is a adaptation of the base function to the objects
#' of class `declared`. In addition to the regular arguments, it has two
#' additional (logical) arguments called `prefixed` (FALSE by default), to 
#' retrieve the value labels prefixed with their values, and `print_as_df`
#' (TRUE by default) to print the result as a data frame.
#'
#' @return
#' \code{labels()} will return a named vector.
#'
#' \code{label()} will return a single character string.
#'
#' @examples
#' x <- declared(
#'     c(-2, 1:5, -1),
#'     labels = c("Good" = 1, "Bad" = 5, "DK" = -1),
#'     na_values = c(-1, -2),
#'     label = "Test variable"
#' )
#' x
#'
#' labels(x)
#'
#' labels(x, prefixed = TRUE)
#'
#' labels(x) <- c("Good" = 1, "Bad" = 5, "DK" = -1, "Not applicable" = -2)
#'
#' label(x)
#'
#' label(x) <- "This is a proper label"
#'
#' x
#'
#' @param x Any vector of values that should be declared as missing
#' (for `labels`) or a numeric vector of length two giving the (inclusive)
#' extents of the range of missing values (for `label`).
#'
#' @export
label <- function (x) {
  UseMethod ("label")
}


#' @export
label.default <- function (x) {
  attr (x, "label", exact = TRUE)
}


#' @export
label.haven_labelled <- function (x) {
  attr (x, "label", exact = TRUE)
}


#' @export
label.declared <- function (x) {
  attr (x, "label", exact = TRUE)
}


#' @export
label.data.frame <- function (x) {
  lapply (x, label)
}


#' @rdname labels
#' @param ... Other arguments, for internal use.
#' @param value The variable label, or a list of (named) variable labels
#' @export
`label<-` <- function (x, ..., value) {
  UseMethod ("label<-")
}


#' @export
`label<-.declared` <- function (x, ..., value) {
  if (!is.null (value) && length (value) > 1) {
    stopError_ ("`value` should be a single character string or NULL.")
  }

  if (is.null (value)) {
    attr (x, "label") <- NULL
  }
  else {
    attr (x, "label") <- as.character (value)
  }

  return (x)
}


#' @export
`label<-.haven_labelled` <- function (x, ..., value) {
  if (!is.null (value) && length (value) > 1) {
    stopError_ ("`value` should be a single character string or NULL.")
  }

  if (is.null (value)) {
    attr (x, "label") <- NULL
  }
  else {
    attr (x, "label") <- as.character (value)
  }

  return (x)
}



# the following two functions are deliberately taken from
# package Hmisc to ensure functionality upon a namespace collision

#' @export
`label<-.default` <- function (x, ..., value) {
  if (is.list (value)) {
    stopError_ ("cannot assign a list to be a object label")
  }

  if (!is.null (value) && length (value) != 1L) {
    stopError_ ("value must be character vector of length 1")
  }

  attr (x, "label") <- value

  if (! inherits (x, "labelled")) {
    class (x) <- c ("labelled", class (x))
  }

  return (x)
}


#' @export
`label<-.data.frame` <- function (x, self = TRUE, ..., value) {
  if (is.list (value)) {
    self <- FALSE
  }

  if (self) {
    if (!is.null (value) && length (value) > 1) {
      stopError_ ("`value` should be a single character string or NULL.")
    }

    xc <- class (x)
    xx <- unclass (x)
    if (is.null (value)) {
      attr (xx, "label") <- NULL
    }
    else {
      attr (xx, "label") <- as.character (value)
    }

    class (xx) <- xc
    return (xx)
  }
  else {
    if (length (value) != length (x)) {
      stopError_ ("value must have the same length as x")
    }

    for (i in seq (along.with = x)) {
      label(x[[i]]) <- value[[i]]
    }
  }

  return (x)
}






#' @export
labels.declared <- function (
    object, prefixed = FALSE, print_as_df = TRUE, ...
  ) {
    labels <- attr (object, "labels", exact = TRUE)
    
    if (is.null(labels)) {
      return(NULL)
    }

    if (isTRUE(prefixed)) {
      names (labels) <- paste0 ("[", labels, "] ", names (labels))
    }

    attr (labels, "print_as_df") <- isTRUE (print_as_df)
      
    return (
      structure (labels, class = unique (c ("labels_df", class (labels))))
    )
}


#' @export
labels.haven_labelled <- function (
    object, prefixed = FALSE, print_as_df = TRUE, ...
  ) {
    
    labels <- attr (object, "labels", exact = TRUE)
    
    if (is.null(labels)) {
      return(NULL)
    }

    if (isTRUE(prefixed)) {
      names (labels) <- paste0 ("[", labels, "] ", names (labels))
    }

    attr (labels, "print_as_df") <- isTRUE (print_as_df)
      
    return (
      structure (labels, class = unique (c ("labels_df", class (labels))))
    )
}


#' @export
labels.data.frame <- function (object, ...) {
  lapply (object, labels, ...)
}




#' @rdname labels
#' @export
`labels<-` <- function (x, value) {
  UseMethod ("labels<-")
}


#' @export
`labels<-.default` <- function (x, value) {
  # do nothing
  return (x)
}


#' @export
`labels<-.declared` <- function (x, value) {
    attr (x, "labels") <- value
    return (x)
}


#' @export
`labels<-.haven_labelled` <- function (x, value) {
  attr (x, "labels") <- value
  return (x)
}