Merge branch 'main' of https://github.com/drdsdaniel/Dmisc

dnldelarosa · Mar 21, 2024 · 2fe2940 · 2fe2940
2 parents b093886 + 951df40
commit 2fe2940
Show file tree

Hide file tree

Showing 11 changed files with 151 additions and 14 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: Dmisc
 Title: Daniel miscellaneous functions
-Version: 0.3.5
+Version: 0.3.10
 Authors@R: 
     person(given = "Daniel E.",
            family = "de la Rosa",
@@ -25,11 +25,11 @@ Imports:
     odbc,
     rlang,
     stringr,
-    tidyr
+    tidyr,
 Suggests: 
-    cli, 
+    cli,
     DBI,
-    DT, 
+    DT,
     flextable,
     forecast,
     ggcorrplot,
@@ -38,10 +38,10 @@ Suggests:
     janitor,
     keyring,
     knitr,
-    lmtest ,
+    lmtest,
     lubridate,
     patchwork,
-    pins ,
+    pins,
     purrr,
     renv,
     RPostgres,
@@ -56,5 +56,6 @@ Suggests:
     tseries,
     vars,
     withr,
-    xts ,
+    xts,
+    yardstick,
     zoo
diff --git a/NAMESPACE b/NAMESPACE
@@ -1,15 +1,19 @@
 # Generated by roxygen2: do not edit by hand
 
+export("%...>%")
+export("%<...%")
 export("%>%")
 export("%T>%")
 export(":=")
 export(cut3)
 export(cut3_quantile)
 export(describe)
+export(instalar_paquete_si_falta)
 export(vars_to_date)
 importFrom(lifecycle,deprecate_soft)
 importFrom(lifecycle,deprecate_warn)
 importFrom(lifecycle,deprecated)
 importFrom(magrittr,"%>%")
 importFrom(magrittr,"%T>%")
 importFrom(rlang,":=")
+importFrom(utils,install.packages)
diff --git a/R/evaluate_arima.R b/R/evaluate_arima.R
@@ -73,6 +73,8 @@ evaluate_arima <- function(
   if (.train_stats) {
     result[["model-summary"]] <- summary(model)
 
+    # instalar_paquete_si_falta("yardstick")
+    rlang::check_installed("yardstick")
     for (m in .metrics) {
       metric_func <- utils::getFromNamespace(paste0(m, "_vec"), "yardstick")
       if (!is.function(metric_func)) {
@@ -86,6 +88,8 @@ evaluate_arima <- function(
     note2 <- NULL
     result[["training_metrics"]] <- as.matrix(metric)
     if (.resid_tests) {
+      # instalar_paquete_si_falta("patchwork")
+      rlang::check_installed("patchwork")
       if (!"package:patchwork" %in% search()) {
         requireNamespace('patchwork')
       }
@@ -178,6 +182,8 @@ evaluate_arima <- function(
     )
 
     metric <- c()
+    # instalar_paquete_si_falta("yardstick")
+    rlang::check_installed("yardstick")
     for (m in .metrics) {
       metric_func <- utils::getFromNamespace(paste0(m, "_vec"), "yardstick")
       if (!is.function(metric_func)) {

diff --git a/R/evaluate_lm.R b/R/evaluate_lm.R
@@ -83,6 +83,8 @@ evaluate_lm <- function(model, valid = NULL, test = NULL, .undiff = NULL, .train
   if (.train_stats) {
     result[["model-summary"]] <- summary(model)
 
+    # instalar_paquete_si_falta("yardstick")
+    rlang::check_installed("yardstick")
     for (m in .metrics) {
       metric_func <- utils::getFromNamespace(paste0(m, "_vec"), "yardstick")
       if (!is.function(metric_func)) {
@@ -95,6 +97,8 @@ evaluate_lm <- function(model, valid = NULL, test = NULL, .undiff = NULL, .train
     note2 <- NULL
     result[["correlations"]] <- ggcorrplot::ggcorrplot(stats::cor(model$model), type = "lower", lab = TRUE)
     if (.resid_tests) {
+      # instalar_paquete_si_falta("patchwork")
+      rlang::check_installed("patchwork")
       if (!"package:patchwork" %in% search()) {
         requireNamespace('patchwork')
       }
@@ -208,6 +212,8 @@ evaluate_lm <- function(model, valid = NULL, test = NULL, .undiff = NULL, .train
       fcs
     )
 
+    # instalar_paquete_si_falta("yardstick")
+    rlang::check_installed("yardstick")
     metric <- c()
     for (m in .metrics) {
       metric_func <- utils::getFromNamespace(paste0(m, "_vec"), "yardstick")

diff --git a/R/evaluate_var.R b/R/evaluate_var.R
@@ -138,6 +138,8 @@ evaluate_var <- function(model, valid = NULL, test = NULL, xreg = NULL, .undiff
       result[["model-summary"]] <- summary(model)
     }
 
+    # instalar_paquete_si_falta("yardstick")
+    rlang::check_installed("yardstick")
     for (m in .metrics) {
       metric_func <- utils::getFromNamespace(paste0(m, "_vec"), "yardstick")
       if (!is.function(metric_func)) {
@@ -155,6 +157,8 @@ evaluate_var <- function(model, valid = NULL, test = NULL, xreg = NULL, .undiff
     note1 <- "The training metrics are different from those in the model summary because the indicated transformations were applied to the former, while not to the summary ones."
     note2 <- NULL
     if (.resid_tests) {
+      # instalar_paquete_si_falta("patchwork")
+      rlang::check_installed("patchwork")
       if (!"package:patchwork" %in% search()) {
         requireNamespace('patchwork')
       }
@@ -245,6 +249,8 @@ evaluate_var <- function(model, valid = NULL, test = NULL, xreg = NULL, .undiff
     }
     estimate <- dplyr::bind_rows(fitted, fcs)
 
+    # instalar_paquete_si_falta("yardstick")
+    rlang::check_installed("yardstick")
     metric <- list()
     for (m in .metrics) {
       metric_func <- utils::getFromNamespace(paste0(m, "_vec"), "yardstick")

diff --git a/R/pins.R b/R/pins.R
@@ -40,7 +40,7 @@ pin_get_or_create <- function(.data, .board, .name, type = 'csv', ...) {
     }
   }
   if (is.null(.version)) {
-    pins::pin_write(.board, .data, .name, type, ...)
+    pins::pin_write(.board, .data, .name, type = type, ...)
     .versions <- pins::pin_versions(.board, .name)
     .version <- .versions %>%
       dplyr::arrange(created) %>%

diff --git a/R/scaler.R b/R/scaler.R
@@ -9,17 +9,32 @@ revert_scale <- function(scaled_data, center = NULL, scale = NULL) {
 }
 
 
+ts_revert_scale <- function(ts, center = NULL, scale = NULL) {
+  if('mts' %in% class(ts)){
+    stop("Not implemented for mts.")
+  }
+  .res <- revert_scale(ts, center, scale)
+  attr(.res, 'scaled:center') <- NULL
+  attr(.res, 'scaled:scale') <- NULL
+  .res
+}
+
+
 
 ts_scale <- function(ts, center = TRUE, scale = TRUE) {
   if('mts' %in% class(ts)){
     stop("Not implemented for mts.")
   }
-  ts(
-    scale(ts, center, scale),
+  scaled <- scale(ts, center, scale)
+  .res <- ts(
+    scaled,
     start = stats::start(ts),
     end = stats::end(ts),
     frequency = stats::frequency(ts)
   )
+  attr(.res, 'scaled:center') <- attr(scaled, 'scaled:center')
+  attr(.res, 'scaled:scale') <- attr(scaled, 'scaled:scale')
+  .res
 }
 
 scale2 <- function(data, scaled){

diff --git a/R/unpack_assign.R b/R/unpack_assign.R
@@ -12,6 +12,7 @@
 #'
 #' @return NULL. The function performs assignments in the specified environment.
 #'
+#' @export
 #'
 #' @rdname unpkg-assign
 #'
@@ -21,18 +22,22 @@
 #' }
 `%<...%` <- function(names, values) {
   # Collect additional arguments
+  .envir <- .GlobalEnv
   tryCatch({
     .envir <- names[['.envir']]
     names[['.envir']] <- NULL
   }, error = function(x){
-    .envir <- .GlobalEnv
+    #cli::cli_warn("The '.envir' argument must be a valid environment. ",
+    #             "The global environment will be used by default.")
   })
 
+  .warn <- TRUE
   tryCatch({
     .warn <- names[['.warn']]
     .warn <- NULL
   }, error = function(x){
-    .warn <- TRUE
+    #cli::cli_warn("The '.warn' argument must be a logical value. ",
+    #             "A warning will be issued by default.")
   })
 
   # Issue a warning if '.warn' is TRUE
@@ -69,8 +74,21 @@
 
 
 
-# @rdname unpkg-assign
-# @order 2
+
+#' Assign values to specified names in an environment and unpack the values (reverse of `%<...%`)
+#'
+#' @param values A list or vector containing the values to be assigned to the names.
+#' @param names A list or character vector specifying the names of variables to be assigned.
+#'
+#' @return NULL. The function performs assignments in the specified environment.
+#' @export
+#' 
+#' @rdname unpkg-right-assign
+#'
+#' @examples
+#' \dontrun{
+#' list(1, 2) %...>% c("x", "y")
+#' }
 `%...>%` <- function(values, names) {
   `%<...%`(names, values)
 }
diff --git a/R/utils.R b/R/utils.R
@@ -0,0 +1,31 @@
+#' Instalar un paquete si no esta presente
+#'
+#' Esta función verifica si un paquete de R esta instalado. Si no lo esta,
+#' pregunta al usuario si desea instalarlo. Si el usuario responde afirmativamente,
+#' instala el paquete. Si el usuario responde negativamente, la función se detiene
+#' y muestra un mensaje indicando que el paquete es necesario.
+#'
+#' @param nombre_del_paquete El nombre del paquete que se quiere verificar e instalar.
+#' 
+#' @return Invisible NULL. La función se utiliza principalmente por sus efectos
+#'   secundarios (instalación de paquetes), y no devuelve ningún valor.
+#' @export
+#' 
+#' @importFrom utils install.packages
+#' 
+#' @examples
+#' \dontrun{
+#'  instalar_paquete_si_falta("dplyr")
+#' }
+instalar_paquete_si_falta <- function(nombre_del_paquete) {
+  if (!requireNamespace(nombre_del_paquete, quietly = TRUE)) {
+    mensaje <- paste("El paquete", nombre_del_paquete, "no esta instalado. Desea instalarlo ahora? (y/n)")
+    respuesta <- readline(prompt = mensaje)
+
+    if (tolower(respuesta) == "y") {
+      install.packages(nombre_del_paquete)
+    } else {
+      stop(paste("El paquete", nombre_del_paquete, "es necesario y no esta instalado."))
+    }
+  }
+}
diff --git a/man/instalar_paquete_si_falta.Rd b/man/instalar_paquete_si_falta.Rd
diff --git a/man/unpkg-right-assign.Rd b/man/unpkg-right-assign.Rd