Final Assignment
Eric Cantu
2026-08-02
library(tidyverse)## Warning: package 'ggplot2' was built under R version 4.5.2## Warning: package 'dplyr' was built under R version 4.5.2## ── Attaching core tidyverse packages ──────────────────────── tidyverse 2.0.0 ──
## ✔ dplyr 1.1.4 ✔ readr 2.1.5
## ✔ forcats 1.0.0 ✔ stringr 1.5.2
## ✔ ggplot2 4.0.1 ✔ tibble 3.3.0
## ✔ lubridate 1.9.4 ✔ tidyr 1.3.1
## ✔ purrr 1.1.0
## ── 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(caret)## Warning: package 'caret' was built under R version 4.5.3## Loading required package: lattice
##
## Attaching package: 'caret'
##
## The following object is masked from 'package:purrr':
##
## liftlibrary(DT)## Warning: package 'DT' was built under R version 4.5.3set.seed(12345)library(readr)
fund <- read_csv("school/fundraising.csv")## Rows: 3000 Columns: 21
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (7): zipconvert2, zipconvert3, zipconvert4, zipconvert5, homeowner, fem...
## dbl (14): num_child, income, wealth, home_value, med_fam_inc, avg_fam_inc, p...
##
## ℹ 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.View(fund)
future_fund <- read_csv("school/future_fundraising.csv")## Rows: 120 Columns: 20
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (6): zipconvert2, zipconvert3, zipconvert4, zipconvert5, homeowner, female
## dbl (14): num_child, income, wealth, home_value, med_fam_inc, avg_fam_inc, p...
##
## ℹ 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.View(future_fund)#response to a factor
fund <- fund %>%
mutate(
target = factor(
target,
levels = c("Donor", "No Donor"),
labels = c("Donor", "No_Donor")
)
)
table(fund$target)##
## Donor No_Donor
## 1499 1501prop.table(table(fund$target))##
## Donor No_Donor
## 0.4996667 0.5003333round(
prop.table(table(fund$target)) * 100,
2
)##
## Donor No_Donor
## 49.97 50.03#split the data to 80/20
set.seed(12345)
train_index <- createDataPartition(
fund$target,
p = 0.80,
list = FALSE
)
fund_train <- fund[train_index, ]
fund_validation <- fund[-train_index, ]dim(fund_train)## [1] 2401 21dim(fund_validation)## [1] 599 21table(fund_train$target)##
## Donor No_Donor
## 1200 1201table(fund_validation$target)##
## Donor No_Donor
## 299 300round(
prop.table(table(fund_train$target)) * 100,
2
)##
## Donor No_Donor
## 49.98 50.02round(
prop.table(table(fund_validation$target)) * 100,
2
)##
## Donor No_Donor
## 49.92 50.08train_x <- fund_train %>%
select(-target)
train_y <- fund_train$target
validation_x <- fund_validation %>%
select(-target)
validation_y <- fund_validation$target
future_x <- future_fund
cv_control <- trainControl(
method = "cv",
number = 10,
classProbs = TRUE,
summaryFunction = twoClassSummary,
savePredictions = "final"
)#look at data, check variables and check for any missing values
summary(fund)## zipconvert2 zipconvert3 zipconvert4 zipconvert5
## Length:3000 Length:3000 Length:3000 Length:3000
## Class :character Class :character Class :character Class :character
## Mode :character Mode :character Mode :character Mode :character
##
##
##
## homeowner num_child income female
## Length:3000 Min. :1.000 Min. :1.000 Length:3000
## Class :character 1st Qu.:1.000 1st Qu.:3.000 Class :character
## Mode :character Median :1.000 Median :4.000 Mode :character
## Mean :1.069 Mean :3.899
## 3rd Qu.:1.000 3rd Qu.:5.000
## Max. :5.000 Max. :7.000
## wealth home_value med_fam_inc avg_fam_inc
## Min. :0.000 Min. : 0.0 Min. : 0.0 Min. : 0.0
## 1st Qu.:5.000 1st Qu.: 554.8 1st Qu.: 278.0 1st Qu.: 318.0
## Median :8.000 Median : 816.5 Median : 355.0 Median : 396.0
## Mean :6.396 Mean :1143.3 Mean : 388.4 Mean : 432.3
## 3rd Qu.:8.000 3rd Qu.:1341.2 3rd Qu.: 465.0 3rd Qu.: 516.0
## Max. :9.000 Max. :5945.0 Max. :1500.0 Max. :1331.0
## pct_lt15k num_prom lifetime_gifts largest_gift
## Min. : 0.00 Min. : 11.00 Min. : 15.0 Min. : 5.00
## 1st Qu.: 5.00 1st Qu.: 29.00 1st Qu.: 45.0 1st Qu.: 10.00
## Median :12.00 Median : 48.00 Median : 81.0 Median : 15.00
## Mean :14.71 Mean : 49.14 Mean : 110.7 Mean : 16.65
## 3rd Qu.:21.00 3rd Qu.: 65.00 3rd Qu.: 135.0 3rd Qu.: 20.00
## Max. :90.00 Max. :157.00 Max. :5674.9 Max. :1000.00
## last_gift months_since_donate time_lag avg_gift
## Min. : 0.00 Min. :17.00 Min. : 0.000 Min. : 2.139
## 1st Qu.: 7.00 1st Qu.:29.00 1st Qu.: 3.000 1st Qu.: 6.333
## Median : 10.00 Median :31.00 Median : 5.000 Median : 9.000
## Mean : 13.48 Mean :31.13 Mean : 6.876 Mean : 10.669
## 3rd Qu.: 16.00 3rd Qu.:34.00 3rd Qu.: 9.000 3rd Qu.: 12.800
## Max. :219.00 Max. :37.00 Max. :77.000 Max. :122.167
## target
## Donor :1499
## No_Donor:1501
##
##
##
## glimpse(fund)## Rows: 3,000
## Columns: 21
## $ zipconvert2 <chr> "Yes", "No", "No", "No", "No", "No", "No", "Yes", …
## $ zipconvert3 <chr> "No", "No", "No", "Yes", "Yes", "No", "No", "No", …
## $ zipconvert4 <chr> "No", "No", "No", "No", "No", "No", "Yes", "No", "…
## $ zipconvert5 <chr> "No", "Yes", "Yes", "No", "No", "Yes", "No", "No",…
## $ homeowner <chr> "Yes", "No", "Yes", "Yes", "Yes", "Yes", "Yes", "Y…
## $ num_child <dbl> 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,…
## $ income <dbl> 1, 5, 3, 4, 4, 4, 4, 4, 4, 1, 4, 5, 2, 3, 4, 4, 2,…
## $ female <chr> "No", "Yes", "No", "No", "Yes", "Yes", "No", "Yes"…
## $ wealth <dbl> 7, 8, 4, 8, 8, 8, 5, 8, 8, 5, 5, 8, 8, 5, 6, 9, 7,…
## $ home_value <dbl> 698, 828, 1471, 547, 482, 857, 505, 1438, 1316, 42…
## $ med_fam_inc <dbl> 422, 358, 484, 386, 242, 450, 333, 458, 541, 203, …
## $ avg_fam_inc <dbl> 463, 376, 546, 432, 275, 498, 388, 533, 575, 271, …
## $ pct_lt15k <dbl> 4, 13, 4, 7, 28, 5, 16, 8, 11, 39, 6, 8, 5, 3, 13,…
## $ num_prom <dbl> 46, 32, 94, 20, 38, 47, 51, 21, 66, 73, 59, 25, 27…
## $ lifetime_gifts <dbl> 94, 30, 177, 23, 73, 139, 63, 26, 108, 161, 84, 40…
## $ largest_gift <dbl> 12, 10, 10, 11, 10, 20, 15, 16, 12, 6, 5, 10, 20, …
## $ last_gift <dbl> 12, 5, 8, 11, 10, 20, 10, 16, 7, 3, 3, 10, 20, 7, …
## $ months_since_donate <dbl> 34, 29, 30, 30, 31, 37, 37, 30, 31, 32, 30, 32, 37…
## $ time_lag <dbl> 6, 7, 3, 6, 3, 3, 8, 6, 1, 7, 12, 2, 7, 1, 10, 3, …
## $ avg_gift <dbl> 9.400000, 4.285714, 7.080000, 7.666667, 7.300000, …
## $ target <fct> Donor, Donor, No_Donor, No_Donor, Donor, Donor, Do…str(fund)## tibble [3,000 × 21] (S3: tbl_df/tbl/data.frame)
## $ zipconvert2 : chr [1:3000] "Yes" "No" "No" "No" ...
## $ zipconvert3 : chr [1:3000] "No" "No" "No" "Yes" ...
## $ zipconvert4 : chr [1:3000] "No" "No" "No" "No" ...
## $ zipconvert5 : chr [1:3000] "No" "Yes" "Yes" "No" ...
## $ homeowner : chr [1:3000] "Yes" "No" "Yes" "Yes" ...
## $ num_child : num [1:3000] 1 2 1 1 1 1 1 1 1 1 ...
## $ income : num [1:3000] 1 5 3 4 4 4 4 4 4 1 ...
## $ female : chr [1:3000] "No" "Yes" "No" "No" ...
## $ wealth : num [1:3000] 7 8 4 8 8 8 5 8 8 5 ...
## $ home_value : num [1:3000] 698 828 1471 547 482 ...
## $ med_fam_inc : num [1:3000] 422 358 484 386 242 450 333 458 541 203 ...
## $ avg_fam_inc : num [1:3000] 463 376 546 432 275 498 388 533 575 271 ...
## $ pct_lt15k : num [1:3000] 4 13 4 7 28 5 16 8 11 39 ...
## $ num_prom : num [1:3000] 46 32 94 20 38 47 51 21 66 73 ...
## $ lifetime_gifts : num [1:3000] 94 30 177 23 73 139 63 26 108 161 ...
## $ largest_gift : num [1:3000] 12 10 10 11 10 20 15 16 12 6 ...
## $ last_gift : num [1:3000] 12 5 8 11 10 20 10 16 7 3 ...
## $ months_since_donate: num [1:3000] 34 29 30 30 31 37 37 30 31 32 ...
## $ time_lag : num [1:3000] 6 7 3 6 3 3 8 6 1 7 ...
## $ avg_gift : num [1:3000] 9.4 4.29 7.08 7.67 7.3 ...
## $ target : Factor w/ 2 levels "Donor","No_Donor": 1 1 2 2 1 1 1 2 1 1 ...missing_summary <- sapply(fund, function(x) sum(is.na(x)))
missing_summary## zipconvert2 zipconvert3 zipconvert4 zipconvert5
## 0 0 0 0
## homeowner num_child income female
## 0 0 0 0
## wealth home_value med_fam_inc avg_fam_inc
## 0 0 0 0
## pct_lt15k num_prom lifetime_gifts largest_gift
## 0 0 0 0
## last_gift months_since_donate time_lag avg_gift
## 0 0 0 0
## target
## 0table(fund$target)##
## Donor No_Donor
## 1499 1501prop.table(table(fund$target))##
## Donor No_Donor
## 0.4996667 0.5003333numeric_vars <- fund %>%
select(where(is.numeric))
ncol(numeric_vars)## [1] 14numeric_vars %>%
pivot_longer(
everything(),
names_to = "Variable",
values_to = "Value"
) %>%
ggplot(aes(Value)) +
geom_histogram(
bins = 30,
fill = "steelblue",
color = "white"
) +
facet_wrap(~Variable, scales = "free") +
theme_minimal()
fund %>%
pivot_longer(
cols = where(is.numeric),
names_to = "Variable",
values_to = "Value"
) %>%
ggplot(aes(target, Value, fill = target)) +
geom_boxplot(alpha = .8) +
facet_wrap(~Variable, scales = "free") +
theme_minimal() +
theme(
legend.position = "none"
)
cor_matrix <- cor(
numeric_vars,
use = "complete.obs"
)
round(cor_matrix, 2)## num_child income wealth home_value med_fam_inc avg_fam_inc
## num_child 1.00 0.09 0.06 -0.01 0.05 0.05
## income 0.09 1.00 0.21 0.29 0.37 0.38
## wealth 0.06 0.21 1.00 0.26 0.38 0.39
## home_value -0.01 0.29 0.26 1.00 0.74 0.75
## med_fam_inc 0.05 0.37 0.38 0.74 1.00 0.97
## avg_fam_inc 0.05 0.38 0.39 0.75 0.97 1.00
## pct_lt15k -0.03 -0.28 -0.38 -0.40 -0.67 -0.68
## num_prom -0.09 -0.07 -0.41 -0.06 -0.05 -0.06
## lifetime_gifts -0.05 -0.02 -0.23 -0.02 -0.04 -0.04
## largest_gift -0.02 0.03 -0.03 0.06 0.05 0.04
## last_gift -0.01 0.11 0.05 0.16 0.14 0.13
## months_since_donate -0.01 0.08 0.03 0.02 0.03 0.03
## time_lag -0.01 0.00 -0.07 0.00 0.02 0.02
## avg_gift -0.02 0.12 0.09 0.17 0.14 0.13
## pct_lt15k num_prom lifetime_gifts largest_gift last_gift
## num_child -0.03 -0.09 -0.05 -0.02 -0.01
## income -0.28 -0.07 -0.02 0.03 0.11
## wealth -0.38 -0.41 -0.23 -0.03 0.05
## home_value -0.40 -0.06 -0.02 0.06 0.16
## med_fam_inc -0.67 -0.05 -0.04 0.05 0.14
## avg_fam_inc -0.68 -0.06 -0.04 0.04 0.13
## pct_lt15k 1.00 0.04 0.06 -0.01 -0.06
## num_prom 0.04 1.00 0.54 0.11 -0.06
## lifetime_gifts 0.06 0.54 1.00 0.51 0.20
## largest_gift -0.01 0.11 0.51 1.00 0.45
## last_gift -0.06 -0.06 0.20 0.45 1.00
## months_since_donate -0.01 -0.28 -0.14 0.02 0.19
## time_lag -0.02 0.12 0.04 0.04 0.08
## avg_gift -0.06 -0.15 0.18 0.47 0.87
## months_since_donate time_lag avg_gift
## num_child -0.01 -0.01 -0.02
## income 0.08 0.00 0.12
## wealth 0.03 -0.07 0.09
## home_value 0.02 0.00 0.17
## med_fam_inc 0.03 0.02 0.14
## avg_fam_inc 0.03 0.02 0.13
## pct_lt15k -0.01 -0.02 -0.06
## num_prom -0.28 0.12 -0.15
## lifetime_gifts -0.14 0.04 0.18
## largest_gift 0.02 0.04 0.47
## last_gift 0.19 0.08 0.87
## months_since_donate 1.00 0.02 0.19
## time_lag 0.02 1.00 0.07
## avg_gift 0.19 0.07 1.00library(corrplot)## Warning: package 'corrplot' was built under R version 4.5.2## corrplot 0.95 loadedcorrplot(
cor_matrix,
method = "color",
tl.cex = .7,
number.cex = .6
)
fund %>%
group_by(target) %>%
summarise(
across(
where(is.numeric),
mean,
na.rm = TRUE
)
)## Warning: There was 1 warning in `summarise()`.
## ℹ In argument: `across(where(is.numeric), mean, na.rm = TRUE)`.
## ℹ In group 1: `target = Donor`.
## Caused by warning:
## ! The `...` argument of `across()` is deprecated as of dplyr 1.1.0.
## Supply arguments directly to `.fns` through an anonymous function instead.
##
## # Previously
## across(a:b, mean, na.rm = TRUE)
##
## # Now
## across(a:b, \(x) mean(x, na.rm = TRUE))## # A tibble: 2 × 15
## target num_child income wealth home_value med_fam_inc avg_fam_inc pct_lt15k
## <fct> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 Donor 1.05 3.96 6.40 1164. 390. 433. 14.7
## 2 No_Donor 1.08 3.84 6.39 1123. 387. 432. 14.7
## # ℹ 7 more variables: num_prom <dbl>, lifetime_gifts <dbl>, largest_gift <dbl>,
## # last_gift <dbl>, months_since_donate <dbl>, time_lag <dbl>, avg_gift <dbl>#Overall Distribution of the Predictors The first figure shows the distribution of every numerical predictor.
Several important patterns emerge immediately. Most numerical variables are positively (right) skewed, especially: avg_gift largest_gift last_gift lifetime_gifts home_value
This indicates that most individuals donate relatively small amounts while only a few donors contribute very large gifts. Likewise, neighborhood financial variables such as
home_value avg_fam_inc med_fam_inc
also display long right tails, suggesting variability in socioeconomic status across households. Variables such as: income wealth
are ordinal rather than continuous and therefore naturally appear clustered into categories. The histogram of months_since_donate suggests that many donors have not contributed recently, while num_prom indicates a wide range in the number of promotional mailings previously received.
Mean Comparison
The summary statistics reinforce these visual observations.
Variable Donor No Donor Interpretation Income 3.96 3.84 Donors have slightly higher income levels. Wealth 6.40 6.39 Nearly identical distributions. Home Value 1163.8 1122.7 Donors tend to live in somewhat higher-value neighborhoods. Median Family Income 389.8 387.0 Very small difference. Average Family Income 432.8 431.8 Nearly identical. Promotions Received 50.7 47.6 Donors received more promotions. Lifetime Gifts 113.7 107.8 Donors have contributed more historically. Largest Gift 16.25 17.05 Very similar averages. Last Gift 12.67 14.30 Slight difference between groups.
The differences in historical donation variables are more pronounced than those observed for demographic variables, suggesting that behavioral variables are likely to provide stronger predictive information.
table(fund_train$target, useNA = "ifany")##
## Donor No_Donor
## 1200 1201levels(fund_train$target)## [1] "Donor" "No_Donor"fund <- fund %>%
mutate(
target = str_trim(as.character(target)),
target = case_when(
target %in% c("Donor", "Yes") ~ "Donor",
target %in% c("No Donor", "No_Donor", "No") ~ "No_Donor",
TRUE ~ NA_character_
),
target = factor(
target,
levels = c("Donor", "No_Donor")
)
)
table(fund$target, useNA = "ifany")##
## Donor No_Donor
## 1499 1501set.seed(12345)
train_index <- createDataPartition(
fund$target,
p = 0.80,
list = FALSE
)
fund_train <- fund[train_index, ]
fund_validation <- fund[-train_index, ]# Identify numeric and categorical predictors from the training set
numeric_names <- fund_train %>%
select(-target) %>%
select(where(is.numeric)) %>%
names()
categorical_names <- fund_train %>%
select(-target) %>%
select(where(is.character)) %>%
names()
numeric_names## [1] "num_child" "income" "wealth"
## [4] "home_value" "med_fam_inc" "avg_fam_inc"
## [7] "pct_lt15k" "num_prom" "lifetime_gifts"
## [10] "largest_gift" "last_gift" "months_since_donate"
## [13] "time_lag" "avg_gift"categorical_names## [1] "zipconvert2" "zipconvert3" "zipconvert4" "zipconvert5" "homeowner"
## [6] "female"wilcox_results <- lapply(
numeric_names,
function(x) {
test_result <- wilcox.test(
fund_train[[x]] ~ fund_train$target,
exact = FALSE
)
donor_values <- fund_train %>%
filter(target == "Donor") %>%
pull(all_of(x))
non_donor_values <- fund_train %>%
filter(target == "No_Donor") %>%
pull(all_of(x))
data.frame(
Variable = x,
Donor_Mean = mean(
donor_values,
na.rm = TRUE
),
No_Donor_Mean = mean(
non_donor_values,
na.rm = TRUE
),
Donor_Median = median(
donor_values,
na.rm = TRUE
),
No_Donor_Median = median(
non_donor_values,
na.rm = TRUE
),
W_Statistic = unname(
test_result$statistic
),
P_Value = test_result$p.value
)
}
) %>%
bind_rows() %>%
mutate(
Adjusted_P_Value = p.adjust(
P_Value,
method = "BH"
),
Significant = ifelse(
Adjusted_P_Value < 0.05,
"Yes",
"No"
)
) %>%
arrange(Adjusted_P_Value)
wilcox_results## Variable Donor_Mean No_Donor_Mean Donor_Median No_Donor_Median
## 1 months_since_donate 30.585833 31.797669 31.00000 31.000000
## 2 last_gift 12.750000 14.393838 10.00000 12.000000
## 3 avg_gift 10.191256 11.247593 8.60119 9.818182
## 4 largest_gift 15.757500 17.141965 13.00000 15.000000
## 5 num_prom 50.310833 47.180683 50.00000 44.000000
## 6 income 4.005000 3.832639 4.00000 4.000000
## 7 lifetime_gifts 113.485008 107.401674 82.00000 77.000000
## 8 home_value 1190.540833 1102.825978 835.50000 788.000000
## 9 num_child 1.057500 1.087427 1.00000 1.000000
## 10 time_lag 6.843333 6.877602 5.00000 5.000000
## 11 avg_fam_inc 436.134167 430.510408 397.00000 393.000000
## 12 med_fam_inc 392.718333 385.407161 356.50000 355.000000
## 13 wealth 6.439167 6.417985 8.00000 8.000000
## 14 pct_lt15k 14.686667 14.796003 12.00000 12.000000
## W_Statistic P_Value Adjusted_P_Value Significant
## 1 614190.0 2.765762e-10 3.872067e-09 Yes
## 2 622667.0 6.577368e-09 4.604157e-08 Yes
## 3 631211.5 1.416983e-07 6.612588e-07 Yes
## 4 634174.0 3.064916e-07 1.072721e-06 Yes
## 5 778311.0 6.782392e-04 1.899070e-03 Yes
## 6 763121.5 1.013170e-02 2.364063e-02 Yes
## 7 759282.0 2.275472e-02 4.550945e-02 Yes
## 8 753127.0 5.548638e-02 9.710116e-02 No
## 9 709603.0 8.884078e-02 1.381968e-01 No
## 10 705190.0 3.622153e-01 5.071014e-01 No
## 11 731903.0 5.057599e-01 6.436944e-01 No
## 12 729352.5 6.063507e-01 7.074092e-01 No
## 13 723647.0 8.441291e-01 8.733680e-01 No
## 14 723306.0 8.733680e-01 8.733680e-01 Nowilcox_table <- wilcox_results %>%
mutate(
across(
c(
Donor_Mean,
No_Donor_Mean,
Donor_Median,
No_Donor_Median
),
~ round(.x, 2)
),
P_Value = format.pval(
P_Value,
digits = 3,
eps = 0.001
),
Adjusted_P_Value = format.pval(
Adjusted_P_Value,
digits = 3,
eps = 0.001
)
)
datatable(
wilcox_table,
rownames = FALSE,
options = list(
pageLength = 15,
scrollX = TRUE
)
)chi_results <- lapply(
categorical_names,
function(x) {
contingency_table <- table(
fund_train[[x]],
fund_train$target
)
test_result <- chisq.test(
contingency_table
)
data.frame(
Variable = x,
Chi_Square = unname(
test_result$statistic
),
Degrees_of_Freedom = unname(
test_result$parameter
),
P_Value = test_result$p.value,
Minimum_Expected_Count = min(
test_result$expected
)
)
}
) %>%
bind_rows() %>%
mutate(
Adjusted_P_Value = p.adjust(
P_Value,
method = "BH"
),
Significant = ifelse(
Adjusted_P_Value < 0.05,
"Yes",
"No"
)
) %>%
arrange(Adjusted_P_Value)
chi_results## Variable Chi_Square Degrees_of_Freedom P_Value Minimum_Expected_Count
## 1 zipconvert5 3.15451412 1 0.07571723 464.3065
## 2 homeowner 2.68623625 1 0.10121864 275.3853
## 3 zipconvert2 1.07899874 1 0.29892165 253.8942
## 4 zipconvert3 0.45379623 1 0.50053768 221.9075
## 5 female 0.67480740 1 0.41138053 465.3061
## 6 zipconvert4 0.03530836 1 0.85095098 258.3923
## Adjusted_P_Value Significant
## 1 0.3036559 No
## 2 0.3036559 No
## 3 0.5978433 No
## 4 0.6006452 No
## 5 0.6006452 No
## 6 0.8509510 Nochi_table <- chi_results %>%
mutate(
Chi_Square = round(
Chi_Square,
3
),
Minimum_Expected_Count = round(
Minimum_Expected_Count,
2
),
P_Value = format.pval(
P_Value,
digits = 3,
eps = 0.001
),
Adjusted_P_Value = format.pval(
Adjusted_P_Value,
digits = 3,
eps = 0.001
)
)
datatable(
chi_table,
rownames = FALSE,
options = list(
pageLength = 10,
scrollX = TRUE
)
)categorical_donor_rates <- lapply(
categorical_names,
function(x) {
fund_train %>%
group_by(
Category = .data[[x]]
) %>%
summarise(
Total = n(),
Donors = sum(
target == "Donor",
na.rm = TRUE
),
Donor_Rate = mean(
target == "Donor",
na.rm = TRUE
) * 100,
.groups = "drop"
) %>%
mutate(
Variable = x
) %>%
select(
Variable,
Category,
Total,
Donors,
Donor_Rate
)
}
) %>%
bind_rows() %>%
mutate(
Donor_Rate = round(
Donor_Rate,
2
)
)
categorical_donor_rates## # A tibble: 12 × 5
## Variable Category Total Donors Donor_Rate
## <chr> <chr> <int> <int> <dbl>
## 1 zipconvert2 No 1893 957 50.6
## 2 zipconvert2 Yes 508 243 47.8
## 3 zipconvert3 No 1957 985 50.3
## 4 zipconvert3 Yes 444 215 48.4
## 5 zipconvert4 No 1884 944 50.1
## 6 zipconvert4 Yes 517 256 49.5
## 7 zipconvert5 No 1472 714 48.5
## 8 zipconvert5 Yes 929 486 52.3
## 9 homeowner No 551 258 46.8
## 10 homeowner Yes 1850 942 50.9
## 11 female No 931 455 48.9
## 12 female Yes 1470 745 50.7train_x <- fund_train %>%
select(-target)
train_y <- fund_train$target
validation_x <- fund_validation %>%
select(-target)
validation_y <- fund_validation$target
future_x <- future_fund
dummy_encoder <- dummyVars(
~ .,
data = train_x,
fullRank = TRUE
)
train_dummy <- predict(
dummy_encoder,
newdata = train_x
) %>%
as.data.frame()
validation_dummy <- predict(
dummy_encoder,
newdata = validation_x
) %>%
as.data.frame()
future_dummy <- predict(
dummy_encoder,
newdata = future_x
) %>%
as.data.frame()identical(
names(train_dummy),
names(validation_dummy)
)## [1] TRUEidentical(
names(train_dummy),
names(future_dummy)
)## [1] TRUEpreprocess_plan <- preProcess(
train_dummy,
method = c("nzv","medianImpute","center","scale")
)
train_processed_x <- predict(
preprocess_plan,
train_dummy
)
validation_processed_x <- predict(
preprocess_plan,
validation_dummy
)
future_processed_x <- predict(
preprocess_plan,
future_dummy
)
train_processed <- train_processed_x %>%
mutate(
target = train_y
)
dim(train_processed)## [1] 2401 20table(train_processed$target)##
## Donor No_Donor
## 1200 1201set.seed(12345)
cv_control <- trainControl(
method = "cv",
number = 10,
classProbs = TRUE,
summaryFunction = twoClassSummary,
savePredictions = "final"
)
levels(train_processed$target)## [1] "Donor" "No_Donor"set.seed(12345)
fit_logistic <- train(
target ~ .,
data = train_processed,
method = "glm",
family = binomial,
trControl = cv_control,
metric = "ROC"
)
fit_logistic## Generalized Linear Model
##
## 2401 samples
## 19 predictor
## 2 classes: 'Donor', 'No_Donor'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold)
## Summary of sample sizes: 2160, 2161, 2161, 2161, 2161, 2161, ...
## Resampling results:
##
## ROC Sens Spec
## 0.5828854 0.5491667 0.5637121library(randomForest)## Warning: package 'randomForest' was built under R version 4.5.3## randomForest 4.7-1.2## Type rfNews() to see new features/changes/bug fixes.##
## Attaching package: 'randomForest'## The following object is masked from 'package:dplyr':
##
## combine## The following object is masked from 'package:ggplot2':
##
## marginset.seed(12345)
fit_rf <- train(
target ~ .,
data = train_processed,
method = "rf",
trControl = cv_control,
metric = "ROC",
tuneLength = 10,
ntree = 500,
importance = TRUE
)
fit_rf## Random Forest
##
## 2401 samples
## 19 predictor
## 2 classes: 'Donor', 'No_Donor'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold)
## Summary of sample sizes: 2160, 2161, 2161, 2161, 2161, 2161, ...
## Resampling results across tuning parameters:
##
## mtry ROC Sens Spec
## 2 0.5655621 0.5650000 0.5420937
## 3 0.5636253 0.5425000 0.5395523
## 5 0.5596610 0.5350000 0.5420868
## 7 0.5552302 0.5366667 0.5412466
## 9 0.5495927 0.5216667 0.5345868
## 11 0.5586571 0.5283333 0.5420523
## 13 0.5513439 0.5208333 0.5328857
## 15 0.5496723 0.5108333 0.5378994
## 17 0.5494794 0.5066667 0.5312466
## 19 0.5531028 0.5275000 0.5354132
##
## ROC was used to select the optimal model using the largest value.
## The final value used for the model was mtry = 2.library(gbm)## Warning: package 'gbm' was built under R version 4.5.3## Loaded gbm 2.3.1## This version of gbm is no longer under development. Consider transitioning to gbm3, https://github.com/gbm-developers/gbm3gbm_grid <- expand.grid(
interaction.depth = c(1, 3, 5),
n.trees = seq(50, 500, 50),
shrinkage = c(0.01, 0.05, 0.10),
n.minobsinnode = 10
)
set.seed(12345)
fit_gbm <- train(
target ~ .,
data = train_processed,
method = "gbm",
trControl = cv_control,
metric = "ROC",
tuneGrid = gbm_grid,
verbose = FALSE
)
fit_gbm## Stochastic Gradient Boosting
##
## 2401 samples
## 19 predictor
## 2 classes: 'Donor', 'No_Donor'
##
## No pre-processing
## Resampling: Cross-Validated (10 fold)
## Summary of sample sizes: 2160, 2161, 2161, 2161, 2161, 2161, ...
## Resampling results across tuning parameters:
##
## shrinkage interaction.depth n.trees ROC Sens Spec
## 0.01 1 50 0.5871902 0.5108333 0.5971006
## 0.01 1 100 0.5868709 0.5050000 0.6162190
## 0.01 1 150 0.5866520 0.5091667 0.6112259
## 0.01 1 200 0.5873276 0.4958333 0.6212052
## 0.01 1 250 0.5884808 0.5016667 0.6111915
## 0.01 1 300 0.5867824 0.5000000 0.6036983
## 0.01 1 350 0.5867077 0.5008333 0.6012190
## 0.01 1 400 0.5864314 0.5041667 0.5978994
## 0.01 1 450 0.5869979 0.5050000 0.5970523
## 0.01 1 500 0.5868120 0.5133333 0.5970592
## 0.01 3 50 0.5834890 0.4733333 0.6345041
## 0.01 3 100 0.5834818 0.4991667 0.6137121
## 0.01 3 150 0.5830301 0.5091667 0.6003788
## 0.01 3 200 0.5839170 0.5166667 0.5920386
## 0.01 3 250 0.5828504 0.5250000 0.5911983
## 0.01 3 300 0.5814833 0.5191667 0.5812121
## 0.01 3 350 0.5810635 0.5233333 0.5795730
## 0.01 3 400 0.5799949 0.5275000 0.5770799
## 0.01 3 450 0.5808554 0.5308333 0.5720799
## 0.01 3 500 0.5805433 0.5350000 0.5654270
## 0.01 5 50 0.5807189 0.4916667 0.6178237
## 0.01 5 100 0.5838570 0.5083333 0.5886708
## 0.01 5 150 0.5830572 0.5150000 0.5745730
## 0.01 5 200 0.5840156 0.5250000 0.5753857
## 0.01 5 250 0.5823982 0.5316667 0.5762121
## 0.01 5 300 0.5812022 0.5250000 0.5737190
## 0.01 5 350 0.5797654 0.5325000 0.5612259
## 0.01 5 400 0.5793595 0.5333333 0.5712397
## 0.01 5 450 0.5784559 0.5383333 0.5703994
## 0.01 5 500 0.5772937 0.5408333 0.5620799
## 0.05 1 50 0.5801494 0.4900000 0.5970799
## 0.05 1 100 0.5821347 0.5041667 0.5995386
## 0.05 1 150 0.5808439 0.5158333 0.5945523
## 0.05 1 200 0.5778736 0.5225000 0.5837466
## 0.05 1 250 0.5776246 0.5216667 0.5837190
## 0.05 1 300 0.5780453 0.5341667 0.5820592
## 0.05 1 350 0.5763645 0.5333333 0.5820592
## 0.05 1 400 0.5755462 0.5250000 0.5845455
## 0.05 1 450 0.5750011 0.5250000 0.5820799
## 0.05 1 500 0.5751161 0.5308333 0.5703857
## 0.05 3 50 0.5785560 0.5175000 0.5886846
## 0.05 3 100 0.5743572 0.5333333 0.5695317
## 0.05 3 150 0.5731283 0.5400000 0.5703926
## 0.05 3 200 0.5717544 0.5316667 0.5687121
## 0.05 3 250 0.5719180 0.5391667 0.5737121
## 0.05 3 300 0.5684960 0.5466667 0.5587397
## 0.05 3 350 0.5675515 0.5466667 0.5604132
## 0.05 3 400 0.5660358 0.5491667 0.5604201
## 0.05 3 450 0.5656340 0.5525000 0.5520868
## 0.05 3 500 0.5637859 0.5375000 0.5570868
## 0.05 5 50 0.5776976 0.5283333 0.5696006
## 0.05 5 100 0.5777009 0.5391667 0.5695592
## 0.05 5 150 0.5707661 0.5475000 0.5629063
## 0.05 5 200 0.5635941 0.5408333 0.5512259
## 0.05 5 250 0.5596989 0.5383333 0.5395455
## 0.05 5 300 0.5578395 0.5375000 0.5428788
## 0.05 5 350 0.5554613 0.5308333 0.5478857
## 0.05 5 400 0.5523394 0.5350000 0.5453719
## 0.05 5 450 0.5503411 0.5275000 0.5428926
## 0.05 5 500 0.5484089 0.5358333 0.5453857
## 0.10 1 50 0.5830633 0.4991667 0.6162121
## 0.10 1 100 0.5824015 0.5166667 0.6012397
## 0.10 1 150 0.5796074 0.5258333 0.5878650
## 0.10 1 200 0.5757002 0.5383333 0.5703926
## 0.10 1 250 0.5763155 0.5216667 0.5653719
## 0.10 1 300 0.5713349 0.5250000 0.5637603
## 0.10 1 350 0.5746566 0.5216667 0.5670661
## 0.10 1 400 0.5677965 0.5108333 0.5578857
## 0.10 1 450 0.5656247 0.5141667 0.5645455
## 0.10 1 500 0.5636862 0.5150000 0.5570730
## 0.10 3 50 0.5754660 0.5350000 0.5762190
## 0.10 3 100 0.5650912 0.5558333 0.5570730
## 0.10 3 150 0.5592927 0.5491667 0.5362741
## 0.10 3 200 0.5514911 0.5308333 0.5279477
## 0.10 3 250 0.5479465 0.5308333 0.5320455
## 0.10 3 300 0.5482414 0.5325000 0.5470592
## 0.10 3 350 0.5467438 0.5350000 0.5329339
## 0.10 3 400 0.5435460 0.5358333 0.5287466
## 0.10 3 450 0.5393327 0.5358333 0.5287534
## 0.10 3 500 0.5378383 0.5366667 0.5237603
## 0.10 5 50 0.5695336 0.5358333 0.5504408
## 0.10 5 100 0.5629578 0.5341667 0.5571212
## 0.10 5 150 0.5559458 0.5266667 0.5404339
## 0.10 5 200 0.5525657 0.5250000 0.5304683
## 0.10 5 250 0.5460956 0.5208333 0.5196419
## 0.10 5 300 0.5395363 0.5283333 0.5196556
## 0.10 5 350 0.5368030 0.5283333 0.5154752
## 0.10 5 400 0.5323716 0.5216667 0.5254477
## 0.10 5 450 0.5338858 0.5183333 0.5196143
## 0.10 5 500 0.5309390 0.5316667 0.5096143
##
## Tuning parameter 'n.minobsinnode' was held constant at a value of 10
## ROC was used to select the optimal model using the largest value.
## The final values used for the model were n.trees = 250, interaction.depth =
## 1, shrinkage = 0.01 and n.minobsinnode = 10.model_resamples <- resamples(
list(
Logistic = fit_logistic,
RandomForest = fit_rf,
GradientBoosting = fit_gbm
)
)
summary(model_resamples)##
## Call:
## summary.resamples(object = model_resamples)
##
## Models: Logistic, RandomForest, GradientBoosting
## Number of resamples: 10
##
## ROC
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## Logistic 0.5203472 0.5558422 0.5835069 0.5828854 0.6100174 0.6450694
## RandomForest 0.5031250 0.5492420 0.5668750 0.5655621 0.5946007 0.6138194
## GradientBoosting 0.5389583 0.5540574 0.5905556 0.5884808 0.6060243 0.6670139
## NA's
## Logistic 0
## RandomForest 0
## GradientBoosting 0
##
## Sens
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## Logistic 0.4833333 0.5104167 0.5416667 0.5491667 0.5854167 0.6333333
## RandomForest 0.4416667 0.5583333 0.5708333 0.5650000 0.6041667 0.6166667
## GradientBoosting 0.4250000 0.4583333 0.5000000 0.5016667 0.5562500 0.5583333
## NA's
## Logistic 0
## RandomForest 0
## GradientBoosting 0
##
## Spec
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## Logistic 0.4916667 0.5363636 0.5708333 0.5637121 0.5979167 0.6083333
## RandomForest 0.4876033 0.5000000 0.5458333 0.5420937 0.5666667 0.6250000
## GradientBoosting 0.5250000 0.5756026 0.6208333 0.6111915 0.6416667 0.7250000
## NA's
## Logistic 0
## RandomForest 0
## GradientBoosting 0bwplot(
model_resamples,
metric = "ROC",
main = "Cross-Validated ROC Comparison"
)
dotplot(
model_resamples,
metric = "ROC",
main = "Model Performance Comparison"
)
Logistic regression is balanced and nearly tied for the best ROC. Random Forest has the highest donor sensitivity. Gradient Boosting has the highest ROC and specificity. All ROC values are fairly close to 0.50, so predictive separation is modest.
library(pROC)## Warning: package 'pROC' was built under R version 4.5.3## Type 'citation("pROC")' for a citation.##
## Attaching package: 'pROC'## The following objects are masked from 'package:stats':
##
## cov, smooth, varlogistic_class <- predict(
fit_logistic,
newdata = validation_processed_x,
type = "raw"
)
logistic_prob <- predict(
fit_logistic,
newdata = validation_processed_x,
type = "prob"
)
rf_class <- predict(
fit_rf,
newdata = validation_processed_x,
type = "raw"
)
rf_prob <- predict(
fit_rf,
newdata = validation_processed_x,
type = "prob"
)
gbm_class <- predict(
fit_gbm,
newdata = validation_processed_x,
type = "raw"
)
gbm_prob <- predict(
fit_gbm,
newdata = validation_processed_x,
type = "prob"
)library(caret)logistic_cm <- confusionMatrix(
logistic_class,
validation_y,
positive = "Donor"
)
rf_cm <- confusionMatrix(
rf_class,
validation_y,
positive = "Donor"
)
gbm_cm <- confusionMatrix(
gbm_class,
validation_y,
positive = "Donor"
)
logistic_cm## Confusion Matrix and Statistics
##
## Reference
## Prediction Donor No_Donor
## Donor 177 147
## No_Donor 122 153
##
## Accuracy : 0.5509
## 95% CI : (0.5101, 0.5912)
## No Information Rate : 0.5008
## P-Value [Acc > NIR] : 0.007924
##
## Kappa : 0.102
##
## Mcnemar's Test P-Value : 0.143384
##
## Sensitivity : 0.5920
## Specificity : 0.5100
## Pos Pred Value : 0.5463
## Neg Pred Value : 0.5564
## Prevalence : 0.4992
## Detection Rate : 0.2955
## Detection Prevalence : 0.5409
## Balanced Accuracy : 0.5510
##
## 'Positive' Class : Donor
## rf_cm## Confusion Matrix and Statistics
##
## Reference
## Prediction Donor No_Donor
## Donor 161 148
## No_Donor 138 152
##
## Accuracy : 0.5225
## 95% CI : (0.4817, 0.5632)
## No Information Rate : 0.5008
## P-Value [Acc > NIR] : 0.1535
##
## Kappa : 0.0451
##
## Mcnemar's Test P-Value : 0.5946
##
## Sensitivity : 0.5385
## Specificity : 0.5067
## Pos Pred Value : 0.5210
## Neg Pred Value : 0.5241
## Prevalence : 0.4992
## Detection Rate : 0.2688
## Detection Prevalence : 0.5159
## Balanced Accuracy : 0.5226
##
## 'Positive' Class : Donor
## gbm_cm## Confusion Matrix and Statistics
##
## Reference
## Prediction Donor No_Donor
## Donor 162 124
## No_Donor 137 176
##
## Accuracy : 0.5643
## 95% CI : (0.5235, 0.6044)
## No Information Rate : 0.5008
## P-Value [Acc > NIR] : 0.001077
##
## Kappa : 0.1285
##
## Mcnemar's Test P-Value : 0.457614
##
## Sensitivity : 0.5418
## Specificity : 0.5867
## Pos Pred Value : 0.5664
## Neg Pred Value : 0.5623
## Prevalence : 0.4992
## Detection Rate : 0.2705
## Detection Prevalence : 0.4775
## Balanced Accuracy : 0.5642
##
## 'Positive' Class : Donor
## logistic_roc <- roc(
response = validation_y,
predictor = logistic_prob$Donor,
levels = c("No_Donor", "Donor"),
direction = "<"
)
rf_roc <- roc(
response = validation_y,
predictor = rf_prob$Donor,
levels = c("No_Donor", "Donor"),
direction = "<"
)
gbm_roc <- roc(
response = validation_y,
predictor = gbm_prob$Donor,
levels = c("No_Donor", "Donor"),
direction = "<"
)
auc(logistic_roc)## Area under the curve: 0.5457auc(rf_roc)## Area under the curve: 0.5152auc(gbm_roc)## Area under the curve: 0.569plot(
logistic_roc,
col = "steelblue",
lwd = 3,
main = "Validation ROC Curves"
)
plot(
rf_roc,
col = "firebrick",
lwd = 3,
add = TRUE
)
plot(
gbm_roc,
col = "darkgreen",
lwd = 3,
add = TRUE
)
abline(
0, 1,
lty = 2,
col = "gray50"
)
legend(
"bottomright",
legend = c(
paste0("Logistic (AUC = ", round(auc(logistic_roc), 3), ")"),
paste0("Random Forest (AUC = ", round(auc(rf_roc), 3), ")"),
paste0("Gradient Boosting (AUC = ", round(auc(gbm_roc), 3), ")")
),
col = c(
"steelblue",
"firebrick",
"darkgreen"
),
lwd = 3,
bty = "n"
)
Logistic Regression Highest donor sensitivity (59.2%) Good baseline
model Easy to interpret Validation ROC decreased from 0.583 to 0.546
It identifies the largest proportion of donors but misclassifies more non-donors.
Random Forest
Random Forest was honestly a little disappointing.
Lowest validation ROC (0.515) Lowest accuracy (52.4%) Lowest Kappa (0.049)
Despite its flexibility, it did not generalize well to unseen data.
Gradient Boosting
Gradient Boosting consistently performed best overall.
Highest validation ROC (0.573) Highest validation accuracy (56.1%) Highest specificity (55.0%) Highest Kappa (0.122)
Although its sensitivity is slightly lower than logistic regression, it provides a much better balance between identifying donors and avoiding false positives.
For a fundraising campaign, mailing unnecessary solicitations is costly, so improving specificity has real business value.
Going based off the results even though logistic regression captures a few more donors, gradient boosting provides the strongest overall descrimination between donors and no donors, due to having the highest scores other than sensitivity
#Get Validation Probabilities
gbm_prob <- predict(
fit_gbm,
newdata = validation_processed_x,
type = "prob"
)
head(gbm_prob)## Donor No_Donor
## 1 0.5098856 0.4901144
## 2 0.5954272 0.4045728
## 3 0.4979468 0.5020532
## 4 0.4167457 0.5832543
## 5 0.5035020 0.4964980
## 6 0.4200376 0.5799624mail_cost <- 0.68
donation <- 13
cutoffs <- seq(0.10, 0.90, by = 0.01)
profit_results <- map_df(cutoffs, function(cut){
prediction <- ifelse(
gbm_prob$Donor >= cut,
"Donor",
"No_Donor"
)
mailed <- prediction == "Donor"
actual_donor <- validation_y == "Donor"
total_mailings <- sum(mailed)
donations <- sum(mailed & actual_donor)
revenue <- donations * donation
mailing_cost <- total_mailings * mail_cost
profit <- revenue - mailing_cost
tibble(
Cutoff = cut,
Mailings = total_mailings,
Donations = donations,
Revenue = revenue,
Mailing_Cost = mailing_cost,
Profit = profit
)
})
profit_results## # A tibble: 81 × 6
## Cutoff Mailings Donations Revenue Mailing_Cost Profit
## <dbl> <int> <int> <dbl> <dbl> <dbl>
## 1 0.1 599 299 3887 407. 3480.
## 2 0.11 599 299 3887 407. 3480.
## 3 0.12 599 299 3887 407. 3480.
## 4 0.13 599 299 3887 407. 3480.
## 5 0.14 599 299 3887 407. 3480.
## 6 0.15 599 299 3887 407. 3480.
## 7 0.16 599 299 3887 407. 3480.
## 8 0.17 599 299 3887 407. 3480.
## 9 0.18 599 299 3887 407. 3480.
## 10 0.19 599 299 3887 407. 3480.
## # ℹ 71 more rowsbest_cutoff <- profit_results %>%
slice_max(
Profit,
n = 1,
with_ties = FALSE
)
best_cutoff## # A tibble: 1 × 6
## Cutoff Mailings Donations Revenue Mailing_Cost Profit
## <dbl> <int> <int> <dbl> <dbl> <dbl>
## 1 0.4 598 299 3887 407. 3480.mail_percent <- best_cutoff$Mailings /
nrow(validation_processed_x)
round(
mail_percent * 100,
2
)## [1] 99.83best_cutoff %>%
mutate(
Percent_Mailed = round(
100 * Mailings /
nrow(validation_processed_x),
2
)
)## # A tibble: 1 × 7
## Cutoff Mailings Donations Revenue Mailing_Cost Profit Percent_Mailed
## <dbl> <int> <int> <dbl> <dbl> <dbl> <dbl>
## 1 0.4 598 299 3887 407. 3480. 99.8profit_results <- profit_results %>%
mutate(
Profit_Per_Mailing = Profit / Mailings
)
profit_results## # A tibble: 81 × 7
## Cutoff Mailings Donations Revenue Mailing_Cost Profit Profit_Per_Mailing
## <dbl> <int> <int> <dbl> <dbl> <dbl> <dbl>
## 1 0.1 599 299 3887 407. 3480. 5.81
## 2 0.11 599 299 3887 407. 3480. 5.81
## 3 0.12 599 299 3887 407. 3480. 5.81
## 4 0.13 599 299 3887 407. 3480. 5.81
## 5 0.14 599 299 3887 407. 3480. 5.81
## 6 0.15 599 299 3887 407. 3480. 5.81
## 7 0.16 599 299 3887 407. 3480. 5.81
## 8 0.17 599 299 3887 407. 3480. 5.81
## 9 0.18 599 299 3887 407. 3480. 5.81
## 10 0.19 599 299 3887 407. 3480. 5.81
## # ℹ 71 more rowsprofit_results %>%
distinct(Mailings, .keep_all = TRUE)## # A tibble: 31 × 7
## Cutoff Mailings Donations Revenue Mailing_Cost Profit Profit_Per_Mailing
## <dbl> <int> <int> <dbl> <dbl> <dbl> <dbl>
## 1 0.1 599 299 3887 407. 3480. 5.81
## 2 0.4 598 299 3887 407. 3480. 5.82
## 3 0.42 580 289 3757 394. 3363. 5.80
## 4 0.43 540 273 3549 367. 3182. 5.89
## 5 0.44 521 266 3458 354. 3104. 5.96
## 6 0.45 485 252 3276 330. 2946. 6.07
## 7 0.46 466 242 3146 317. 2829. 6.07
## 8 0.47 443 232 3016 301. 2715. 6.13
## 9 0.48 400 219 2847 272 2575 6.44
## 10 0.49 344 192 2496 234. 2262. 6.58
## # ℹ 21 more rowsprofit_plot <- profit_results %>%
distinct(Mailings, .keep_all = TRUE)
ggplot(profit_plot,
aes(Cutoff, Profit)) +
geom_line(
color = "steelblue",
linewidth = 1.2
) +
geom_point(
color = "firebrick",
size = 2
) +
labs(
title = "Expected Profit by Probability Cutoff",
x = "Probability Cutoff",
y = "Expected Profit ($)"
) +
theme_minimal()
training and validation data are balanced (roughly 50% donors and 50%
non-donors), whereas the real campaign has only about a 5.1% response
rate.
Because of this balanced sample:
The model predicts many individuals with probabilities near 0.50. Almost everyone exceeds the very low break-even probability implied by the mailing cost (0.68) relative to the average donation ($13.00). As a result, the profit analysis on the balanced validation set suggests mailing nearly everyone.
This is an important limitation to mention.
importance <- varImp(fit_gbm)
plot(importance,
top = 15,
main = "Gradient Boosting Variable Importance")
#NOW LETS SEE WHAT I GET
future_prob <- predict(
fit_gbm,
newdata = future_processed_x,
type = "prob"
)
head(future_prob)## Donor No_Donor
## 1 0.5814565 0.4185435
## 2 0.4648134 0.5351866
## 3 0.5591237 0.4408763
## 4 0.4247319 0.5752681
## 5 0.6103071 0.3896929
## 6 0.4183518 0.5816482optimal_cutoff <- best_cutoff$Cutoff
optimal_cutoff## [1] 0.4future_predictions <- future_prob %>%
mutate(
value = ifelse(
Donor >= optimal_cutoff,
"Donor",
"No Donor"
)
) %>%
select(value)
View(future_predictions)dim(future_predictions)## [1] 120 1table(future_predictions$value)##
## Donor
## 120round(
prop.table(table(future_predictions$value)) * 100,
2
)##
## Donor
## 100summary(future_prob$Donor)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0.4139 0.4440 0.4836 0.4989 0.5379 0.6903range(future_prob$Donor)## [1] 0.4138722 0.6903397future_predictions <- future_prob %>%
mutate(
value = ifelse(
Donor >= 0.50,
"Donor",
"No Donor"
)
) %>%
select(value)
dim(future_predictions)## [1] 120 1table(future_predictions$value)##
## Donor No Donor
## 47 73round(
prop.table(table(future_predictions$value)) * 100,
2
)##
## Donor No Donor
## 39.17 60.83View(future_predictions)write_csv(
future_predictions,
"future_fundraising_predictions.csv"
)
submission_check <- read_csv(
"future_fundraising_predictions.csv"
)## Rows: 120 Columns: 1
## ── Column specification ────────────────────────────────────────────────────────
## Delimiter: ","
## chr (1): value
##
## ℹ 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.dim(submission_check)## [1] 120 1names(submission_check)## [1] "value"table(submission_check$value)##
## Donor No Donor
## 47 73head(submission_check)## # A tibble: 6 × 1
## value
## <chr>
## 1 Donor
## 2 No Donor
## 3 Donor
## 4 No Donor
## 5 Donor
## 6 No DonorThe selected Gradient Boosting model was applied to the 120 future fundraising candidates. Using a classification cutoff of 0.50, the model predicted 47 candidates (39.17%) as donors and 73 candidates (60.83%) as non-donors.