INFO H-510 Week 3
Sashank
2024-01-30
INFO-H510 Week 3 Data Dive
library(tidyverse)## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.4 ✔ readr 2.1.4
## ✔ forcats 1.0.0 ✔ stringr 1.5.1
## ✔ ggplot2 3.4.4 ✔ tibble 3.2.1
## ✔ lubridate 1.9.3 ✔ tidyr 1.3.0
## ✔ 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(ggplot2)
#Loading data
data <- read_delim("../Churn_Modelling.csv", delim = ",")## Rows: 10002 Columns: 14
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (3): Surname, Geography, Gender
## dbl (11): RowNumber, CustomerId, CreditScore, Age, Tenure, Balance, NumOfPro...
##
## ℹ 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.str(data)## spc_tbl_ [10,002 × 14] (S3: spec_tbl_df/tbl_df/tbl/data.frame)
## $ RowNumber : num [1:10002] 1 2 3 4 5 6 7 8 9 10 ...
## $ CustomerId : num [1:10002] 15634602 15647311 15619304 15701354 15737888 ...
## $ Surname : chr [1:10002] "Hargrave" "Hill" "Onio" "Boni" ...
## $ CreditScore : num [1:10002] 619 608 502 699 850 645 822 376 501 684 ...
## $ Geography : chr [1:10002] "France" "Spain" "France" "France" ...
## $ Gender : chr [1:10002] "Female" "Female" "Female" "Female" ...
## $ Age : num [1:10002] 42 41 42 39 43 44 50 29 44 NA ...
## $ Tenure : num [1:10002] 2 1 8 1 2 8 7 4 4 2 ...
## $ Balance : num [1:10002] 0 83808 159661 0 125511 ...
## $ NumOfProducts : num [1:10002] 1 1 3 2 1 2 2 4 2 1 ...
## $ HasCrCard : num [1:10002] 1 0 1 0 NA 1 1 1 0 1 ...
## $ IsActiveMember : num [1:10002] 1 1 0 0 1 0 1 0 NA 1 ...
## $ EstimatedSalary: num [1:10002] 101349 112543 113932 93827 79084 ...
## $ Exited : num [1:10002] 1 0 1 0 0 1 0 1 0 0 ...
## - attr(*, "spec")=
## .. cols(
## .. RowNumber = col_double(),
## .. CustomerId = col_double(),
## .. Surname = col_character(),
## .. CreditScore = col_double(),
## .. Geography = col_character(),
## .. Gender = col_character(),
## .. Age = col_double(),
## .. Tenure = col_double(),
## .. Balance = col_double(),
## .. NumOfProducts = col_double(),
## .. HasCrCard = col_double(),
## .. IsActiveMember = col_double(),
## .. EstimatedSalary = col_double(),
## .. Exited = col_double()
## .. )
## - attr(*, "problems")=<externalptr>Grouping 1
Grouping over Geography to summarize Balance.
data_grouping1 <- data |>
filter(!is.na(Geography)) |> #Geography contains one N/A value
group_by(Geography) |>
summarize(Average_Balance = mean(Balance), Total_Customers = n())
print(data_grouping1)## # A tibble: 3 × 3
## Geography Average_Balance Total_Customers
## <chr> <dbl> <int>
## 1 France 62119. 5014
## 2 Germany 119712. 2510
## 3 Spain 61818. 2477Here the least number of customers belong to Spain, let’s assign them to the Lowest Probability Group 1.
min_group_grouping1 <- data_grouping1 |>
filter(Total_Customers == min(Total_Customers)) |>
select(Geography)
min_group_grouping1 <- min_group_grouping1[[1, 1]]
print(paste("Minimum group -", min_group_grouping1))## [1] "Minimum group - Spain"Assigning Special Tag to Lowest Probability Group (ProbabilityGroup column)
data_1 <- data
data_1$ProbabilityGroup <- ifelse(data$Geography == min_group_grouping1, "LPG1", "") #LPG - Lowest Probability Group
print(data_1)## # A tibble: 10,002 × 15
## RowNumber CustomerId Surname CreditScore Geography Gender Age Tenure
## <dbl> <dbl> <chr> <dbl> <chr> <chr> <dbl> <dbl>
## 1 1 15634602 Hargrave 619 France Female 42 2
## 2 2 15647311 Hill 608 Spain Female 41 1
## 3 3 15619304 Onio 502 France Female 42 8
## 4 4 15701354 Boni 699 France Female 39 1
## 5 5 15737888 Mitchell 850 Spain Female 43 2
## 6 6 15574012 Chu 645 Spain Male 44 8
## 7 7 15592531 Bartlett 822 <NA> Male 50 7
## 8 8 15656148 Obinna 376 Germany Female 29 4
## 9 9 15792365 He 501 France Male 44 4
## 10 10 15592389 H? 684 France Male NA 2
## # ℹ 9,992 more rows
## # ℹ 7 more variables: Balance <dbl>, NumOfProducts <dbl>, HasCrCard <dbl>,
## # IsActiveMember <dbl>, EstimatedSalary <dbl>, Exited <dbl>,
## # ProbabilityGroup <chr>Both Spain and Germany have a similar number of customers, but interestingly the Average Balance of an individual from Germany is nearly double that of from Spain (On average). France on the other hand has double the number of customers, yet the average balance remained similar to Spain.
Visualizing
data_grouping1 |>
ggplot(aes(Geography, Total_Customers, fill=Geography)) +
geom_bar(stat="identity") +
labs(title ="Bar Chart of No. of Customers across each Geography", y="Total Customers")
data_grouping1 |>
ggplot(aes(Geography, Average_Balance, fill=Geography)) +
geom_bar(stat="identity") +
labs(title="Bar Chart of Average Customer Balance over Geographies", y="Average Balance")
Grouping 2
Grouping Credit Score of a customer and summarizing over Churn Status (Exited column)
First we need to divide CreditScore into multiple categories.
data |>
ggplot(aes(CreditScore)) +
geom_histogram() +
labs(x="Credit Score", y="Count")## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
Let’s split the data in to 3 categories - Low, Medium and High
data_2 <- data
data_2$CreditScCat <- cut_number(data$CreditScore, n=3, labels=c("Low", "Medium", "High"))
print(data_2)## # A tibble: 10,002 × 15
## RowNumber CustomerId Surname CreditScore Geography Gender Age Tenure
## <dbl> <dbl> <chr> <dbl> <chr> <chr> <dbl> <dbl>
## 1 1 15634602 Hargrave 619 France Female 42 2
## 2 2 15647311 Hill 608 Spain Female 41 1
## 3 3 15619304 Onio 502 France Female 42 8
## 4 4 15701354 Boni 699 France Female 39 1
## 5 5 15737888 Mitchell 850 Spain Female 43 2
## 6 6 15574012 Chu 645 Spain Male 44 8
## 7 7 15592531 Bartlett 822 <NA> Male 50 7
## 8 8 15656148 Obinna 376 Germany Female 29 4
## 9 9 15792365 He 501 France Male 44 4
## 10 10 15592389 H? 684 France Male NA 2
## # ℹ 9,992 more rows
## # ℹ 7 more variables: Balance <dbl>, NumOfProducts <dbl>, HasCrCard <dbl>,
## # IsActiveMember <dbl>, EstimatedSalary <dbl>, Exited <dbl>,
## # CreditScCat <fct>data_grouping2 <- data_2 |>
group_by(CreditScCat) |>
summarise(Churned=sum(Exited), Total=n()) |>
mutate(Proportion = Churned / Total)
print(data_grouping2)## # A tibble: 3 × 4
## CreditScCat Churned Total Proportion
## <fct> <dbl> <int> <dbl>
## 1 Low 724 3363 0.215
## 2 Medium 659 3334 0.198
## 3 High 655 3305 0.198A remarkably similar proportion of the customers have churned across the different Credit Score class. Not intuition would have suggested that often individuals with higher credit score are less likely to churn. But, data here suggests that the probability is fairly similar across each class.
min_group_grouping2 <- data_grouping2 |>
filter(Total == min(Total)) |>
select(CreditScCat)
min_group_grouping2 <- min_group_grouping2[[1, 1]]
print(paste("Minimum group -", min_group_grouping2))## [1] "Minimum group - High"data_2$ProbabilityGroup <- ifelse(data_2$CreditScCat == min_group_grouping2, "LPG2", "")
print(data_2)## # A tibble: 10,002 × 16
## RowNumber CustomerId Surname CreditScore Geography Gender Age Tenure
## <dbl> <dbl> <chr> <dbl> <chr> <chr> <dbl> <dbl>
## 1 1 15634602 Hargrave 619 France Female 42 2
## 2 2 15647311 Hill 608 Spain Female 41 1
## 3 3 15619304 Onio 502 France Female 42 8
## 4 4 15701354 Boni 699 France Female 39 1
## 5 5 15737888 Mitchell 850 Spain Female 43 2
## 6 6 15574012 Chu 645 Spain Male 44 8
## 7 7 15592531 Bartlett 822 <NA> Male 50 7
## 8 8 15656148 Obinna 376 Germany Female 29 4
## 9 9 15792365 He 501 France Male 44 4
## 10 10 15592389 H? 684 France Male NA 2
## # ℹ 9,992 more rows
## # ℹ 8 more variables: Balance <dbl>, NumOfProducts <dbl>, HasCrCard <dbl>,
## # IsActiveMember <dbl>, EstimatedSalary <dbl>, Exited <dbl>,
## # CreditScCat <fct>, ProbabilityGroup <chr>data_grouping2 |>
ggplot(aes(CreditScCat, Proportion, fill=CreditScCat)) +
geom_bar(stat="identity") +
labs(title="Proportion of Churned Customers Vs Credit Score Category",
x="Credit Score Category")
Grouping 3
Grouping of Estimated Salary and Geography, and summarizing over the Balance column.
Similar to earlier, we need to split the Estimated Salary into categories
data_3 <- data
data_3 |>
ggplot(aes(EstimatedSalary)) +
geom_histogram() +
labs(x="Estimated Salary", y="Count")## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
The number of people across each salary class are fairly similar. This should provide us with as unbiased estimation, since the number of individuals in each class are similar.
breaks <- c(0, 50000, 100000, 150000, Inf)
categories <- c("Below 50,000", "50,000 - 100,000", "100,000 - 150,000", "Above 150,000")
data_3$EstimatedSalCat <- cut(data_3$EstimatedSalary, breaks=breaks, labels=categories,include.lowest = TRUE)
print(data_3)## # A tibble: 10,002 × 15
## RowNumber CustomerId Surname CreditScore Geography Gender Age Tenure
## <dbl> <dbl> <chr> <dbl> <chr> <chr> <dbl> <dbl>
## 1 1 15634602 Hargrave 619 France Female 42 2
## 2 2 15647311 Hill 608 Spain Female 41 1
## 3 3 15619304 Onio 502 France Female 42 8
## 4 4 15701354 Boni 699 France Female 39 1
## 5 5 15737888 Mitchell 850 Spain Female 43 2
## 6 6 15574012 Chu 645 Spain Male 44 8
## 7 7 15592531 Bartlett 822 <NA> Male 50 7
## 8 8 15656148 Obinna 376 Germany Female 29 4
## 9 9 15792365 He 501 France Male 44 4
## 10 10 15592389 H? 684 France Male NA 2
## # ℹ 9,992 more rows
## # ℹ 7 more variables: Balance <dbl>, NumOfProducts <dbl>, HasCrCard <dbl>,
## # IsActiveMember <dbl>, EstimatedSalary <dbl>, Exited <dbl>,
## # EstimatedSalCat <fct>data_grouping3 <- data_3 |>
filter(!is.na(Geography)) |>
group_by(EstimatedSalCat, Geography) |>
summarize(Average_Balance = mean(Balance), Count=n())## `summarise()` has grouped output by 'EstimatedSalCat'. You can override using
## the `.groups` argument.print(data_grouping3)## # A tibble: 12 × 4
## # Groups: EstimatedSalCat [4]
## EstimatedSalCat Geography Average_Balance Count
## <fct> <chr> <dbl> <int>
## 1 Below 50,000 France 60695. 1222
## 2 Below 50,000 Germany 118929. 616
## 3 Below 50,000 Spain 60782. 615
## 4 50,000 - 100,000 France 62787. 1297
## 5 50,000 - 100,000 Germany 120527. 617
## 6 50,000 - 100,000 Spain 60359. 624
## 7 100,000 - 150,000 France 62322. 1268
## 8 100,000 - 150,000 Germany 119731. 640
## 9 100,000 - 150,000 Spain 64203. 647
## 10 Above 150,000 France 62619. 1227
## 11 Above 150,000 Germany 119662. 637
## 12 Above 150,000 Spain 61826. 591min_group_grouping3 <- data_grouping3 |>
ungroup() |>
filter(Count == min(Count)) |>
select(EstimatedSalCat, Geography)
min_group_grouping3_1 <- min_group_grouping3[[1, 1]]
min_group_grouping3_2 <- min_group_grouping3[[1, 2]]
print(paste("Minimum Group -(", min_group_grouping3_1, ",", min_group_grouping3_2, ")"))## [1] "Minimum Group -( Above 150,000 , Spain )"data_3$ProbabilityGroup <- ifelse(data_3$EstimatedSalCat == min_group_grouping3_1 & data_3$Geography == min_group_grouping3_2, "LPG3", "")
print(data_3)## # A tibble: 10,002 × 16
## RowNumber CustomerId Surname CreditScore Geography Gender Age Tenure
## <dbl> <dbl> <chr> <dbl> <chr> <chr> <dbl> <dbl>
## 1 1 15634602 Hargrave 619 France Female 42 2
## 2 2 15647311 Hill 608 Spain Female 41 1
## 3 3 15619304 Onio 502 France Female 42 8
## 4 4 15701354 Boni 699 France Female 39 1
## 5 5 15737888 Mitchell 850 Spain Female 43 2
## 6 6 15574012 Chu 645 Spain Male 44 8
## 7 7 15592531 Bartlett 822 <NA> Male 50 7
## 8 8 15656148 Obinna 376 Germany Female 29 4
## 9 9 15792365 He 501 France Male 44 4
## 10 10 15592389 H? 684 France Male NA 2
## # ℹ 9,992 more rows
## # ℹ 8 more variables: Balance <dbl>, NumOfProducts <dbl>, HasCrCard <dbl>,
## # IsActiveMember <dbl>, EstimatedSalary <dbl>, Exited <dbl>,
## # EstimatedSalCat <fct>, ProbabilityGroup <chr>Since, Spain is the country with least number of customers as well as lowest average salary, it makes sense that they have the lowest number of individuals having salary over 150,000.
data_grouping3 |>
ggplot(aes(EstimatedSalCat, Average_Balance, fill=EstimatedSalCat)) +
geom_bar(stat="identity") +
facet_wrap(~ Geography, ncol=1) +
labs(title="Estimated Salary Category Vs Average Balance across Geographies", x="Estimated Salary Category", y="Average Balance")
data_grouping3 |>
ggplot(aes(EstimatedSalCat, Average_Balance, fill=EstimatedSalCat)) +
geom_bar(stat="identity") +
labs(title="Estimated Salary Category Vs Average Balance", x="Estimated Salary Category", y="Average Balance")
From both the visualizations it is clear that, even if the individuals salary is high, the average balance remains the same. So this suggests that higher spending across the individuals with Salary over 150,000. This patterns stays consistent with the people across all three geographies as well.
data_4 <- data
data_4$HasCrCard <- factor(data_4$HasCrCard, levels=c(0, 1))
data_4$Exited <- factor(data_4$Exited, levels=c(0, 1))
data_4 |>
filter(!is.na(data_4$HasCrCard)) |>
group_by(Exited, HasCrCard) |>
summarise(Count = n()) |>
ggplot(aes(Exited, Count, fill=Exited)) +
geom_bar(stat="identity") +
facet_wrap(~ HasCrCard) +
labs(title="Bar Chart of No. of People Exited and Have Credit Card")## `summarise()` has grouped output by 'Exited'. You can override using the
## `.groups` argument.
Least number of individuals belong to ones that have a credit card and have churned. It makes logical sense because having a credit a card is considered a luxuary and often the case is that they are less likely to churn. Hence, it resulted in least number of individuals in this category.