fix: prepare for ggplot2 4.0.0 + budget allocator initials points + robyn_write()'s bug + op's mean points + styler() (#1283)

* recode: comply with ggplot2 4.0.0
* recode: apply styler
* fix: #1282 + gg warnings
* fix: initResponseUnit NAs
* recode: format
* fix: initial point in plot over resp curve
* fix: points in op always over the curve

Author: laresbernardo

R/DESCRIPTION

@@ -1,11 +1,11 @@
 Package: Robyn
 Type: Package
 Title: Semi-Automated Marketing Mix Modeling (MMM) from Meta Marketing Science 
-Version: 3.12.0.9008
+Version: 3.12.1
 Authors@R: c(
     person("Gufeng", "Zhou", , "[email protected]", c("cre", "aut")),
-    person("Igor", "Skokan", , "[email protected]", c("aut")),
     person("Bernardo", "Lares", , "[email protected]", c("aut")),
+    person("Igor", "Skokan", , "[email protected]", c("aut")),
     person("Leonel", "Sentana", , "[email protected]", c("aut")),
     person("Meta Platforms, Inc.", role = c("cph", "fnd")))
 Maintainer: Gufeng Zhou <[email protected]>
@@ -17,14 +17,14 @@ Imports:
     doRNG,
     dplyr,
     foreach,
-    ggplot2,
+    ggplot2 (>= 3.4.0),
     ggridges,
     glmnet,
     jsonlite,
     lares,
     lubridate,
     nloptr,
-    patchwork,
+    patchwork (>= 1.3.1),
     prophet,
     reticulate,
     stringr,

R/R/allocator.R

@@ -250,8 +250,7 @@ robyn_allocator <- function(robyn_object = NULL,
   usecase <- paste(usecase, ifelse(!is.null(total_budget), "+ defined_budget", "+ historical_budget"))
 
   # Response values based on date range -> mean spend
-  initResponseUnit <- NULL
-  initResponseMargUnit <- NULL
+  initResponseUnit <- initResponseUnitSim <- initResponseMargUnit <- NULL
   hist_carryover <- list()
   qa_carryover <- list()
   for (i in seq_along(mediaSelectedSorted)) {
@@ -300,11 +299,17 @@ robyn_allocator <- function(robyn_object = NULL,
       x_hist_carryover = mean(hist_carryover_temp),
       get_sum = FALSE
     )
-    initResponseUnit <- c(initResponseUnit, resp$mean_response) # resp_simulate
+    initResponseUnit <- c(initResponseUnit, ifelse(
+      all(mediaSelectedSorted %in% InputCollect$paid_media_spends),
+      resp$mean_response,
+      resp_simulate
+    ))
+    initResponseUnitSim <- c(initResponseUnitSim, resp_simulate)
     initResponseMargUnit <- c(initResponseMargUnit, resp_simulate_plus1 - resp_simulate)
   }
   qa_carryover <- do.call(cbind, qa_carryover) %>% as.data.frame()
-  names(initResponseUnit) <- names(hist_carryover) <- names(qa_carryover) <- mediaSelectedSorted
+  names(initResponseUnit) <- names(initResponseUnitSim) <-
+    names(hist_carryover) <- names(qa_carryover) <- mediaSelectedSorted
   # QA adstock: simulated adstock should be identical to model adstock
   # qa_carryover_origin <- OutputCollect$mediaVecCollect %>%
   #   filter(.data$solID == select_model & .data$type == "adstockedMedia") %>%
@@ -591,6 +596,7 @@ robyn_allocator <- function(robyn_object = NULL,
     # adstocked_end_date = as.Date(ifelse(adstocked, tail(resp$date, 1), NA), origin = "1970-01-01"),
     # adstocked_periods = length(resp$date),
     initResponseUnit = initResponseUnit,
+    initResponseUnitSim = initResponseUnitSim,
     initResponseUnitTotal = sum(initResponseUnit),
     initResponseMargUnit = initResponseMargUnit,
     initResponseTotal = sum(initResponseUnit) * unique(simulation_period),
@@ -655,7 +661,7 @@ robyn_allocator <- function(robyn_object = NULL,
   eval_list$levs1 <- levs1
 
   dt_optimOutScurve <- rbind(
-    select(dt_optimOut, .data$channels, .data$initSpendUnit, .data$initResponseUnit) %>%
+    select(dt_optimOut, .data$channels, .data$initSpendUnit, .data$initResponseUnitSim) %>%
       mutate(x = levs1[1]) %>% as.matrix(),
     select(dt_optimOut, .data$channels, .data$optmSpendUnit, .data$optmResponseUnit) %>%
       mutate(x = levs1[2]) %>% as.matrix(),

R/R/auxiliary.R

@@ -97,16 +97,18 @@ baseline_vars <- function(InputCollect, baseline_level) {
 
 # Calculate dot product
 .dot_product <- function(range, proportion) {
-  mapply(function(proportion) {
-    c(range %*% c(1 - proportion, proportion))
-  },
-  proportion = proportion)
+  mapply(
+    function(proportion) {
+      c(range %*% c(1 - proportion, proportion))
+    },
+    proportion = proportion
+  )
 }
 
 # Calculate quantile interval
 .qti <- function(x, interval = 0.95) {
   check_qti(interval)
-  int_low <- (1 - interval)/2
+  int_low <- (1 - interval) / 2
   int_up <- 1 - int_low
   qt_low <- quantile(x, int_low)
   qt_up <- quantile(x, int_up)
@@ -131,13 +133,14 @@ baseline_vars <- function(InputCollect, baseline_level) {
   } else {
     warning(paste(
       "Unable to determine frequency to calculate next logical date.",
-      "Returning last available date."))
+      "Returning last available date."
+    ))
     return(as.Date(tail(dates, 1)))
   }
-  next_date <- switch(
-    frequency,
+  next_date <- switch(frequency,
     "daily" = dates[length(dates)] + 1,
     "weekly" = dates[length(dates)] + 7,
-    "monthly" = seq(dates[length(dates)], by = "1 month", length.out = 2)[2])
+    "monthly" = seq(dates[length(dates)], by = "1 month", length.out = 2)[2]
+  )
   return(as.Date(next_date))
 }

R/R/calibration.R

@@ -51,7 +51,8 @@
 #' # "reach 1+" for gamma lower bound and "reach 10+" for gamma upper bound
 #' facebook_I_gammas <- c(
 #'   curve_out[["curve_collect"]][["reach 1+"]][["hill"]][["gamma_best"]],
-#'   curve_out[["curve_collect"]][["reach 10+"]][["hill"]][["gamma_best"]])
+#'   curve_out[["curve_collect"]][["reach 10+"]][["hill"]][["gamma_best"]]
+#' )
 #' print(facebook_I_gammas)
 #' }
 #' @return List. Class: \code{curve_out}. Contains the results of all trials
@@ -94,7 +95,8 @@ robyn_calibrate <- function(
         burn_in_rel,
         sim_n,
         hp_interval,
-        quiet)
+        quiet
+      )
     }
 
     df_curve_plot <- bind_rows(lapply(curve_collect, function(x) x$df_out))
@@ -108,12 +110,14 @@ robyn_calibrate <- function(
         x = "cumulative spend",
         y = "cumulative reach"
       ) +
-      #theme_lares(background = "white")+
-      #scale_alpha_discrete(range = c(1, 0.2))
-      scale_colour_discrete(h =c(120,260))
+      # theme_lares(background = "white")+
+      # scale_alpha_discrete(range = c(1, 0.2))
+      scale_colour_discrete(h = c(120, 260))
 
-    return(list(curve_collect = curve_collect,
-                plot_reach_freq = p_rnf))
+    return(list(
+      curve_collect = curve_collect,
+      plot_reach_freq = p_rnf
+    ))
   } else {
     curve_collect <- robyn_calibrate_single_dim(
       df_curve,
@@ -127,7 +131,8 @@ robyn_calibrate <- function(
       burn_in_rel,
       sim_n,
       hp_interval,
-      quiet)
+      quiet
+    )
     return(list(curve_collect = curve_collect))
   }
 }
@@ -314,7 +319,8 @@ robyn_calibrate_single_dim <- function(
 
   ## get calibration range for hyparameters
   p_alpha <- data.frame(alpha = alpha_collect_converged) %>%
-    ggplot(aes(x = alpha)) + geom_density(fill = "grey99", color = "grey")
+    ggplot(aes(x = alpha)) +
+    geom_density(fill = "grey99", color = "grey")
   alpha_den <- .den_interval(p_alpha, hp_interval, best_alpha)
 
   p_gamma <- data.frame(gamma = gamma_collect_converged) %>% ggplot(aes(x = gamma)) +
@@ -330,11 +336,12 @@ robyn_calibrate_single_dim <- function(
   # qt_coef_out <- .qti(x = coef_collect_converged, interval = hp_interval)
 
   ## plotting & prompting
-  #coef_response <- max(response_cum_sot) / max(response_sot_scaled)
+  # coef_response <- max(response_cum_sot) / max(response_sot_scaled)
   df_sot_plot <- data.frame(
     spend = spend_cum_sot,
     response = response_cum_sot,
-    response_pred = best_pred_response)
+    response_pred = best_pred_response
+  )
   temp_spend <- seq(0, max(spend_cum_sot), length.out = sim_n)
   temp_sat <- best_coef * saturation_hill(x = total_cum_spend, alpha = best_alpha, gamma = best_gamma, x_marginal = temp_spend)[["x_saturated"]]
   df_pred_sim_plot <- data.frame(spend = temp_spend, response = temp_sat)
@@ -368,7 +375,7 @@ robyn_calibrate_single_dim <- function(
       aes(
         x = .data$sim_spend, y = .data$sim_saturation,
         color = .data$sim
-      ), size = 2, alpha = 0.2
+      ), linewidth = 2, alpha = 0.2
     ) +
     scale_colour_grey() +
     geom_point(
@@ -389,14 +396,14 @@ robyn_calibrate_single_dim <- function(
     iterations = unlist(mapply(function(x) seq(x), max_iters_vec, SIMPLIFY = FALSE)),
     trials = as.character(unlist(
       mapply(function(x, y) rep(x, y),
-             x = 1:max_trials, y = max_iters_vec
+        x = 1:max_trials, y = max_iters_vec
       )
     ))
   )
   p_mse <- df_mse %>%
     mutate(trials = factor(.data$trials, levels = seq(max_trials))) %>%
     ggplot(aes(x = .data$iterations, y = .data$mse)) +
-    geom_line(size = 0.2) +
+    geom_line(linewidth = 0.2) +
     facet_grid(.data$trials ~ .) +
     labs(
       title = paste0(
@@ -415,8 +422,10 @@ robyn_calibrate_single_dim <- function(
   p_alpha <- p_alpha +
     labs(
       title = paste0("Alpha (Hill) density after ", round(burn_in_rel * 100), "% burn-in"),
-      subtitle = paste0(round(hp_interval*100), "% center density: ", round(alpha_den$interval[1], 4), "-", round(alpha_den$interval[2], 4),
-                        "\nBest alpha: ", round(best_alpha,4))
+      subtitle = paste0(
+        round(hp_interval * 100), "% center density: ", round(alpha_den$interval[1], 4), "-", round(alpha_den$interval[2], 4),
+        "\nBest alpha: ", round(best_alpha, 4)
+      )
     ) +
     theme_lares(...) +
     scale_y_abbr()
@@ -425,8 +434,10 @@ robyn_calibrate_single_dim <- function(
   p_gamma <- p_gamma +
     labs(
       title = paste0("Gamma (Hill) density after ", round(burn_in_rel * 100), "% burn-in"),
-      subtitle = paste0(round(hp_interval*100), "% center density: ", round(gamma_den$interval[1], 4), "-", round(gamma_den$interval[2], 4),
-                        "\nBest gamma: ", round(best_gamma,4))
+      subtitle = paste0(
+        round(hp_interval * 100), "% center density: ", round(gamma_den$interval[1], 4), "-", round(gamma_den$interval[2], 4),
+        "\nBest gamma: ", round(best_gamma, 4)
+      )
     ) +
     theme_lares(...) +
     scale_y_abbr()
@@ -458,13 +469,15 @@ robyn_calibrate_single_dim <- function(
   }
 
   curve_out <- list(
-    hill = list(alpha_range = c(alpha_den$interval),
-                alpha_best = best_alpha,
-                gamma_range = c(gamma_den$interval),
-                gamma_best = best_gamma,
-                coef_range = c(coef_den$interval),
-                coef_best = best_coef,
-                inflexion_max = total_cum_spend),
+    hill = list(
+      alpha_range = c(alpha_den$interval),
+      alpha_best = best_alpha,
+      gamma_range = c(gamma_den$interval),
+      gamma_best = best_gamma,
+      coef_range = c(coef_den$interval),
+      coef_best = best_coef,
+      inflexion_max = total_cum_spend
+    ),
     plot = p_lines / p_mse / (p_alpha + p_gamma) +
       plot_annotation(
         theme = theme_lares(background = "white", ...)
@@ -482,13 +495,15 @@ robyn_calibrate_single_dim <- function(
   get_den <- ggplot_build(plot_object)$data[[1]]
   # mode_loc <- which.max(get_den$y)
   mode_loc <- which.min(abs(get_den$x - best_val))
-  mode_wing <- sum(get_den$y) * hp_interval /2
+  mode_wing <- sum(get_den$y) * hp_interval / 2
   int_left <- mode_loc - which.min(abs(cumsum(get_den$y[mode_loc:1]) - mode_wing)) + 1
   int_left <- ifelse(is.na(int_left) | int_left < 1, 1, int_left)
-  int_right <- mode_loc + which.min(abs(cumsum(get_den$y[(mode_loc+1):length(get_den$y)]) - mode_wing))
-  int_right <- ifelse(length(int_right) == 0 , length(get_den$y), int_right)
-  return(list(interval = c(get_den$x[int_left],  get_den$x[int_right]),
-              mode = get_den$x[mode_loc]))
+  int_right <- mode_loc + which.min(abs(cumsum(get_den$y[(mode_loc + 1):length(get_den$y)]) - mode_wing))
+  int_right <- ifelse(length(int_right) == 0, length(get_den$y), int_right)
+  return(list(
+    interval = c(get_den$x[int_left], get_den$x[int_right]),
+    mode = get_den$x[mode_loc]
+  ))
 }
 
 

R/R/checks.R

@@ -585,9 +585,11 @@ check_calibration <- function(dt_input, date_var, calibration_input, dayInterval
     }
     all_media <- c(paid_media_spends, organic_vars)
     cal_media <- str_split(calibration_input$channel, "\\+|,|;|\\s")
-    cal_media_selected <- lapply(cal_media, function(x) sapply(x, function(y) {
-      ifelse(y %in% c(paid_media_selected, organic_vars), y, paid_media_selected[paid_media_spends == y])
-    }))
+    cal_media_selected <- lapply(cal_media, function(x) {
+      sapply(x, function(y) {
+        ifelse(y %in% c(paid_media_selected, organic_vars), y, paid_media_selected[paid_media_spends == y])
+      })
+    })
     calibration_input$channel_selected <- sapply(cal_media_selected, function(x) paste0(x, collapse = "+"))
     if (!all(unlist(cal_media) %in% all_media)) {
       these <- unique(unlist(cal_media)[which(!unlist(cal_media) %in% all_media)])
@@ -859,14 +861,14 @@ check_allocator <- function(OutputCollect, select_model, paid_media_selected, sc
     stop("Input 'scenario' must be one of: ", paste(opts, collapse = ", "))
   }
   if ((is.null(channel_constr_low) & !is.null(channel_constr_up)) |
-      (!is.null(channel_constr_low) & is.null(channel_constr_up))) {
+    (!is.null(channel_constr_low) & is.null(channel_constr_up))) {
     stop("channel_constr_low and channel_constr_up must be both provided or both NULL")
   } else if (!is.null(channel_constr_low) & !is.null(channel_constr_up)) {
     if (any(channel_constr_low < 0)) {
       stop("Inputs 'channel_constr_low' must be >= 0")
     }
     if ((length(channel_constr_low) != 1 && length(channel_constr_low) != length(paid_media_selected)) |
-        (length(channel_constr_up) != 1 && length(channel_constr_up) != length(paid_media_selected))) {
+      (length(channel_constr_up) != 1 && length(channel_constr_up) != length(paid_media_selected))) {
       stop("'channel_constr_low' and 'channel_constr_up' require either only 1 value or the same length as 'paid_media_selected'")
     }
     if (any(channel_constr_up < channel_constr_low)) {
@@ -884,10 +886,12 @@ check_metric_type <- function(metric_name, paid_media_spends, paid_media_vars, p
     metric_type <- "organic"
     metric_name_updated <- metric_name
   } else if ((metric_name %in% paid_media_spends && length(metric_name) == 1) |
-             (metric_name %in% paid_media_vars && length(metric_name) == 1)) {
+    (metric_name %in% paid_media_vars && length(metric_name) == 1)) {
     metric_type <- "paid"
-    name_loc <- unique(c(which(metric_name == paid_media_spends),
-                         which(metric_name == paid_media_vars)))
+    name_loc <- unique(c(
+      which(metric_name == paid_media_spends),
+      which(metric_name == paid_media_vars)
+    ))
     metric_name_updated <- paid_media_selected[name_loc]
   } else {
     stop(paste(
@@ -898,8 +902,10 @@ check_metric_type <- function(metric_name, paid_media_spends, paid_media_vars, p
       paste("\n- organic_vars:", v2t(organic_vars, quotes = FALSE))
     ))
   }
-  return(list(metric_type = metric_type,
-              metric_name_updated = metric_name_updated))
+  return(list(
+    metric_type = metric_type,
+    metric_name_updated = metric_name_updated
+  ))
 }
 
 check_metric_dates <- function(date_range = NULL, all_dates, dayInterval = NULL, quiet = FALSE, is_allocator = FALSE, ...) {

R/R/clusters.R

@@ -382,7 +382,7 @@ errors_scores <- function(df, balance = rep(1, 3), ts_validation = TRUE, ...) {
       position = position_nudge(x = -0.02, y = 0.1),
       colour = "grey30", size = 3.5
     ) +
-    geom_vline(xintercept = 1, linetype = "dashed", size = .5, colour = "grey75") +
+    geom_vline(xintercept = 1, linetype = "dashed", linewidth = .5, colour = "grey75") +
     # scale_fill_viridis_c(option = "D") +
     labs(
       title = paste("In-Cluster", temp, "& bootstrapped 95% CI"),

R/R/convergence.R

@@ -159,8 +159,6 @@ robyn_converge <- function(OutputModels,
       x = ifelse(max(nrmse_win) == 1, "NRMSE", sprintf("NRMSE [Winsorized %s]", paste(nrmse_win, collapse = "-"))),
       y = "DECOMP.RSSD",
       colour = "Time [s]",
-      size = "MAPE",
-      alpha = NULL,
       caption = paste(conv_msg, collapse = "\n")
     ) +
     theme_lares(background = "white", )