Detecção de Fraudes no Tráfego de Cliques em Propagandas de Aplicações Mobile

INTRODUÇÃO:

O risco de fraude está em toda parte, mas para as empresas que anunciam online, a fraude de cliques pode acontecer em um volume avassalador, resultando em dados de cliques enganosos e dinheiro desperdiçado. Os canais de anúncios podem aumentar os custos simplesmente quando pessoas ou bots clicam nos anúncios em grande escala, o que na prática não gera o resultado esperado. Com mais de 1 bilhão de dispositivos móveis em uso todos os meses, a China é o maior mercado móvel do mundo e, portanto, sofre com grandes volumes de tráfego fraudulento.

A TalkingData (https://www.talkingdata.com), a maior plataforma de Big Data independente da China, cobre mais de 70% dos dispositivos móveis ativos em todo o país. Eles lidam com 3 bilhões de cliques por dia, dos quais 90% são potencialmente fraudulentos. Sua abordagem atual para impedir fraudes de cliques para desenvolvedores de aplicativos é medir a jornada do clique de um usuário em todo o portfólio e sinalizar endereços IP que produzem muitos cliques, mas nunca acabam instalando aplicativos. Com essas informações, eles criaram uma lista negra de IPs e uma lista negra de dispositivos.

Embora bem-sucedidos, eles querem estar sempre um passo à frente dos fraudadores e pediram a sua ajuda para desenvolver ainda mais a solução. Você está desafiado a criar um algoritmo que possa prever se um usuário fará o download de um aplicativo depois de clicar em um anúncio de aplicativo para dispositivos móveis.

PROBLEMA DE NEGÓCIO:

Construir um modelo de machine learning cujo preveja se um clique é fraudulento ou nao.

SOBRE O DATASET:

O dataset utilizado aqui, faz parte de uma das competições presentes no kaggle: https://www.kaggle.com/c/talkingdata-adtracking-fraud-detection/data

DICIONÁRIO DE DADOS:

ip: endereço IP de clique
app: ID do aplicativo
device: ID do tipo de celular do usuário
os: ID da versão do celular
channel: ID do canal do editor de anúncios
click_time: data e hora do clique
attribute_time: horario de dowload do app caso o usuario o tenha baixado depois de clicar no anuncio.
is_attributed: 1 se o aplicativo foi baixado e 0 se nao foi baixado.

DIRETÓRIO DE TRABALHO:

setwd("E:/projetos/concluidos/deteccao_de_fraudes_no_trafego_de_cliques")

LIBRARYS:

pacman::p_load(tidyverse, caTools, corrplot, caret, data.table,knitr, gridExtra,gmodels, class,e1071,ROCR)

CARREGANDO DATASETS:

list.files()

##  [1] "deteccao_de_fraudes.html" "deteccao_de_fraudes.R"   
##  [3] "deteccao_de_fraudes.Rmd"  "Projeto01.pdf"           
##  [5] "sample_submission.csv"    "test.csv"                
##  [7] "test_supplement.csv"      "teste.csv"               
##  [9] "train.csv"                "train_sample.csv"        
## [11] "treino.csv"

df <- fread("train.csv");dim(df);table(df$is_attributed)

## [1] 184903890         8

## 
##         0         1 
## 184447044    456846

Para mantermos o balanceamento da nossa amostra, vamos subsetar outro dataset com 137k de observacoes considerando is_attibruted == 0. Em seguida vamos pré-visualizar nossos dados.

df2 <- df %>% 
  filter(is_attributed == 1) %>% 
  sample_frac(0.3);dim(df2)

## [1] 137054      8

df <- df %>% filter(is_attributed == 0);dim(df)

## [1] 184447044         8

df <- df[1:137054,];dim(df)

## [1] 137054      8

df <- rbind(df,df2);kable(head(df));kable(tail(df));glimpse(df)

ip	app	device	os	channel	click_time
83230	3	1	13	379	2017-11-06 14:32:21
17357	3	1	19	379	2017-11-06 14:33:34
35810	3	1	13	379	2017-11-06 14:34:12
45745	14	1	13	478	2017-11-06 14:34:52
161007	3	1	13	379	2017-11-06 14:35:08
18787	3	1	16	379	2017-11-06 14:36:26

ip	app	device	os	channel	click_time	attributed_time	is_attributed
194316	51	0	24	203	2017-11-07 11:27:48	2017-11-07 11:30:00	1
332494	148	1	19	213	2017-11-08 17:42:31	2017-11-08 17:45:09	1
106223	107	1	19	171	2017-11-08 00:32:19	2017-11-08 04:14:33	1
355151	29	1	19	213	2017-11-08 23:13:03	2017-11-08 23:17:05	1
146712	10	1	37	113	2017-11-07 05:07:58	2017-11-07 05:08:29	1
291965	19	78	0	333	2017-11-09 13:03:49	2017-11-09 13:04:29	1

## Rows: 274,108
## Columns: 8
## $ ip              <int> 83230, 17357, 35810, 45745, 161007, 18787, 103022, ...
## $ app             <int> 3, 3, 3, 14, 3, 3, 3, 3, 3, 64, 3, 3, 3, 3, 3, 3, 3...
## $ device          <int> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, ...
## $ os              <int> 13, 19, 13, 13, 13, 16, 23, 19, 13, 22, 25, 13, 19,...
## $ channel         <int> 379, 379, 379, 478, 379, 379, 379, 379, 379, 459, 3...
## $ click_time      <chr> "2017-11-06 14:32:21", "2017-11-06 14:33:34", "2017...
## $ attributed_time <chr> "", "", "", "", "", "", "", "", "", "", "", "", "",...
## $ is_attributed   <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ...

PRÉ-PROCESSAMENTO:

Verificando se há valores NA no dataset:

colSums(is.na(df))

##              ip             app          device              os         channel 
##               0               0               0               0               0 
##      click_time attributed_time   is_attributed 
##               0               0               0

Dropando colunas que nao iremos utilizar, e criando novas variáveis.

df <- df %>% 
  mutate_if(is.integer,as.factor) %>% 
  select(c(-attributed_time)) %>% 
  mutate_if(is.character,as.POSIXct) %>% 
  mutate(hora_click = as.factor(hour(click_time)),
         dia_click = as.factor(weekdays(click_time))) %>% 
  select(c(-click_time));kable(head(df));glimpse(df)

ip	app	device	os	channel	hora_click	dia_click
83230	3	1	13	379	14	segunda-feira
17357	3	1	19	379	14	segunda-feira
35810	3	1	13	379	14	segunda-feira
45745	14	1	13	478	14	segunda-feira
161007	3	1	13	379	14	segunda-feira
18787	3	1	16	379	14	segunda-feira

## Rows: 274,108
## Columns: 8
## $ ip            <fct> 83230, 17357, 35810, 45745, 161007, 18787, 103022, 11...
## $ app           <fct> 3, 3, 3, 14, 3, 3, 3, 3, 3, 64, 3, 3, 3, 3, 3, 3, 3, ...
## $ device        <fct> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,...
## $ os            <fct> 13, 19, 13, 13, 13, 16, 23, 19, 13, 22, 25, 13, 19, 1...
## $ channel       <fct> 379, 379, 379, 478, 379, 379, 379, 379, 379, 459, 379...
## $ is_attributed <fct> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,...
## $ hora_click    <fct> 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 1...
## $ dia_click     <fct> segunda-feira, segunda-feira, segunda-feira, segunda-...

ANÁLISE EXPLORATÓRIA:

df3 <- df2 %>% 
  mutate_if(is.integer,as.factor) %>% 
  mutate_if(is.character,as.POSIXct) %>% 
  mutate(hora_click = as.factor(hour(click_time)),
         dia_click = as.factor(weekdays(click_time)),
         hora_attributed = as.factor(hour(attributed_time)),
         dia_attributed = as.factor(weekdays(attributed_time))) %>% 
  select(ip,app,device,os,channel,dia_click,hora_click,dia_attributed,hora_attributed,is_attributed);kable(head(df3));glimpse(df3)

ip	app	device	os	channel	dia_click	hora_click	dia_attributed	hora_attributed	is_attributed
268216	22	1	19	116	quinta-feira	2	quinta-feira	2	1
49573	9	1	22	134	terça-feira	3	terça-feira	4	1
304621	3	1	13	137	quarta-feira	21	quinta-feira	14	1
344851	5	1	43	113	quinta-feira	7	quinta-feira	7	1
355265	191	33	29	414	quinta-feira	2	quinta-feira	2	1
110300	45	1	77	419	quinta-feira	10	quinta-feira	10	1

## Rows: 137,054
## Columns: 10
## $ ip              <fct> 268216, 49573, 304621, 344851, 355265, 110300, 1303...
## $ app             <fct> 22, 9, 3, 5, 191, 45, 9, 108, 45, 35, 35, 19, 29, 4...
## $ device          <fct> 1, 1, 1, 1, 33, 1, 1, 1, 1, 1, 1, 60, 1, 1, 1, 1, 0...
## $ os              <fct> 19, 22, 13, 43, 29, 77, 19, 18, 61, 14, 22, 38, 8, ...
## $ channel         <fct> 116, 134, 137, 113, 414, 419, 466, 243, 419, 274, 2...
## $ dia_click       <fct> quinta-feira, terça-feira, quarta-feira, quinta-fei...
## $ hora_click      <fct> 2, 3, 21, 7, 2, 10, 12, 2, 12, 9, 5, 10, 21, 17, 7,...
## $ dia_attributed  <fct> quinta-feira, terça-feira, quinta-feira, quinta-fei...
## $ hora_attributed <fct> 2, 4, 14, 7, 2, 10, 13, 3, 12, 9, 6, 10, 22, 14, 10...
## $ is_attributed   <fct> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, ...

p1 <- ggplot(df3, aes(x=dia_click))+
  geom_bar(fill = "lightblue")+theme_minimal()+labs(x = "Dia",title="Click por dia")
p2 <- ggplot(df3, aes(x=dia_attributed))+
  geom_bar(fill = "lightgreen")+theme_minimal()+labs(x = "Dia",title = "Download por dia")
grid.arrange(p1,p2,nrow=2)

Segunda-feira é o pior dia, tanto quando falamos em downloads quando falamos em clicks.

É possível notar também que existe um padrão quanto ao comportamento de ambas as amostras.

Vamos analisar quais são os números de “os” dos usuários que mais efetuam downloads.

df_os <- df3 %>% group_by(os) %>%  summarize(n = n()) %>%  arrange(desc(n));df_os <- df_os[1:10,]

## `summarise()` ungrouping output (override with `.groups` argument)

df_os_na <- df3 %>% group_by(os) %>%  summarize(n = n()) %>%  arrange(desc(n));df_os <- df_os[1:10,]

## `summarise()` ungrouping output (override with `.groups` argument)

p4 <- ggplot(df_os, aes(x = reorder(os,n),y=n))+
  geom_col(fill = "steelblue")+theme_minimal()+labs(x = "os",title = "Numero de dowloads por tipo de os (top 10)")

grid.arrange(p4,nrow=1)

Os usuário que possuem o os numero 19 e 13 são os que mais efetuam downloads.

Vamos ver também como fica a relação entre a hora do click e a hora em que foram realizados os downloads.

A ideia aqui, é tentar identificar se há algum padrão.

p5 <- ggplot(df3, aes(x = hora_click))+
  geom_histogram(stat = "count",fill = "steelblue")+theme_minimal()+labs(x = "Hora",title = "Click por hora")

## Warning: Ignoring unknown parameters: binwidth, bins, pad

p6 <- ggplot(df3, aes(x = hora_attributed))+
  geom_histogram(stat = "count",fill = "lightgreen")+theme_minimal()+labs(x = "Hora",title = "Download por hora")

## Warning: Ignoring unknown parameters: binwidth, bins, pad

grid.arrange(p5,p6,nrow=1)

Embora existam algumas diferencas entre o horário de click e de download (especialmente entre a faixa de 0 a 4), pode-se dizer que as amostras possuem o mesmo padrao.

DADOS DE TREINO E DE TESTE:

glimpse(df)

## Rows: 274,108
## Columns: 8
## $ ip            <fct> 83230, 17357, 35810, 45745, 161007, 18787, 103022, 11...
## $ app           <fct> 3, 3, 3, 14, 3, 3, 3, 3, 3, 64, 3, 3, 3, 3, 3, 3, 3, ...
## $ device        <fct> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,...
## $ os            <fct> 13, 19, 13, 13, 13, 16, 23, 19, 13, 22, 25, 13, 19, 1...
## $ channel       <fct> 379, 379, 379, 478, 379, 379, 379, 379, 379, 459, 379...
## $ is_attributed <fct> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,...
## $ hora_click    <fct> 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 1...
## $ dia_click     <fct> segunda-feira, segunda-feira, segunda-feira, segunda-...

df_final <- df %>% select(1:5,7,8,6) %>% 
  mutate(ip = as.numeric(ip),
         hora_click = as.numeric(hora_click),
         device = as.numeric(device),
         os = as.numeric(os),
         channel = as.numeric(channel),
         is_attributed = as.factor(is_attributed),
         dia_click = as.factor(dia_click),
         app = as.numeric(app))

sample <- sample.split(df_final$ip, SplitRatio = 0.7)
treino <- subset(df_final,sample == TRUE)
teste <- subset(df_final,sample == FALSE)

kable(head(treino));kable(head(teste))

ip	app	device	os	channel	hora_click	dia_click
16323	4	2	14	114	15	segunda-feira
6925	4	2	14	114	15	segunda-feira
3717	4	2	17	114	15	segunda-feira
22430	4	2	20	114	15	segunda-feira
38575	4	2	14	114	15	segunda-feira
14604	57	2	23	148	15	segunda-feira

ip	app	device	os	channel	hora_click	dia_click
3392	4	2	20	114	15	segunda-feira
8903	15	2	14	156	15	segunda-feira
36881	4	2	14	114	15	segunda-feira
20141	4	2	24	114	15	segunda-feira
20718	4	2	14	114	15	segunda-feira
54258	4	2	20	114	15	segunda-feira

SEPARANDO OS ATRIBUTOS E AS CLASSES:

teste.att <- data.frame(teste[,-8])
teste.class <- data.frame(teste[,8])

FEATURE SELECTION:

Vamos utilizar o algoritimo “trainControl” para nos indicar as variáveis mais relevantes para a construção do modelo preditivo.

formula <- "is_attributed~."
formula <- as.formula(formula)
control <- trainControl(method = "repeatedcv", number = 10, repeats = 2 )
model <- train(formula, data = treino, method = "glm", trControl = control)

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

## Warning: glm.fit: fitted probabilities numerically 0 or 1 occurred

importance <- varImp(model,scale = FALSE)
plot(importance)

CONSTRUINDO O MODELO COM AS VARIÁVEIS SELECIONADAS:

formula.new <- "is_attributed~app+ip+channel+os"
formula.new <- as.formula(formula.new)
modelo <- glm(formula=formula.new,data=treino,family = "binomial");summary(modelo)

## 
## Call:
## glm(formula = formula.new, family = "binomial", data = treino)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -6.3638  -0.7556   0.0845   0.6915   2.4287  
## 
## Coefficients:
##               Estimate Std. Error  z value Pr(>|z|)    
## (Intercept) -2.685e+00  1.929e-02 -139.175  < 2e-16 ***
## app          9.188e-02  5.933e-04  154.857  < 2e-16 ***
## ip           4.868e-05  2.842e-07  171.334  < 2e-16 ***
## channel     -3.398e-03  1.480e-04  -22.965  < 2e-16 ***
## os           2.368e-03  3.954e-04    5.989 2.11e-09 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 290981  on 211128  degrees of freedom
## Residual deviance: 193505  on 211124  degrees of freedom
## AIC: 193515
## 
## Number of Fisher Scoring iterations: 6

PREVENDO E AVALIANDO O MODELO:

previsoes <- round(predict(modelo, teste, "response"))
previsoes_new <- round(as.data.frame(predict(modelo, teste, "response")))
colnames(previsoes_new) <- "previsoes";previsoes_new$previsoes <- as.factor(previsoes_new$previsoes)

CONFUSION MATRIX E AVALIAÇÃO DO RESULTADO:

confusionMatrix(table(data = previsoes_new$previsoes,reference = teste.class$is_attributed), positive = "1")

## Confusion Matrix and Statistics
## 
##     reference
## data     0     1
##    0 33804  8840
##    1  7167 13168
##                                           
##                Accuracy : 0.7458          
##                  95% CI : (0.7424, 0.7492)
##     No Information Rate : 0.6506          
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.431           
##                                           
##  Mcnemar's Test P-Value : < 2.2e-16       
##                                           
##             Sensitivity : 0.5983          
##             Specificity : 0.8251          
##          Pos Pred Value : 0.6476          
##          Neg Pred Value : 0.7927          
##              Prevalence : 0.3494          
##          Detection Rate : 0.2091          
##    Detection Prevalence : 0.3229          
##       Balanced Accuracy : 0.7117          
##                                           
##        'Positive' Class : 1               
##

Analisando pela confusion matrix, pode-se dizer que nosso modelo teve um bom indice de acurácia (0.7434).

O número de falsos negativos e falsos posivos também foram baixos.

AVALIAÇÃO COM A CURVA ROC:

previsoes <- predict(modelo,teste.att,"response")
avaliacao <- prediction(previsoes, teste.class)

plot.roc.curve <- function(predictions, title.text){
  perf <- performance(predictions, "tpr", "fpr")
  plot(perf,col = "black",lty = 1, lwd = 2,
       main = title.text, cex.main = 0.6, cex.lab = 0.8,xaxs = "i", yaxs = "i")
  abline(0,1, col = "red")
  auc <- performance(predictions,"auc")
  auc <- unlist(slot(auc, "y.values"))
  auc <- round(auc,2)
  legend(0.4,0.4,legend = c(paste0("AUC: ",auc)), cex = 0.6, bty = "n", box.col = "white")
  
}

par(mfrow = c(1,1))
plot.roc.curve(avaliacao,title.text = "Curva Roc")

A curva ROC, valida nossa afirmação anterior, apresentando AUC = 0.78.

O que é muito bom.

linkedin/in/sandropenha

github.com/sandropenha