fct_recode

gistfile1.txt

get_fct_recode <- function(path_config_fl) {

  mapp_col <- readRDS(file.path(path_config_fl, "mapp_col.rds"))
  
  list_config_fls <- Sys.glob(file.path(path_config_fl, "*.rds"))
  
  mapp_col <- mapp_col %>% dplyr::mutate(file_name_config = file.path(path_config_fl, paste0(common, "_levels.rds")), 
                                         list_config_fct = dplyr::if_else(file_name_config %in% list_config_fls, file_name_config, NA_character_)) %>%
    dplyr::select(-file_name_config)
  

  
  # # add column for the level recode  mapping specified in the config file
  mapping_levels <- function(fn) {
    if(is.na(fn)) {
      return(NA)
    } else {
      readRDS(fn)
    }
  }

  map_levels_vector <- Vectorize(mapping_levels)
  
  mapp_col <- mapp_col %>% dplyr::mutate(lev_map = map_levels_vector(list_config_fct))
  
  make_recode_vector <- function(lev_map) {
    
    if(all(is.na(lev_map))){
      return(NA)
    } else {
      # take the tibble specifying the mapping from given to standard levels, and
      # convert it to a named vector ready to be passed into forcats::fct_recode
      rlang::set_names(lev_map %>% dplyr::pull(given), lev_map %>% dplyr::pull(common))
    }
  }
  
  make_recor_vector_v <- Vectorize(make_recode_vector)
  
  mapp_col <- mapp_col %>% dplyr::mutate(recode_vector = make_recor_vector_v(lev_map))
  
  
  # add a column of expressions that call fct_recode with the specified arguments.
  # Modify this expression so that new (standard) levels that are missing (NA) get
  # named "NULL". See documentation of readr::fct_recode.
  fix_factor_recode_nas <- function(recode_call) {
    call_arg_names <- names(recode_call)[3:length(recode_call)]
    call_arg_names[which(call_arg_names == "")] <- "NULL"
    new_names <- c(names(recode_call)[1:2],call_arg_names)
    names(recode_call) <- new_names
    recode_call
  }
  
  make_factor_recode_expr <- function(...) {
    common <- list(...)[["common"]]
    recode_vector <- list(...)[["recode_vector"]]
    
    if(all(is.na(recode_vector))) return(NA)
    
    call_fct <- rlang::expr(forcats::fct_recode(!!rlang::sym(common), !!!recode_vector))
    
    fix_factor_recode_nas(call_fct)
  }
  
  mapp_col <- mapp_col %>% dplyr::mutate(factor_recode_expr = purrr::pmap(., function(...) make_factor_recode_expr(...)))
  
  # convert the column of fct_recode call expressions into a named vector
  # ready to be unquote-spliced into mutate in import_and_standardise
  mapp_col <- mapp_col %>% dplyr::filter(!is.na(factor_recode_expr))
  
  rlang::set_names(mapp_col %>% dplyr::pull(factor_recode_expr), mapp_col %>% dplyr::pull(common))
  
 }