diff --git a/R/DESCRIPTION b/R/DESCRIPTION index e2a1bce13..bf4c0ec20 100644 --- a/R/DESCRIPTION +++ b/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", , "gufeng@meta.com", c("cre", "aut")), person("Igor", "Skokan", , "igorskokan@meta.com", c("aut")), diff --git a/R/R/allocator.R b/R/R/allocator.R index 7a8c9ea33..51df98746 100644 --- a/R/R/allocator.R +++ b/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,7 +167,7 @@ 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] @@ -172,9 +175,11 @@ robyn_allocator <- function(robyn_object = NULL, ## 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) %>% @@ -182,9 +187,15 @@ robyn_allocator <- function(robyn_object = NULL, 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() diff --git a/R/R/json.R b/R/R/json.R index a828066b7..888556426 100644 --- a/R/R/json.R +++ b/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) diff --git a/R/R/pareto.R b/R/R/pareto.R index b52b2733a..258017065 100644 --- a/R/R/pareto.R +++ b/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, diff --git a/R/R/response.R b/R/R/response.R index bf22fea21..a51698f53 100644 --- a/R/R/response.R +++ b/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,11 +202,13 @@ 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, @@ -214,11 +216,12 @@ robyn_response <- function(InputCollect = NULL, 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,