Bank Marketing - Part 3 - Keeping up with the times - Sliding Window Models

Sun, 18 Oct 2026 00:00:00 +0000

The Timeline of the Calls

In Part 1, we recovered the year of each call from the order of the calls. Here are the calls and the subscription rate in each month:

p1 <- ggplot(dfMonthly, aes(x = year_month, y = calls)) +
  geom_col(fill = "#00AED8") +
  scale_y_continuous(labels = scales::label_comma()) +
  scale_x_date(date_breaks = "3 months", date_labels = "%b %Y") +
  labs(x = NULL, y = "Calls", title = "Number of calls in each month")
p2 <- ggplot(dfMonthly, aes(x = year_month, y = rate)) +
  geom_line(color = "#F37735") + geom_point(aes(size = calls), color = "#F37735", show.legend = FALSE) +
  scale_y_continuous(labels = scales::label_percent()) +
  scale_x_date(date_breaks = "3 months", date_labels = "%b %Y") +
  labs(x = NULL, y = "Subscription rate", title = "Subscription rate in each month (point size: number of calls)")
cowplot::plot_grid(plotlist = list(p1, p2), ncol = 1, align = "v")

Most of the calls were made in 2008, when few clients said yes. From the middle of 2009, the bank made far fewer calls, and about half of them succeeded. So a model trained on the past learns from a very different situation from the one that it has to predict.

How the Sliding Windows Work

Each cycle has two parts:

A training window of the 12 calendar months before the testing period. We choose the hyperparameters with cross validation on these calls only, and train the final model on all of them.
A testing period of the next 3 months. The model predicts these calls, which it has never seen.

Then the window moves forward by 3 months. The first testing period starts in June 2009, the first month with 12 full months of calls before it, and the last one ends in November 2010, the last month of the data. Some months have no calls, so a window can have fewer than 12 months of calls.

dfCycles %>%
  transmute(Cycle = cycle,
            `Training months` = paste(format(train_first, "%b %Y"), "-", format(train_last, "%b %Y")),
            `Training calls` = scales::label_comma()(train_calls),
            `Training rate` = scales::label_percent(accuracy = 0.1)(train_rate),
            `Testing months` = if_else(test_first == test_last, format(test_first, "%b %Y"),
                                       paste(format(test_first, "%b %Y"), "-", format(test_last, "%b %Y"))),
            `Testing calls` = scales::label_comma()(test_calls),
            `Testing rate` = scales::label_percent(accuracy = 0.1)(test_rate)) %>%
  knitr::kable()

Cycle	Training months	Training calls	Training rate	Testing months	Testing calls	Testing rate
1	Jun 2008 - May 2009	28,452	7.7%	Jun 2009 - Aug 2009	1,662	35.7%
2	Oct 2008 - Aug 2009	13,886	13.8%	Sep 2009 - Nov 2009	1,070	42.4%
3	Dec 2008 - Nov 2009	11,274	19.0%	Dec 2009	172	51.2%
4	Mar 2009 - Dec 2009	11,436	19.5%	Mar 2010 - May 2010	650	56.8%
5	Jun 2009 - May 2010	3,554	42.3%	Jun 2010 - Aug 2010	773	52.1%
6	Sep 2009 - Aug 2010	2,665	49.3%	Sep 2010 - Nov 2010	635	47.4%

dfCycles %>%
  select(cycle, train_first, train_last, test_first, test_last) %>%
  pivot_longer(-cycle, names_to = c("part", ".value"), names_sep = "_") %>%
  mutate(part = if_else(part == "train", "training window", "testing period"),
         last = last %m+% months(1)) %>%
  ggplot(aes(y = factor(cycle), xmin = first, xmax = last, color = part)) +
  geom_linerange(linewidth = 6) +
  scale_y_discrete(limits = rev) +
  scale_x_date(date_breaks = "3 months", date_labels = "%b %Y") +
  scale_color_manual(values = c("training window" = "#00AED8", "testing period" = "#F37735"), name = NULL) +
  labs(x = NULL, y = "Cycle", title = "Training windows and testing periods")

What’s notable?

The training windows shrink from 28,452 calls in the first cycle to 2,665 in the last, because the bank made fewer calls each year.
In the first cycles, the models learn from a very different situation from the one that they predict: in cycle 1, 7.7% of the training calls succeeded, but 35.7% of the testing calls did. By the last cycles, the training windows have similar rates to the testing periods.
Cycle 3 tests only December 2009, because there were no calls in January and February 2010.

In each cycle, the code checks that every training call was made before every testing call, and that no call is in both. Everything that the model learns, including the hyperparameters and the preparation of the features (such as the dummy variables and which features are skewed), comes from the training window only.

Feature Sets

We compare three sets of features:

client and campaign: the features of the client and of the call, such as age, job, contact, month and the history of previous campaigns. No economic features.
+ economic levels: the same features plus the five economic features, as in Part 2.
+ economic trends: the client and campaign features plus three features that describe how things changed, instead of their levels: euribor_change, the change of the Euribor rate; employed_change, the change of the number of employees; and prev_month_rate, the subscription rate in the last month that the model knows.

For the calls in a testing period, the trend features compare with the last month of the training window, the last month that the bank knows when it trains the model. So the model does not use the results of other calls in the testing period.

p1 <- ggplot(dfMonthly, aes(x = year_month, y = euribor_mean)) +
  geom_line(color = "#00AED8") + geom_point(color = "#00AED8") +
  scale_x_date(date_breaks = "3 months", date_labels = "%b %Y") +
  labs(x = NULL, y = "3 month Euribor (%)", title = "Average 3 month Euribor in each month") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))
p2 <- ggplot(dfMonthly %>% filter(!is.na(prev_month_rate)), aes(x = rate, y = prev_month_rate)) +
  geom_abline(lty = 2) +
  geom_point(aes(size = calls), color = "#F37735", alpha = 0.7, show.legend = FALSE) +
  scale_x_continuous(labels = scales::label_percent()) +
  scale_y_continuous(labels = scales::label_percent()) +
  labs(x = "Subscription rate in the month", y = "Rate in the previous month with calls",
       title = "Subscription rate vs the previous month")
cowplot::plot_grid(plotlist = list(p1, p2), ncol = 2)

Results

All the Testing Periods Together

We put the predictions of all the testing periods together, 4,962 calls in total, and measure each model and feature set. We also measure the ROC AUC within each month and take the average. This shows how well a model ranks the clients within a month, which is what a bank needs to decide whom to call that month.

dfOverall <- dfSlidingPred %>%
  group_by(model, feature_set) %>%
  summarise(roc_auc = roc_auc_vec(y, .pred_yes),
            pr_auc = pr_auc_vec(y, .pred_yes),
            mn_log_loss = mn_log_loss_vec(y, .pred_yes),
            mean_predicted = mean(.pred_yes),
            actual_rate = mean(y == "yes"),
            .groups = "drop") %>%
  left_join(dfSlidingPred %>%
              group_by(model, feature_set, year_month) %>%
              summarise(month_roc_auc = roc_auc_vec(y, .pred_yes), .groups = "drop") %>%
              group_by(model, feature_set) %>%
              summarise(monthly_roc_auc = mean(month_roc_auc), .groups = "drop"),
            by = c("model", "feature_set")) %>%
  mutate(feature_set = factor(feature_set, levels = names(lFeatureSets))) %>%
  arrange(model, feature_set)

dfOverall %>%
  mutate(across(c(roc_auc, pr_auc, mn_log_loss, monthly_roc_auc), ~ round(.x, 3)),
         across(c(mean_predicted, actual_rate), ~ scales::label_percent(accuracy = 0.1)(.x))) %>%
  select(model, feature_set, roc_auc, monthly_roc_auc, pr_auc, mn_log_loss, mean_predicted, actual_rate) %>%
  # in the HTML table, each cell's text is on a line of its own, and Hugo would turn a line that starts with "+" into a
  # bulleted list, so the text is wrapped in a <span>
  mutate(feature_set = paste0("<span>", feature_set, "</span>")) %>%
  # an HTML table, so that the browser sizes the columns to their contents, and the headers break where they should;
  # text columns are aligned left, and number columns right, with their headers
  knitr::kable(format = "html", escape = FALSE, align = c("l", "l", "r", "r", "r", "r", "r", "r"),
               col.names = c("Model", "Features", "ROC<br>AUC", "Average ROC AUC<br>within a month", "PR<br>AUC", "Log<br>loss",
                             "Average predicted<br>probability", "Actual<br>subscription rate"))

Model	Features	ROC AUC	Average ROC AUC within a month	PR AUC	Log loss	Average predicted probability	Actual subscription rate
glmnet	client and campaign	0.655	0.678	0.621	0.762	27.4%	44.5%
glmnet	+ economic levels	0.596	0.683	0.519	1.337	50.7%	44.5%
glmnet	+ economic trends	0.588	0.678	0.521	0.902	45.9%	44.5%
xgboost	client and campaign	0.650	0.677	0.615	0.764	27.7%	44.5%
xgboost	+ economic levels	0.638	0.669	0.598	0.721	31.7%	44.5%
xgboost	+ economic trends	0.573	0.650	0.519	0.716	47.1%	44.5%

overall <- function(model, feature_set, metric) dfOverall[[metric]][dfOverall$model == model & dfOverall$feature_set == feature_set]
# the best model and feature set, by ROC AUC over all the testing periods together
best_row <- dfOverall %>% slice_max(roc_auc, n = 1)

What’s notable?

On calls that they have not seen, from the next 3 months, the models do much worse than in Part 2. The best ROC AUC is 0.655, for glmnet with the client and campaign features, compared with about 0.80 on the random testing set of Part 2.
Within a month, all the models and feature sets rank the clients about equally well, with an average ROC AUC of 0.650 to 0.683. The differences in the overall ROC AUC come mostly from how well the models predict the level of each month: a model that gives every client in a good month a higher probability ranks them higher overall.
The economic features do not help. With their levels, glmnet has an overall ROC AUC of only 0.596 and the worst log loss, 1.337. The trend features do not help either.
Without the economic features, the models expect far fewer subscribers than there are: an average predicted probability of about 27%, compared with the actual rate of 44%. They learned from windows with lower subscription rates.

Cycle by Cycle

dfCycleResults <- dfSlidingPred %>%
  group_by(cycle, model, feature_set) %>%
  summarise(roc_auc = roc_auc_vec(y, .pred_yes), .groups = "drop") %>%
  mutate(feature_set = factor(feature_set, levels = names(lFeatureSets)))

ggplot(dfCycleResults, aes(x = cycle, y = roc_auc, color = feature_set)) +
  geom_hline(yintercept = 0.5, lty = 2) +
  geom_line() + geom_point(size = 2) +
  facet_wrap(~ model) +
  scale_x_continuous(breaks = dfCycles$cycle) +
  scale_color_quant(palette = "metro", name = "Features") +
  labs(x = "Cycle", y = "ROC AUC on the testing period", title = "ROC AUC in each testing period",
       subtitle = "The dashed line is a random ranking")

What’s notable?

In every cycle, the models and feature sets have similar ROC AUCs. The period matters much more than the model or the features.
The ROC AUC rises from about 0.57 in cycle 1 to about 0.76 in the last cycle. In the first cycle, the training window is mostly calls from 2008, when few clients said yes. In the last cycles, the training window is from the same situation as the testing period, so what the models learned still applies.

Predicted and Actual Subscription Rates

A bank also needs to know how many subscribers to expect, for example to plan its staff. Here is the average predicted probability in each testing month, compared with the actual subscription rate:

dfSlidingPred %>%
  mutate(feature_set = factor(feature_set, levels = names(lFeatureSets))) %>%
  group_by(model, feature_set, year_month) %>%
  summarise(predicted = mean(.pred_yes), actual = mean(y == "yes"), .groups = "drop") %>%
  ggplot(aes(x = year_month)) +
  geom_line(aes(y = actual), color = "black", linewidth = 1) +
  geom_line(aes(y = predicted, color = feature_set)) +
  geom_point(aes(y = predicted, color = feature_set), size = 1.5) +
  facet_wrap(~ model) +
  scale_y_continuous(labels = scales::label_percent()) +
  scale_x_date(date_breaks = "3 months", date_labels = "%b %Y") +
  scale_color_quant(palette = "metro", name = "Features") +
  labs(x = NULL, y = "Subscription rate", title = "Predicted (colors) and actual (black) subscription rate in each testing month")

What’s notable?

Without the economic features, the models predict too few subscribers in the first cycles, and catch up as the training windows include more months with high rates.
With the levels of the economic features, glmnet swings widely: in September to November 2009, it predicts that almost every client will say yes. In those months, interest rates were lower than in any month of its training window, so it extended a straight-line trend that no longer applied (as in Part 2).
With the trend features, the average prediction is closer to the actual rate over the whole period, but it jumps from one cycle to the next, because the change of the economy and last month’s rate are only a rough guide to the next 3 months.

The Hyperparameters Change from Cycle to Cycle

These are the hyperparameters of xgboost chosen in each cycle, with the client and campaign features:

dfCycleParams %>%
  filter(model == "xgboost", feature_set == best_row$feature_set) %>%
  unnest(params) %>%
  transmute(Cycle = cycle, min_n, tree_depth, learn_rate = signif(learn_rate, 3),
            `Cross validated ROC AUC in the training window` = round(cv_roc_auc, 3)) %>%
  knitr::kable()

Cycle	min_n	tree_depth	learn_rate	Cross validated ROC AUC in the training window
1	23	2	0.0032	0.619
2	40	1	0.0395	0.692
3	39	12	0.0035	0.755
4	39	12	0.0035	0.759
5	23	2	0.0032	0.634
6	23	15	0.0089	0.693

What’s notable?

The best hyperparameters change from cycle to cycle, from very shallow trees (a depth of 1 or 2) to deep trees (a depth of 12 or more). This is why we must choose them again in each cycle, on the training window only, rather than reuse the hyperparameters of Part 2, which were chosen on calls from the whole period.
The cross validated ROC AUC within a training window does not tell us how well the model will do on the next 3 months: sometimes it is higher, and sometimes lower. Cross validation within a window measures how well a model fits that period, not the next one.

Comparison with Part 2

The three ways of testing the models give very different answers:

On a random testing set from the same period (Part 2), the best models had a ROC AUC of about 0.80.
When we trained on the first 75% of the calls and tested on the last 25% (Part 2), the ROC AUC was between 0.28 and 0.71, depending on the model and the features. But the hyperparameters had been chosen on calls from the whole period.
With sliding windows, where every choice is made on past calls only, the ROC AUC over all the testing periods is between 0.573 and 0.655.

The testing periods are not exactly the same (the later calls of Part 2 start in May 2009, and the testing periods here start in June 2009), so the numbers cannot be compared exactly. But the message is clear: the random testing set of Part 2 gave a much too good picture of how the models would predict future calls.

How a Bank Could Use the Models

Even with modest ROC AUCs, the models are useful within a month. If the bank calls the 20% of each month’s clients with the highest probabilities, using the glmnet model with the client and campaign features:

dfTopCalls <- dfSlidingPred %>%
  filter(model == best_row$model, feature_set == best_row$feature_set) %>%
  group_by(year_month) %>%
  arrange(desc(.pred_yes), .by_group = TRUE) %>%
  mutate(called = row_number() <= ceiling(0.2 * n())) %>%
  ungroup()

top_reach <- sum(dfTopCalls$y == "yes" & dfTopCalls$called) / sum(dfTopCalls$y == "yes")
top_rate <- mean(dfTopCalls$y[dfTopCalls$called] == "yes")
all_rate <- mean(dfTopCalls$y == "yes")

It reaches 31% of the subscribers with 20% of the calls.
68% of these calls end with a yes, compared with 44% of all the calls in the testing periods: 1.5 times as many.

This is a smaller gain than in Part 2, where the top 20% reached about two thirds of the subscribers. But it is an honest estimate of what the bank could expect from a model trained on the past.

Conclusions

When the data covers a period of time, the way we test a model matters as much as the model itself. A random testing set lets the model learn from the same period that it is tested on, and it gives a much too good picture.
In a sliding window, every step that learns from data, including the choice of the hyperparameters, the preparation of the features and the features that describe the recent past, must use the training window only. Then the testing period is truly unseen.
On truly unseen calls, the models rank the clients within a month moderately well (an average ROC AUC of about 0.67), and calling the top 20% of each month gives about 1.5 times the success rate of calling at random.
The economic features, which looked so useful in Part 2, do not help a model that predicts the future: the economy of the next months is outside what the model has seen.
The models do better when the recent past is like the near future. In practice, a bank should train its models again often, and watch how well they predict each new month.

Appendix: Sliding Window Code

This code runs the sliding windows. It takes several minutes, so it does not run each time we build this page. Instead, the page saves the results in the file Bank_Sliding.Rda, together with a fingerprint (a hash) of the inputs: the clean data from Part 1 and the code itself. When we build the page again, it calculates the fingerprint again:

If the fingerprint is the same, the page loads the saved results in a few seconds.
If the data or any part of the code has changed, the page runs the sliding windows again and saves the new results.

Changes to the comments or the spacing of the code do not count as changes. To run the sliding windows again without any change, delete Bank_Sliding.Rda.

# How the sliding window code is built:
#   1. Each cycle has a training window of 12 calendar months and a testing period of the next 3 months. Then the
#      window moves forward by 3 months. Hyperparameters are tuned within each training window only, so no information
#      from the testing period or later is used (no lookahead). The Part 2 hyperparameters are not reused, because they
#      were tuned on calls from the whole period.
#   2. Within a training window, the hyperparameters are tuned by racing with 5-fold cross validation, as in Part 2.
#      The folds are random within the window: they do not need to respect time, because all of them come before the
#      testing period.
#   3. Three feature sets are compared: the client and campaign features only, these plus the five economic features
#      (their levels, as in Part 2), and these plus three trend features that describe how the economy and the campaign
#      changed (see "Trend features").
#   4. Two models are compared: glmnet (regularized logistic regression) and xgboost. Plain logistic regression is not
#      used, because the later training windows have only a few thousand calls and ~50 predictors, where an
#      unregularized model is unstable. ranger is not used, because it was the slowest to tune in Part 2, and it did
#      not do better than xgboost.
#   5. The cycles run one after another; within a cycle, the tuning runs in parallel (see "Parallel backend").

# load the clean dataset and the dates of the calls from Part 1 (bank_data_file is set in the "sliding_cache" chunk)
load(bank_data_file)

dfCalls <- dfClean %>%
    inner_join(dfCallDates, by = "Id") %>%
    arrange(Id)

# Trend features
########################################################################################################################################################
# Calculated from past months only:
#   euribor_change:  the 3 month Euribor on the day of the call, minus its average in a reference month.
#   employed_change: the number of employees (nr.employed) at the time of the call, minus its average in the
#                    reference month.
#   prev_month_rate: the subscription rate in the reference month.
# For the calls in a training window, the reference month is the previous month with calls (some months have no calls:
# January, February and September 2008). For the calls in a testing period, it is the last month of the training
# window, for all 3 testing months (see "Run the cycles"). Otherwise, in the 2nd and 3rd testing months,
# prev_month_rate would use the results of calls in the testing period, which the model must not see.
# Euribor and employment on the day of a call are published economic data, known at the time of the call.
# The first month, May 2008, has no previous month, so its calls are left out.
dfMonthly <- dfCalls %>%
    group_by(year_month) %>%
    summarise(calls = n(), rate = mean(y == "yes"), euribor_mean = mean(euribor3m), employed_mean = mean(nr.employed)) %>%
    arrange(year_month) %>%
    mutate(prev_euribor = lag(euribor_mean), prev_employed = lag(employed_mean), prev_month_rate = lag(rate))

dfCalls <- dfCalls %>%
    inner_join(dfMonthly %>% select(year_month, prev_euribor, prev_employed, prev_month_rate), by = "year_month") %>%
    mutate(euribor_change = euribor3m - prev_euribor,
           employed_change = nr.employed - prev_employed) %>%
    select(-prev_euribor, -prev_employed) %>%
    filter(!is.na(prev_month_rate))

vFeaturesEconomic <- c("emp.var.rate", "cons.price.idx", "cons.conf.idx", "euribor3m", "nr.employed")
vFeaturesTrend <- c("euribor_change", "employed_change", "prev_month_rate")

# predictors left out of each feature set (Id, year and year_month are never predictors)
lFeatureSets <- list("client and campaign" = c(vFeaturesEconomic, vFeaturesTrend),
                     "+ economic levels" = vFeaturesTrend,
                     "+ economic trends" = vFeaturesEconomic)


# Cycles
########################################################################################################################################################
# The first testing period starts 12 calendar months after the first usable month (June 2008), so that every training
# window has 12 full months. Each cycle tests the next 3 months, and the next cycle starts 3 months later, until the
# last month of the data.
first_month <- min(dfCalls$year_month)
last_month <- max(dfCalls$year_month)
dfCycles <- tibble(test_start = seq(first_month %m+% months(12), last_month, by = "3 months")) %>%
    mutate(train_start = test_start %m-% months(12),
           train_end = test_start %m-% months(1),
           test_end = test_start %m+% months(2),
           cycle = row_number(),
           train_first = as.Date(NA), train_last = as.Date(NA), test_first = as.Date(NA), test_last = as.Date(NA),
           train_calls = NA_integer_, train_rate = NA_real_, test_calls = NA_integer_, test_rate = NA_real_)

# Preprocessing Recipe
########################################################################################################################################################
# As in Part 2: dummy variables, log of right-skewed features, and removal of single-value predictors and exact linear
# combinations. It is prepared on the training window of each cycle only, and so is the choice of the skewed features.
vFeaturesClientNum <- c("age", "campaign", "previous")
get_preprocessing_recipe <- function(df) {

    vFeaturesSkew <- df %>%
        select(all_of(vFeaturesClientNum)) %>%
        select_if(function(Z) timeDate::skewness(Z, na.rm = T) > 0.75) %>%
        colnames()

    recipe(y ~ ., data = df) %>%
        update_role(Id, year, year_month, new_role = "ID") %>%
        step_mutate_at(all_of(vFeaturesSkew), fn = ~ log(. + 1)) %>%
        step_dummy(all_nominal_predictors()) %>%
        step_zv(all_predictors()) %>%
        step_intercept() %>%
        step_lincomb(all_numeric_predictors()) %>%
        step_rm(any_of("intercept")) %>%
        prep()
}

# Models and grids
########################################################################################################################################################
class_metrics <- metric_set(roc_auc, pr_auc, mn_log_loss)

get_model_spec <- function(modelType) {
    switch(modelType,
           glmnet = logistic_reg(mode = "classification", penalty = tune(), mixture = tune()) %>%
               set_engine("glmnet"),
           xgboost = boost_tree(mode = "classification", trees = 1000, min_n = tune(), tree_depth = tune(),
                                learn_rate = tune()) %>%
               set_engine("xgboost", nthread = 1))
}

# The same grids as in Part 2 (glmnet: 20 penalties x 5 mixtures; xgboost: a space-filling grid over the same ranges),
# with 10 instead of 25 xgboost combinations, because the tuning runs 18 times (6 cycles x 3 feature sets). In a test
# run with 4 xgboost combinations, xgboost already took 9 minutes over the 18 tuning runs. The ranges are not narrowed
# with what Part 2 found, because Part 2 tuned on calls from the whole period (that would be a lookahead).
get_model_param_grid <- function(modelType, randomSeed = 2300) {
    if(modelType == "glmnet") {
        return(grid_regular(penalty(), mixture(), levels = c(penalty = 20, mixture = 5)))
    }
    set.seed(randomSeed)
    grid_space_filling(parameters(min_n(), tree_depth(), learn_rate(range = c(-2.5, -0.5))), size = 10, type = "max_entropy")
}

# !! puts the names in vExclude into the workflow itself. Without it, the workflow keeps a reference to the variable,
# which the parallel workers cannot find.
get_workflow <- function(model_spec, vExclude) {
    workflow() %>%
        add_variables(outcomes = y, predictors = c(-Id, -year, -year_month, -any_of(!!vExclude))) %>%
        add_model(model_spec)
}

# Tune a model on the training window with racing, train it with the best combination on the whole window, and
# predict the testing period
tune_fit_predict <- function(dfTrain_Proc, dfTest_Proc, modelType, vExclude, randomSeed = 2300) {

    model_spec <- get_model_spec(modelType)
    set.seed(randomSeed)
    folds <- vfold_cv(dfTrain_Proc, v = 5, strata = y)
    race <- get_workflow(model_spec, vExclude) %>%
        finetune::tune_race_anova(resamples = folds,
                                  grid = get_model_param_grid(modelType, randomSeed),
                                  metrics = class_metrics,
                                  control = finetune::control_race(burn_in = 3, parallel_over = "everything"))
    params_best <- select_best(race, metric = "roc_auc")
    set.seed(randomSeed)
    model_final <- get_workflow(model_spec, vExclude) %>%
        finalize_workflow(params_best) %>%
        fit(data = dfTrain_Proc)

    list(params = params_best %>% select(-.config),
         cv_roc_auc = show_best(race, metric = "roc_auc", n = 1)$mean,
         predictions = dfTest_Proc %>%
             select(Id, year_month, y) %>%
             mutate(.pred_yes = predict(model_final, dfTest_Proc, type = "prob")$.pred_yes))
}


# Parallel backend
########################################################################################################################################################
# As in Part 2: workers are capped at cores - 1 and at what fits in 70% of the available RAM, at 0.75 GB per worker.
gb_per_worker <- 0.75
gb_available <- ps::ps_system_memory()$avail / 1024^3
num_workers <- max(1, min(parallel::detectCores() - 1, floor(0.7 * gb_available / gb_per_worker)))
message(sprintf("Using %d parallel workers (%.1f GB RAM available)", num_workers, gb_available))
plan(multisession, workers = num_workers)


# Run the cycles
########################################################################################################################################################
lResults <- list()
dfTimings <- tibble(cycle = integer(), model = character(), feature_set = character(), seconds = numeric())
for (i in seq_len(nrow(dfCycles))) {

    cycle <- dfCycles[i, ]
    dfTrain <- dfCalls %>% filter(year_month >= cycle$train_start, year_month <= cycle$train_end)
    dfTest <- dfCalls %>% filter(year_month >= cycle$test_start, year_month <= cycle$test_end)

    # The testing period must be unseen: every training call comes before every testing call, and no call is in both
    stopifnot(max(dfTrain$year_month) < min(dfTest$year_month),
              length(intersect(dfTrain$Id, dfTest$Id)) == 0)

    # Trend features of the testing calls, relative to the last month of the training window (see "Trend features")
    reference_month <- dfMonthly %>% filter(year_month == max(dfTrain$year_month))
    dfTest <- dfTest %>%
        mutate(euribor_change = euribor3m - reference_month$euribor_mean,
               employed_change = nr.employed - reference_month$employed_mean,
               prev_month_rate = reference_month$rate)

    preprocessing_recipe <- get_preprocessing_recipe(dfTrain)
    dfTrain_Proc <- bake(preprocessing_recipe, new_data = NULL)
    dfTest_Proc <- bake(preprocessing_recipe, new_data = dfTest)

    for (feature_set in names(lFeatureSets)) {
        for (modelType in c("glmnet", "xgboost")) {
            t0 <- Sys.time()
            result <- tune_fit_predict(dfTrain_Proc, dfTest_Proc, modelType, lFeatureSets[[feature_set]])
            dfTimings <- dfTimings %>% add_row(cycle = cycle$cycle, model = modelType, feature_set = feature_set,
                                               seconds = as.numeric(difftime(Sys.time(), t0, units = "secs")))
            lResults[[length(lResults) + 1]] <- list(cycle = cycle$cycle, model = modelType, feature_set = feature_set,
                                                     params = result$params, cv_roc_auc = result$cv_roc_auc,
                                                     predictions = result$predictions)
        }
    }
    dfCycles$train_first[i] <- min(dfTrain$year_month)
    dfCycles$train_last[i] <- max(dfTrain$year_month)
    dfCycles$test_first[i] <- min(dfTest$year_month)
    dfCycles$test_last[i] <- max(dfTest$year_month)
    dfCycles$train_calls[i] <- nrow(dfTrain)
    dfCycles$train_rate[i] <- mean(dfTrain$y == "yes")
    dfCycles$test_calls[i] <- nrow(dfTest)
    dfCycles$test_rate[i] <- mean(dfTest$y == "yes")
}

plan(sequential)

# predictions for every call of every testing period, by model and feature set
dfSlidingPred <- map_dfr(lResults, ~ .x$predictions %>% mutate(cycle = .x$cycle, model = .x$model, feature_set = .x$feature_set))

# the hyperparameters chosen in each cycle, with their cross validated ROC AUC within the training window
dfCycleParams <- map_dfr(lResults, ~ tibble(cycle = .x$cycle, model = .x$model, feature_set = .x$feature_set,
                                            cv_roc_auc = .x$cv_roc_auc, params = list(.x$params)))

# the results that the post uses, which are saved to Bank_Sliding.Rda
vSlidingResults <- c("dfSlidingPred", "dfCycleParams", "dfCycles", "dfMonthly", "dfTimings", "num_workers",
                     "vFeaturesEconomic", "vFeaturesTrend", "lFeatureSets")

And this code decides whether to load the saved results or to run the sliding windows:

# The clean dataset and the dates of the calls from Part 1
bank_data_file <- "../bank-marketing-part1-eda/Bank_Marketing_Clean.Rda"

# Fingerprint (hash) of the inputs: the data that the code uses, and the code of the "sliding_steps" chunk.
# Comments and spacing are removed from the code first, so editing them does not start a new run.
envData <- new.env()
load(bank_data_file, envir = envData)
sliding_steps <- knitr::knit_code$get("sliding_steps")
sliding_hash <- rlang::hash(list(data = list(envData$dfClean, envData$dfCallDates),
                                 code = deparse(parse(text = sliding_steps, keep.source = FALSE))))

# If the saved results were made from the same inputs, load them. Otherwise, run the sliding windows again and save
# the new results together with the fingerprint of their inputs.
envSaved <- new.env()
if (file.exists("Bank_Sliding.Rda")) load("Bank_Sliding.Rda", envir = envSaved)
if (identical(envSaved$sliding_hash, sliding_hash)) {
  list2env(as.list(envSaved), envir = environment())
} else {
  eval(parse(text = sliding_steps))
  save(list = c(vSlidingResults, "sliding_hash"), file = "Bank_Sliding.Rda")
}
rm(envData, envSaved)

Time Series | Nitin Gupta

Bank Marketing - Part 3 - Keeping up with the times - Sliding Window Models

Other posts in this series:

The Timeline of the Calls

How the Sliding Windows Work

What’s notable?

Feature Sets

Results

All the Testing Periods Together

What’s notable?

Cycle by Cycle

What’s notable?

Predicted and Actual Subscription Rates

What’s notable?

The Hyperparameters Change from Cycle to Cycle

What’s notable?

Comparison with Part 2

How a Bank Could Use the Models

Conclusions

Appendix: Sliding Window Code