Homework 5
Austin Phillips
10/28/2026
Starter code for German credit scoring
Refer to http://archive.ics.uci.edu/ml/datasets/Statlog+(German+Credit+Data))
for variable description. The response variable is Class
and all others are predictors.
Only run the following code once to install the package
caret. The German credit scoring data in
provided in that package.
if (!requireNamespace("caret", quietly = TRUE)) {
install.packages("caret")
}
if (!requireNamespace("listenv", quietly = TRUE)) {
install.packages("listenv")
}
if (!requireNamespace("pROC", quietly = TRUE)) {
install.packages("pROC")
}Task1: Data Preparation (5pts)
1. Load the caret package and the GermanCredit dataset.
library(caret) #this package contains the german data with its numeric format## Loading required package: ggplot2## Loading required package: latticedata("GermanCredit", package = "caret") # load explicitly from caret
GermanCredit$Class <- as.numeric(GermanCredit$Class == "Good") # now 1 is Good and 0 is Bad
str(GermanCredit)## 'data.frame': 1000 obs. of 62 variables:
## $ Duration : int 6 48 12 42 24 36 24 36 12 30 ...
## $ Amount : int 1169 5951 2096 7882 4870 9055 2835 6948 3059 5234 ...
## $ InstallmentRatePercentage : int 4 2 2 2 3 2 3 2 2 4 ...
## $ ResidenceDuration : int 4 2 3 4 4 4 4 2 4 2 ...
## $ Age : int 67 22 49 45 53 35 53 35 61 28 ...
## $ NumberExistingCredits : int 2 1 1 1 2 1 1 1 1 2 ...
## $ NumberPeopleMaintenance : int 1 1 2 2 2 2 1 1 1 1 ...
## $ Telephone : num 0 1 1 1 1 0 1 0 1 1 ...
## $ ForeignWorker : num 1 1 1 1 1 1 1 1 1 1 ...
## $ Class : num 1 0 1 1 0 1 1 1 1 0 ...
## $ CheckingAccountStatus.lt.0 : num 1 0 0 1 1 0 0 0 0 0 ...
## $ CheckingAccountStatus.0.to.200 : num 0 1 0 0 0 0 0 1 0 1 ...
## $ CheckingAccountStatus.gt.200 : num 0 0 0 0 0 0 0 0 0 0 ...
## $ CheckingAccountStatus.none : num 0 0 1 0 0 1 1 0 1 0 ...
## $ CreditHistory.NoCredit.AllPaid : num 0 0 0 0 0 0 0 0 0 0 ...
## $ CreditHistory.ThisBank.AllPaid : num 0 0 0 0 0 0 0 0 0 0 ...
## $ CreditHistory.PaidDuly : num 0 1 0 1 0 1 1 1 1 0 ...
## $ CreditHistory.Delay : num 0 0 0 0 1 0 0 0 0 0 ...
## $ CreditHistory.Critical : num 1 0 1 0 0 0 0 0 0 1 ...
## $ Purpose.NewCar : num 0 0 0 0 1 0 0 0 0 1 ...
## $ Purpose.UsedCar : num 0 0 0 0 0 0 0 1 0 0 ...
## $ Purpose.Furniture.Equipment : num 0 0 0 1 0 0 1 0 0 0 ...
## $ Purpose.Radio.Television : num 1 1 0 0 0 0 0 0 1 0 ...
## $ Purpose.DomesticAppliance : num 0 0 0 0 0 0 0 0 0 0 ...
## $ Purpose.Repairs : num 0 0 0 0 0 0 0 0 0 0 ...
## $ Purpose.Education : num 0 0 1 0 0 1 0 0 0 0 ...
## $ Purpose.Vacation : num 0 0 0 0 0 0 0 0 0 0 ...
## $ Purpose.Retraining : num 0 0 0 0 0 0 0 0 0 0 ...
## $ Purpose.Business : num 0 0 0 0 0 0 0 0 0 0 ...
## $ Purpose.Other : num 0 0 0 0 0 0 0 0 0 0 ...
## $ SavingsAccountBonds.lt.100 : num 0 1 1 1 1 0 0 1 0 1 ...
## $ SavingsAccountBonds.100.to.500 : num 0 0 0 0 0 0 0 0 0 0 ...
## $ SavingsAccountBonds.500.to.1000 : num 0 0 0 0 0 0 1 0 0 0 ...
## $ SavingsAccountBonds.gt.1000 : num 0 0 0 0 0 0 0 0 1 0 ...
## $ SavingsAccountBonds.Unknown : num 1 0 0 0 0 1 0 0 0 0 ...
## $ EmploymentDuration.lt.1 : num 0 0 0 0 0 0 0 0 0 0 ...
## $ EmploymentDuration.1.to.4 : num 0 1 0 0 1 1 0 1 0 0 ...
## $ EmploymentDuration.4.to.7 : num 0 0 1 1 0 0 0 0 1 0 ...
## $ EmploymentDuration.gt.7 : num 1 0 0 0 0 0 1 0 0 0 ...
## $ EmploymentDuration.Unemployed : num 0 0 0 0 0 0 0 0 0 1 ...
## $ Personal.Male.Divorced.Seperated : num 0 0 0 0 0 0 0 0 1 0 ...
## $ Personal.Female.NotSingle : num 0 1 0 0 0 0 0 0 0 0 ...
## $ Personal.Male.Single : num 1 0 1 1 1 1 1 1 0 0 ...
## $ Personal.Male.Married.Widowed : num 0 0 0 0 0 0 0 0 0 1 ...
## $ Personal.Female.Single : num 0 0 0 0 0 0 0 0 0 0 ...
## $ OtherDebtorsGuarantors.None : num 1 1 1 0 1 1 1 1 1 1 ...
## $ OtherDebtorsGuarantors.CoApplicant : num 0 0 0 0 0 0 0 0 0 0 ...
## $ OtherDebtorsGuarantors.Guarantor : num 0 0 0 1 0 0 0 0 0 0 ...
## $ Property.RealEstate : num 1 1 1 0 0 0 0 0 1 0 ...
## $ Property.Insurance : num 0 0 0 1 0 0 1 0 0 0 ...
## $ Property.CarOther : num 0 0 0 0 0 0 0 1 0 1 ...
## $ Property.Unknown : num 0 0 0 0 1 1 0 0 0 0 ...
## $ OtherInstallmentPlans.Bank : num 0 0 0 0 0 0 0 0 0 0 ...
## $ OtherInstallmentPlans.Stores : num 0 0 0 0 0 0 0 0 0 0 ...
## $ OtherInstallmentPlans.None : num 1 1 1 1 1 1 1 1 1 1 ...
## $ Housing.Rent : num 0 0 0 0 0 0 0 1 0 0 ...
## $ Housing.Own : num 1 1 1 0 0 0 1 0 1 1 ...
## $ Housing.ForFree : num 0 0 0 1 1 1 0 0 0 0 ...
## $ Job.UnemployedUnskilled : num 0 0 0 0 0 0 0 0 0 0 ...
## $ Job.UnskilledResident : num 0 0 1 0 0 1 0 0 1 0 ...
## $ Job.SkilledEmployee : num 1 1 0 1 1 0 1 0 0 0 ...
## $ Job.Management.SelfEmp.HighlyQualified: num 0 0 0 0 0 0 0 1 0 1 ...Your observation: The GermanCredit dataset consists mostly of 0/1 dummy variables derived from categorical features, with only a few genuinely continuous columns (such as Duration, Amount, Age, and InstallmentRatePercentage) alongside the target Class column.
#This is an optional code that drop variables that provide no information in the data
GermanCredit = GermanCredit[,-c(14,19,27,30,35,40,44,45,48,52,55,58,62)] #don't run this code twice!! Think about why.(Running it twice would drop a second, different set of columns because the column positions shift after the first drop. The dropped columns are the constant/redundant dummies.)
2. Explore the dataset to understand its structure.
dim(GermanCredit)## [1] 1000 49sum(is.na(GermanCredit)) # missing values## [1] 0table(GermanCredit$Class) # class balance##
## 0 1
## 300 700round(prop.table(table(GermanCredit$Class)), 3)##
## 0 1
## 0.3 0.7# continuous variables
summary(GermanCredit[, c("Duration", "Amount", "Age",
"InstallmentRatePercentage", "ResidenceDuration",
"NumberExistingCredits", "NumberPeopleMaintenance")])## Duration Amount Age InstallmentRatePercentage
## Min. : 4.0 Min. : 250 Min. :19.00 Min. :1.000
## 1st Qu.:12.0 1st Qu.: 1366 1st Qu.:27.00 1st Qu.:2.000
## Median :18.0 Median : 2320 Median :33.00 Median :3.000
## Mean :20.9 Mean : 3271 Mean :35.55 Mean :2.973
## 3rd Qu.:24.0 3rd Qu.: 3972 3rd Qu.:42.00 3rd Qu.:4.000
## Max. :72.0 Max. :18424 Max. :75.00 Max. :4.000
## ResidenceDuration NumberExistingCredits NumberPeopleMaintenance
## Min. :1.000 Min. :1.000 Min. :1.000
## 1st Qu.:2.000 1st Qu.:1.000 1st Qu.:1.000
## Median :3.000 Median :1.000 Median :1.000
## Mean :2.845 Mean :1.407 Mean :1.155
## 3rd Qu.:4.000 3rd Qu.:2.000 3rd Qu.:1.000
## Max. :4.000 Max. :4.000 Max. :2.000# which columns are 0/1 dummies?
is_dummy <- sapply(GermanCredit[, names(GermanCredit) != "Class"],
function(x) all(x %in% c(0, 1)))
table(is_dummy)## is_dummy
## FALSE TRUE
## 7 41# a quick visual of the main numeric predictors by class
par(mfrow = c(1, 3))
boxplot(Duration ~ Class, data = GermanCredit, main = "Duration by Class")
boxplot(Amount ~ Class, data = GermanCredit, main = "Amount by Class")
boxplot(Age ~ Class, data = GermanCredit, main = "Age by Class")
par(mfrow = c(1, 1))Your observation: There are no missing values in the data. The response variable is a little unbalanced, with about r round(100*mean(GermanCredit\(Class),1)% of customers being Good (1) and r round(100*(1-mean(GermanCredit\)Class)),1)% being Bad (0). r sum(is_dummy) of the predictors are dummy variables (0/1), and the rest are regular numeric variables. The Amount variable is skewed to the right. Customers labeled Bad usually have longer loan durations and slightly higher loan amounts.
Since the dummy variables represent categories, I change them into factors. The other numeric variables stay the same. I keep Class as 0/1 because the logistic regression model uses it to predict the chance of a customer being Good (1).
dummy_names <- names(is_dummy)[is_dummy]
GermanCredit[dummy_names] <- lapply(GermanCredit[dummy_names], factor)
str(GermanCredit[, 1:10])## 'data.frame': 1000 obs. of 10 variables:
## $ Duration : int 6 48 12 42 24 36 24 36 12 30 ...
## $ Amount : int 1169 5951 2096 7882 4870 9055 2835 6948 3059 5234 ...
## $ InstallmentRatePercentage: int 4 2 2 2 3 2 3 2 2 4 ...
## $ ResidenceDuration : int 4 2 3 4 4 4 4 2 4 2 ...
## $ Age : int 67 22 49 45 53 35 53 35 61 28 ...
## $ NumberExistingCredits : int 2 1 1 1 2 1 1 1 1 2 ...
## $ NumberPeopleMaintenance : int 1 1 2 2 2 2 1 1 1 1 ...
## $ Telephone : Factor w/ 2 levels "0","1": 1 2 2 2 2 1 2 1 2 2 ...
## $ ForeignWorker : Factor w/ 2 levels "0","1": 2 2 2 2 2 2 2 2 2 2 ...
## $ Class : num 1 0 1 1 0 1 1 1 1 0 ...3. Split the dataset into training and test set.
Please use the random seed as 2024 for
reproducibility.
set.seed(2024)
n <- nrow(GermanCredit)
train_idx <- sample(seq_len(n), size = round(0.7 * n))
train <- GermanCredit[train_idx, ]
test <- GermanCredit[-train_idx, ]
dim(train); dim(test)## [1] 700 49## [1] 300 49round(prop.table(table(train$Class)), 3)##
## 0 1
## 0.279 0.721round(prop.table(table(test$Class)), 3)##
## 0 1
## 0.35 0.65Your observation: I used a random 70/30 split. The training set has 700 observations and the test set has 300. The proportion of Good customers is similar in both (0.721 in training vs. 0.65 in test), so the split is reasonably representative.
Task 2: Model Fitting (10pts)
1. Fit a logistic regression model using the training set. Please use all variables, but make sure the variable types are right.
full_model <- glm(Class ~ ., data = train, family = binomial)Your observation: The model uses all the predictors. The 0/1 variables are treated as factors, while the other variables stay numeric. Some coefficients might show up as NA if variables overlap too much or basically give the same information. R handles this by automatically removing those variables from the model.
2. Summarize the model and interpret the coefficients (pick at least one coefficient you think important and discuss it in detail).
summary(full_model)##
## Call:
## glm(formula = Class ~ ., family = binomial, data = train)
##
## Coefficients:
## Estimate Std. Error z value Pr(>|z|)
## (Intercept) 9.369e+00 1.829e+00 5.122 3.02e-07 ***
## Duration -2.500e-02 1.159e-02 -2.158 0.030928 *
## Amount -1.866e-04 5.568e-05 -3.352 0.000802 ***
## InstallmentRatePercentage -4.458e-01 1.136e-01 -3.923 8.75e-05 ***
## ResidenceDuration 6.363e-03 1.103e-01 0.058 0.953999
## Age 1.953e-02 1.216e-02 1.606 0.108182
## NumberExistingCredits -1.261e-01 2.450e-01 -0.515 0.606850
## NumberPeopleMaintenance -1.950e-01 3.260e-01 -0.598 0.549618
## Telephone1 -3.987e-01 2.603e-01 -1.532 0.125566
## ForeignWorker1 -1.476e+00 7.829e-01 -1.885 0.059450 .
## CheckingAccountStatus.lt.01 -1.813e+00 2.948e-01 -6.151 7.69e-10 ***
## CheckingAccountStatus.0.to.2001 -1.419e+00 2.957e-01 -4.800 1.59e-06 ***
## CheckingAccountStatus.gt.2001 -2.207e-01 5.404e-01 -0.408 0.682962
## CreditHistory.NoCredit.AllPaid1 -1.020e+00 5.507e-01 -1.851 0.064107 .
## CreditHistory.ThisBank.AllPaid1 -1.717e+00 5.911e-01 -2.905 0.003677 **
## CreditHistory.PaidDuly1 -7.613e-01 3.259e-01 -2.336 0.019502 *
## CreditHistory.Delay1 -1.106e+00 4.157e-01 -2.660 0.007815 **
## Purpose.NewCar1 -1.907e+00 1.065e+00 -1.790 0.073450 .
## Purpose.UsedCar1 -2.447e-01 1.082e+00 -0.226 0.821017
## Purpose.Furniture.Equipment1 -9.006e-01 1.066e+00 -0.845 0.398330
## Purpose.Radio.Television1 -1.076e+00 1.070e+00 -1.006 0.314601
## Purpose.DomesticAppliance1 -1.640e+00 1.390e+00 -1.180 0.238012
## Purpose.Repairs1 -1.620e+00 1.211e+00 -1.338 0.180844
## Purpose.Education1 -2.242e+00 1.161e+00 -1.932 0.053400 .
## Purpose.Retraining1 -6.540e-01 1.664e+00 -0.393 0.694309
## Purpose.Business1 -7.351e-01 1.094e+00 -0.672 0.501698
## SavingsAccountBonds.lt.1001 -1.341e+00 3.467e-01 -3.868 0.000110 ***
## SavingsAccountBonds.100.to.5001 -1.179e+00 4.488e-01 -2.627 0.008615 **
## SavingsAccountBonds.500.to.10001 -1.064e+00 5.682e-01 -1.873 0.061102 .
## SavingsAccountBonds.gt.10001 -2.395e-01 6.545e-01 -0.366 0.714428
## EmploymentDuration.lt.11 3.040e-01 5.495e-01 0.553 0.580133
## EmploymentDuration.1.to.41 4.008e-01 5.289e-01 0.758 0.448574
## EmploymentDuration.4.to.71 8.251e-01 5.670e-01 1.455 0.145643
## EmploymentDuration.gt.71 3.905e-01 5.359e-01 0.729 0.466142
## Personal.Male.Divorced.Seperated1 -1.529e-01 5.695e-01 -0.268 0.788356
## Personal.Female.NotSingle1 -9.258e-02 3.755e-01 -0.247 0.805267
## Personal.Male.Single1 3.861e-01 3.809e-01 1.014 0.310692
## OtherDebtorsGuarantors.None1 -1.039e+00 5.761e-01 -1.803 0.071362 .
## OtherDebtorsGuarantors.CoApplicant1 -1.635e+00 7.330e-01 -2.230 0.025730 *
## Property.RealEstate1 7.315e-01 5.452e-01 1.342 0.179726
## Property.Insurance1 2.724e-01 5.293e-01 0.515 0.606870
## Property.CarOther1 5.846e-01 5.159e-01 1.133 0.257157
## OtherInstallmentPlans.Bank1 -1.058e+00 2.980e-01 -3.551 0.000383 ***
## OtherInstallmentPlans.Stores1 -6.249e-01 5.052e-01 -1.237 0.216067
## Housing.Rent1 -1.006e+00 6.242e-01 -1.612 0.106903
## Housing.Own1 -2.691e-01 6.022e-01 -0.447 0.654919
## Job.UnemployedUnskilled1 1.787e+00 1.032e+00 1.732 0.083320 .
## Job.UnskilledResident1 1.094e-01 4.442e-01 0.246 0.805560
## Job.SkilledEmployee1 5.852e-02 3.652e-01 0.160 0.872710
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## (Dispersion parameter for binomial family taken to be 1)
##
## Null deviance: 828.24 on 699 degrees of freedom
## Residual deviance: 576.87 on 651 degrees of freedom
## AIC: 674.87
##
## Number of Fisher Scoring iterations: 5# odds ratios for the numeric predictors
b <- coef(full_model)
round(exp(b[c("Duration", "Amount", "Age", "InstallmentRatePercentage")]), 4)## Duration Amount Age
## 0.9753 0.9998 1.0197
## InstallmentRatePercentage
## 0.6403# the most significant coefficients
coefs <- summary(full_model)$coefficients
head(coefs[order(coefs[, 4]), ], 8)## Estimate Std. Error z value
## CheckingAccountStatus.lt.01 -1.8130627964 2.947520e-01 -6.151146
## (Intercept) 9.3685655723 1.829107e+00 5.121934
## CheckingAccountStatus.0.to.2001 -1.4192679315 2.956710e-01 -4.800159
## InstallmentRatePercentage -0.4457622977 1.136343e-01 -3.922781
## SavingsAccountBonds.lt.1001 -1.3411859189 3.467167e-01 -3.868248
## OtherInstallmentPlans.Bank1 -1.0581408665 2.979670e-01 -3.551201
## Amount -0.0001866305 5.567637e-05 -3.352059
## CreditHistory.ThisBank.AllPaid1 -1.7167869535 5.910522e-01 -2.904628
## Pr(>|z|)
## CheckingAccountStatus.lt.01 7.692487e-10
## (Intercept) 3.024174e-07
## CheckingAccountStatus.0.to.2001 1.585399e-06
## InstallmentRatePercentage 8.753273e-05
## SavingsAccountBonds.lt.1001 1.096203e-04
## OtherInstallmentPlans.Bank1 3.834775e-04
## Amount 8.021301e-04
## CreditHistory.ThisBank.AllPaid1 3.676893e-03Your observation: The Duration coefficient shows that longer loans are more likely to be linked to Bad customers. This makes sense because the bank is taking a risk for a longer time. The InstallmentRatePercentage also shows that higher installment rates lower the chances of being a Good customer. The table shows that checking account status and credit history are some of the most important predictors. Some other variables are not very important and may not be needed in the model.
Task 3: Find Optimal Probability Cut-off, with weight_FN = 1 and weight_FP = 1. (10pts)
1. Use the training set to obtain predicted probabilities.
train_prob <- predict(full_model, newdata = train, type = "response")
summary(train_prob)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.02777 0.53594 0.81218 0.72143 0.94126 0.99935hist(train_prob, breaks = 30, main = "Predicted P(Good), training set", xlab = "Probability")
Your observation: The predicted probabilities (of being Good) range from 0.028 to 0.999 with a mean of 0.721. Most are above 0.5, reflecting the 70% Good base rate.
2. Find the optimal probability cut-off point using the MR (misclassification rate) or equivalently the equal-weight cost.
A prediction is “Good” (1) when the predicted probability exceeds the cut-off. I define the cost with explicit weights:
w_FN: cost of predicting Bad when the customer is actually Good (actual 1, predicted 0)w_FP: cost of predicting Good when the customer is actually Bad (actual 0, predicted 1)
cost_fn <- function(actual, prob, cutoff, w_FN = 1, w_FP = 1) {
pred <- as.numeric(prob > cutoff)
FN <- sum(actual == 1 & pred == 0)
FP <- sum(actual == 0 & pred == 1)
(w_FN * FN + w_FP * FP) / length(actual) # average cost
}
cutoffs <- seq(0.01, 0.99, by = 0.01)
cost_equal <- sapply(cutoffs, function(c) cost_fn(train$Class, train_prob, c, 1, 1))
best_cut_equal <- cutoffs[which.min(cost_equal)]
best_cut_equal## [1] 0.49min(cost_equal)## [1] 0.19plot(cutoffs, cost_equal, type = "l", xlab = "Cut-off", ylab = "Misclassification rate",
main = "Equal weights (FN = 1, FP = 1)")
abline(v = best_cut_equal, col = "red", lty = 2)
Your observation: With equal weights, the cost equals the misclassification rate, and it is minimized at a cut-off of 0.49 (training MR = 0.19). The curve is fairly flat near the minimum, so cut-offs close to this value perform almost equally well.
Task 4: Model Evaluation (10pts)
1. Using the optimal probability cut-off point obtained in 3.2, generate confusion matrix and obtain MR for the training set.
train_pred <- as.numeric(train_prob > best_cut_equal)
cm_train <- table(Actual = train$Class, Predicted = train_pred)
cm_train## Predicted
## Actual 0 1
## 0 104 91
## 1 42 463MR_train <- mean(train_pred != train$Class)
MR_train## [1] 0.19Your observation: The training MR is 0.19. The confusion matrix shows how many Good and Bad customers are correctly and incorrectly classified.
2. Using the optimal probability cut-off point obtained in 3.2, generate the ROC curve and calculate the AUC for the training set.
library(pROC)## Type 'citation("pROC")' for a citation.##
## Attaching package: 'pROC'## The following objects are masked from 'package:stats':
##
## cov, smooth, varroc_train <- roc(train$Class, train_prob, quiet = TRUE)
auc_train <- auc(roc_train)
plot(roc_train, main = "ROC curve, training set", print.auc = TRUE)
# mark the chosen cut-off
points(1 - mean(train_pred[train$Class == 0] == 0),
mean(train_pred[train$Class == 1] == 1), col = "red", pch = 19, cex = 1.3)
auc_train## Area under the curve: 0.855Your observation: The training AUC is 0.855. The red point marks the operating point (sensitivity vs. 1 - specificity) at the chosen cut-off. The ROC curve itself does not depend on the cut-off; the cut-off only picks a point on it.
3. Using the same cut-off point, generate confusion matrix and obtain MR for the test set.
test_prob <- predict(full_model, newdata = test, type = "response")
test_pred <- as.numeric(test_prob > best_cut_equal)
cm_test <- table(Actual = test$Class, Predicted = test_pred)
cm_test## Predicted
## Actual 0 1
## 0 48 57
## 1 20 175MR_test <- mean(test_pred != test$Class)
MR_test## [1] 0.2566667Your observation: The test MR is r round(MR_test, 4), compared to r round(MR_train, 4) for the training set. The test error is higher, which means the model may be overfitting a little. This could be because the model uses a lot of predictors.
4. Using the same cut-off point, generate the ROC curve and calculate the AUC for the test set.
roc_test <- roc(test$Class, test_prob, quiet = TRUE)
auc_test <- auc(roc_test)
plot(roc_test, main = "ROC curve, test set", print.auc = TRUE)
points(1 - mean(test_pred[test$Class == 0] == 0),
mean(test_pred[test$Class == 1] == 1), col = "red", pch = 19, cex = 1.3)
auc_test## Area under the curve: 0.7545Your observation: The test AUC is r round(as.numeric(auc_test), 4), compared to r round(as.numeric(auc_train), 4) for the training set. This shows how well the model works on new data. The model is still better than random guessing at telling Good customers from Bad ones (AUC = 0.5).
Task 5: Using different weights (10pts)
Now, let’s assume “It is worse to class a customer as good when they are bad (weight = 5), than it is to class a customer as bad when they are good (weight = 1).” Please figure out which weight should be 5 and which weight should be 1. Then define your cost function accordingly!
Classifying a customer as Good when they are actually Bad is a false positive here (positive = Good), so weight_FP = 5. Classifying a Good customer as Bad is a false negative, so weight_FN = 1. Intuitively, lending to a customer who defaults is much more costly than turning away a good customer.
1. Obtain optimal probability cut-off point again, with the new weights.
cost_w <- sapply(cutoffs, function(c) cost_fn(train$Class, train_prob, c, w_FN = 1, w_FP = 5))
best_cut_w <- cutoffs[which.min(cost_w)]
best_cut_w## [1] 0.81min(cost_w)## [1] 0.3971429plot(cutoffs, cost_w, type = "l", xlab = "Cut-off", ylab = "Average cost",
main = "Weights: FN = 1, FP = 5")
abline(v = best_cut_w, col = "red", lty = 2)
Your observation: With the new weights the optimal cut-off is 0.81, much higher than the 0.49 found with equal weights. This matches theory: with a cost ratio of 5:1, the cost-minimizing rule predicts Good only when P(Good) > 5/(5+1) = 0.833. The model now requires strong evidence before approving a customer.
2. Obtain the confusion matrix and MR for the training set.
train_pred_w <- as.numeric(train_prob > best_cut_w)
cm_train_w <- table(Actual = train$Class, Predicted = train_pred_w)
cm_train_w## Predicted
## Actual 0 1
## 0 174 21
## 1 173 332MR_train_w <- mean(train_pred_w != train$Class)
MR_train_w## [1] 0.2771429cost_fn(train$Class, train_prob, best_cut_w, 1, 5) # weighted cost## [1] 0.3971429Your observation: The training MR is r round(MR_train_w, 4), which is higher than the r round(MR_train, 4) with equal weights. This makes sense because the model is now focusing more on catching Bad customers. It makes fewer mistakes with Bad customers but also incorrectly labels more Good customers as Bad.
3. Obtain the confusion matrix and MR for the test set.
test_pred_w <- as.numeric(test_prob > best_cut_w)
cm_test_w <- table(Actual = test$Class, Predicted = test_pred_w)
cm_test_w## Predicted
## Actual 0 1
## 0 77 28
## 1 74 121MR_test_w <- mean(test_pred_w != test$Class)
MR_test_w## [1] 0.34cost_fn(test$Class, test_prob, best_cut_w, 1, 5) # weighted cost on test## [1] 0.7133333cost_fn(test$Class, test_prob, best_cut_equal, 1, 5) # weighted cost if we had kept the old cut-off## [1] 1.016667Your observation: The test MR is r round(MR_test_w, 4). Even though the overall error is higher, the new cut-off does a better job of lowering the cost of mistakes. With the 5:1 cost setup, the new cut-off is cheaper than the old one.
Task 6: Conclusion (5pts)
Summarize your findings, including the optimal probability cut-off, MR and AUC for both training and testing data. Discuss what you observed and what you will do to improve the model further.
summary_tbl <- data.frame(
Setting = c("Equal weights (1:1)", "Equal weights (1:1)", "Weights FN=1, FP=5", "Weights FN=1, FP=5"),
Data = c("Training", "Test", "Training", "Test"),
Cutoff = c(best_cut_equal, best_cut_equal, best_cut_w, best_cut_w),
MR = round(c(MR_train, MR_test, MR_train_w, MR_test_w), 4),
AUC = round(c(as.numeric(auc_train), as.numeric(auc_test),
as.numeric(auc_train), as.numeric(auc_test)), 4)
)
summary_tbl## Setting Data Cutoff MR AUC
## 1 Equal weights (1:1) Training 0.49 0.1900 0.8550
## 2 Equal weights (1:1) Test 0.49 0.2567 0.7545
## 3 Weights FN=1, FP=5 Training 0.81 0.2771 0.8550
## 4 Weights FN=1, FP=5 Test 0.81 0.3400 0.7545Findings. I used logistic regression with all predictors and split the data into 70% training and 30% testing. With equal weights, the cut-off was r best_cut_equal, with training MR of r round(MR_train, 4) and test MR of r round(MR_test, 4). When Bad loans were made five times more costly, the cut-off increased to r best_cut_w, and the error rate went up. This is because the model became more careful about labeling customers as Good.
Observations. The model did a little worse on the test data, which could mean some overfitting. Checking account status, credit history, loan duration, and installment rate were the biggest factors. The best cut-off depends on how costly bad loans are.
Improvements. (1) Remove variables that are not very useful. (2) est the model with different data splits. (3) Try other models like decision trees or random forests. (4) Find better ways to handle the unbalanced data. (5) Use the bank’s actual costs instead of assuming a 5:1 cost ratio.