R/labeltools.R

In adviceas/adviceverse: Tools for Data and Survey Analysis, Advice A/S

#' Wrapper around \code{case_when()}. Levels in the same order as \code{case_when()}-statement.
#' Use with dplyr::mutate()
#'
#' @param ... Syntax as \code{case_when()}
#' @return Factor variable
fct_case_when <- function(...) {

  # Credits to Dennis YL, StackOverflow.

  case_when_levels <- sapply(as.list(match.call())[-1], # Remove first element in list
                             function(f) f[[3]] # Extract elements after "~" => Names of levels
  )

  factor(dplyr::case_when(...),
         levels = case_when_levels[!is.na(case_when_levels)])

}

#' Add variable label attributes to class factor.
#' Use after/with e.g. \code{fct_case_when()}
#' Use haven::labelled() with dplyr::mutate() for numerics and characters
#'
#' @param var Vector of variable names for cross tabs
#' @return Data frame with variable labelled
fct_label <- function(x,
                      label) {

  if (!is.factor(x))
    stop("Not a factor variable")

  attr(x, "label") <- label

  x

}

#' BETA. Smart recode and collapse categories / factors.
fct_cat_collapse <- function(var, ...) {

  # Skrives evt. om så den bruger map-funktioner i stedet eller fct_collapse.

  if(!is.factor(var))
    stop("Input must be a factor.")

  groups <- rlang::list2(...)

  for (i in 1:length(groups)) {

    cats_combined <- paste(groups[[i]], collapse = "/")

    for (k in 1:length(groups[[i]])) {

      cats <- c(groups[[i]][k])
      names(cats) <- cats_combined

      var <- forcats::fct_recode(var, !!!cats)

    }

  }

  var

}

#' BETA. Keep label.
keep_label_num <- function (x, fun, ...) {

  if(!is.numeric(x) & !has_label(x))
    stop("Input must be a labelled numeric.")

  # Get label
  varlab <- attr(x, "label", exact = TRUE)

  call_embedded_fun <- function(x, fun, ...) {

    embedded_fun <- match.fun(fun)
    embedded_fun(x, ...)

  }

  haven::labelled(
    call_embedded_fun(x,
                      fun,
                      ...),
    labels = NULL,
    label = varlab
  )

}

#' Check if variable has variable label attribute. Logical.
has_label <- function(x) {

  varlab <- attr(x, "label", exact = TRUE)

  if (!is.null(varlab)) TRUE
  else FALSE

}

#' Print variable label, like haven::print_labels() for value labels.
print_label <- function(x) {

  varlab <- attr(x, "label", exact = TRUE)

  cat(varlab)
  invisible(varlab) # Return variable label as string

}

#' Check if variable has value labels attribute. Logical.
has_labels <- function(x) {

  vallabs <- attr(x, "labels", exact = TRUE)

  if (!is.null(vallabs)) TRUE
  else FALSE

}

#' Check if variable has both variable label and value labels attributes. Logical.
#' Useful for coercing all labelled categorical variables into factor variables with dplyr::mutate_if() and haven::as_factor()
has_all_labels <- function(x) {

  if (has_label(x) & has_labels(x)) TRUE
  else FALSE

}

#' Add varname as varlabel
#' E.g.: data %>% mutate_all(varname_as_varlabel) %>% janitor::clean_names() %>% llookup()
varname_as_varlabel <- function(x) {

  #if (adviceverse::has_label(x) == FALSE) {

  value <- deparse(substitute(x))
  attr(x, "label") <- value
  return(x)

  #}

}