DAEN 690 Immigration Fraud project
Khanh Nguyen
10/9/2021
##Reference: George Mason University https://www.gmudatamining.com/
In this analysis, we will perform classification using logistic regression, knn, linear discriminant analysis (lda), quadratic dicriminant analysis (qda), decision tree, and random forest algorithms with R packages tidymodels.
The generated synthetic dataset contains demographics and outcomes of various variables in finite numeric and binary data type . The variable of interest in this dataset is FraudAlerted and it indicates whether an immigration application is a fraud or not. (Yes or No).
library(vip)
library(lubridate)
library(readxl)
library(scales)
library(tidyverse)
library(tidymodels)
library(discrim) # for discriminant analysis
library(tidyverse)
library(rpart.plot)
library(ranger)
library(scatterplot3d)
library(readr)
library(lubridate)
library(plotly)
library(corrplot)
library(ggthemes)
library(viridisLite)
library(gclus)df <- read_xlsx('C:/Users/Khanh/Desktop/GMUeducation/DAEN_690/week7/GroundTruthdata.xlsx')
#write.csv(df,"'C:/Users/Khanh/Desktop/GMUeducation/DAEN_690/week7/GroundTruthdata.csv", row.names = FALSE)
df$FraudAlerted <- as.factor(df$FraudAlerted)
df# A tibble: 5,492 x 16
`Last Name` `First Name` Gender Income Age_Gap NumChildren NumDivorce
<chr> <chr> <chr> <dbl> <dbl> <dbl> <dbl>
1 SMITH JAMES Male 6.57e4 8.77 6.56 1.33
2 JOHNSON JOHN Male 8.19e4 10.7 4.20 3.00
3 WILLIAMS ROBERT Male 8.60e4 11.1 4.42 2.97
4 JONES MICHAEL Male 1.68e5 6.50 1.38 0.912
5 BROWN WILLIAM Male 4.21e4 3.78 1.64 0.998
6 DAVIS DAVID Male 8.98e4 0.472 4.26 1.19
7 MILLER RICHARD Male 1.68e5 15.0 3.29 2.41
8 WILSON CHARLES Male 8.76e4 14.2 1.76 0.753
9 MOORE JOSEPH Male 1.54e5 3.30 0.885 3.76
10 TAYLOR THOMAS Male 1.25e5 9.22 3.47 1.72
# ... with 5,482 more rows, and 9 more variables: DiffLanguage <dbl>,
# TooManyChildren <dbl>, TooManyDivorce <dbl>, TooLowIncome <dbl>,
# BigAgeGap <dbl>, DiffAddress <dbl>, PreviousImmigrationProblem <dbl>,
# CriminalHistory <dbl>, FraudAlerted <fct>summarise(df)# A tibble: 1 x 0Visual Exploration of numeric predictors
Histograms for Income variable
ggplot(data = df, mapping = aes(x = Income)) +
geom_histogram(fill = '#006EA1', color = 'white', bins = 50) +
labs(title = 'Distribution of Income') +
theme_light()
Age_Gap
ggplot(data = df, mapping = aes(x = Age_Gap)) +
geom_histogram(fill = 'brown', color = 'white', bins = 20) +
labs(title = 'Distribution of Age Gap') +
theme_light()
Number of Divorce
ggplot(data = df, mapping = aes(NumDivorce)) +
geom_histogram(fill = 'orange', color = 'black', bins = 6, position = 'dodge') +
labs(title = 'Distribution of Number of Divorce') +
theme_light()
Number of Children
ggplot(data = df, mapping = aes(NumChildren)) +
geom_histogram(fill = 'green', color = 'black', bins = 8, position = 'dodge') +
labs(title = 'Distribution of Number of Divorce') +
theme_light()
3D graph to identify Outliers
library(scatterplot3d)
attach(df)
scatterplot3d(`Income`, `Age_Gap`, `NumChildren`, color = 'red', main = "3D View for Income, Age Gap, Number of Children")
We selected the 3 variables: Income, Age_Gap, NumChildren for further analysis. We want to visually explore them to see if we can identify any big outliers right away. According to our graph, there are no outliers really stand out from the 3D scatter plot.
3D interactive scatter plot
figure2 <- plot_ly(df, x = ~`Income`, y=~ `Age_Gap`, z= ~`NumChildren`)
figure2 <- figure2 %>% add_markers()
figure2 <- figure2 %>% layout(title = "Interactive 3D View for Income, Age Gap, Number of Children")
figure2This 3D interactive graph give us the view from different angle to the 3 variables. We zoomed in and out of the scattered dots and we don’t really see any big outliers that help us identify fraud.
Logistic Regression
In logistic regression classification model, we are interested in predicting FraudAlerted = 'Yes', is known as the Postive event. Whereas the remaining event, FraudAlerted = 'No', is the Negative event.
We will follow the model fitting processfor our classification model, whether logistic regression or a different type of algorithm, we will take the following steps:
Split the data into a training and test set
Specify a feature engineering pipeline with the
recipespackageSpecify a model object
Package your recipe and model into a workflow
Fit your workflow to the training data
If our model has hyperparameters, we perform hyperparameter tuning
Evaluate model performance on the test set by studying the confusion matrix, ROC curve, and other performance metrics.
Data Splitting
For the df data, the event we are predicting is FraudAlerted = 'Yes'. The levels() function to check the FraudAlerted variable and it has 2 levels: “no”, “yes”.
levels(df$FraudAlerted)[1] "no" "yes"We split the data 70% for training and 30% for testing to calculate the model performance with measurement metrics.
set.seed(345)
df_split <- initial_split(df, prop = 0.70,
strata = FraudAlerted)
df_training <- df_split %>% training()
df_test <- df_split %>% testing()Feature Engineering
Next we create our feature engineering pipeline with these below steps:
- Remove skewness from numeric predictors
- Normalize all numeric predictors
- Create dummy variables for all nominal predictors
df_recipe <- recipe(FraudAlerted ~ Income + Age_Gap + NumDivorce + DiffLanguage +DiffAddress + PreviousImmigrationProblem + CriminalHistory, data = df_training) %>%
step_YeoJohnson(all_numeric(), -all_outcomes()) %>%
step_normalize(all_numeric(), -all_outcomes()) %>%
step_dummy(all_nominal(), -all_outcomes())We use these variables as predictors for Fraud: Income + Age_Gap + NumDivorce + DiffLanguage +DiffAddress + PreviousImmigrationProblem + CriminalHistory
The code below processes our training data with prep() and bake().
df_recipe %>%
prep(training = df_training) %>%
bake(new_data = NULL)# A tibble: 3,845 x 8
Income Age_Gap NumDivorce DiffLanguage DiffAddress PreviousImmigra~
<dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 1.68 -0.232 -1.04 -0.337 -0.278 -0.0972
2 -1.28 -0.992 -0.929 -0.337 -0.278 -0.0972
3 0.110 -2.41 -0.696 -0.337 -0.278 -0.0972
4 1.43 -1.15 1.47 -0.337 -0.278 -0.0972
5 0.891 0.383 -0.127 -0.337 -0.278 -0.0972
6 -0.981 -0.0196 1.82 -0.337 -0.278 -0.0972
7 1.92 1.23 0.445 -0.337 -0.278 -0.0972
8 1.25 0.210 -1.23 -0.337 -0.278 -0.0972
9 -0.470 0.502 -0.869 -0.337 -0.278 -0.0972
10 0.269 -0.0186 -1.12 -0.337 -0.278 -0.0972
# ... with 3,835 more rows, and 2 more variables: CriminalHistory <dbl>,
# FraudAlerted <fct>Model Specification
We use the logistic_reg() function with our engine is glm and our mode is ‘classification’.
logistic_model <- logistic_reg() %>%
set_engine('glm') %>%
set_mode('classification')Create a Workflow
Now we can combine our model object and recipe into a single workflow object using the workflow() function.
df_wf <- workflow() %>%
add_model(logistic_model) %>%
add_recipe(df_recipe)Fit the Model
Next we fit our workflow to the training data. This is done by passing our workflow object to the fit() function
df_logistic_fit <- df_wf %>%
fit(data = df_training)Exploring our Trained Model
We pass df_logistic_fit to the pull_workflow_fit() function to extract our trained model from the workflow.
df_trained_model <- df_logistic_fit %>%
pull_workflow_fit()Variable Importance
Next we pass df_trained_model to the vip() function. This will return a ggplot object with the variable importance scores from our model. The importance scores are based on the z-statistics associated with each predictor.
We see from the results below, that Different Language, Different Address, Number of Divorces are the top 3 important predictors of immigration fraud from our synthetic data set.
vip(df_trained_model)
Evaluate Performance
We create a results data frame with the following data:
- The true response values from our test set
- The predicted response category for each row of our test data
- The estimated probabilities for each response category
Predicted Categories
We get a data frame with a column named .pred_class which has the predicted category (yes/no) for each row of our test data set.
predictions_categories <- predict(df_logistic_fit,
new_data = df_test)
predictions_categories# A tibble: 1,647 x 1
.pred_class
<fct>
1 no
2 yes
3 no
4 no
5 no
6 no
7 no
8 no
9 yes
10 no
# ... with 1,637 more rowsNext we need to obtain the estimated probabilities for each category of our response variable. In this case we get a data frame with the following columns, .pred_yes and .pred_no.
predictions_probabilities <- predict(df_logistic_fit,
new_data = df_test,
type = 'prob')
predictions_probabilities# A tibble: 1,647 x 2
.pred_no .pred_yes
<dbl> <dbl>
1 0.996 0.00428
2 0.222 0.778
3 0.928 0.0720
4 0.912 0.0880
5 0.996 0.00417
6 0.967 0.0327
7 0.890 0.110
8 0.999 0.00110
9 0.176 0.824
10 0.945 0.0554
# ... with 1,637 more rowsThe final step is to combine the results from above with the true response variable values in our test data set.
library(dplyr)
# Combine
test_results <- df_test %>% #select(`FraudAlerted`) %>%
bind_cols(predictions_categories) %>%
bind_cols(predictions_probabilities)
test_results# A tibble: 1,647 x 19
`Last Name` `First Name` Gender Income Age_Gap NumChildren NumDivorce
<chr> <chr> <chr> <dbl> <dbl> <dbl> <dbl>
1 SMITH JAMES Male 6.57e4 8.77 6.56 1.33
2 JOHNSON JOHN Male 8.19e4 10.7 4.20 3.00
3 WILLIAMS ROBERT Male 8.60e4 11.1 4.42 2.97
4 MILLER RICHARD Male 1.68e5 15.0 3.29 2.41
5 WILSON CHARLES Male 8.76e4 14.2 1.76 0.753
6 HARRIS DONALD Male 2.37e4 11.7 1.46 2.42
7 THOMPSON KENNETH Male 1.11e5 5.87 3.29 1.23
8 CLARK RONALD Male 1.49e5 16.1 0.927 0.0712
9 YOUNG JOSE Male 7.48e4 6.81 2.91 4.10
10 HERNANDEZ LARRY Male 7.12e4 10.8 3.41 2.82
# ... with 1,637 more rows, and 12 more variables: DiffLanguage <dbl>,
# TooManyChildren <dbl>, TooManyDivorce <dbl>, TooLowIncome <dbl>,
# BigAgeGap <dbl>, DiffAddress <dbl>, PreviousImmigrationProblem <dbl>,
# CriminalHistory <dbl>, FraudAlerted <fct>, .pred_class <fct>,
# .pred_no <dbl>, .pred_yes <dbl>Exploring Performance Metrics
We’re calculating performance metrics on the results of a machine learning algorithm.
Confusion Matrix
We have 77 false positives (we predicted the positive class (‘yes’) but the truth was ‘no’) and 32 false negatives.
conf_mat(test_results,
truth = FraudAlerted,
estimate = .pred_class) Truth
Prediction no yes
no 1435 77
yes 32 103Sensitivity
The sensitivity is a performance metric that calculates the proportion of actual positive cases that the classification model predicted correctly. In our dataset, this is the proportion of applications who were predicted to be fraud (FraudAlerted = Yes).
From the results below, we have a sensitivity of 0.97818 on our test data results.
sens(test_results,
truth = FraudAlerted,
estimate = .pred_class)# A tibble: 1 x 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 sens binary 0.978ROC Curve
The roc_curve() function takes a data frame with model results, the truth, and estimate columns to produce a data frame with the specificity and sensitivity for all probability thresholds.
roc_curve(test_results,
truth = FraudAlerted,
estimate = .pred_yes)# A tibble: 1,649 x 3
.threshold specificity sensitivity
<dbl> <dbl> <dbl>
1 -Inf 0 1
2 0.0000370 0 1
3 0.0000413 0 0.999
4 0.0000460 0 0.999
5 0.0000571 0 0.998
6 0.0000721 0 0.997
7 0.0000758 0 0.997
8 0.0000812 0 0.996
9 0.0000887 0 0.995
10 0.0000913 0 0.995
# ... with 1,639 more rowsArea Under the ROC Curve
To calculate the area under the ROC curve, we use the roc_auc(). From our results below, our model gets a “A” at 92%.
roc_auc <- roc_auc(test_results,
truth = FraudAlerted,
.pred_no)
roc_auc# A tibble: 1 x 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 roc_auc binary 0.920F1 Score
The F1 score is a performance metric that equally balances our false positive and false negative mistakes. The range of an F1 score is from 0 (worst) to 1 (best). From the results below, we have an F1 score on our test data results.
f_meas(test_results,
truth = FraudAlerted,
estimate = .pred_class)# A tibble: 1 x 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 f_meas binary 0.963Creating Custom Metric Sets
The metric set below produce the accuracy, sensitivity, F1 results.
my_metrics <- metric_set(accuracy, sens,f_meas)
my_metrics(test_results,
truth = FraudAlerted,
estimate = .pred_class,
.pred_yes)# A tibble: 3 x 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 accuracy binary 0.934
2 sens binary 0.978
3 f_meas binary 0.963Automating the Process
We automate the process of fitting a logistic regression model. This automatically apply the predictions and metrics on our test data set.
last_fit_model <- df_wf %>%
last_fit(split = df_split,
metrics = my_metrics)We obtain the metrics on the test set (accuracy, sensitivity, f1).
last_fit_model %>%
collect_metrics()# A tibble: 3 x 4
.metric .estimator .estimate .config
<chr> <chr> <dbl> <fct>
1 accuracy binary 0.934 Preprocessor1_Model1
2 sens binary 0.978 Preprocessor1_Model1
3 f_meas binary 0.963 Preprocessor1_Model1We also obtain a data frame with test set results.
last_fit_results <- last_fit_model %>%
collect_predictions()
last_fit_results# A tibble: 1,647 x 5
id .pred_class .row FraudAlerted .config
<chr> <fct> <int> <fct> <fct>
1 train/test split no 1 no Preprocessor1_Model1
2 train/test split yes 2 yes Preprocessor1_Model1
3 train/test split no 3 no Preprocessor1_Model1
4 train/test split no 7 no Preprocessor1_Model1
5 train/test split no 8 no Preprocessor1_Model1
6 train/test split no 15 no Preprocessor1_Model1
7 train/test split no 17 no Preprocessor1_Model1
8 train/test split no 21 no Preprocessor1_Model1
9 train/test split yes 28 yes Preprocessor1_Model1
10 train/test split no 29 no Preprocessor1_Model1
# ... with 1,637 more rows#DISCRIMINANT ANALYSIS
In this section, we performed classification with discriminant analysis and include hyperparameter tuning. We used an R package for this lesson, discrim. This packages is part of tidymodels and serves as a general interface to discriminant analysis algorithms in R.
library(tidymodels)
library(discrim) # for discriminant analysisThe outcome variable in this data is yes which indicates whether the immigration applicant is a potential fraud.
df <- read_xlsx('C:/Users/Khanh/Desktop/GMUeducation/DAEN_690/week7/GroundTruthdata.xlsx')
df$FraudAlerted <- as.factor(df$FraudAlerted)
df# A tibble: 5,492 x 16
`Last Name` `First Name` Gender Income Age_Gap NumChildren NumDivorce
<chr> <chr> <chr> <dbl> <dbl> <dbl> <dbl>
1 SMITH JAMES Male 6.57e4 8.77 6.56 1.33
2 JOHNSON JOHN Male 8.19e4 10.7 4.20 3.00
3 WILLIAMS ROBERT Male 8.60e4 11.1 4.42 2.97
4 JONES MICHAEL Male 1.68e5 6.50 1.38 0.912
5 BROWN WILLIAM Male 4.21e4 3.78 1.64 0.998
6 DAVIS DAVID Male 8.98e4 0.472 4.26 1.19
7 MILLER RICHARD Male 1.68e5 15.0 3.29 2.41
8 WILSON CHARLES Male 8.76e4 14.2 1.76 0.753
9 MOORE JOSEPH Male 1.54e5 3.30 0.885 3.76
10 TAYLOR THOMAS Male 1.25e5 9.22 3.47 1.72
# ... with 5,482 more rows, and 9 more variables: DiffLanguage <dbl>,
# TooManyChildren <dbl>, TooManyDivorce <dbl>, TooLowIncome <dbl>,
# BigAgeGap <dbl>, DiffAddress <dbl>, PreviousImmigrationProblem <dbl>,
# CriminalHistory <dbl>, FraudAlerted <fct>Linear Discriminant Analysis
Linear discriminant analysis (LDA) is a classification algorithm where the set of predictor variables are assumed to follow a multivariate normal distribution with a common covariance matrix. We use LDA to predict whether a record is potentially alerted for Fraud in the df data frame. We will follow our standard machine learning workflow that was introduced in the previous logistic regression.
Data Splitting
We split the data to 70% for training and 30% for testing.
set.seed(314)
df_split <- initial_split(df, prop = 0.70,
strata = FraudAlerted)
df_training <- df_split %>% training()
df_test <- df_split %>% testing()Feature Engineering Recipe
We follow the same steps of feature engineering:
- Remove skewness from numeric predictors
- Normalize all numeric predictors
- Create dummy variables for all nominal predictors
df_recipe <- recipe(FraudAlerted ~ Income + Age_Gap + NumDivorce + DiffLanguage +DiffAddress + PreviousImmigrationProblem + CriminalHistory, data = df_training) %>%
step_YeoJohnson(all_numeric(), -all_outcomes()) %>%
step_normalize(all_numeric(), -all_outcomes()) %>%
step_dummy(all_nominal(), -all_outcomes())The result from the feature engineering steps have been carried out correctly.
df_recipe %>%
prep(training = df_training) %>%
bake(new_data = NULL)# A tibble: 3,845 x 8
Income Age_Gap NumDivorce DiffLanguage DiffAddress PreviousImmigra~
<dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
1 -0.0946 0.671 0.952 3.14 -0.283 -0.101
2 0.0115 0.750 0.931 -0.319 -0.283 -0.101
3 1.72 -0.232 -1.01 -0.319 -0.283 -0.101
4 -1.29 -0.991 -0.902 -0.319 -0.283 -0.101
5 0.105 -2.40 -0.673 -0.319 -0.283 -0.101
6 0.0506 1.30 -1.22 -0.319 -0.283 -0.101
7 1.46 -1.15 1.46 -0.319 -0.283 -0.101
8 -0.995 -0.0191 1.81 -0.319 -0.283 -0.101
9 1.96 1.23 0.450 -0.319 -0.283 -0.101
10 1.27 0.212 -1.20 -0.319 -0.283 -0.101
# ... with 3,835 more rows, and 2 more variables: CriminalHistory <dbl>,
# FraudAlerted <fct>LDA Model Specification
Linear discriminant analysis is specified with the discrim_regularized function. The optional frac_common_cov is used to specify an LDA or QDA model.
For LDA, we set frac_common_cov = 1. This instructs discrim_regularied that we are assuming that each class in the response variable has the same variance. FOR QDA, we set frac_common_cov = 0, indicating that each class within our response variable has its own class-specific variance.
lda_model <- discrim_regularized(frac_common_cov = 1) %>%
set_engine('klaR') %>%
set_mode('classification')Create a Workflow
Next we create a workflow that combines our feature engineering steps and LDA model.
lda_wf <- workflow() %>%
add_model(lda_model) %>%
add_recipe(df_recipe)Train and Evaluate With last_fit()
Finally we will train our model and estimate performance on our test data set.
last_fit_lda <- lda_wf %>%
last_fit(split = df_split)To obtain the metrics on the test set (accuracy and roc_auc)
last_fit_lda %>% collect_metrics()# A tibble: 2 x 4
.metric .estimator .estimate .config
<chr> <chr> <dbl> <fct>
1 accuracy binary 0.937 Preprocessor1_Model1
2 roc_auc binary 0.930 Preprocessor1_Model1We obtain a data frame with test set results. It contains the estimated probabilities for fraud, .pred_yes, the predicted class of our response variable, .pred_class, and the truth, FraudAlerted.
lda_predictions <- last_fit_lda %>%
collect_predictions()
lda_predictions# A tibble: 1,647 x 7
id .pred_no .pred_yes .row .pred_class FraudAlerted .config
<chr> <dbl> <dbl> <int> <fct> <fct> <fct>
1 train/test ~ 0.992 0.00809 1 no no Preprocessor1~
2 train/test ~ 0.958 0.0417 7 no no Preprocessor1~
3 train/test ~ 0.987 0.0134 10 no no Preprocessor1~
4 train/test ~ 0.993 0.00683 14 no no Preprocessor1~
5 train/test ~ 0.975 0.0246 15 no no Preprocessor1~
6 train/test ~ 0.389 0.611 28 yes yes Preprocessor1~
7 train/test ~ 0.967 0.0329 29 no no Preprocessor1~
8 train/test ~ 0.995 0.00514 30 no no Preprocessor1~
9 train/test ~ 0.996 0.00353 32 no no Preprocessor1~
10 train/test ~ 0.982 0.0180 40 no no Preprocessor1~
# ... with 1,637 more rowsConfusion Matrix
We see that our model made 20 false negatives and 83 false positives.
conf_mat(lda_predictions, truth = FraudAlerted, estimate = .pred_class) Truth
Prediction no yes
no 1447 83
yes 20 97F1 Score
The F1 score is calculated below:
f_meas(lda_predictions, truth = FraudAlerted, estimate = .pred_class)# A tibble: 1 x 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 f_meas binary 0.966Quadratic Discriminant Analysis
QDA Model Specification
For QDA, we set frac_common_cov = 0, indicating that each class within our response variable has its own class-specific variance.
qda_model <- discrim_regularized(frac_common_cov = 0) %>%
set_engine('klaR') %>%
set_mode('classification')Create a Workflow
Next we create a QDA workflow object that combines our feature engineering steps from the previous section and our QDA model.
qda_wf <- workflow() %>%
add_model(qda_model) %>%
add_recipe(df_recipe)Train and Evaluate With last_fit()
Finally we train our model and estimate performance on our test data set.
last_fit_qda <- qda_wf %>%
last_fit(split = df_split)We collect the metrics for accuray and roc_auc:
last_fit_qda %>% collect_metrics()# A tibble: 2 x 4
.metric .estimator .estimate .config
<chr> <chr> <dbl> <fct>
1 accuracy binary 0.875 Preprocessor1_Model1
2 roc_auc binary 0.912 Preprocessor1_Model1QDA model prediction is as below:
qda_predictions <- last_fit_qda %>%
collect_predictions()
qda_predictions# A tibble: 1,647 x 7
id .pred_no .pred_yes .row .pred_class FraudAlerted .config
<chr> <dbl> <dbl> <int> <fct> <fct> <fct>
1 train/test ~ 0.999 0.00106 1 no no Preprocessor1~
2 train/test ~ 0.982 0.0176 7 no no Preprocessor1~
3 train/test ~ 0.998 0.00157 10 no no Preprocessor1~
4 train/test ~ 0.999 0.00126 14 no no Preprocessor1~
5 train/test ~ 0.986 0.0139 15 no no Preprocessor1~
6 train/test ~ 0.277 0.723 28 yes yes Preprocessor1~
7 train/test ~ 0.997 0.00281 29 no no Preprocessor1~
8 train/test ~ 0.999 0.00148 30 no no Preprocessor1~
9 train/test ~ 0.998 0.00169 32 no no Preprocessor1~
10 train/test ~ 0.997 0.00326 40 no no Preprocessor1~
# ... with 1,637 more rowsConfusion Matrix
We see that our model made 159 false negatives and 47 false positives.
conf_mat(qda_predictions, truth = FraudAlerted, estimate = .pred_class) Truth
Prediction no yes
no 1308 47
yes 159 133F1 Score
The F1 score is calculated below:
f_meas(qda_predictions, truth = FraudAlerted, estimate = .pred_class)# A tibble: 1 x 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 f_meas binary 0.927Our QDA model had lower performance to our LDA model. Remember that QDA is a more complicated model than LDA since we are estimating more parameters.
Since we didn’t get any improvement in model performance, it is always recommended to choose the simpler model which is the LDA model if we are deciding which one to use.
K-Nearest Neighbor
In this section, we will perform classification using the k-nearest neighbor (KNN) algorithm and hyperparameter tuning with cross validation.
Classification
We will use KNN to predict whether a immigration application is a potential fraud or not in our synthetic data. To do this, we adjust our machine learning workflow by incorporating hyperparameter tuning.
Data Splitting
Since we perform hyperparameter tuning, we need to add the extra step of creating cross validation folds from our training data. This is done with the vfold_cv() function.
In the code below, we further split our df_training data into folds with vfold_cv(). The v parameter specifies how many folds to create. We are creating 5 folds.
### Create folds for cross validation on the training data set
## These will be used to tune model hyperparameters
set.seed(314)
df_folds <- vfold_cv(df_training, v = 5)Feature Engineering
Since we have already trained our feature engineering steps, we can use the df_recipe in our KNN modeling.
KNN Model Specification
In the code below, we specify our KNN classification model with the “kknn” engine.
knn_model <- nearest_neighbor(neighbors = tune()) %>%
set_engine('kknn') %>%
set_mode('classification')Creating a Workflow
Follow similar steps, we create a workflow with our recipe and model.
knn_wf <- workflow() %>%
add_model(knn_model) %>%
add_recipe(df_recipe)Hyperparameter tuning
Hyperparameter tuning is performed using a grid search algorithm. We create a data frame with values ranging from 10 to 150. Our goal here is to choose a range of values to test, from small to relatively large numbers of neighbors and determine which one is best.
## Create a grid of hyperparameter values to test
k_grid <- tibble(neighbors = c(10, 20, 30, 50, 75, 100, 125, 150))# View grid
k_grid# A tibble: 8 x 1
neighbors
<dbl>
1 10
2 20
3 30
4 50
5 75
6 100
7 125
8 150We use tune_grid() function to take a model or workflow object, cross validation folds, and a tuning grid as arguments.
## Tune workflow
set.seed(123)
knn_tuning <- knn_wf %>%
tune_grid(resamples = df_folds,
grid = k_grid)From the results below, we see that for each value of neighbors we specified, tune_grid() fit a KNN model with that parameter value 5 times (since we have 5 folds in our cross validation object). The mean column in the results below indicates the average value of the performance metric that was obtained
## Show the top 5 best models based on roc_auc metric
knn_tuning %>% show_best('roc_auc')# A tibble: 5 x 7
neighbors .metric .estimator mean n std_err .config
<dbl> <chr> <chr> <dbl> <int> <dbl> <fct>
1 75 roc_auc binary 0.946 5 0.00665 Preprocessor1_Model5
2 50 roc_auc binary 0.946 5 0.00646 Preprocessor1_Model4
3 100 roc_auc binary 0.945 5 0.00699 Preprocessor1_Model6
4 125 roc_auc binary 0.944 5 0.00738 Preprocessor1_Model7
5 150 roc_auc binary 0.942 5 0.00757 Preprocessor1_Model8We use the select_best() model to select the model from our tuning results that had the best overall performance.
## Select best model based on roc_auc
best_k <- knn_tuning %>%
select_best(metric = 'roc_auc')
## View model
best_k# A tibble: 1 x 2
neighbors .config
<dbl> <fct>
1 75 Preprocessor1_Model5The last step is to use finalize_workflow() to add our optimal model to our workflow object.
## Finalize workflow by adding the best performing model
final_knn_wf <- knn_wf %>%
finalize_workflow(best_k)Train and Evaluate With last_fit()
After we have tuned our hyperparameter, and finalized our workflow object with the optimal model, we train our model and estimate performance on our test data set.
last_fit_knn <- final_knn_wf %>%
last_fit(split = df_split)Based on the accuracy and the area under the ROC curve, our model has a great score and performs better than LDA and QDA.
last_fit_knn %>% collect_metrics()# A tibble: 2 x 4
.metric .estimator .estimate .config
<chr> <chr> <dbl> <fct>
1 accuracy binary 0.945 Preprocessor1_Model1
2 roc_auc binary 0.953 Preprocessor1_Model1ROC Curve
Let’s also have a look at our ROC curve and confusion matrix.
knn_predictions <- last_fit_knn %>%
collect_predictions()
knn_predictions# A tibble: 1,647 x 7
id .pred_no .pred_yes .row .pred_class FraudAlerted .config
<chr> <dbl> <dbl> <int> <fct> <fct> <fct>
1 train/test ~ 1 0 1 no no Preprocessor1~
2 train/test ~ 0.918 0.0822 7 no no Preprocessor1~
3 train/test ~ 1 0 10 no no Preprocessor1~
4 train/test ~ 1 0 14 no no Preprocessor1~
5 train/test ~ 1 0 15 no no Preprocessor1~
6 train/test ~ 0.296 0.704 28 yes yes Preprocessor1~
7 train/test ~ 0.947 0.0532 29 no no Preprocessor1~
8 train/test ~ 1 0 30 no no Preprocessor1~
9 train/test ~ 1 0 32 no no Preprocessor1~
10 train/test ~ 1 0 40 no no Preprocessor1~
# ... with 1,637 more rowsConfusion Matrix
We see that our model made 0 false negatives and 91 false positives.
conf_mat(knn_predictions, truth = FraudAlerted, estimate = .pred_class) Truth
Prediction no yes
no 1467 91
yes 0 89F1 Score
The F1 score has been improved to 96.99% from the previous LDA model 96.59%
f_meas(lda_predictions, truth = FraudAlerted, estimate = .pred_class)# A tibble: 1 x 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 f_meas binary 0.966f_meas(knn_predictions, truth = FraudAlerted, estimate = .pred_class)# A tibble: 1 x 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 f_meas binary 0.970Decision Tree
Next, we build a decision tree classifier with the following hyperparameters:
cost_complexity: The cost complexity parameter tree_depth: The maximum depth of a tree min_n: The minimum number of data points in a node that are required for the node to be split further.
tree_model <- decision_tree(cost_complexity = tune(),
tree_depth = tune(),
min_n = tune()) %>%
set_engine('rpart') %>%
set_mode('classification')###Workflow:
Next, we combine our model and recipe into a workflow to easily manage the model-building process.
tree_workflow <- workflow() %>%
add_model(tree_model) %>%
add_recipe(df_recipe)###Hyperparameter Tuning We will perform a grid search on the decision tree hyperparameters and select the best performing model.
## Create a grid of hyperparameter values to test
tree_grid <- grid_regular(cost_complexity(),
tree_depth(),
min_n(),
levels = 2)
# View grid
tree_grid# A tibble: 8 x 3
cost_complexity tree_depth min_n
<dbl> <int> <int>
1 0.0000000001 1 2
2 0.1 1 2
3 0.0000000001 15 2
4 0.1 15 2
5 0.0000000001 1 40
6 0.1 1 40
7 0.0000000001 15 40
8 0.1 15 40###Tuning Hyperparameters with tune_grid() To find the optimal combination of hyperparameters from our tuning grid, we will use the cross valdidation folds for and a tree grid data frame.
## Tune decision tree workflow
set.seed(314)
tree_tuning <- tree_workflow %>%
tune_grid(resamples = df_folds,
grid = tree_grid)To view the results of our hyperparameter tuning, we fit a decision tree model with that combination 5 times (since we have 5 folds in our cross validation object). The mean column in the results below indicates the average value of the performance metric.
## Show the top 5 best models based on roc_auc metric
tree_tuning %>% show_best('roc_auc')# A tibble: 5 x 9
cost_complexity tree_depth min_n .metric .estimator mean n std_err
<dbl> <int> <int> <chr> <chr> <dbl> <int> <dbl>
1 0.0000000001 15 40 roc_auc binary 0.891 5 0.0135
2 0.0000000001 15 2 roc_auc binary 0.883 5 0.00950
3 0.0000000001 1 2 roc_auc binary 0.5 5 0
4 0.1 1 2 roc_auc binary 0.5 5 0
5 0.1 15 2 roc_auc binary 0.5 5 0
# ... with 1 more variable: .config <fct>We select the model from our tuning results that had the best overall performance. In the code below, we see that the model with a cost complexity of 1e-10, a tree depth of 15, and minimum n of 40 produced the best model.
## Select best model based on roc_auc
best_tree <- tree_tuning %>%
select_best(metric = 'roc_auc')
# View the best tree parameters
best_tree# A tibble: 1 x 4
cost_complexity tree_depth min_n .config
<dbl> <int> <int> <fct>
1 0.0000000001 15 40 Preprocessor1_Model7###Finalize Workflow The last step in hyperparameter tuning is to use finalize_workflow() to add our optimal model to our workflow object.
final_tree_workflow <- tree_workflow %>%
finalize_workflow(best_tree)###Visualize Results
The next section shows how to fit the model for automatically obtaining test set performance.
###Fit the Model Next we fit our workflow to the training data.
tree_wf_fit <- final_tree_workflow %>%
fit(data = df_training)###Exploring our Trained Model Once we have trained our model on our training data, we study variable importance with the vip() function.
tree_fit <- tree_wf_fit %>%
pull_workflow_fit()###Variable Importance Next we pass tree_fit to the vip() function. We see from the results from the bar chart below, that DiffLanguage, Age_Gap, DiffAddress, and NumDivorce are the most important predictors of Marriage Fraud.
vip(tree_fit)
###Decision Tree Plot
This visualization is a tool to communicate the prediction rules of the trained decision tree
rpart.plot(tree_fit$fit, roundint = FALSE)
###Train and Evaluate With last_fit() Next we fit our final model workflow to the training data and evaluate performance on the test data.
tree_last_fit <- final_tree_workflow %>%
last_fit(df_split)We can view our performance metrics on the test data below:
tree_last_fit %>% collect_metrics()# A tibble: 2 x 4
.metric .estimator .estimate .config
<chr> <chr> <dbl> <fct>
1 accuracy binary 0.968 Preprocessor1_Model1
2 roc_auc binary 0.932 Preprocessor1_Model1###Confusion Matrix We see that our model made 0 false negatives and 53 false positives on our test data set.
tree_predictions <- tree_last_fit %>% collect_predictions()
conf_mat(tree_predictions, truth = FraudAlerted, estimate = .pred_class) Truth
Prediction no yes
no 1467 53
yes 0 127F1 Score
F1 score is 98.22%, higher than previous ML models.
f_meas(tree_predictions, truth = FraudAlerted, estimate = .pred_class)# A tibble: 1 x 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 f_meas binary 0.982Random Forests:
In this section, we fit a random forest model to the fraud df data. Random forests take decision trees and construct more powerful models in terms of prediction accuracy.
Data Spitting and Feature Engineering
We apply the same split to our dataset and reuse it in our random forest workflow.
Model Specification
Next, we specify a random forest classifier with the following hyperparameters: mtry: The number of predictors that will be randomly sampled at each split when creating the tree models trees: The number of decision trees to fit and ultimately average min_n: The minimum number of data points in a node that are required for the node to be split further
rf_model <- rand_forest(mtry = tune(),
trees = tune(),
min_n = tune()) %>%
set_engine('ranger', importance = "impurity") %>%
set_mode('classification')Workflow
Next, we combine our model and recipe into a workflow to easily manage the model-building process.
rf_workflow <- workflow() %>%
add_model(rf_model) %>%
add_recipe(df_recipe)Hyperparameter Tuning: Random Grid Search
We perform a grid search on the random forest hyperparameters and select the best performing model based on the area under the ROC curve during cross validation.
## Create a grid of hyperparameter values to test
set.seed(314)
rf_grid <- grid_random(mtry() %>% range_set(c(4, 8)),
trees(),
min_n(),
size = 5)
# View grid
rf_grid# A tibble: 5 x 3
mtry trees min_n
<int> <int> <int>
1 7 1270 7
2 6 1855 13
3 7 1644 27
4 6 1440 25
5 5 1549 30Tuning Hyperparameters with tune_grid()
we use the tune_grid() function to find the optimal combination of hyperparameters from our tuning grid.
## Tune random forest workflow
set.seed(314)
rf_tuning <- rf_workflow %>%
tune_grid(resamples = df_folds,
grid = rf_grid)
# View grid
rf_grid# A tibble: 5 x 3
mtry trees min_n
<int> <int> <int>
1 7 1270 7
2 6 1855 13
3 7 1644 27
4 6 1440 25
5 5 1549 30We view the results of our hyperparameter tuning.
## Show the top 5 best models based on roc_auc metric
rf_tuning %>% show_best('roc_auc')# A tibble: 5 x 9
mtry trees min_n .metric .estimator mean n std_err .config
<int> <int> <int> <chr> <chr> <dbl> <int> <dbl> <fct>
1 6 1855 13 roc_auc binary 0.952 5 0.00564 Preprocessor1_Model2
2 7 1270 7 roc_auc binary 0.951 5 0.00616 Preprocessor1_Model1
3 6 1440 25 roc_auc binary 0.950 5 0.00606 Preprocessor1_Model4
4 5 1549 30 roc_auc binary 0.950 5 0.00616 Preprocessor1_Model5
5 7 1644 27 roc_auc binary 0.949 5 0.00748 Preprocessor1_Model3We use the select_best() function to select the model from our tuning results that had the best overall performance.
## Select best model based on roc_auc
best_rf <- rf_tuning %>%
select_best(metric = 'roc_auc')
# View the best parameters
best_rf# A tibble: 1 x 4
mtry trees min_n .config
<int> <int> <int> <fct>
1 6 1855 13 Preprocessor1_Model2Finalize Workflow
The last step in hyperparameter tuning is to use finalize_workflow() to add our optimal model to our workflow object.
final_rf_workflow <- rf_workflow %>%
finalize_workflow(best_rf)Fit the Model
Next we fit our workflow to the training data.
rf_wf_fit <- final_rf_workflow %>%
fit(data = df_training)We pull the workflow to fit into our random forest model
rf_fit <- rf_wf_fit %>%
pull_workflow_fit()Variable Importance
We see from the results below, that NumDivorce, Age_Gap, DiffLanguage, and DiffAdress are the most important predictors of Immigration Fraud.
vip(rf_fit)
Train and Evaluate With last_fit()
Next we fit our final model workflow to the training data and evaluate performance on the test data. We can view our performance metrics on the test data. Accuracy: 97% and roc_auc is 95.9%.
rf_last_fit <- final_rf_workflow %>%
last_fit(df_split)
rf_last_fit %>% collect_metrics()# A tibble: 2 x 4
.metric .estimator .estimate .config
<chr> <chr> <dbl> <fct>
1 accuracy binary 0.970 Preprocessor1_Model1
2 roc_auc binary 0.959 Preprocessor1_Model1Confusion Matrix
We see that our model made 3 false negatives and 46 false positives on our test data set, outperforming our decision tree model.
rf_predictions <- rf_last_fit %>% collect_predictions()
conf_mat(rf_predictions, truth = FraudAlerted, estimate = .pred_class) Truth
Prediction no yes
no 1464 46
yes 3 134F1 Score
F1 score is 98.4% , the highest score so far.
f_meas(rf_predictions, truth = FraudAlerted, estimate = .pred_class)# A tibble: 1 x 3
.metric .estimator .estimate
<chr> <chr> <dbl>
1 f_meas binary 0.984