translation available

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: transcats
 Type: Package
 Title: Translate Categorical Data Using Translation Tables
-Version: 0.0.0.9004
+Version: 0.0.0.9005
 Authors@R: 
     person(
     "Carwil", "Bjork-James",

NAMESPACE

@@ -7,6 +7,7 @@ export(create_blank_translation_table)
 export(create_blank_translation_tables)
 export(dest_lang)
 export(dest_lang_list)
+export(get_translation_variables)
 export(parse_combined_translation_table)
 export(reactable_lang_en)
 export(reactable_lang_es)
@@ -21,12 +22,14 @@ export(title_lang)
 export(translated_join)
 export(translated_join_vars)
 export(translated_levels)
+export(translation_available_for)
 export(var_lang)
 export(var_lang_str)
 export(var_name_language_available)
 export(variable_name)
 export(variable_name_from_string)
 export(variable_names_vector)
+export(which_translation_available)
 importFrom(assertthat,is.string)
 importFrom(dplyr,all_of)
 importFrom(dplyr,filter)
@@ -36,6 +39,7 @@ importFrom(dplyr,slice)
 importFrom(fs,path_package)
 importFrom(lifecycle,deprecated)
 importFrom(magrittr,"%>%")
+importFrom(rlang,.data)
 importFrom(rlang,as_label)
 importFrom(rlang,enquo)
 importFrom(stats,setNames)

R/data.R

@@ -66,6 +66,18 @@
 #' @source Created as part of `transcats`
 "gss_var_table"
 
+#' Translation table for gss_cat
+#'
+#' A translation table for the variable gss_cat, a data source from the
+#' General Social Survey that is included in the package `forcats`
+#' and used for examples in `transcats`.
+#'
+#' @format ## `gss_translation`
+#' A list of tibbles, each with three columns named "en", "es", "fr".
+#' Their names correspond to the categorical variables involved:
+#' `marital`, `race`, `rincome`, `partyid`, `relig`, `denom`.
+"gss_translation"
+
 #' State Responsibility Levels
 #'
 #' A vector ordering the levels for the variable `state_responsibility` in

R/transcats-package.R

@@ -10,6 +10,7 @@
 #' @importFrom dplyr slice
 #' @importFrom fs path_package
 #' @importFrom lifecycle deprecated
+#' @importFrom rlang .data
 #' @importFrom rlang as_label
 #' @importFrom rlang enquo
 #' @importFrom stats setNames

R/translation-available.R

@@ -0,0 +1,173 @@
+#' Check whether translations are available for all values in a vector/column
+#'
+#' @description
+#' `translation_available_for` checks if the values in a vector or
+#'  column to see which have translations available in the
+#'  translation table.
+#'
+#' `num_translation_available` returns the number of values
+#'  that have translations available, from zero to
+#'  length(unique(vector)).
+#'
+#' `all_translation_available_for` checks if all values in the vector
+#' have translations available in the translation table.
+#'
+#' `which_translation_unavailable_for` returns a vector with the values
+#'  that do not have translations available in the translation table.
+#'
+#' @param dataframe A vector or dataframe to be checked. If a dataframe,
+#'   it should contain the variable specified in `variable`.
+#' @param variable_name The name of the variable to be checked, as a string.
+#' @param translation_table A translation table, by default
+#'   this is the active translation table.
+#' @param dest_lang The destination language code, by default
+#'  this is the current source language, set by set_dest_lang().
+#' @param source_lang The source language code, by default
+#'  this is the current source language, set by set_source_lang().
+#' @param verbose If TRUE, prints messages about the process.
+#'
+#' @returns A list of values with available translation
+#'
+#' @export
+translation_available_for <- function(dataframe, variable_name,
+                                      translation_table = tcats$translation_table,
+                                      dest_lang = tcats$dest_lang,
+                                      source_lang = tcats$source_lang,
+                                      verbose = FALSE){
+  if (!is.character(variable_name) || length(variable_name) != 1) {
+    stop("The variable name must be a single string.")
+  }
+  if (is.data.frame(dataframe)) {
+    vector <- dataframe[[variable_name]]
+  } else {
+    vector <- dataframe
+  }
+  if (!(variable_name %in% names(translation_table))) {
+    if (verbose) message("Variable not found in translation table.")
+    return(NULL)
+  }
+  var_trans_table <- purrr::pluck(translation_table, variable_name)
+  if (!(source_lang %in% names(var_trans_table))){
+    if (verbose) message("Source language not found in translation table.")
+    return(NULL)
+  }
+  if (!(dest_lang %in% names(var_trans_table))){
+    if (verbose) message("Destination language not found in translation table.")
+    return(NULL)
+  }
+  # Check if all values in the vector have a translation
+  if (is.null(vector) || length(vector) == 0) {
+    warning("No values to check for translation.")
+    return(NULL)
+  }
+  unique_values <- unique(vector)
+  intersect(unique_values, purrr::pluck(var_trans_table, source_lang))
+}
+
+#' @rdname translation_available_for
+num_translation_available <- function(dataframe, variable_name,
+                                      translation_table = tcats$translation_table,
+                                      dest_lang = tcats$dest_lang,
+                                      source_lang = tcats$source_lang,
+                                      verbose = FALSE){
+  translation_available_for(dataframe, variable_name,
+                            translation_table = translation_table,
+                            dest_lang = dest_lang,
+                            source_lang = source_lang,
+                            verbose = verbose) %>%
+    length()
+}
+
+#' @rdname translation_available_for
+all_translation_available_for <- function(dataframe, variable_name,
+                                      translation_table = tcats$translation_table,
+                                      dest_lang = tcats$dest_lang,
+                                      source_lang = tcats$source_lang,
+                                      verbose = FALSE) {
+  available_values <- translation_available_for(dataframe, variable_name,
+                                                translation_table = translation_table,
+                                                dest_lang = dest_lang,
+                                                source_lang = source_lang,
+                                                verbose = verbose)
+  unique_values <- unique(dataframe[[variable_name]])
+  all(unique_values %in% translation_available_for(dataframe, variable_name,
+                                                   translation_table = translation_table,
+                                                   dest_lang = dest_lang,
+                                                   source_lang = source_lang))
+}
+
+#' @rdname translation_available_for
+which_translation_unavailable_for <- function(dataframe, variable_name,
+                                          translation_table = tcats$translation_table,
+                                          dest_lang = tcats$dest_lang,
+                                          source_lang = tcats$source_lang,
+                                          verbose = FALSE) {
+  unique_values <- unique(dataframe[[variable_name]])
+  available_values <- translation_available_for(dataframe, variable_name,
+                                                translation_table = translation_table,
+                                                dest_lang = dest_lang,
+                                                source_lang = source_lang,
+                                                verbose = verbose)
+  unavailable_values <- setdiff(unique_values, available_values)
+  return(unavailable_values)
+}
+
+#' Show values with available translations
+#'
+#' @description
+#' `which_translation_available` returns the values for which
+#'  there is an available translation in the translation table.
+#'
+#'  Note that unlike functions like `translation_available_for`,
+#'  `which_translation_available` does not check the values
+#'  within a dataframe or vector, but looks directly at the
+#'  translation table and returns all possible values that
+#'  can be translated.
+#'
+#' @param variable_name The name of the variable to be checked,
+#'  as a string.
+#' @param translation_table A translation table, by default
+#'   this is the active translation table.
+#' @param dest_lang The destination language code, by default
+#'  this is the current source language, set by set_dest_lang().
+#' @param source_lang The source language code, by default
+#'  this is the current source language, set by set_source_lang().
+#' @param verbose If TRUE, prints messages about the process.
+#'
+#' @returns A character vector with the values that have translations
+#'  available.
+#'
+#' @export
+which_translation_available <-  function(variable_name,
+                                         translation_table = tcats$translation_table,
+                                         dest_lang = tcats$dest_lang,
+                                         source_lang = tcats$source_lang,
+                                         verbose = FALSE) {
+  if (!is.character(variable_name) || length(variable_name) != 1) {
+    stop("The variable name must be a single string.")
+  }
+  if (!(variable_name %in% names(translation_table))) {
+    if (verbose) message("Variable not found in translation table.")
+    return(NULL)
+  }
+
+  var_trans_table <- purrr::pluck(translation_table, variable_name)
+  var_trans_table <- var_trans_table [ , names(var_trans_table) %in%
+                                         c(source_lang, dest_lang)]
+
+  if (!(source_lang %in% names(var_trans_table))){
+    if (verbose) message("Source language not found in translation table.")
+    return(NULL)
+  }
+  if (!(dest_lang %in% names(var_trans_table))){
+    if (verbose) message("Destination language not found in translation table.")
+    return(NULL)
+  }
+  # Get the values that have translations available
+  filtered_var_trans_table <- var_trans_table[
+    var_trans_table[[1]] != "" & !is.na(var_trans_table[[1]]) &
+    var_trans_table[[2]] != "" & !is.na(var_trans_table[[2]]), ]
+  filtered_var_trans_table[[1]] %>%
+    unique() %>%
+    sort()
+}

R/translation-functions.R

@@ -14,6 +14,22 @@ set_active_translation_table <- function(transtable) {
   invisible(old)
 }
 
+#' Get list of variables in the active translation table
+#'
+#' Returns a list of variables in the active translation table.
+#'
+#' @returns A character vector with the names of the variables in the
+#' active translation table.
+#'
+#' @export
+#'
+#' @examples
+#' set_active_translation_table(uc_translation)
+#' get_translation_variables()
+get_translation_variables <- function() {
+  names(tcats$translation_table)
+}
+
 #' Translated Join
 #'
 #' Adds one column (`translated_join`) or several columns (`translated_join_vars`)
@@ -66,8 +82,6 @@ translated_join <- function(dataframe, variable,
   return(dataframe)
 }
 
-
-
 #' @rdname translated_join
 #'
 #' @export
@@ -78,7 +92,3 @@ translated_join_vars <- function(dataframe, variables=c(""), ...){
     }
   return(dataframe)
 }
-
-
-
-

data-raw/gss_translation.R

@@ -0,0 +1,6 @@
+gss_translation_combined <-
+       readr::read_csv("inst/extdata/gss_cat_transtable_complete.csv")
+gss_translation <-
+  transcats::parse_combined_translation_table(gss_translation_combined)
+
+usethis::use_data(gss_translation, overwrite = TRUE)