wisc_bc_data - kNN with CV

Author

Prof. Eric A. Suess 

library(tidyverse)
── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
✔ dplyr     1.1.4     ✔ readr     2.1.5
✔ forcats   1.0.0     ✔ stringr   1.5.1
✔ ggplot2   3.5.1     ✔ tibble    3.2.1
✔ lubridate 1.9.4     ✔ tidyr     1.3.1
✔ purrr     1.0.4     
── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
✖ dplyr::filter() masks stats::filter()
✖ dplyr::lag()    masks stats::lag()
ℹ Use the conflicted package (<http://conflicted.r-lib.org/>) to force all conflicts to become errors
library(tidymodels)
── Attaching packages ────────────────────────────────────── tidymodels 1.3.0 ──
✔ broom        1.0.7          ✔ rsample      1.2.1.9000
✔ dials        1.4.0.9000     ✔ tune         1.3.0.9000
✔ infer        1.0.7          ✔ workflows    1.2.0.9000
✔ modeldata    1.4.0          ✔ workflowsets 1.1.0     
✔ parsnip      1.3.0.9000     ✔ yardstick    1.3.2     
✔ recipes      1.1.1.9000     
── Conflicts ───────────────────────────────────────── tidymodels_conflicts() ──
✖ scales::discard() masks purrr::discard()
✖ dplyr::filter()   masks stats::filter()
✖ recipes::fixed()  masks stringr::fixed()
✖ dplyr::lag()      masks stats::lag()
✖ yardstick::spec() masks readr::spec()
✖ recipes::step()   masks stats::step()
library(naniar)
wbcd <- read_csv("wisc_bc_data.csv")
Rows: 569 Columns: 32
── Column specification ────────────────────────────────────────────────────────
Delimiter: ","
chr  (1): diagnosis
dbl (31): id, radius_mean, texture_mean, perimeter_mean, area_mean, smoothne...

ℹ Use `spec()` to retrieve the full column specification for this data.
ℹ Specify the column types or set `show_col_types = FALSE` to quiet this message.
wbcd <- wbcd %>% select(-id) %>% 
  mutate(diagnosis = as_factor(diagnosis))
wbcd
# A tibble: 569 × 31
   diagnosis radius_mean texture_mean perimeter_mean area_mean smoothness_mean
   <fct>           <dbl>        <dbl>          <dbl>     <dbl>           <dbl>
 1 B                12.3         12.4           78.8      464.          0.103 
 2 B                10.6         19.0           69.3      346.          0.0969
 3 B                11.0         16.8           70.9      373.          0.108 
 4 B                11.3         13.4           73        385.          0.116 
 5 B                15.2         13.2           97.6      712.          0.0796
 6 B                11.6         19.0           74.2      410.          0.0855
 7 B                11.5         23.9           74.5      404.          0.0926
 8 M                13.8         23.8           91.6      598.          0.132 
 9 B                10.5         19.3           67.4      336.          0.0999
10 B                11.1         15.0           71.5      374.          0.103 
# ℹ 559 more rows
# ℹ 25 more variables: compactness_mean <dbl>, concavity_mean <dbl>,
#   points_mean <dbl>, symmetry_mean <dbl>, dimension_mean <dbl>,
#   radius_se <dbl>, texture_se <dbl>, perimeter_se <dbl>, area_se <dbl>,
#   smoothness_se <dbl>, compactness_se <dbl>, concavity_se <dbl>,
#   points_se <dbl>, symmetry_se <dbl>, dimension_se <dbl>, radius_worst <dbl>,
#   texture_worst <dbl>, perimeter_worst <dbl>, area_worst <dbl>, …
wbcd %>% filter(is_na(diagnosis))
# A tibble: 0 × 31
# ℹ 31 variables: diagnosis <fct>, radius_mean <dbl>, texture_mean <dbl>,
#   perimeter_mean <dbl>, area_mean <dbl>, smoothness_mean <dbl>,
#   compactness_mean <dbl>, concavity_mean <dbl>, points_mean <dbl>,
#   symmetry_mean <dbl>, dimension_mean <dbl>, radius_se <dbl>,
#   texture_se <dbl>, perimeter_se <dbl>, area_se <dbl>, smoothness_se <dbl>,
#   compactness_se <dbl>, concavity_se <dbl>, points_se <dbl>,
#   symmetry_se <dbl>, dimension_se <dbl>, radius_worst <dbl>, …
wbcd_split <- initial_split(wbcd, prop = 0.8)
wbcd_split
<Training/Testing/Total>
<455/114/569>
wbcd_train <- training(wbcd_split)
head(wbcd_train)
# A tibble: 6 × 31
  diagnosis radius_mean texture_mean perimeter_mean area_mean smoothness_mean
  <fct>           <dbl>        <dbl>          <dbl>     <dbl>           <dbl>
1 M               13.2          18.7           86.0      535.          0.116 
2 B               12.8          16.5           81.4      502.          0.0983
3 B                9.85         15.7           63        293.          0.0949
4 B               11.8          17.4           75.3      429.          0.101 
5 M               15.5          24.0          104.       731.          0.118 
6 M               18.5          17.5          121.      1068           0.101 
# ℹ 25 more variables: compactness_mean <dbl>, concavity_mean <dbl>,
#   points_mean <dbl>, symmetry_mean <dbl>, dimension_mean <dbl>,
#   radius_se <dbl>, texture_se <dbl>, perimeter_se <dbl>, area_se <dbl>,
#   smoothness_se <dbl>, compactness_se <dbl>, concavity_se <dbl>,
#   points_se <dbl>, symmetry_se <dbl>, dimension_se <dbl>, radius_worst <dbl>,
#   texture_worst <dbl>, perimeter_worst <dbl>, area_worst <dbl>,
#   smoothness_worst <dbl>, compactness_worst <dbl>, concavity_worst <dbl>, …
wbcd_test <- testing(wbcd_split)
head(wbcd_test)
# A tibble: 6 × 31
  diagnosis radius_mean texture_mean perimeter_mean area_mean smoothness_mean
  <fct>           <dbl>        <dbl>          <dbl>     <dbl>           <dbl>
1 B                12.3         12.4           78.8      464.          0.103 
2 B                11.6         19.0           74.2      410.          0.0855
3 B                13.1         20.7           86.0      537.          0.0867
4 M                19.6         25            128.      1191           0.103 
5 B                15.1         16.4           99.6      674.          0.115 
6 M                15.3         25.3          102.       732.          0.108 
# ℹ 25 more variables: compactness_mean <dbl>, concavity_mean <dbl>,
#   points_mean <dbl>, symmetry_mean <dbl>, dimension_mean <dbl>,
#   radius_se <dbl>, texture_se <dbl>, perimeter_se <dbl>, area_se <dbl>,
#   smoothness_se <dbl>, compactness_se <dbl>, concavity_se <dbl>,
#   points_se <dbl>, symmetry_se <dbl>, dimension_se <dbl>, radius_worst <dbl>,
#   texture_worst <dbl>, perimeter_worst <dbl>, area_worst <dbl>,
#   smoothness_worst <dbl>, compactness_worst <dbl>, concavity_worst <dbl>, …
wbcd %>% count(diagnosis) %>% 
  mutate(prop = n/sum(n))
# A tibble: 2 × 3
  diagnosis     n  prop
  <fct>     <int> <dbl>
1 B           357 0.627
2 M           212 0.373
wbcd_train %>% count(diagnosis) %>% 
  mutate(prop = n/sum(n))
# A tibble: 2 × 3
  diagnosis     n  prop
  <fct>     <int> <dbl>
1 B           295 0.648
2 M           160 0.352
wbcd_test %>% count(diagnosis) %>% 
  mutate(prop = n/sum(n))
# A tibble: 2 × 3
  diagnosis     n  prop
  <fct>     <int> <dbl>
1 B            62 0.544
2 M            52 0.456
wbcd_rec <-
  recipe(diagnosis ~ ., data = wbcd_train) %>%
  step_normalize(all_predictors()) 

wbcd_rec
── Recipe ──────────────────────────────────────────────────────────────────────
── Inputs 
Number of variables by role
outcome:    1
predictor: 30
── Operations 
• Centering and scaling for: all_predictors()
summary(wbcd_rec)
# A tibble: 31 × 4
   variable         type      role      source  
   <chr>            <list>    <chr>     <chr>   
 1 radius_mean      <chr [2]> predictor original
 2 texture_mean     <chr [2]> predictor original
 3 perimeter_mean   <chr [2]> predictor original
 4 area_mean        <chr [2]> predictor original
 5 smoothness_mean  <chr [2]> predictor original
 6 compactness_mean <chr [2]> predictor original
 7 concavity_mean   <chr [2]> predictor original
 8 points_mean      <chr [2]> predictor original
 9 symmetry_mean    <chr [2]> predictor original
10 dimension_mean   <chr [2]> predictor original
# ℹ 21 more rows
knn_model <- 
  nearest_neighbor(neighbors = 9) %>%
  set_engine("kknn") %>% 
  set_mode("classification")
knn_fit <- knn_model %>% fit(diagnosis ~., wbcd_train)

knn_fit
parsnip model object


Call:
kknn::train.kknn(formula = diagnosis ~ ., data = data, ks = min_rows(9,     data, 5))

Type of response variable: nominal
Minimal misclassification: 0.03516484
Best kernel: optimal
Best k: 9
knn_training_pred <-
  predict(knn_fit, wbcd_train) %>% 
  bind_cols(predict(knn_fit, wbcd_train, type = "prob")) %>% 
  # Add the true outcome data back in
  bind_cols(wbcd_train %>% 
              select(diagnosis))
knn_training_pred %>%                # training set predictions
  accuracy(truth = diagnosis, .pred_class)
# A tibble: 1 × 3
  .metric  .estimator .estimate
  <chr>    <chr>          <dbl>
1 accuracy binary         0.987
knn_training_pred %>% # training set predictions
  roc_auc(truth = diagnosis, .pred_B)
# A tibble: 1 × 3
  .metric .estimator .estimate
  <chr>   <chr>          <dbl>
1 roc_auc binary          1.00
knn_training_pred %>%
  conf_mat(truth = diagnosis, estimate = .pred_class)
          Truth
Prediction   B   M
         B 294   5
         M   1 155
knn_test_pred <-
  predict(knn_fit, wbcd_test) %>% 
  bind_cols(predict(knn_fit, wbcd_test, type = "prob")) %>% 
  # Add the true outcome data back in
  bind_cols(wbcd_test %>% 
              select(diagnosis))
knn_test_pred %>%                # training set predictions
  accuracy(truth = diagnosis, .pred_class)
# A tibble: 1 × 3
  .metric  .estimator .estimate
  <chr>    <chr>          <dbl>
1 accuracy binary         0.991
knn_test_pred %>% # training set predictions
  roc_auc(truth = diagnosis, .pred_B)
# A tibble: 1 × 3
  .metric .estimator .estimate
  <chr>   <chr>          <dbl>
1 roc_auc binary         0.997
knn_test_pred %>%
  conf_mat(truth = diagnosis, estimate = .pred_class)
          Truth
Prediction  B  M
         B 62  1
         M  0 51
wbcd_wflow <-
  workflow() %>%
  add_recipe(wbcd_rec) %>%
  add_model(knn_model)

wbcd_wflow
══ Workflow ════════════════════════════════════════════════════════════════════
Preprocessor: Recipe
Model: nearest_neighbor()

── Preprocessor ────────────────────────────────────────────────────────────────
1 Recipe Step

• step_normalize()

── Model ───────────────────────────────────────────────────────────────────────
K-Nearest Neighbor Model Specification (classification)

Main Arguments:
  neighbors = 9

Computational engine: kknn 
knn_fit <- wbcd_wflow %>%
  last_fit(wbcd_split)
knn_fit %>%
  collect_predictions() %>%
  conf_mat(truth = diagnosis, estimate = .pred_class)
          Truth
Prediction  B  M
         B 62  1
         M  0 51
knn_fit %>%
  collect_metrics()
# A tibble: 3 × 4
  .metric     .estimator .estimate .config             
  <chr>       <chr>          <dbl> <chr>               
1 accuracy    binary        0.991  Preprocessor1_Model1
2 roc_auc     binary        0.997  Preprocessor1_Model1
3 brier_class binary        0.0163 Preprocessor1_Model1

Using Cross Validation

folds <- vfold_cv(wbcd_train, v = 10)
folds
#  10-fold cross-validation 
# A tibble: 10 × 2
   splits           id    
   <list>           <chr> 
 1 <split [409/46]> Fold01
 2 <split [409/46]> Fold02
 3 <split [409/46]> Fold03
 4 <split [409/46]> Fold04
 5 <split [409/46]> Fold05
 6 <split [410/45]> Fold06
 7 <split [410/45]> Fold07
 8 <split [410/45]> Fold08
 9 <split [410/45]> Fold09
10 <split [410/45]> Fold10
wbcd_fit_rs <- 
  wbcd_wflow %>% 
  fit_resamples(folds)
collect_metrics(wbcd_fit_rs)
# A tibble: 3 × 6
  .metric     .estimator   mean     n std_err .config             
  <chr>       <chr>       <dbl> <int>   <dbl> <chr>               
1 accuracy    binary     0.967     10 0.00991 Preprocessor1_Model1
2 brier_class binary     0.0287    10 0.00575 Preprocessor1_Model1
3 roc_auc     binary     0.991     10 0.00514 Preprocessor1_Model1