R/label_data.R

In cjvanlissa/worcs: Workflow for Open Reproducible Code in Science

make_labels <- function(data, variables = names(data)[sapply(data, inherits, what = "factor")], filename = "value_labels.yml"){
  df <- data[variables]
  out <- lapply(df, function(i){
    whatclass <- class(i)[1]
    res <- levels(i)
    names(res) <- 1:length(levels(i))
    c(list(class = whatclass), as.list(res))
  })
  yaml::write_yaml(out, file = filename)
}

# read_labels <- function(filename = "value_labels.yml"){
#   labs <- yaml::read_yaml(filename)
#   class(labs) <- c("value_labels", class(labs))
#   labs
# }


#' @title Drop value labels
#' @description Coerces `factor` and `ordered` variables to class `integer`.
#' @param x A `data.frame`.
#' @param variables Column names of `x` to coerce to integer.
#' @return A `data.frame`.
#' @examples
#' \dontrun{
#' if(interactive()){
#'  df <- data.frame(x = factor(c("a", "b")))
#'  data_unlabel(df)
#'  }
#' }
#' @rdname data_unlabel
#' @export
data_unlabel <- function(x, variables = names(x)[sapply(x, inherits, what = "factor")]){
  if(length(variables) > 0){
    x[variables] <- lapply(x[variables], as.integer)
  }
  x
}

#' @title Label factor variables using metadata
#' @description For each column of `x`, this function checks whether value
#' labels exist in `value_labels`. If so, integer values are replaced with these
#' value labels.
#' @param x A `data.frame`.
#' @param variables Column names of `x` to replace, Default: `names(x)`
#' @param value_labels A list with value labels, typically read from metadata
#' generated by \code{\link{open_data}} or \code{\link{closed_data}}.
#' Default: `read_yaml(paste0("value_labels_", substitute(x), ".yml"))`
#' @return A `data.frame`.
#' @examples
#' \dontrun{
#' if(interactive()){
#'  labs <- list(x = list(class = "factor", `1` = "a", `2` = "b"))
#'  df <- data.frame(x = 1:2)
#'  data_label(df, value_labels = labs)
#'  }
#' }
#' @rdname data_label
#' @export
data_label <- function(x, variables = names(x), value_labels = read_yaml(paste0("value_labels_", substitute(x), ".yml"))){
  out <- x
  for(nam in variables){
    if(!nam %in% names(value_labels)){
      next
    }
    if(inherits(x[[nam]], what = value_labels[[nam]][1])){
      next
    }
    switch(value_labels[[nam]][["class"]],
           "factor" = {
             out[[nam]] <- factor(x[[nam]], levels = names(value_labels[[nam]])[-1], labels = unlist(value_labels[[nam]][-1]))
           },
           "ordered" = {
             out[[nam]] <- ordered(x[[nam]], levels = names(value_labels[[nam]])[-1], labels = unlist(value_labels[[nam]][-1]))
           })
  }
  out
}