FRAUDE FINANCIERO SERVICIO DE DINERO MOVIL

A-INTRODUCCION

Hay una falta de conjuntos de datos disponibles públicamente sobre servicios financieros y especialmente en el dominio emergente de transacciones de dinero móvil.

Se muestra un conjunto de datos sinteticos generados a partir de una muestra de transacciones reales extraídas de un mes de registros financieros de un servicio de dinero movil. El conjunto de datos generados se realiza usando un simulador llamado PaySim como una aproximacion a tal problema.

Los registros originales fueron proporcionados por una empresa multinacional, que es el proveedor del servicio financiero móvil que actualmente se ejecuta en más de 14 países de todo el mundo.

se ejecuto PaySim varias veces utilizando semillas aleatorias para 743 pasos, que representan cada hora de un mes de tiempo real, que coincide con los registros originales.

B-OBJETIVO

Predecir las transaciones fraudulentas dentro de este conjunto de datos.

C-DESCRIPCION DE LAS VARIABLES DEL DATASET

step: mapea una unidad de tiempo en el mundo real. En este caso 1 paso es 1 hora de tiempo. Pasos totales 744 (simulación de 30 días).

type: CASH-IN, CASH-OUT, DÉBITO, PAGO y TRANSFERENCIA.

amount: monto de la transacción en moneda local.

nameOrig: cliente que inició la transacción.

oldbalanceOrg: saldo inicial antes de la transacción.

newbalanceOrig: nuevo saldo después de la transacción.

nameDest: cliente que es el destinatario de la transacción.

oldbalanceDest: destinatario del saldo inicial antes de la transacción.

newbalanceDest: destinatario del nuevo saldo después de la transacción.

isFraud: estas son las transacciones realizadas por los agentes fraudulentos dentro de la simulación. En este conjunto de datos específico, el comportamiento fraudulento de los agentes tiene como objetivo obtener ganancias tomando el control de las cuentas de los clientes e intentar vaciar los fondos transfiriéndolos a otra cuenta y luego cobrando del sistema.

isFlaggedFraud: el modelo comercial tiene como objetivo controlar las transferencias masivas de una cuenta a otra y marca los intentos ilegales. Un intento ilegal en este conjunto de datos es un intento de transferir más de 200.000 en una sola transacción.

0. CARGA DE LIBRERIAS, OPCIONES Y DATOS

#Carga de librerias:

library(tidyverse)
library(kableExtra)
library(corrplot)
library(ggpubr)
library(cowplot)
library(kableExtra)
library(tidymodels)
library(doParallel)
library(randomForest)
library(rpart)
library(xgboost)
library(embed)
library(rpart.plot)
library(rattle)
library(ROCR)
library(data.table)
library(RColorBrewer)
library(DataExplorer)
library(inspectdf)
library(ggpubr)
library(numbers)

options(scipen=999)#Desactiva la notacion cientifica

memory.limit(500000)

## [1] 500000

#Carga de datos:

dt <- fread('PS_20174392719_1491204439457_log.csv')

1. ANALISIS EXPLORATORIO PRELIMINAR

as.data.frame(sort(names(dt))) # Visualizacion nombre de variables datos

##    sort(names(dt))
## 1           amount
## 2   isFlaggedFraud
## 3          isFraud
## 4         nameDest
## 5         nameOrig
## 6   newbalanceDest
## 7   newbalanceOrig
## 8   oldbalanceDest
## 9    oldbalanceOrg
## 10            step
## 11            type

str(dt) # Visualizacion estructura datos 1

## Classes 'data.table' and 'data.frame':   6362620 obs. of  11 variables:
##  $ step          : int  1 1 1 1 1 1 1 1 1 1 ...
##  $ type          : chr  "PAYMENT" "PAYMENT" "TRANSFER" "CASH_OUT" ...
##  $ amount        : num  9840 1864 181 181 11668 ...
##  $ nameOrig      : chr  "C1231006815" "C1666544295" "C1305486145" "C840083671" ...
##  $ oldbalanceOrg : num  170136 21249 181 181 41554 ...
##  $ newbalanceOrig: num  160296 19385 0 0 29886 ...
##  $ nameDest      : chr  "M1979787155" "M2044282225" "C553264065" "C38997010" ...
##  $ oldbalanceDest: num  0 0 0 21182 0 ...
##  $ newbalanceDest: num  0 0 0 0 0 ...
##  $ isFraud       : int  0 0 1 1 0 0 0 0 0 0 ...
##  $ isFlaggedFraud: int  0 0 0 0 0 0 0 0 0 0 ...
##  - attr(*, ".internal.selfref")=<externalptr>

glimpse(dt) # Visualizacion estructura datos 2

## Rows: 6,362,620
## Columns: 11
## $ step           <int> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1~
## $ type           <chr> "PAYMENT", "PAYMENT", "TRANSFER", "CASH_OUT", "PAYMENT"~
## $ amount         <dbl> 9839.64, 1864.28, 181.00, 181.00, 11668.14, 7817.71, 71~
## $ nameOrig       <chr> "C1231006815", "C1666544295", "C1305486145", "C84008367~
## $ oldbalanceOrg  <dbl> 170136.0, 21249.0, 181.0, 181.0, 41554.0, 53860.0, 1831~
## $ newbalanceOrig <dbl> 160296.36, 19384.72, 0.00, 0.00, 29885.86, 46042.29, 17~
## $ nameDest       <chr> "M1979787155", "M2044282225", "C553264065", "C38997010"~
## $ oldbalanceDest <dbl> 0, 0, 0, 21182, 0, 0, 0, 0, 0, 41898, 10845, 0, 0, 0, 0~
## $ newbalanceDest <dbl> 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4~
## $ isFraud        <int> 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0~
## $ isFlaggedFraud <int> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0~

#Visualizamos primeras lineas del dataframe

kable(head(dt,6), booktabs = T) %>%
  kable_styling(font_size=12)

step	type	amount	nameOrig	oldbalanceOrg	newbalanceOrig	nameDest	oldbalanceDest	isFraud
1	PAYMENT	9839.64	C1231006815	170136	160296.36	M1979787155	0	0
1	PAYMENT	1864.28	C1666544295	21249	19384.72	M2044282225	0	0
1	TRANSFER	181.00	C1305486145	181	0.00	C553264065	0	1
1	CASH_OUT	181.00	C840083671	181	0.00	C38997010	21182	1
1	PAYMENT	11668.14	C2048537720	41554	29885.86	M1230701703	0	0
1	PAYMENT	7817.71	C90045638	53860	46042.29	M573487274	0	0

Visualizamos la estructura de datos y sus dimensiones de forma mas grafica.

plot_intro(dt)

2. CALIDAD DE DATOS

2.1 Estadisticos Basicos

lapply(dt,summary)

## $step
##    Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
##     1.0   156.0   239.0   243.4   335.0   743.0 
## 
## $type
##    Length     Class      Mode 
##   6362620 character character 
## 
## $amount
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##        0    13390    74872   179862   208721 92445517 
## 
## $nameOrig
##    Length     Class      Mode 
##   6362620 character character 
## 
## $oldbalanceOrg
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##        0        0    14208   833883   107315 59585040 
## 
## $newbalanceOrig
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
##        0        0        0   855114   144258 49585040 
## 
## $nameDest
##    Length     Class      Mode 
##   6362620 character character 
## 
## $oldbalanceDest
##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
##         0         0    132706   1100702    943037 356015889 
## 
## $newbalanceDest
##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
##         0         0    214661   1224996   1111909 356179279 
## 
## $isFraud
##     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
## 0.000000 0.000000 0.000000 0.001291 0.000000 1.000000 
## 
## $isFlaggedFraud
##      Min.   1st Qu.    Median      Mean   3rd Qu.      Max. 
## 0.0000000 0.0000000 0.0000000 0.0000025 0.0000000 1.0000000

2.2 Analisis de nulos(NA’s)

Visualizacion grafica de posibles NA’s.

plot_missing(dt)

data.frame(colSums(is.na(dt)))

##                colSums.is.na.dt..
## step                            0
## type                            0
## amount                          0
## nameOrig                        0
## oldbalanceOrg                   0
## newbalanceOrig                  0
## nameDest                        0
## oldbalanceDest                  0
## newbalanceDest                  0
## isFraud                         0
## isFlaggedFraud                  0

CONCLUSION: Corroboramos que no existen nulos en nuestros datos.

2.3 Analisis de ceros

Examen preliminar de nuestros datos con la funcion considerada, para comprobar si existe un problema de calidad en nuestros datos respecto al numero de ceros considerados en las variables.

contar_ceros <- function(variable) {
  temp <- transmute(dt,if_else(variable==0,1,0))
  sum(temp)
}

num_ceros <- sapply(dt,contar_ceros)
num_ceros <- data.frame(VARIABLE=names(num_ceros),CEROS = as.numeric(num_ceros),
                        stringsAsFactors = F) 
num_ceros <- num_ceros %>%
  arrange(desc(CEROS)) %>%
  mutate(PORCENTAJE = CEROS / nrow(dt) * 100)
num_ceros

##          VARIABLE   CEROS    PORCENTAJE
## 1  isFlaggedFraud 6362604 99.9997485313
## 2         isFraud 6354407 99.8709179552
## 3  newbalanceOrig 3609566 56.7308121497
## 4  oldbalanceDest 2704388 42.5043142605
## 5  newbalanceDest 2439433 38.3400705998
## 6   oldbalanceOrg 2102449 33.0437618465
## 7          amount      16  0.0002514687
## 8            step       0  0.0000000000
## 9            type       0  0.0000000000
## 10       nameOrig       0  0.0000000000
## 11       nameDest       0  0.0000000000

CONCLUSION: las variables referidas a fraude nos da una idea de que el dataset esta desbalanceado con un 99.99% de ceros, intentaremos balancear nuestros datos cuando vayamos a modelizar.

2.4 Analisis de Atipicos

2.4.1 Analisis Atipicos tipo numerico

out <- function(variable){
  t(t(head(sort(variable,decreasing = T),20))) 
}
lapply(dt,function(x){
  if(is.double(x)) out(x)
})

## $step
## NULL
## 
## $type
## NULL
## 
## $amount
##           [,1]
##  [1,] 92445517
##  [2,] 73823490
##  [3,] 71172480
##  [4,] 69886731
##  [5,] 69337316
##  [6,] 67500761
##  [7,] 66761272
##  [8,] 64234448
##  [9,] 63847993
## [10,] 63294840
## [11,] 62785417
## [12,] 61733762
## [13,] 60965276
## [14,] 60642003
## [15,] 60154456
## [16,] 59579503
## [17,] 58944753
## [18,] 58318373
## [19,] 57787801
## [20,] 57436619
## 
## $nameOrig
## NULL
## 
## $oldbalanceOrg
##           [,1]
##  [1,] 59585040
##  [2,] 57316255
##  [3,] 50399045
##  [4,] 49585040
##  [5,] 47316255
##  [6,] 45674548
##  [7,] 44892193
##  [8,] 43818855
##  [9,] 43686616
## [10,] 42542664
## [11,] 41699144
## [12,] 41690843
## [13,] 40399045
## [14,] 39585040
## [15,] 38939424
## [16,] 38563401
## [17,] 38441832
## [18,] 38364748
## [19,] 38259597
## [20,] 38166700
## 
## $newbalanceOrig
##           [,1]
##  [1,] 49585040
##  [2,] 47316255
##  [3,] 43686616
##  [4,] 43673802
##  [5,] 41690843
##  [6,] 41432359
##  [7,] 40399045
##  [8,] 39585040
##  [9,] 38946233
## [10,] 38939424
## [11,] 38563401
## [12,] 38441832
## [13,] 38364748
## [14,] 38259597
## [15,] 38166700
## [16,] 37950093
## [17,] 37919816
## [18,] 37538005
## [19,] 37316255
## [20,] 37297463
## 
## $nameDest
## NULL
## 
## $oldbalanceDest
##            [,1]
##  [1,] 356015889
##  [2,] 355553416
##  [3,] 355381434
##  [4,] 355380484
##  [5,] 355185537
##  [6,] 328194465
##  [7,] 327998074
##  [8,] 327963024
##  [9,] 327852121
## [10,] 327827763
## [11,] 324915061
## [12,] 321589798
## [13,] 311492903
## [14,] 311404901
## [15,] 302560856
## [16,] 302394178
## [17,] 302275362
## [18,] 301140972
## [19,] 300985928
## [20,] 291667716
## 
## $newbalanceDest
##            [,1]
##  [1,] 356179279
##  [2,] 356015889
##  [3,] 355553416
##  [4,] 355553416
##  [5,] 355381434
##  [6,] 355380484
##  [7,] 355185537
##  [8,] 328431698
##  [9,] 328194465
## [10,] 327998074
## [11,] 327963024
## [12,] 327852121
## [13,] 327827763
## [14,] 321589798
## [15,] 311492903
## [16,] 311404901
## [17,] 311404901
## [18,] 311404901
## [19,] 302560856
## [20,] 302394178
## 
## $isFraud
## NULL
## 
## $isFlaggedFraud
## NULL

CONCLUSION: No apreciamos nada relevante en lo referente a los atipicos numericos.

2.4.2 Analisis Atipicos tipo integer

out <- function(variable){
  t(t(table(variable))) 
}
lapply(dt,function(x){
  if(is.integer(x)) out(x)
})

## $step
##         
## variable [,1] 
##      1    2708
##      2    1014
##      3     552
##      4     565
##      5     665
##      6    1660
##      7    6837
##      8   21097
##      9   37628
##      10  35991
##      11  37241
##      12  36153
##      13  37515
##      14  41485
##      15  44609
##      16  42471
##      17  43361
##      18  49579
##      19  51352
##      20  40625
##      21  19152
##      22  12635
##      23   6144
##      24   3216
##      25   1598
##      26    440
##      27     41
##      28      4
##      29      4
##      30      8
##      31     12
##      32     12
##      33  23616
##      34  30904
##      35  29157
##      36  39774
##      37  34000
##      38  31453
##      39  23391
##      40  34270
##      41  36348
##      42  41304
##      43  45060
##      44  38523
##      45  18500
##      46  12445
##      47   8681
##      48   5693
##      49    764
##      50      6
##      51     14
##      52      8
##      53     10
##      54      4
##      55     12
##      56     18
##      57      6
##      58     20
##      59     20
##      60     12
##      61     14
##      62      8
##      63      8
##      64     18
##      65     20
##      66     24
##      67      6
##      68     18
##      69     20
##      70      6
##      71     20
##      72     14
##      73      8
##      74     22
##      75      8
##      76      4
##      77     10
##      78     10
##      79     10
##      80     10
##      81     10
##      82     10
##      83     12
##      84     16
##      85     14
##      86     18
##      87      6
##      88      8
##      89      6
##      90     16
##      91      8
##      92     10
##      93   4444
##      94  10372
##      95   6858
##      96   6350
##      97    685
##      98     14
##      99      8
##      100     6
##      101    12
##      102    12
##      103     8
##      104    14
##      105    18
##      106    18
##      107    10
##      108     8
##      109    12
##      110    10
##      111    10
##      112     2
##      113     6
##      114     4
##      115    10
##      116    14
##      117    12
##      118    12
##      119  5740
##      120  3144
##      121  1074
##      122   414
##      123    52
##      124     4
##      125    10
##      126     6
##      127    14
##      128     8
##      129 21986
##      130 32890
##      131 36375
##      132 35936
##      133 35147
##      134 32391
##      135 27556
##      136 30340
##      137 32559
##      138 31422
##      139 46054
##      140 37012
##      141 16434
##      142 12189
##      143  7609
##      144  3523
##      145  1117
##      146   522
##      147    84
##      148    12
##      149    22
##      150    14
##      151    18
##      152     6
##      153 19475
##      154 29241
##      155 29927
##      156 27603
##      157 29764
##      158 27839
##      159 27561
##      160 27765
##      161 33049
##      162 40622
##      163 46352
##      164 39102
##      165 16542
##      166 12176
##      167  7946
##      168  3824
##      169  1464
##      170   529
##      171    14
##      172    10
##      173    14
##      174    10
##      175     8
##      176    10
##      177 17336
##      178 28204
##      179 30534
##      180 31481
##      181 31749
##      182 31900
##      183 31199
##      184 32175
##      185 37323
##      186 43747
##      187 49083
##      188 39079
##      189 17674
##      190 12669
##      191  9111
##      192  4314
##      193  1511
##      194   671
##      195   141
##      196     8
##      197     4
##      198    12
##      199    10
##      200     8
##      201 17963
##      202 31949
##      203 36176
##      204 36856
##      205 33549
##      206 29777
##      207 28288
##      208 29058
##      209 30372
##      210 33004
##      211 36889
##      212 34047
##      213 14775
##      214 10746
##      215  7975
##      216  4130
##      217  3347
##      218    12
##      219    10
##      220     6
##      221    10
##      222     8
##      223     8
##      224    10
##      225 18366
##      226 27522
##      227 30871
##      228 30965
##      229 28304
##      230 26034
##      231 26968
##      232 27482
##      233 14703
##      234 34053
##      235 47491
##      236 37109
##      237 16003
##      238 10920
##      239  8554
##      240  4189
##      241  1865
##      242   637
##      243     8
##      244    12
##      245     4
##      246     4
##      247     8
##      248    10
##      249 23209
##      250 31854
##      251 35269
##      252 35590
##      253 33311
##      254 29553
##      255 28840
##      256 28570
##      257 26843
##      258 27662
##      259 43328
##      260 33674
##      261 14420
##      262 11125
##      263  8021
##      264  4042
##      265  1581
##      266   767
##      267    77
##      268     6
##      269    14
##      270    16
##      271    12
##      272    12
##      273  7871
##      274 19202
##      275 24797
##      276 26383
##      277 25925
##      278 25737
##      279 25925
##      280 25956
##      281 27778
##      282 31118
##      283 36644
##      284 33449
##      285 14266
##      286 11333
##      287  6889
##      288  4018
##      289  1437
##      290   487
##      291    44
##      292     8
##      293     4
##      294    18
##      295    10
##      296    22
##      297 20609
##      298 29579
##      299 31940
##      300 31176
##      301 30881
##      302 29127
##      303 24714
##      304 26697
##      305 34595
##      306 43615
##      307 46968
##      308 36983
##      309 15147
##      310 11393
##      311  9863
##      312  3266
##      313  1305
##      314   512
##      315    12
##      316    12
##      317    20
##      318     6
##      319     8
##      320    14
##      321 17768
##      322 27147
##      323 29884
##      324 29430
##      325 27901
##      326 26655
##      327 25183
##      328 26877
##      329 32161
##      330 36682
##      331 40186
##      332 36156
##      333 14553
##      334 12016
##      335 10456
##      336  2932
##      337   320
##      338   529
##      339    10
##      340    10
##      341    10
##      342    14
##      343    12
##      344     6
##      345 14670
##      346 26073
##      347 30222
##      348 29467
##      349 29552
##      350 28245
##      351 26927
##      352 27139
##      353 30420
##      354 40696
##      355 44787
##      356 33528
##      357 15096
##      358 12050
##      359  7991
##      360  3508
##      361  1441
##      362   504
##      363    14
##      364     6
##      365    14
##      366    10
##      367    14
##      368     6
##      369 14490
##      370 25429
##      371 28388
##      372 29515
##      373 28853
##      374 27727
##      375 26103
##      376 20122
##      377 18183
##      378 37127
##      379 41759
##      380 37693
##      381 14961
##      382 11829
##      383  7818
##      384  3588
##      385  1419
##      386   633
##      387    28
##      388    18
##      389    10
##      390    12
##      391    12
##      392    10
##      393 19269
##      394 28959
##      395 22797
##      396 34075
##      397 30348
##      398 26656
##      399 30223
##      400 30910
##      401 33468
##      402 40218
##      403 45155
##      404 36726
##      405 16604
##      406 12023
##      407  7937
##      408  8256
##      409   483
##      410    20
##      411    16
##      412     8
##      413   289
##      414    16
##      415    16
##      416  2182
##      417     6
##      418     6
##      419  1257
##      420  2620
##      421    14
##      422  1259
##      423   766
##      424    14
##      425    28
##      426  5139
##      427    14
##      428  2792
##      429  2357
##      430     8
##      431  1685
##      432     4
##      433     6
##      434     8
##      435     4
##      436   248
##      437    16
##      438    12
##      439   883
##      440    18
##      441    10
##      442  1222
##      443    10
##      444    20
##      445    64
##      446    12
##      447    10
##      448  2548
##      449  1194
##      450    16
##      451  3751
##      452   308
##      453    59
##      454    39
##      455   824
##      456    18
##      457    10
##      458   438
##      459     8
##      460    59
##      461    83
##      462    16
##      463    10
##      464    16
##      465    12
##      466   984
##      467    12
##      468    12
##      469  6016
##      470    12
##      471  2620
##      472    84
##      473    10
##      474  2728
##      475    14
##      476  3755
##      477    10
##      478  1908
##      479   904
##      480     6
##      481    14
##      482    16
##      483   317
##      484     6
##      485    12
##      486     8
##      487   912
##      488     8
##      489    14
##      490  3820
##      491    12
##      492  5119
##      493  1819
##      494     8
##      495  3256
##      496   873
##      497    20
##      498    12
##      499    10
##      500  6108
##      501    28
##      502   313
##      503  1878
##      504    10
##      505   936
##      506     8
##      507    14
##      508     6
##      509   288
##      510    10
##      511     6
##      512    12
##      513    10
##      514  8733
##      515     6
##      516    14
##      517  1391
##      518  3488
##      519    12
##      520  3037
##      521    14
##      522 18631
##      523    30
##      524  2664
##      525  8023
##      526  2470
##      527  2697
##      528   937
##      529    33
##      530   409
##      531   250
##      532    95
##      533    12
##      534   531
##      535     6
##      536    12
##      537    18
##      538  3120
##      539     4
##      540  5476
##      541    12
##      542  4475
##      543     6
##      544  9358
##      545  3562
##      546  7771
##      547  2261
##      548  5689
##      549   642
##      550  4804
##      551   949
##      552  1517
##      553     8
##      554    18
##      555   144
##      556     6
##      557    20
##      558    14
##      559    10
##      560    10
##      561    16
##      562    10
##      563  3284
##      564  3546
##      565  5425
##      566  1421
##      567  4356
##      568    14
##      569  1182
##      570  1965
##      571  4256
##      572    18
##      573  3487
##      574  2614
##      575     8
##      576   877
##      577   364
##      578   269
##      579    12
##      580    58
##      581    10
##      582   775
##      583    16
##      584   281
##      585  2047
##      586  1581
##      587  2740
##      588  4894
##      589  6245
##      590  6584
##      591    57
##      592  5373
##      593     4
##      594  6536
##      595  5434
##      596  9319
##      597  2486
##      598   934
##      599  1816
##      600    18
##      601   865
##      602     8
##      603    12
##      604     8
##      605    16
##      606    14
##      607     8
##      608  1082
##      609     8
##      610  1199
##      611    14
##      612  2677
##      613    45
##      614  1278
##      615     8
##      616     6
##      617  2680
##      618     8
##      619  2800
##      620     8
##      621  1121
##      622     4
##      623     6
##      624    10
##      625    24
##      626     6
##      627     4
##      628     6
##      629    20
##      630   150
##      631    12
##      632     8
##      633     8
##      634    10
##      635    16
##      636    12
##      637  3390
##      638    14
##      639    14
##      640  1398
##      641    10
##      642  1141
##      643    14
##      644  2267
##      645    10
##      646    20
##      647    10
##      648    14
##      649   263
##      650    16
##      651    10
##      652    14
##      653     8
##      654     8
##      655     4
##      656  1965
##      657    10
##      658    14
##      659  2500
##      660    12
##      661  4877
##      662     2
##      663    10
##      664  1125
##      665    10
##      666     6
##      667  1400
##      668     8
##      669   322
##      670  1906
##      671    18
##      672   153
##      673   445
##      674    14
##      675    30
##      676     8
##      677     8
##      678     6
##      679    72
##      680    22
##      681  4703
##      682     6
##      683  2192
##      684  4562
##      685    14
##      686  4689
##      687  8040
##      688  7885
##      689    14
##      690  4972
##      691  4809
##      692  6898
##      693     4
##      694  2664
##      695  2827
##      696     6
##      697    12
##      698    65
##      699    55
##      700     6
##      701    18
##      702    14
##      703     8
##      704    16
##      705  2362
##      706     4
##      707   309
##      708     4
##      709  2313
##      710  1788
##      711     8
##      712    23
##      713     8
##      714   681
##      715  1879
##      716   140
##      717   632
##      718   918
##      719    14
##      720    10
##      721     4
##      722    10
##      723    14
##      724    14
##      725     4
##      726    22
##      727    12
##      728    10
##      729     4
##      730    28
##      731    16
##      732    10
##      733    10
##      734     8
##      735    12
##      736    14
##      737    10
##      738    10
##      739    10
##      740     6
##      741    22
##      742    14
##      743     8
## 
## $type
## NULL
## 
## $amount
## NULL
## 
## $nameOrig
## NULL
## 
## $oldbalanceOrg
## NULL
## 
## $newbalanceOrig
## NULL
## 
## $nameDest
## NULL
## 
## $oldbalanceDest
## NULL
## 
## $newbalanceDest
## NULL
## 
## $isFraud
##         
## variable [,1]   
##        0 6354407
##        1    8213
## 
## $isFlaggedFraud
##         
## variable [,1]   
##        0 6362604
##        1      16

CONCLUSION: Nada a destacar.

2.5 Analisis de Coherencia

Nada a destacar fuera de lo normal.

2.6 Comprobacion de correlacion de variables continuas.

corr_cont <- dt%>%select(c("step", "amount", "oldbalanceOrg", "newbalanceOrig", 
                           "oldbalanceDest", "newbalanceDest"))
dat.cor <- cor(corr_cont, method = "pearson")

corrplot(dat.cor, method = "shade",
         shade.col = NA, tl.col = "black",
         tl.srt = 90,
         addCoef.col = "black", addcolorlabel = "no",
         order = "AOE")

CONCLUSION: Vemos que tienen una alta correlacion las variables newbalance y oldbalance tanto Org/Orig y Dest entre ellas repectivamente, lo solucionaremos posteriormente eliminando aquellas de las que podamos prescindir de cara al modelo de regresion logistica a posteriori a utilizar.

3. ANALISIS SECUNDARIO Y ELIMINACION DE VARIABLES SOBRANTES MODELIZACION

Vamos a analizar la penetracion de la target(fraude) en la variable ‘isFlaggedFraud’ que representa los intentos de fraude por encima(1) o por debajo(0) de 200000.

dtn <- dt
dtn$isFraud <- as.factor(dtn$isFraud)
dtn$isFlaggedFraud <- as.factor(dtn$isFlaggedFraud)

pen_fraud <- dtn%>%
  group_by(isFlaggedFraud,isFraud)%>%
  summarise(Count= n())
                
ggbarplot(pen_fraud, x = "isFlaggedFraud", y = "Count",
    fill = "isFraud", color = "isFraud", palette = "Paired",label=T,lab.pos = "out",
    lab.size=3.5, lab.col = "black")+theme(legend.position="bottom")

CONCLUSION: Podemos decir que todas las transacciones por encima de 200.000 son sistemáticamente un fraude y también que los estafadores realizan transacciones por debajo de 200.000.

Ahora vamos a hacer una analisis a nivel horario de las horas mas frecuentes en que se comete el fraude a partir de nuestros datos.

Cada paso(step) representa 1 hora del mundo real y hay un total de 743 pasos para 30 días de datos. Vamos a convertirlos en 24 horas donde cada día tiene de 1 a 24 horas y el patrón se repite de nuevo.

dtn$hour <- mod(dtn$step,24)

p <- ggdensity(dtn,x="hour", color="isFraud", fill="isFraud", palette=c("darkorchid1","aquamarine"),title="FRAUDE POR UNIDAD HORARIA EN EL MUNDO REAL",ggtheme=theme_gray())

p + scale_x_continuous(
  breaks = get_breaks(by = 2, from = 0),
  limits =  c(0, 24))

CONCLUSION: Entre las (0-9)horas aprox. apenas hay transacciones, pero practicamente todas son fraudulentas, a partir las 9h aprox. hay muchas mas transacciones, destacando en mayor proporcion como fraudulentas las que se dan entre las (21-24)horas aprox.

Vamos a analizar la variable por tipo de transaccion realizada en la que veremos la penetracion de la target (fraude) en cada tipo efectuado.

fra_tr <- dt %>% 
      group_by(type) %>% 
      summarise(fr_tran = sum(isFraud))

ggbarplot(fra_tr, x = "type", y = "fr_tran",
          fill = "type", color = "type", palette = "jco", sort.val="desc",
          sort.by.groups = FALSE)+geom_text(aes(label=fr_tran),vjust=-0.5)+
          ggtitle('TRANSACCIONES FRAUDULENTAS POR TIPO')+labs(x='TIPO DE 
          TRANSACCION', y='NUM_TRANSACCIONES_FRAUDULENTAS')

CONCLUSION: Como se puede ver del tipo de transacciones existentes los unicos 2 tipos que contienen transacciones fraudulentas son: ‘CASH_OUT’ y ‘TRANSFER’. con lo cual con posterioridad filtraremos nuestros datos solo con estos tipos de transacciones.

Parece ser tambien que los nombres de origen y destino tienen un denominador comun con respecto al prefijo de esos mismos nombres, que parecen ser catalogados como los prefijos ‘C’ y ‘M’ en cada comienzo de cada nombre.

dt2 <- dt %>% mutate(ori_name_prefx = str_sub(nameOrig,1,1), 
                    dest_name_prefx = str_sub(nameDest, 1, 1)) 

kable(head(dt2,6), booktabs = T) %>%
  kable_styling(font_size=12)

step	type	amount	nameOrig	oldbalanceOrg	newbalanceOrig	nameDest	oldbalanceDest	isFraud	ori_name_prefx	dest_name_prefx
1	PAYMENT	9839.64	C1231006815	170136	160296.36	M1979787155	0	0	C	M
1	PAYMENT	1864.28	C1666544295	21249	19384.72	M2044282225	0	0	C	M
1	TRANSFER	181.00	C1305486145	181	0.00	C553264065	0	1	C	C
1	CASH_OUT	181.00	C840083671	181	0.00	C38997010	21182	1	C	C
1	PAYMENT	11668.14	C2048537720	41554	29885.86	M1230701703	0	0	C	M
1	PAYMENT	7817.71	C90045638	53860	46042.29	M573487274	0	0	C	M

dt2%>%select(c(ori_name_prefx,dest_name_prefx))%>%table()%>%print()

##               dest_name_prefx
## ori_name_prefx       C       M
##              C 4211125 2151495

Se puede ver que los nombres en origen tienen como prefijo la letra C y en los de destino tienen como prefijo ambas la C y la M.

Vamos a ver si esto tiene alguna relacion con nuestra variable objetivo de alguna forma o correspondencia.

Convertimos para ello a factores la variable objetivo y nuestras variables prefijo.

dt2$isFraud <- factor(dt2$isFraud)                

dt2$ori_name_prefx <- factor(dt2$ori_name_prefx)

dt2$dest_name_prefx <- factor(dt2$dest_name_prefx)


 ori <- dt2%>%
  group_by(ori_name_prefx,isFraud)%>%
  summarise(Count= n())
 

 p1 <- ggbarplot(ori, x = "ori_name_prefx", y = "Count",
                fill = "isFraud", color = "isFraud", palette = "Paired",label=TRUE,
                lab.pos = "out",lab.size=3.5, lab.col = "black")+
                theme(legend.position="none")

 
 dest <- dt2%>%
   group_by(dest_name_prefx,isFraud)%>%
   summarise(Count= n())
 
 p2 <- ggbarplot(dest, x = "dest_name_prefx", y = "Count",
           fill = "isFraud", color = "isFraud", palette = "Paired",label=TRUE,
           lab.pos = "out",lab.size=3.5, lab.col = "black")+
           theme(legend.position="none")
 
 
ggarrange(p1,p2, 
          labels = "AUTO",
          common.legend = T, 
          legend = "bottom", 
          align = "hv", 
          ncol = 2)

CONCLUSION: Como vemos los nombres con los prefijos en M no tienen relacion alguna con casos de fraude, vamos ahora a descartar estas observaciones que nunca estan asociadas a fraude ya que son innecesarias para nuestros propositos en la consecucion de los modelos a realizar posteriormente.

dt2 <- dt2%>%filter(type==c('CASH_OUT','TRANSFER'))

dt2 <- dt2%>%filter(dest_name_prefx=='C')

Vamos ahora a visualizar nuestros datos antes y finalmente despues de la limpieza de estas observaciones tomando como referencia los distintos niveles de nuestra variable objetivo.

dt$isFraud <- factor(dt$isFraud)

levels(dt$isFraud) <- c("No_Fraud","Fraud")

dtd <- dt2

levels(dtd$isFraud) <- c("No_Fraud","Fraud")


fraude_antes <- dt%>%
  group_by(isFraud)%>%
  summarise(Count= n())


p3 <- ggbarplot(fraude_antes, x = "isFraud", y = "Count",
                fill = "isFraud", color = "isFraud", palette = "Paired",label=TRUE,lab.pos = "out",lab.size=3.5, lab.col = "black")+theme(legend.position="none")


fraude_despues <- dtd%>%
  group_by(isFraud)%>%
  summarise(Count= n())

p4 <-ggbarplot(fraude_despues, x = "isFraud", y = "Count",
               fill = "isFraud", color = "isFraud", palette = "Paired",label=TRUE,lab.pos = "out",lab.size=3.5, lab.col = "black")+theme(legend.position="none")

ggarrange(p3,p4, 
          labels = "AUTO",
          common.legend = T, 
          legend = "bottom", 
          align = "hv", 
          ncol = 2)

Vemos la variable objetivo en la figura ‘A’ del dataset en funcion del numero de observaciones antes de la limpieza de las mismas y en la figura ‘B’ despues de la limpieza y vemos una reduccion significativa en las observaciones resultantes, no obstante el problema principal sigue siendo que las clases estan muy desbalanceadas,lo cual habra que solucionar con posterioridad para el modelaje.

Vamos ahora a eliminar variables que consideramos con poco impacto en la prediccion del modelo y a guardar las variables que consideremos para incoporar al analisis y al modelo final hallado. Asi pues:

dt3 <- dt2%>%select(nameOrig,nameDest)

dt4 <- dt2%>%select(-step,-nameOrig,-nameDest,-isFlaggedFraud,-ori_name_prefx,
       -dest_name_prefx)

# Cambiamos tambien a factor la variable type

dt4$type <- as.factor(dt4$type)

4. MODELIZACION

FUNCIONES QUE VAMOS A APLICAR A LOS MODELOS:

Funcion para crear una matriz de confusion

confusion<-function(real,scoring,umbral){ 
  conf<-table(real,scoring>=umbral)
  if(ncol(conf)==2) return(conf) else return(NULL)
}

Funcion para calcular las metricas de los modelos: acierto, precision, cobertura y F1

metricas<-function(matriz_conf){
  acierto <- (matriz_conf[1,1] + matriz_conf[2,2]) / sum(matriz_conf) *100
  precision <- matriz_conf[2,2] / (matriz_conf[2,2] + matriz_conf[1,2]) *100
  cobertura <- matriz_conf[2,2] / (matriz_conf[2,2] + matriz_conf[2,1]) *100
  F1 <- 2*precision*cobertura/(precision+cobertura)
  salida<-c(acierto,precision,cobertura,F1)
  return(salida)
}

Funcion para probar distintos umbrales y ver el efecto sobre precision y cobertura

umbrales<-function(real,scoring){
  umbrales<-data.frame(umbral=rep(0,times=19),acierto=rep(0,times=19),
  precision=rep(0,times=19),cobertura=rep(0,times=19),F1=rep(0,times=19))
  cont <- 1
  for (cada in seq(0.05,0.95,by = 0.05)){
    datos<-metricas(confusion(real,scoring,cada))
    registro<-c(cada,datos)
    umbrales[cont,]<-registro
    cont <- cont + 1
  }
  return(umbrales)
}

Funciones que calculan la curva ROC y el AUC

roc<-function(prediction){
  r<-performance(prediction,'tpr','fpr')
  plot(r)
}

auc<-function(prediction){
  a<-performance(prediction,'auc')
  return(a@y.values[[1]])
}

DIVISION DE LOS DATOS ENTRENAMIENTO Y PRUEBA

Creamos las particiones de entrenamiento y prueba, 70% y 30% respectivamente.

Vamos a aplicar un cross-validation a todos los modelos de vfold=10

4.1 Regresion Logistica

set.seed(45)
split_inicial <- initial_split(
  data   = dt4,
  prop   = 0.7,
  strata = isFraud
)

train <- training(split_inicial)
test  <- testing(split_inicial)


# Balanceamos datos y preprocesamos:


# Hacemos preprocesamiento de datos

mod_rcp <- recipe(isFraud~., data=train)%>%
  step_corr(all_numeric_predictors(),threshold = 0.8)%>%
  step_discretize_xgb(all_numeric(), outcome = "isFraud")%>%
  themis::step_downsample(isFraud)

downsp <- mod_rcp%>%
  prep()%>%
  juice()

# hacemos ahora el modelo con los datos balanceados


mod_rl <- logistic_reg(mode = 'classification') %>%
  set_engine(engine = "glm",family=binomial(link='logit'))

mod_dwn <- recipe(isFraud~.,data=downsp)


set.seed(45)
cv_folds <- vfold_cv(
  data    = downsp,
  v       = 10,
  strata  = isFraud
)


wf_m <- workflow()%>%
  add_recipe(mod_dwn)%>%
  add_model(mod_rl)


my_metrics <- metric_set(accuracy,roc_auc,kap)

set.seed(45)
rlog <- wf_m%>%
  fit_resamples(
    resamples    = cv_folds,
    metrics      = my_metrics,
    control      = control_resamples(save_pred = TRUE)
  )

collect_metrics(rlog)

## # A tibble: 3 x 6
##   .metric  .estimator  mean     n std_err .config             
##   <chr>    <chr>      <dbl> <int>   <dbl> <chr>               
## 1 accuracy binary     0.944    10 0.00294 Preprocessor1_Model1
## 2 kap      binary     0.889    10 0.00588 Preprocessor1_Model1
## 3 roc_auc  binary     0.982    10 0.00144 Preprocessor1_Model1

show_best(rlog, metric = "roc_auc")

## # A tibble: 1 x 6
##   .metric .estimator  mean     n std_err .config             
##   <chr>   <chr>      <dbl> <int>   <dbl> <chr>               
## 1 roc_auc binary     0.982    10 0.00144 Preprocessor1_Model1

best_rlog2 <- rlog%>%
  select_best("roc_auc")

wf_final <- 
  wf_m%>%
  finalize_workflow(best_rlog2)


set.seed(45)
final_model_rl <- fit(object = wf_final, data = train)

model_extr1 <- final_model_rl%>%extract_fit_engine()


summary(model_extr1)

## 
## Call:
## stats::glm(formula = ..y ~ ., family = ~binomial(link = "logit"), 
##     data = data)
## 
## Deviance Residuals: 
##     Min       1Q   Median       3Q      Max  
## -5.0462  -0.0467  -0.0181  -0.0046   8.4904  
## 
## Coefficients:
##                     Estimate    Std. Error z value            Pr(>|z|)    
## (Intercept)    -5.7031377169  0.0406966268 -140.14 <0.0000000000000002 ***
## typeTRANSFER    1.7992980995  0.0528839738   34.02 <0.0000000000000002 ***
## amount         -0.0000190255  0.0000006229  -30.55 <0.0000000000000002 ***
## oldbalanceOrg   0.0000262188  0.0000006183   42.40 <0.0000000000000002 ***
## newbalanceOrig -0.0000281307  0.0000006292  -44.71 <0.0000000000000002 ***
## oldbalanceDest -0.0000003700  0.0000000239  -15.48 <0.0000000000000002 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## (Dispersion parameter for binomial family taken to be 1)
## 
##     Null deviance: 38559  on 969753  degrees of freedom
## Residual deviance: 16351  on 969748  degrees of freedom
## AIC: 16363
## 
## Number of Fisher Scoring iterations: 14

Como vemos todas las variables tienen al menos algun elemento altamente significativo(***), por lo tanto consideramos estas variables altamente predictivas y continuamos con nuestro proceso.

La Prediccion del scoring del modelo (conjunto test) sera:

rl_predict <- predict(model_extr1,test,type = "response")
head(rl_predict,20)

##                    4                    5                   13 
## 0.000708984929020051 0.003365156558490609 0.000016078819871626 
##                   14                   16                   18 
## 0.000000236123729351 0.015566069939317723 0.001252460310565901 
##                   21                   24                   28 
## 0.002420627806890194 0.001277093821118475 0.000624287896275398 
##                   31                   32                   33 
## 0.000221191256711430 0.001164488984029582 0.000016317041568318 
##                   34                   40                   61 
## 0.000076444646274630 0.002260365206929941 0.000878236801888946 
##                   66                   67                   73 
## 0.000459258967177029 0.000049883138795761 0.000015241523103905 
##                   77                   84 
## 0.000000972128235837 0.000000000005481085

Veamos graficamente la pinta que tiene:

plot(rl_predict~test$isFraud)

Calculamos ahora el pseudo R cuadrado, visualizando con anterioridad los coeficientes y significancia de acuerdo con lo que hemos decidido escoger para nuestro modelo:

psdo_R <- 1-(model_extr1$deviance/model_extr1$null.deviance)

psdo_R

## [1] 0.5759434

El valor que nos da es muy bueno, este valor nos indica que con las variables que tenemos somos capaces de explicar el 57% de los motivos por los que una transaccion, es fraudulenta, y hay aprox. un 43% que no somos capaces de explicar.

Con la funcion umbrales probamos diferentes cortes y para este caso concreto de descubrimiento de fraude vamos a intentar aumentar la cobertura, pero sin que disminuya mucho la precision, puesto que para un caso de fraude asumimos que pueda haber algo mas de errores de deteccion en pos de que haya mas cobertura para asegurar que se corte la transaccion ante la sospecha para proteger el dinero del cliente.

umb_rl<-umbrales(test$isFraud,rl_predict)
umb_rl

##    umbral  acierto precision cobertura       F1
## 1    0.05 99.63596  41.39458  62.22962 49.71751
## 2    0.10 99.75506  58.12721  54.74210 56.38389
## 3    0.15 99.78369  66.06575  51.83028 58.08858
## 4    0.20 99.79644  71.39423  49.41764 58.40708
## 5    0.25 99.80583  76.02108  48.00333 58.84753
## 6    0.30 99.81112  79.57447  46.67221 58.83587
## 7    0.35 99.81281  81.64179  45.50749 58.44017
## 8    0.40 99.81401  83.25581  44.67554 58.14835
## 9    0.45 99.81497  84.75120  43.92679 57.86301
## 10   0.50 99.81666  87.41497  42.76206 57.43017
## 11   0.55 99.81666  88.59649  42.01331 56.99774
## 12   0.60 99.81641  89.83666  41.18136 56.47461
## 13   0.65 99.81690  91.36961  40.51581 56.13833
## 14   0.70 99.81714  92.50000  40.01664 55.86527
## 15   0.75 99.81521  93.22709  38.93511 54.92958
## 16   0.80 99.81473  94.62810  38.10316 54.32977
## 17   0.85 99.81208  95.07495  36.93844 53.20551
## 18   0.90 99.81016  95.99109  35.85691 52.21078
## 19   0.95 99.80631  96.92671  34.10982 50.46154

Seleccionamos el umbral en funcion de lo anteriormente comentado.

umbral_final_rl<-0.25
umbral_final_rl

## [1] 0.25

Hallamos la matriz de confusion del umbral optimizado.

confusion(test$isFraud,rl_predict,0.25)

##     
## real  FALSE   TRUE
##    0 414226    182
##    1    625    577

rl_metricas<-filter(umb_rl,umbral==umbral_final_rl)
rl_metricas

##   umbral  acierto precision cobertura       F1
## 1   0.25 99.80583  76.02108  48.00333 58.84753

Evaluamos la ROC

#creamos el objeto prediction
rl_prediction<-prediction(rl_predict,test$isFraud)
#visualizamos la ROC
roc(rl_prediction)

Sacamos las metricas definitivas incluyendo el AUC

rl_metricas<-cbind(rl_metricas,AUC=round(auc(rl_prediction),2)*100)
print(t(rl_metricas))

##               [,1]
## umbral     0.25000
## acierto   99.80583
## precision 76.02108
## cobertura 48.00333
## F1        58.84753
## AUC       98.00000

4.2 Arbol de Decision.

set.seed(45)
split_inicial <- initial_split(
  data   = dt4,
  prop   = 0.7,
  strata = isFraud
)
train <- training(split_inicial)
test  <- testing(split_inicial)

# Balanceamos datos y preprocesamos:


# Hacemos preprocesamiento de datos


mod_rcp <- recipe(isFraud~.,
                  data = train)%>%
  step_discretize_xgb(all_numeric(), outcome = "isFraud")%>%
  themis::step_downsample(isFraud)

downsp <- mod_rcp%>%
  prep()%>%
  juice() 


# hacemos ahora el modelo con los datos balanceados

mod_rp <- decision_tree(
  mode = 'classification',
  cost_complexity=0.00001,
  tree_depth = tune(),
  min_n = tune()
)%>%
  set_engine(engine = "rpart",parms = list(split="information"))


mod_dwn <- recipe(isFraud~.,data=downsp)


set.seed(45)
cv_folds <- vfold_cv(
  data = downsp,
  v = 10,
  strata = isFraud
)

wf_rp <- workflow()%>%
  add_recipe(mod_dwn)%>%
  add_model(mod_rp)

registerDoParallel(cores = parallel::detectCores() - 1)

set.seed(45)
rp_fit <- wf_rp%>%tune_bayes(
  resamples = cv_folds,
  initial = 10,
  iter = 20,
  metrics = metric_set(roc_auc),
  control = control_bayes(save_pred=TRUE,no_improve = 10, verbose = FALSE))

stopImplicitCluster()

show_best(rp_fit, metric = "roc_auc")

## # A tibble: 5 x 9
##   tree_depth min_n .metric .estimator  mean     n std_err .config .iter
##        <int> <int> <chr>   <chr>      <dbl> <int>   <dbl> <chr>   <int>
## 1          8     2 roc_auc binary     0.989    10 0.00108 Iter4       4
## 2          8     3 roc_auc binary     0.989    10 0.00108 Iter9       9
## 3          8     4 roc_auc binary     0.989    10 0.00108 Iter10     10
## 4          9     2 roc_auc binary     0.989    10 0.00118 Iter8       8
## 5          9     3 roc_auc binary     0.989    10 0.00121 Iter13     13

mejor_hiper1 <- select_best(rp_fit, metric="roc_auc")
mejor_hiper1

## # A tibble: 1 x 3
##   tree_depth min_n .config
##        <int> <int> <chr>  
## 1          8     2 Iter4

wf_finalrp <- 
  wf_rp%>%
  finalize_workflow(mejor_hiper1)


set.seed(45)
final_model_rp <- fit(object = wf_finalrp, data = train)

model_ext <- final_model_rp%>%
  extract_fit_engine()

Visualizamos el arbol del modelo

fancyRpartPlot(model_ext)

Ahora revisamos la tabla donde podemos ver en primer termino el parametro de complejidad, error relativo,error absoluto, y desviacion estandar.

printcp(model_ext)

## 
## Classification tree:
## rpart::rpart(formula = ..y ~ ., data = data, parms = ~list(split = "information"), 
##     cp = ~0.00001, maxdepth = ~8, minsplit = min_rows(2, data))
## 
## Variables actually used in tree construction:
## [1] amount         newbalanceDest newbalanceOrig oldbalanceDest oldbalanceOrg 
## [6] type          
## 
## Root node error: 2819/969754 = 0.0029069
## 
## n= 969754 
## 
##            CP nsplit rel error  xerror     xstd
## 1  0.17949628      0   1.00000 1.00000 0.018807
## 2  0.12593118      2   0.64101 0.64101 0.015065
## 3  0.07981554      3   0.51508 0.51543 0.013512
## 4  0.01064207      5   0.35545 0.35722 0.011251
## 5  0.00709471     10   0.30223 0.30188 0.010344
## 6  0.00407946     11   0.29514 0.29869 0.010289
## 7  0.00106421     13   0.28698 0.29124 0.010160
## 8  0.00059123     15   0.28485 0.29266 0.010185
## 9  0.00053210     19   0.28237 0.29124 0.010160
## 10 0.00035474     21   0.28131 0.29088 0.010154
## 11 0.00017737     24   0.28024 0.28911 0.010123
## 12 0.00011825     40   0.27740 0.29372 0.010203
## 13 0.00001000     43   0.27705 0.29443 0.010215

En ella nos fijamos en el parametro de complejidad desde el que tomamos de partida 0.00001 abajo del todo hasta arriba de esa relacion, tenemos que mirar en la columna xerror(error absoluto), que empieza a bajar desde arriba, En el
momento que encontramos un numero donde empieza a cambiar la tendencia (a aumentar) ese seria, el parametro de complejidad que tenemos que tomar
correspondiente a ese valor, y por ahi vamos a podar el arbol y ejecutar otra vez el modelo.

En este caso el parametro de complejidad que corresponderia a lo dicho anteriormente parece que minimiza aproximadamente en 0.0001.

Tambien lo podemos interpretar viendo la representacion grafica (ejes: y- xerror x-cp) como vemos a continuacion.

plotcp(model_ext)

Cambiamos el parametro de complejidad de partida a 0.0001 e incluimos en el arbol que no tenga mas de 5 niveles.

set.seed(45)
split_inicial <- initial_split(
  data   = dt4,
  prop   = 0.7,
  strata = isFraud
)
train <- training(split_inicial)
test  <- testing(split_inicial)

# Balanceamos datos y preprocesamos:


# Hacemos preprocesamiento de datos


mod_rcp <- recipe(isFraud~.,
                  data = train)%>%
  step_discretize_xgb(all_numeric(), outcome = "isFraud")%>%
  themis::step_downsample(isFraud)

downsp <- mod_rcp%>%
  prep()%>%
  juice() 


# hacemos ahora el modelo con los datos balanceados


mod_rp <- decision_tree(
  mode = 'classification',
  cost_complexity=0.0001,
  tree_depth = 5,
  min_n = tune()
)%>%
  set_engine(engine = "rpart",parms = list(split="information"))


mod_dwn <- recipe(isFraud~.,data=downsp)


set.seed(45)
cv_folds <- vfold_cv(
  data = downsp,
  v = 10,
  strata = isFraud
)

wf_rp <- workflow()%>%
  add_recipe(mod_dwn)%>%
  add_model(mod_rp)

registerDoParallel(cores = parallel::detectCores() - 1)

set.seed(45)
rp_fit <- wf_rp%>%tune_bayes(
  resamples = cv_folds,
  initial = 10,
  iter = 20,
  metrics = metric_set(roc_auc),
  control = control_bayes(save_pred=TRUE,no_improve = 10, verbose = FALSE))

stopImplicitCluster()

show_best(rp_fit, metric = "roc_auc")

## # A tibble: 5 x 8
##   min_n .metric .estimator  mean     n std_err .config               .iter
##   <int> <chr>   <chr>      <dbl> <int>   <dbl> <chr>                 <int>
## 1     3 roc_auc binary     0.978    10 0.00175 Iter1                     1
## 2     2 roc_auc binary     0.978    10 0.00175 Iter2                     2
## 3     4 roc_auc binary     0.978    10 0.00175 Iter3                     3
## 4    10 roc_auc binary     0.977    10 0.00174 Preprocessor1_Model02     0
## 5     6 roc_auc binary     0.977    10 0.00174 Preprocessor1_Model09     0

mejor_hiper2 <- select_best(rp_fit, metric="roc_auc")
mejor_hiper2

## # A tibble: 1 x 2
##   min_n .config
##   <int> <chr>  
## 1     3 Iter1

wf_finalrp <- 
  wf_rp%>%
  finalize_workflow(mejor_hiper2)


set.seed(45)
final_model_rp <- fit(object = wf_finalrp, data = train)

model_extr2 <- final_model_rp%>%
  extract_fit_engine()

Visualizamos tabla complejidad-errores

printcp(model_extr2)

## 
## Classification tree:
## rpart::rpart(formula = ..y ~ ., data = data, parms = ~list(split = "information"), 
##     cp = ~0.0001, maxdepth = ~5, minsplit = min_rows(3, data))
## 
## Variables actually used in tree construction:
## [1] amount         newbalanceDest newbalanceOrig oldbalanceDest oldbalanceOrg 
## [6] type          
## 
## Root node error: 2819/969754 = 0.0029069
## 
## n= 969754 
## 
##            CP nsplit rel error  xerror     xstd
## 1  0.17949628      0   1.00000 1.00000 0.018807
## 2  0.12593118      2   0.64101 0.64101 0.015065
## 3  0.07981554      3   0.51508 0.51543 0.013512
## 4  0.00709471      5   0.35545 0.35722 0.011251
## 5  0.00407946      6   0.34835 0.34729 0.011094
## 6  0.00106421      8   0.34019 0.33984 0.010974
## 7  0.00053210      9   0.33913 0.33877 0.010957
## 8  0.00035474     11   0.33806 0.33913 0.010963
## 9  0.00017737     12   0.33771 0.33842 0.010951
## 10 0.00010000     16   0.33700 0.33948 0.010968

Podemos ver una clara tendencia descendente de xerror(error absoluto) hasta llegar al parametro de complejidad 0.001 de partida y tanto su error relativo como el absoluto son bastane proximos en dicho parametro y en los demas.

Por tanto consideramos como buena dicha aproximacion.

Visualizamos grafica error validacion cruzada y complejidad.

plotcp(model_extr2)

Visualizamos el arbol del modelo

fancyRpartPlot(model_extr2)

Reglas que podrian ser utilizadas para hacer implantacion del arbol. (y es Churn–la variable objetivo(dependiente) en las reglas del arbol)

rpart.rules(model_extr2, style = 'tall', cover = T,roundint=FALSE)

## ..y is 0.00 with cover 0% when
##     newbalanceDest >=      0.87
##     oldbalanceOrg >= 1010777
##     newbalanceOrig >= 449225
## 
## ..y is 0.00 with cover 0% when
##     newbalanceDest >=      0.87
##     oldbalanceOrg >= 1010777
##     newbalanceOrig is   318 to 439766
## 
## ..y is 0.00 with cover 0% when
##     newbalanceDest >= 1133242.50
##     type is TRANSFER
##     oldbalanceOrg >= 1010777
##     newbalanceOrig <   318
## 
## ..y is 0.00 with cover 0% when
##     newbalanceDest <     0.87
##     type is CASH_OUT
##     amount <  179
##     oldbalanceDest >= 4574
## 
## ..y is 0.00 with cover 0% when
##     newbalanceDest <     0.87
##     type is TRANSFER
##     oldbalanceDest >=   4
## 
## ..y is 0.00 with cover 0% when
##     newbalanceDest <     0.87
##     type is TRANSFER
##     oldbalanceOrg <  50457
##     amount >= 53631
##     oldbalanceDest <   4
## 
## ..y is 0.00 with cover 0% when
##     newbalanceDest <     0.87
##     type is TRANSFER
##     oldbalanceOrg >=  50457
##     amount < 50548
##     oldbalanceDest <   4
## 
## ..y is 0.00 with cover 0% when
##     newbalanceDest <     0.87
##     type is CASH_OUT
##     amount >= 2810
## 
## ..y is 0.00 with cover 99% when
##     newbalanceDest >=      0.87
##     oldbalanceOrg < 1010777
## 
## ..y is 0.01 with cover 0% when
##     newbalanceDest <     0.87
##     type is CASH_OUT
##     amount is  179 to 2753
## 
## ..y is 0.97 with cover 0% when
##     newbalanceDest <     0.87
##     type is TRANSFER
##     oldbalanceOrg <  50457
##     amount < 53631
##     oldbalanceDest <   4
## 
## ..y is 1.00 with cover 0% when
##     newbalanceDest <     0.87
##     type is TRANSFER
##     oldbalanceOrg >=  50457
##     amount >= 50548
##     oldbalanceDest <   4
## 
## ..y is 1.00 with cover 0% when
##     newbalanceDest >=      0.87
##     oldbalanceOrg >= 1010777
##     newbalanceOrig is 439766 to 449225
## 
## ..y is 1.00 with cover 0% when
##     newbalanceDest is     0.87 to 1133242.50
##     type is TRANSFER
##     oldbalanceOrg >= 1010777
##     newbalanceOrig <   318
## 
## ..y is 1.00 with cover 0% when
##     newbalanceDest >=      0.87
##     type is CASH_OUT
##     oldbalanceOrg >= 1010777
##     newbalanceOrig <   318
## 
## ..y is 1.00 with cover 0% when
##     newbalanceDest <     0.87
##     type is CASH_OUT
##     amount is 2753 to 2810
## 
## ..y is 1.00 with cover 0% when
##     newbalanceDest <     0.87
##     type is CASH_OUT
##     amount <  179
##     oldbalanceDest < 4574

Vemos el numero de nodos final por cliente

rp_numnod <- rpart.predict(model_extr2,test,nn=T)

head(rp_numnod)

##            0            1 nn
## 4  0.9990275 0.0009725271  4
## 5  0.9994805 0.0005194805 24
## 13 0.9990275 0.0009725271  4
## 14 0.9990275 0.0009725271  4
## 16 1.0000000 0.0000000000 14
## 18 0.9990275 0.0009725271  4

Calculo de prediccion del modelo (scorings)

rp_predict <- predict(model_extr2, test, type = 'prob')[,2]

head(rp_predict,20)

##            4            5           13           14           16           18 
## 0.0009725271 0.0005194805 0.0009725271 0.0009725271 0.0000000000 0.0009725271 
##           21           24           28           31           32           33 
## 0.0009725271 0.0009725271 0.0009725271 0.0009725271 0.0005194805 0.0009725271 
##           34           40           61           66           67           73 
## 0.0005194805 0.0009725271 0.0009725271 0.0009725271 0.0009725271 0.0009725271 
##           77           84 
## 0.0009725271 0.0009725271

Veamos graficamente como se ve:

plot(rp_predict~test$isFraud)

Buscamos un umbral que maximice la coberturra sin disminuir demasiado la precision

umb_rp<-umbrales(test$isFraud,rp_predict)
umb_rp

##    umbral  acierto precision cobertura       F1
## 1    0.05 99.90159  98.53121  66.97171 79.74245
## 2    0.10 99.90159  98.53121  66.97171 79.74245
## 3    0.15 99.90159  98.53121  66.97171 79.74245
## 4    0.20 99.90159  98.53121  66.97171 79.74245
## 5    0.25 99.90159  98.53121  66.97171 79.74245
## 6    0.30 99.90159  98.53121  66.97171 79.74245
## 7    0.35 99.90159  98.53121  66.97171 79.74245
## 8    0.40 99.90159  98.53121  66.97171 79.74245
## 9    0.45 99.90159  98.53121  66.97171 79.74245
## 10   0.50 99.90159  98.53121  66.97171 79.74245
## 11   0.55 99.90159  98.53121  66.97171 79.74245
## 12   0.60 99.90159  98.53121  66.97171 79.74245
## 13   0.65 99.90159  98.53121  66.97171 79.74245
## 14   0.70 99.90159  98.53121  66.97171 79.74245
## 15   0.75 99.90159  98.53121  66.97171 79.74245
## 16   0.80 99.90159  98.53121  66.97171 79.74245
## 17   0.85 99.90159  98.53121  66.97171 79.74245
## 18   0.90 99.90159  98.53121  66.97171 79.74245
## 19   0.95 99.90159  98.53121  66.97171 79.74245

Lo hallamos directamente con la siguiente sintaxis

umbral_final_rp<-0.05
umbral_final_rp

## [1] 0.05

Hallamos la matriz de confusion del umbral optimizado

confusion(test$isFraud,rp_predict,0.05)

##     
## real  FALSE   TRUE
##    0 414396     12
##    1    397    805

rp_metricas<-filter(umb_rp,umbral==umbral_final_rp)
rp_metricas

##   umbral  acierto precision cobertura       F1
## 1   0.05 99.90159  98.53121  66.97171 79.74245

Evaluamos la ROC

#creamos el objeto prediction
rp_prediction<-prediction(rp_predict,test$isFraud)
#visualizamos la ROC
roc(rp_prediction)

Sacamos las metricas definitivas incluyendo el AUC

rp_metricas<-cbind(rp_metricas,AUC=round(auc(rp_prediction),2)*100)
print(t(rp_metricas))

##               [,1]
## umbral     0.05000
## acierto   99.90159
## precision 98.53121
## cobertura 66.97171
## F1        79.74245
## AUC       83.00000

4.3 Random Forest

set.seed(45)
split_inicial <- initial_split(
  data   = dt4,
  prop   = 0.7,
  strata = isFraud
)
train <- training(split_inicial)
test  <- testing(split_inicial)

# Balanceamos datos y preprocesamos:


# Hacemos preprocesamiento de datos


mod_rcp <- recipe(isFraud~.,
                  data = train)%>%
  step_discretize_xgb(all_numeric(), outcome = "isFraud")%>%
  themis::step_downsample(isFraud)

downsp <- mod_rcp%>%
  prep()%>%
  juice() 


# hacemos ahora el modelo con los datos balanceados


mod_rf <- rand_forest(
  mode  = "classification",
  mtry  = tune(),
  trees = 50,
  min_n = tune()
) %>%
  set_engine(engine = "randomForest",importance=T)


mod_dwn <- recipe(isFraud~.,data=downsp)


set.seed(45)
cv_folds <- vfold_cv(
  data = downsp,
  v = 10,
  strata = isFraud)


wf_rf <- workflow()%>%
  add_recipe(mod_dwn)%>%
  add_model(mod_rf)


hiperpar_grid=grid_max_entropy(
  # Rango de busqueda para cada hiperparametro
  mtry(range = c(1L, 10L), trans = NULL),
  min_n(range = c(2L, 100L), trans = NULL),
  # Numero de combinaciones totales
  size = 100
)

registerDoParallel(cores = parallel::detectCores() - 1)

set.seed(45)
rf_fit <- wf_rf%>%tune_grid(
  resamples = cv_folds,
  metrics = metric_set(roc_auc),
  control = control_resamples(save_pred = TRUE),
  grid = hiperpar_grid)

stopImplicitCluster()

show_best(rf_fit, metric = "roc_auc")

## # A tibble: 5 x 8
##    mtry min_n .metric .estimator  mean     n std_err .config              
##   <int> <int> <chr>   <chr>      <dbl> <int>   <dbl> <chr>                
## 1     2    37 roc_auc binary     0.988    10 0.00152 Preprocessor1_Model81
## 2     2    56 roc_auc binary     0.988    10 0.00129 Preprocessor1_Model70
## 3     2    29 roc_auc binary     0.988    10 0.00152 Preprocessor1_Model36
## 4     2    17 roc_auc binary     0.988    10 0.00163 Preprocessor1_Model18
## 5     2    88 roc_auc binary     0.987    10 0.00156 Preprocessor1_Model53

mejor_hiper3 <- select_best(rf_fit, metric="roc_auc")
mejor_hiper3

## # A tibble: 1 x 3
##    mtry min_n .config              
##   <int> <int> <chr>                
## 1     2    37 Preprocessor1_Model81

wf_finalrf <- 
  wf_rf%>%
  finalize_workflow(mejor_hiper3)


set.seed(45)
final_model_rf <- fit(object = wf_finalrf, data = train)

model_xtr <- final_model_rf%>%
  extract_fit_engine()

Visualizamos las variables de nuestros datos mas importantes en un grafico

varImpPlot(model_xtr)

Como hay 2 criterios, creamos una unica variable agregada para tener una mejor idea de la importancia de cada variable.

importancia <- randomForest::importance(model_xtr)[,3:4]
#normalizamos para poner las dos variables en la misma escala. los valores 
#negativos son las que menos predicen y los positivos las que mas
importancia_norm <- as.data.frame(scale(importancia))
#creamos una unica variable como suma de las otras
importancia_norm <- importancia_norm %>% mutate(
  Variable = rownames(importancia_norm),
  Imp_tot = MeanDecreaseAccuracy + MeanDecreaseGini) %>%
  mutate(Imp_tot = Imp_tot + abs(min(Imp_tot))) %>% 
  arrange(desc(Imp_tot)) %>% 
  select(Variable,Imp_tot,MeanDecreaseAccuracy,MeanDecreaseGini)
#hacemos un grafico para ver la curva de caida de importancia
ggplot(importancia_norm, aes(reorder(Variable,-Imp_tot),Imp_tot)) + 
geom_bar(stat = "identity") + theme(axis.text.x = element_text(angle = 90,size = 7))

importancia_norm

##                      Variable   Imp_tot MeanDecreaseAccuracy MeanDecreaseGini
## oldbalanceOrg   oldbalanceOrg 4.1562794            1.0929973       1.53600151
## newbalanceOrig newbalanceOrig 1.5850338            1.2630649      -1.20531164
## newbalanceDest newbalanceDest 1.5086951           -0.7711384       0.75255295
## amount                 amount 1.4615422            0.1827522      -0.24849057
## type                     type 0.4521328           -0.9829132      -0.09223457
## oldbalanceDest oldbalanceDest 0.0000000           -0.7847629      -0.74251767

Vemos el grafico y nuestros datos en la tabla de forma decreciente segun nivel de importancia, y vemos donde puede estar un corte claro, diferencia de una con respecto a la anterior, y vemos que la variable ‘oldbalanceDest’ tiene la mayor diferencia con respecto al resto en cuanto a importancia(0),

Vamos a deseleccionar de nuestros datos esta variable sobrante por debajo del corte de ‘type’ y nos quedaremos con esta y las de la parte superior.

dt6 <- dt4%>%select(-oldbalanceDest)

y ahora vamos a realizar de nuevo el modelo con las nuevas variables

set.seed(45)
split_inicial <- initial_split(
  data   = dt6,
  prop   = 0.7,
  strata = isFraud
)
train <- training(split_inicial)
test  <- testing(split_inicial)


# Balanceamos datos y preprocesamos:


# Hacemos preprocesamiento de datos


mod_rcp <- recipe(isFraud~.,
                  data = train)%>%
  step_discretize_xgb(all_numeric(), outcome = "isFraud")%>%
  themis::step_downsample(isFraud)

downsp <- mod_rcp%>%
  prep()%>%
  juice() 


# hacemos ahora el modelo con los datos balanceados

mod_rf <- rand_forest(
  mode  = "classification",
  mtry  = tune(),
  trees = 50,
  min_n = tune()
) %>%
  set_engine(engine = "randomForest",importance=T)


mod_dwn <- recipe(isFraud~.,data=downsp)


set.seed(45)
cv_folds <- vfold_cv(
  data = downsp,
  v = 10,
  strata = isFraud)

wf_rf <- workflow()%>%
  add_recipe(mod_dwn)%>%
  add_model(mod_rf)

hiperpar_grid=grid_max_entropy(
  # Rango de busqueda para cada hiperparametro
  mtry(range = c(1L, 10L), trans = NULL),
  min_n(range = c(2L, 100L), trans = NULL),
  # Numero de combinaciones totales
  size = 100
)

registerDoParallel(cores = parallel::detectCores() - 1)


set.seed(45)
rf_fit <- wf_rf%>%tune_grid(
  resamples = cv_folds,
  metrics = metric_set(roc_auc),
  control = control_resamples(save_pred = TRUE),
  grid = hiperpar_grid)

stopImplicitCluster()

show_best(rf_fit, metric = "roc_auc")

## # A tibble: 5 x 8
##    mtry min_n .metric .estimator  mean     n std_err .config              
##   <int> <int> <chr>   <chr>      <dbl> <int>   <dbl> <chr>                
## 1     2    37 roc_auc binary     0.987    10 0.00157 Preprocessor1_Model81
## 2     2    88 roc_auc binary     0.987    10 0.00159 Preprocessor1_Model53
## 3     2    36 roc_auc binary     0.987    10 0.00180 Preprocessor1_Model46
## 4     2    51 roc_auc binary     0.987    10 0.00180 Preprocessor1_Model90
## 5     2    85 roc_auc binary     0.986    10 0.00195 Preprocessor1_Model29

mejor_hiper4 <- select_best(rf_fit, metric="roc_auc")
mejor_hiper4

## # A tibble: 1 x 3
##    mtry min_n .config              
##   <int> <int> <chr>                
## 1     2    37 Preprocessor1_Model81

wf_finalrf <- 
  wf_rf%>%
  finalize_workflow(mejor_hiper4)


set.seed(45)
final_model_rf <- fit(object = wf_finalrf, data = train)

model_extr3 <- final_model_rf%>%
  extract_fit_engine()

Calculo de prediccion del modelo (scorings)

rf_predict <- predict(model_extr3, test, type = 'prob')[,2]

head(rf_predict,20)

##   4   5  13  14  16  18  21  24  28  31  32  33  34  40  61  66  67  73  77  84 
## 0.0 0.0 0.0 0.0 0.3 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0

Veamos graficamente como se ve:

plot(rf_predict~test$isFraud)

Buscamos un umbral que maximice la coberturra sin disminuir demasiado la precision

umb_rf<-umbrales(test$isFraud,rf_predict)
umb_rf

##    umbral  acierto precision cobertura       F1
## 1    0.05 99.82099  63.77858  88.18636 74.02235
## 2    0.10 99.86911  74.58894  83.02829 78.58268
## 3    0.15 99.89028  82.04467  79.45092 80.72697
## 4    0.20 99.89870  86.05725  77.53744 81.57549
## 5    0.25 99.90616  90.84507  75.12479 82.24044
## 6    0.30 99.90712  92.32365  74.04326 82.17913
## 7    0.35 99.91458  96.08270  73.46090 83.26261
## 8    0.40 99.91555  96.70692  73.29451 83.38855
## 9    0.45 99.91627  97.55011  72.87854 83.42857
## 10   0.50 99.91651  97.76536  72.79534 83.45255
## 11   0.55 99.91555  97.97069  72.29617 83.19770
## 12   0.60 99.91458  98.40000  71.63062 82.90804
## 13   0.65 99.91458  98.51088  71.54742 82.89157
## 14   0.70 99.91482  99.07407  71.21464 82.86544
## 15   0.75 99.91290  99.29577  70.38270 82.37585
## 16   0.80 99.91121  99.64243  69.55075 81.92063
## 17   0.85 99.90520  99.63145  67.47088 80.45635
## 18   0.90 99.87007  99.84940  55.15807 71.06109
## 19   0.95 99.85154 100.00000  48.66889 65.47286

Lo hallamos directamente con la siguiente sintaxis

umbral_final_rf<-0.25
umbral_final_rf

## [1] 0.25

Hallamos la matriz de confusion del umbral optimizado

confusion(test$isFraud,rf_predict,0.25)

##     
## real  FALSE   TRUE
##    0 414317     91
##    1    299    903

rf_metricas<-filter(umb_rf,umbral==umbral_final_rf)
rf_metricas

##   umbral  acierto precision cobertura       F1
## 1   0.25 99.90616  90.84507  75.12479 82.24044

Evaluamos la ROC

#creamos el objeto prediction
rf_prediction<-prediction(rf_predict,test$isFraud)
#visualizamos la ROC
roc(rf_prediction)

Sacamos las metricas definitivas incluyendo el AUC

rf_metricas<-cbind(rf_metricas,AUC=round(auc(rf_prediction),2)*100)
print(t(rf_metricas))

##               [,1]
## umbral     0.25000
## acierto   99.90616
## precision 90.84507
## cobertura 75.12479
## F1        82.24044
## AUC       97.00000

4.4 XGBOOST (Extreme Gradient Boosting)

set.seed(45)
split_inicial <- initial_split(
  data   = dt4,
  prop   = 0.7,
  strata = isFraud
)
train <- training(split_inicial)
test  <- testing(split_inicial)


# Balanceamos datos y preprocesamos:


# Hacemos preprocesamiento de datos


mod_rcp <- recipe(isFraud~.,
                  data = train)%>%
  step_discretize_xgb(all_numeric(), outcome = "isFraud")%>%
  step_dummy(all_nominal(), -all_outcomes())%>%
  themis::step_downsample(isFraud)

downsp <- mod_rcp%>%
  prep()%>%
  juice() 


# hacemos ahora el modelo con los datos balanceados

mod_xg <- boost_tree(mtry = tune(),
                     min_n = tune(),
                     tree_depth = tune(),
                     trees = 50,
                     learn_rate = 0.1,
                     sample_size = 0.8) %>% 
  set_engine("xgboost") %>% 
  set_mode("classification")


mod_dwn <- recipe(isFraud~.,data=downsp)


set.seed(45)
cv_folds <- vfold_cv(
  data = downsp,
  v = 10,
  strata = isFraud)


wf_xg<- workflow()%>%
  add_recipe(mod_dwn)%>%
  add_model(mod_xg)


# Parametros para tuning
params_xgb <- parameters(
  finalize(mtry(), x = train[, -1]),
  min_n(range = c(2L, 50L)),
  tree_depth(range = c(3L, 8L))
)

# Grid
set.seed(45)
grid_xgb <- params_xgb %>% 
  grid_max_entropy(size = 10)

registerDoParallel(cores = parallel::detectCores() - 1)

set.seed(2631)
xg_fit <- wf_xg%>%tune_grid(
  resamples = cv_folds,
  metrics = metric_set(roc_auc),
  grid = grid_xgb,
  control = control_grid(save_pred = TRUE))


stopImplicitCluster()

show_best(xg_fit, metric = "roc_auc")

## # A tibble: 5 x 9
##    mtry min_n tree_depth .metric .estimator  mean     n std_err .config         
##   <int> <int>      <int> <chr>   <chr>      <dbl> <int>   <dbl> <chr>           
## 1     5    12          6 roc_auc binary     0.983    10 0.00109 Preprocessor1_M~
## 2     4    19          8 roc_auc binary     0.979    10 0.00117 Preprocessor1_M~
## 3     5    11          3 roc_auc binary     0.974    10 0.00114 Preprocessor1_M~
## 4     2    12          5 roc_auc binary     0.969    10 0.00155 Preprocessor1_M~
## 5     5    31          5 roc_auc binary     0.968    10 0.00141 Preprocessor1_M~

mejor_hiper5 <- select_best(xg_fit, metric="roc_auc")
mejor_hiper5

## # A tibble: 1 x 4
##    mtry min_n tree_depth .config              
##   <int> <int>      <int> <chr>                
## 1     5    12          6 Preprocessor1_Model03

wf_finalxg <- 
  wf_rf%>%
  finalize_workflow(mejor_hiper5)


set.seed(45)
final_model_xg <- fit(object = wf_finalxg, data = train)

model_extr4 <- final_model_xg%>%
  extract_fit_engine()

Calculo de prediccion del modelo (scorings)

xg_predict <- predict(model_extr4, test, type = 'prob')[,2]

head(xg_predict,20)

##  4  5 13 14 16 18 21 24 28 31 32 33 34 40 61 66 67 73 77 84 
##  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0  0

Veamos graficamente como se ve:

plot(xg_predict~test$isFraud)

Buscamos un umbral que maximice la coberturra sin disminuir demasiado la precision

umb_xg<-umbrales(test$isFraud,xg_predict)
umb_xg

##    umbral  acierto precision cobertura       F1
## 1    0.05 99.83807  64.73538  96.67221 77.54421
## 2    0.10 99.87873  71.89460  95.34110 81.97425
## 3    0.15 99.90352  77.71626  93.42762 84.85077
## 4    0.20 99.91121  80.11569  92.17970 85.72534
## 5    0.25 99.91747  82.86151  90.09983 86.32921
## 6    0.30 99.92156  84.65190  89.01830 86.78021
## 7    0.35 99.92637  87.08609  87.52080 87.30290
## 8    0.40 99.92902  88.66155  86.52246 87.57895
## 9    0.45 99.93022  90.28269  85.02496 87.57498
## 10   0.50 99.93143  91.64396  83.94343 87.62484
## 11   0.55 99.93287  93.99428  82.02995 87.60551
## 12   0.60 99.92998  95.23337  79.78369 86.82662
## 13   0.65 99.92806  96.02446  78.36938 86.30325
## 14   0.70 99.92565  97.14889  76.53910 85.62122
## 15   0.75 99.92637  98.17204  75.95674 85.64728
## 16   0.80 99.92373  98.57300  74.70882 84.99763
## 17   0.85 99.91964  98.98420  72.96173 84.00383
## 18   0.90 99.91506  99.41793  71.04825 82.87239
## 19   0.95 99.90905  99.63855  68.80200 81.39764

Lo hallamos directamente con la siguiente sintaxis

umbral_final_xg <- 0.45
umbral_final_xg

## [1] 0.45

Hallamos la matriz de confusion del umbral optimizado

confusion(test$isFraud,xg_predict,0.45)

##     
## real  FALSE   TRUE
##    0 414298    110
##    1    180   1022

xg_metricas<-filter(umb_xg,umbral==umbral_final_xg)
xg_metricas

##   umbral  acierto precision cobertura       F1
## 1   0.45 99.93022  90.28269  85.02496 87.57498

Evaluamos la ROC

#creamos el objeto prediction
xg_prediction<-prediction(xg_predict,test$isFraud)
#visualizamos la ROC
roc(xg_prediction)

Sacamos las metricas definitivas incluyendo el AUC

xg_metricas<-cbind(xg_metricas,AUC=round(auc(xg_prediction),2)*100)
print(t(xg_metricas))

##               [,1]
## umbral     0.45000
## acierto   99.93022
## precision 90.28269
## cobertura 85.02496
## F1        87.57498
## AUC       99.00000

4.5 Comparativa de metricas y curvas ROC

4.5.1 Comparativa de metricas

comparativa <- rbind(rl_metricas,rp_metricas,rf_metricas,xg_metricas)
rownames(comparativa) <- c('Regresion Logistica', 'Arbol Decision', 
                           'Random Forest', 'Extreme Gradiant Boosting')
                           
t(comparativa)

##           Regresion Logistica Arbol Decision Random Forest
## umbral                0.25000        0.05000       0.25000
## acierto              99.80583       99.90159      99.90616
## precision            76.02108       98.53121      90.84507
## cobertura            48.00333       66.97171      75.12479
## F1                   58.84753       79.74245      82.24044
## AUC                  98.00000       83.00000      97.00000
##           Extreme Gradiant Boosting
## umbral                      0.45000
## acierto                    99.93022
## precision                  90.28269
## cobertura                  85.02496
## F1                         87.57498
## AUC                        99.00000

4.5.2 Comparativas de Curvas ROC de los modelos

rl_auc <- rlog%>%collect_predictions(summarize=TRUE,parameters=best_rlog2)%>%
  roc_curve(isFraud,.pred_0)%>%
  mutate(model = "Regresion Logistica")

rp_auc <- rp_fit%>%collect_predictions(summarize=TRUE,parameters=mejor_hiper2)%>%
  roc_curve(isFraud,.pred_0)%>%
  mutate(model = "Arbol de Decision") 

rf_auc <- rf_fit%>%collect_predictions(summarize=TRUE,parameters=mejor_hiper4)%>%
  roc_curve(isFraud,.pred_0)%>%
  mutate(model = "Random Forest") 

xg_auc <- xg_fit%>%collect_predictions(summarize=TRUE,parameters=mejor_hiper5)%>%
  roc_curve(isFraud,.pred_0)%>%
  mutate(model = "Xgboost")

bind_rows(rl_auc,rp_auc,rf_auc,xg_auc)%>% # Dibuja las 4 curvas AUC juntas
  ggplot(aes(x=1-specificity, y = sensitivity, col = model))+ # Especifica el eje x e y dibuja la columna para usar el nombre de la metrica
  geom_path(lwd = 1.5, alpha = 0.8) + # Conecta a las 4 AUC, lwd = anchura de linea, alpha = Color transparencia del valor.
  geom_abline(lty = 3) + # abline del dibujo, lty= linea tipo
  coord_equal() + # Asegura que los rangos de los ejes sean iguales
  scale_color_viridis_d(option = "plasma", end = .6)

En base a la comparativa el modelo de Extreme Gradient Boosting ha obtenido mejores resultados, asi que seleccionamos este modelo ganador en la comparativa.

4.6 Guardado del modelo seleccionado.

Añadimos la variable scoring a nuestro dataframe en base a la prediccion del modelo seleccionado y guardamos el modelo final.

dt4$SCORING_FRAUD <- predict(model_extr4, dt4, type = 'prob')[,2]
saveRDS(model_extr4,'modelo_final.rds')

Visualizamos tabla añadiendo variables de nombres al modelo descrito

dt5 <- cbind(dt3,dt4)

kable(head(dt5,6), booktabs = T) %>%
  kable_styling(font_size=12)

nameOrig	nameDest	type	amount	oldbalanceOrg	newbalanceOrig	oldbalanceDest	newbalanceDest
C1670993182	C1100439041	TRANSFER	215310.30	705.00	0	22425	0.00
C768216420	C1509514333	CASH_OUT	110414.71	26845.41	0	288800	2415.16
C512549200	C248609774	CASH_OUT	5346.89	0.00	0	652637	6453430.91
C1528834618	C476800120	CASH_OUT	82940.31	3017.87	0	132372	49864.36
C527211736	C2096057945	CASH_OUT	47458.86	209534.84	162076	52120	0.00
C1718906711	C977993101	CASH_OUT	94253.33	25203.05	0	99773	965870.05