Apply: Classification
Eli O’Neill
2024-10-17
Import Data
library(tidyverse)## Warning: package 'ggplot2' was built under R version 4.3.3## ── 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.3 ✔ tidyr 1.3.1
## ✔ purrr 1.0.2
## ── 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 errorslibrary(correlationfunnel)## Warning: package 'correlationfunnel' was built under R version 4.3.3## ══ Using correlationfunnel? ════════════════════════════════════════════════════
## You might also be interested in applied data science training for business.
## </> Learn more at - www.business-science.io </>members <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2020/2020-09-22/members.csv')## Rows: 76519 Columns: 21
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (10): expedition_id, member_id, peak_id, peak_name, season, sex, citizen...
## dbl (5): year, age, highpoint_metres, death_height_metres, injury_height_me...
## lgl (6): hired, success, solo, oxygen_used, died, injured
##
## ℹ 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.members## # A tibble: 76,519 × 21
## expedition_id member_id peak_id peak_name year season sex age
## <chr> <chr> <chr> <chr> <dbl> <chr> <chr> <dbl>
## 1 AMAD78301 AMAD78301-01 AMAD Ama Dablam 1978 Autumn M 40
## 2 AMAD78301 AMAD78301-02 AMAD Ama Dablam 1978 Autumn M 41
## 3 AMAD78301 AMAD78301-03 AMAD Ama Dablam 1978 Autumn M 27
## 4 AMAD78301 AMAD78301-04 AMAD Ama Dablam 1978 Autumn M 40
## 5 AMAD78301 AMAD78301-05 AMAD Ama Dablam 1978 Autumn M 34
## 6 AMAD78301 AMAD78301-06 AMAD Ama Dablam 1978 Autumn M 25
## 7 AMAD78301 AMAD78301-07 AMAD Ama Dablam 1978 Autumn M 41
## 8 AMAD78301 AMAD78301-08 AMAD Ama Dablam 1978 Autumn M 29
## 9 AMAD79101 AMAD79101-03 AMAD Ama Dablam 1979 Spring M 35
## 10 AMAD79101 AMAD79101-04 AMAD Ama Dablam 1979 Spring M 37
## # ℹ 76,509 more rows
## # ℹ 13 more variables: citizenship <chr>, expedition_role <chr>, hired <lgl>,
## # highpoint_metres <dbl>, success <lgl>, solo <lgl>, oxygen_used <lgl>,
## # died <lgl>, death_cause <chr>, death_height_metres <dbl>, injured <lgl>,
## # injury_type <chr>, injury_height_metres <dbl>Clean Data
skimr::skim(members)| Name | members |
| Number of rows | 76519 |
| Number of columns | 21 |
| _______________________ | |
| Column type frequency: | |
| character | 10 |
| logical | 6 |
| numeric | 5 |
| ________________________ | |
| Group variables | None |
Variable type: character
| skim_variable | n_missing | complete_rate | min | max | empty | n_unique | whitespace |
|---|---|---|---|---|---|---|---|
| expedition_id | 0 | 1.00 | 9 | 9 | 0 | 10350 | 0 |
| member_id | 0 | 1.00 | 12 | 12 | 0 | 76518 | 0 |
| peak_id | 0 | 1.00 | 4 | 4 | 0 | 391 | 0 |
| peak_name | 15 | 1.00 | 4 | 25 | 0 | 390 | 0 |
| season | 0 | 1.00 | 6 | 7 | 0 | 5 | 0 |
| sex | 2 | 1.00 | 1 | 1 | 0 | 2 | 0 |
| citizenship | 10 | 1.00 | 2 | 23 | 0 | 212 | 0 |
| expedition_role | 21 | 1.00 | 4 | 25 | 0 | 524 | 0 |
| death_cause | 75413 | 0.01 | 3 | 27 | 0 | 12 | 0 |
| injury_type | 74807 | 0.02 | 3 | 27 | 0 | 11 | 0 |
Variable type: logical
| skim_variable | n_missing | complete_rate | mean | count |
|---|---|---|---|---|
| hired | 0 | 1 | 0.21 | FAL: 60788, TRU: 15731 |
| success | 0 | 1 | 0.38 | FAL: 47320, TRU: 29199 |
| solo | 0 | 1 | 0.00 | FAL: 76398, TRU: 121 |
| oxygen_used | 0 | 1 | 0.24 | FAL: 58286, TRU: 18233 |
| died | 0 | 1 | 0.01 | FAL: 75413, TRU: 1106 |
| injured | 0 | 1 | 0.02 | FAL: 74806, TRU: 1713 |
Variable type: numeric
| skim_variable | n_missing | complete_rate | mean | sd | p0 | p25 | p50 | p75 | p100 | hist |
|---|---|---|---|---|---|---|---|---|---|---|
| year | 0 | 1.00 | 2000.36 | 14.78 | 1905 | 1991 | 2004 | 2012 | 2019 | ▁▁▁▃▇ |
| age | 3497 | 0.95 | 37.33 | 10.40 | 7 | 29 | 36 | 44 | 85 | ▁▇▅▁▁ |
| highpoint_metres | 21833 | 0.71 | 7470.68 | 1040.06 | 3800 | 6700 | 7400 | 8400 | 8850 | ▁▁▆▃▇ |
| death_height_metres | 75451 | 0.01 | 6592.85 | 1308.19 | 400 | 5800 | 6600 | 7550 | 8830 | ▁▁▂▇▆ |
| injury_height_metres | 75510 | 0.01 | 7049.91 | 1214.24 | 400 | 6200 | 7100 | 8000 | 8880 | ▁▁▂▇▇ |
Notes: * drop death_cause, highpoint_metres, death_height_metres, injury_height_metres, injury_type (missing values) * filter missing observations out- age, peak_name, sex, citizenship, expedition_role * target variable- died- only small amount die * member_id is id variable (one repeat- remove one obs) * drop peak_id- redundant * convert character variables to factor
data <- members %>%
# Drop variables with too many missing values
select(-death_cause, -injury_type, -highpoint_metres, -death_height_metres, -injury_height_metres) %>%
# Drop observations with missing values
drop_na() %>%
# Remove a redundant variable
select(-peak_id, -expedition_id) %>%
# Remove one of the two members with the identical id
distinct(member_id, .keep_all = TRUE) %>%
# Recode died
mutate(died = case_when(died == "TRUE" ~ "died", died == "FALSE" ~ "no")) %>%
# Convert character variables to factors
mutate(across(where(is.character), factor)) %>%
# Convert logical variables to factors
mutate(across(where(is.logical), factor)) %>%
# id should be character
mutate(member_id = as.character(member_id))
skimr::skim(data)| Name | data |
| Number of rows | 72984 |
| Number of columns | 14 |
| _______________________ | |
| Column type frequency: | |
| character | 1 |
| factor | 11 |
| numeric | 2 |
| ________________________ | |
| Group variables | None |
Variable type: character
| skim_variable | n_missing | complete_rate | min | max | empty | n_unique | whitespace |
|---|---|---|---|---|---|---|---|
| member_id | 0 | 1 | 12 | 12 | 0 | 72984 | 0 |
Variable type: factor
| skim_variable | n_missing | complete_rate | ordered | n_unique | top_counts |
|---|---|---|---|---|---|
| peak_name | 0 | 1 | FALSE | 390 | Eve: 20994, Cho: 8608, Ama: 8235, Man: 4510 |
| season | 0 | 1 | FALSE | 4 | Spr: 36150, Aut: 34186, Win: 2011, Sum: 637 |
| sex | 0 | 1 | FALSE | 2 | M: 66150, F: 6834 |
| citizenship | 0 | 1 | FALSE | 207 | Nep: 14367, USA: 6318, Jap: 6188, UK: 5071 |
| expedition_role | 0 | 1 | FALSE | 483 | Cli: 43315, H-A: 13033, Lea: 9884, Exp: 1411 |
| hired | 0 | 1 | FALSE | 2 | FAL: 59006, TRU: 13978 |
| success | 0 | 1 | FALSE | 2 | FAL: 44913, TRU: 28071 |
| solo | 0 | 1 | FALSE | 2 | FAL: 72868, TRU: 116 |
| oxygen_used | 0 | 1 | FALSE | 2 | FAL: 55215, TRU: 17769 |
| died | 0 | 1 | FALSE | 2 | no: 72055, die: 929 |
| injured | 0 | 1 | FALSE | 2 | FAL: 71333, TRU: 1651 |
Variable type: numeric
| skim_variable | n_missing | complete_rate | mean | sd | p0 | p25 | p50 | p75 | p100 | hist |
|---|---|---|---|---|---|---|---|---|---|---|
| year | 0 | 1 | 2001.00 | 14.12 | 1905 | 1992 | 2004 | 2012 | 2019 | ▁▁▁▃▇ |
| age | 0 | 1 | 37.34 | 10.39 | 7 | 29 | 36 | 44 | 85 | ▁▇▅▁▁ |
Explore Data
Correlation funnel
data_binarized <- data %>%
select(-member_id) %>%
binarize()
data_binarized %>% glimpse()## Rows: 72,984
## Columns: 67
## $ peak_name__Ama_Dablam <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, …
## $ peak_name__Annapurna_I <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ peak_name__Annapurna_IV <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ peak_name__Baruntse <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ peak_name__Cho_Oyu <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ peak_name__Dhaulagiri_I <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ peak_name__Everest <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ peak_name__Himlung_Himal <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ peak_name__Kangchenjunga <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ peak_name__Lhotse <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ peak_name__Makalu <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ peak_name__Manaslu <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ peak_name__Pumori <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ `peak_name__-OTHER` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ `year__-Inf_1992` <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, …
## $ year__1992_2004 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ year__2004_2012 <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ year__2012_Inf <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ season__Autumn <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, …
## $ season__Spring <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, …
## $ season__Winter <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ `season__-OTHER` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ sex__F <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ sex__M <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, …
## $ `age__-Inf_29` <dbl> 0, 0, 1, 0, 0, 1, 0, 1, 0, 0, 1, 0, 1, …
## $ age__29_36 <dbl> 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 0, …
## $ age__36_44 <dbl> 1, 1, 0, 1, 0, 0, 1, 0, 0, 1, 0, 1, 0, …
## $ age__44_Inf <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__Australia <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__Austria <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__Canada <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__China <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__France <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, …
## $ citizenship__Germany <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__India <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__Italy <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__Japan <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__Nepal <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__Netherlands <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__New_Zealand <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__Poland <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__Russia <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__S_Korea <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__Spain <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__Switzerland <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__UK <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ citizenship__USA <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 1, …
## $ citizenship__W_Germany <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, …
## $ `citizenship__-OTHER` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ expedition_role__Climber <dbl> 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, …
## $ expedition_role__Deputy_Leader <dbl> 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ expedition_role__Exp_Doctor <dbl> 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ `expedition_role__H-A_Worker` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ expedition_role__Leader <dbl> 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ `expedition_role__-OTHER` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, …
## $ hired__FALSE <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, …
## $ hired__TRUE <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ success__FALSE <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, …
## $ success__TRUE <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0, …
## $ solo__FALSE <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, …
## $ `solo__-OTHER` <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ oxygen_used__FALSE <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, …
## $ oxygen_used__TRUE <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ died__died <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ died__no <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, …
## $ injured__FALSE <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, …
## $ injured__TRUE <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …data_correlation <- data_binarized %>%
correlate(died__died)## Warning: correlate(): [Data Imbalance Detected] Consider sampling to balance the classes more than 5%
## Column with imbalance: died__dieddata_correlation## # A tibble: 67 × 3
## feature bin correlation
## <fct> <chr> <dbl>
## 1 died died 1
## 2 died no -1
## 3 year -Inf_1992 0.0519
## 4 peak_name Annapurna_I 0.0336
## 5 success FALSE 0.0332
## 6 success TRUE -0.0332
## 7 peak_name Dhaulagiri_I 0.0290
## 8 peak_name Ama_Dablam -0.0281
## 9 peak_name Cho_Oyu -0.0241
## 10 year 2004_2012 -0.0211
## # ℹ 57 more rowsdata_correlation %>%
correlationfunnel::plot_correlation_funnel()## Warning: ggrepel: 41 unlabeled data points (too many overlaps). Consider
## increasing max.overlaps
Notes: * strongest correlation appears to be year (1992_2004) * look further into- peak_name, sex, solo
Year - is it safer with modern equipment?
data %>%
ggplot(aes(died, year)) +
geom_boxplot()
Notes: fewer average deaths
Peak_name - are some peaks more dangerous?
top10_peaks <- data %>% count(peak_name, sort = TRUE) %>% slice_max(order_by = n, n = 10) %>% pull(peak_name)
data %>%
filter(peak_name %in% top10_peaks) %>%
count(died, peak_name) %>%
pivot_wider(names_from = died, values_from = n, values_fill = 0) %>%
mutate(percent_died = (died / (no + died)) * 100) %>%
ggplot(aes(percent_died, fct_reorder(peak_name, percent_died))) +
geom_col() +
labs(y = "Peak Names", x = "Percent Died")
Notes: Annapurna has most deaths, followed by Dhaulgiri
Sex
data %>%
count(died, sex) %>%
pivot_wider(names_from = died, values_from = n) %>%
mutate(percent_died = (died / (no + died)) * 100) %>%
ggplot(aes(percent_died, sex)) +
geom_col()
Notes: Men have higher percentage of deaths
split data
library(tidymodels)## Warning: package 'tidymodels' was built under R version 4.3.3## ── Attaching packages ────────────────────────────────────── tidymodels 1.2.0 ──## ✔ broom 1.0.5 ✔ rsample 1.2.1
## ✔ dials 1.3.0 ✔ tune 1.2.1
## ✔ infer 1.0.7 ✔ workflows 1.1.4
## ✔ modeldata 1.4.0 ✔ workflowsets 1.1.0
## ✔ parsnip 1.2.1 ✔ yardstick 1.3.1
## ✔ recipes 1.1.0## Warning: package 'dials' was built under R version 4.3.3## Warning: package 'infer' was built under R version 4.3.3## Warning: package 'modeldata' was built under R version 4.3.3## Warning: package 'parsnip' was built under R version 4.3.3## Warning: package 'recipes' was built under R version 4.3.3## Warning: package 'rsample' was built under R version 4.3.3## Warning: package 'tune' was built under R version 4.3.3## Warning: package 'workflows' was built under R version 4.3.3## Warning: package 'workflowsets' was built under R version 4.3.3## Warning: package 'yardstick' was built under R version 4.3.3## ── 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()
## • Use tidymodels_prefer() to resolve common conflicts.#set.seed(333)
#data <- data %>% sample_n(100)
data_split <- initial_split(data, strata = died)
data_train <- training(data_split)
data_test <- testing(data_split)
data_cv <- rsample::vfold_cv(data_train, strata = died)preprocess data
library(themis)## Warning: package 'themis' was built under R version 4.3.3xgboost_rec <- recipes::recipe(died ~ ., data = data_train) %>%
update_role(member_id, new_role = "ID") %>%
step_other(peak_name, citizenship, expedition_role) %>%
step_dummy(all_nominal_predictors()) %>% step_smote(died)
xgboost_rec %>% prep() %>% juice() %>% glimpse()## Rows: 108,110
## Columns: 25
## $ member_id <fct> AMAD78301-02, AMAD78301-05, AMAD78301-07, A…
## $ year <dbl> 1978, 1978, 1978, 1978, 1979, 1979, 1979, 1…
## $ age <dbl> 41, 34, 41, 29, 35, 37, 23, 44, 25, 32, 32,…
## $ died <fct> no, no, no, no, no, no, no, no, no, no, no,…
## $ peak_name_Cho.Oyu <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ peak_name_Everest <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ peak_name_Manaslu <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ peak_name_other <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ season_Spring <dbl> 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1…
## $ season_Summer <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ season_Winter <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ sex_M <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1…
## $ citizenship_Japan <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ citizenship_Nepal <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ citizenship_UK <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ citizenship_USA <dbl> 0, 0, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1…
## $ citizenship_other <dbl> 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ expedition_role_H.A.Worker <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ expedition_role_Leader <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ expedition_role_other <dbl> 1, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 1, 0, 1…
## $ hired_TRUE. <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ success_TRUE. <dbl> 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 1, 1, 0…
## $ solo_TRUE. <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ oxygen_used_TRUE. <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…
## $ injured_TRUE. <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0…specify model
library(usemodels)## Warning: package 'usemodels' was built under R version 4.3.3usemodels::use_xgboost(died ~., data = data_train)## xgboost_recipe <-
## recipe(formula = died ~ ., data = data_train) %>%
## step_zv(all_predictors())
##
## xgboost_spec <-
## boost_tree(trees = tune(), min_n = tune(), tree_depth = tune(), learn_rate = tune(),
## loss_reduction = tune(), sample_size = tune()) %>%
## set_mode("classification") %>%
## set_engine("xgboost")
##
## xgboost_workflow <-
## workflow() %>%
## add_recipe(xgboost_recipe) %>%
## add_model(xgboost_spec)
##
## set.seed(76269)
## xgboost_tune <-
## tune_grid(xgboost_workflow, resamples = stop("add your rsample object"), grid = stop("add number of candidate points"))xgboost_spec <-
boost_tree(trees = tune()) %>%
set_mode("classification") %>%
set_engine("xgboost")
xgboost_workflow <-
workflow() %>%
add_recipe(xgboost_rec) %>%
add_model(xgboost_spec) tune hyperparameters
doParallel::registerDoParallel()
set.seed(62219)
xgboost_tune <-
tune_grid(xgboost_workflow, resamples = data_cv, grid = 5, control = control_grid(save_pred = TRUE))Model Eval
Identify optimal values for hyperparameters
collect_metrics(xgboost_tune)## # A tibble: 15 × 7
## trees .metric .estimator mean n std_err .config
## <int> <chr> <chr> <dbl> <int> <dbl> <chr>
## 1 353 accuracy binary 0.986 10 0.000442 Preprocessor1_Model1
## 2 353 brier_class binary 0.0130 10 0.000364 Preprocessor1_Model1
## 3 353 roc_auc binary 0.717 10 0.0140 Preprocessor1_Model1
## 4 614 accuracy binary 0.986 10 0.000527 Preprocessor1_Model2
## 5 614 brier_class binary 0.0135 10 0.000401 Preprocessor1_Model2
## 6 614 roc_auc binary 0.706 10 0.0149 Preprocessor1_Model2
## 7 801 accuracy binary 0.985 10 0.000545 Preprocessor1_Model3
## 8 801 brier_class binary 0.0137 10 0.000418 Preprocessor1_Model3
## 9 801 roc_auc binary 0.704 10 0.0149 Preprocessor1_Model3
## 10 1420 accuracy binary 0.984 10 0.000629 Preprocessor1_Model4
## 11 1420 brier_class binary 0.0145 10 0.000452 Preprocessor1_Model4
## 12 1420 roc_auc binary 0.704 10 0.0150 Preprocessor1_Model4
## 13 1733 accuracy binary 0.984 10 0.000622 Preprocessor1_Model5
## 14 1733 brier_class binary 0.0147 10 0.000459 Preprocessor1_Model5
## 15 1733 roc_auc binary 0.703 10 0.0150 Preprocessor1_Model5collect_predictions(xgboost_tune) %>%
group_by(id) %>%
roc_curve(died, .pred_died) %>%
autoplot()
fit the model for the last time
xgboost_last <- xgboost_workflow %>%
finalize_workflow(select_best(xgboost_tune, metric = "accuracy")) %>%
last_fit(data_split)## Warning: package 'xgboost' was built under R version 4.3.3collect_metrics(xgboost_last)## # A tibble: 3 × 4
## .metric .estimator .estimate .config
## <chr> <chr> <dbl> <chr>
## 1 accuracy binary 0.984 Preprocessor1_Model1
## 2 roc_auc binary 0.740 Preprocessor1_Model1
## 3 brier_class binary 0.0144 Preprocessor1_Model1collect_predictions(xgboost_last) %>%
yardstick::conf_mat(died, .pred_class) %>%
autoplot()
variable importance
library(vip)## Warning: package 'vip' was built under R version 4.3.3##
## Attaching package: 'vip'## The following object is masked from 'package:utils':
##
## vixgboost_last %>%
workflows::extract_fit_engine() %>%
vip()