Este relatório contém a manipulação do dataset referente a competição do kaggle IEEE-CIS Fraud Detection e será utilizado para realização do projeto final da disciplina de Redes Neurais do curso de estatística da UFPE no período de 2019.2. A métrica de performance para averiguar o desempenho dos modelos será a AUC.
Carregando os dados e entendendo o dataset
O dataset em questão trata-se de um problema de detecção de fraude, portanto, temos um desfecho binário em que, quando a variável isFraud assume valores iguais a 1, indica que a transação foi fraudulenta, e 0 caso contrário.
suppressMessages(suppressWarnings(require(tidyverse)))
train <- read_csv("/opt/datasets/heitor/train_transaction.csv")## Parsed with column specification:
## cols(
## .default = col_double(),
## ProductCD = col_character(),
## card4 = col_character(),
## card6 = col_character(),
## P_emaildomain = col_character(),
## R_emaildomain = col_character(),
## M1 = col_logical(),
## M2 = col_logical(),
## M3 = col_logical(),
## M4 = col_character(),
## M5 = col_logical(),
## M6 = col_logical(),
## M7 = col_logical(),
## M8 = col_logical(),
## M9 = col_logical()
## )## See spec(...) for full column specifications.## Parsed with column specification:
## cols(
## .default = col_double(),
## id_12 = col_character(),
## id_15 = col_character(),
## id_16 = col_character(),
## id_23 = col_character(),
## id_27 = col_character(),
## id_28 = col_character(),
## id_29 = col_character(),
## id_30 = col_character(),
## id_31 = col_character(),
## id_33 = col_character(),
## id_34 = col_character(),
## id_35 = col_logical(),
## id_36 = col_logical(),
## id_37 = col_logical(),
## id_38 = col_logical(),
## DeviceType = col_character(),
## DeviceInfo = col_character()
## )
## See spec(...) for full column specifications.Descrição de algumas variáveis:
1.TransactionDT: Intervalo de duração da transação (unidade de medida não específicada);
2.TransactionAMT: Valor do pagamento da transação em USD;
3.ProductCD: Código do produto para cada transação;
4.card1 - card6: Informações do cartão de pagamento, como tipo de cartão, categoria do cartão, banco emissor, país etc;
5.addr: endereço
6.dist1 e dist2: Alguma distância (não específicado);
7.P_ e (R__) domínio de email: Domínio de email do comprador e do destinatário;
8.C1-C14: Contagem de quantos endereços estão associados ao cartão de pagamento, etc (O significado real é mascarado);
9.D1-D15: Tempo entre transações anteriores, etc;
10.M1-M9: Correspondência, como nomes no cartão e endereço, etc;
11.Variáveis que iniciam com V: o Vesta projetou recursos avançados, incluindo classificação, contagem e outras relações de entidade.
Encontrando as melhores variáveis
O dataset de treino disponibilizado contem 590540 transações, sendo a proporção geral de fraudes igual a 0.03499, que é bastante baixo (não sei se é baixo para problemas desse tipo). Uma taxa de fraude dessas será um desafio, pois possivelmente poucas variáveis servirão para discriminar os fraudulentos dos não fraudulentos, sendo necessário uma AED detalhada.
# Separando em treino e teste
set.seed(14122019)
i_test <- sample(1:nrow(train),size = nrow(train)*0.3)
i_train <- setdiff(1:nrow(train),i_test)
test <- train[i_test,]
train <- train[i_train,]Primeiro, vamos analisar o conjunto de variáveis C1 até C14. Muito provavelmente elas terão a mesma relação com a variável resposta. Logo, é interessante criar novas variáveis que sejam a combinação linear destas 14. Para isso, utilizarei a técnica de componentes principais.
C1_14 <- princomp(select(train,C1,C2,C3,C4,C5,C6,
C7,C8,C9,C10,C11,C12,
C13,C14),cor = TRUE)
summary(C1_14)## Importance of components:
## Comp.1 Comp.2 Comp.3 Comp.4
## Standard deviation 3.1861003 1.5650166 0.9999302 0.52270653
## Proportion of Variance 0.7250882 0.1749484 0.0714186 0.01951587
## Cumulative Proportion 0.7250882 0.9000366 0.9714552 0.99097102
## Comp.5 Comp.6 Comp.7 Comp.8
## Standard deviation 0.280436728 0.159042129 0.1052425308 0.0725186213
## Proportion of Variance 0.005617483 0.001806743 0.0007911422 0.0003756393
## Cumulative Proportion 0.996588506 0.998395249 0.9991863911 0.9995620304
## Comp.9 Comp.10 Comp.11 Comp.12
## Standard deviation 0.0471208881 0.0408529437 3.350985e-02 2.482463e-02
## Proportion of Variance 0.0001585984 0.0001192116 8.020784e-05 4.401875e-05
## Cumulative Proportion 0.9997206288 0.9998398404 9.999200e-01 9.999641e-01
## Comp.13 Comp.14
## Standard deviation 1.972892e-02 1.066918e-02
## Proportion of Variance 2.780215e-05 8.130811e-06
## Cumulative Proportion 9.999919e-01 1.000000e+00Veja que a variância explicada pelas 2 primeiras componentes é de 90%, o que irá preservar bastante a estrutura de variabilidade destas variáveis. Agora, irei estudar como é dada a relação entre as componentes 1 e 2 e o alvo. Para isso, utilizarei modelos GAM, que são modelos não-paramétricos que estimam a relação existente entre duas variáveis númericas.
# Relacao das Componentes
train %>%
ggplot(aes(c1_141,isFraud)) +
geom_smooth(method = "gam",method.args = list(family = "binomial")) +
theme_minimal() # Componente 1 possui clientes que nao fraudam
train %>%
ggplot(aes(c1_142,isFraud)) +
geom_smooth(method = "gam",method.args = list(family = "binomial")) +
theme_minimal() # Componente 2 os clientes fraudam ate certo ponto
Podemos ver que as duas componentes apresentam uma relação estritamente crescente com o alvo. Veja que a para a componente 2, a estimativa de probabilidade começa a crescer consideravelmente após próximas do valor zero, ou seja, somente para alguns casos ela será útil para discriminar os fraudulentos.
# Funcoes uteis
poe_NA <- function(x){
return( if_else(is.na(x)==T,"NA",as.character(x)) )
}
train <- train %>%
mutate(card1 = as.character(card1),
card2 = as.character(card2),
card3 = as.character(card3),
card5 = as.character(card5)) %>%
mutate_if(is.character,poe_NA)
# Agrupando as informacoes do cartao de credito por risco
faz_tabela <- function(x,y){
tab <- table(x,y)
ptab <- tab/rowSums(tab)
resu <- cbind(tab[,1],ptab[,1],tab[,2],ptab[,2])
colnames(resu) <- c("N(0)","P(0)","N(1)","P(1)")
return( resu )
}Agora, irei estudar as variáveis com informação dos cartões de crédito. No total temos 6 variáveis, contudo, algumas delas possuem um número muito grande de categorias. Por exemplo, a variável card1 possui 12331 categorias diferentes. Sendo assim, é factível reduzir a dimensão do problema. Para isso irei utilizar o algoritmo k-means a partir da taxa de fraude calculada para cada categoria utilizando a função que criei denominada faz_tabela. A função faz_tabela possui como output uma tabela de contingência. Vamos analisar as variáveis card4 e card6 que possuem poucas categorias para entender o que minha função faz.
c1 <- faz_tabela(train$card1,train$isFraud)
c2 <- faz_tabela(train$card2,train$isFraud)
c3 <- faz_tabela(train$card3,train$isFraud)
c4 <- faz_tabela(train$card4,train$isFraud)
c5 <- faz_tabela(train$card5,train$isFraud)
c6 <- faz_tabela(train$card6,train$isFraud)
c4 %>% knitr::kable(digits = 2,format = "html",row.names = TRUE)| N(0) | P(0) | N(1) | P(1) | |
|---|---|---|---|---|
| american express | 5596 | 0.97 | 154 | 0.03 |
| discover | 4359 | 0.92 | 357 | 0.08 |
| mastercard | 127976 | 0.97 | 4582 | 0.03 |
| NA | 1074 | 0.97 | 31 | 0.03 |
| visa | 259851 | 0.97 | 9398 | 0.03 |
| N(0) | P(0) | N(1) | P(1) | |
|---|---|---|---|---|
| charge card | 10 | 1.00 | 0 | 0.00 |
| credit | 97347 | 0.93 | 7011 | 0.07 |
| debit | 300404 | 0.98 | 7482 | 0.02 |
| debit or credit | 22 | 1.00 | 0 | 0.00 |
| NA | 1073 | 0.97 | 29 | 0.03 |
Pode-se notar que, card4 indica a bandeira dos cartões. Além disso, a bandeira discover possue uma taxa elevada de fraudes (em comparação com os demais). Já para card6, esse parece trazer a informação do tipo de cartão utilizado e, quanto a isso, temos elevada taxa de fraude para cartões de crédtio, sendo que, cartões do tipo charge card e de débito ou crédito não apresentaram fraudes.
Agora, vamos para o k-means. Para definir o número de clusters, irei utilizar o gráfico elbow e observar até qual número de clusters a soma de quadrados diminue de forma consistente. Quando esta soma diminuir muito pouco de um número de cluster para outro, eu definirei a quantidade de clusters sendo o número ao qual não a ganhos significantes. Para facilitar os cálculos e deixar o código mais limpo, criei a função faz_elbow.
faz_elbow <- function(d,n = 10){
k <- numeric()
for(i in 1:n){
k[i] <- kmeans(d,centers = i)$tot.withinss
}
data.frame(k = 1:n,
SQ = k) %>%
ggplot(aes(k,SQ)) +
geom_point(size = 3) +
theme_minimal()
}
faz_elbow(c1[,4],n = 10) # k = 3
Veja que para todas as variáveis de cartão eu escolhi 3 clusters. Agora, vamos criar os agrupamentos. Para isso, criei a função faz_kmeans. Ela irá retornar um vetor com os clusters anexado a cada tabela de contingência. Além disso, um print é dado com as informações da média de cada cluster. Essa função irá facilitar muito colocar os clusters na base de treino pois me possibilita fazer vários joins simultâneos.
faz_kmeans <- function(d,y=4,k = 3){
set.seed(14122019)
cc1 <- kmeans(d[,4],centers = k)
tab <- cbind(d,k = cc1$cluster) %>%
as.data.frame.array()
colnames(tab)[y] <- "p"
print( tab %>%
group_by(k) %>%
summarise(pFraud = mean(p),
nCategories = n()) )
return(tab)
}
c1 <- faz_kmeans(c1,4,3)## # A tibble: 3 x 3
## k pFraud nCategories
## <dbl> <dbl> <int>
## 1 1 0.00403 11728
## 2 2 0.950 227
## 3 3 0.324 376## # A tibble: 3 x 3
## k pFraud nCategories
## <dbl> <dbl> <int>
## 1 1 0.237 29
## 2 2 0.0712 62
## 3 3 0.00912 410## # A tibble: 3 x 3
## k pFraud nCategories
## <dbl> <dbl> <int>
## 1 1 1 5
## 2 2 0.0208 97
## 3 3 0.323 7## # A tibble: 3 x 3
## k pFraud nCategories
## <dbl> <dbl> <int>
## 1 1 0.00558 92
## 2 2 0.0773 21
## 3 3 0.361 3c1 <- c1 %>%
mutate(cat = rownames(c1)) %>%
transmute(cat1 = cat,
kcard1 = k)
c2 <- c2 %>%
mutate(cat = rownames(c2)) %>%
transmute(cat2 = cat,
kcard2 = k)
c3 <- c3 %>%
mutate(cat = rownames(c3)) %>%
transmute(cat3 = cat,
kcard3 = k)
c5 <- c5 %>%
mutate(cat = rownames(c5)) %>%
transmute(cat5 = cat,
kcard5 = k)
train <- train %>%
mutate(card1 = as.character(card1),
card2 = as.character(card2),
card3 = as.character(card3),
card5 = as.character(card5)) %>%
left_join(c1,by = c("card1" = "cat1")) %>%
left_join(c2,by = c("card2" = "cat2")) %>%
left_join(c3,by = c("card3" = "cat3")) %>%
left_join(c5,by = c("card5" = "cat5"))
train %>%
group_by(kcard1) %>%
summarise(pFraud = mean(isFraud),
n = n()) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| kcard1 | pFraud | n | |
|---|---|---|---|
| 1 | 1 | 0.02 | 393552 |
| 2 | 2 | 0.88 | 592 |
| 3 | 3 | 0.24 | 19234 |
train %>%
group_by(kcard2) %>%
summarise(pFraud = mean(isFraud),
n = n()) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| kcard2 | pFraud | n | |
|---|---|---|---|
| 1 | 1 | 0.22 | 14729 |
| 2 | 2 | 0.06 | 81037 |
| 3 | 3 | 0.02 | 317612 |
train %>%
group_by(kcard3) %>%
summarise(pFraud = mean(isFraud),
n = n()) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| kcard3 | pFraud | n | |
|---|---|---|---|
| 1 | 1 | 1.00 | 8 |
| 2 | 2 | 0.04 | 413276 |
| 3 | 3 | 0.28 | 94 |
train %>%
group_by(kcard5) %>%
summarise(pFraud = mean(isFraud),
n = n()) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| kcard5 | pFraud | n | |
|---|---|---|---|
| 1 | 1 | 0.03 | 353645 |
| 2 | 2 | 0.08 | 59714 |
| 3 | 3 | 0.32 | 19 |
Note que eu reduzi a dimensão para cada variável card, contudo, ainda possuo muitas, sendo que algumas possuem uma quantidade amostral muito baixa. Sendo assim, irei utilizar a técnica de análise de correspondência múltipla para unir as variáveis card de acordo com a associação entre elas.
library(FactoMineR)
cards <- MCA(train %>%
select(starts_with("kcard"),"card4","card6") %>%
mutate_all(as.factor),ncp = 2,graph = FALSE)
factoextra::fviz_mca_var(cards)
Note que parecem haver agrupamentos naturais das variáveis e suas categorias. Vamos então utilizar o k-means novamente.
set.seed(14122019)
cardsg <- kmeans(cards$var$coord,centers = 3)
cardsgD <- data.frame(as.data.frame.array(cards$var$coord),k = cardsg$cluster,var = rownames(cards$var$coord))
factoextra::fviz_mca_var(cards,col.var = factor(cardsgD$k))
# Jutando tudo
train <- train %>%
mutate(cards = case_when(card4=="NA"|card6=="NA"~"NA",
kcard1==3|kcard2==1|kcard5==3|card4=="discover"|card6=="charge card"~"card1")) %>%
mutate(cards = if_else(is.na(cards)==TRUE,"card2",cards))
train %>%
group_by(cards) %>%
summarise(n = n(),
isFraud = mean(isFraud)) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| cards | n | isFraud | |
|---|---|---|---|
| 1 | card1 | 26807 | 0.20 |
| 2 | card2 | 385461 | 0.02 |
| 3 | NA | 1110 | 0.03 |
Veja que a categoria NA possui uma quantidade amostral mt baixa e que sua taxa de fraude se assemelha bastante a taxa do grupo card1. Daí, irei juntar tais categorias em uma única, totalizando agora 2 classes. Veja que tinhamos milhares de classes distribuídas em 6 variáveis categoricas e agora temos somente 1 variável categorica com 2 únicas classes. Isso é genial !!!
train <- train %>%
mutate(cards = if_else(cards=="NA"|cards=="card2","card1","card2"))
train %>%
group_by(cards) %>%
summarise(n = n(),
isFraud = mean(isFraud)) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| cards | n | isFraud | |
|---|---|---|---|
| 1 | card1 | 386571 | 0.02 |
| 2 | card2 | 26807 | 0.20 |
Agora, analisando a variável referente ao montante de transação.
train %>%
ggplot(aes(TransactionAmt,isFraud)) +
geom_smooth(method = "gam",method.args = list(family = "binomial")) +
theme_minimal()
Observe que, para esta configuração quão maior for o montante da transação, maior o risco de fraude, entretando, observando o gráfico a seguir veremos algo bastante diferente.
train %>%
ggplot(aes(TransactionAmt,isFraud,colour = cards)) +
geom_smooth(method = "gam",method.args = list(family = "binomial")) +
theme_minimal()## Warning in gam.fit3(x = args$X, y = args$y, sp = lsp, Eb = args$Eb, UrS =
## args$UrS, : Algorithm did not converge
Veja como a relação anterior estava mascarada. Agora, para pequenos valores de transação, há um risco decrescente de fraude.
Agora, analisarei a variável TransactionDT.
train %>%
ggplot(aes(TransactionDT,isFraud)) +
geom_smooth(method = "gam",method.args = list(family = "binomial")) +
theme_minimal() # Serve para nada
train %>%
ggplot(aes(TransactionDT,isFraud,colour = cards)) +
geom_smooth(method = "gam",method.args = list(family = "binomial")) +
theme_minimal() # Talvez sirva
Veja que sozinha ela não serve para muita coisa, contudo, combinada a variável dos cartões, talvez seja útil.
Agora, a variável ProductCDserá analisada.
faz_tabela(train$ProductCD,train$isFraud) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| N(0) | P(0) | N(1) | P(1) | |
|---|---|---|---|---|
| C | 42500 | 0.88 | 5694 | 0.12 |
| H | 22013 | 0.95 | 1071 | 0.05 |
| R | 25356 | 0.96 | 973 | 0.04 |
| S | 7654 | 0.94 | 466 | 0.06 |
| W | 301333 | 0.98 | 6318 | 0.02 |
Note que para as categorias S e C, há uma taxa alta de fraudes. Esta será bastante útil para a modelagem.
Agora, investigando as variáveis de distância, dist1 e dist2, é possível observar que ambas possuem muitos valores faltantes. Supondo que tais valores sejam para pessoas que não se deslocaram para lugar algum, irei substituir os valores faltantes por 0.
## Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
## 0.0 3.0 8.0 117.8 24.0 10286.0 246729## Min. 1st Qu. Median Mean 3rd Qu. Max. NA's
## 0.0 7.0 36.0 230.5 206.0 11623.0 386918train <- train %>%
mutate(dist1 = if_else(is.na(dist1),0,dist1),
dist2 = if_else(is.na(dist2),0,dist2))
train %>%
ggplot(aes(dist1,isFraud)) +
geom_smooth(method = "gam",method.args = list(family = "binomial")) +
theme_minimal() # Serve para nada
train %>%
ggplot(aes(dist2,isFraud)) +
geom_smooth(method = "gam",method.args = list(family = "binomial")) +
theme_minimal() # Serve muito
Irei utilizar na modelagem a variável dist2 devido as estimativas de probabilidade serem consideráveis.
Seguindo, analisarei as variáveis referentes ao dominio dos emails.
## # A tibble: 3 x 3
## k pFraud nCategories
## <dbl> <dbl> <int>
## 1 1 0.111 6
## 2 2 0.385 1
## 3 3 0.0143 53
## # A tibble: 3 x 3
## k pFraud nCategories
## <dbl> <dbl> <int>
## 1 1 0.283 3
## 2 2 0.963 1
## 3 3 0.0199 57p_dominio <- p_dominio %>%
transmute(k_p_dominio = k,
domain = rownames(p_dominio))
r_dominio <- r_dominio %>%
transmute(k_r_dominio = k,
domain = rownames(r_dominio))
train <- train %>%
left_join(p_dominio,by = c("P_emaildomain" = "domain")) %>%
left_join(r_dominio,by = c("R_emaildomain" = "domain"))
train %>%
group_by(k_r_dominio) %>%
summarise(n = n(),
isFraud = mean(isFraud)) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| k_r_dominio | n | isFraud | |
|---|---|---|---|
| 1 | 1 | 1858 | 0.18 |
| 2 | 2 | 27 | 0.96 |
| 3 | 3 | 411493 | 0.03 |
train %>%
group_by(k_p_dominio) %>%
summarise(n = n(),
isFraud = mean(isFraud)) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| k_p_dominio | n | isFraud | |
|---|---|---|---|
| 1 | 1 | 5236 | 0.10 |
| 2 | 2 | 52 | 0.38 |
| 3 | 3 | 408090 | 0.03 |
Observando os agrupamento, algo nítido é que existem categorias com alto nível de fraude, entretanto, a quantidade de transações destas é muito baixo inviabilizando a inserção destas variáveis na modelagem.
Algo interessante a se observar é se o domínio de quem envia é igual de quem recebe. Daí, criarei uma variável que mede isso.
train <- train %>%
mutate(p_r_domain = if_else(P_emaildomain==R_emaildomain,"equal","distinct"))
train %>%
group_by(p_r_domain) %>%
summarise(n = n(),
isFraud = mean(isFraud)) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| p_r_domain | n | isFraud | |
|---|---|---|---|
| 1 | distinct | 282929 | 0.02 |
| 2 | equal | 130449 | 0.06 |
Ficou balanceado e muito bom, já que a taxa de fraude do grupo que teve os dominios iguais é 3 vezes maior que o de seu complementar.
A seguir, a análise das variáveis referentes a correspondência.
train <- train %>%
mutate_at(vars(starts_with("M")),poe_NA)
faz_tabela(train$M1,train$isFraud) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| N(0) | P(0) | N(1) | P(1) | |
|---|---|---|---|---|
| FALSE | 17 | 1.00 | 0 | 0.00 |
| NA | 179823 | 0.95 | 10046 | 0.05 |
| TRUE | 219016 | 0.98 | 4476 | 0.02 |
faz_tabela(train$M2,train$isFraud) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| N(0) | P(0) | N(1) | P(1) | |
|---|---|---|---|---|
| FALSE | 22920 | 0.96 | 835 | 0.04 |
| NA | 179823 | 0.95 | 10046 | 0.05 |
| TRUE | 196113 | 0.98 | 3641 | 0.02 |
faz_tabela(train$M3,train$isFraud) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| N(0) | P(0) | N(1) | P(1) | |
|---|---|---|---|---|
| FALSE | 45947 | 0.97 | 1474 | 0.03 |
| NA | 179823 | 0.95 | 10046 | 0.05 |
| TRUE | 173086 | 0.98 | 3002 | 0.02 |
faz_tabela(train$M4,train$isFraud) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c") # good| N(0) | P(0) | N(1) | P(1) | |
|---|---|---|---|---|
| M0 | 132334 | 0.96 | 5097 | 0.04 |
| M1 | 35911 | 0.97 | 1016 | 0.03 |
| M2 | 37364 | 0.89 | 4837 | 0.11 |
| NA | 193247 | 0.98 | 3572 | 0.02 |
faz_tabela(train$M5,train$isFraud) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| N(0) | P(0) | N(1) | P(1) | |
|---|---|---|---|---|
| FALSE | 90230 | 0.97 | 2464 | 0.03 |
| NA | 236204 | 0.96 | 9172 | 0.04 |
| TRUE | 72422 | 0.96 | 2886 | 0.04 |
faz_tabela(train$M6,train$isFraud) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c") # good| N(0) | P(0) | N(1) | P(1) | |
|---|---|---|---|---|
| FALSE | 155786 | 0.98 | 3788 | 0.02 |
| NA | 110298 | 0.93 | 8404 | 0.07 |
| TRUE | 132772 | 0.98 | 2330 | 0.02 |
faz_tabela(train$M7,train$isFraud) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| N(0) | P(0) | N(1) | P(1) | |
|---|---|---|---|---|
| FALSE | 144800 | 0.98 | 2906 | 0.02 |
| NA | 231508 | 0.95 | 11100 | 0.05 |
| TRUE | 22548 | 0.98 | 516 | 0.02 |
faz_tabela(train$M8,train$isFraud) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| N(0) | P(0) | N(1) | P(1) | |
|---|---|---|---|---|
| FALSE | 106019 | 0.98 | 2410 | 0.02 |
| NA | 231499 | 0.95 | 11100 | 0.05 |
| TRUE | 61338 | 0.98 | 1012 | 0.02 |
faz_tabela(train$M9,train$isFraud) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| N(0) | P(0) | N(1) | P(1) | |
|---|---|---|---|---|
| FALSE | 26134 | 0.97 | 829 | 0.03 |
| NA | 231499 | 0.95 | 11100 | 0.05 |
| TRUE | 141223 | 0.98 | 2593 | 0.02 |
As variáveis M4 e M6 parecem ser valiosas.
Por fim, analisarei as variáveis que estão no arquvio identit, que são referentes ao tipo objeto eletrônico uutilizado.
train <- train %>%
left_join(identit_train %>%
select(TransactionID,DeviceInfo),by = "TransactionID")
train <- train %>%
mutate(DeviceInfo = poe_NA(DeviceInfo))
faz_elbow(faz_tabela(train$DeviceInfo,train$isFraud)[,4])
## # A tibble: 3 x 3
## k pFraud nCategories
## <dbl> <dbl> <int>
## 1 1 0.00975 1406
## 2 2 0.344 152
## 3 3 0.873 90device <- data.frame(device) %>%
transmute(device = rownames(device),
k_device = k)
train <- train %>%
left_join(device,by = c("DeviceInfo" = "device"))
train <- train %>%
mutate_at(vars(starts_with("k_")),as.factor)
faz_tabela(train$k_device,train$isFraud) %>%
knitr::kable(format = "html",digits = 2,row.names = TRUE,align = "c")| N(0) | P(0) | N(1) | P(1) | |
|---|---|---|---|---|
| 1 | 396094 | 0.97 | 12606 | 0.03 |
| 2 | 2598 | 0.71 | 1059 | 0.29 |
| 3 | 164 | 0.16 | 857 | 0.84 |
Contruindo modelo
Primeiro, criar a matriz de treino.
X_train <- model.matrix(~c1_141+c1_142+cards+k_device+TransactionAmt+TransactionDT+
ProductCD+dist2+M4+M6+p_r_domain-1,data = train %>%
mutate_if(is.factor,as.character))Para a modelagem irei utilizar XGboost e Redes neurais artificiais.
XGboost
RNA
library(keras)
model_keras <- keras_model_sequential()
model_keras <- model_keras %>%
layer_dense(units = 120, activation = "relu",
input_shape = ncol(X_train)) %>%
layer_dropout(rate = 0.4) %>%
layer_dense(units = 60, activation = "elu") %>%
layer_dropout(rate = 0.2) %>%
layer_dense(units = 1, activation = "sigmoid")
# Compiling
model_keras <- model_keras %>%
compile(optimizer = 'adam', loss = 'binary_crossentropy', metrics = c('accuracy','AUC'))
Y_train <- train$isFraud
kemodel <- fit(object = model_keras,
x = as.matrix(X_train),
y = Y_train,
batch_size = 120,
epochs = 5,
validation_split = 0.30)Testando modelo na base de teste
mod_base <- xgboost::xgb.load("mod_base1")
test <- test %>%
mutate(c1_141 = predict(C1_14,newdata = test)[,1],
c1_142 = predict(C1_14,newdata = test)[,2])
test <- test %>%
mutate(card1 = as.character(card1),
card2 = as.character(card2),
card3 = as.character(card3),
card5 = as.character(card5)) %>%
mutate_if(is.character,poe_NA)
test <- test %>%
mutate(card1 = as.character(card1),
card2 = as.character(card2),
card3 = as.character(card3),
card5 = as.character(card5)) %>%
left_join(c1,by = c("card1" = "cat1")) %>%
left_join(c2,by = c("card2" = "cat2")) %>%
left_join(c3,by = c("card3" = "cat3")) %>%
left_join(c5,by = c("card5" = "cat5"))
test <- test %>%
mutate(cards = case_when(card4=="NA"|card6=="NA"~"NA",
kcard1==3|kcard2==1|kcard5==3|card4=="discover"|card6=="charge card"~"card1")) %>%
mutate(cards = if_else(is.na(cards)==TRUE,"card2",cards))
test <- test %>%
mutate(cards = if_else(cards=="NA"|cards=="card2","card1","card2"))
test <- test %>%
mutate(dist1 = if_else(is.na(dist1),0,dist1),
dist2 = if_else(is.na(dist2),0,dist2))
test <- test %>%
mutate(p_r_domain = if_else(P_emaildomain==R_emaildomain,"equal","distinct"))
test <- test %>%
mutate_at(vars(starts_with("M")),poe_NA)
test <- test %>%
left_join(identit_train %>%
select(TransactionID,DeviceInfo),by = "TransactionID")
test <- test %>%
mutate(DeviceInfo = poe_NA(DeviceInfo))
test <- test %>%
left_join(device,by = c("DeviceInfo" = "device"))
test <- test %>%
mutate_at(vars(starts_with("k_")),as.factor)
test <- test %>%
mutate(ProductCD = factor(ProductCD,c("W","R","H","S","C")),
M4 = factor(M4,levels = c("NA","M1","M0","M2")),
M6 = factor(M6,levels = c("TRUE","FALSE","NA")),
k_device = factor(k_device,c("1","2","3")),
p_r_domain = factor(p_r_domain,c("distinct","equal")))
input_c1_141 <- mean(train$c1_141)
input_c1_142 <- mean(train$c1_142)
test <- test %>%
mutate(c1_141 = if_else(is.na(c1_141)==TRUE,input_c1_141,c1_141),
c1_142 = if_else(is.na(c1_142)==TRUE,input_c1_142,c1_142),
k_device = if_else(is.na(k_device)==TRUE,"1",as.character(k_device)))
test %>%
select(c1_141,c1_142,cards,k_device,TransactionAmt,TransactionDT,
ProductCD,dist2,M4,M6,p_r_domain,isFraud) %>%
summary()## c1_141 c1_142 cards
## Min. : -0.44993 Min. :-15.695799 Length:177162
## 1st Qu.: -0.33160 1st Qu.: 0.243436 Class :character
## Median : -0.31855 Median : 0.313529 Mode :character
## Mean : -0.02242 Mean : -0.005435
## 3rd Qu.: -0.27667 3rd Qu.: 0.369778
## Max. :106.52079 Max. : 11.893568
## k_device TransactionAmt TransactionDT ProductCD
## Length:177162 Min. : 0.251 Min. : 86400 W:132019
## Class :character 1st Qu.: 43.950 1st Qu.: 3037415 R: 11370
## Mode :character Median : 68.500 Median : 7306784 H: 9940
## Mean : 135.012 Mean : 7377685 S: 3508
## 3rd Qu.: 125.000 3rd Qu.:11238940 C: 20325
## Max. :6450.970 Max. :15811088
## dist2 M4 M6 p_r_domain
## Min. : 0.00 NA:84625 TRUE :58222 distinct:121715
## 1st Qu.: 0.00 M1:15899 FALSE:68282 equal : 55447
## Median : 0.00 M0:58974 NA :50658
## Mean : 14.82 M2:17664
## 3rd Qu.: 0.00
## Max. :9103.00
## isFraud
## Min. :0.00000
## 1st Qu.:0.00000
## Median :0.00000
## Mean :0.03466
## 3rd Qu.:0.00000
## Max. :1.00000X_train_test <- model.matrix(~c1_141+c1_142+cards+k_device+TransactionAmt+TransactionDT+
ProductCD+dist2+M4+M6+p_r_domain-1,data = test %>%
mutate_if(is.factor,as.character))
pred_train <- predict(mod_base,newdata = X_train)
pred_test <- predict(mod_base,newdata = X_train_test)
summary(pred_train)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.002557 0.008639 0.016486 0.035098 0.026095 0.997830## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.002557 0.008639 0.016466 0.034933 0.026029 0.995558## Warning in ks.test(pred_train[train$isFraud == 0], pred_train[train$isFraud
## == : p-value will be approximate in the presence of ties##
## Two-sample Kolmogorov-Smirnov test
##
## data: pred_train[train$isFraud == 0] and pred_train[train$isFraud == 1]
## D = 0.5466, p-value < 2.2e-16
## alternative hypothesis: two-sided## Warning in ks.test(pred_test[test$isFraud == 0], pred_test[test$isFraud
## == : p-value will be approximate in the presence of ties##
## Two-sample Kolmogorov-Smirnov test
##
## data: pred_test[test$isFraud == 0] and pred_test[test$isFraud == 1]
## D = 0.53661, p-value < 2.2e-16
## alternative hypothesis: two-sided## Warning in ks.test(pred_train, pred_test): p-value will be approximate in
## the presence of ties##
## Two-sample Kolmogorov-Smirnov test
##
## data: pred_train and pred_test
## D = 0.0017506, p-value = 0.8417
## alternative hypothesis: two-sided
Submetendo para o kaggle
valid <- read_csv("/opt/datasets/heitor/test_transaction.csv")
identit_test <- read_csv("/opt/datasets/heitor/test_identity.csv")
valid <- valid %>%
mutate(c1_141 = predict(C1_14,newdata = valid)[,1],
c1_142 = predict(C1_14,newdata = valid)[,2])
valid <- valid %>%
mutate(card1 = as.character(card1),
card2 = as.character(card2),
card3 = as.character(card3),
card5 = as.character(card5)) %>%
mutate_if(is.character,poe_NA)
valid <- valid %>%
mutate(card1 = as.character(card1),
card2 = as.character(card2),
card3 = as.character(card3),
card5 = as.character(card5)) %>%
left_join(c1,by = c("card1" = "cat1")) %>%
left_join(c2,by = c("card2" = "cat2")) %>%
left_join(c3,by = c("card3" = "cat3")) %>%
left_join(c5,by = c("card5" = "cat5"))
valid <- valid %>%
mutate(cards = case_when(card4=="NA"|card6=="NA"~"NA",
kcard1==3|kcard2==1|kcard5==3|card4=="discover"|card6=="charge card"~"card1")) %>%
mutate(cards = if_else(is.na(cards)==TRUE,"card2",cards))
valid <- valid %>%
mutate(cards = if_else(cards=="NA"|cards=="card2","card1","card2"))
valid <- valid %>%
mutate(dist1 = if_else(is.na(dist1),0,dist1),
dist2 = if_else(is.na(dist2),0,dist2))
valid <- valid %>%
mutate(p_r_domain = if_else(P_emaildomain==R_emaildomain,"equal","distinct"))
valid <- valid %>%
mutate_at(vars(starts_with("M")),poe_NA)
valid <- valid %>%
left_join(identit_test %>%
select(TransactionID,DeviceInfo),by = "TransactionID")
valid <- valid %>%
mutate(DeviceInfo = poe_NA(DeviceInfo))
valid <- valid %>%
left_join(device,by = c("DeviceInfo" = "device"))
valid <- valid %>%
mutate_at(vars(starts_with("k_")),as.factor)
valid <- valid %>%
mutate(ProductCD = factor(ProductCD,c("W","R","H","S","C")),
M4 = factor(M4,levels = c("NA","M1","M0","M2")),
M6 = factor(M6,levels = c("TRUE","FALSE","NA")),
k_device = factor(k_device,c("1","2","3")),
p_r_domain = factor(p_r_domain,c("distinct","equal")))
input_c1_141 <- mean(train$c1_141)
input_c1_142 <- mean(train$c1_142)
valid <- valid %>%
mutate(c1_141 = if_else(is.na(c1_141)==TRUE,input_c1_141,c1_141),
c1_142 = if_else(is.na(c1_142)==TRUE,input_c1_142,c1_142),
k_device = if_else(is.na(k_device)==TRUE,"1",as.character(k_device)))
X_train_valid <- model.matrix(~c1_141+c1_142+cards+k_device+TransactionAmt+TransactionDT+
ProductCD+dist2+M4+M6+p_r_domain-1,data = valid %>%
mutate_if(is.factor,as.character))
pred_train <- predict(mod_base,newdata = X_train)
pred_valid <- predict(mod_base,newdata = X_train_valid)
subm <- data.frame(read_csv("/opt/datasets/heitor/sample_submission.csv"))
subm
subm[,2] <- pred_valid
subm %>%
write.csv("Submission.csv",row.names = FALSE,sep = ";")Só enviei as previsões com os dados do modelo XGboost pois a rede neural para o conjunto de dados de treino fornecido por mim dava como estimativa a taxa de fraude geral, ou seja, a rede neural não conseguiu estimar a estrutura do dataset.