Merge branch 'master' into master

dataset_prep.R

@@ -0,0 +1,42 @@
+#### data load and preprocessing
+
+library(tidyverse)
+library(tidymodels)
+library(stringr)
+library(scorecard)
+library(recipes)
+
+rm(list = ls())
+
+source("funs_preproc.R")
+
+data_raw <- read_csv("data/dataset1.csv")
+data1 <- data_raw %>% 
+  mutate(Geography = factor(Geography), Gender = factor(Gender), 
+         Exited = factor(Exited) %>% `levels<-`(c("No", "Yes")), 
+         IsActiveMember = factor(IsActiveMember) %>% `levels<-`(c("No", "Yes")),
+         HasCrCard = factor(HasCrCard) %>% `levels<-`(c("No", "Yes"))) %>% 
+  dplyr::select(-RowNumber, -CustomerId, -Surname)
+
+data2 <- recipe(Exited ~ ., data = data1) %>% 
+  step_dummy(Geography) %>% 
+  prep %>% bake(new_data = data1)
+
+changed_cols_idx <- data2 %>% colnames %>% str_split("_") %>% map_lgl(~ .x[1] == "Geography")
+changed_cols <- colnames(data2)[changed_cols_idx]
+data2 <- data2 %>% 
+  mutate_at(changed_cols, ~ as.factor(.x) %>% `levels<-`(c("No", "Yes"))) %>% 
+  rename_at(changed_cols, ~ str_remove(.x, "_"))
+
+data2 %>% filter_vars_by_iv(significance_thres = 0.01) %>%
+  initial_split(prop = 0.75) %>%
+  write_rds("data/split_raw.RDS", compress = "gz2")
+
+data3 <- data2 %>% 
+  factorize(bin_methods = "tree") %>% 
+  as_tibble() %>% 
+  filter_vars_by_iv(significance_thres = 0.01)
+
+dataset_split <- data3 %>% initial_split(prop = 0.75) %>% write_rds("data/split.RDS", compress = "gz2")
+
+rm(list = ls())

docs/report1.Rmd

@@ -1,14 +1,21 @@
 ---
-title: "IRD Report - Churn Modelling"
-author: "Jakub Cierocki"
+title: "Churn modeling - problem klasyfikacji klienta banku"
+author: "Jakub Cierocki & Szymon Reddig"
 date: "14 04 2020"
 output: pdf_document
----
-WPROWADZENIE
 
-Rozważania na temat "customer churn", czyli zakończenie współpracy klienta z przedsiębiorstwem było w kręgu zainteresowania naukowców od wielu lat. Firmy, w szczególności banki są zainteresowane takimi klientami i analizowaniem ich zachowania, gdyż pozyskiwania nowych klientów zwykle jest o wiele droższym zabiegiem, niż utrzymanie dotychczasowych. Przykładowo, jeśli Spotify zidentyifkowałby segment osób, które byłyby obciążone ryzykiem churnowania, przedsiębiorstwo mogłoby zasypać ich specjalnymi ofertami, zachęcających ich do dalszego korzystania z ich usług.
 
-Kolejnym argumentem potwierdzającym znaczenie badania jest ryzyko powielającej się zależności, która powoduje długotrwałą strate klientów, której przedsiębiorstwo mogłoby uniknąć, analizując zachowania oraz cechy klientów w grupie ryzyka.
+# Wprowadzenie
+
+Zjawisko tzw "customer churn" (\textit{churn} - ang. odpływ, rezygnacja), czyli rezygnacji klienta ze  współpracy z przedsiębiorstwem, jest w kręgu zainteresowania naukowców od wielu lat. Wiąże się z nim kilka różnych problemów analitycznych, m.in. prognozowanie dynamiki liczby klientów oraz klasyfikacja indywidualnego klienta (czy zrezygnuje?).
+
+Firmy, a w szczególności banki, inwestują mocno w modelowanie tego zjawiska, gdyż pozyskiwanie nowych klientów jest często o wiele droższym zabiegiem, niż utrzymanie dotychczasowych, a dynamika ich liczby jest kluczowa przy modelowaniu procesów biznesowych. Przykładowo, jeśli Spotify (dostawca usługi streamowania muzyki) zidentyfikowałoby segment osób, które z dużym prawdopobieństwem zrezygnują niedługo z subskrypcji, przedsiębiorstwo mogłoby zasypać ich specjalnymi ofertami, zachęcających ich do dalszego korzystania z ich oferty. Z drugiej strony powiązanie nielojalności konsumenckiej z atrybutami konkretnej podgrupy klientów może pomóc w racjonalizacji kosztów przeznaczonych na reklamę i projektowanie produktów przeznaczonych dla jej przedstawicieli.
+
+W niniejszym raporcie zbadamy, jak cechy klienta są powiązane z podjęciem przez niego decyzji o zmianie dostawcy usług bankowych. Na analizowane przez nas czynniki składają się atrybuty charakteryzującego samego klienta jak i jego dotychczasową współpracę z bankiem.
+
+Zjawisko "churnu" będziemy analizować z perspektywy banku. Dysponuje on pewnymi danymi personalnymi swoich klientów oraz pełną informacją o ich aktualnej (i przeszłej) subskrypcji usług tego banku. Problem badawczy, jaki chcemy przeanalizować to czy na podstawie tych danych bank jest w stanie z dużym prawdobieństwem przewidzieć potencjalną decyzję klienta o rezygnacji z jego usług w niedalekiej (bliżej nie określonej) przyszłości.
+
+# Problem badawczy
 
 W ninejszym raporcie zbadamy, jakie czynniki wpływają na decyzję klienta w przyadku zmiany banku. Skupimy się na czynnikach ekonomicznych, ale również aspektach psychofizycznych, które będą znacząco wpływać na wynik badanego przez nas zagadnienia.
 
@@ -74,4 +81,5 @@ Zmienne, które wybraliśmy zostały dobrane na podstawie ówcześnie wykonanej
   \textit{EstimatedSalary} - zmienna ciągła określająca estymowaną wartość zarobków klienta\newline
 
 
-  \textit{Tenure} - zmienna ciągła określająca liczbę lat jaka minęła, odkąd klient dołączył do banku\newline
+  \textit{Tenure} - zmienna ciągła określająca liczbę lat jaka minęła, odkąd klient dołączył do banku\newline
+

funs_preproc.R

@@ -0,0 +1,65 @@
+#### auxilary functions concerning data preprocessing linked visualization
+
+plot_freq <- function(df, fac_var, target = "Exited") {
+  target_vec <- df %>% pull(target)
+
+  count_frame <- as.data.frame(table(df[,fac_var])) %>% as_tibble() %>%
+    rename(TotalFreq = Freq) %>% 
+    add_column(ExitedFreq = as.integer(table(df[target_vec == "Yes", fac_var]))) %>% 
+    mutate_at(vars(TotalFreq, ExitedFreq), ~ .x / 100)  %>% 
+    column_to_rownames(var = "Var1")
+
+  print(count_frame)
+  multi <- max(count_frame$TotalFreq)/max(count_frame$ExitedFreq)
+
+  ggplot(count_frame) + 
+    geom_bar(aes(x = rownames(count_frame), y = TotalFreq), stat = "identity", color = "black", fill = "grey") +
+    geom_line(aes(x = 1:nrow(count_frame), y = ExitedFreq * multi), color = "red", lwd = 2) + 
+    scale_y_continuous(sec.axis = sec_axis(trans = ~ . / multi)) +
+    xlab("Country")
+}
+
+merge_factor_vars <- function(var1, ...) {
+  UseMethod("merge_factor_vars", var1)
+}
+
+merge_factor_vars.factor <- function(var1, ...) {
+  factor(str_c(var1, ...))
+}
+
+merge_factor_vars.tbl <- function(var1, ...) {
+  do.call(function(...) factor(str_c(...)), as.list(var1))
+}
+
+choose_best_binning <- function(binnings_df) {
+  binnings_df %>% pmap(function(...) {
+    opts <- list(...)
+    best_iv_idx <- opts %>% map_dbl(~ .x$total_iv[1]) %>% which.max()
+
+    opts[[best_iv_idx]]
+  }) %>% return
+}
+
+factorize <- function(df, y_name = "Exited", y_pos = "No", bin_limit = 6, bin_methods = c("tree", "chimerge")) {
+  fct_cols <- colnames(df)[(df %>% map_lgl(~ !is.factor(.x))) & colnames(df) != y_name]
+  binnings <- bin_methods %>% 
+    map(~ df %>% woebin(y = y_name, x = fct_cols, positive = y_pos, bin_num_limit = bin_limit, method = .x)) %>% 
+    `names<-`(bin_methods) %>% 
+    as_tibble()
+
+  bins_best <- choose_best_binning(binnings)
+
+  df %>% woebin_ply(bins = bins_best, to = "bin") %>% 
+    mutate_if(~ !is.factor(.x), as.factor) %>% 
+    rename_all(function(x) str_split(x, "_") %>% map_chr(~ .x[1])) %>% 
+    return
+}
+
+filter_vars_by_iv <- function(df, significance_thres = 0.02, y_name = "Exited", y_pos = "No") {
+  non_significant_vars <- df %>% 
+    iv(y_name, positive = y_pos) %>% 
+    filter(info_value < significance_thres) %>% 
+    pull(variable)
+
+  df %>% dplyr::select(-all_of(non_significant_vars)) %>% return
+}

funs_valid.R

@@ -0,0 +1,25 @@
+#### validation and visualisation automating functions
+
+get_all_iv <- function(..., y_name = "Exited", pos = "No") {
+  ivs_list <- list(...) %>% map(~ iv(.x, y = y_name, positive = pos) %>% as_tibble)
+
+  ivs_list %>% 
+    reduce(~ full_join(.x, .y, by = ("variable"))) %>% 
+    `colnames<-`(c("Klasyfikator", str_c("Model ", 1:length(ivs)))) %>% 
+    return
+}
+
+get_all_metrics <- function(pred_dfs, spec = 1L, y_name = "Exited") {
+  metrics_list <- pred_dfs %>% 
+    map(~ .x[[1]]) %>%
+    map(~ metrics(.x, y_name, .pred_class, .pred_No) %>% select(-2))
+
+  metrics_list %>% 
+    reduce(~ full_join(.x, .y, by = (".metric"))) %>% 
+    `colnames<-`(c("Metryka", str_c("Model ", 1:length(metrics_list)))) %>% 
+    return
+}
+
+exportable_conf_matrix <- function(df) {
+  conf_mat(df, Exited, .pred_class)$table
+}

gbm.R

@@ -0,0 +1,48 @@
+##### XGBoost GBM model
+
+library(tidyverse)
+library(stringr)
+library(tidymodels)
+library(xgboost)
+library(vip)
+
+rm(list = ls())
+
+# source("dataset_prep.R")
+
+dataset_split <- readRDS("data/split.RDS")
+dataset_split$data <-  dataset_split$data %>%
+  mutate_if(~ length(levels(.x)) > 3, as.integer) %>%
+  mutate_at(vars(Balance), as.integer)
+
+# dataset_split <- readRDS("data/split_raw.RDS")
+
+df_train <- dataset_split %>% training()
+df_test <- dataset_split %>% testing()
+
+gbm_model_1 <- boost_tree(mode = "classification",
+                          mtry = 3,
+                          trees = 500,
+                          min_n = 5,
+                          # tree_depth = 5,
+                          learn_rate = .1,
+                          loss_reduction = 0,
+                          sample_size = 0.7) %>% 
+  set_engine("xgboost", objective = "binary:logistic") %>% 
+  fit(Exited ~ ., data = df_train)
+
+df_pred <- gbm_model_1 %>% 
+  predict(df_test) %>% 
+  bind_cols(df_test)
+
+df_pred %>% metrics(Exited, .pred_class)
+
+df_pred_probs <- gbm_model_1 %>% 
+  predict(df_test, type = "prob") %>% 
+  bind_cols(df_test)
+
+df_pred_probs %>% roc_auc(Exited, .pred_No)
+df_pred_probs %>% roc_curve(Exited, .pred_No) %>% autoplot()
+
+vi(gbm_model_1)
+vip(gbm_model_1)

rand_forest.R

@@ -0,0 +1,44 @@
+##### ranger random forest model
+
+library(tidyverse)
+library(stringr)
+library(tidymodels)
+library(ranger)
+library(vip)
+
+rm(list = ls())
+
+# source("dataset_prep.R")
+
+dataset_splits <- list(
+  read_rds("data/split.RDS"),
+  read_rds("data/split_raw.RDS")
+  )
+
+testing_sets <- dataset_splits %>% map(~ .x %>% testing())
+
+models_specs <- list(
+  rand_forest("classification", 2, 1000, 5) %>% 
+    # set_engine("ranger", num.threads = 8, replace = F, sample.fraction = 0.8, importance = "impurity") %>%
+    set_engine("ranger", num.threads = 8, replace = F, sample.fraction = 0.8, importance = "permutation", local.importance = T)
+  )
+
+spec_names <- str_c("model_", 1:length(dataset_splits))
+fitted_models <- dataset_splits %>% 
+  map(~ .x %>% training()) %>% 
+  map2_dfc(spec_names, function(df, col_name) {
+    tibble(!!col_name := models_specs %>% map(~ .x %>%  fit(Exited ~ ., data = df)))
+  })
+
+pred_dfs <- list(fitted_models, testing_sets, spec_names) %>% pmap_dfc(function(models_by_spec, df, spec_name) {
+  tibble(!!spec_name := 
+           models_by_spec %>% map(function(model) {
+             df %>% bind_cols(
+               model %>% predict(df),
+               model %>% predict(df, type = "prob")
+             )
+           }))
+})
+
+fitted_models %>% write_rds("data/fitted_models.RDS", compress = "bz2")
+pred_dfs %>% write_rds("data/predictions.RDS", compress = "bz2")

validation_rf.R

@@ -0,0 +1,72 @@
+#### validation
+
+library(tidyverse)
+library(stringr)
+library(tidymodels)
+library(ranger)
+library(vip)
+library(knitr)
+library(kableExtra)
+library(scorecard)
+
+rm(list = ls())
+
+source("funs_valid.R")
+
+fitted_models <- read_rds("data/fitted_models.RDS")
+pred_dfs <- read_rds("data/predictions.RDS")
+df_1 <- read_rds("data/split.RDS")$data
+df_2 <- read_rds("data/split_raw.RDS")$data
+
+##########
+
+all_iv <- get_all_iv(df_1, df_2)
+all_iv %>% kable("markdown")
+
+# all_iv %>% kable("html") %>% save_kable("figures/ivs.png")
+
+all_metrics <- get_all_metrics(pred_dfs)
+all_metrics %>% kable("markdown")
+
+# all_metrics %>% kable("html") %>% save_kable("figures/metrics.png")
+
+##########
+
+## tu filtrujemy wybraną specyfikację
+
+preds <- pred_dfs %>% map(~ .x[[1]])
+
+##########
+
+conf_matrix_1 <- preds[[1]] %>% exportable_conf_matrix 
+conf_matrix_1 %>% kable("markdown")
+
+# conf_matrix_1 %>% kable("html") %>% save_kable("figures/conf_matrix1.png")
+
+conf_matrix_2 <- preds[[2]] %>% exportable_conf_matrix 
+conf_matrix_2 %>% kable("markdown")
+
+# conf_matrix_2 %>% kable("html") %>% save_kable("figures/conf_matrix2.png")
+
+roc_1 <- preds[[1]] %>% 
+  roc_curve(Exited, .pred_No) %>% 
+  autoplot()
+
+roc_2 <- preds[[1]] %>% 
+  roc_curve(Exited, .pred_No) %>% 
+  autoplot()
+
+roc_1
+roc_2
+
+# ggsave("figures/roc_1.png", roc_1)
+# ggsave("figures/roc_2.png", roc_2)
+
+vip_1 <- vip(fitted_models[[1]][[1]])
+vip_2 <- vip(fitted_models[[2]][[1]])
+
+vip_1
+vip_2
+
+# ggsave("figures/vip_1.png", vip_1)
+# ggsave("figures/vip_2.png", vip_2)