R/harmonize_values.R

In retroharmonize: Ex Post Survey Data Harmonization

#' Harmonize values and labels of labelled vectors
#'
#' Create a harmonized labelled vector with standardized value labels,
#' numeric coding, and missing value definitions.
#'
#' @description
#' `harmonize_values()` converts heterogeneous labelled survey vectors
#' into a harmonized representation suitable for cross-survey integration.
#'
#' The function:
#'
#' - harmonizes value labels using regex-based matching;
#' - assigns harmonized numeric codes;
#' - preserves original coding metadata;
#' - standardizes user-defined missing values;
#' - preserves SPSS-style labelled metadata;
#' - and records provenance attributes.
#'
#' @details
#' Harmonization is performed using a harmonization table supplied via
#' `harmonize_labels`.
#'
#' The harmonization table must contain:
#'
#' - `from`: regex patterns matching original labels;
#' - `to`: harmonized labels;
#' - `numeric_values`: harmonized numeric codes.
#'
#' Original labels and numeric codes are preserved in attributes
#' attached to the returned vector.
#'
#' If no harmonization table is supplied, the function still attempts
#' to normalize common missing value labels such as:
#'
#' - `"inap"`
#' - `"declined"`
#' - `"do_not_know"`
#'
#' @param x A labelled vector, typically of class
#'   `"haven_labelled"` or `"haven_labelled_spss"`.
#'
#' @param harmonize_label Optional harmonized variable label.
#'   Defaults to the original variable label.
#'
#' @param harmonize_labels A list describing harmonization rules.
#'   Must contain the elements:
#'
#'   - `from`
#'   - `to`
#'   - `numeric_values`
#'
#' @param na_values Named numeric vector defining harmonized
#'   missing value codes.
#'
#' @param na_range Optional SPSS-style missing value range.
#'   Usually left `NULL`.
#'
#' @param id Survey identifier.
#'   Defaults to `"survey_id"`.
#'
#' @param name_orig Optional original variable name.
#'   Defaults to the object name supplied to `x`.
#'
#' @param remove Optional regex pattern removed from original labels
#'   before harmonization.
#'
#' @param perl Logical. Use Perl-compatible regular expressions?
#'   Defaults to `FALSE`.
#'
#' @return
#' A harmonized `haven_labelled_spss` vector.
#'
#' The returned vector preserves:
#'
#' - harmonized value labels;
#' - harmonized numeric coding;
#' - SPSS missing value metadata;
#' - original coding metadata;
#' - survey provenance metadata.
#'
#' @family harmonization functions
#'
#' @examples
#' var1 <- labelled::labelled_spss(
#'   x = c(1, 0, 1, 1, 0, 8, 9),
#'   labels = c(
#'     "TRUST" = 1,
#'     "NOT TRUST" = 0,
#'     "DON'T KNOW" = 8,
#'     "INAP. HERE" = 9
#'   ),
#'   na_values = c(8, 9)
#' )
#'
#' harmonize_values(
#'   var1,
#'   harmonize_labels = list(
#'     from = c(
#'       "^tend\\sto|^trust",
#'       "^tend\\snot|not\\strust",
#'       "^dk|^don",
#'       "^inap"
#'     ),
#'     to = c(
#'       "trust",
#'       "not_trust",
#'       "do_not_know",
#'       "inap"
#'     ),
#'     numeric_values = c(
#'       1,
#'       0,
#'       99997,
#'       99999
#'     )
#'   ),
#'   na_values = c(
#'     "do_not_know" = 99997,
#'     "inap" = 99999
#'   ),
#'   id = "survey_id"
#' )
#'
#' @seealso
#' [harmonize_var_names()]
#'
#' @importFrom assertthat assert_that
#' @importFrom dplyr arrange distinct distinct_all filter if_else
#' @importFrom dplyr left_join mutate select
#' @importFrom haven labelled_spss
#' @importFrom labelled labelled na_range na_values
#' @importFrom labelled to_character val_labels var_label
#' @importFrom rlang .data set_names
#' @importFrom tibble as_tibble tibble
#' @importFrom tidyselect all_of
#'
#' @export

harmonize_values <- function(
  x,
  harmonize_label = NULL,
  harmonize_labels = NULL,
  na_values = c(
    "do_not_know" = 99997,
    "declined" = 99998,
    "inap" = 99999
  ),
  na_range = NULL,
  id = "survey_id",
  name_orig = NULL,
  remove = NULL,
  perl = FALSE
) {
  if (is.null(na_values)) input_na_values <- NULL

  if (is.null(na_values)[1] | is.na(na_values)[1]) {
    if ("na_values" %in% names(harmonize_labels)) {
      input_na_values <- na_values
      harmonize_labels <- harmonize_labels[c("from", "to", "numeric_values")]
    }
  } else {
    # what if there are no na_values given?
    input_na_values <- na_values
    harmonize_labels <- harmonize_labels[c("from", "to", "numeric_values")]
  }

  validate_label_list <- function(label_list) {
    assert_that(
      all(c("from", "to", "numeric_values") %in% names(label_list)),
      msg = "The harmonize_labels list must have 'from', 'to', and 'numeric_values' vectors."
    )

    ll_lengths <- vapply(label_list[c("from", "to", "numeric_values")], length, numeric(1))

    assert_that(
      length(unique(ll_lengths)) == 1,
      msg = paste0(
        "The 'from', 'to', and 'numeric_values' vectors must be of equal length, currently it is: ",
        as.character(paste(ll_lengths, collapse = ", "))
      )
    )

    ll <- as_tibble(label_list[c("from", "to", "numeric_values")])

    for (l in unique(label_list$to)) {
      matched_numeric_value <- ll %>%
        filter(.data$to == l) %>%
        distinct(.data$to, .data$numeric_values) %>%
        pull(.data$numeric_values)

      assert_that(length(matched_numeric_value) == 1,
        msg = paste0(
          "in harmonized_list ",
          l, " is matched with multiple numeric values: <",
          paste(matched_numeric_value, collapse = ","), ">"
        )
      )
    }
  }

  if (!is.null(harmonize_labels)) {
    validate_label_list(label_list = harmonize_labels)
  }

  if (is.null(id)) {
    # if not otherwise stated, inherit the ID of x, if present
    if (!is.null(attr(x, "id"))) {
      id <- attr(x, "id")
    } else {
      id <- "unknown"
    }
  }

  ## Get the original object name for recording it as metadata
  original_x_name <- deparse(substitute(x))

  ## Harmonize SPSS variable labels, if they exist
  if (is.null(harmonize_label)) harmonize_label <- labelled::var_label(x)
  if (is.null(harmonize_label)) harmonize_label <- original_x_name

  if (!is.null(harmonize_labels) & validate_harmonize_labels(harmonize_labels)) { ## see assertions.R
    harmonize_labels <- tibble::as_tibble(harmonize_labels) %>%
      select(all_of(c("from", "to", "numeric_values")))
  }

  original_values <- tibble::tibble(
    x = vctrs::vec_data(x)
  )

  original_values$orig_labels <- if_else(
    condition = original_values$x %in% labelled::val_labels(x),
    true = as_character(x),
    false = NA_character_
  )

  if (!is.null(remove)) {
    harmonize_labels$from <- gsub(remove, "", harmonize_labels$from)
    original_values$orig_labels <- gsub(remove, "", original_values$orig_labels)
  }

  if (is.na_range_to_values(x)) {
    x <- na_range_to_values(x)
  }

  if (!is.null(harmonize_labels)) {
    condition_string <- tolower(gsub("\\.|\\(|\\)", "", harmonize_labels$from))
    codebook_string <- tolower(gsub("\\.|\\(|\\)", "", original_values$orig_labels))

    original_values$orig_labels <- if_else(
      # label == "" if not in the harmonization list
      condition = grepl(paste(condition_string, collapse = "|"),
        codebook_string,
        perl = perl
      ),
      true = codebook_string,
      false = ""
    )

    code_table <- dplyr::distinct_all(original_values)
    str <- code_table$orig_labels # string of original values
    code_table$new_labels <- NA_character_
    code_table$new_values <- NA_real_

    for (o in seq_along(harmonize_labels$from)) {
      from_string <- tolower(gsub("\\.|\\(|\\)", "", harmonize_labels$from[o]))

      code_table$new_labels[which(grepl(from_string, str))] <- harmonize_labels$to[o]
      code_table$new_values[which(grepl(from_string, str))] <- harmonize_labels$numeric_values[o]

      # code_table$new_labels [which ( tolower(harmonize_labels$from[o]) == str) ] <- harmonize_labels$to[o]
      # code_table$new_values [which ( tolower(harmonize_labels$from[o]) == str) ] <- harmonize_labels$numeric_values[o]
    }

    old_code <- function() {
      ## Can be removed after extensive testing -------
      for (r in seq_along(harmonize_labels$to)) {
        ## harmonize the strings to new labelling by regex
        str[which(grepl(tolower(harmonize_labels$from[r]), str, perl = perl))] <- harmonize_labels$to[r]
      }

      add_new_values <- harmonize_labels %>%
        as_tibble() %>%
        dplyr::select(tidyselect::all_of(
          c("to", "numeric_values")
        )) %>%
        rlang::set_names(c("new_labels", "new_values"))

      code_table <- dplyr::left_join(
        code_table,
        add_new_values,
        by = "new_labels"
      ) %>%
        filter(!is.na(.data$new_values))
    }

    code_table$original_values <- NULL
  } else {
    # no harmonization is given -----------------------
    code_table <- get_labelled_attributes(x) ## see below main function
    na_labels <- names(na_values)

    if (length(na_labels) > 0) {
      # if there is no valid label harmonization, still check for potential missings
      potential_na_values <- sapply(na_labels, function(x) paste0("^", x, "|", x))
      na_regex <- sapply(potential_na_values, function(s) grepl(s, val_label_normalize(code_table$new_labels), perl = perl))
      for (c in seq_along(na_labels)) {
        code_table$new_labels[which(na_regex[, c])] <- na_labels[c]
      }
    }
  }

  code_table <- code_table %>%
    distinct_all() %>%
    dplyr::arrange(.data$new_values)

  new_value_table <- original_values %>%
    dplyr::left_join(
      code_table,
      by = c("x", "orig_labels")
    ) %>%
    dplyr::mutate(new_values = if_else(
      condition = is.na(.data$new_labels),
      true = x,
      false = .data$new_values
    )) %>% # invalid labels should be treated elsewhere
    dplyr::arrange(.data$new_values)


  original_values$x
  ## define new missing values, not with range
  ## A message should be given, these are just suspected to be missing
  new_na_values <- new_value_table$new_values[which(new_value_table$new_values >= 99900)]

  if (!is.null(na_values) & length(na_values) > 0) {
    # The user gets a message if the state missing range (described with labels) is not empty.
    potential_na_values <- original_values$x[which(original_values$x %in% as.numeric(na_values))]
    if (length(potential_na_values) > 0) {
      unique_potential_na_values <- paste(unique(potential_na_values), collapse = ", ")
      warning_message <- glue::glue("Variable {original_x_name} has values {unique_potential_na_values} that you mark as missing.")
      # message ( warning_message)
    }
  }


  new_na_values <- input_na_values

  # define new value - label pairs
  new_labelling <- new_value_table %>%
    dplyr::distinct(.data$new_values, .data$new_labels)
  new_labels <- new_labelling$new_values
  names(new_labels) <- new_labelling$new_labels

  new_labelling <- new_labelling %>%
    mutate(new_labels = ifelse(is.na(.data$new_labels),
      ifelse(.data$new_values %in% input_na_values,
        names(input_na_values), .data$new_labels
      ),
      .data$new_labels
    ))

  # define original labelling
  original_labelling <- new_value_table %>%
    dplyr::distinct(.data$new_values, .data$orig_labels)

  original_labels <- original_labelling$new_values
  names(original_labels) <- original_labelling$orig_labels

  # define original numeric code
  original_numerics <- new_value_table %>%
    dplyr::distinct(.data$new_values, .data$x)
  original_numeric_values <- original_numerics$new_values
  names(original_numeric_values) <- original_numerics$x

  # create new numerics
  new_numerics <- tibble::tibble(x = original_values$x) %>%
    dplyr::left_join(original_numerics, by = "x")

  # ifelse ( is.null(labelled::na_values(x)),
  #         na_values,
  #         c())

  na_value_labels <- na_values

  return_value <- labelled_spss_survey(
    x = new_numerics$new_values,
    labels = labelled::val_labels(x),
    label = harmonize_label,
    na_values = labelled::na_values(x),
    na_range = labelled::na_range(x),
    id = id,
    name_orig = original_x_name
  )

  add_to_value_range <- (!harmonize_labels$to %in% new_labelling$new_labels)
  further_valid_labels <- harmonize_labels$numeric_values[add_to_value_range]
  names(further_valid_labels) <- harmonize_labels$to[add_to_value_range]

  new_valid_range_labels <- sort(
    c(
      new_labels,
      further_valid_labels,
      input_na_values[which(!input_na_values %in% new_labelling$new_labels)]
    )
  )

  new_valid_range_labels_2 <- new_valid_range_labels[unique(names(new_valid_range_labels))]
  new_valid_range_labels_3 <- new_valid_range_labels_2[!is.na(new_valid_range_labels_2)]
  new_valid_range_labels_3

  attr(return_value, "labels") <- new_valid_range_labels_3
  attr(return_value, "na_values") <- unique(new_na_values)
  attr(return_value, paste0(attr(return_value, "id"), "_values")) <- original_numeric_values

  assertthat::assert_that(
    inherits(return_value, "haven_labelled_spss")
  )

  return_value
}

#' @importFrom dplyr distinct_all
#' @keywords internal
get_labelled_attributes <- function(x) {
  unlabelled_x <- sapply(attributes(x), function(i) {
    attributes(i) <- NULL
    x
  })[, 1]

  code_table <- tibble::tibble(
    x = unlabelled_x,
    new_values = unlabelled_x
  )

  code_table$orig_labels <- as_character(x)
  code_table$new_labels <- as_character(x)

  dplyr::distinct_at(code_table, dplyr::vars(
    all_of(c("x", "new_values", "orig_labels", "new_labels"))
  ))
}