Merge pull request #826 from facebookexperimental/add_objective_weights

Author: gufengzhou

R/DESCRIPTION

@@ -1,7 +1,7 @@
 Package: Robyn
 Type: Package
 Title: Semi-Automated Marketing Mix Modeling (MMM) from Meta Marketing Science 
-Version: 3.10.4.9012
+Version: 3.10.5.9000
 Authors@R: c(
     person("Gufeng", "Zhou", , "gufeng@meta.com", c("cre","aut")),
     person("Leonel", "Sentana", , "leonelsentana@meta.com", c("aut")),

R/R/allocator.R

@@ -108,7 +108,6 @@ robyn_allocator <- function(robyn_object = NULL,
                             quiet = FALSE,
                             ui = FALSE,
                             ...) {
-
   ### Use previously exported model using json_file
   if (!is.null(json_file)) {
     if (is.null(InputCollect)) {
@@ -141,12 +140,12 @@ robyn_allocator <- function(robyn_object = NULL,
   #   OutputCollect <- imported$OutputCollect
   #   select_model <- imported$select_model
   # } else {
-    if (is.null(select_model) && length(OutputCollect$allSolutions == 1)) {
-      select_model <- OutputCollect$allSolutions
-    }
-    if (any(is.null(InputCollect), is.null(OutputCollect), is.null(select_model))) {
-      stop("When 'robyn_object' is not provided, then InputCollect, OutputCollect, select_model must be provided")
-    }
+  if (is.null(select_model) && length(OutputCollect$allSolutions == 1)) {
+    select_model <- OutputCollect$allSolutions
+  }
+  if (any(is.null(InputCollect), is.null(OutputCollect), is.null(select_model))) {
+    stop("When 'robyn_object' is not provided, then InputCollect, OutputCollect, select_model must be provided")
+  }
   # }
 
   if (length(InputCollect$paid_media_spends) <= 1) {
@@ -238,9 +237,12 @@ robyn_allocator <- function(robyn_object = NULL,
   simulation_period <- initial_mean_period <- unlist(summarise_all(select(histFiltered, any_of(mediaSpendSorted)), length))
   nDates <- lapply(mediaSpendSorted, function(x) histFiltered$ds)
   names(nDates) <- mediaSpendSorted
-  if (!quiet) message(sprintf(
-    "Date Window: %s:%s (%s %ss)",
-    date_min, date_max, unique(initial_mean_period), InputCollect$intervalType))
+  if (!quiet) {
+    message(sprintf(
+      "Date Window: %s:%s (%s %ss)",
+      date_min, date_max, unique(initial_mean_period), InputCollect$intervalType
+    ))
+  }
   zero_spend_channel <- names(histSpendWindow[histSpendWindow == 0])
 
   initSpendUnitTotal <- sum(initSpendUnit)
@@ -253,7 +255,7 @@ robyn_allocator <- function(robyn_object = NULL,
   if (usecase == "all_historical_vec") {
     ndates_loc <- which(InputCollect$dt_mod$ds %in% histFiltered$ds)
   } else {
-    ndates_loc <- 1:length(histFiltered$ds)
+    ndates_loc <- seq_along(histFiltered$ds)
   }
   usecase <- paste(usecase, ifelse(!is.null(total_budget), "+ defined_budget", "+ historical_budget"))
 
@@ -359,14 +361,19 @@ robyn_allocator <- function(robyn_object = NULL,
   skip_these <- (channel_constr_low == 0 & channel_constr_up == 0)
   zero_constraint_channel <- mediaSpendSorted[skip_these]
   if (any(skip_these) && !quiet) {
-    message("Excluded variables (constrained to 0): ",
-            paste(zero_constraint_channel, collapse = ", "))
+    message(
+      "Excluded variables (constrained to 0): ",
+      paste(zero_constraint_channel, collapse = ", ")
+    )
   }
   if (!all(coefSelectorSorted)) {
     zero_coef_channel <- setdiff(names(coefSelectorSorted), mediaSpendSorted[coefSelectorSorted])
-    if (!quiet) message(
-      "Excluded variables (coefficients are 0): ",
-      paste(zero_coef_channel, collapse = ", "))
+    if (!quiet) {
+      message(
+        "Excluded variables (coefficients are 0): ",
+        paste(zero_coef_channel, collapse = ", ")
+      )
+    }
   } else {
     zero_coef_channel <- as.character()
   }
@@ -754,7 +761,9 @@ robyn_allocator <- function(robyn_object = NULL,
       select_model, scenario, eval_list,
       export, plot_folder, quiet
     )
-  } else plots <- NULL
+  } else {
+    plots <- NULL
+  }
 
   output <- list(
     dt_optimOut = dt_optimOut,

R/R/checks.R

@@ -38,12 +38,14 @@ check_novar <- function(dt_input, InputCollect = NULL) {
       "There are %s column(s) with no-variance: %s. \nPlease, remove the variable(s) to proceed...",
       length(novar), v2t(novar)
     )
-    if (!is.null(InputCollect)) msg <- sprintf(
-      "%s\n>>> Note: there's no variance on these variables because of the modeling window filter (%s:%s)",
-      msg,
-      InputCollect$window_start,
-      InputCollect$window_end
-    )
+    if (!is.null(InputCollect)) {
+      msg <- sprintf(
+        "%s\n>>> Note: there's no variance on these variables because of the modeling window filter (%s:%s)",
+        msg,
+        InputCollect$window_start,
+        InputCollect$window_end
+      )
+    }
     stop(msg)
   }
 }
@@ -164,9 +166,12 @@ check_prophet <- function(dt_holidays, prophet_country, prophet_vars, prophet_si
     prophet_vars <- tolower(prophet_vars)
     opts <- c("trend", "season", "monthly", "weekday", "holiday")
     if (!"holiday" %in% prophet_vars) {
-      if (!is.null(prophet_country)) warning(paste(
-        "Input 'prophet_country' is defined as", prophet_country,
-        "but 'holiday' is not setup within 'prophet_vars' parameter"))
+      if (!is.null(prophet_country)) {
+        warning(paste(
+          "Input 'prophet_country' is defined as", prophet_country,
+          "but 'holiday' is not setup within 'prophet_vars' parameter"
+        ))
+      }
       prophet_country <- NULL
     }
     if (!all(prophet_vars %in% opts)) {
@@ -177,7 +182,7 @@ check_prophet <- function(dt_holidays, prophet_country, prophet_vars, prophet_si
     }
     if ("holiday" %in% prophet_vars && (
       is.null(prophet_country) || length(prophet_country) > 1 |
-      isTRUE(!prophet_country %in% unique(dt_holidays$country)))) {
+        isTRUE(!prophet_country %in% unique(dt_holidays$country)))) {
       stop(paste(
         "You must provide 1 country code in 'prophet_country' input.",
         length(unique(dt_holidays$country)), "countries are included:",
@@ -649,6 +654,26 @@ check_calibration <- function(dt_input, date_var, calibration_input, dayInterval
   return(calibration_input)
 }
 
+check_obj_weight <- function(calibration_input, objective_weights, refresh) {
+  obj_len <- ifelse(is.null(calibration_input), 2, 3)
+  if (!is.null(objective_weights)) {
+    if ((length(objective_weights) != obj_len)) {
+      stop(paste0("objective_weights must have length of ", obj_len))
+    }
+    if (any(objective_weights < 0) | any(objective_weights > 10)) {
+      stop("objective_weights must be >= 0 & <= 10")
+    }
+  }
+  if (is.null(objective_weights) & refresh) {
+    if (obj_len == 2) {
+      objective_weights <- c(1, 10)
+    } else {
+      objective_weights <- c(1, 10, 10)
+    }
+  }
+  return(objective_weights)
+}
+
 check_iteration <- function(calibration_input, iterations, trials, hyps_fixed, refresh) {
   if (!refresh) {
     if (!hyps_fixed) {

R/R/clusters.R

@@ -77,9 +77,10 @@ robyn_clusters <- function(input, dep_var_type,
       {
         suppressMessages(
           clusterKmeans(df,
-                        k = NULL, limit = limit_clusters, ignore = ignore,
-                        dim_red = dim_red, quiet = TRUE, seed = seed
-          ))
+            k = NULL, limit = limit_clusters, ignore = ignore,
+            dim_red = dim_red, quiet = TRUE, seed = seed
+          )
+        )
       },
       error = function(err) {
         message(paste("Couldn't automatically create clusters:", err))
@@ -109,8 +110,10 @@ robyn_clusters <- function(input, dep_var_type,
   stopifnot(k %in% min_clusters:30)
   suppressMessages(
     cls <- clusterKmeans(
-      df, k = k, limit = limit_clusters, ignore = ignore,
-      dim_red = dim_red, quiet = TRUE, seed = seed)
+      df,
+      k = k, limit = limit_clusters, ignore = ignore,
+      dim_red = dim_red, quiet = TRUE, seed = seed
+    )
   )
 
   # Select top models by minimum (weighted) distance to zero
@@ -181,8 +184,9 @@ confidence_calcs <- function(
     if (length(unique(df_outcome$solID)) < 3) {
       warning(paste("Cluster", j, "does not contain enough models to calculate CI"))
     } else {
-      if (cluster_by == "hyperparameters")
+      if (cluster_by == "hyperparameters") {
         all_paid <- unique(gsub(paste(paste0("_", HYPS_NAMES), collapse = "|"), "", all_paid))
+      }
       for (i in all_paid) {
         # Bootstrap CI
         if (dep_var_type == "conversion") {
@@ -317,7 +321,8 @@ errors_scores <- function(df, balance = rep(1, 3), ts_validation = TRUE, ...) {
     if (cluster_by == "hyperparameters") {
       outcome <- select(
         x, .data$solID, contains(HYPS_NAMES),
-        contains(c("nrmse", "decomp.rssd", "mape"))) %>%
+        contains(c("nrmse", "decomp.rssd", "mape"))
+      ) %>%
         removenacols(all = FALSE)
     }
   }

R/R/convergence.R

@@ -148,8 +148,8 @@ robyn_converge <- function(OutputModels,
   moo_cloud_plot <- df %>%
     mutate(nrmse = lares::winsorize(.data$nrmse, nrmse_win)) %>%
     ggplot(aes(
-    x = .data$nrmse, y = .data$decomp.rssd, colour = .data$ElapsedAccum
-  )) +
+      x = .data$nrmse, y = .data$decomp.rssd, colour = .data$ElapsedAccum
+    )) +
     scale_colour_gradient(low = "skyblue", high = "navyblue") +
     labs(
       title = ifelse(!calibrated, "Multi-objective evolutionary performance",

R/R/inputs.R

@@ -361,8 +361,10 @@ robyn_inputs <- function(dt_input = NULL,
     # Check for no-variance columns (after filtering modeling window)
     dt_mod_model_window <- InputCollect$dt_mod %>%
       select(-any_of(InputCollect$unused_vars)) %>%
-      filter(.data$ds >= InputCollect$window_start,
-             .data$ds <= InputCollect$window_end)
+      filter(
+        .data$ds >= InputCollect$window_start,
+        .data$ds <= InputCollect$window_end
+      )
     check_novar(dt_mod_model_window, InputCollect)
   }
 

R/R/json.R

@@ -64,7 +64,8 @@ robyn_write <- function(InputCollect,
   outputs_time <- sprintf("%s min", attr(OutputCollect, "runTime"))
   total_time <- sprintf(
     "%s min",
-    attr(OutputCollect, "runTime") + attr(OutputCollect$OutputModels, "runTime"))
+    attr(OutputCollect, "runTime") + attr(OutputCollect$OutputModels, "runTime")
+  )
   if (!is.null(OutputCollect)) {
     outputs <- list()
     outputs$select_model <- select_model
@@ -160,12 +161,12 @@ print.robyn_write <- function(x, ...) {
   print(glued("\n\nSummary Values on Selected Model:"))
 
   print(x$ExportedModel$summary %>%
-          select(-contains("boot"), -contains("ci_")) %>%
-          dplyr::rename_at("performance", list(~ ifelse(x$InputCollect$dep_var_type == "revenue", "ROI", "CPA"))) %>%
-          mutate(decompPer = formatNum(100 * .data$decompPer, pos = "%")) %>%
-          dplyr::mutate_if(is.numeric, function(x) ifelse(!is.infinite(x), x, 0)) %>%
-          dplyr::mutate_if(is.numeric, function(x) formatNum(x, 4, abbr = TRUE)) %>%
-          replace(., . == "NA", "-") %>% as.data.frame())
+    select(-contains("boot"), -contains("ci_")) %>%
+    dplyr::rename_at("performance", list(~ ifelse(x$InputCollect$dep_var_type == "revenue", "ROI", "CPA"))) %>%
+    mutate(decompPer = formatNum(100 * .data$decompPer, pos = "%")) %>%
+    dplyr::mutate_if(is.numeric, function(x) ifelse(!is.infinite(x), x, 0)) %>%
+    dplyr::mutate_if(is.numeric, function(x) formatNum(x, 4, abbr = TRUE)) %>%
+    replace(., . == "NA", "-") %>% as.data.frame())
 
   print(glued(
     "\n\nHyper-parameters:\n    Adstock: {x$InputCollect$adstock}"
@@ -178,8 +179,8 @@ print.robyn_write <- function(x, ...) {
     select(-contains("lambda"), -any_of(HYPS_OTHERS)) %>%
     tidyr::gather() %>%
     tidyr::separate(.data$key,
-                    into = c("channel", "none"),
-                    sep = regex, remove = FALSE
+      into = c("channel", "none"),
+      sep = regex, remove = FALSE
     ) %>%
     mutate(hyperparameter = gsub("^.*_", "", .data$key)) %>%
     select(.data$channel, .data$hyperparameter, .data$value) %>%

R/R/model.R

@@ -49,6 +49,10 @@
 #' In other words, given the same DECOMP.RSSD score, a model with 50\% 0-coef
 #' variables will get penalized by DECOMP.RSSD * 1.5 (larger error), while
 #' another model with no 0-coef variables gets un-penalized with DECOMP.RSSD * 1.
+#' @param objective_weights Numeric. Default to NULL that gives equal weights
+#' to all objective functions. Set c(2, 1) to give double weight to the 1st.
+#' This is an experimental feature. There's no research on optimal weight
+#' setting. Subjective weights might strongly bias modelling result.
 #' @param seed Integer. For reproducible results when running nevergrad.
 #' @param outputs Boolean. Process results with \code{robyn_outputs()}?
 #' @param lambda_control Deprecated in v3.6.0.
@@ -81,6 +85,7 @@ robyn_run <- function(InputCollect = NULL,
                       trials = 5,
                       iterations = 2000,
                       rssd_zero_penalty = TRUE,
+                      objective_weights = NULL,
                       nevergrad_algo = "TwoPointsDE",
                       intercept = TRUE,
                       intercept_sign = "non_negative",
@@ -135,6 +140,7 @@ robyn_run <- function(InputCollect = NULL,
   check_run_inputs(cores, iterations, trials, intercept_sign, nevergrad_algo)
   check_iteration(InputCollect$calibration_input, iterations, trials, hyps_fixed, refresh)
   init_msgs_run(InputCollect, refresh, lambda_control = NULL, quiet)
+  objective_weights <- check_obj_weight(InputCollect$calibration_input, objective_weights, refresh)
 
   #####################################
   #### Prepare hyper-parameters
@@ -160,6 +166,7 @@ robyn_run <- function(InputCollect = NULL,
     ts_validation = ts_validation,
     add_penalty_factor = add_penalty_factor,
     rssd_zero_penalty = rssd_zero_penalty,
+    objective_weights = objective_weights,
     refresh, seed, quiet
   )
 
@@ -290,6 +297,7 @@ robyn_train <- function(InputCollect, hyper_collect,
                         dt_hyper_fixed = NULL,
                         ts_validation = TRUE,
                         add_penalty_factor = FALSE,
+                        objective_weights = NULL,
                         rssd_zero_penalty = TRUE,
                         refresh = FALSE, seed = 123,
                         quiet = FALSE) {
@@ -309,6 +317,7 @@ robyn_train <- function(InputCollect, hyper_collect,
       ts_validation = ts_validation,
       add_penalty_factor = add_penalty_factor,
       rssd_zero_penalty = rssd_zero_penalty,
+      objective_weights = objective_weights,
       seed = seed,
       quiet = quiet
     )
@@ -345,6 +354,7 @@ robyn_train <- function(InputCollect, hyper_collect,
         ts_validation = ts_validation,
         add_penalty_factor = add_penalty_factor,
         rssd_zero_penalty = rssd_zero_penalty,
+        objective_weights = objective_weights,
         refresh = refresh,
         trial = ngt,
         seed = seed + ngt,
@@ -401,6 +411,7 @@ robyn_mmm <- function(InputCollect,
                       intercept_sign,
                       ts_validation = TRUE,
                       add_penalty_factor = FALSE,
+                      objective_weights = NULL,
                       dt_hyper_fixed = NULL,
                       # lambda_fixed = NULL,
                       rssd_zero_penalty = TRUE,
@@ -529,11 +540,24 @@ robyn_mmm <- function(InputCollect,
     my_tuple <- tuple(hyper_count)
     instrumentation <- ng$p$Array(shape = my_tuple, lower = 0, upper = 1)
     optimizer <- ng$optimizers$registry[optimizer_name](instrumentation, budget = iterTotal, num_workers = cores)
+
     # Set multi-objective dimensions for objective functions (errors)
     if (is.null(calibration_input)) {
       optimizer$tell(ng$p$MultiobjectiveReference(), tuple(1, 1))
+      if (is.null(objective_weights)) {
+        objective_weights <- tuple(1, 1)
+      } else {
+        objective_weights <- tuple(objective_weights[1], objective_weights[2])
+      }
+      optimizer$set_objective_weights(objective_weights)
     } else {
       optimizer$tell(ng$p$MultiobjectiveReference(), tuple(1, 1, 1))
+      if (is.null(objective_weights)) {
+        objective_weights <- tuple(1, 1, 1)
+      } else {
+        objective_weights <- tuple(objective_weights[1], objective_weights[2], objective_weights[3])
+      }
+      optimizer$set_objective_weights(objective_weights)
     }
   }
 

R/R/plots.R

@@ -589,10 +589,10 @@ robyn_onepagers <- function(
       rver <- utils::sessionInfo()$R.version
       onepagerTitle <- sprintf("One-pager for Model ID: %s", sid)
       onepagerCaption <- sprintf("Robyn v%s [R-%s.%s]", ver, rver$major, rver$minor)
-      get_height <-  length(unique(plotMediaShareLoopLine$rn)) / 5
+      get_height <- length(unique(plotMediaShareLoopLine$rn)) / 5
       pg <- (p2 + p5) / (p1 + p8) / (p3 + p7) / (p4 + p6) +
         patchwork::plot_layout(heights = c(get_height, get_height, get_height, 1), guides = "collect") +
-      #pg <- wrap_plots(p2, p5, p1, p8, p3, p7, p4, p6, ncol = 2) +
+        # pg <- wrap_plots(p2, p5, p1, p8, p3, p7, p4, p6, ncol = 2) +
         plot_annotation(
           title = onepagerTitle, subtitle = errors,
           theme = theme_lares(background = "white", legend = "none"),
@@ -1339,7 +1339,8 @@ refresh_plots_json <- function(OutputCollectRF, json_file, export = TRUE, ...) {
     ggsave(
       filename = paste0(
         chainData[[length(chainData)]]$ExportedModel$plot_folder,
-        "report_decomposition.png"),
+        "report_decomposition.png"
+      ),
       plot = pBarRF,
       dpi = 900, width = 12, height = 8, limitsize = FALSE
     )