Machine Learning | Tengku Hanis

Using UMAP preprocessing for image classification

Wed, 16 Mar 2022 00:00:00 +0000

UMAP

Uniform manifold approximation and projection or in short UMAP is a type of dimension reduction techniques. So, basically UMAP will project a set of features into a smaller space. UMAP can be a supervised technique in which we give a label or an outcome or an unsupervised one. For those interested to know in detail how UMAP works can refer to this reference. For those prefer a much simpler or shorter version of it, I recommend a YouTube video by Joshua Starmer.

Example in R

We going to see how to apply a UMAP techniques for image preprocessing and further classify the images using kNN and naive bayes.

These are the packages that we need.

library(keras) #for data and reshape to tabular format
library(tidymodels)
library(embed) #for umap
library(discrim) #for naive bayes model

We going to use the famous MNIST dataset. This dataset contained a handwritten digit from 0 to 9. This dataset is available in keras package.

mnist_data <- dataset_mnist()

## Loaded Tensorflow version 2.2.0

image_data <- mnist_data$train$x
image_labels <- mnist_data$train$y
image_data %>% dim()

## [1] 60000    28    28

For example this is the image for the second row.

image_data[2, 1:28, 1:28] %>% 
  t() %>% 
  image(col = gray.colors(256))

Next, we going to change the image into a tabular data frame format. We going to limit the data to the first 1000 rows or images out of the total 6000 images.

# Reformat to tabular format
image_data <- array_reshape(image_data, dim = c(60000, 28*28))
image_data %>% dim()

## [1] 60000   784

image_data <- image_data[1:10000,]
image_labels <- image_labels[1:10000]

# Reformat to data frame
full_data <- 
  data.frame(image_data) %>% 
  bind_cols(label = image_labels) %>% 
  mutate(label = as.factor(label))

Then, we going to split the data and create a 3-folds cross-validation sets for the sake of simplicity.

# Split data
set.seed(123)
ind <- initial_split(full_data)
data_train <- training(ind)  
data_test <- testing(ind)

# 10-folds CV
set.seed(123)
data_cv <- vfold_cv(data_train, v = 3)

For recipe specification, we going to scale and center all the predictor after creating a new variable using step_umap(). Notice that in step_umap() we supply the outcome and we tune the number of components (num_comp).

rec <- 
  recipe(label ~ ., data = data_train) %>% 
  step_umap(all_predictors(), outcome = vars(label), num_comp = tune()) %>% 
  step_center(all_predictors()) %>% 
  step_scale(all_predictors())

We create a a base workflow.

wf <- 
  workflow() %>% 
  add_recipe(rec)

We going to use two models as classifier:

kNN
Naive bayes

For each classifier, we going to create a regular grid of parameters to be tuned and further run a regular grid search.

For kNN.

# knn model
knn_mod <- 
  nearest_neighbor(neighbors = tune()) %>% 
  set_mode("classification") %>% 
  set_engine("kknn")

# knn grid
knn_grid <- grid_regular(neighbors(), num_comp(range = c(2, 8)), levels = 3)

# Tune grid search
knn_tune <- 
  tune_grid(
  wf %>% add_model(knn_mod),
  resamples = data_cv,
  grid = knn_grid, 
  control = control_grid(verbose = F)
)

For naive bayes.

# nb model
nb_mod <- 
  naive_Bayes(smoothness = tune()) %>% 
  set_mode("classification") %>% 
  set_engine("naivebayes")

# nb grid
nb_grid <- grid_regular(smoothness(), num_comp(range = c(2, 10)), levels = 3)

# Tune grid search
nb_tune <- 
  tune_grid(
    wf %>% add_model(nb_mod),
    resamples = data_cv,
    grid = nb_grid, 
    control = control_grid(verbose = F)
  )

Let’s see our tuning performance of our model.

# knn model
knn_tune %>% 
  show_best("roc_auc")

## # A tibble: 5 x 8
##   neighbors num_comp .metric .estimator  mean     n  std_err .config            
##       <int>    <int> <chr>   <chr>      <dbl> <int>    <dbl> <chr>              
## 1        10        8 roc_auc hand_till  0.961     3 0.000268 Preprocessor3_Mode~
## 2        10        5 roc_auc hand_till  0.961     3 0.000421 Preprocessor2_Mode~
## 3         5        8 roc_auc hand_till  0.959     3 0.000757 Preprocessor3_Mode~
## 4        10        2 roc_auc hand_till  0.959     3 0.000737 Preprocessor1_Mode~
## 5         5        5 roc_auc hand_till  0.958     3 0.000740 Preprocessor2_Mode~

knn_tune %>% 
  show_best("accuracy")

## # A tibble: 5 x 8
##   neighbors num_comp .metric  .estimator  mean     n std_err .config            
##       <int>    <int> <chr>    <chr>      <dbl> <int>   <dbl> <chr>              
## 1        10        8 accuracy multiclass 0.914     3 0.00104 Preprocessor3_Mode~
## 2         5        8 accuracy multiclass 0.913     3 0.00315 Preprocessor3_Mode~
## 3        10        5 accuracy multiclass 0.912     3 0.00114 Preprocessor2_Mode~
## 4         5        5 accuracy multiclass 0.91      3 0.00139 Preprocessor2_Mode~
## 5        10        2 accuracy multiclass 0.910     3 0.00175 Preprocessor1_Mode~

# nb model
nb_tune %>% 
  show_best("roc_auc")

## # A tibble: 5 x 8
##   smoothness num_comp .metric .estimator  mean     n  std_err .config           
##        <dbl>    <int> <chr>   <chr>      <dbl> <int>    <dbl> <chr>             
## 1        1.5       10 roc_auc hand_till  0.971     3 0.000400 Preprocessor3_Mod~
## 2        1.5        6 roc_auc hand_till  0.971     3 0.000997 Preprocessor2_Mod~
## 3        1         10 roc_auc hand_till  0.971     3 0.000634 Preprocessor3_Mod~
## 4        1          6 roc_auc hand_till  0.970     3 0.00124  Preprocessor2_Mod~
## 5        0.5       10 roc_auc hand_till  0.969     3 0.000808 Preprocessor3_Mod~

nb_tune %>% 
  show_best("accuracy")

## # A tibble: 5 x 8
##   smoothness num_comp .metric  .estimator  mean     n  std_err .config          
##        <dbl>    <int> <chr>    <chr>      <dbl> <int>    <dbl> <chr>            
## 1        1         10 accuracy multiclass 0.913     3 0.000481 Preprocessor3_Mo~
## 2        1.5       10 accuracy multiclass 0.913     3 0.000267 Preprocessor3_Mo~
## 3        0.5       10 accuracy multiclass 0.912     3 0.000462 Preprocessor3_Mo~
## 4        1.5        6 accuracy multiclass 0.911     3 0.00135  Preprocessor2_Mo~
## 5        1          6 accuracy multiclass 0.910     3 0.00157  Preprocessor2_Mo~

Next, we going to select the best model from the tuned parameters and finalise our model using last_fit().

For knn model.

# Finalize
knn_best <- knn_tune %>% select_best("roc_auc")
knn_rec <- 
  recipe(label ~ ., data = data_train) %>% 
  step_umap(all_predictors(), outcome = vars(label), num_comp = knn_best$num_comp) %>% 
  step_center(all_predictors()) %>% 
  step_scale(all_predictors())

knn_wf <- 
  workflow() %>% 
  add_recipe(knn_rec) %>% 
  add_model(knn_mod) %>% 
  finalize_workflow(knn_best) 

# Last fit
knn_lastfit <- 
  knn_wf %>% 
  last_fit(ind)

For naive bayes model.

# Finalize
nb_best <- nb_tune %>% select_best("roc_auc")
nb_rec <- 
  recipe(label ~ ., data = data_train) %>% 
  step_umap(all_predictors(), outcome = vars(label), num_comp = nb_best$num_comp) %>% 
  step_center(all_predictors()) %>% 
  step_scale(all_predictors())

nb_wf <- 
  workflow() %>% 
  add_recipe(nb_rec) %>% 
  add_model(nb_mod) %>% 
  finalize_workflow(nb_best) 

# Last fit
nb_lastfit <- 
  nb_wf %>% 
  last_fit(ind)

Let’s see the model performance on the testing data.

knn_lastfit %>% 
  collect_metrics() %>% 
  mutate(model = "knn") %>% 
  dplyr::bind_rows(nb_lastfit %>% 
                     collect_metrics() %>% 
                     mutate(model = "nb")) %>% 
  select(-.config)

## # A tibble: 4 x 4
##   .metric  .estimator .estimate model
##   <chr>    <chr>          <dbl> <chr>
## 1 accuracy multiclass     0.938 knn  
## 2 roc_auc  hand_till      0.971 knn  
## 3 accuracy multiclass     0.936 nb   
## 4 roc_auc  hand_till      0.980 nb

These are the confusion matrices.

knn_lastfit %>% 
  collect_predictions() %>%
  conf_mat(label, .pred_class) %>% 
  autoplot(type = "heatmap") +
  labs(title = "Confusion matrix - kNN")

nb_lastfit %>% 
  collect_predictions() %>%
  conf_mat(label, .pred_class) %>% 
  autoplot(type = "heatmap") +
  labs(title = "Confusion matrix - naive bayes")

Lastly, we can compare the ROC plots for each class.

knn_lastfit %>% 
  collect_predictions() %>%
  mutate(id = "knn") %>% 
  bind_rows(
    nb_lastfit %>% 
      collect_predictions() %>% 
      mutate(id = "nb")
            ) %>% 
  group_by(id) %>% 
  roc_curve(label, .pred_0:.pred_9) %>% 
  autoplot()

Conclusion

I believe UMAP is quite good and can be used as one of preprocessing step in image classification. We are able to get a pretty good performance result in this post. I believe if the the parameter tuning approach is a bit more rigorous, the performance result will be a lot better.

Explore data using PCA

Wed, 09 Feb 2022 00:00:00 +0000

Principal component analysis (PCA)

PCA is a dimension reduction techniques. So, if we have a large number of predictors, instead of using all the predictors for modelling or other analysis, we can compressed all the information from the variables and create a new set of variables. This new set of variables are known as components or principal component (PC). So, now we have a smaller number of variables which contain the information from the original variables.

PCA usually used for a dataset with a large features or predictors like genomic data. Additionally, PCA is a good pre-processing option if you have a correlated variable or have a multicollinearity issue in the model. Also, we can use PCA for exploration of the data and have a better understanding of our data.

For those who want to study the theoretical side of PCA can further read on this link. We going to focus more on the coding part in the machine learning framework (using tidymodels package) in this post.

Example in R

These are the packages that we going to use.

library(tidymodels)
library(tidyverse)
library(mlbench) #data

We going to use diabetes dataset. The outcome is binary; positive = diabetes and negative = non-diabetes/healthy. All other variables are numerical values.

data("PimaIndiansDiabetes")
glimpse(PimaIndiansDiabetes)

## Rows: 768
## Columns: 9
## $ pregnant <dbl> 6, 1, 8, 1, 0, 5, 3, 10, 2, 8, 4, 10, 10, 1, 5, 7, 0, 7, 1, 1~
## $ glucose  <dbl> 148, 85, 183, 89, 137, 116, 78, 115, 197, 125, 110, 168, 139,~
## $ pressure <dbl> 72, 66, 64, 66, 40, 74, 50, 0, 70, 96, 92, 74, 80, 60, 72, 0,~
## $ triceps  <dbl> 35, 29, 0, 23, 35, 0, 32, 0, 45, 0, 0, 0, 0, 23, 19, 0, 47, 0~
## $ insulin  <dbl> 0, 0, 0, 94, 168, 0, 88, 0, 543, 0, 0, 0, 0, 846, 175, 0, 230~
## $ mass     <dbl> 33.6, 26.6, 23.3, 28.1, 43.1, 25.6, 31.0, 35.3, 30.5, 0.0, 37~
## $ pedigree <dbl> 0.627, 0.351, 0.672, 0.167, 2.288, 0.201, 0.248, 0.134, 0.158~
## $ age      <dbl> 50, 31, 32, 21, 33, 30, 26, 29, 53, 54, 30, 34, 57, 59, 51, 3~
## $ diabetes <fct> pos, neg, pos, neg, pos, neg, pos, neg, pos, pos, neg, pos, n~

We going to split the data and extract the training dataset. We going to explore only the training set since we going to do this in a machine learning framework.

set.seed(1)

ind <- initial_split(PimaIndiansDiabetes)
dat_train <- training(ind)

We create a recipe and apply normalization and PCA techniques. Then, we prep it.

# Recipe
pca_rec <- 
  recipe(diabetes ~ ., data = dat_train) %>% 
  step_normalize(all_numeric_predictors()) %>% 
  step_pca(all_numeric_predictors())

# Prep
pca_prep <- prep(pca_rec)

So, we can extract the PCA data using tidy(). type = "coef" indicates that we want the loadings values. So, the values in the data are the loadings.

pca_tidied <- tidy(pca_prep, 2, type = "coef")
pca_tidied

## # A tibble: 64 x 4
##    terms     value component id       
##    <chr>     <dbl> <chr>     <chr>    
##  1 pregnant  0.107 PC1       pca_JtuLZ
##  2 glucose   0.357 PC1       pca_JtuLZ
##  3 pressure  0.330 PC1       pca_JtuLZ
##  4 triceps   0.460 PC1       pca_JtuLZ
##  5 insulin   0.466 PC1       pca_JtuLZ
##  6 mass      0.447 PC1       pca_JtuLZ
##  7 pedigree  0.315 PC1       pca_JtuLZ
##  8 age       0.158 PC1       pca_JtuLZ
##  9 pregnant -0.597 PC2       pca_JtuLZ
## 10 glucose  -0.192 PC2       pca_JtuLZ
## # ... with 54 more rows

So, basically the loadings indicate how much each variable contributes to each component (PC). A large loading (positive or negative) indicates a strong relationship between the variables and the related components. The sign indicates a negative or positive correlation between the variables and components.

We can further visualise these loadings.

pca_tidied %>% 
  ggplot(aes(value, terms, fill = terms)) +
  geom_col(show.legend = F) +
  facet_wrap(~ component) +
  ylab("") +
  xlab("Loadings") + 
  theme_minimal()

Besides the loadings, we can also get a variance information. Variance of each component (or PC) measures how much that particular component explains the variability in the data. For example, PC1 explain 26.2% variance in the data.

pca_tidied2 <- tidy(pca_prep, 2, type = "variance")

pca_tidied2 %>% 
  pivot_wider(names_from = component, values_from = value, names_prefix = "PC") %>% 
  select(-id) %>% 
  mutate_if(is.numeric, round, digits = 1) %>% 
  kableExtra::kable("simple")

terms	PC1	PC2	PC3	PC4	PC5	PC6	PC7	PC8
variance	2.1	1.7	1.0	0.8	0.8	0.7	0.5	0.4
cumulative variance	2.1	3.8	4.9	5.7	6.5	7.2	7.6	8.0
percent variance	26.2	21.5	12.9	10.6	9.9	8.5	5.7	4.7
cumulative percent variance	26.2	47.7	60.7	71.2	81.1	89.6	95.3	100.0

Next, we can visualise PC1 and PC2 in a scatter plot and see how each variable influences both PCs. First, we need to extract the loadings and convert into a wide format for our arrow coordinate in the scatter plot.

pca_tidied3 <- 
  pca_tidied %>% 
  filter(component %in% c("PC1", "PC2")) %>% 
  select(-id) %>% 
  pivot_wider(names_from = component, values_from = value)
pca_tidied3

## # A tibble: 8 x 3
##   terms      PC1    PC2
##   <chr>    <dbl>  <dbl>
## 1 pregnant 0.107 -0.597
## 2 glucose  0.357 -0.192
## 3 pressure 0.330 -0.234
## 4 triceps  0.460  0.279
## 5 insulin  0.466  0.200
## 6 mass     0.447  0.121
## 7 pedigree 0.315  0.110
## 8 age      0.158 -0.638

Now, we can make a scatter plot using training set data (juice(pca_prep)) and the loadings data (pca_tidied3). Also, we going to add percentage of variance for PC1 and PC2 in the axis labels.

juice(pca_prep) %>% 
  ggplot(aes(PC1, PC2)) +
  geom_point(aes(color = diabetes, shape = diabetes), size = 2, alpha = 0.6) +
  geom_segment(data = pca_tidied3, 
               aes(x = 0, y = 0, xend = PC1 * 5, yend = PC2 * 5), 
               arrow = arrow(length = unit(1/2, "picas")),
               color = "blue") +
  annotate("text", 
           x = pca_tidied3$PC1 * 5.2, 
           y = pca_tidied3$PC2 * 5.2, 
           label = pca_tidied3$terms) +
  theme_minimal() +
  xlab("PC1 (26.2%)") +
  ylab("PC2 (21.5%)")

So, from this scatter plot we learn that:

(triceps, insulin, pedigree and mass), (glucose and pressure) and (pregnant and age) are correlated as their lines are close to each other
As PC1 and PC2 increase, triceps, insulin, pedigree and mass also increase
As PC2 decreases, pregnant and age increase

References:

Variable selection using genetic algorithm

Sun, 02 Jan 2022 00:00:00 +0000

Background

Genetic algorithm is inspired by a natural selection process by which the fittest individuals be selected to reproduce. This algorithm has been used in optimization and search problem, and also, can be used for variable selection.

Genetic algorithm - gene, chromosome, population, crossover (upper right), offspring (lower right)

First, let’s go into a few terms related to genetic algorithm theory.

Population - a set of chromosomes
Chromosome - a subset of variables (also known as individual by some reference)
Gene - a variable or feature
Fitness function - give fitness score to each chromosome and guide the selection
Selection - a process to select the two chromosome known as parents
Crossover - a process to generate offspring by parents (illustrate in the picture above, on the upper right side)
Mutation - the process by which the gene in the chromosome is randomly flipped into 1 or 0

Mutation

So, the basic flow of genetic algorithm:

Algorithm starts with an initial population, often randomly generated
Create a successive generation by selecting a portion of the initial population (the selection is guided by the fitness function) - this includes selection -> crossover -> mutation
The algorithm terminates if certain predetermined criteria are met such as:
- Solution satisfies the minimum criteria
- Fixed number of generation reached
- Successive iteration no longer produce a better result

Example in R

There is GA package in R, where we can implement the genetic algorithm a bit more manually where we can specify our own fitness function. However, I think it is easier to use a genetic algorithm implemented in caret package for variable selection.

Load the packages.

library(caret)
library(tidyverse)
library(rsample)
library(recipes)

The data.

dat <- 
  mtcars %>% 
  mutate(across(c(vs, am), as.factor),
         am = fct_recode(am, auto = "0", man = "1"))
str(dat)

## 'data.frame':    32 obs. of  11 variables:
##  $ mpg : num  21 21 22.8 21.4 18.7 18.1 14.3 24.4 22.8 19.2 ...
##  $ cyl : num  6 6 4 6 8 6 8 4 4 6 ...
##  $ disp: num  160 160 108 258 360 ...
##  $ hp  : num  110 110 93 110 175 105 245 62 95 123 ...
##  $ drat: num  3.9 3.9 3.85 3.08 3.15 2.76 3.21 3.69 3.92 3.92 ...
##  $ wt  : num  2.62 2.88 2.32 3.21 3.44 ...
##  $ qsec: num  16.5 17 18.6 19.4 17 ...
##  $ vs  : Factor w/ 2 levels "0","1": 1 1 2 2 1 2 1 2 2 2 ...
##  $ am  : Factor w/ 2 levels "auto","man": 2 2 2 1 1 1 1 1 1 1 ...
##  $ gear: num  4 4 4 3 3 3 3 4 4 4 ...
##  $ carb: num  4 4 1 1 2 1 4 2 2 4 ...

For this, we going to use random forest (rfGA). Other options are bagged tree (treebagGA) and caretGA. We are able to use other method in caret if we use caretGA.

# specify control
ga_ctrl <- gafsControl(functions = rfGA, method = "cv", number = 5)

# run random forest
set.seed(123)
rf_ga <- gafs(x = dat %>% select(-am), 
              y = dat$am,
              iters = 5,
              gafsControl = ga_ctrl)
rf_ga

## 
## Genetic Algorithm Feature Selection
## 
## 32 samples
## 10 predictors
## 2 classes: 'auto', 'man' 
## 
## Maximum generations: 5 
## Population per generation: 50 
## Crossover probability: 0.8 
## Mutation probability: 0.1 
## Elitism: 0 
## 
## Internal performance values: Accuracy, Kappa
## Subset selection driven to maximize internal Accuracy 
## 
## External performance values: Accuracy, Kappa
## Best iteration chose by maximizing external Accuracy 
## External resampling method: Cross-Validated (5 fold) 
## 
## During resampling:
##   * the top 5 selected variables (out of a possible 10):
##     qsec (60%), wt (60%), disp (40%), gear (40%), vs (40%)
##   * on average, 3.2 variables were selected (min = 1, max = 7)
## 
## In the final search using the entire training set:
##    * 7 features selected at iteration 3 including:
##      cyl, hp, drat, qsec, vs ... 
##    * external performance at this iteration is
## 
##    Accuracy       Kappa 
##      0.9429      0.8831

The optimal features/variables:

rf_ga$optVariables

## [1] "cyl"  "hp"   "drat" "qsec" "vs"   "gear" "carb"

This is the time taken for random forest approach.

rf_ga$times

## $everything
##    user  system elapsed 
##   51.22    1.25   52.92

By default the algorithm will find a solution or a set of variable that reduce RMSE for numerical outcome, and accuracy for categorical outcome. Also, genetic algorithm tend to overfit, that’s why for the implementation in caret we have internal and external performance. So, for the 10-fold cross-validation, 10 genetic algorithm will be run separately. All the first nine folds are used for the genetic algorithm, and the 10th for external performance evaluation.

Let’s try a variable selection using linear regression model.

# specify control
lm_ga_ctrl <- gafsControl(functions = caretGA, method = "cv", number = 5)

# run lm
set.seed(123)
lm_ga <- gafs(x = dat %>% select(-mpg), 
              y = dat$mpg,
              iters = 5,
              gafsControl = lm_ga_ctrl,
              # below is the option for `train`
              method = "lm",
              trControl = trainControl(method = "cv", allowParallel = F))
lm_ga

## 
## Genetic Algorithm Feature Selection
## 
## 32 samples
## 10 predictors
## 
## Maximum generations: 5 
## Population per generation: 50 
## Crossover probability: 0.8 
## Mutation probability: 0.1 
## Elitism: 0 
## 
## Internal performance values: RMSE, Rsquared, MAE
## Subset selection driven to minimize internal RMSE 
## 
## External performance values: RMSE, Rsquared, MAE
## Best iteration chose by minimizing external RMSE 
## External resampling method: Cross-Validated (5 fold) 
## 
## During resampling:
##   * the top 5 selected variables (out of a possible 10):
##     wt (100%), hp (80%), carb (60%), cyl (60%), am (40%)
##   * on average, 4.4 variables were selected (min = 4, max = 5)
## 
## In the final search using the entire training set:
##    * 5 features selected at iteration 5 including:
##      cyl, disp, hp, wt, qsec  
##    * external performance at this iteration is
## 
##        RMSE    Rsquared         MAE 
##      3.3434      0.7624      2.6037

Now, let’s see how to integrate this in machine learning flow using recipes from rsample.

First, we split the data.

set.seed(123)
dat_split <-initial_split(dat)
dat_train <- training(dat_split)
dat_test <- testing(dat_split)

We specify two recipes for numerical and categorical outcome.

# Numerical
rec_num <- 
  recipe(mpg ~., data = dat_train) %>% 
  step_center(all_numeric()) %>% 
  step_dummy(all_nominal_predictors())

# Categorical
rec_cat <- 
  recipe(am ~., data = dat_train) %>% 
  step_center(all_numeric()) %>% 
  step_dummy(all_nominal_predictors())

We run random forest for numerical outcome recipes.

# specify control
rf_ga_ctrl <- gafsControl(functions = rfGA, method = "cv", number = 5)

# run random forest
set.seed(123)
rf_ga2 <- 
  gafs(rec_num,
       data = dat_train,
       iters = 5, 
       gafsControl = rf_ga_ctrl) 
rf_ga2

## 
## Genetic Algorithm Feature Selection
## 
## 24 samples
## 10 predictors
## 
## Maximum generations: 5 
## Population per generation: 50 
## Crossover probability: 0.8 
## Mutation probability: 0.1 
## Elitism: 0 
## 
## Internal performance values: RMSE, Rsquared
## Subset selection driven to minimize internal RMSE 
## 
## External performance values: RMSE, Rsquared, MAE
## Best iteration chose by minimizing external RMSE 
## External resampling method: Cross-Validated (5 fold) 
## 
## During resampling:
##   * the top 5 selected variables (out of a possible 10):
##     cyl (80%), disp (80%), hp (80%), wt (80%), carb (60%)
##   * on average, 4.8 variables were selected (min = 2, max = 9)
## 
## In the final search using the entire training set:
##    * 6 features selected at iteration 5 including:
##      cyl, disp, hp, wt, gear ... 
##    * external performance at this iteration is
## 
##       RMSE   Rsquared        MAE 
##      2.830      0.928      2.408

The optimal variables.

rf_ga2$optVariables

## [1] "cyl"   "disp"  "hp"    "wt"    "gear"  "vs_X1"

Let’s try run SVM for the numerical outcome recipes.

# specify control
svm_ga_ctrl <- gafsControl(functions = caretGA, method = "cv", number = 5)

# run SVM
set.seed(123)
svm_ga <- 
  gafs(rec_cat,
       data = dat_train,
       iters = 5, 
       gafsControl = svm_ga_ctrl,
       # below is the options to `train` for caretGA
       method = "svmRadial", #SVM with Radial Basis Function Kernel
       trControl = trainControl(method = "cv", allowParallel = T))
svm_ga

## 
## Genetic Algorithm Feature Selection
## 
## 24 samples
## 10 predictors
## 2 classes: 'auto', 'man' 
## 
## Maximum generations: 5 
## Population per generation: 50 
## Crossover probability: 0.8 
## Mutation probability: 0.1 
## Elitism: 0 
## 
## Internal performance values: Accuracy, Kappa
## Subset selection driven to maximize internal Accuracy 
## 
## External performance values: Accuracy, Kappa
## Best iteration chose by maximizing external Accuracy 
## External resampling method: Cross-Validated (5 fold) 
## 
## During resampling:
##   * the top 5 selected variables (out of a possible 10):
##     wt (80%), qsec (60%), vs_X1 (60%), carb (40%), disp (40%)
##   * on average, 4 variables were selected (min = 3, max = 6)
## 
## In the final search using the entire training set:
##    * 9 features selected at iteration 2 including:
##      mpg, cyl, disp, hp, drat ... 
##    * external performance at this iteration is
## 
##    Accuracy       Kappa 
##      0.9200      0.8571

The optimal variables.

svm_ga$optVariables

## [1] "mpg"   "cyl"   "disp"  "hp"    "drat"  "wt"    "qsec"  "carb"  "vs_X1"

Conclusion

Although genetic algorithm seems quite good for variable selection, the main limitation I would say is the computational time. However, if we have a lot of variables or features to reduced, using the genetic algorithm despite the long computational time seems beneficial to me.

Reference:

Handling imbalanced data

Fri, 14 May 2021 00:00:00 +0000

Overview

Imbalance data happens when there is unequal distribution of data within a categorical outcome variable. Imbalance data occurs due to several reasons such as biased sampling method and measurement errors. However, the imbalance may also be the inherent characteristic of the data. For example, a rare disease predictive model, in this case, the imbalance is expected.

Generally, there are two types of imbalanced problem:

Slight imbalance: the imbalance is small, like 4:6
Severe imbalance: the imbalance is large, like 1:100 or more

In slight imbalanced cases, usually it is not a concern, while severe imbalanced cases require a more specialised method to to build a predictive model.

The problem

What’s the problem with the imbalanced data?
Firstly, a predictive model of an imbalanced data is bias towards the majority class. The minority class becomes harder to predict as there are few data from this class. So, the detection rate for a minority class will be very low. Secondly, accuracy is not a good measure in this case. We may get a good accuracy,but in reality the accuracy does not reflect the unequal distribution of the data. This is known as an accuracy paradox. Imagine we have 90% of data belong to the majority class, while the remaining 10% belong to the minority class. So, just by predicting all data as a majority class, the model can easily get 90% accuracy.

Handling approach

The easiest approach is to collect more data, though this may not be practical in all situation. Fortunately, there are a few machine learning techniques available to tackle this problem.

Here is a summary of resampling techniques available in themis package.

Over-sampling approach is preferred when the dataset is small. The under-sampling approach can be used when the dataset is large, though this approach may lead to loss of information. Additionally, ensemble technique such as random forest is said to be able to model the imbalanced data, though some references/blogs say otherwise.

So, we are going to compare four of over-sampling techniques (upsample, SMOTE, ADASYN, and ROSE), and three of under-sampling techniques (downsample, nearmiss and tomek). The base model is a decision tree, which will be used for all the techniques. The decision trees are not going to be extensively hyperparameter tuned, for the sake of simplicity. Additionally, random forest is also going to be included in the comparison.

The dataset is from here. This is a summary of the dataset.

summary(df)

##  admit        gre             gpa        rank   
##  0:273   Min.   :220.0   Min.   :2.260   1: 61  
##  1:127   1st Qu.:520.0   1st Qu.:3.130   2:151  
##          Median :580.0   Median :3.395   3:121  
##          Mean   :587.7   Mean   :3.390   4: 67  
##          3rd Qu.:660.0   3rd Qu.:3.670          
##          Max.   :800.0   Max.   :4.000

As we can see from the summary, variable admit has a moderate imbalanced data about 1:3 ratio.

ggplot(df, aes(admit)) + 
  geom_bar() +
  theme_bw()

Below is the code for each model.

Show code

# Packages
library(tidyverse)
library(magrittr)
library(tidymodels)
library(themis)

# Data
df <- read.csv("https://raw.githubusercontent.com/finnstats/finnstats/main/binary.csv")

# Split data
set.seed(1234)
df_split <- initial_split(df)
df_train <- training(df_split)
df_test <- testing(df_split)

# 1) Decision tree ----

# Recipe
dt_rec <- 
  recipe(admit ~., data = df_train) %>% 
  step_mutate_at(c("admit", "rank"), fn = as_factor) %>% 
  step_dummy(rank)

df_train_rec <- 
  dt_rec %>% 
  prep() %>% 
  bake(new_data = NULL)
  
df_test_rec <- 
  dt_rec %>% 
  prep() %>% 
  bake(new_data = df_test)

## 10-folds CV
set.seed(1234)
df_cv <- vfold_cv(df_train_rec)

# Tune and finalize workflow
## Specify model
dt_mod <- 
  decision_tree(
    cost_complexity = tune(),
    tree_depth = tune(),
    min_n = tune()
  ) %>% 
  set_engine("rpart") %>% 
  set_mode("classification")

## Specify workflow
dt_wf <- 
  workflow() %>% 
  add_model(dt_mod) %>% 
  add_formula(admit ~.)

## Tune model
set.seed(1234)
dt_tune <- 
  dt_wf %>% 
  tune_grid(resamples = df_cv,
            metrics = metric_set(accuracy))

## Select best model
best_tune <- dt_tune %>% select_best("accuracy")

## Finalize workflow
dt_wf_final <- 
  dt_wf %>% 
  finalize_workflow(best_tune)

# Fit on train data
dt_train <- 
  dt_wf_final %>% 
  fit(data = df_train_rec)

# Fit on test data and get accuracy
df_test  %<>%  
  bind_cols(predict(dt_train, new_data = df_test_rec)) %>% 
  rename(pred = .pred_class)

# 2) Oversampling ----
## step_upsample() ----

# Recipe
up_rec <- 
  recipe(admit ~., data = df_train) %>% 
  step_mutate_at(c("admit", "rank"), fn = as_factor) %>% 
  step_dummy(rank) %>% 
  step_upsample(admit,
                seed = 1234)

df_train_up <- 
  up_rec %>% 
  prep() %>% 
  bake(new_data = NULL)

df_test_rec_up <- 
  up_rec %>% 
  prep() %>% 
  bake(new_data = df_test)

## 10-folds CV
set.seed(1234)
df_cv_up <- vfold_cv(df_train_up)

# Tune and finalize workflow
## Specify model
# same as before

## Specify workflow
dt_wf_up <- 
  workflow() %>% 
  add_model(dt_mod) %>% 
  add_formula(admit ~.)

## Tune model
set.seed(1234)
dt_tune_up <- 
  dt_wf_up %>% 
  tune_grid(resamples = df_cv_up,
            metrics = metric_set(accuracy))

## Select best model
best_tune_up <- dt_tune_up %>% select_best("accuracy")

## Finalize workflow
dt_wf_final_up <- 
  dt_wf_up %>% 
  finalize_workflow(best_tune_up)

# Fit on train data
dt_train_up <- 
  dt_wf_final_up %>% 
  fit(data = df_train_up)

# Fit on test data and get accuracy
df_test  %<>%  
  bind_cols(predict(dt_train_up, new_data = df_test_rec_up)) %>% 
  rename(pred_up = .pred_class)

## step_smote() ----

# Recipe
smote_rec <- 
  recipe(admit ~., data = df_train) %>% 
  step_mutate_at(c("admit", "rank"), fn = as_factor) %>% 
  step_dummy(rank) %>% 
  step_smote(admit, 
             seed = 1234)

df_train_smote <- 
  smote_rec %>% 
  prep() %>% 
  bake(new_data = NULL)

df_test_rec_smote <- 
  smote_rec %>% 
  prep() %>% 
  bake(new_data = df_test)

## 10-folds CV
set.seed(1234)
df_cv_smote <- vfold_cv(df_train_smote)

# Tune and finalize workflow
## Specify model
# same as before

## Specify workflow
dt_wf_smote <- 
  workflow() %>% 
  add_model(dt_mod) %>% 
  add_formula(admit ~.)

## Tune model
set.seed(1234)
dt_tune_smote <- 
  dt_wf_smote %>% 
  tune_grid(resamples = df_cv_smote,
            metrics = metric_set(accuracy))

## Select best model
best_tune_smote <- dt_tune_smote %>% select_best("accuracy")

## Finalize workflow
dt_wf_final_smote <- 
  dt_wf_smote %>% 
  finalize_workflow(best_tune_smote)

# Fit on train data
dt_train_smote <- 
  dt_wf_final_smote %>% 
  fit(data = df_train_smote)

# Fit on test data and get accuracy
df_test  %<>%  
  bind_cols(predict(dt_train_smote, new_data = df_test_rec_smote)) %>% 
  rename(pred_smote = .pred_class)

## step_rose() ----

# Recipe
rose_rec <- 
  recipe(admit ~., data = df_train) %>% 
  step_mutate_at(c("admit", "rank"), fn = as_factor) %>% 
  step_dummy(rank) %>% 
  step_rose(admit, 
             seed = 1234)

df_train_rose <- 
  rose_rec %>% 
  prep() %>% 
  bake(new_data = NULL)

df_test_rec_rose <- 
  rose_rec %>% 
  prep() %>% 
  bake(new_data = df_test)

## 10-folds CV
set.seed(1234)
df_cv_rose <- vfold_cv(df_train_rose)

# Tune and finalize workflow
## Specify model
# same as before

## Specify workflow
dt_wf_rose <- 
  workflow() %>% 
  add_model(dt_mod) %>% 
  add_formula(admit ~.)

## Tune model
set.seed(1234)
dt_tune_rose <- 
  dt_wf_rose %>% 
  tune_grid(resamples = df_cv_rose,
            metrics = metric_set(accuracy))

## Select best model
best_tune_rose <- dt_tune_rose %>% select_best("accuracy")

## Finalize workflow
dt_wf_final_rose <- 
  dt_wf_rose %>% 
  finalize_workflow(best_tune_rose)

# Fit on train data
dt_train_rose <- 
  dt_wf_final_rose %>% 
  fit(data = df_train_rose)

# Fit on test data and get accuracy
df_test  %<>%  
  bind_cols(predict(dt_train_rose, new_data = df_test_rec_rose)) %>% 
  rename(pred_rose = .pred_class)

## step_adasyn() ----

# Recipe
adasyn_rec <- 
  recipe(admit ~., data = df_train) %>% 
  step_mutate_at(c("admit", "rank"), fn = as_factor) %>% 
  step_dummy(rank) %>% 
  step_adasyn(admit, 
            seed = 1234)

df_train_adasyn <- 
  adasyn_rec %>% 
  prep() %>% 
  bake(new_data = NULL)

df_test_rec_adasyn <- 
  adasyn_rec %>% 
  prep() %>% 
  bake(new_data = df_test)

## 10-folds CV
set.seed(1234)
df_cv_adasyn <- vfold_cv(df_train_adasyn)

# Tune and finalize workflow
## Specify model
# same as before

## Specify workflow
dt_wf_adasyn <- 
  workflow() %>% 
  add_model(dt_mod) %>% 
  add_formula(admit ~.)

## Tune model
set.seed(1234)
dt_tune_adasyn <- 
  dt_wf_adasyn %>% 
  tune_grid(resamples = df_cv_adasyn,
            metrics = metric_set(accuracy))

## Select best model
best_tune_adasyn <- dt_tune_adasyn %>% select_best("accuracy")

## Finalize workflow
dt_wf_final_adasyn <- 
  dt_wf_adasyn %>% 
  finalize_workflow(best_tune_adasyn)

# Fit on train data
dt_train_adasyn <- 
  dt_wf_final_adasyn %>% 
  fit(data = df_train_adasyn)

# Fit on test data and get accuracy
df_test  %<>%  
  bind_cols(predict(dt_train_adasyn, new_data = df_test_rec_adasyn)) %>% 
  rename(pred_adasyn = .pred_class)

# 3) Undersampling ----
## step_downsample() ----

# Recipe
down_rec <- 
  recipe(admit ~., data = df_train) %>% 
  step_mutate_at(c("admit", "rank"), fn = as_factor) %>% 
  step_dummy(rank) %>% 
  step_downsample(admit,
                seed = 1234)

df_train_down <- 
  down_rec %>% 
  prep() %>% 
  bake(new_data = NULL)

df_test_rec_down <- 
  down_rec %>% 
  prep() %>% 
  bake(new_data = df_test)

## 10-folds CV
set.seed(1234)
df_cv_down <- vfold_cv(df_train_down)

# Tune and finalize workflow
## Specify model
# same as before

## Specify workflow
dt_wf_down <- 
  workflow() %>% 
  add_model(dt_mod) %>% 
  add_formula(admit ~.)

## Tune model
set.seed(1234)
dt_tune_down <- 
  dt_wf_down %>% 
  tune_grid(resamples = df_cv_down,
            metrics = metric_set(accuracy))

## Select best model
best_tune_down <- dt_tune_down %>% select_best("accuracy")

## Finalize workflow
dt_wf_final_down <- 
  dt_wf_down %>% 
  finalize_workflow(best_tune_down)

# Fit on train data
dt_train_down <- 
  dt_wf_final_down %>% 
  fit(data = df_train_down)

# Fit on test data and get accuracy
df_test  %<>%  
  bind_cols(predict(dt_train_down, new_data = df_test_rec_down)) %>% 
  rename(pred_down = .pred_class)

## step_nearmiss() ----

# Recipe
nearmiss_rec <- 
  recipe(admit ~., data = df_train) %>% 
  step_mutate_at(c("admit", "rank"), fn = as_factor) %>% 
  step_dummy(rank) %>% 
  step_nearmiss(admit,
                  seed = 1234)

df_train_nearmiss <- 
  nearmiss_rec %>% 
  prep() %>% 
  bake(new_data = NULL)

df_test_rec_nearmiss <- 
  nearmiss_rec %>% 
  prep() %>% 
  bake(new_data = df_test)

## 10-folds CV
set.seed(1234)
df_cv_nearmiss <- vfold_cv(df_train_nearmiss)

# Tune and finalize workflow
## Specify model
# same as before

## Specify workflow
dt_wf_nearmiss <- 
  workflow() %>% 
  add_model(dt_mod) %>% 
  add_formula(admit ~.)

## Tune model
set.seed(1234)
dt_tune_nearmiss <- 
  dt_wf_nearmiss %>% 
  tune_grid(resamples = df_cv_nearmiss,
            metrics = metric_set(accuracy))

## Select best model
best_tune_nearmiss <- dt_tune_nearmiss %>% select_best("accuracy")

## Finalize workflow
dt_wf_final_nearmiss <- 
  dt_wf_nearmiss %>% 
  finalize_workflow(best_tune_nearmiss)

# Fit on train data
dt_train_nearmiss <- 
  dt_wf_final_nearmiss %>% 
  fit(data = df_train_nearmiss)

# Fit on test data and get accuracy
df_test  %<>%  
  bind_cols(predict(dt_train_nearmiss, new_data = df_test_rec_nearmiss)) %>% 
  rename(pred_nearmiss = .pred_class)

## step_tomek() ----

# Recipe
tomek_rec <- 
  recipe(admit ~., data = df_train) %>% 
  step_mutate_at(c("admit", "rank"), fn = as_factor) %>% 
  step_dummy(rank) %>% 
  step_tomek(admit,
                  seed = 1234)

df_train_tomek <- 
  tomek_rec %>% 
  prep() %>% 
  bake(new_data = NULL)

df_test_rec_tomek <- 
  tomek_rec %>% 
  prep() %>% 
  bake(new_data = df_test)

## 10-folds CV
set.seed(1234)
df_cv_tomek <- vfold_cv(df_train_tomek)

# Tune and finalize workflow
## Specify model
# same as before

## Specify workflow
dt_wf_tomek <- 
  workflow() %>% 
  add_model(dt_mod) %>% 
  add_formula(admit ~.)

## Tune model
set.seed(1234)
dt_tune_tomek <- 
  dt_wf_tomek %>% 
  tune_grid(resamples = df_cv_tomek,
            metrics = metric_set(accuracy))

## Select best model
best_tune_tomek <- dt_tune_tomek %>% select_best("accuracy")

## Finalize workflow
dt_wf_final_tomek <- 
  dt_wf_tomek %>% 
  finalize_workflow(best_tune_tomek)

# Fit on train data
dt_train_tomek <- 
  dt_wf_final_tomek %>% 
  fit(data = df_train_tomek)

# Fit on test data and get accuracy
df_test  %<>%  
  bind_cols(predict(dt_train_tomek, new_data = df_test_rec_tomek)) %>% 
  rename(pred_tomek = .pred_class)

# 4) Ensemble approach: random forest ----

## 10-folds CV
set.seed(1234)
df_cv <- vfold_cv(df_train_rec)

# Tune and finalize workflow
## Specify model
rf_mod <- rand_forest(
 mtry = tune(),
 trees = tune(),
 min_n = tune()
 ) %>% 
  set_engine("ranger") %>% 
  set_mode("classification")

## Specify workflow
rf_wf <- 
  workflow() %>% 
  add_model(rf_mod) %>% 
  add_formula(admit ~.)

## Tune model
set.seed(1234)
rf_tune <- 
  rf_wf %>% 
  tune_grid(resamples = df_cv,
            metrics = metric_set(accuracy))

## Select best model
best_tune <- rf_tune %>% select_best("accuracy")

## Finalize workflow
rf_wf_final <- 
  rf_wf %>% 
  finalize_workflow(best_tune)

# Fit on train data
rf_train <- 
  rf_wf_final %>% 
  fit(data = df_train_rec)

# Fit on test data and get accuracy
df_test  %<>%  
  bind_cols(predict(rf_train, new_data = df_test_rec)) %>% 
  rename(pred_rf = .pred_class)

Now, let’s get the accuracy, sensitivity, specificity, and Mathews Correlation Coefficient (MCC) for each model.

Show code

# Get all measurements
df_test$admit %<>% as_factor()
pred_col <- colnames(df_test)[5:13]
result <- vector("list", 0)
sensi <- vector("list", 0)
specif <- vector("list", 0)
mathew <- vector("list", 0)

for (i in seq_along(pred_col)) {
  # accuracy
  result[[i]] <-
    df_test %>% 
    accuracy(admit, df_test[,pred_col[i]])
  
  # sensitivity
  sensi[[i]] <-
    df_test %>% 
    sensitivity(admit, df_test[,pred_col[i]])
  
  # specificity
  specif[[i]] <-
    df_test %>% 
    specificity(admit, df_test[,pred_col[i]])
  
  # MCC
  mathew[[i]] <-
    df_test %>% 
    mcc(admit, df_test[,pred_col[i]])
}

## Turn into dataframe
result  %<>%  
  enframe() %>% 
  unnest(cols = c("value")) %>% 
  rename(model = name, 
         accuracy = .estimate) %>% 
  select(model, accuracy) %>% 
  mutate(model = factor(model,labels = 
                          c(
                            "1" = "base",
                            "2" = "upsample",
                            "3" = "smote",
                            "4" = "rose",
                            "5" = "adasyn",
                            "6" = "downsample",
                            "7" = "nearmiss",
                            "8" = "tomek",
                            "9" = "random_forest"
                            )
                        ))

sensi  %<>%  
  enframe() %>% 
  unnest(cols = c("value"))

specif %<>% 
  enframe() %>% 
  unnest(cols = c("value"))

mathew %<>% 
  enframe() %>% 
  unnest(cols = c("value"))

result %<>% 
  bind_cols(sensitive = sensi$.estimate, specific = specif$.estimate, mathew = mathew$.estimate)

# Plot the result
result %>% 
  pivot_longer(cols = 2:5, names_to = "measure") %>% 
  ggplot(aes(x = model, y = value, fill = measure)) +
  geom_bar(position = "dodge", stat = "identity") +
  theme_bw() +
  coord_flip() +
  geom_text(aes(label = paste0(round(value*100, digits = 1), "%")), 
            position = position_dodge(0.9), vjust = 0.3, size = 2.7, hjust = -0.1) +
  labs(title = "Comparison of unbalanced data techniques", 
       x = "Techniques", 
       y = "Performance") +
  scale_fill_discrete(name = "Metrics:",
                      labels = c("Accuracy", "MCC", "Sensitivity", "Specificity")) +
  theme(legend.position = "bottom")

We can see from the above plot, the base model (decision tree) clearly has a low detection rate for a minority class (specificity). All methods able to increase the specificity, while sacrificing the accuracy and sensitivity. As mentioned earlier, accuracy is not a good metrics for this kind of model (ie; accuracy paradox). MCC on the other hand, takes into account all values of confusion matrix; true positive, false positive, true negative, and false negative. Hence, MCC is more informative compared to accuracy (and F score, which has not been included in the plot, for the sake of simplicity).

A more balanced model probably downsample approach based on MCC, specificity, and sensitivity. However, this does not mean that downsample technique is the best as I believes each technique behaves differently from one data to another.

References: