Goal: Build a classification model to predict whether the person died in an expedition

Import Data

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.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 errors
library(correlationfunnel)
## Warning: package 'correlationfunnel' was built under R version 4.4.1
## ══ Using correlationfunnel? ════════════════════════════════════════════════════
## You might also be interested in applied data science training for business.
## </> Learn more at - www.business-science.io </>
library(tidytext)
## Warning: package 'tidytext' was built under R version 4.4.1
library(xgboost)
## Warning: package 'xgboost' was built under R version 4.4.1
## 
## Attaching package: 'xgboost'
## 
## The following object is masked from 'package:dplyr':
## 
##     slice
library(textrecipes)
## Warning: package 'textrecipes' was built under R version 4.4.1
## Loading required package: recipes
## 
## Attaching package: 'recipes'
## 
## The following object is masked from 'package:stringr':
## 
##     fixed
## 
## The following object is masked from 'package:stats':
## 
##     step
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.

Explore Data

skimr::skim(members)
Data summary
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 ▁▁▂▇▇ 
str(members)
## spc_tbl_ [76,519 × 21] (S3: spec_tbl_df/tbl_df/tbl/data.frame)
##  $ expedition_id       : chr [1:76519] "AMAD78301" "AMAD78301" "AMAD78301" "AMAD78301" ...
##  $ member_id           : chr [1:76519] "AMAD78301-01" "AMAD78301-02" "AMAD78301-03" "AMAD78301-04" ...
##  $ peak_id             : chr [1:76519] "AMAD" "AMAD" "AMAD" "AMAD" ...
##  $ peak_name           : chr [1:76519] "Ama Dablam" "Ama Dablam" "Ama Dablam" "Ama Dablam" ...
##  $ year                : num [1:76519] 1978 1978 1978 1978 1978 ...
##  $ season              : chr [1:76519] "Autumn" "Autumn" "Autumn" "Autumn" ...
##  $ sex                 : chr [1:76519] "M" "M" "M" "M" ...
##  $ age                 : num [1:76519] 40 41 27 40 34 25 41 29 35 37 ...
##  $ citizenship         : chr [1:76519] "France" "France" "France" "France" ...
##  $ expedition_role     : chr [1:76519] "Leader" "Deputy Leader" "Climber" "Exp Doctor" ...
##  $ hired               : logi [1:76519] FALSE FALSE FALSE FALSE FALSE FALSE ...
##  $ highpoint_metres    : num [1:76519] NA 6000 NA 6000 NA ...
##  $ success             : logi [1:76519] FALSE FALSE FALSE FALSE FALSE FALSE ...
##  $ solo                : logi [1:76519] FALSE FALSE FALSE FALSE FALSE FALSE ...
##  $ oxygen_used         : logi [1:76519] FALSE FALSE FALSE FALSE FALSE FALSE ...
##  $ died                : logi [1:76519] FALSE FALSE FALSE FALSE FALSE FALSE ...
##  $ death_cause         : chr [1:76519] NA NA NA NA ...
##  $ death_height_metres : num [1:76519] NA NA NA NA NA NA NA NA NA NA ...
##  $ injured             : logi [1:76519] FALSE FALSE FALSE FALSE FALSE FALSE ...
##  $ injury_type         : chr [1:76519] NA NA NA NA ...
##  $ injury_height_metres: num [1:76519] NA NA NA NA NA NA NA NA NA NA ...
##  - attr(*, "spec")=
##   .. cols(
##   ..   expedition_id = col_character(),
##   ..   member_id = col_character(),
##   ..   peak_id = col_character(),
##   ..   peak_name = col_character(),
##   ..   year = col_double(),
##   ..   season = col_character(),
##   ..   sex = col_character(),
##   ..   age = col_double(),
##   ..   citizenship = col_character(),
##   ..   expedition_role = col_character(),
##   ..   hired = col_logical(),
##   ..   highpoint_metres = col_double(),
##   ..   success = col_logical(),
##   ..   solo = col_logical(),
##   ..   oxygen_used = col_logical(),
##   ..   died = col_logical(),
##   ..   death_cause = col_character(),
##   ..   death_height_metres = col_double(),
##   ..   injured = col_logical(),
##   ..   injury_type = col_character(),
##   ..   injury_height_metres = col_double()
##   .. )
##  - attr(*, "problems")=<externalptr>
variances <- apply(members, 2, var, na.rm = TRUE)
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
## Warning in FUN(newX[, i], ...): NAs introduced by coercion
zero_variance_columns <- names(variances[variances == 0])

print(zero_variance_columns)
##  [1] NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA NA

Clean Data

factors_vec <- c("death_cause", "injury_type", "highpoint_metres", "death_height_metres")

members_clean <- members %>% 
 select(-death_cause, -injury_type, -highpoint_metres, -death_height_metres, -injury_height_metres) %>%
  drop_na()
# Adressing Missing Values
members_clean <- members_clean %>%
 mutate(across(where(is.character), factor)) %>%
  
  mutate(across(where(is.logical), factor)) %>%
  mutate(member_id = as.character(member_id))

skimr::skim(members_clean)
Data summary
Name members_clean
Number of rows 72985
Number of columns 16
_______________________
Column type frequency:
character 1
factor 13
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
expedition_id 0 1 FALSE 10279 EVE: 92, HIM: 90, EVE: 79, EVE: 76
peak_id 0 1 FALSE 390 EVE: 20994, CHO: 8608, AMA: 8235, MAN: 4510
peak_name 0 1 FALSE 390 Eve: 20994, Cho: 8608, Ama: 8235, Man: 4510
season 0 1 FALSE 4 Spr: 36151, Aut: 34186, Win: 2011, Sum: 637
sex 0 1 FALSE 2 M: 66151, 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: 9885, Exp: 1411
hired 0 1 FALSE 2 FAL: 59007, TRU: 13978
success 0 1 FALSE 2 FAL: 44914, TRU: 28071
solo 0 1 FALSE 2 FAL: 72869, TRU: 116
oxygen_used 0 1 FALSE 2 FAL: 55216, TRU: 17769
died 0 1 FALSE 2 FAL: 72056, TRU: 929
injured 0 1 FALSE 2 FAL: 71334, 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.40 7 29 36 44 85 ▁▇▅▁▁

Continue Exploring Data

members_clean %>%
  ggplot(aes(x = age, fill = as.factor(died))) +
  geom_histogram(binwidth = 5, alpha = 0.7, position = "dodge") +
  facet_wrap(~ as.factor(died), scales = "free_y") +
  labs(
    title = "Age Distribution by Survival Status",
    x = "Age",
    y = "count",
    fill = "Died"
  ) +
  theme_minimal()

Prepare DAta

data_binarized_tbl <- members_clean %>%
  select(-peak_id, -expedition_id) %>%
  distinct(member_id, .keep_all = TRUE) %>%
  mutate(died = case_when(died == "TRUE" ~ "died", died == "FALSE" ~ "no")) %>%
  binarize()


data_binarized_tbl %>% glimpse()
## Rows: 72,984
## Columns: 69
## $ `member_id__ACHN15301-01`      <dbl> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, …
## $ `member_id__-OTHER`            <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, …
## $ 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, …

Correlate

data_corr_tbl <- data_binarized_tbl %>% 
  correlate( died__died )
## Warning: correlate(): [Data Imbalance Detected] Consider sampling to balance the classes more than 5%
##   Column with imbalance: died__died
data_corr_tbl
## # A tibble: 69 × 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
## # ℹ 59 more rows

Plot

data_corr_tbl %>%
  plot_correlation_funnel()
## Warning: ggrepel: 41 unlabeled data points (too many overlaps). Consider
## increasing max.overlaps