Importando datos

Primero importamos los datos sobre ventas en línea que tenemos y removemos los NA’s, si es que tiene.

library(tidyverse)
library(neuralnet)
library(fastDummies)
set.seed(5)
data <- read.csv("C:/Users/LuisAlberto/Downloads/fraud_data.csv")
data <- na.omit(data)

Observemos la estructura de los datos. Donde class nos dice si fue una compra fraudulenta (1) o no lo fue (0).

str(data)
## 'data.frame':    151112 obs. of  11 variables:
##  $ user_id       : int  22058 333320 1359 150084 221365 159135 50116 360585 159045 182338 ...
##  $ signup_time   : chr  "2015-02-24 22:55:49" "2015-06-07 20:39:50" "2015-01-01 18:52:44" "2015-04-28 21:13:25" ...
##  $ purchase_time : chr  "2015-04-18 02:47:11" "2015-06-08 01:38:54" "2015-01-01 18:52:45" "2015-05-04 13:54:50" ...
##  $ purchase_value: int  34 16 15 44 39 42 11 27 30 62 ...
##  $ device_id     : chr  "QVPSPJUOCKZAR" "EOGFQPIZPYXFZ" "YSSKYOSJHPPLJ" "ATGTXKYKUDUQN" ...
##  $ source        : chr  "SEO" "Ads" "SEO" "SEO" ...
##  $ browser       : chr  "Chrome" "Chrome" "Opera" "Safari" ...
##  $ sex           : chr  "M" "F" "M" "M" ...
##  $ age           : int  39 53 53 41 45 18 19 34 43 31 ...
##  $ ip_address    : num  7.33e+08 3.50e+08 2.62e+09 3.84e+09 4.16e+08 ...
##  $ class         : int  0 0 1 0 0 0 0 0 0 0 ...

Por si solos la fecha de registro y la fecha de compra no nos dicen nada relevante, por lo que calcularemos una nueva columna llamada time que nos dirá la diferencia en horas de estas dos fechas para tener en cuenta el tiempo que se tardó en realizar una compra. Al mismo tiempo seleccionaremos las columnas que nos serán de utilidad.

data$time <- as.numeric(difftime(as.POSIXct(data$purchase_time), as.POSIXct(data$signup_time), units = "hours"))
data <- data[,c(12,4,6,7,8,9,11)]

Al tener aún variables categóricas como source, browser y sex, les asignaremos dummies para poder trabajar numéricamente con ellas. Después ordenamos las columnas de nuestro dataframe y realizar la transformación min-max para que la escala en cada una de las variables sea la misma y así de cierta manera mantenemos la asimetría que pueda haber entre las variables ya que solo mandamos los datos al intervalo [0,1].

data <- dummy_cols(data)
data <- data[,c(1,2,6,8:17,7)]
maxs <- apply(data, 2, max)
mins <- apply(data, 2, min)
scaled <- as.data.frame(scale(data, center = mins, scale = maxs - mins))

Observemos el boxplot de las variables númericas antes de la transformación:

boxplot(data$time, data$purchase_value, data$age, col = "white", names = c("Time", "Purchase Value", "Age"))

Y después de la transformación:

boxplot(scaled$time, scaled$purchase_value, scaled$age, col = "white", names = c("Time", "Purchase Value", "Age"))

Procedemos partiendo los datos, un dataframe de entrenamiento que nos ayudará a ajustar una red neuronal y uno de prueba para probar el modelo.

index <- sample(1:nrow(data), round(0.75*nrow(data)))
train <- scaled[index,]
test <- scaled[-index,]

Aplicación de Redes Neuronales

Usaremos la función neuralnet para poder ajustarle una red neuronal con 2 capas ocultas, la primera con 6 nodos y la segunda con 3. Ponemos linear.outpout como false ya que nuestro objetivo es realizar una clasificación.

n <- names(train)
f <- as.formula(paste("class ~", paste(n[!n %in% "class"], collapse = " + ")))
nn <- neuralnet(f, data = train, hidden = c(6,3), linear.output = F, lifesign = "full", threshold = 0.01,
                 stepmax = 1e+07)

Calculando el error cuadrático medio (deshaciendo la transformación) obtenemos:

pred <- neuralnet::compute(nn, test[,c(1:13)])
pred <- pred$net.result*(max(data$class)-min(data$class)) + min(data$class)
test.r <- (test$class)*(max(data$class)-min(data$class)) + min(data$class)
 
MSE <- sum(test.r - pred)^2/nrow(test)
MSE
## [1] 0.01496829

El cual podemos observar, es bajo.

Calculando el balanced accuracy, observamos que es aprox. del 76%:

tab <- table(test$class, round(pred))
sens <- tab[2,2]/(tab[2,2]+tab[2,1])
spec <- tab[1,1]/(tab[1,1]+tab[1,2])
acc <- (sens + spec)/2
acc
## [1] 0.7659667

Y la curva AUC-ROC se ve de la siguiente manera.

library(ROCR)
prob <- pred
nn.pred <- ROCR::prediction(prob, test$class)
pref <- performance(nn.pred, 'tpr', 'fpr')
plot(pref, col = "#ff7f7f")

Por lo cual podemos considerar que es un buen modelo. Entonces mostramos nuestra red neuronal, la cual tiene como objetivo calcular la probabilidad de que una compra sea fraudulenta después de pasarle datos como el tiempo entre registro y compra en horas, la edad, el sexo, el navegador, la edad, el monto de la compra y su source.

library(devtools)
source_url('https://gist.githubusercontent.com/fawda123/7471137/raw/466c1474d0a505ff044412703516c34f1a4684a5/nnet_plot_update.r')
plot.nnet(nn)

Que tiene los siguientes pesos (en tabla páginas y con color dependiendo si la beta es positiva o negativa):

library(scales)
weights <- as.data.frame(nn$result.matrix)
weights <- as.data.frame(cbind(rownames(weights), weights[,1]))
weights$V2 <- comma(round(as.numeric(weights$V2),2))
weights <- weights[-c(1:3),]
row.names(weights) <- NULL
colnames(weights) <- c('Connections', 'Weights')
rmarkdown::paged_table(weights)
library(formattable)
improvement_formatter <- 
  formatter("span", 
            style = x ~ style(
              font.weight = "bold", 
              color = ifelse(x > 0, "#71CA97", ifelse(x < 0, "#ff7f7f", "black"))))

formattable(weights, align = c('l', 'c'),
                      list(`Connections` = formatter(
                        "span", style = ~ style(color = "grey", 'font-weight' = "bold")),
                        'Weights' = improvement_formatter
                      ))
Connections Weights
Intercept.to.1layhid1 -1.5400
time.to.1layhid1 1,268.5500
purchase_value.to.1layhid1 10.2500
age.to.1layhid1 1.5700
source_Ads.to.1layhid1 -1.2300
source_Direct.to.1layhid1 -712.2800
source_SEO.to.1layhid1 0.1300
browser_Chrome.to.1layhid1 -2.4700
browser_FireFox.to.1layhid1 -1.9600
browser_IE.to.1layhid1 0.4200
browser_Opera.to.1layhid1 -711.8500
browser_Safari.to.1layhid1 -712.1500
sex_F.to.1layhid1 -0.6800
sex_M.to.1layhid1 -1.2600
Intercept.to.1layhid2 -1.7900
time.to.1layhid2 1,324.1300
purchase_value.to.1layhid2 -4.8800
age.to.1layhid2 -17.5800
source_Ads.to.1layhid2 -2.4500
source_Direct.to.1layhid2 4.5200
source_SEO.to.1layhid2 2.0000
browser_Chrome.to.1layhid2 6.8700
browser_FireFox.to.1layhid2 0.2200
browser_IE.to.1layhid2 0.3000
browser_Opera.to.1layhid2 -714.8700
browser_Safari.to.1layhid2 -0.1600
sex_F.to.1layhid2 1.4500
sex_M.to.1layhid2 6.1800
Intercept.to.1layhid3 -0.8600
time.to.1layhid3 1,323.7500
purchase_value.to.1layhid3 2.3400
age.to.1layhid3 8.0200
source_Ads.to.1layhid3 3.2200
source_Direct.to.1layhid3 -2.4600
source_SEO.to.1layhid3 0.4400
browser_Chrome.to.1layhid3 -2.1100
browser_FireFox.to.1layhid3 -2.5800
browser_IE.to.1layhid3 -1.8800
browser_Opera.to.1layhid3 1.2200
browser_Safari.to.1layhid3 0.0000
sex_F.to.1layhid3 -2.1800
sex_M.to.1layhid3 -0.8700
Intercept.to.1layhid4 0.1100
time.to.1layhid4 1,326.5000
purchase_value.to.1layhid4 -7.5100
age.to.1layhid4 4.8900
source_Ads.to.1layhid4 -2.1900
source_Direct.to.1layhid4 2.8600
source_SEO.to.1layhid4 -0.6400
browser_Chrome.to.1layhid4 0.7800
browser_FireFox.to.1layhid4 -4.0900
browser_IE.to.1layhid4 1.3900
browser_Opera.to.1layhid4 0.4200
browser_Safari.to.1layhid4 0.2100
sex_F.to.1layhid4 -0.2500
sex_M.to.1layhid4 -1.1800
Intercept.to.1layhid5 0.8000
time.to.1layhid5 -1,323.1100
purchase_value.to.1layhid5 -17.2500
age.to.1layhid5 15.0500
source_Ads.to.1layhid5 -2.5000
source_Direct.to.1layhid5 2.3500
source_SEO.to.1layhid5 -0.6500
browser_Chrome.to.1layhid5 4.0000
browser_FireFox.to.1layhid5 -12.4400
browser_IE.to.1layhid5 1.4800
browser_Opera.to.1layhid5 -1.5400
browser_Safari.to.1layhid5 -1.4600
sex_F.to.1layhid5 -3.3300
sex_M.to.1layhid5 5.9100
Intercept.to.1layhid6 0.0300
time.to.1layhid6 -1,307.3800
purchase_value.to.1layhid6 -34.6700
age.to.1layhid6 -2.1700
source_Ads.to.1layhid6 1.8700
source_Direct.to.1layhid6 -4.8200
source_SEO.to.1layhid6 13.7000
browser_Chrome.to.1layhid6 14.0700
browser_FireFox.to.1layhid6 17.5800
browser_IE.to.1layhid6 -0.4300
browser_Opera.to.1layhid6 50.1900
browser_Safari.to.1layhid6 1.2900
sex_F.to.1layhid6 62.2700
sex_M.to.1layhid6 0.2200
Intercept.to.2layhid1 -98.2300
1layhid1.to.2layhid1 26,762.2400
1layhid2.to.2layhid1 175.3700
1layhid3.to.2layhid1 906.9400
1layhid4.to.2layhid1 144.9800
1layhid5.to.2layhid1 -511.2600
1layhid6.to.2layhid1 -28.1300
Intercept.to.2layhid2 -33.0700
1layhid1.to.2layhid2 111.1800
1layhid2.to.2layhid2 314.8200
1layhid3.to.2layhid2 219.0700
1layhid4.to.2layhid2 656.4000
1layhid5.to.2layhid2 -390.7100
1layhid6.to.2layhid2 -385.3200
Intercept.to.2layhid3 -319.0100
1layhid1.to.2layhid3 313.9600
1layhid2.to.2layhid3 456.9500
1layhid3.to.2layhid3 663.5600
1layhid4.to.2layhid3 534.8300
1layhid5.to.2layhid3 -717.2000
1layhid6.to.2layhid3 -301.9500
Intercept.to.class 7.4100
2layhid1.to.class -4.6300
2layhid2.to.class -4.5400
2layhid3.to.class -1.2800