Otimização de conversão de campanhas de marketing digital de uma empresa anônima

Contexto e objetivo

Uma empresa anônima veiculou 1.143 anúncios no Facebook Ads, distribuídos em 3 campanhas (códigos 916, 936 e 1178). Cada linha da base é um anúncio direcionado a um segmento de público, descrito por idade, gênero e interesse (código da categoria de interesse do usuário no Facebook), além do investimento (Spent) e dos resultados (impressões, cliques e conversões aprovadas).

Duas perguntas de negócio guiam a análise:

O que faz um anúncio converter? Comparamos regressões, culminando em um LASSO com interações, para ranquear os fatores e as combinações de fatores associados à conversão. Isso orienta o desenho dos próximos anúncios.
Qual campanha destinar a cada público? As duas maiores campanhas (936 e 1178) disputam orçamento. Modelamos o uplift relativo entre elas para decidir, segmento a segmento, qual campanha tende a converter mais.

Nota metodológica: os dados são observacionais (não houve sorteio de qual público veria qual campanha) e não existe grupo sem campanha. As implicações disso para a leitura do uplift são discutidas em detalhe na seção de modelagem uplift.

Importação de bibliotecas

library(skimr)
library(tidyverse)
library(tidymodels)
library(GGally)

library(dplyr)
library(tools4uplift)
library(ggplot2)

library(broom)
library(doParallel)
library(vip)

Leitura dos dados

df <- read.csv("KAG_conversion_data.csv") |>
    as_tibble()

df |> glimpse()

## Rows: 1,143
## Columns: 11
## $ ad_id               <int> 708746, 708749, 708771, 708815, 708818, 708820, 70…
## $ xyz_campaign_id     <int> 916, 916, 916, 916, 916, 916, 916, 916, 916, 916, …
## $ fb_campaign_id      <int> 103916, 103917, 103920, 103928, 103928, 103929, 10…
## $ age                 <chr> "30-34", "30-34", "30-34", "30-34", "30-34", "30-3…
## $ gender              <chr> "M", "M", "M", "M", "M", "M", "M", "M", "M", "M", …
## $ interest            <int> 15, 16, 20, 28, 28, 29, 15, 16, 27, 28, 31, 7, 16,…
## $ Impressions         <int> 7350, 17861, 693, 4259, 4133, 1915, 15615, 10951, …
## $ Clicks              <int> 1, 2, 0, 1, 1, 0, 3, 1, 1, 3, 0, 0, 0, 0, 7, 0, 1,…
## $ Spent               <dbl> 1.43, 1.82, 0.00, 1.25, 1.29, 0.00, 4.77, 1.27, 1.…
## $ Total_Conversion    <int> 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,…
## $ Approved_Conversion <int> 1, 0, 0, 0, 1, 1, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1, 0,…

Tratamento dos dados

Frequência dos tipos de campanhas

set.seed(123)

df <- df |>
    mutate(
        across(c(xyz_campaign_id, fb_campaign_id, gender, interest, age), as.factor),
        ad_id = as.character(ad_id),
        across(c(Impressions, Clicks, Total_Conversion, Approved_Conversion), as.integer),
        Spent = as.double(Spent)
    )

table(df$xyz_campaign_id)

## 
##  916  936 1178 
##   54  464  625

# as duas principais campanhas são 936 e 1178; vamos otimizar o melhor público para cada uma delas

Exploração

Sem valores faltantes; as variáveis numéricas apresentam cauda longa (comportamento próximo do exponencial)

df |> skim()

Data summary
Name	df
Number of rows	1143
Number of columns	11
_______________________
Column type frequency:
character	1
factor	5
numeric	5
________________________
Group variables	None

Variable type: character

skim_variable	n_missing	complete_rate	min	max	empty	n_unique	whitespace
ad_id	0	1	6	7	0	1143	0

Variable type: factor

skim_variable	complete_rate	ordered	n_unique	top_counts
xyz_campaign_id	1	FALSE	3	117: 625, 936: 464, 916: 54
fb_campaign_id	1	FALSE	691	144: 6, 144: 6, 144: 6, 144: 6
age	1	FALSE	4	30-: 426, 45-: 259, 35-: 248, 40-: 210
gender	1	FALSE	2	M: 592, F: 551
interest	1	FALSE	40	16: 140, 10: 85, 29: 77, 27: 60

Variable type: numeric

skim_variable	complete_rate	mean	sd	p0	p25	p50	p75	p100	hist
Impressions	1	186732.13	312762.18	87	6503.50	51509.00	221769.00	3052003	▇▁▁▁▁
Clicks	1	33.39	56.89	0	1.00	8.00	37.50	421	▇▁▁▁▁
Spent	1	51.36	86.91	0	1.48	12.37	60.02	640	▇▁▁▁▁
Total_Conversion	1	2.86	4.48	0	1.00	1.00	3.00	60	▇▁▁▁▁
Approved_Conversion	1	0.94	1.74	0	0.00	1.00	1.00	21	▇▁▁▁▁

Analisando granularidade da base

df |> group_by(ad_id) |> summarise(n = n()) |> arrange(desc(n)) |> head(5)

## # A tibble: 5 × 2
##   ad_id       n
##   <chr>   <int>
## 1 1121091     1
## 2 1121092     1
## 3 1121094     1
## 4 1121095     1
## 5 1121096     1

# fb_campaign_id é um identificador interno do Facebook, com granularidade quase igual à do anúncio; não é útil como preditora
df |> group_by(fb_campaign_id) |> summarise(n = n()) |> arrange(desc(n)) |> head(5)

## # A tibble: 5 × 2
##   fb_campaign_id     n
##   <fct>          <int>
## 1 144536             6
## 2 144562             6
## 3 144599             6
## 4 144611             6
## 5 144636             6

Distribuição e interação das variáveis numéricas

ggpairs(df %>% select_if(is.numeric))

Após transformar com log, as distribuições ficam mais próximas de uma normal:

ggpairs(df %>% mutate(across(where(is.numeric), log)) %>% select_if(is.numeric))

Três leituras importantes saem dessa exploração:

Spent, Clicks e Impressions são fortemente correlacionados entre si porque são consequência da veiculação: só existem depois que o anúncio roda. Usá-los para prever conversão em um modelo de planejamento seria vazamento de dados, então ficam fora das preditoras.
Gasto e conversão têm correlação apenas moderada: há dinheiro sendo investido em públicos que não respondem. É exatamente esse desperdício que a segmentação por uplift tenta corrigir.
As variáveis numéricas têm cauda longa; a transformação log(x+1) as aproxima de uma normal e estabiliza a variância. A conversão aprovada é uma contagem pequena (a grande maioria entre 0 e 3), então um modelo de contagem (Poisson) seria uma alternativa natural; mantemos a regressão sobre log(1+y) pela simplicidade e pela leitura direta dos betas.

ggplot(df, aes(x = Approved_Conversion)) +
  stat_density(aes(y = after_stat(density)), geom = "line", color = "blue", adjust = 3) +
  labs(title = "Densidade de Approved_Conversion",
       x = "Approved_Conversion",
       y = "Densidade") +
  theme_minimal()

ggplot(df |> mutate(Approved_Conversion = log(Approved_Conversion+1)), aes(x = Approved_Conversion)) +
  stat_density(aes(y = after_stat(density)), geom = "line", color = "blue", adjust = 3) +
  labs(title = "Densidade da Log de Approved_Conversion",
       x = "Approved_Conversion",
       y = "Densidade") +
  theme_minimal()

df_1 <- df |> mutate(flag_patrocinada = as.factor(ifelse(Spent!=0,1,0)))

Separação em treino e teste

set.seed(123)

split <- initial_split(df_1, prop = 0.8, strata = Approved_Conversion)
treinamento <- training(split)
teste <- testing(split)

Tidymodels

treinamento |> glimpse()

(receita <- recipe(Approved_Conversion ~., data = treinamento) %>%
    step_rm(ad_id, fb_campaign_id, Impressions, Clicks, Total_Conversion) %>% # remove IDs e variáveis que só existem depois da veiculação (vazamento)
    step_zv(all_predictors()) %>% # remove variáveis com um único valor
    step_log(Spent, Approved_Conversion, offset = 1) %>% # log(x+1) para normalizar distribuições
    step_other(all_nominal(), -all_outcomes(), threshold = .02, other = "outros") %>% # agrupa em "outros" categorias com representatividade abaixo de 2%
    step_dummy(all_nominal(), -all_outcomes(), one_hot = TRUE) |>
    step_normalize(all_numeric(), -all_outcomes()) %>%  # normaliza as preditoras: média 0, desvio-padrão 1
    step_zv(all_predictors())
   )

(receita_prep <- prep(receita))

# obtém os dados processados
treinamento_proc <- bake(receita_prep, new_data = NULL)
teste_proc <- bake(receita_prep, new_data = teste)

base_proc <- bake(receita_prep, new_data = df_1)

base_proc |> glimpse()

Modelos de Regressão:

Subimos uma escada de três modelos, cada um respondendo uma pergunta:

Naive (média): qual o erro de não modelar nada? É a régua mínima que qualquer modelo precisa bater.
Regressão linear: quanto os efeitos principais (idade, gênero, interesse, gasto) explicam sozinhos?
LASSO com interações: quanto as combinações de fatores acrescentam, e quais combinações são essas?

O objetivo final é identificar as variáveis e combinações mais importantes para a conversão, para a empresa considerá-las ao desenhar anúncios e selecionar públicos.

Criação de tabela de comparação

desempenho <- tibble()

Modelo Naive/Nulo

desempenho <- desempenho %>%
  bind_rows(tibble(.pred = exp(mean(treinamento_proc$Approved_Conversion))-1,
                   observado = exp(teste_proc$Approved_Conversion)-1,
                   modelo = "Naive"))

desempenho %>%
  group_by(modelo) %>%
  metrics(truth = observado, estimate = .pred) %>%
  dplyr::filter(.metric=='rmse')

## # A tibble: 1 × 4
##   modelo .metric .estimator .estimate
##   <chr>  <chr>   <chr>          <dbl>
## 1 Naive  rmse    standard        1.64

Regressão Linear

logreg_cls_spec <-
  linear_reg() %>%
  set_engine("glm")

set.seed(1)
fit_lm <- logreg_cls_spec %>% fit(Approved_Conversion ~ ., data = treinamento_proc)


desempenho <- desempenho %>%
  bind_rows(tibble(.pred = exp(predict(fit_lm, new_data = teste_proc)$.pred)-1,
                   observado = exp(teste_proc$Approved_Conversion)-1,
                   modelo = "LM"))

desempenho %>%
  group_by(modelo) %>%
  metrics(truth = observado, estimate = .pred) %>%
  dplyr::filter(.metric=='rmse')

## # A tibble: 2 × 4
##   modelo .metric .estimator .estimate
##   <chr>  <chr>   <chr>          <dbl>
## 1 LM     rmse    standard        1.41
## 2 Naive  rmse    standard        1.64

Variáveis mais significativas e seus respectivos betas:

library(broom)
# coeficientes com p-valor < 0,05, em ordem de significância
tidy(fit_lm) |> arrange(p.value) |> filter(p.value < 0.05)

## # A tibble: 10 × 5
##    term                estimate std.error statistic   p.value
##    <chr>                  <dbl>     <dbl>     <dbl>     <dbl>
##  1 (Intercept)           0.473     0.0155     30.5  2.39e-140
##  2 Spent                 0.393     0.0310     12.6  8.06e- 34
##  3 age_X30.34            0.159     0.0214      7.41 2.86e- 13
##  4 flag_patrocinada_X0   0.108     0.0211      5.11 3.99e-  7
##  5 interest_X27         -0.0673    0.0180     -3.75 1.90e-  4
##  6 age_X35.39            0.0748    0.0201      3.72 2.10e-  4
##  7 interest_X22         -0.0507    0.0168     -3.01 2.68e-  3
##  8 gender_F             -0.0401    0.0165     -2.44 1.49e-  2
##  9 age_X40.44            0.0422    0.0193      2.18 2.92e-  2
## 10 interest_X64         -0.0347    0.0175     -1.98 4.76e-  2

Lasso com interação entre variáveis

Por que LASSO com interações, e não uma ANOVA ou regressão comum? Queremos capturar efeitos combinados (por exemplo, um interesse que performa bem apenas em um gênero ou faixa etária específica). Criar todas as interações dois a dois gera dezenas de colunas correlacionadas: em uma regressão comum ou ANOVA os testes perdem poder, os betas ficam instáveis e o modelo decora o ruído. O LASSO resolve isso penalizando a soma dos |betas|: interações sem sinal consistente são zeradas, e sobra um conjunto esparso e legível de efeitos principais e combinações que realmente importam. O preço da penalização é que os betas sobreviventes são encolhidos em direção a zero, então devem ser lidos como ranking de importância e direção do efeito, e não como magnitude causal exata.

Adição de step de interação entre variáveis

(receita <- recipe(Approved_Conversion ~., data = treinamento) %>%
    step_rm(ad_id, fb_campaign_id, Impressions, Clicks, Total_Conversion) %>% # remove IDs e variáveis pós-veiculação (vazamento)
    step_zv(all_predictors()) %>%
    step_log(Spent, Approved_Conversion, offset = 1) %>%
    step_other(all_nominal(), -all_outcomes(), threshold = .02, other = "outros") %>%
    step_dummy(all_nominal(), -all_outcomes(), one_hot = TRUE) |>

    step_interact(~ all_predictors():all_predictors()) %>% # cria interações entre todas as preditoras
    step_zv(all_predictors()) %>%

    step_normalize(all_numeric(), -all_outcomes()) %>%
    step_zv(all_predictors())
   )

(receita_prep <- prep(receita))

# obtém os dados processados
treinamento_proc <- bake(receita_prep, new_data = NULL)
teste_proc <- bake(receita_prep, new_data = teste)
base_proc <- bake(receita_prep, new_data = df_1)

base_proc |> glimpse()

Treinamento do modelo Lasso e visualização da regularização x erro:

set.seed(123)

# Definir os hiperparâmetros para tunagem
LASSO <- linear_reg(penalty = tune(), mixture = 1) %>% # mixture = 1 é lasso, 0 é ridge; penalty é o lambda
  set_engine("glmnet") %>%
  set_mode("regression")

# validação cruzada de 10 folds para escolher o lambda
cv_split <- vfold_cv(treinamento, v = 10)

# Paralelização
doParallel::registerDoParallel(makeCluster(16))

tempo <- system.time({
  LASSO_grid <- tune_grid(LASSO,
                         receita,
                         resamples = cv_split,
                         grid = 100,
                         metrics = metric_set(rmse))
})

autoplot(LASSO_grid)  # Plota os resultados do grid search

Visualização do grid de resultados

LASSO_grid %>%
  collect_metrics() %>%
  arrange(mean) |>
  head(6)

## # A tibble: 6 × 7
##   penalty .metric .estimator  mean     n std_err .config               
##     <dbl> <chr>   <chr>      <dbl> <int>   <dbl> <chr>                 
## 1 0.0148  rmse    standard   0.463    10  0.0135 Preprocessor1_Model082
## 2 0.0102  rmse    standard   0.464    10  0.0125 Preprocessor1_Model081
## 3 0.0167  rmse    standard   0.464    10  0.0139 Preprocessor1_Model083
## 4 0.00858 rmse    standard   0.465    10  0.0122 Preprocessor1_Model080
## 5 0.0200  rmse    standard   0.466    10  0.0145 Preprocessor1_Model084
## 6 0.00667 rmse    standard   0.467    10  0.0119 Preprocessor1_Model079

Dispersão entre valores preditos e observados:

# Seleciona o melhor conjunto de hiperparâmetros
best_LASSO <- LASSO_grid %>%
  select_best(metric = "rmse")

# Faz o fit do modelo com o melhor conjunto de hiperparâmetros
LASSO_fit <- finalize_model(LASSO, parameters = best_LASSO) %>%
  fit(Approved_Conversion ~ ., data = treinamento_proc)

# plot predito vs realizado
LASSO_fit %>%
  predict(new_data = teste_proc) %>%
  mutate(.pred = exp(.pred)-1,
         observado = exp(teste_proc$Approved_Conversion)-1,
         modelo = "LASSO") %>%
  ggplot(aes(x = observado, y = .pred)) +
  geom_point(size = 1, col = "blue") +
  geom_abline(intercept = 0,
              slope = 1,
              color = "red",
              linetype = "dashed",
              linewidth = 0.7) +
  labs(y = "predito LASSO", x = "Observado") +
  theme_bw()

Preditoras mais importantes pelo método da função vip (quando são alteradas aleatoriamente, mais aumentam o erro na predição):

# visualizando variáveis mais importantes
vip(LASSO_fit)

Variáveis mais importantes, pelo método de maiores betas absolutos:

# como as preditoras foram normalizadas, os |betas| são comparáveis entre si
tidy(LASSO_fit) |> filter(estimate != 0 & term!= "(Intercept)") |> arrange(desc(abs(estimate))) |> slice(1:8) |> select(term, estimate)

## # A tibble: 8 × 2
##   term                                        estimate
##   <chr>                                          <dbl>
## 1 Spent_x_xyz_campaign_id_X1178                 0.268 
## 2 Spent_x_age_X30.34                            0.113 
## 3 Spent_x_interest_X29                          0.0703
## 4 xyz_campaign_id_X1178_x_flag_patrocinada_X1  -0.0496
## 5 gender_M_x_interest_X27                      -0.0435
## 6 Spent_x_interest_X22                         -0.0337
## 7 Spent_x_age_X35.39                            0.0328
## 8 xyz_campaign_id_X1178                        -0.0320

Comparativo dos modelos

O melhor modelo foi o LASSO com interação entre variáveis

# coloca previsões no tibble de resultados
desempenho <- desempenho %>%
  bind_rows(tibble(.pred = exp(predict(LASSO_fit, new_data = teste_proc)$.pred)-1,
                   observado = exp(teste_proc$Approved_Conversion)-1,
                   modelo = "LASSO -interação"))

desempenho %>%
  group_by(modelo) %>%
  metrics(truth = observado, estimate = .pred) %>%
  dplyr::filter(.metric=='rmse')

## # A tibble: 3 × 4
##   modelo           .metric .estimator .estimate
##   <chr>            <chr>   <chr>          <dbl>
## 1 LASSO -interação rmse    standard        1.36
## 2 LM               rmse    standard        1.41
## 3 Naive            rmse    standard        1.64

Visualização das variáveis mais importantes, pelo método de maiores betas absolutos do melhor modelo:

dados <- tidy(LASSO_fit) |>
  filter(estimate != 0 & term != "(Intercept)") |>
  arrange(desc(abs(estimate))) |>
  slice(1:6) |>
  select(term, estimate)

dados$color <- ifelse(dados$estimate > 0, "beta positivo", "beta negativo")


ggplot(dados, aes(x = reorder(term, abs(estimate)), y = abs(estimate), fill = color)) +
  geom_bar(stat = "identity") +
  coord_flip() +
  labs(x = "Parâmetros", y = "Magnitude do  beta", fill = "") +
  theme_minimal() +
  theme(axis.text.y = element_text(face = "bold"),
        text = element_text(size = 10))

Como ler esse gráfico: termos com _x_ são interações selecionadas pelo LASSO, ou seja, combinações de público cujo efeito vai além da soma das partes. O gasto (Spent) interagindo com atributos de segmento indica onde investimento adicional rende mais conversão; interações entre atributos demográficos e de interesse revelam nichos com resposta acima (beta positivo) ou abaixo (beta negativo) do esperado pelos efeitos isolados. É exatamente o tipo de leitura que uma regressão sem interações, ou uma ANOVA saturada e sem regularização, não entrega com estabilidade.

Agora que sabemos as variáveis mais importantes para conversão, podemos considerá-las ao planejar campanhas futuras. No entanto, ainda não sabemos otimizar o público para as diferentes campanhas. Para isso, vamos modelar o uplift entre as duas principais campanhas da empresa.

Modelagem Uplift

O que estamos estimando (e o que não estamos)

No uplift clássico compara-se um grupo tratado (que recebeu a ação, por exemplo um e-mail) com um grupo controle que não recebeu ação nenhuma. Isso permite estimar o efeito incremental de agir versus não agir e separar os clientes nos quatro perfis célebres: persuadáveis, os que convertem de qualquer jeito, causas perdidas e os que reagem mal ao contato.

Aqui a situação é diferente em dois pontos, e vale ser explícito sobre ambos:

Não existe grupo sem campanha na base. Todos os anúncios pertencem a alguma campanha. Vamos rotular a campanha 936 como referência (treat = 0) e a 1178 como tratamento (treat = 1), mas isso é convenção: o que o modelo estima é o uplift relativo entre duas ações, tau(x) = P(converter | 1178, x) - P(converter | 936, x). A pergunta respondida é “qual das duas campanhas converte mais para este perfil de público”, e não “quanto a campanha adiciona sobre não anunciar”. Para a decisão de negócio em questão (dividir o público entre as duas campanhas), é exatamente a quantidade certa.
A atribuição não foi randomizada. Os públicos das duas campanhas podem diferir sistematicamente (é o viés de seleção típico de dados observacionais). Por isso, logo abaixo, verificamos o balanceamento das covariáveis entre os grupos antes de modelar, e tratamos as conclusões como condicionais ao perfil observado. A validação definitiva de qualquer política de alocação derivada daqui seria um teste A/B randomizado.

Dessas observações decorrem duas decisões de modelagem:

Usamos como preditoras apenas atributos definidos antes da veiculação: idade, gênero e interesse. O gasto (Spent) é realizado depois da atribuição da campanha e é afetado por ela (é um mediador do efeito); condicionar nele distorceria a comparação entre campanhas, então ele fica fora do modelo de uplift.
Filtramos anúncios com Spent > 0: um anúncio nunca veiculado não carrega informação sobre a resposta do público. A ressalva é que isso condiciona a análise aos anúncios efetivamente entregues.

Frequência e custo por conversão das campanhas:

table(df$xyz_campaign_id)

## 
##  916  936 1178 
##   54  464  625

cat("% de representatividade das campanhas 1178 e 936 em relação ao total de anúncios: ", (1-(54/(625+464)))*100)

## % de representatividade das campanhas 1178 e 936 em relação ao total de anúncios:  95.04

# custo por conversão aprovada de cada campanha: contexto de negócio para o uplift
df |>
  filter(xyz_campaign_id %in% c(936, 1178)) |>
  group_by(xyz_campaign_id) |>
  summarise(anuncios = n(),
            gasto_total = sum(Spent),
            conversoes = sum(Approved_Conversion),
            custo_por_conversao = gasto_total / conversoes)

## # A tibble: 2 × 5
##   xyz_campaign_id anuncios gasto_total conversoes custo_por_conversao
##   <fct>              <int>       <dbl>      <int>               <dbl>
## 1 936                  464       2893.        183                15.8
## 2 1178                 625      55662.        872                63.8

df1 <- df |> filter(xyz_campaign_id %in% c(1178, 936) & Spent > 0) |>  # somente as campanhas comparadas e anúncios efetivamente veiculados
  mutate(treat = as.integer(if_else(xyz_campaign_id== 1178, 1, 0))) |>
  select(age, gender, interest, Approved_Conversion, treat)

A campanha 1178 é maior e gasta muito mais por conversão que a 936. Isso reforça a pergunta do uplift: se parte do público da 1178 converteria igual (ou mais) na 936, há orçamento sendo desperdiçado.

Verificando similaridade entre os grupos (referência vs tratamento)

Antes de modelar, comparamos a composição dos públicos das duas campanhas. Se os grupos fossem muito diferentes, parte do “efeito de campanha” seria na verdade efeito de composição de público, e é justamente isso que o modelo com covariáveis tenta ajustar.

balanco <- df1 |>
  mutate(campanha = ifelse(treat == 1, "1178", "936")) |>
  select(campanha, age, gender, interest) |>
  pivot_longer(-campanha, names_to = "variavel", values_to = "categoria") |>
  count(campanha, variavel, categoria) |>
  group_by(campanha, variavel) |>
  mutate(prop = n / sum(n)) |>
  ungroup()

# composição por idade e gênero
balanco |>
  filter(variavel %in% c("age", "gender")) |>
  ggplot(aes(x = categoria, y = prop, fill = campanha)) +
  geom_col(position = "dodge") +
  facet_wrap(~variavel, scales = "free_x") +
  scale_y_continuous(labels = scales::percent) +
  labs(x = "", y = "participação no público da campanha", fill = "campanha") +
  theme_minimal()

Diferença padronizada de médias (SMD) por categoria: a regra de bolso em inferência causal é que SMD abaixo de 0,10 indica bom balanceamento e acima de 0,25 indica desbalanceamento relevante.

smd_tab <- balanco |>
  select(-n) |>
  pivot_wider(names_from = campanha, values_from = prop, values_fill = 0) |>
  mutate(smd = abs(`1178` - `936`) / sqrt((`1178`*(1-`1178`) + `936`*(1-`936`))/2)) |>
  arrange(desc(smd))

smd_tab |> head(10)

## # A tibble: 10 × 5
##    variavel categoria `1178`  `936`   smd
##    <chr>    <fct>      <dbl>  <dbl> <dbl>
##  1 interest 16        0.0620 0.233  0.496
##  2 gender   F         0.444  0.618  0.355
##  3 gender   M         0.556  0.382  0.355
##  4 interest 10        0.0555 0.118  0.224
##  5 interest 66        0.0163 0      0.182
##  6 interest 27        0.0424 0.0833 0.169
##  7 interest 107       0.0131 0      0.163
##  8 interest 110       0.0131 0      0.163
##  9 interest 21        0.0343 0.0104 0.162
## 10 interest 32        0.0326 0.0104 0.153

smd_tab |>
  mutate(rotulo = paste0(variavel, ": ", categoria)) |>
  slice(1:10) |>
  ggplot(aes(x = reorder(rotulo, smd), y = smd)) +
  geom_col(fill = "steelblue") +
  geom_hline(yintercept = 0.10, linetype = "dashed", color = "darkgreen") +
  geom_hline(yintercept = 0.25, linetype = "dashed", color = "red") +
  coord_flip() +
  labs(x = "", y = "SMD (diferença padronizada entre campanhas)",
       title = "Top 10 categorias mais desbalanceadas entre 936 e 1178") +
  theme_minimal()

Leitura: os públicos não são equivalentes. O interesse 16 (23% do público da 936 contra 6% da 1178, SMD 0,50) e o gênero (a 936 é 62% feminina, a 1178 é 44%, SMD 0,36) passam bem do limiar de 0,25. Isso confirma que uma comparação bruta das taxas de conversão entre campanhas seria enganosa. Como essas variáveis desbalanceadas estão no modelo, o uplift condicional ajusta a comparação dentro de cada perfil; ainda assim, é mais um motivo para confirmar as recomendações com randomização antes de realocar todo o orçamento.

Transformação da variável resposta

Transformação da variável resposta em binária (se houve ou não venda para o anúncio)

df2 <- df1  |> mutate(conversion = as.integer(ifelse(Approved_Conversion>0,1,0)))

df2 |> glimpse()

## Rows: 901
## Columns: 6
## $ age                 <fct> 30-34, 30-34, 30-34, 35-39, 35-39, 35-39, 35-39, 3…
## $ gender              <fct> M, M, M, M, M, M, M, M, M, M, M, F, F, F, F, F, F,…
## $ interest            <fct> 10, 15, 29, 10, 16, 20, 27, 28, 29, 29, 29, 10, 16…
## $ Approved_Conversion <int> 1, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 1, 1, 0, 3, 1, 0,…
## $ treat               <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,…
## $ conversion          <int> 1, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 1, 1, 0, 1, 1, 0,…

Separação em treino e teste

set.seed(123)

split <- initial_split(df2, prop = 0.8, strata = Approved_Conversion)
treinamento <- training(split)
teste <- testing(split)

Tidymodels

Tratamento dos dados pré modelagem estatística

(receita <- recipe(conversion + treat ~., data = treinamento) %>%
    step_rm(Approved_Conversion) %>% # a resposta do uplift é a versão binária (conversion)
    step_zv(all_predictors()) %>%
    step_other(all_nominal(), -all_outcomes(), threshold = .02, other = "outros") %>% # agrupa categorias com menos de 2% em "outros"
    step_dummy(all_nominal(), -all_outcomes(), one_hot = TRUE) |>
    step_zv(all_predictors())
   )

(receita_prep <- prep(receita))

# obtém os dados processados
treinamento_proc <- bake(receita_prep, new_data = NULL)
teste_proc <- bake(receita_prep, new_data = teste)

treinamento_proc |> glimpse()

Treina modelo de interuplift

O InterUplift ajusta uma regressão logística com o tratamento interagindo com todas as covariáveis:

\[logit \, P(conversao) = \beta_0 + \sum_j \beta_j X_j + \beta_T \, treat + \sum_j \beta_{Tj} \,(X_j \times treat)\]

O uplift previsto de cada anúncio é a diferença entre as probabilidades preditas com treat = 1 e com treat = 0. É o mesmo espírito do LASSO com interações da seção anterior, mas aqui as interações que interessam são as do tratamento com o perfil.

table(treinamento_proc$treat, treinamento_proc$conversion)

preditoras <- setdiff(names(treinamento_proc), c("conversion", "treat"))

fit_interuplift <- InterUplift(data=treinamento_proc, treat="treat", outcome="conversion", predictors=preditoras, input = "all")
print(fit_interuplift)

Resumo do modelo

summary(fit_interuplift)

## 
## Call:
## InterUplift(data = treinamento_proc, treat = "treat", outcome = "conversion", 
##     predictors = preditoras, input = "all")
## 
## Coefficients: (6 not defined because of singularities)
##                        Estimate Std. Error z value Pr(>|z|)
## (Intercept)             -0.1798     0.5903   -0.30     0.76
## treat                    0.2107     0.6482    0.33     0.75
## age_X30.34               0.0541     0.3720    0.15     0.88
## age_X35.39               0.2000     0.4201    0.48     0.63
## age_X40.44              -0.2035     0.4487   -0.45     0.65
## age_X45.49                   NA         NA      NA       NA
## gender_F                -0.2468     0.3012   -0.82     0.41
## gender_M                     NA         NA      NA       NA
## interest_X2            -15.3143  1026.2781   -0.01     0.99
## interest_X10             0.3124     0.6861    0.46     0.65
## interest_X15            -0.1776     0.8564   -0.21     0.84
## interest_X16            -0.1244     0.6163   -0.20     0.84
## interest_X18            -0.6159     0.8721   -0.71     0.48
## interest_X19             1.4981     1.2853    1.17     0.24
## interest_X20            -0.0585     0.8021   -0.07     0.94
## interest_X21           -15.2912  1027.3793   -0.01     0.99
## interest_X22            -0.5564     1.0190   -0.55     0.59
## interest_X25             0.3495     1.1587    0.30     0.76
## interest_X26            -0.5106     0.8875   -0.58     0.57
## interest_X27            -0.7015     0.7719   -0.91     0.36
## interest_X28            -0.0397     0.7851   -0.05     0.96
## interest_X29            -0.2268     0.7252   -0.31     0.75
## interest_X32            16.0746  1026.1507    0.02     0.99
## interest_X63            -0.8550     0.8592   -1.00     0.32
## interest_X64            -0.5669     0.8836   -0.64     0.52
## interest_outros              NA         NA      NA       NA
## treat:age_X30.34         0.5797     0.4609    1.26     0.21
## treat:age_X35.39         0.0750     0.5087    0.15     0.88
## treat:age_X40.44         0.5000     0.5342    0.94     0.35
## treat:age_X45.49             NA         NA      NA       NA
## treat:gender_F           0.3003     0.3621    0.83     0.41
## treat:gender_M               NA         NA      NA       NA
## treat:interest_X2       15.4431  1026.2782    0.02     0.99
## treat:interest_X10       0.6463     0.8261    0.78     0.43
## treat:interest_X15       0.9986     1.0457    0.95     0.34
## treat:interest_X16       1.2107     0.7862    1.54     0.12
## treat:interest_X18       1.6033     1.1002    1.46     0.15
## treat:interest_X19      -1.3945     1.3729   -1.02     0.31
## treat:interest_X20       0.9622     1.0005    0.96     0.34
## treat:interest_X21      14.8845  1027.3794    0.01     0.99
## treat:interest_X22      -0.8301     1.1597   -0.72     0.47
## treat:interest_X25      -1.0835     1.2849   -0.84     0.40
## treat:interest_X26      -0.0865     1.0621   -0.08     0.94
## treat:interest_X27       0.1605     0.9000    0.18     0.86
## treat:interest_X28      -0.2526     0.9481   -0.27     0.79
## treat:interest_X29       1.4567     0.8928    1.63     0.10
## treat:interest_X32     -15.4649  1026.1509   -0.02     0.99
## treat:interest_X63       1.6573     1.0150    1.63     0.10
## treat:interest_X64       0.5138     1.0277    0.50     0.62
## treat:interest_outros        NA         NA      NA       NA
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 990.51  on 719  degrees of freedom
## Residual deviance: 885.77  on 676  degrees of freedom
## AIC: 973.8
## 
## Number of Fisher Scoring iterations: 14

Estudo de parâmetros e fatores mais determinantes

Como ler os coeficientes desse modelo:

Efeitos principais (beta_base): descrevem o perfil de conversão na campanha de referência (936).
Interações com o tratamento (beta_int, termos treat:X): são os drivers do uplift. Dizem como a resposta daquela categoria muda na 1178 em relação à 936. Interação positiva: o segmento responde melhor à 1178; negativa: melhor à 936.
O efeito da categoria dentro da campanha 1178 é a soma beta_base + beta_int.
Dois cuidados de leitura: o one-hot cria dummies redundantes que o glm descarta (aparecem como NA no summary, funcionando como categorias de referência), e categorias com pouquíssimos anúncios podem exibir separação perfeita (betas na casa de 15 com erro-padrão gigante); filtramos esses artefatos da análise.

summary_fit <- summary(fit_interuplift)

coefficients <- summary_fit$coefficients
coefficients_df <- as.data.frame(coefficients)

preditoras_nm <- rownames(coefficients_df)
coefficients_df$preditoras <- preditoras_nm
rownames(coefficients_df) <- NULL

colnames(coefficients_df)[which(names(coefficients_df) == "Pr(>|z|)")] <- "p.value"
colnames(coefficients_df)[which(names(coefficients_df) == "Estimate")] <- "beta"

coefficients_df <- coefficients_df[, c("preditoras", "beta", "p.value")]

# separa efeitos principais e interações com o tratamento
principais <- coefficients_df |>
  filter(!grepl(":", preditoras) & !preditoras %in% c("(Intercept)", "treat")) |>
  transmute(categoria = preditoras, beta_base = beta, p_base = p.value)

interacoes <- coefficients_df |>
  filter(grepl(":", preditoras)) |>
  transmute(categoria = str_extract(preditoras, "(?<=:).*"),
            beta_int = beta, p_int = p.value)

drivers <- principais |>
  left_join(interacoes, by = "categoria") |>
  mutate(
    beta_1178 = beta_base + coalesce(beta_int, 0), # efeito da categoria dentro da campanha 1178
    recomendacao = case_when(
      is.na(beta_int)  ~ "sem sinal de diferença",
      beta_int > 0     ~ "responde melhor à 1178",
      TRUE             ~ "responde melhor à 936"
    )
  ) |>
  arrange(p_int)

# top 8 drivers de uplift por menor p-valor da interação
# (filtrando dummies redundantes e categorias com separação perfeita)
drivers_top <- drivers |>
  filter(!is.na(beta_int), abs(beta_int) < 5) |>
  slice_min(p_int, n = 8)

drivers_top |>
  select(categoria, beta_base, beta_int, beta_1178, p_int, recomendacao)

##      categoria beta_base beta_int beta_1178  p_int           recomendacao
## 1 interest_X63  -0.85498   1.6573    0.8023 0.1025 responde melhor à 1178
## 2 interest_X29  -0.22677   1.4567    1.2299 0.1028 responde melhor à 1178
## 3 interest_X16  -0.12436   1.2107    1.0863 0.1236 responde melhor à 1178
## 4 interest_X18  -0.61594   1.6033    0.9874 0.1450 responde melhor à 1178
## 5   age_X30.34   0.05408   0.5797    0.6338 0.2085 responde melhor à 1178
## 6 interest_X19   1.49808  -1.3945    0.1036 0.3098  responde melhor à 936
## 7 interest_X20  -0.05845   0.9622    0.9038 0.3362 responde melhor à 1178
## 8 interest_X15  -0.17764   0.9986    0.8210 0.3396 responde melhor à 1178

drivers_top |>
  ggplot(aes(x = reorder(categoria, beta_int), y = beta_int,
             fill = beta_int > 0)) +
  geom_col() +
  coord_flip() +
  scale_fill_manual(values = c("TRUE" = "darkgreen", "FALSE" = "firebrick"),
                    labels = c("TRUE" = "melhor na 1178", "FALSE" = "melhor na 936")) +
  labs(x = "", y = "beta da interação com o tratamento (driver do uplift)",
       fill = "", title = "Top 8 drivers de resposta diferente entre as campanhas") +
  theme_minimal()

Duas observações honestas sobre essa tabela:

Com ~720 anúncios no treino, nenhuma interação isolada atinge significância convencional (todos os p-valores ficam acima de 0,05). Isso não invalida o modelo: em uplift, a validação relevante é do ranking agregado que as interações produzem juntas (curvas de uplift e Qini no teste, logo abaixo), não do teste de hipótese de cada coeficiente. Os drivers acima devem ser lidos como direcionais.
A versão anterior desta análise ranqueava a diferença beta_base - beta_int, o que mistura a propensão de base com a heterogeneidade do efeito. A quantidade que responde “para quem a 1178 funciona melhor que a 936” é o próprio beta da interação, e é ela que usamos aqui.

Quantidade de anúncios do treino com maior probabilidade prevista de converter na 1178 do que na 936 (uplift previsto > 0):

predictions <- predict.InterUplift(fit_interuplift, newdata=treinamento_proc, treat= "treat", outcome="conversion")

predictions |> as.vector() |> as_tibble() |> mutate(flag = ifelse(value>0, 1,0))  |> pull(flag) |> table()

## 
##   0   1 
##  78 642

Resumo das probabilidades de uplift

treinamento_proc$predito <- predictions |> as.vector()

summary(predictions)

##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##  -0.345   0.126   0.264   0.253   0.407   0.700

Visualização do uplift (treino, para escolher o corte)

plot(PerformanceUplift(data = treinamento_proc, treat= "treat", outcome="conversion", prediction="predito", nb.group = 20))

## [1] 3.641

Tabela de uplift para diferentes pontos de corte do público, ordenado do mais provável de converter com a campanha 1178 para o menos provável. O ganho incremental acumulado cresce rápido até cerca de 60% do público, entra em platô na faixa de 22% a 25% e, no fim da fila, os grupos marginais alternam uplift observado negativo: exatamente o público que tende a responder melhor à 936. Adotamos o corte operacional de 75% para a 1178 e 25% para a 936, no início do platô, e validamos esse corte no conjunto de teste adiante.

PerformanceUplift(data = treinamento_proc, treat= "treat", outcome="conversion", prediction="predito", nb.group = 20)

##       Targeted Population (%) Incremental Uplift (%) Observed Uplift (%)
##  [1,]                    0.05                  2.624              53.247
##  [2,]                    0.10                  5.204              52.000
##  [3,]                    0.15                  5.223              23.636
##  [4,]                    0.20                  8.130              61.893
##  [5,]                    0.25                  9.921              39.441
##  [6,]                    0.30                  9.456               6.667
##  [7,]                    0.35                 11.196              40.217
##  [8,]                    0.40                 12.857              43.316
##  [9,]                    0.45                 14.673              28.788
## [10,]                    0.50                 15.327              37.778
## [11,]                    0.55                 17.215              48.000
## [12,]                    0.60                 19.409              16.248
## [13,]                    0.65                 20.351             -33.333
## [14,]                    0.70                 22.006              39.394
## [15,]                    0.75                 22.184               3.788
## [16,]                    0.80                 23.188              16.711
## [17,]                    0.85                 24.380              31.724
## [18,]                    0.90                 25.092              23.214
## [19,]                    0.95                 24.577             -26.667
## [20,]                    1.00                 25.439             -32.258
## attr(,"class")
## [1] "print.PerformanceUplift"

PerformanceUplift(data = treinamento_proc, treat= "treat", outcome="conversion", prediction="predito", nb.group = 100) %>%
  {tibble(cum_per = .$cum_per, uplift = .$uplift)} %>%
  ggplot(aes(x = cum_per, y = uplift)) +
  geom_point() +
  geom_smooth(method = "lm",formula = y~x, se = TRUE) +
  theme_minimal() +
  labs(x = "Cumulative Percentage", y = "Uplift", title = "Uplift vs Cumulative Percentage")

Verificando se o modelo está bem ajustado

Toda a avaliação a seguir usa o conjunto de teste, que o modelo não viu no ajuste. Verificamos:

Se os casos apontados como melhores para a campanha 1178 realmente convertem mais nela do que na 936.
Se os casos apontados como melhores para a campanha 936 realmente convertem mais nela do que na 1178.

Curva de uplift e coeficiente de Qini no teste

predictions_teste <- predict.InterUplift(fit_interuplift, newdata=teste_proc, treat= "treat", outcome="conversion")
teste_proc$predito <- predictions_teste |> as.vector()

perf_teste <- PerformanceUplift(data = teste_proc, treat= "treat", outcome="conversion",
                                prediction="predito", nb.group = 10)
plot(perf_teste)

## [1] 4.262

cat("Coeficiente de Qini no teste:", QiniArea(perf_teste))

## Coeficiente de Qini no teste: 4.262

O coeficiente de Qini resume a curva: é a área entre a curva de ganho incremental do modelo e a reta da alocação aleatória. Qini positivo significa que ordenar o público pelo uplift previsto captura mais conversões incrementais do que distribuir as campanhas ao acaso.

Método 1: alocação pelo sinal do uplift previsto

Uplift previsto > 0: público recomendado para a campanha 1178

teste_proc_1 <- teste_proc |> mutate(treat = (ifelse(treat == 1, "1178", "936")))
teste_proc_1 <- teste_proc_1 |> mutate(conversion = ifelse(conversion == 1, "vendeu", "falhou"))

teste_proc_1178 <- teste_proc_1 |> filter(predito>0)
teste_proc_936 <- teste_proc_1 |> filter(predito<0)

round(prop.table(table(teste_proc_1178$treat, teste_proc_1178$conversion), margin = 1) * 100, 2) # público recomendado para 1178

##       
##        falhou vendeu
##   1178  36.79  63.21
##   936   57.41  42.59

Uplift previsto ≤ 0: público recomendado para a campanha 936

round(prop.table(table(teste_proc_936$treat, teste_proc_936$conversion), margin = 1) * 100, 2) # público recomendado para 936

##       
##        falhou vendeu
##   1178  52.94  47.06
##   936   50.00  50.00

Leitura das tabelas: dentro de cada grupo recomendado, comparamos a taxa de venda observada de quem de fato recebeu cada campanha. O padrão esperado de um modelo bem ajustado é a campanha recomendada apresentar taxa de venda maior que a alternativa dentro do seu próprio grupo.

Método 2: alocação pelo corte de maior ganho incremental (75/25, definido no treino)

75% dos casos mais prováveis para a campanha 1178:

base_proc_1_sorted <- teste_proc_1 |> arrange(desc(predito))

index_75 <- ceiling(nrow(base_proc_1_sorted) * 0.75)

teste_proc_1178 <- base_proc_1_sorted |> slice(1:index_75)
teste_proc_936 <- base_proc_1_sorted |> slice((index_75 + 1):n())

round(prop.table(table(teste_proc_1178$treat, teste_proc_1178$conversion), margin = 1) * 100, 2) # público recomendado para 1178

##       
##        falhou vendeu
##   1178  33.33  66.67
##   936   59.62  40.38

25% dos casos menos prováveis para a campanha 936

round(prop.table(table(teste_proc_936$treat, teste_proc_936$conversion), margin = 1) * 100, 2) # público recomendado para 936

##       
##        falhou vendeu
##   1178  51.28  48.72
##   936   33.33  66.67

O método 2 se provou o melhor critério de separação de público entre as campanhas, com uma inversão limpa no teste: no grupo destinado à 1178, quem recebeu a 1178 vendeu em 66,7% dos anúncios contra 40,4% de quem recebeu a 936; no grupo destinado à 936, a relação se inverte (66,7% de venda sob a 936 contra 48,7% sob a 1178). É exatamente o comportamento que um modelo de uplift bem ajustado deveria capturar. Como os grupos não são perfeitamente balanceados (seção de similaridade), a confirmação final deve vir de um experimento randomizado.

Considerações Finais

Recomendação para a empresa:

Desenhar os anúncios levando em consideração os principais fatores e interações do LASSO
Segmentar o público entre as campanhas 1178 e 936 utilizando a predição do uplift (corte 75/25 como ponto de partida)
Retroalimentar os modelos com os novos anúncios realizados

Limitações e próximos passos:

O uplift aqui é relativo entre duas campanhas ativas. Para medir o efeito incremental de anunciar versus não anunciar, é preciso reservar um grupo holdout sem exposição na próxima rodada.
Os dados são observacionais. A política de alocação sugerida deve ser validada com um teste A/B: randomizar qual campanha cada segmento recebe e comparar com a alocação do modelo.
Conversão não é lucro. O passo seguinte é incorporar o custo por conversão de cada campanha por segmento, transformando a decisão de “quem converte mais” em “onde cada real investido rende mais”.

Otimização de conversão de campanhas de marketing digital de uma empresa anônima

Arnaldo Chebl

2023-06-19 · revisão metodológica em 2026-07-06

Contexto e objetivo

Importação de bibliotecas

Leitura dos dados

Tratamento dos dados

Exploração

Separação em treino e teste

Tidymodels

Modelos de Regressão:

Criação de tabela de comparação

Modelo Naive/Nulo

Regressão Linear

Lasso com interação entre variáveis

Comparativo dos modelos

Modelagem Uplift

O que estamos estimando (e o que não estamos)

Verificando similaridade entre os grupos (referência vs tratamento)

Transformação da variável resposta

Separação em treino e teste

Tidymodels

Treina modelo de interuplift

Estudo de parâmetros e fatores mais determinantes

Visualização do uplift (treino, para escolher o corte)

Verificando se o modelo está bem ajustado

Curva de uplift e coeficiente de Qini no teste

Método 1: alocação pelo sinal do uplift previsto

Método 2: alocação pelo corte de maior ganho incremental (75/25, definido no treino)

Considerações Finais