Fix: remove epitrix dependency and add clean_label function

DESCRIPTION

@@ -45,7 +45,6 @@ RoxygenNote: 7.3.2
 Imports: 
     config,
     dplyr,
-    epitrix,
     ggplot2,
     httr2,
     kableExtra,
@@ -54,6 +53,7 @@ Imports:
     sf,
     showtext,
     stats,
+    stringi,
     stringr,
     sysfonts,
     tools,

R/checking_data.R

@@ -1005,18 +1005,16 @@ calcular_incidencia <- function(data_incidencia = NULL,
     } else if (is.null(sex)) {
       data_agrupada <- data_agrupada[data_agrupada[[nomb_cols[1]]] == dpto, ]
     }
-  } else {
-    if (poblacion == "proyecciones") {
+  } else if (poblacion == "proyecciones") {
       poblacion_incidencia <-
         dplyr::filter(
           data_incidencia,
           .data$area_geografica == "Total",
           .data$ano == year
         )
-    } else {
-      total_poblacion <-
-        sum(poblacion_incidencia[[paste0("poblacion_riesgo_", year)]])
-    }
+  } else {
+    total_poblacion <-
+      sum(poblacion_incidencia[[paste0("poblacion_riesgo_", year)]])
   }
   if (!is.null(sex)) {
     if (sex == "F") {

R/cleaning_data.R

@@ -45,7 +45,7 @@ estandarizar_geo_cods <- function(data_event) {
       }
     }
   }
-  return(data_event)
+  data_event
 }
 
 #' @title Convertir edad a años
@@ -177,7 +177,7 @@ remove_val_nin <- function(data_event, nomb_col) {
     is.nan(data_event[[nomb_col]]) |
     is.infinite(data_event[[nomb_col]])
   data_event_del <- data_event[!del_rows]
-  return(data_event_del)
+  data_event_del
 }
 
 #' @title Eliminar fechas mayores que el valor de comparación
@@ -256,14 +256,84 @@ format_cod_geo <- function(cod_geo, etiqueta, digitos, tam) {
     if (nchar(cod_geo) > tam) {
       stop(
         "El codigo del ", etiqueta,
-        " debe tener maximo ", tam, " digitos"
+        " debe tener maximo ", tam, " digitos",
+        call. = FALSE
       )
     }
     if (nchar(cod_format) == tam - 1) {
       cod_format <- paste0("0", cod_format)
     }
   }
-  return(cod_format)
+  cod_format
+}
+
+#' Estandarizar etiquetas
+#' @description
+#' Código tomado de la función `epitrix::clean_labels()`.
+#' La función `clean_labels()` de \pkg{epitrix} se reutiliza con
+#' permiso y está lincenciada bajo MIT al igual que \pkg{epitrix}.
+#' \pkg{epitrix} está en CRAN.
+#' @param x Un vector de etiquetas, normalmente proporcionado como caracteres.
+#' @param sep Una cadena de caracteres utilizada como separador, con un valor
+#' predeterminado de '_'.
+#' @param transformation Una cadena que se pasa a
+#' `stringi::stri_trans_general()` para la conversión. Por defecto es
+#' "Any-Latin; Latin-ASCII", lo que convierte cualquier carácter no latino a
+#' caracteres latinos y luego convierte todos los caracteres acentuados a
+#' caracteres ASCII. Consulta `stringi::stri_trans_list()` para una lista
+#' completa de opciones.
+#' @param protect Una cadena de caracteres que define la puntuación que se debe
+#' proteger. Esto ayuda a evitar que se eliminen símbolos significativos
+#' como > y <.
+#' @md
+#' @note Debido a diferencias entre el motor de transliteración subyacente
+#' (ICU), las transformaciones predeterminadas no transliterarán correctamente
+#' las diéresis alemanas (umlaute). Puedes agregarlas especificando "de-ASCII"
+#' en la cadena `transformation` después de "Any-Latin".
+#' @examples
+#' \dontrun{
+#' clean_labels("-_-Esto es; Una    Fräse**./extraña...")
+#' clean_labels("-_-Esto es; Una    Fräse**./extraña...", sep = ".")
+#' input <- c("Pedro y stëven",
+#'            "pedro-y.stëven",
+#'            "pëtêr y stëven  _-")
+#' clean_labels(input)
+#' # No transliterar palabras no latinas
+#' clean_labels(input, transformation = "Latin-ASCII")
+#' # proteger símbolos útiles
+#' clean_labels(c("energía > 9000", "energía < 9000"), protect = "><")
+#' # si solo deseas limpiar acentos, transformar a minúsculas y transliterar,
+#' # puedes especificar "[:punct:][:space:]" para protect:
+#' clean_labels(input, protect = "[:punct:][:space:]")
+#'}
+#' @note El código original fue escrito por los autores de \pkg{epitrix}.
+#' Consulta \url{https://CRAN.R-project.org/package=epitrix} para más detalles.
+#' @noRd
+clean_labels <- function(x, sep = "_",
+                         transformation = "Any-Latin; Latin-ASCII",
+                         protect = "") {
+  x <- as.character(x)
+  ## Sobre el procesamiento de la entrada:
+  ## - conversión a minúsculas
+  ## - reemplazo de caracteres acentuados por sus equivalentes más cercanos
+  ## - reemplazo de signos de puntuación y espacios que no estén en la lista
+  ##   protegida con sep de forma cuidadosa
+  ## - eliminación de separadores al inicio y al final
+  sep <- gsub("([.*?])", "\\\\\\1", sep)
+  out <- tolower(x)
+  out <- stringi::stri_trans_general(out, id = transformation)
+  # Búsqueda anticipada negativa para caracteres alfanuméricos y cualquier
+  # símbolo protegido
+  to_protect <- sprintf("(?![a-z0-9%s])", paste(protect, collapse = ""))
+  # Si la búsqueda anticipada negativa no encuentra lo que está buscando,
+  # entonces realiza el reemplazo.
+  to_replace <- sprintf("%s[[:punct:][:space:]]+?", to_protect)
+  # Función principal
+  out <- gsub(to_replace, sep, out, perl = TRUE)
+  out <- gsub(paste0("(", sep, ")+"), sep, out, perl = TRUE)
+  out <- sub(paste0("^", sep), "", out, perl = TRUE)
+  out <- sub(paste0(sep, "$"), "", out, perl = TRUE)
+  return(out)
 }
 
 #' @title Limpiar las etiquetas del encabezado
@@ -279,8 +349,8 @@ format_cod_geo <- function(cod_geo, etiqueta, digitos, tam) {
 #' @export
 limpiar_encabezado <- function(data_event) {
   validar_data_event(data_event)
-  names(data_event) <- epitrix::clean_labels(names(data_event))
-  return(data_event)
+  names(data_event) <- clean_labels(names(data_event))
+  data_event
 }
 
 #' @title Limpiar fechas de los datos de una enfermedad o evento

R/import_data.R

@@ -13,35 +13,39 @@
 #' @noRd
 realizar_peticion_http <- function(url) {
   request_timeout <- obtener_val_config("request_timeout")
-  return(tryCatch(
+  tryCatch(
     httr2::req_perform(
       httr2::req_timeout(httr2::request(url),
                          request_timeout)),
     httr2_failure = function(e) {
       stop(
-        "No se pudo conectar al servidor de SIVIGILA para descargar los datos")
+        "No se pudo conectar al servidor de SIVIGILA para descargar los datos",
+        call. = FALSE)
     },
     httr2_error = function(e) {
       stop(
-        "Error al conectarse al servidor de SIVIGILA para descargar los datos")
+        "Error al conectarse al servidor de SIVIGILA para descargar los datos",
+        call. = FALSE)
     },
     httr2_http_404 = function(e) {
       stop(
-        "El dato no existe en los servidores de SIVIGILA")
+        "El dato no existe en los servidores de SIVIGILA", call. = FALSE)
     },
     httr2_http = function(e) {
       stop(
-        "Error al conectarse al servidor de SIVIGILA para descargar los datos")
+        "Error al conectarse al servidor de SIVIGILA para descargar los datos",
+        call. = FALSE)
     },
     error = function(e) {
       if (grepl("Timeout", e$message, fixed = TRUE)) {
        stop(
-        "No se pudo conectar al servidor de SIVIGILA para descargar los datos")
+        "No se pudo conectar al servidor de SIVIGILA para descargar los datos",
+        call. = FALSE)
       } else {
-        stop("Ha ocurrido un error inesperado ", parent = e)
+        stop("Ha ocurrido un error inesperado", parent = e, call. = FALSE)
       }
     }
-  ))
+  )
 }
 
 #' @title Importar datos geográficos de Colombia
@@ -63,7 +67,7 @@ import_geo_cods <- function(descargar = FALSE) {
   if (descargar) {
     ruta_data <- obtener_val_config("geo_data_path")
     data_geo <- utils::read.csv(ruta_data)
-    names(data_geo) <- epitrix::clean_labels(names(data_geo))
+    names(data_geo) <- clean_labels(names(data_geo))
   } else {
     ruta_extdata <- system.file("extdata", package = "sivirep")
     ruta_data <- obtener_val_config("divipola_data_path")
@@ -142,7 +146,7 @@ list_events <- function() {
                             aa = years_events)
   list_events <- list_events[order(list_events$enfermedad,
                                    decreasing = FALSE), ]
-  return(list_events)
+  list_events
 }
 
 #' @title Importar los datos de una enfermedad o evento por año
@@ -263,7 +267,8 @@ import_sep_data <- function(ruta_data = NULL,
     obtener_ruta_dir(ruta_dir = ruta_dir, cache = cache,
                      mensaje_error = "los datos de la enfermedad o evento")
   if (!dir.exists(ruta_dir)) {
-    stop("La ruta ingresada en el parametro ruta_dir no existe")
+    stop("La ruta ingresada en el parametro ruta_dir no existe",
+         call. = FALSE)
   }
   if (!is.null(ruta_data)) {
     ini_nomb_archivo <-
@@ -468,10 +473,12 @@ import_pob_riesgo <- function(event, year,
     warning("Para el ", year, " la poblacion a riesgo no esta disponible.",
             " Los ", etiqueta_year, " disponibles para la enfermedad o ",
             "evento son: ",
-            toString(years_disponibles))
+            toString(years_disponibles),
+            call. = FALSE)
   } else {
     warning("Para ", event, " no hay poblacion a riesgo disponible de ",
-            "ningun year")
+            "ningun year",
+            call. = FALSE)
   }
   return(pob_riesgo_event)
 }
@@ -501,10 +508,10 @@ import_shape_map <- function(ruta_dir = NULL,
   carpeta_base <- obtener_val_config("map_shape_folder")
   ruta_shape <- file.path(ruta_dir, carpeta_base,
                           obtener_val_config("map_shape_file"))
-  if (file.exists(ruta_shape)) {
-    shp <- sf::st_read(dsn = ruta_shape, quiet = TRUE)
-  } else {
-    stop("No es posible obtener el Shapefile del mapa")
+  if (!file.exists(ruta_shape)) {
+    stop("No es posible obtener el Shapefile del mapa",
+         call. = FALSE)
   }
+  shp <- sf::st_read(dsn = ruta_shape, quiet = TRUE)
   return(shp)
 }

R/scraping_data.R

@@ -53,5 +53,5 @@ obtener_ruta_data_event_year <- function(nombre_event, year) {
     ruta_base,
     ruta_archivo, ruta_archivo_params
   )
-  return(ruta_descarga_archivo)
+  ruta_descarga_archivo
 }

R/theme_sivirep.R

@@ -24,7 +24,7 @@ tema_sivirep <- function() {
       plot.subtitle = ggplot2::element_text(face = "bold",
                                             hjust = 0.5)
     )
-  return(tema)
+  tema
 }
 
 #' @title Obtener la estética de una escala para un gráfico de \pkg{sivirep}