Merge branch 'main' into allocation_range

Author: laresbernardo

R/NAMESPACE

@@ -1,11 +1,13 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(plot,robyn_allocator)
+S3method(plot,robyn_save)
 S3method(print,robyn_allocator)
 S3method(print,robyn_inputs)
 S3method(print,robyn_models)
 S3method(print,robyn_outputs)
 S3method(print,robyn_refresh)
+S3method(print,robyn_save)
 export(adstock_geometric)
 export(adstock_weibull)
 export(hyper_limits)

R/R/clusters.R

@@ -112,7 +112,7 @@ robyn_clusters <- function(input, all_media = NULL, k = "auto", limit = 1,
   if (export) {
     fwrite(output$data, file = paste0(path, "pareto_clusters.csv"))
     ggsave(paste0(path, "pareto_clusters_wss.png"), plot = output$wss, dpi = 500, width = 5, height = 4)
-    ggsave(paste0(path, "pareto_clusters_corr.png"), plot = output$corrs, dpi = 500, width = 7, height = 5)
+    # ggsave(paste0(path, "pareto_clusters_corr.png"), plot = output$corrs, dpi = 500, width = 7, height = 5)
     db <- wrap_plots(output$plot_models_rois, output$plot_models_errors)
     ggsave(paste0(path, "pareto_clusters_detail.png"), plot = db, dpi = 600, width = 12, height = 9)
   }
@@ -121,6 +121,28 @@ robyn_clusters <- function(input, all_media = NULL, k = "auto", limit = 1,
 
 }
 
+# # Mean Media ROI by Cluster
+# df %>%
+#   mutate(cluster = sprintf("Cluster %s", cls$df$cluster)) %>%
+#   select(-.data$mape, -.data$decomp.rssd, -.data$nrmse, -.data$solID) %>%
+#   group_by(.data$cluster) %>%
+#   summarize_all(list(mean)) %>%
+#   tidyr::pivot_longer(-one_of("cluster"), names_to = "media", values_to = "meanROI") %>%
+#   ggplot(aes(y = reorder(.data$media, .data$meanROI), x = .data$meanROI)) +
+#   facet_grid(.data$cluster~.) +
+#   geom_col() + theme_lares() +
+#   labs(title = "Mean Media ROI by Cluster",
+#        x = "(Un-normalized) mean ROI within clsuter", y = NULL)
+# df %>%
+#   mutate(cluster = sprintf("Cluster %s", cls$df$cluster)) %>%
+#   select(-.data$solID, -.data$mape, -.data$decomp.rssd, -.data$nrmse) %>%
+#   tidyr::pivot_longer(-one_of("cluster"), names_to = "media", values_to = "roi") %>%
+#   ggplot(aes(y = reorder(.data$media, .data$roi), x = .data$roi)) +
+#   facet_grid(.data$cluster~.) +
+#   geom_boxplot() + theme_lares() +
+#   labs(title = "Media ROI by Cluster",
+#        x = "(Un-normalized) ROI", y = NULL)
+
 # ROIs data.frame for clustering (from xDecompAgg or pareto_aggregated.csv)
 .prepare_roi <- function(x, all_media) {
   check_opts(all_media, unique(x$rn))
@@ -171,7 +193,7 @@ robyn_clusters <- function(input, all_media = NULL, k = "auto", limit = 1,
   balance <- balance / sum(balance)
   left_join(df, select(top_sols, 1:3), "solID") %>%
     mutate(
-      alpha = ifelse(is.na(.data$cluster), 0.5, 1),
+      alpha = ifelse(is.na(.data$cluster), 0.6, 1),
       label = ifelse(!is.na(.data$cluster), sprintf(
         "[%s.%s]", .data$cluster, .data$rank
       ), NA)

R/R/inputs.R

@@ -287,7 +287,7 @@ robyn_inputs <- function(dt_input = NULL,
       adstock = adstock,
       hyperparameters = hyperparameters,
       calibration_input = calibration_input,
-      ...
+      custom_params = list(...)
     )
 
     if (!is.null(hyperparameters)) {
@@ -323,7 +323,6 @@ robyn_inputs <- function(dt_input = NULL,
       output <- robyn_engineering(InputCollect, ...)
     }
   }
-  output$custom_params <- list(...)
   class(output) <- c("robyn_inputs", class(output))
   return(output)
 }
@@ -626,10 +625,9 @@ robyn_engineering <- function(x, ...) {
   #### Obtain prophet trend, seasonality and change-points
 
   if (!is.null(InputCollect$prophet_vars) && length(InputCollect$prophet_vars) > 0) {
-    custom_params <- list(...) # custom_params <- list()
     if (length(InputCollect[["custom_params"]]) > 0) {
       custom_params <- InputCollect[["custom_params"]]
-    }
+    } else custom_params <- list(...) # custom_params <- list()
     robyn_args <- setdiff(
       unique(c(names(as.list(args(robyn_run))),
                names(as.list(args(robyn_outputs))),
@@ -638,7 +636,7 @@ robyn_engineering <- function(x, ...) {
       c("", "..."))
     prophet_custom_args <- setdiff(names(custom_params), robyn_args)
     if (length(prophet_custom_args)>0)
-      message(paste("Using custom prophet parameters:", paste(names(prophet_custom_args), collapse = ", ")))
+      message(paste("Using custom prophet parameters:", paste(prophet_custom_args, collapse = ", ")))
     dt_transform <- prophet_decomp(
       dt_transform,
       dt_holidays = InputCollect$dt_holidays,
@@ -865,7 +863,7 @@ set_holidays <- function(dt_transform, dt_holidays, intervalType) {
   if (intervalType == "week") {
     weekStartInput <- lubridate::wday(dt_transform$ds[1], week_start = 1)
     if (!weekStartInput %in% c(1, 7)) stop("Week start has to be Monday or Sunday")
-    dt_holidays$dsWeekStart <- floor_date(dt_holidays$ds, unit = "week", week_start = 1)
+    dt_holidays$dsWeekStart <- floor_date(dt_holidays$ds, unit = "week", week_start = weekStartInput)
     holidays <- dt_holidays[, .(ds = dsWeekStart, holiday, country, year)]
     holidays <- holidays[, lapply(.SD, paste0, collapse = "#"), by = c("ds", "country", "year"), .SDcols = "holiday"]
   }

R/R/model.R

@@ -512,11 +512,11 @@ robyn_mmm <- function(InputCollect,
             } else if (adstock == "weibull_cdf") {
               shape <- hypParamSam[paste0(all_media[v], "_shapes")]
               scale <- hypParamSam[paste0(all_media[v], "_scales")]
-              x_list <- adstock_weibull(x = m, shape = shape, scale = scale, windlen = rollingWindowLength, type = "cdf")
+              x_list <- adstock_weibull(x = m, shape = shape, scale = scale, type = "cdf")
             } else if (adstock == "weibull_pdf") {
               shape <- hypParamSam[paste0(all_media[v], "_shapes")]
               scale <- hypParamSam[paste0(all_media[v], "_scales")]
-              x_list <- adstock_weibull(x = m, shape = shape, scale = scale, windlen = rollingWindowLength, type = "pdf")
+              x_list <- adstock_weibull(x = m, shape = shape, scale = scale, type = "pdf")
             }
             m_adstocked <- x_list$x_decayed
             mediaAdstocked[[v]] <- m_adstocked
@@ -1075,11 +1075,11 @@ robyn_response <- function(robyn_object = NULL,
   } else if (adstock == "weibull_cdf") {
     shape <- dt_hyppar[solID == select_model, get(paste0(hpm_name, "_shapes"))]
     scale <- dt_hyppar[solID == select_model, get(paste0(hpm_name, "_scales"))]
-    x_list <- adstock_weibull(x = media_vec, shape = shape, scale = scale, windlen = InputCollect$rollingWindowLength, type = "cdf")
+    x_list <- adstock_weibull(x = media_vec, shape = shape, scale = scale, type = "cdf")
   } else if (adstock == "weibull_pdf") {
     shape <- dt_hyppar[solID == select_model, get(paste0(hpm_name, "_shapes"))]
     scale <- dt_hyppar[solID == select_model, get(paste0(hpm_name, "_scales"))]
-    x_list <- adstock_weibull(x = media_vec, shape = shape, scale = scale, windlen = InputCollect$rollingWindowLength, type = "pdf")
+    x_list <- adstock_weibull(x = media_vec, shape = shape, scale = scale, type = "pdf")
   }
   m_adstocked <- x_list$x_decayed
 

R/R/pareto.R

@@ -189,11 +189,11 @@ robyn_pareto <- function(InputCollect, OutputModels, pareto_fronts, calibration_
         } else if (InputCollect$adstock == "weibull_cdf") {
           shape <- hypParam[paste0(InputCollect$all_media[med], "_shapes")]
           scale <- hypParam[paste0(InputCollect$all_media[med], "_scales")]
-          x_list <- adstock_weibull(x = m, shape = shape, scale = scale, windlen = InputCollect$rollingWindowLength, type = "cdf")
+          x_list <- adstock_weibull(x = m, shape = shape, scale = scale, type = "cdf")
         } else if (InputCollect$adstock == "weibull_pdf") {
           shape <- hypParam[paste0(InputCollect$all_media[med], "_shapes")]
           scale <- hypParam[paste0(InputCollect$all_media[med], "_scales")]
-          x_list <- adstock_weibull(x = m, shape = shape, scale = scale, windlen = InputCollect$rollingWindowLength, type = "pdf")
+          x_list <- adstock_weibull(x = m, shape = shape, scale = scale, type = "pdf")
         }
         m_adstocked <- x_list$x_decayed
         dt_transformAdstock[, (med_select) := m_adstocked]

R/R/plots.R

@@ -245,13 +245,13 @@ robyn_onepagers <- function(InputCollect, OutputCollect, select_model = NULL, qu
   all_plots <- list()
   cnt <- 0
 
-  for (pf in pareto_fronts_vec) { # pf = 1
+  for (pf in pareto_fronts_vec) { # pf = pareto_fronts_vec[1]
 
     plotMediaShare <- xDecompAgg[robynPareto == pf & rn %in% InputCollect$paid_media_spends]
     uniqueSol <- plotMediaShare[, unique(solID)]
 
     # parallelResult <- for (sid in uniqueSol) { # sid = uniqueSol[1]
-    parallelResult <- foreach(sid = uniqueSol) %dorng% {
+    parallelResult <- foreach(sid = uniqueSol) %dorng% { # sid = uniqueSol[1]
       plotMediaShareLoop <- plotMediaShare[solID == sid]
       rsq_train_plot <- plotMediaShareLoop[, round(unique(rsq_train), 4)]
       nrmse_plot <- plotMediaShareLoop[, round(unique(nrmse), 4)]
@@ -429,6 +429,7 @@ robyn_onepagers <- function(InputCollect, OutputCollect, select_model = NULL, qu
         cnt <- cnt + 1
         setTxtProgressBar(pbplot, cnt)
       }
+      return(all_plots)
     }
     if (!quiet & count_mod_out > 0) {
       cnt <- cnt + length(uniqueSol)
@@ -438,7 +439,7 @@ robyn_onepagers <- function(InputCollect, OutputCollect, select_model = NULL, qu
   if (!quiet & count_mod_out > 0) close(pbplot)
   # Stop cluster to avoid memory leaks
   if (check_parallel_plot()) stopImplicitCluster()
-  return(invisible(all_plots))
+  return(invisible(parallelResult[[1]]))
 }
 
 allocation_plots <- function(InputCollect, OutputCollect, dt_optimOut, select_model, scenario, export = TRUE, quiet = FALSE) {

R/R/refresh.R

@@ -9,7 +9,7 @@
 #' Use \code{robyn_save()} to select and save as .RDS file the initial model.
 #'
 #' @inheritParams robyn_allocator
-#' @return (Invisible) file's name.
+#' @return (Invisible) list with filename and summary.
 #' @examples
 #' \dontrun{
 #' # Get model IDs from OutputCollect
@@ -24,7 +24,11 @@
 #' )
 #' }
 #' @export
-robyn_save <- function(robyn_object, InputCollect, OutputCollect, select_model = NULL) {
+robyn_save <- function(robyn_object,
+                       select_model,
+                       InputCollect,
+                       OutputCollect,
+                       quiet = FALSE) {
   check_robyn_object(robyn_object)
   if (is.null(select_model)) select_model <- OutputCollect[["selectID"]]
   if (!(select_model %in% OutputCollect$resultHypParam$solID)) {
@@ -34,10 +38,23 @@ robyn_save <- function(robyn_object, InputCollect, OutputCollect, select_model =
     )))
   }
 
+  output <- list(
+    robyn_object = robyn_object,
+    select_model = select_model,
+    summary = OutputCollect$xDecompAgg[
+      solID == select_model & !is.na(mean_spend)
+      , .(rn, coef,mean_spend, mean_response, roi_mean
+          , total_spend, total_response = xDecompAgg, roi_total)],
+    plot = robyn_onepagers(InputCollect, OutputCollect, select_model, quiet = TRUE, export = FALSE))
+  class(output) <- c("robyn_save", class(output))
+
   if (file.exists(robyn_object)) {
-    answer <- askYesNo(paste0(robyn_object, " already exists. Are you certain to overwrite it?"))
+    if (!quiet) {
+      answer <- askYesNo(paste0(robyn_object, " already exists. Are you certain to overwrite it?"))
+    } else answer <- TRUE
     if (answer == FALSE | is.na(answer)) {
-      stop("stopped")
+      message("Stopped export to avoid overwriting")
+      return(invisible(output))
     }
   }
 
@@ -50,11 +67,33 @@ robyn_save <- function(robyn_object, InputCollect, OutputCollect, select_model =
   InputCollect$refreshCounter <- 0
   listInit <- list(OutputCollect = OutputCollect, InputCollect = InputCollect)
   Robyn <- list(listInit = listInit)
+
   saveRDS(Robyn, file = robyn_object)
+  if (!quiet) message("Exported results: ", robyn_object)
+  return(invisible(output))
+}
 
-  return(invisible(robyn_object))
+#' @rdname robyn_save
+#' @aliases robyn_save
+#' @param x \code{robyn_save()} output.
+#' @export
+print.robyn_save <- function(x, ...) {
+  print(glued(
+    "
+  Exported file: {x$robyn_object}
+  Exported model: {x$select_model}
+
+  Media Summary for Selected Model:
+  "))
+  print(x$summary)
 }
 
+#' @rdname robyn_save
+#' @aliases robyn_save
+#' @param x \code{robyn_save()} output.
+#' @export
+plot.robyn_save <- function(x, ...) plot(x$plot[[1]], ...)
+
 
 ####################################################################
 #' Build Refresh Model