R/label.R

In msberends/certedata: Tools for Data Analysis at Certe

# ==================================================================== #
# TITLE                                                                #
# Tools for Data Analysis at Certe                                     #
#                                                                      #
# AUTHORS                                                              #
# Berends MS (m.berends@certe.nl)                                      #
# Meijer BC (b.meijer@certe.nl)                                        #
# Hassing EEA (e.hassing@certe.nl)                                     #
#                                                                      #
# COPYRIGHT                                                            #
# (c) 2019 Certe Medische diagnostiek & advies - https://www.certe.nl  #
#                                                                      #
# LICENCE                                                              #
# This R package is free software; you can redistribute it and/or      #
# modify it under the terms of the GNU General Public License          #
# version 2.0, as published by the Free Software Foundation.           #
# This R package is distributed in the hope that it will be useful,    #
# but WITHOUT ANY WARRANTY; without even the implied warranty of       #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the         #
# GNU General Public License for more details.                         #
# ==================================================================== #

#' Label van een object
#'
#' Hiermee kan de eigenschap (\emph{attribute}) \code{label} van een object weergegeven worden of aan een object toegewezen worden.
#' @param x Vector of \code{data.frame}.
#' @param value Vector met labels, die evt. benoemd zijn met kolomnamen van \code{x}.
#' @rdname label
#' @importFrom crayon silver italic
#' @export
#' @examples
#' x <- data.frame(a = "test", b = "test", stringsAsFactors = FALSE)
#' label(x) <- "Dit is de dataframe"
#' label(x)
#'
#' label(x$a) <- "Dit is kolom 'a'"
#' print(x$a)
#'
#' label(x) <- c("Dit is kolom 'a'", "Dit is kolom 'b'")
#' label(x) <- c(b = "Dit is kolom 'b'", a = "Dit is kolom 'a'")
#'
#'
#' x <- 5
#' label(x) <- "Dit is het getal 5."
#' print(x)
label <- function(x) {
  l <- attributes(x)$label
  if (is.null(l)) {
    NULL
  } else {
    class(l) <- "label"
    l
  }
}

#' @rdname label
#' @export
`label<-` <- function(x, value) {
  value <- as.character(value)
  if (NCOL(x) == 1) {
    if (length(value) > 1) {
      warning("only first label will be assigned", call. = FALSE)
    }
    attr(x, "label") <- value[1L]
    if (!"labelled" %in% class(x)) {
      class(x) <- c("labelled", class(x))
    }
  } else {
    if (is.null(names(value))) {
      if (length(value) == 1) {
        # label voor data.frame
        attr(x, "label") <- value[1L]
        if (!"labelled" %in% class(x)) {
          class(x) <- c("labelled", class(x))
        }
      } else {
        # label per kolom
        if (length(x) != length(value)) {
          stop("`x` and `value` must be of same length.")
        }
        for (i in 1:length(x)) {
          attr(x[, i], "label") <- value[i]
          if (!"labelled" %in% class(x[, i])) {
            class(x[, i]) <- c("labelled", class(x[, i]))
          }
        }
      }
    } else {
      # labels benoemd
      col.names <- names(value)
      for (i in 1:length(col.names)) {
        if (col.names[i] %in% colnames(x)) {
          attr(x[, col.names[i]], "label") <- value[i]
          if (!"labelled" %in% class(x[, col.names[i]])) {
            class(x[, col.names[i]]) <- c("labelled", class(x[, col.names[i]]))
          }
        }
      }
    }
  }
  x
}


#' @exportMethod print.label
#' @export
print.label <- function(x, ...) {
  cat(silver(italic(x)), "\n")
}


#' @exportMethod print.labelled
#' @export
print.labelled <- function(x, ...) {
  obj <- x
  attr(obj, "label") <- NULL
  class(obj) <- class(obj)[class(obj) != "labelled"]
  print(obj, ...)
  cat(silver(italic(label(x))), "\n")
}