fix: mean response and performance values standardized across functions (#1280)

Author: laresbernardo

R/DESCRIPTION

@@ -1,7 +1,7 @@
 Package: Robyn
 Type: Package
 Title: Semi-Automated Marketing Mix Modeling (MMM) from Meta Marketing Science 
-Version: 3.12.0.9007
+Version: 3.12.0.9008
 Authors@R: c(
     person("Gufeng", "Zhou", , "[email protected]", c("cre", "aut")),
     person("Igor", "Skokan", , "[email protected]", c("aut")),

R/R/allocator.R

@@ -133,8 +133,11 @@ robyn_allocator <- function(robyn_object = NULL,
 
   ## set local variables, sort & prompt
   # paid_media_spends <- InputCollect$paid_media_spends
-  paid_media_selected <- if ("paid_media_selected" %in% names(InputCollect))
-    InputCollect$paid_media_selected else InputCollect$paid_media_spends
+  paid_media_selected <- if ("paid_media_selected" %in% names(InputCollect)) {
+    InputCollect$paid_media_selected
+  } else {
+    InputCollect$paid_media_spends
+  }
   dep_var_type <- InputCollect$dep_var_type
   if (is.null(select_model) && length(OutputCollect$allSolutions == 1)) {
     select_model <- OutputCollect$allSolutions
@@ -145,7 +148,7 @@ robyn_allocator <- function(robyn_object = NULL,
   mediaSelectedSorted <- paid_media_selected[media_order]
 
   ## Checks and constraints
-  if ("max_historical_response" %in% scenario) scenario <- "max_response" #legacy
+  if ("max_historical_response" %in% scenario) scenario <- "max_response" # legacy
   check_allocator(
     OutputCollect, select_model, paid_media_selected, scenario,
     channel_constr_low, channel_constr_up, constr_mode
@@ -164,27 +167,35 @@ robyn_allocator <- function(robyn_object = NULL,
   }
   if (length(channel_constr_low) == 1) channel_constr_low <- rep(channel_constr_low, length(paid_media_selected))
   if (length(channel_constr_up) == 1) channel_constr_up <- rep(channel_constr_up, length(paid_media_selected))
-  #check_allocator_constrains(channel_constr_low, channel_constr_up)
+  # check_allocator_constrains(channel_constr_low, channel_constr_up)
   names(channel_constr_low) <- names(channel_constr_up) <- paid_media_selected
   channelConstrLowSorted <- channel_constr_low[mediaSelectedSorted]
   channelConstrUpSorted <- channel_constr_up[mediaSelectedSorted]
 
   ## get hill parameters and coefs
   dt_hyppar_sorted <- OutputCollect$resultHypParam %>%
     filter(.data$solID == select_model) %>%
-    select(c(hyper_names(InputCollect$adstock, mediaSelectedSorted),
-             paste0(mediaSelectedSorted, "_inflexion"),
-             paste0(mediaSelectedSorted, "_inflation"))) %>%
+    select(c(
+      hyper_names(InputCollect$adstock, mediaSelectedSorted),
+      paste0(mediaSelectedSorted, "_inflexion"),
+      paste0(mediaSelectedSorted, "_inflation")
+    )) %>%
     select(sort(colnames(.)))
   dt_coef_sorted <- OutputCollect$xDecompAgg %>%
     filter(.data$solID == select_model & .data$rn %in% mediaSelectedSorted) %>%
     select("rn", "coef") %>%
     arrange(.data$rn)
   non_zero_coef_sorted <- dt_coef_sorted$coef > 0
   names(non_zero_coef_sorted) <- dt_coef_sorted$rn
-  alphas <- dt_hyppar_sorted %>% select(contains("alphas")) %>% unlist
-  inflexions <- dt_hyppar_sorted %>% select(contains("inflexion")) %>% unlist
-  inflations <- dt_hyppar_sorted %>% select(contains("inflation")) %>% unlist
+  alphas <- dt_hyppar_sorted %>%
+    select(contains("alphas")) %>%
+    unlist()
+  inflexions <- dt_hyppar_sorted %>%
+    select(contains("inflexion")) %>%
+    unlist()
+  inflations <- dt_hyppar_sorted %>%
+    select(contains("inflation")) %>%
+    unlist()
   coefs_sorted <- dt_coef_sorted$coef
   names(coefs_sorted) <- dt_coef_sorted$rn
 
@@ -289,7 +300,7 @@ robyn_allocator <- function(robyn_object = NULL,
       x_hist_carryover = mean(hist_carryover_temp),
       get_sum = FALSE
     )
-    initResponseUnit <- c(initResponseUnit, resp_simulate)
+    initResponseUnit <- c(initResponseUnit, resp$mean_response) # resp_simulate
     initResponseMargUnit <- c(initResponseMargUnit, resp_simulate_plus1 - resp_simulate)
   }
   qa_carryover <- do.call(cbind, qa_carryover) %>% as.data.frame()

R/R/json.R

@@ -89,29 +89,38 @@ robyn_write <- function(InputCollect,
       stopifnot(select_model %in% OutputCollect$allSolutions)
       outputs <- list()
       outputs$select_model <- select_model
-      df <- filter(OutputCollect$xDecompAgg, .data$solID == select_model)
+      sp <- select(InputCollect$dt_mod, c("ds", InputCollect$paid_media_spends))
+      df <- filter(OutputCollect$mediaVecCollect, .data$solID %in% select_model, .data$type == "decompMedia")
       perf_metric <- ifelse(InputCollect$dep_var_type == "revenue", "ROAS", "CPA")
-      outputs$performance <- df %>%
-        filter(.data$rn %in% InputCollect$paid_media_spends) %>%
-        group_by(.data$solID) %>%
-        summarise(
+      performance <- left_join(
+        tidyr::gather(dplyr::summarize_all(select(sp, InputCollect$paid_media_spends), sum), "channel", "spend"),
+        tidyr::gather(dplyr::summarize_all(select(df, InputCollect$paid_media_spends), sum), "channel", "response"),
+        by = "channel"
+      ) %>%
+        dplyr::rowwise() %>%
+        mutate(
           metric = perf_metric,
           performance = ifelse(
             perf_metric == "ROAS",
-            sum(.data$xDecompAgg) / sum(.data$total_spend),
-            sum(.data$total_spend) / sum(.data$xDecompAgg)
-          ), .groups = "drop"
+            .data$response / .data$spend,
+            .data$spend / .data$response
+          )
         )
-      outputs$summary <- df %>%
-        mutate(
-          metric = perf_metric,
-          performance = ifelse(.data$metric == "ROAS", .data$roi_total, .data$cpa_total)
-        ) %>%
+      outputs$performance <- performance %>%
+        group_by(solID = select_model, .data$metric) %>%
+        dplyr::summarize_if(is.numeric, sum) %>%
+        mutate(solID = select_model)
+      outputs$summary <- filter(OutputCollect$xDecompAgg, .data$solID == select_model) %>%
+        left_join(performance, by = c("rn" = "channel")) %>%
         select(
           variable = .data$rn, coef = .data$coef,
           decompPer = .data$xDecompPerc, decompAgg = .data$xDecompAggRF,
-          .data$performance, .data$mean_response, .data$mean_spend,
+          .data$performance, "mean_response" = .data$response, "mean_spend" = .data$spend,
           contains("boot_mean"), contains("ci_")
+        ) %>%
+        mutate(
+          mean_response = .data$mean_response / InputCollect$totalObservations,
+          mean_spend = .data$mean_spend / InputCollect$totalObservations
         )
       outputs$errors <- filter(OutputCollect$resultHypParam, .data$solID == select_model) %>%
         select(starts_with("rsq_"), starts_with("nrmse"), .data$decomp.rssd, .data$mape)

R/R/pareto.R

@@ -175,7 +175,7 @@ robyn_pareto <- function(InputCollect, OutputModels,
         )
         list_response <- list(
           dt_resp = data.frame(
-            mean_response = get_resp$mean_response_total,
+            mean_response = get_resp$mean_response,
             mean_spend_adstocked = get_resp$mean_input_immediate + get_resp$mean_input_carryover,
             mean_carryover = get_resp$mean_input_carryover,
             rn = get_media_name,

R/R/response.R

@@ -132,12 +132,12 @@ robyn_response <- function(InputCollect = NULL,
     if (is.null(dt_hyppar)) dt_hyppar <- OutputCollect$resultHypParam
     if (is.null(dt_coef)) dt_coef <- OutputCollect$xDecompAgg
   } else {
-      # Get pre-filled values
-      if (is.null(dt_hyppar)) dt_hyppar <- OutputCollect$resultHypParam
-      if (is.null(dt_coef)) dt_coef <- OutputCollect$xDecompAgg
-      if (any(is.null(dt_hyppar), is.null(dt_coef), is.null(InputCollect), is.null(OutputCollect))) {
-        stop("When 'json_file' is not provided, 'InputCollect' & 'OutputCollect' must be provided")
-      }
+    # Get pre-filled values
+    if (is.null(dt_hyppar)) dt_hyppar <- OutputCollect$resultHypParam
+    if (is.null(dt_coef)) dt_coef <- OutputCollect$xDecompAgg
+    if (any(is.null(dt_hyppar), is.null(dt_coef), is.null(InputCollect), is.null(OutputCollect))) {
+      stop("When 'json_file' is not provided, 'InputCollect' & 'OutputCollect' must be provided")
+    }
   }
 
   if ("selectID" %in% names(OutputCollect)) {
@@ -202,23 +202,26 @@ robyn_response <- function(InputCollect = NULL,
   hist_transform <- transform_decomp(
     all_values = all_values,
     adstock, theta, shape, scale, alpha, gamma,
-    window_loc, coeff, metric_loc = ds_list$metric_loc)
+    window_loc, coeff, metric_loc = ds_list$metric_loc
+  )
   dt_line <- data.frame(
     metric = hist_transform$input_total[window_loc],
     response = hist_transform$response_total,
-    channel = metric_name_updated)
+    channel = metric_name_updated
+  )
   dt_point <- data.frame(
     mean_input_immediate = hist_transform$mean_input_immediate,
     mean_input_carryover = hist_transform$mean_input_carryover,
     mean_input_total = hist_transform$mean_input_immediate + hist_transform$mean_input_carryover,
     mean_response_immediate = hist_transform$mean_response_total - hist_transform$mean_response_carryover,
     mean_response_carryover = hist_transform$mean_response_carryover,
     mean_response_total = hist_transform$mean_response_total
-    )
+  )
   if (!is.null(date_range)) {
     dt_point_sim <- data.frame(
       input = hist_transform$sim_mean_spend + hist_transform$sim_mean_carryover,
-      output = hist_transform$sim_mean_response)
+      output = hist_transform$sim_mean_response
+    )
   }
 
   ## Simulated transformation
@@ -227,10 +230,12 @@ robyn_response <- function(InputCollect = NULL,
       all_values = all_values_updated,
       adstock, theta, shape, scale, alpha, gamma,
       window_loc, coeff, metric_loc = ds_list$metric_loc,
-      calibrate_inflexion = hist_transform$inflexion)
+      calibrate_inflexion = hist_transform$inflexion
+    )
     dt_point_sim <- data.frame(
       input = hist_transform_sim$sim_mean_spend + hist_transform_sim$sim_mean_carryover,
-      output = hist_transform_sim$sim_mean_response)
+      output = hist_transform_sim$sim_mean_response
+    )
   }
 
   ## Plot optimal response
@@ -239,17 +244,20 @@ robyn_response <- function(InputCollect = NULL,
     geom_point(
       data = dt_point,
       aes(x = .data$mean_input_total, y = .data$mean_response_total),
-      size = 3, color = "grey") +
+      size = 3, color = "grey"
+    ) +
     labs(
       title = paste(
         "Saturation curve of", metric_type$metric_type,
         "media:", metric_type$metric_name_updated
       ),
-      subtitle = sprintf(paste(
-        "Response: %s @ mean input %s",
-        "Response: %s @ mean input carryover %s",
-        "Response: %s @ mean input immediate %s",
-        sep = "\n"),
+      subtitle = sprintf(
+        paste(
+          "Response: %s @ mean input %s",
+          "Response: %s @ mean input carryover %s",
+          "Response: %s @ mean input immediate %s",
+          sep = "\n"
+        ),
         num_abbr(dt_point$mean_response_total),
         num_abbr(dt_point$mean_input_total),
         num_abbr(dt_point$mean_response_carryover),
@@ -294,6 +302,7 @@ robyn_response <- function(InputCollect = NULL,
     mean_input_carryover = hist_transform$mean_input_carryover,
     mean_response_total = hist_transform$mean_response_total,
     mean_response_carryover = hist_transform$mean_response_carryover,
+    mean_response = hist_transform$mean_response,
     sim_mean_spend = sim_mean_spend,
     sim_mean_carryover = sim_mean_carryover,
     sim_mean_response = sim_mean_response,
@@ -327,7 +336,7 @@ which_usecase <- function(metric_value, date_range) {
 }
 
 transform_decomp <- function(all_values, adstock, theta, shape, scale, alpha, gamma,
-                              window_loc, coeff, metric_loc, calibrate_inflexion = NULL) {
+                             window_loc, coeff, metric_loc, calibrate_inflexion = NULL) {
   ## adstock
   x_list <- transform_adstock(x = all_values, adstock, theta, shape, scale)
   input_total <- x_list$x_decayed
@@ -348,6 +357,7 @@ transform_decomp <- function(all_values, adstock, theta, shape, scale, alpha, ga
   ## simulate mean response of all_values periods
   mean_input_immediate <- mean(input_immediate[window_loc])
   mean_input_carryover <- mean(input_carryover_rw)
+  mean_response <- mean(saturated_total$x_saturated[window_loc] * coeff)
   mean_response_total <- fx_objective(
     x = mean_input_immediate,
     coeff = coeff,
@@ -392,6 +402,7 @@ transform_decomp <- function(all_values, adstock, theta, shape, scale, alpha, ga
     mean_input_immediate = mean_input_immediate,
     mean_input_carryover = mean_input_carryover,
     mean_response_total = mean_response_total,
+    mean_response = mean_response,
     mean_response_carryover = mean_response_carryover,
     sim_mean_spend = sim_mean_spend,
     sim_mean_carryover = sim_mean_carryover,