iis24094

Dataset explained

Η βάση δεδομένων που θα χρησιμοποιήσουμε περιέχει συνναλαγές πιστωτικών καρτών που έγιναν στο διάστημα του Σεπτεμβρίου 2013 Στην Ευρώπη. Η βάση θα χρησιμποιηθεί για να εκπαιδευτεί μοντέλο που προβλέπει απάτες συναλλαγών.

Method

Η μέθοδος που θα χρησιμοποιήσω για την δημιουργία του μοντέλου αυτού είναι : Random Forest , καθώς θα καταφέρει να δώσει την μεγαλύτερη ακρίβεια στις προβλέψεις του μοντέλου μας .

Loading the data set

library(caTools)
library(xgboost)

## Warning: package 'xgboost' was built under R version 4.6.1

library(ROCR)


fraud <- read.csv("creditcard.csv")

class_table <- table(fraud$Class)
print(class_table)

## 
##      0      1 
## 284315    492

Μόλις το 0.172% των καταγραφών αποτελούν παράδειγμα απάτης.

Train / Split test

Πάμε να χωρίσουμε τα δεδομένα σε 70/30.

set.seed(94)

split <- sample.split(fraud$Class, SplitRatio = 0.70)
train <-subset(fraud, split ==TRUE)
test <-subset(fraud, split == FALSE)

cat("Train rows:", nrow(train), " Frauds:" , sum(train$Class), "\n")

## Train rows: 199364  Frauds: 344

cat("Test rows: ", nrow(test), "Frauds: ", sum(test$Class), "\n")

## Test rows:  85443 Frauds:  148

Τυποποιούμε τις τιμές Time και Amount. Έτσι αποφεύγουμε την διαρροή δεδομένων.

for(col in c("Time" , "Amount")) {
  mu <-mean(train[[col]])
  sdv <- sd(train[[col]])
  train[[col]] <- (train[[col]] - mu)/ sdv
  test[[col]] <- (test[[col]] - mu) / sdv
}

Ερώτηση 1

Ας δούμε πόσο καλά υπολογίζονται οι δόλιες συναλλαγές με την χρήση κατάλληλων μετρικών για ανισοκατανομή αντί για απλό accuracy.

roc_auc <- function(prob , actual) {
  performance(prediction(prob, actual), "auc")@y.values[[1]]
}

pr_auc <- function(prob, actual) {
  perf <- performance(prediction(prob, actual), "prec" , "rec")
  rec <- perf@x.values[[1]]
  prec <- perf@y.values[[1]]
  ok   <- !is.nan(prec) & !is.nan(rec)
  rec  <- rec[ok]; prec <- prec[ok]
  ord  <- order(rec)
  rec  <- rec[ord]; prec <- prec[ord]
  sum(diff(rec) * (head(prec, -1) + tail(prec, -1)) / 2)
} 

evaluate <- function(actual, prob, threshold = 0.5, label = "") {
  pred <- ifelse(prob > threshold, 1, 0)
  cm <- table(Actual    = factor(actual, levels = c(0, 1)),
   Predicted = factor(pred,   levels = c(0, 1)))
  TN <- cm[1, 1]; FP <- cm[1, 2]; FN <- cm[2, 1]; TP <- cm[2, 2]

  precision <- TP / (TP + FP)
  recall    <- TP / (TP + FN)   # a.k.a. sensitivity / fraud-detection rate
  f1        <- 2 * precision * recall / (precision + recall)

  cat("---", label, "(threshold =", threshold, ") ---\n")
  print(cm)
  cat("\nFraud caught (TP):", TP, " Fraud missed (FN):", FN,
      " False alarms (FP):", FP, "\n")
  cat("Precision:", round(precision, 4),
      "| Recall:", round(recall, 4),
      "| F1:", round(f1, 4), "\n")
  cat("ROC-AUC:", round(roc_auc(prob, actual), 4),
      "| PR-AUC:", round(pr_auc(prob, actual), 4), "\n\n")

  invisible(list(precision = precision, recall = recall, f1 = f1,
                 TP = TP, FN = FN, FP = FP))
}

Baseline : Λογιστική Παλινδρόμιση

Χρησιμοποιούμε για να δούμε ποιο είναι το baseline μας.

log_model <-glm(Class ~ ., data = train, family = binomial)

pred_log <- predict(log_model, newdata = test, type = "response")

log_res <- evaluate(test$Class, pred_log, threshold = 0.5,
    label = "Λογιστική Παλινδρόμηση")

## --- Λογιστική Παλινδρόμηση (threshold = 0.5 ) ---
##       Predicted
## Actual     0     1
##      0 85282    13
##      1    50    98
## 
## Fraud caught (TP): 98  Fraud missed (FN): 50  False alarms (FP): 13 
## Precision: 0.8829 | Recall: 0.6622 | F1: 0.7568 
## ROC-AUC: 0.9834 | PR-AUC: 0.7642

Μοντέλο Ensemble: XGBoost

Τώρα το ensemble. Εκπαιδεύουμε σε 150 γύρους boosting .

feature_cols <- setdiff(names(train), "Class")

dtrain <- xgb.DMatrix(data = as.matrix(train[, feature_cols]),
                      label = train$Class)
dtest  <- xgb.DMatrix(data = as.matrix(test[, feature_cols]),
                      label = test$Class)

spw <- sum(train$Class == 0) / sum(train$Class == 1)
cat("scale_pos_weight:", round(spw, 1), "\n")

## scale_pos_weight: 578.5

params <- list(
  objective        = "binary:logistic",
  eval_metric      = "aucpr",
  max_depth        = 6,
  eta              = 0.1,
  scale_pos_weight = spw
)

set.seed(94)
xgb_model <- xgb.train(params, dtrain, nrounds = 150, verbose = 0)

pred_xgb <- predict(xgb_model, dtest)

xgb_res <- evaluate(test$Class, pred_xgb, threshold = 0.5, label = "XGBoost (με βάρη)")

## --- XGBoost (με βάρη) (threshold = 0.5 ) ---
##       Predicted
## Actual     0     1
##      0 85281    14
##      1    22   126
## 
## Fraud caught (TP): 126  Fraud missed (FN): 22  False alarms (FP): 14 
## Precision: 0.9 | Recall: 0.8514 | F1: 0.875 
## ROC-AUC: 0.9803 | PR-AUC: 0.8616

Ερώτηση 2

Για να απομονώσουμε την επίδραση της αντιμετώπισης της ανισορροπίας, εκπαιδεύουμε ένα δεύτερο XGBoost χωρίς βάρη και συγκρίνουμε με το μοντέλο.

params_unw <- params
params_unw$scale_pos_weight <- 1

set.seed(94)
xgb_unw <- xgb.train(params_unw, dtrain, nrounds = 150, verbose = 0)
pred_unw <- predict(xgb_unw, dtest)

unw_res <- evaluate(test$Class, pred_unw, threshold = 0.5,label = "XGBoost (χωρίς βάρη)")

## --- XGBoost (χωρίς βάρη) (threshold = 0.5 ) ---
##       Predicted
## Actual     0     1
##      0 85291     4
##      1    30   118
## 
## Fraud caught (TP): 118  Fraud missed (FN): 30  False alarms (FP): 4 
## Precision: 0.9672 | Recall: 0.7973 | F1: 0.8741 
## ROC-AUC: 0.9801 | PR-AUC: 0.8618

Το βάρος στη θετική κλάση ανταλλάσει λίγο precision για ουσιαστικό κέρδος στο recall. Το μοντέλο εντοπίζει περισσότερες από τις σπάνιες απάτες στο προεπιλεγμένο κατόφλι.

Ερώτηση 3

Παρότι τα χαρακτηριστικά είναι ανώνυμα, το XGBoost μας λέει ποια οδηγούν στην ανίχνευση.

importance <- xgb.importance(model = xgb_model)
print(head(importance, 10))

##     Feature       Gain      Cover  Frequency
##      <char>      <num>      <num>      <num>
##  1:     V14 0.69128014 0.25624675 0.06607539
##  2:      V4 0.06706925 0.13507141 0.06563193
##  3:      V8 0.02540563 0.01517702 0.03281596
##  4:  Amount 0.02324721 0.02004121 0.03991131
##  5:     V12 0.02205286 0.06573006 0.05321508
##  6:     V10 0.01572641 0.08316870 0.04434590
##  7:      V7 0.01479704 0.05968729 0.04390244
##  8:      V1 0.01244930 0.05858371 0.04146341
##  9:     V19 0.01133595 0.03384091 0.02682927
## 10:     V17 0.01031379 0.03551934 0.02793792

xgb.plot.importance(importance[1:10, ],
                    main = "Top 10 χαρακτηριστικά κατά σημαντικότητα (Gain)")

Λίγες από τις συνιστώσες PCA (συνήθως οι V14, V17, V12 , V10 , V4) κυριαρχούν στη στήλη Gain, μεταφέρουν το μεγαλύτερο μέρος του σήματος που διαχωρίζει την απάτη από τη νόμιμη συναλλαγή.

Ερώτηση 4

Σύγκριση απλού μοντέλου vs Ensemble

Ερώτηση 5

Το προεπιλεγμένο κατώφλι είναι 0.5. Επειδή μια χαμένη απάτη κοστίζει περισσότερο από έναν λανθασμένο συναγερμό, σαρώνουμε διάφορα κατώφλια και διαβάζουμε το : trade-off precission / recall , για να επιλέξουμε ένα σημείο που μεγιστοποιεί το recall (ελαχιστοποιεί τα false negatives) χωρίς να εκτοξεύει τα false positives.

thresholds <- seq(0.10, 0.90, by = 0.05)

scan <- data.frame(t = thresholds,
                   Recall = NA, Precision = NA,
                   FN = NA, FP = NA)

for (i in seq_along(thresholds)) {
  pred <- ifelse(pred_xgb > thresholds[i], 1, 0)
  TP <- sum(pred == 1 & test$Class == 1)
  FP <- sum(pred == 1 & test$Class == 0)
  FN <- sum(pred == 0 & test$Class == 1)
  scan$Recall[i]    <- TP / (TP + FN)
  scan$Precision[i] <- ifelse(TP + FP == 0, NA, TP / (TP + FP))
  scan$FN[i] <- FN
  scan$FP[i] <- FP
}
print(scan, row.names = FALSE)

##     t    Recall Precision FN FP
##  0.10 0.8648649 0.7191011 20 50
##  0.15 0.8648649 0.7852761 20 35
##  0.20 0.8581081 0.8355263 21 25
##  0.25 0.8581081 0.8639456 21 20
##  0.30 0.8581081 0.8639456 21 20
##  0.35 0.8581081 0.8819444 21 17
##  0.40 0.8581081 0.8943662 21 15
##  0.45 0.8581081 0.9007092 21 14
##  0.50 0.8513514 0.9000000 22 14
##  0.55 0.8513514 0.9064748 22 13
##  0.60 0.8513514 0.9197080 22 11
##  0.65 0.8445946 0.9191176 23 11
##  0.70 0.8310811 0.9248120 25 10
##  0.75 0.8310811 0.9389313 25  8
##  0.80 0.8243243 0.9457364 26  7
##  0.85 0.8175676 0.9527559 27  6
##  0.90 0.8175676 0.9680000 27  4

plot(scan$t, scan$Recall, type = "b", pch = 19, col = "steelblue",
     ylim = c(0, 1), xlab = "Κατώφλι πιθανότητας", ylab = "Τιμή",
     main = "Precision vs Recall σε διάφορα κατώφλια")
lines(scan$t, scan$Precision, type = "b", pch = 17, col = "firebrick")
legend("bottom", legend = c("Recall", "Precision"),
       col = c("steelblue", "firebrick"), pch = c(19, 17), horiz = TRUE)

Διαβάζοντας τις καμπύλες, ένα χαμηλότερο κατώφλι ανεβαίζει το recall (λιγότερες χαμένες απάτες) με κόστος το precision. Ένα λογικό σημείο λειτουργίας κρατά το recall υψηλό ενώ η precision παραμένει αποδεκτή.