feat: allocator's new scenario for ROAS target

R/DESCRIPTION

@@ -1,7 +1,7 @@
 Package: Robyn
 Type: Package
 Title: Semi-Automated Marketing Mix Modeling (MMM) from Meta Marketing Science 
-Version: 3.10.0.9000
+Version: 3.10.1.9000
 Authors@R: c(
     person("Gufeng", "Zhou", , "[email protected]", c("aut")),
     person("Leonel", "Sentana", , "[email protected]", c("aut")),

R/R/checks.R

@@ -780,8 +780,6 @@ check_class <- function(x, object) {
 
 check_allocator_constrains <- function(low, upr) {
   max_length <- max(c(length(low), length(upr)))
-  if (length(low) == 1) low <- rep(low, max_length)
-  if (length(upr) == 1) upr <- rep(upr, max_length)
   if (any(low < 0)) {
     stop("Inputs 'channel_constr_low' must be >= 0")
   }
@@ -802,35 +800,30 @@ check_allocator <- function(OutputCollect, select_model, paid_media_spends, scen
       paste(OutputCollect$allSolutions, collapse = ", ")
     )
   }
-  if (any(channel_constr_up > 5)) {
-    warning("Inputs 'channel_constr_up' > 5 might cause unrealistic allocation")
-  }
-  if ("max_response_expected_spend" %in% scenario) {
-    stop(paste(
-      "Scenario 'max_response_expected_spend' has been deprecated.",
-      "Use scenario = 'max_historical_response' and new 'total_budget' parameter instead."
-    ))
-  }
-  opts <- "max_historical_response" # Deprecated: max_response_expected_spend
+  if ("max_historical_response" %in% scenario) scenario <- "max_response"
+  opts <- c("max_response", "target_efficiency") # Deprecated: max_response_expected_spend
   if (!(scenario %in% opts)) {
     stop("Input 'scenario' must be one of: ", paste(opts, collapse = ", "))
   }
-  if (length(channel_constr_low) != 1 && length(channel_constr_low) != length(paid_media_spends)) {
-    stop(paste(
-      "Input 'channel_constr_low' have to contain either only 1",
-      "value or have same length as 'InputCollect$paid_media_spends':", length(paid_media_spends)
-    ))
-  }
-  if (length(channel_constr_up) != 1 && length(channel_constr_up) != length(paid_media_spends)) {
-    stop(paste(
-      "Input 'channel_constr_up' have to contain either only 1",
-      "value or have same length as 'InputCollect$paid_media_spends':", length(paid_media_spends)
-    ))
+  if (!(scenario == "target_efficiency" & is.null(channel_constr_low) & is.null(channel_constr_up))) {
+    if (length(channel_constr_low) != 1 && length(channel_constr_low) != length(paid_media_spends)) {
+      stop(paste(
+        "Input 'channel_constr_low' have to contain either only 1",
+        "value or have same length as 'InputCollect$paid_media_spends':", length(paid_media_spends)
+      ))
+    }
+    if (length(channel_constr_up) != 1 && length(channel_constr_up) != length(paid_media_spends)) {
+      stop(paste(
+        "Input 'channel_constr_up' have to contain either only 1",
+        "value or have same length as 'InputCollect$paid_media_spends':", length(paid_media_spends)
+      ))
+    }
   }
   opts <- c("eq", "ineq")
   if (!(constr_mode %in% opts)) {
     stop("Input 'constr_mode' must be one of: ", paste(opts, collapse = ", "))
   }
+  return(scenario)
 }
 
 check_metric_type <- function(metric_name, paid_media_spends, paid_media_vars, exposure_vars, organic_vars) {

R/R/json.R

@@ -14,6 +14,7 @@
 #' @param select_model Character. Which model ID do you want to export
 #' into the JSON file?
 #' @param dir Character. Existing directory to export JSON file to.
+#' @param all_sol_json Dataframe. Add all pareto solutions to json.
 #' @param ... Additional parameters.
 #' @examples
 #' \dontrun{
@@ -32,7 +33,9 @@ robyn_write <- function(InputCollect,
                         select_model = NULL,
                         dir = OutputCollect$plot_folder,
                         export = TRUE,
-                        quiet = FALSE, ...) {
+                        quiet = FALSE,
+                        all_sol_json = NULL,
+                        ...) {
   # Checks
   stopifnot(inherits(InputCollect, "robyn_inputs"))
   if (!is.null(OutputCollect)) {
@@ -91,6 +94,14 @@ robyn_write <- function(InputCollect,
   attr(ret, "json_file") <- filename
   if (export) {
     if (!quiet) message(sprintf(">> Exported model %s as %s", select_model, filename))
+    if (!is.null(all_sol_json)) {
+      all_c <- unique(all_sol_json$cluster)
+      all_sol_json <- lapply(all_c, function(x) {
+        (all_sol_json %>% filter(.data$cluster == x))$solID
+      })
+      names(all_sol_json) <- paste0("cluster", all_c)
+      ret[["all_sols"]] <- all_sol_json
+    }
     write_json(ret, filename, pretty = TRUE)
   }
   return(invisible(ret))

R/R/outputs.R

@@ -32,6 +32,7 @@
 #' to "all" will output all iterations as csv. Set NULL to skip exports into CSVs.
 #' @param ui Boolean. Save additional outputs for UI usage. List outcome.
 #' @param export Boolean. Export outcomes into local files?
+#' @param all_sol_json Logical. Add all solutions to json export.
 #' @param quiet Boolean. Keep messages off?
 #' @param refresh Boolean. Refresh mode
 #' @param ... Additional parameters passed to \code{robyn_clusters()}
@@ -47,6 +48,7 @@ robyn_outputs <- function(InputCollect, OutputModels,
                           clusters = TRUE,
                           select_model = "clusters",
                           ui = FALSE, export = TRUE,
+                          all_sol_json = FALSE,
                           quiet = FALSE,
                           refresh = FALSE, ...) {
   if (is.null(plot_folder)) plot_folder <- getwd()
@@ -229,7 +231,15 @@ robyn_outputs <- function(InputCollect, OutputModels,
           )
         }
 
-        robyn_write(InputCollect, dir = OutputCollect$plot_folder, quiet = quiet)
+        if (all_sol_json) {
+          all_sol_json <- OutputCollect$resultHypParam %>%
+            filter(!is.na(.data$cluster)) %>%
+            select(c("solID", "cluster", "top_sol")) %>%
+            arrange(.data$cluster, -.data$top_sol, .data$solID)
+        } else {
+          all_sol_json <- NULL
+        }
+        robyn_write(InputCollect, dir = OutputCollect$plot_folder, quiet = quiet, all_sol_json = all_sol_json)
 
         # For internal use -> UI Code
         if (ui && plot_pareto) OutputCollect$UI$pareto_onepagers <- pareto_onepagers

R/R/pareto.R

@@ -148,7 +148,7 @@ robyn_pareto <- function(InputCollect, OutputModels,
 
   if (!quiet) {
     message(sprintf(
-      ">>> Calculating response curves for all models' variables (%s)...",
+      ">>> Calculating response curves for all models' media variables (%s)...",
       nrow(decompSpendDistPar)
     ))
   }

R/R/plots.R

@@ -700,12 +700,16 @@ allocation_plots <- function(InputCollect, OutputCollect, dt_optimOut, select_mo
       message("NOTE: Given the upper/lower constrains, the total budget can't be fully allocated (^)")
     }
   }
-  levs1 <- c("Initial", "Bounded", paste0("Bounded x", bound_mult))
-  levs2 <- c(
-    "Initial",
-    paste0("Bounded", ifelse(optm_topped_bounded, "^", "")),
-    paste0("Bounded", ifelse(optm_topped_unbounded, "^", ""), " x", bound_mult)
-  )
+  levs1 <- eval_list$levs1
+  if (scenario == "max_response") {
+    levs2 <- c(
+      "Initial",
+      paste0("Bounded", ifelse(optm_topped_bounded, "^", "")),
+      paste0("Bounded", ifelse(optm_topped_unbounded, "^", ""), " x", bound_mult)
+    )
+  } else if (scenario == "target_efficiency") {
+    levs2 <- levs1
+  }
 
   resp_metric <- data.frame(
     type = factor(levs1, levels = levs1),
@@ -726,7 +730,7 @@ allocation_plots <- function(InputCollect, OutputCollect, dt_optimOut, select_mo
     pivot_longer(cols = !"type") %>%
     left_join(resp_metric, "type") %>%
     mutate(
-      name = factor(.data$name, levels = c("spend", "response")),
+      name = factor(paste("total", .data$name), levels = c("total spend", "total response")),
       name_label = factor(
         paste(.data$type, .data$name, sep = "\n"),
         levels = paste(.data$type, .data$name, sep = "\n")
@@ -746,7 +750,7 @@ allocation_plots <- function(InputCollect, OutputCollect, dt_optimOut, select_mo
   df_roi$labs <- factor(rep(labs, each = 2), levels = labs)
 
   outputs[["p1"]] <- p1 <- df_roi %>%
-    ggplot(aes(x = .data$name_label, y = .data$value, fill = .data$type)) +
+    ggplot(aes(x = .data$name, y = .data$value, fill = .data$type)) +
     facet_grid(. ~ .data$labs, scales = "free") +
     scale_fill_manual(values = c("grey", "steelblue", "darkgoldenrod4")) +
     geom_bar(stat = "identity", width = 0.6, alpha = 0.7) +
@@ -780,8 +784,19 @@ allocation_plots <- function(InputCollect, OutputCollect, dt_optimOut, select_mo
     left_join(
       dt_optimOut %>%
         mutate(
-          channel = as.factor(.data$channels), Initial = .data$initRoiUnit,
-          Bounded = .data$optmRoiUnit, Unbounded = .data$optmRoiUnitUnbound
+          channel = as.factor(.data$channels),
+          Initial = dplyr::case_when(
+            metric == "ROAS" ~ .data$initRoiUnit,
+            TRUE ~ .data$initCpaUnit
+          ),
+          Bounded = dplyr::case_when(
+            metric == "ROAS" ~ .data$optmRoiUnit,
+            TRUE ~ .data$optmCpaUnit
+          ),
+          Unbounded = dplyr::case_when(
+            metric == "ROAS" ~ .data$optmRoiUnitUnbound,
+            TRUE ~ .data$optmCpaUnitUnbound
+          )
         ) %>%
         select(.data$channel, .data$Initial, .data$Bounded, .data$Unbounded) %>%
         `colnames<-`(c("channel", levs1)) %>%
@@ -846,25 +861,34 @@ allocation_plots <- function(InputCollect, OutputCollect, dt_optimOut, select_mo
       ),
       values = round(.data$values, 4),
       # Deal with extreme cases divided by almost 0
-      values = ifelse((.data$values > 1e15 & .data$metric == "ROAS"), 0, .data$values),
-      values_label = dplyr::case_when(
+      values = ifelse((.data$values > 1e15 & .data$metric %in% c("ROAS", "mROAS")), 0, .data$values),
+      values_label = suppressWarnings(dplyr::case_when(
         .data$metric %in% c("ROAS", "mROAS") ~ paste0("x", round(.data$values, 2)),
-        .data$metric %in% c("CPA", "mCPA") ~ formatNum(100 * .data$values, 2, abbr = TRUE, pre = "$"),
+        .data$metric %in% c("CPA", "mCPA") ~ formatNum(.data$values, 2, abbr = TRUE, pre = "$"),
         TRUE ~ paste0(round(100 * .data$values, 1), "%")
-      ),
+      )),
       # Better fill scale colours
       values_label = ifelse(grepl("NA|NaN", .data$values_label), "-", .data$values_label),
-      values = ifelse((is.nan(.data$values) | is.na(.data$values)), 0, .data$values)
+      values = ifelse((is.nan(.data$values) | is.na(.data$values)), 0, .data$values),
+    ) %>%
+    mutate(
+      channel = factor(.data$channel, levels = rev(unique(.data$channel))),
+      metric = factor(
+        dplyr::case_when(
+          .data$metric %in% c("spend", "response") ~ paste0(.data$metric, "%"),
+          TRUE ~ .data$metric
+        ),
+        levels = paste0(unique(.data$metric), c("%", "%", "", ""))
+      )
     ) %>%
-    mutate(channel = factor(.data$channel, levels = rev(unique(.data$channel)))) %>%
     group_by(.data$name_label) %>%
     mutate(
       values_norm = lares::normalize(.data$values),
       values_norm = ifelse(is.nan(.data$values_norm), 0, .data$values_norm)
     )
 
   outputs[["p2"]] <- p2 <- df_plot_share %>%
-    ggplot(aes(x = .data$name_label, y = .data$channel, fill = .data$type)) +
+    ggplot(aes(x = .data$metric, y = .data$channel, fill = .data$type)) +
     geom_tile(aes(alpha = .data$values_norm), color = "white") +
     scale_fill_manual(values = c("grey50", "steelblue", "darkgoldenrod4")) +
     scale_alpha_continuous(range = c(0.6, 1)) +
@@ -992,8 +1016,15 @@ allocation_plots <- function(InputCollect, OutputCollect, dt_optimOut, select_mo
 
   # Gather all plots
   if (export) {
-    scenario <- ifelse(scenario == "max_historical_response", "hist", "respo")
-    filename <- paste0(OutputCollect$plot_folder, select_model, "_reallocated_", scenario, ".png")
+    suffix <- dplyr::case_when(
+      scenario == "max_response" & metric == "ROAS" ~ "best_roas",
+      scenario == "max_response" & metric == "CPA" ~ "best_cpa",
+      scenario == "target_efficiency" & metric == "ROAS" ~ "target_roas",
+      scenario == "target_efficiency" & metric == "CPA" ~ "target_cpa",
+      TRUE ~ "none"
+    )
+    # suffix <- ifelse(scenario == "max_response", "resp", "effi")
+    filename <- paste0(OutputCollect$plot_folder, select_model, "_reallocated_", suffix, ".png")
     if (!quiet) message("Exporting charts into file: ", filename)
     ggsave(
       filename = filename,