Quantum Jitter

Reticulating Tibbles

Carl Goodwin — Tue, 30 Apr 2024 23:00:00 GMT

What to do when a model is available (or installable) only in Python, but you code in R?

I want to try the deep-learning time-series package GluonTS on average house prices by London borough. There is an R wrapper for this, but also (at the time of writing) an open issue installing it on Apple silicon.

So, into the caldron boil and bake; a blended approach we will take.

Libraries (R)

library(conflicted)
library(tidyverse)
conflict_prefer_all("dplyr", quiet = TRUE)
library(paletteer)
library(scales)
library(janitor)
library(trelliscope)
library(reticulate)
library(clock)
library(glue)
library(gt)
library(tictoc)
library(patchwork)
library(rvest)
library(ggfoundry)
library(usedthese)

conflict_scout()

Theme (R)

theme_set(theme_bw())

n <- 5
pal_name <- "vangogh::Rest"

pal <- paletteer_d(pal_name)

display_palette(pal, pal_name)

Read & Combine (R)

raw_df <- readRDS("raw_df") # file in github repo

# covid cases
covid_df <- tribble(
  ~date, ~covid_cases,
  "2026-12-31", 0, # optimistic assumption!
  "2025-12-31", NA,
  "2024-12-31", NA,
  "2023-12-31", 570463,
  "2022-12-31", 8665437,
  "2021-12-31", 9461237,
  "2020-12-31", 2327686
) |> 
  mutate(
    date = ymd(date), 
    covid_cases = zoo::na.approx(covid_cases)
    )

# mortgage rates
morgage_df <- str_c(
  "https://www.bankofengland.co.uk/boeapps/database/",
  "fromshowcolumns.asp?Travel=NIxAZxSUx&FromSeries=1&ToSeries=50&",
  "DAT=ALL&",
  "FNY=Y&CSVF=TT&html.x=66&html.y=26&SeriesCodes=", "IUMBV42",
  "&UsingCodes=Y&Filter=N&title=Quoted%20Rates&VPD=Y"
) |>
  read_html() |>
  html_element("#stats-table") |>
  html_table() |>
  clean_names() |>
  mutate(date = dmy(date)) |>
  filter(month(date) == 12) |> 
  rename(morg_rate = 2) |> 
  mutate(morg_rate = morg_rate / 100) |> 
  add_row(date = ymd("2024-12-31"), morg_rate = 0.0371) |> 
  add_row(date = ymd("2025-12-31"), morg_rate = 0.0320) |> 
  add_row(date = ymd("2026-12-31"), morg_rate = 0.0304) # poundf.co.uk/mortgage-rates

long_df <- raw_df |> 
  row_to_names(row_number = 1) |> 
  clean_names() |> 
  rename(district = na) |> 
  select(
    district, 
    date = ncol(raw_df),
    price = overall_average,
    volume = total_sales
    ) |> 
  filter(
    district != "Total", 
    !is.na(district), 
    .by = district
    ) |> 
  mutate(
    across(c(price, volume), as.numeric),
    date = date_build(date, 12, 31),
    district = factor(district)
    ) |> 
  full_join(covid_df, join_by(date)) |> 
  full_join(morgage_df, join_by(date)) |> 
  complete(district, date) |> 
  arrange(date, district) |> 
  group_by(date) |> 
  fill(covid_cases, morg_rate, .direction = "up") |> 
  ungroup() |> 
  drop_na(district) |> 
  arrange(district, date)

long_df |> glimpse()

Rows: 1,056
Columns: 6
$ district     BARKING AND DAGENHAM, BARKING AND DAGENHAM, BARKING AND DA…
$ date         1995-12-31, 1996-12-31, 1997-12-31, 1998-12-31, 1999-12-3…
$ price        50568, 51692, 56234, 63893, 69511, 84149, 94483, 118906, 1…
$ volume       1504, 1906, 2449, 2515, 2698, 2829, 3230, 3473, 3513, 3498…
$ covid_cases  NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA…
$ morg_rate    0.0813, 0.0827, 0.0740, 0.0636, 0.0692, 0.0620, 0.0565, 0.…

long_df |> count(district) |> head()

district	n
BARKING AND DAGENHAM	32
BARNET	32
BEXLEY	32
BRENT	32
BROMLEY	32
CAMDEN	32

Visualise Examples (R)

long_df |>
  mutate(district = as.character(district)) |>
  filter(district %in% c("KENSINGTON AND CHELSEA", "RICHMOND UPON THAMES")) |>
  pivot_longer(-c(date, district), names_to = "var") |>
  mutate(var = fct_inorder(var)) |>
  split(~ district + var) |>
  imap(
    \(x, y) {
      scale_y <- if (str_ends(y, "price")) {
        scale_y_continuous(
          name = "Average\nPrice",
          label = label_currency(scale_cut = cut_short_scale(), prefix = "£")
        )
      } else if (str_ends(y, "volume")) {
        scale_y_continuous(
          name = "Sales\nVolume",
          labels = label_number(scale_cut = cut_short_scale())
          )
      } else if (str_ends(y, "covid_cases")) {
        scale_y_continuous(
          name = "Covid\nCases",
          labels = label_number(scale_cut = cut_short_scale())
          )
      } else {
        scale_y_continuous(
          name = "5yr\nFixed",
          labels = label_percent()
          )
      }
      remove_strip <- if (!str_ends(y, "price$")) theme(strip.text = element_blank())

      x |>
        ggplot(aes(date, value)) +
        annotate("rect",
          xmin = ymd("2023-12-31"), xmax = ymd("2026-12-31"),
          ymin = -Inf, ymax = Inf, alpha = 0.2, fill = pal[1]
        ) +
        geom_line() +
        scale_y +
        facet_wrap(~district, scales = "free_y") +
        remove_strip +
        labs(x = NULL)
    }
  ) |>
  wrap_plots(
    ncol = 2
  ) + plot_layout(
    heights = c(3, 1, 1, 1),
    axes = "collect_x",
    axis_titles = "collect"
  ) +
  plot_annotation(
    title = "Two Example London Boroughs",
    subtitle = "Homes of Chelsea FC and the Fictional Richmond FC",
    caption = "Sources: Land Registry, ONS & BoE"
  )

Install gluonTS (R)

py_install("gluonts", "r-reticulate", pip = TRUE, ignore_installed = TRUE)

py_list_packages("r-reticulate")

Model (Python)

By prefixing long_df with r., Python can access the R object.

import pandas as pd
import numpy as np
import json
import torch

from gluonts.dataset.pandas import PandasDataset
from gluonts.torch import DeepAREstimator
from gluonts.dataset.split import split
from gluonts.evaluation import make_evaluation_predictions, Evaluator
from itertools import tee
from lightning.pytorch.callbacks import EarlyStopping
from lightning.pytorch.loggers import CSVLogger
from lightning.pytorch import seed_everything

full_ds = PandasDataset.from_long_dataframe(
  r.long_df,
  item_id = "district",
  freq = "Y",
  target = "price",
  feat_dynamic_real = ["covid_cases", "morg_rate"],
  past_feat_dynamic_real = ["volume"],
  future_length = 3,
  timestamp = "date")
  
test_ds, _ = split(full_ds, offset = -1)
val_ds, _ = split(full_ds, offset = -2)
train_ds, _ = split(full_ds, offset = -3)
  
seed_everything(20, workers = True)

np.random.seed(123)
torch.manual_seed(123)


early_stop_callback = EarlyStopping("val_loss", min_delta = 1e-4, patience = 5)
logger = CSVLogger(".")

estimator = DeepAREstimator(
  freq = "Y", 
  hidden_size = 100,
  prediction_length = 1, 
  num_layers = 2,
  lr = 0.01,
  batch_size = 128,
  num_batches_per_epoch = 100,
  trainer_kwargs = {
    "max_epochs": 50,
    "deterministic": True,
    "enable_progress_bar": False,
    "enable_model_summary": False,
    "logger": logger,
    "callbacks": [early_stop_callback]
    },
  nonnegative_pred_samples = True)
  
test_predictor = estimator.train(train_ds, val_ds)

Learning Curve (R)

version <- list.files("lightning_logs") |> parse_number() |> max()

log_df <- read_csv(str_c("lightning_logs/version_", version, "/metrics.csv"),
  show_col_types = FALSE
)

log_df |>
  select(-step) |>
  mutate(
    best_val = if_else(val_loss == min(val_loss, na.rm = TRUE), val_loss, NA),
    best_epoch = if_else(!is.na(best_val), glue("Best Epoch\n{epoch}"), NA)
  ) |>
  pivot_longer(ends_with("_loss"), values_drop_na = TRUE) |>
  mutate(name = case_match(
    name,
    "train_loss" ~ "Training",
    "val_loss" ~ "Validation",
  )) |>
  ggplot(aes(epoch, value, colour = name)) +
  geom_line() +
  geom_point(aes(y = best_val), show.legend = FALSE) +
  geom_label(
    aes(label = best_epoch),
    size = 2,
    nudge_y = 0.2,
    show.legend = FALSE
  ) +
  labs(
    title = "GluonTS Learning Curve",
    subtitle = glue("Lightning Log Version {version}"),
    x = "Epoch",
    y = "Loss",
    colour = NULL
  )

Test (Python)

test_fcast = list(test_predictor.predict(test_ds))

seed_everything(42, workers = True)

np.random.seed(123)
torch.manual_seed(123)

# Train and predict
forecast_it, ts_it = make_evaluation_predictions(
    dataset = train_ds, 
    predictor = test_predictor,
    num_samples = 1000
)

# Copy iterators
ts_it, targets = tee(ts_it) 
forecast_it, predictions = tee(forecast_it) 

# Calculate metrics
evaluator = Evaluator(quantiles=[0.05, 0.5, 0.95])
agg_metrics, item_metrics = evaluator(
    ts_it, 
    forecast_it, 
    num_series = len(test_ds)
)

Metrics (R)

By prefixing agg_metrics with py$, R can access the Python object.

aggregated <- as.numeric(py$agg_metrics["MAPE"])

col <- compose(as.character, \(x) pal[x])

py$item_metrics |> 
  select(item_id, MAPE) |> 
  mutate(item_id = fct_reorder(item_id, MAPE)) |> 
  ggplot(aes(MAPE, item_id)) +
  geom_vline(xintercept = aggregated, linetype = "dashed", colour = col(2)) +
  geom_point() +
  scale_x_log10() +
  labs(
    title = "Test Metric by Borough", 
    subtitle = glue("Overall MAPE {round(aggregated, 3)}"), 
    x = "MAPE (log10 scale)", y = NULL
    )

Final Model (Python)

estimator = DeepAREstimator(
  freq = "Y", 
  hidden_size = 100,
  prediction_length = 3, 
  num_layers = 2,
  lr = 0.01,
  batch_size = 128,
  num_batches_per_epoch = 100,
  trainer_kwargs = {
    "max_epochs": 12,
    "deterministic": True,
    "enable_progress_bar": False,
    "enable_model_summary": False,
    },
  nonnegative_pred_samples = True)

seed_everything(42, workers = True)

np.random.seed(123)
torch.manual_seed(123)


final_predictor = estimator.train(full_ds)

future_fcast = list(final_predictor.predict(full_ds))

Forecast (R)

fc_ls = c(py$test_fcast, py$future_fcast)

years_df <- fc_ls |>
  map("mean_ts") |>
  map(as.data.frame.table) |>
  list_rbind() |>
  mutate(
    date = Var1,
    fcast = Freq,
    .keep = "unused"
  )

quantiles_df <- map(1:length(fc_ls), \(x) {
  fc_ls[[x]]$`_sorted_samples` |>
    as_tibble() |>
    reframe(
      across(everything(), \(x) quantile(x, probs = c(0.05, 0.1, 0.5, 0.9, 0.95))),
      quantile = c("pi90_low", "pi80_low", "median", "pi80_high", "pi90_high")
    ) |>
    pivot_longer(-quantile, names_to = "window") |>
    mutate(sample = x, district = fc_ls[[x]]$item_id)
}, .progress = TRUE) |>
  list_rbind() |>
  pivot_wider(names_from = quantile, values_from = value) |>
  bind_cols(years_df) |>
  pivot_longer(starts_with("pi"), names_to = c("pi", ".value"), names_pattern = "(.*)_(.*)") |>
  nest(.by = c(district, sample)) |>
  mutate(sample = row_number(), .by = district) |>
  unnest(data) |>
  mutate(pi_sample = str_c(`pi`, "-", sample) |> factor()) |>
  arrange(district, date, sample) |>
  mutate(date = str_c(date, "-12", "-31") |> ymd())

districts <- long_df |> summarise(n_distinct(district)) |> pull()

Trelliscope (R)

panels_df <- long_df |>
  left_join(quantiles_df, join_by(district, date)) |> 
  ggplot(aes(date, price)) +
  geom_line() +
  geom_ribbon(aes(y = median, ymin = low, ymax = high, fill = fct_rev(pi_sample)),
    alpha = 1, linewidth = 0) +
  geom_line(aes(date, median), colour = "white") +
  scale_fill_manual(values = pal[c(1, 1, 5, 5)]) +
  scale_y_continuous(labels = label_currency(scale_cut = cut_short_scale(), prefix = "£")) +
  facet_panels(vars(district), scales = "free_y") +
  labs(
    title = glue("Price Forecasts for {districts} Postal Districts"),
    subtitle = "Backtest & Future Forecasts with 80 & 90% Prediction Intervals",
    caption = "DeepAR: Probabilistic Forecasting with Autoregressive Recurrent Networks",
    x = NULL, y = "Avg Price", fill = "Prediction\nInterval"
    ) +
  theme(legend.position = "none")

slope <- \(x, y) coef(lm(y ~ x))[2]

summary_df <- long_df |>
  summarise(
    last_price = nth(price, -4),
    slope = slope(date, price),
    .by = district)

panels_df |>
  as_panels_df(as_plotly = TRUE) |>
  as_trelliscope_df(
    name = "Average London House Prices",
    description = str_c(
      "Time series of house prices by London post code district ",
      "sourced from HM Land Registry Open Data."
    )
  ) |>
  left_join(summary_df, join_by(district)) |>
  set_default_labels(c("district", "last_price")) |>
  set_var_labels(
    district = "Post Code District",
    last_price = "Last Year's Avg Price"
  ) |>
  set_default_sort(c("last_price"), dirs = "desc") |>
  set_tags(
    stats = c("last_price", "slope"),
    info = "district"
  ) |>
  view_trelliscope()

R Toolbox

Summarising below the packages and functions used in this post enables me to separately create a toolbox visualisation summarising the usage of packages and functions across all posts.

used_here()

Package	Function
base	as.character[1], as.numeric[1], c[14], col[1], factor[2], if[4], is.na[2], length[1], library[15], list[2], list.files[1], max[1], min[1], ncol[1], readRDS[1], round[1], saveRDS[1], split[4]
clock	date_build[1]
conflicted	conflict_prefer_all[1], conflict_scout[1]
dplyr	across[2], arrange[3], bind_cols[1], case_match[1], count[1], filter[3], full_join[2], group_by[1], if_else[2], join_by[4], left_join[2], mutate[15], n_distinct[1], nth[1], pull[1], reframe[1], rename[2], row_number[1], select[3], summarise[2], ungroup[1], vars[1]
forcats	fct_inorder[1], fct_reorder[1], fct_rev[1]
ggfoundry	display_palette[1]
ggplot2	aes[8], annotate[1], element_blank[1], facet_wrap[1], geom_label[1], geom_line[4], geom_point[2], geom_ribbon[1], geom_vline[1], ggplot[4], labs[4], scale_fill_manual[1], scale_x_log10[1], scale_y_continuous[5], theme[2], theme_bw[1], theme_set[1]
glue	glue[4]
janitor	clean_names[2], row_to_names[1]
lubridate	dmy[1], month[1], ymd[7]
paletteer	paletteer_d[1]
patchwork	plot_annotation[1], plot_layout[1], wrap_plots[1]
pillar	glimpse[1]
purrr	compose[1], imap[1], list_rbind[3], map[4]
readr	parse_number[1], read_csv[2]
reticulate	py_install[1], py_list_packages[1]
rvest	html_element[1], html_table[1]
scales	cut_short_scale[4], label_currency[2], label_number[2], label_percent[1]
stats	coef[1], lm[1], quantile[1]
stringr	str_c[7], str_ends[4]
tibble	add_row[3], as_tibble[1], tribble[1]
tictoc	tic[1], toc[1]
tidyr	complete[1], drop_na[1], fill[1], nest[1], pivot_longer[4], pivot_wider[1], unnest[1]
tidyselect	ends_with[1], everything[1], starts_with[1]
trelliscope	as_panels_df[1], as_trelliscope_df[1], facet_panels[1], set_default_labels[1], set_default_sort[1], set_tags[1], set_var_labels[1], view_trelliscope[1]
usedthese	used_here[1]
utils	head[1]
xml2	read_html[1]
zoo	na.approx[1]

Bayes Lived Here (Probably)

Carl Goodwin — Sun, 11 Jun 2023 23:00:00 GMT

It’s quite common in the UK, and London in particular, for prominent individuals, such as Dickens, Darwin and Galton, who passed at least 20 years ago, to be commemorated by a plaque on a building in which they lived or with which they were associated.

Thomas Bayes lived in Tunbridge Wells, a few miles to the north of London. His former home has a plaque on the front gate. I couldn’t resist a little digital graffiti.

Mortgages weren’t a thing back then. So I wonder what he would have made of modelling fixed mortgage interest rates with Bayesian linear regression and tuning tree-based models with Bayesian optimisation.

library(conflicted)
library(tidyverse)
conflict_prefer_all("dplyr", quiet = TRUE)
library(tidymodels)
library(feasts)
library(tsibble)
library(glue)
library(scales)
library(patchwork)
library(ggfx)
library(janitor)
library(rvest)
library(broom.mixed)
library(imputeTS)
library(readxl)
library(rstantools)
library(shapviz)
library(kernelshap)
library(finetune)
library(tictoc)
library(ggfoundry)
library(usedthese)

conflict_scout()

theme_set(theme_bw())

pal <- c(
  "#7E1134", "#EDD5C5",
  "#057683", "#F3E2D8",
  "black", "#7F7E7C"
)

pal_name <- "Palette from Feature Image"

display_palette(pal, pal_name)

Banks review their mortgage interest rates in response to changes in the central bank rate. Fixed-rate mortgages are further influenced by the value of gilts (government bonds). Banks rely less on the wholesale market to fund mortgages when their balance sheet is well supported by savings made by households.

So, to forecast an average fixed 5-year (75% loan-to-value) mortgage rate (mortgage), I’ll try using the central bank rate (cbr), the 5-year yield from British Government Securities (gilt), the ratio of retail deposits to the value of outstanding mortgages (retail_ratio) and the number of new mortgage approvals (approvals). All sourced from the Bank of England¹.

get_rate <- \(y, z) {
  url <-
    str_c(
      "https://www.bankofengland.co.uk/boeapps/database/",
      "fromshowcolumns.asp?Travel=NIxAZxSUx&FromSeries=1&ToSeries=50&",
      "DAT=ALL&",
      "FNY=Y&CSVF=TT&html.x=66&html.y=26&SeriesCodes=", y,
      "&UsingCodes=Y&Filter=N&title=Quoted%20Rates&VPD=Y"
    )
  
  read_html(url) |>
    html_element("#stats-table") |>
    html_table() |>
    clean_names() |>
    mutate(date = dmy(date)) |> 
    rename({{ z }} := 2)
}

pwalk(
  list(
    x = c("cbr_df", "mor_df", "gil_df", "ret_df", "out_df", "app_df"),
    y = c("IUMBEDR", "IUMBV42", "IUMSNPY", "LPMVRJX", "LPMB3TA", "LPMB3VA"),
    z = c("cbr", "mortgage", "gilt", "retail", "outstanding", "approvals")
  ),
  \(x, y, z) assign(x, get_rate(y, {{ z }}), .GlobalEnv)
)

boe_list <- list(cbr_df, mor_df, gil_df, ret_df, out_df, app_df)

joined_df <- 
  reduce(boe_list, left_join, join_by(date)) |> 
  filter(date <= "2023-04-30") |>
  mutate(retail_ratio = retail / outstanding) |>
  select(-retail, -outstanding)

To enable forecasting to year-end, forward-looking estimates are required for the predictors: cbr², gilt³ and approvals⁴. Imputation is used to linearly interpolate the interim months.

forward_df <- joined_df |>
  rows_append(
    tribble(
      ~date, ~cbr, ~gilt, ~approvals, 
      ymd("2023-06-30"), 4.57, 4.29, 49000, 
      ymd("2023-09-30"), 4.90, NA, NA,
      ymd("2023-12-31"), 4.92, NA, NA,
      ymd("2024-03-31"), 4.64, NA, NA,
      ymd("2024-06-30"), 4.30, 4.92, 68000, 
    )
  )

filled_df <-
  tibble(date = seq(
    joined_df$date |> nth(-2L) |> floor_date("month"),
    forward_df$date |> last() |> floor_date("month"),
    by = "month"
  )) |>
  mutate(date = rollforward(date)) |>
  left_join(forward_df, join_by(date)) |>
  mutate(across(-c(date, mortgage), na_interpolation)) 

forecast_df <-
  bind_rows(actual = joined_df, forecast = filled_df, .id = "id") |>
  arrange(date, id) |>
  distinct(date, .keep_all = TRUE) |>
  mutate(across(c(gilt, cbr),
    list(
      lag1 = lag,
      lag2 = \(x) lag(x, 2),
      lag3 = \(x) lag(x, 3),
      lag12 = \(x) lag(x, 12)
    ),
    .names = "{.col}_{.fn}"
  )) |>
  filter(date >= "1995-01-01", date <= "2023-12-31") |> 
  mutate(mortgage_cut = cut_number(mortgage, 10))

All these historical data and forward-looking estimates may then be visualised to get an overall view.

plot_compare <- \(x){
  forecast_df |>
    ggplot(aes(date, {{ x }}, colour = id)) +
    geom_line() +
    geom_vline(xintercept = ymd("2023-04-30"), linetype = "dashed", colour = "grey60") +
    scale_colour_manual(values = as.character(pal[c(5, 3)])) +
    scale_x_date(date_breaks = "2 years", date_labels = "%Y") +
    scale_y_continuous(labels = label_number(suffix = "%")) +
    labs(x = NULL, colour = NULL) +
    theme(
      axis.text.x = element_blank(),
      axis.ticks.x = element_blank(),
      legend.position = "none"
    )
}

p1 <- plot_compare(cbr) +
  labs(title = "Key Rates", y = "Central\nBank Rate") +
  theme(legend.position = "right")

p2 <- plot_compare(gilt) +
  labs(y = "5-year\nGilt")

p3 <- plot_compare(retail_ratio) +
  scale_y_continuous(labels = label_number()) +
  labs(y = "Retail\nRatio")

p4 <- plot_compare(approvals) +
  scale_y_continuous(labels = label_number()) +
  labs(y = "Approvals")

p5 <- plot_compare(mortgage) +
  labs(y = "Fixed 5-year\nMortgage") +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1),
    axis.ticks.x = element_line()
  )

p1 / p2 / p3 / p4 / p5

Cross-correlation shows not only the strength of the relationship between the response (mortgage) and explanatory variables, but also highlights any lagged effects. Spikes outside the dashed lines indicate significant correlation beyond “white noise”.

plot_xcorr <- \(x){
  forecast_df |>
    mutate(date = yearmonth(date)) |>
    as_tsibble(index = date) |>
    CCF({{ x }}, mortgage, lag_max = 40) |>
    autoplot() +
    scale_y_continuous(limits = c(-1, 1)) +
    labs(y = NULL) +
    theme(
      axis.text.y = element_blank(),
      axis.ticks.y = element_blank()
    )
}

c1 <- plot_xcorr(cbr) +
  labs(title = "CBR", y = "Cross Correlation") +
  theme_bw()

c2 <- plot_xcorr(gilt) +
  ggtitle("Gilt")

c3 <- plot_xcorr(retail_ratio) +
  ggtitle("Retail Ratio")

c4 <- plot_xcorr(approvals) +
  ggtitle("Approvals")

c1 + c2 + c3 + c4 + 
  plot_layout(nrow = 1) +
  plot_annotation(title = "5-year Fixed-rate Mortgage Correlated With:")

history_df <- forecast_df |>
  filter(id == "actual")

plot_lm <- \(x) {
  history_df |>
    ggplot(aes({{ x }}, mortgage)) +
    geom_point() +
    geom_smooth(method = "lm", colour = pal[3]) +
    scale_x_continuous(labels = label_number(accuracy = 0.1, suffix = "%")) +
    scale_y_continuous(labels = label_number(accuracy = 0.1, suffix = "%")) +
    theme(
      axis.text.y = element_blank(),
      axis.ticks.y = element_blank()
    ) +
  labs(y = NULL)
}

l1 <- plot_lm(cbr) +
  labs(y = "Mortgage") +
  theme_bw()

l2 <- plot_lm(gilt)

l3 <- plot_lm(retail_ratio) +
  scale_x_continuous(labels = label_number(accuracy = 0.1))

l4 <- plot_lm(approvals) +
  scale_x_continuous(
    labels = label_number(
      accuracy = 1,
      scale_cut = cut_short_scale()
    )
  )

l1 + l2 + l3 + l4 + 
  plot_annotation(title = "Independent vs Potential Explanatory Variables") +
  plot_layout(nrow = 1)

One could try a time series model⁵, e.g. ARIMA. This would focus on patterns and pattern changes in the historical mortgage data, i.e. autocorrelation, seasonality and trend. External regressors like cbr and gilt, could then be additionally used to reduce any remaining unexplained variance. The train/test split would be a time-based split. This kind of statistical technique works well when relationships and trends in the historical data are clear and fairly stable such as, for example, with electricity consumption.

A causal model feels more appropriate here. Use of linear or non-linear regression would place the principal focus on the external variables. A causal model also allows the train/test split to be sampled from across the full series rather than requiring a time-based split.

The tidymodels ecosystem, including workflowsets (Kuhn and Couch 2023), will facilitate the fitting and tuning of multiple models with differing recipes: Linear and Bayesian regression models (the latter using weakly informative prior distributions via the rstanarm package (Goodrich et al. 2023)) and the non-linear tree-based models Random Forest and XGBoost.

set.seed(1)

data_split <- history_df |>
  initial_split(strata = mortgage_cut)

train <- training(data_split)
test <- testing(data_split)

core_recipe <-
  train |> 
  recipe() |>
  update_role(mortgage, new_role = "outcome") |>
  update_role(id, date, mortgage_cut, new_role = "id") |> 
  update_role(-has_role(c("outcome", "id")), new_role = "predictor") |> 
  step_date(date, features = "decimal")

ns_recipe <-
  core_recipe |>
  step_ns(date_decimal, deg_free = 6) |> 
  step_ns(cbr, deg_free = 5) |> 
  step_ns(gilt, approvals, deg_free = 4) |>
  step_ns(retail_ratio, deg_free = 2) 

lm_model <- 
  linear_reg()

rf_model <-
  rand_forest(
    mode = "regression",
    trees = 756,
    mtry = 5,
    min_n = 2
  )

xgb_model <-
  boost_tree(
    mode = "regression",
    learn_rate = 0.01,
    trees = 1054,
    tree_depth = 14,
    mtry = 3,
    min_n = 3,
  )

bayes_model <-
  linear_reg() |>
  set_engine("stan", refresh = 1)

model_set <-
  workflow_set(
    preproc = list(
      ns = ns_recipe,
      ns = ns_recipe,
      core = core_recipe,
      core = core_recipe
    ),
    models = list(
      lm = lm_model,
      bayes = bayes_model,
      rf = rf_model,
      xgb = xgb_model
    ),
    cross = FALSE
  )

# core_recipe |> prep() |> bake(new_data = NULL)

set.seed(9)

folds <- train |> vfold_cv(strata = mortgage_cut)

# --- Comment out for fit_resamples
# params <- model_set |>
#   extract_workflow("core_rf") |>  # core_xgb
#   parameters() |>
#   update(mtry = finalize(mtry(), train))
# ---------------------------------

doParallel::registerDoParallel()

tic()

set_results <- model_set |>
  workflow_map("fit_resamples",
    # workflow_map("tune_bayes", # Comment out for fit_resamples
    resamples = folds,
    # param_info = params, # Comment out for fit_resamples
    metrics = metric_set(rmse),
    initial = 10,
    iter = 50,
    control = control_bayes(save_workflow = TRUE, no_improve = 30),
    seed = 1
  )

toc()

30.721 sec elapsed

set_results |>
  rank_results() |>
  slice_head(n = 1, by = wflow_id) |>
  mutate(
    tune = str_extract(.config, "\\d?\\d$"),
    model = str_extract(wflow_id, "(?<=_).*$"),
    wflow_id = str_c(wflow_id, " ", tune) |> fct_reorder(.x = mean)
  ) |>
  ggplot(aes(wflow_id, mean,
    ymin = mean - std_err,
    ymax = mean + std_err, colour = model
  )) +
  geom_pointrange(position = position_dodge(width = 0.9)) +
  geom_label(aes(label = tune)) +
  scale_colour_manual(values = pal[c(1, 3, 5, 6)]) +
  labs(
    x = NULL, y = "Mean RMSE",
    title = "Workflow Ranking (Label = Tune Iteration)"
  ) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

# --- Comment out for fit_resamples
# set_results |>
#   extract_workflow_set_result("core_rf") |> # core_xgb
#   unnest(.metrics) |>
#   summarise(.estimate = mean(.estimate), .config = first(.config),
#             .by = c(trees, mtry, min_n)) |> # tree_depth
#   arrange(.estimate) |>
#   slice_head(n = 1)
# ---------------------------------

The models may then be assessed against the test data.

aug_train <- \(x){
  set.seed(2023)

  set_results |>
    filter(wflow_id == x) |>
    fit_best(metric = "rmse") |>
    augment(test)
}

walk2(
  c("xgb_res", "rf_res", "lm_res", "bayes_res"),
  c("core_xgb", "core_rf", "ns_lm", "ns_bayes"),
  \(x, y) assign(x, aug_train(y), .GlobalEnv)
)

The residuals from the trained model used on the test data look quite reasonable aside a small curvature pattern in the linear models. The presence of a pattern could suggest a missing explanatory variable(s), or non-linearity if present only in linear models.

focus_df <- bind_rows(
  rf = rf_res |> mutate(model = "Random Forest"),
  xgb = xgb_res |> mutate(model = "XGBoost"),
  lm = lm_res |> mutate(model = "Linear"),
  bayes = bayes_res |> mutate(model = "Bayes"),
  .id = "id"
)

label_df <- focus_df |>
  nest(-c(id, model)) |>
  mutate(metric = map(data, \(x) rmse(x, mortgage, .pred))) |>
  unnest(metric) |>
  mutate(mortgage = 7.5, .pred = 3.5, .estimate = round(.estimate, 4))

focus_df |>
  ggplot(aes(.pred, mortgage)) +
  geom_point(alpha = 0.5, size = 0.5) +
  geom_abline(alpha = 0.5) +
  geom_smooth(se = FALSE, size = 0.5) +
  geom_label(aes(label = glue("RMSE\n{.estimate}")),
    data = label_df, size = 3, fill = pal[2]
  ) +
  coord_obs_pred() +
  facet_wrap(~model) +
  labs(
    title = "Observed vs Predicted Mortgage Rates",
    subtitle = "Test Data",
    x = "Predictions", y = "Observations"
  )

focus_df |>
  mutate(residual = mortgage - .pred) |>
  ggplot(aes(sample = residual, colour = id)) +
  geom_qq() +
  geom_qq_line() +
  facet_wrap(~model) +
  scale_y_continuous(limits = c(-1, 1)) +
  scale_colour_manual(values = pal[c(1, 3, 5, 6)]) +
  labs(title = "QQ Plot of Residuals", subtitle = "Test Data")

focus_df |>
  mutate(residual = mortgage - .pred) |>
  ggplot(aes(date, residual, colour = id)) +
  geom_hline(yintercept = 0, linetype = "dashed", colour = pal[3], linewidth = 1) +
  geom_point() +
  geom_smooth() +
  facet_wrap(~model) +
  scale_x_date(date_breaks = "2 years", date_labels = "%Y") +
  scale_y_continuous(limits = c(-1, 1)) +
  scale_colour_manual(values = pal[c(1, 3, 5, 6)]) +
  labs(title = "Residuals Over Time", subtitle = "Test Data", x = NULL, y = "Residuals") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

It makes sense to now train the tuned model(s) on all the historical data.

fit_hist <- \(y){
  set.seed(2023)

  model_set |>
    extract_workflow(y) |>
    fit(data = history_df)
}

walk2(
  c("xgb_fit", "rf_fit", "bayes_fit", "lm_fit"),
  c("core_xgb", "core_rf", "ns_bayes", "ns_lm"),
  \(x, y) assign(x, fit_hist(y), .GlobalEnv)
)

aug_fit <- \(y) y |> augment(forecast_df)

walk2(
  c("xgb_res", "rf_res", "bayes_res", "lm_res"),
  list(xgb_fit, rf_fit, bayes_fit, lm_fit),
  \(x, y) assign(x, aug_fit(y), .GlobalEnv)
)

Feature importance unsurprisingly confirms higher gilt and cbr values equate to higher mortgage rates.

set.seed(2023)

make_shap <- \(y){
  kernelshap(y,
    X = forecast_df,
    bg_X = train |> slice_sample(n = 50),
    feature_names = train |> select(-c(id, mortgage, mortgage_cut)) |> names(),
    parallel = TRUE
  ) |>
    shapviz()
}

tic()

walk2(
  c("xgb_shap", "rf_shap", "bayes_shap", "lm_shap"),
  list(xgb_fit, rf_fit, bayes_fit, lm_fit),
  \(x, y) assign(x, make_shap(y), .GlobalEnv)
)

toc()

mshap <- c(bayes = bayes_shap, xgb = xgb_shap, lm = lm_shap, rf = rf_shap)

# 119.9 sec elapsed

sv_importance(mshap, "beeswarm", color_bar_title = NULL) +
  plot_annotation(title = "Feature Importance (Yellow = High Feature Value)")

row_id <- last(which(forecast_df$date == max(forecast_df$date)))

sv_waterfall(mshap, row_id = row_id, max_display = 14) +
  plot_annotation(
    title = glue("{stamp('March 1, 2000')(max(forecast_df$date))} Waterfall")
  )

Whilst modelling with Bayesian (in contrast to linear) regression comes with the computational cost of Markov Chain Monte Carlo (MCMC) simulation, the pay-off is the provision of a credible range of values for each of the parameters in addition to the coefficient point estimates.

ci <- tidy(bayes_fit, conf.int = TRUE, conf.level = 0.9)

as.data.frame(extract_fit_engine(bayes_fit)) |>
  pivot_longer(everything(), names_to = "term") |>
  filter(term != "sigma") |>
  ggplot(aes(value)) +
  as_reference(geom_density(fill = "white"), id = "density") +
  with_blend(
    geom_rect(
      aes(
        x = NULL, y = NULL, xmin = conf.low, xmax = conf.high,
        ymin = -Inf, ymax = Inf, fill = term
      ),
      data = ci, colour = "grey50", fill = pal[1],
    ),
    bg_layer = "density", blend_type = "atop"
  ) +
  geom_vline(aes(xintercept = estimate),
    colour = "white",
    linetype = "dashed", data = ci
  ) +
  geom_density(colour = "grey50") +
  facet_wrap(~term, scales = "free") +
  labs(
    y = "Density", fill = "Term",
    title = "Bayesian Posterior Distributions", x = "Value",
    subtitle = "Terms with 90% Plausible Interval"
  ) +
  theme(legend.position = "none")

The plot below shows the final point estimate for each model as well as a 90% prediction interval for the Bayesian model using rstantools (Gabry et al. 2023).

The forecasts are, at least initially, directionally similar. The test residuals and RMSE would favour the non-linear models, and XGBoost in particular, over the linear models for these data. The forecasts are further dependent upon the quality of the forward-looking externally-sourced estimates for the predictors.

pi <- predictive_interval(extract_fit_engine(bayes_fit),
  newdata = ns_recipe |> prep() |> bake(new_data = forecast_df),
  prob = 0.9
) |>
  as_tibble() |>
  mutate(date = forecast_df$date)

bind_rows(
  xgb = xgb_res,
  bayes = bayes_res,
  rf = rf_res,
  lm = lm_res,
  .id = "model"
) |>
  left_join(pi, join_by(date)) |>
  mutate(across(c(`5%`, `95%`), \(x) if_else(model != "bayes", NA, x))) |>
  ggplot(aes(date, .pred, ymin = `5%`, ymax = `95%`, colour = model, fill = model)) +
  geom_ribbon(fill = pal[1], alpha = 0.3) +
  geom_line() +
  geom_vline(xintercept = ymd("2023-04-30"), linetype = "dashed", colour = "grey70") +
  scale_y_continuous(
    labels = label_number(suffix = "%"),
    breaks = c(2, 4, 6, 8, 10)
  ) +
  scale_x_date(date_breaks = "2 years", date_labels = "%Y") +
  scale_colour_manual(values = pal[c(1, 3, 5, 6)]) +
  scale_fill_manual(values = pal[c(1, 3, 5, 6)]) +
  labs(
    title = "Forecast of Average UK Household Mortgage Rates",
    subtitle = "Fixed 5-year (75% Loan-to-Value)",
    x = NULL, y = "Interest Rate",
    caption = "Source Data: BoE"
  ) +
  facet_wrap(~model) +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1),
    legend.position = "none"
  )

R Toolbox

Summarising below the packages and functions used in this post enables me to separately create a toolbox visualisation summarising the usage of packages and functions across all posts.

used_here()

Package	Function
base	as.character[1], as.data.frame[1], assign[5], c[27], library[21], list[7], max[2], names[1], readRDS[1], round[1], seq[1], set.seed[5], which[1]
conflicted	conflict_prefer_all[1], conflict_scout[1]
doParallel	registerDoParallel[1]
dplyr	across[3], arrange[1], bind_rows[3], distinct[1], filter[5], if_else[1], join_by[3], lag[3], last[2], left_join[2], mutate[18], nth[1], rename[1], rows_append[1], select[2], slice_head[1], slice_sample[1], tribble[1]
feasts	CCF[1]
forcats	fct_reorder[1]
generics	augment[2], fit[1], tidy[1]
ggfoundry	display_palette[1]
ggfx	as_reference[1], with_blend[1]
ggplot2	aes[12], autoplot[1], cut_number[1], element_blank[6], element_line[1], element_text[4], facet_wrap[5], geom_abline[1], geom_density[2], geom_hline[1], geom_label[2], geom_line[2], geom_point[3], geom_pointrange[1], geom_qq[1], geom_qq_line[1], geom_rect[1], geom_ribbon[1], geom_smooth[3], geom_vline[3], ggplot[8], ggtitle[3], labs[16], position_dodge[1], scale_colour_manual[5], scale_fill_manual[1], scale_x_continuous[3], scale_x_date[3], scale_y_continuous[8], theme[9], theme_bw[3], theme_set[1]
glue	glue[2]
hardhat	extract_fit_engine[2], extract_workflow[1]
janitor	clean_names[1]
kernelshap	kernelshap[1]
lubridate	dmy[1], floor_date[2], rollforward[1], stamp[1], year[1], ymd[7]
parsnip	boost_tree[1], linear_reg[2], rand_forest[1], set_engine[1]
patchwork	plot_annotation[4], plot_layout[2]
purrr	map[1], pwalk[1], reduce[1], walk2[4]
recipes	bake[1], has_role[1], prep[1], recipe[1], step_date[1], step_ns[4], update_role[3]
rsample	initial_split[1], testing[1], training[1], vfold_cv[1]
rstantools	predictive_interval[1]
rvest	html_element[1], html_table[1]
scales	cut_short_scale[1], label_number[8]
shapviz	shapviz[1], sv_importance[1], sv_waterfall[1]
stringr	str_c[2], str_extract[2]
tibble	as_tibble[1], tibble[1]
tictoc	tic[2], toc[2]
tidyr	nest[1], pivot_longer[1], unnest[1]
tidyselect	everything[1]
tsibble	as_tsibble[1], yearmonth[1]
tune	control_bayes[1], coord_obs_pred[1], fit_best[1]
usedthese	used_here[1]
workflowsets	rank_results[1], workflow_map[1], workflow_set[1]
xml2	read_html[1]
yardstick	metric_set[1], rmse[1]

References

Gabry, Jonah, Ben Goodrich, Martin Lysy, and Andrew Johnson. 2023. “Rstantools: Tools for Developing r Packages Interfacing with ’Stan’.” https://CRAN.R-project.org/package=rstantools.

Goodrich, Ben, Jonah Gabry, Imad Ali, and Sam Brilleman. 2023. “Rstanarm: Bayesian Applied Regression Modeling via Stan.” https://mc-stan.org/rstanarm/.

Kuhn, Max, and Simon Couch. 2023. “Workflowsets: Create a Collection of ’Tidymodels’ Workflows.” https://CRAN.R-project.org/package=workflowsets.

O’Hara-Wild, Mitchell, Rob Hyndman, and Earo Wang. 2023. “Fable: Forecasting Models for Tidy Time Series.” https://CRAN.R-project.org/package=fable.

Footnotes

Per Legal | Bank of England, the information made available via the Database is the copyright of the Governor and Company of the Bank, unless otherwise stated. Reproduction of data in the Database is subject to the terms of the UK Open Government Licence, allowing and encouraging free and flexible data reuse.↩︎
econforecasting.com (2023). Consensus Interest Rate Forecast Model. Retrieved from https://econforecasting.com/forecast-ukbankrate.↩︎
Estimated by Trading Economics↩︎
Estimated by Trading Economics↩︎
See Forecasting: Principles and Practice with implementation via the fable package(O’Hara-Wild, Hyndman, and Wang 2023).↩︎

An Infinite Number of Monkeys

Carl Goodwin — Fri, 24 Feb 2023 00:00:00 GMT

term	n
cpi_macro	-0.6394982
stamp_macro	-0.6098874
interest_macro	0.4988777
sterling_macro	0.5598381

term	estimate	conf.low	conf.high	tau
(Intercept)	34.9637770	2.5084044	51.5192997	0.05
cpi_macro	1.7368596	0.9750103	2.7228793	0.05
sterling_macro	0.3613259	0.1910106	0.6904453	0.05
interest_macro	-3.3873224	-5.4895894	-2.1548889	0.05
stamp_macro	0.3955557	-0.5174484	1.1546665	0.05
month	0.4243359	-0.1641574	0.8630339	0.05
yr_mon	-0.0139605	-0.0198758	-0.0090087	0.05
(Intercept)	-3.5142925	-31.4504914	14.3832173	0.50
cpi_macro	0.9597555	0.4330227	1.5994709	0.50
sterling_macro	0.7940372	0.5853182	0.9814400	0.50
interest_macro	-2.0952914	-3.8808015	-0.7101136	0.50
stamp_macro	-0.5780211	-1.3335191	0.2582064	0.50
month	0.0315507	-0.3676512	0.3889651	0.50
yr_mon	-0.0076878	-0.0146556	-0.0042168	0.50
(Intercept)	30.0593107	-38.4713831	120.2971361	0.95
cpi_macro	1.4210843	-1.4279209	2.3890940	0.95
sterling_macro	1.1880504	-0.0562413	1.7142605	0.95
interest_macro	-4.0633879	-9.8616286	5.9937923	0.95
stamp_macro	1.7088722	-4.9211859	5.0026191	0.95
month	-0.0877162	-1.3509206	1.8282363	0.95
yr_mon	-0.0145373	-0.0221361	0.0082073	0.95

R Toolbox

Summarising below the packages and functions used in this post enables me to separately create a toolbox visualisation summarising the usage of packages and functions across all posts.

used_here()

Package	Function
Qtools	GOFTest[1]
SPARQL	SPARQL[1]
base	as.double[1], c[5], library[16], list[1], mean[1], options[1], set.seed[1]
broom	tidy[1]
conflicted	conflict_prefer_all[1], conflict_scout[1], conflicts_prefer[2]
corrr	correlate[1], focus[1]
dplyr	across[1], arrange[4], between[1], bind_cols[2], case_when[1], count[1], filter[4], if_else[3], join_by[4], last[2], left_join[3], mutate[16], pull[2], rename[3], row_number[1], rows_insert[2], select[8], slice_tail[1], summarise[3]
ggfoundry	display_palette[1]
ggfx	as_reference[1], with_blend[1]
ggplot2	aes[7], annotate[6], element_text[2], facet_wrap[2], geom_boxplot[1], geom_line[4], geom_point[1], geom_ribbon[1], geom_smooth[2], geom_vline[3], ggplot[4], labs[3], theme[2], theme_bw[1], theme_set[1]
glue	glue[2]
imfr	imf_dataset[1]
janitor	clean_names[1]
lubridate	as_date[1], as_datetime[1], dmy[3], month[2], ymd[5]
paletteer	paletteer_d[1]
purrr	pluck[2], reduce[1]
quantreg	rq[2]
readr	parse_number[3]
rvest	html_element[1], html_elements[2], html_table[2], html_text[1]
scales	percent[1]
stats	predict[2]
stringr	str_c[1], str_detect[3], str_remove[2], str_starts[1]
tibble	as_tibble[4], tibble[2]
tidyr	drop_na[2], fill[2], pivot_longer[2], pivot_wider[1], replace_na[1], separate_wider_delim[1]
tidyselect	ends_with[3], starts_with[1]
tsibble	scale_x_yearmonth[1], yearmonth[10]
usedthese	used_here[1]
xml2	read_html[3]

References

Geraci, M. 2022. “Qtools: Utilities for Quantiles.” https://cran.r-project.org/package=Qtools.

Koenker, Roger. 2022. “Quantreg: Quantile Regression.” https://CRAN.R-project.org/package=quantreg.

Robinson, David, Alex Hayes, and Simon Couch. 2023. “Broom: Convert Statistical Objects into Tidy Tibbles.” https://CRAN.R-project.org/package=broom.

A Footnote in History

Carl Goodwin — Tue, 01 Nov 2022 00:00:00 GMT

The nature of employment has seen significant shifts over time. Occupations are being consigned to ‘footnotes in history’ whilst others grow driven by trends such as concern for the environment.

Producing a journal-quality table requires fine-grained and reproducible control over presentation. Surgical targeting of footnotes, capable of adapting to changes in the underlying data, is one example.

This post briefly explores the shifts in the nature of employment whilst at the same time more fully exploring the grammar of tables gt(Iannone et al. 2022): The natural companion to the grammar of graphics ggplot2(Wickham 2016).

library(conflicted)
library(tidyverse)
conflict_prefer_all("dplyr", quiet = TRUE)
library(readxl)
library(gt)
library(ggfoundry)
library(usedthese)

conflict_scout()

In Digging Deep, the DT package is used to produce a reactable table; one with sortable and searchable columns. DT is intended as an R interface to the DataTables library, but reactivity is not yet supported in gt.

Data frames are liberally printed across all projects including, for example, a table to summarise an auto-generated overview of R packages and functions used in each project. The YAML option df-print: kable renders a nice table (with striped rows) in these cases.

For this project something a little more sophisticated is needed.

As a guiding principle, Posit packages are my first port of call. This provides a confidence in cross-package consistency, interoperability, longevity and an investment in development and support. Hence gt is the go-to package for the footnoted table further down.

As the intent is to present a summary in the style of the Financial Times, we’ll need a suitable custom colour palette.

theme_set(theme_bw())

pal <- c(
  "#FFF1E5", "#F2DFCE",
  "#333333", "#800D33",
  "#C00000", "#00994D"
)

pal_name <- "Financial Times"

display_palette(pal, pal_name)

The labour market data are sourced from the Office for National Statistics¹.

read_data <- \(x) {
  read_xlsx(
    x,
    skip = 12,
    col_names = c(
      "occupation",
      "persons"
    ),
    col_types = c(
      "text",
      "numeric",
      "skip",
      "skip",
      "skip",
      "skip",
      "skip"
    )
  )
} |> 
  mutate(year = x |> str_remove(".xlsx") |> as.integer())

pop_df <- list("2004.xlsx", "2021.xlsx") |> 
  map(read_data) |> 
  list_rbind()

There’s a hierarchy to the data, so I’ll extract the lowest level and then slice off the top and bottom occupations based on their percentage change over time.

change_df <- pop_df |> 
  filter(str_starts(occupation, "\\d{4} ")) |> 
  pivot_wider(names_from = year, values_from = persons) |> 
  separate_wider_regex(occupation, 
                       c(soc = "\\d{4}", " ", occupation = ".*")) |> 
  mutate(change = `2021` / `2004` - 1) |> 
  arrange(desc(change)) |> 
  mutate(group = if_else(row_number() <= 10, "Risers", "Fallers")) |> 
  slice(c(1:10, (n()-10):n())) |> 
  relocate(group)

The handling of footnotes is a particularly nice feature in gt: The package automatically assigns, and maintains the order of, the superscripted numbers (could also be symbols) to ensure they flow naturally. And targeting offers a high degree of control and reproducibility.

For example, two entries (highlighted light blue) in the table below use the abbreviation n.e.c.. The footnote may be targeted at rows which contain that string rather than having to manually identify the rows. And once added, any subsequent footnotes would be renumbered to maintain the flow. So, if I were to change the source datasets to different years or countries, all references to n.e.c. would be auto-magically found and appropriately footnoted.

gt_tbl <- change_df |>
  gt(rowname_col = c("occupation"), groupname_col = "group") |>
  tab_header(title = "UK Employment by Occupation") |> 
  tab_options(table.width = pct(100)) |> 
  fmt_number(
    columns = starts_with("2"),
    decimals = 0
  ) |>
  fmt_percent(
    columns = starts_with("c"),
    decimals = 0,
    force_sign = TRUE
  ) |>
  sub_missing() |>
  tab_spanner(
    label = "Year",
    columns = starts_with("2")
  ) |> 
  tab_style(
    style = cell_text(transform = "capitalize"),
    locations = cells_column_labels(!starts_with("s"))
  ) |> 
  tab_style(
    style = cell_text(transform = "uppercase"),
    locations = cells_column_labels("soc")
  ) |> 
  tab_footnote(
    footnote = "Not elsewhere classified",
    locations = cells_stub(rows = contains("n.e.c."))
  ) |> 
  tab_footnote(
    footnote = "Count of all persons",
    locations = cells_column_spanners()
  ) |>
  tab_footnote(
    footnote = "Standard Occupational Classification 2020",
    locations = cells_column_labels(columns = "soc")
  ) |>
  tab_footnote(
    footnote = "Top & bottom 10 occupations ordered by percent change",
    locations = cells_row_groups(groups = c("Risers", "Fallers"))
  ) |>
  tab_footnote(
    footnote = "Figures suppressed as statistically unreliable",
    locations = cells_body(
      columns = c(change, `2021`),
      rows = is.na(change)
    )
  ) |>
  tab_source_note(source_note = "Source: Office for National Statistics (ONS)")

gt_tbl |>
  tab_style_body(
    style = cell_fill(color = "lightblue"),
    pattern = "n.e.c.",
    extents = "stub"
  ) |> 
  opt_stylize(style = 6, color = "gray", add_row_striping = TRUE) |> 
  as_raw_html()

	²" bgcolor="#5F5F5F" valign="bottom" align="right">soc²	¹" style="border-style: none; color: #FFFFFF; background-color: #5F5F5F; font-size: 100%; font-weight: normal; text-transform: inherit; padding-top: 0; padding-bottom: 0; padding-left: 4px; padding-right: 4px; text-align: center;" bgcolor="#5F5F5F" align="center"> Year¹		change
UK Employment by Occupation
	²" bgcolor="#5F5F5F" valign="bottom" align="right">soc²	2004	2021	change
³" style="border-style: none; padding-top: 8px; padding-bottom: 8px; padding-left: 5px; padding-right: 5px; color: #333333; background-color: #FFFFFF; font-size: 100%; font-weight: initial; text-transform: inherit; border-top-style: solid; border-top-width: 2px; border-top-color: #5F5F5F; border-bottom-style: solid; border-bottom-width: 2px; border-bottom-color: #5F5F5F; border-left-style: none; border-left-width: 1px; border-left-color: #D3D3D3; border-right-style: none; border-right-width: 1px; border-right-color: #D3D3D3; vertical-align: middle; text-align: left;" bgcolor="#FFFFFF" valign="middle" align="left">Risers³
Industrial cleaning process occupations	9132	26,300	241,100	+817%
Health professionals n.e.c.⁴	2219	9,000	70,100	+679%
Police community support officers	3315	2,100	13,900	+562%
Business and financial project management professionals	2424	58,300	350,000	+500%
Advertising and public relations directors	1134	19,400	69,000	+256%
IT business analysts, architects and systems designers	2135	82,800	270,500	+227%
Aircraft maintenance and related trades	5235	27,200	88,300	+225%
Quality assurance and regulatory professionals	2462	43,700	138,000	+216%
Officers of non-governmental organisations	4114	41,800	127,200	+204%
Environment professionals	2142	17,500	52,100	+198%
³" style="border-style: none; padding-top: 8px; padding-bottom: 8px; padding-left: 5px; padding-right: 5px; color: #333333; background-color: #FFFFFF; font-size: 100%; font-weight: initial; text-transform: inherit; border-top-style: solid; border-top-width: 2px; border-top-color: #5F5F5F; border-bottom-style: solid; border-bottom-width: 2px; border-bottom-color: #5F5F5F; border-left-style: none; border-left-width: 1px; border-left-color: #D3D3D3; border-right-style: none; border-right-width: 1px; border-right-color: #D3D3D3; vertical-align: middle; text-align: left;" bgcolor="#FFFFFF" valign="middle" align="left">Fallers³
Sheet metal workers	5213	29,100	10,900	−63%
Process operatives n.e.c.⁴	8119	22,200	8,200	−63%
Footwear and leather working trades	5413	13,000	4,800	−63%
Printing machine assistants	8127	22,600	8,100	−64%
Assemblers (electrical and electronic products)	8131	63,200	20,700	−67%
Printers	5422	63,600	8,900	−86%
Chartered architectural technologists	2435	2,400	⁵ —	⁵ —
Moulders, core makers and die casters	5212	3,900	⁵ —	⁵ —
Air-conditioning and refrigeration engineers	5225	19,400	⁵ —	⁵ —
Pre-press technicians	5421	8,600	⁵ —	⁵ —
Coal mine operatives	8122	2,600	⁵ —	⁵ —
Source: Office for National Statistics (ONS)
¹ Count of all persons
² Standard Occupational Classification 2020
³ Top & bottom 10 occupations ordered by percent change
⁴ Not elsewhere classified
⁵ Figures suppressed as statistically unreliable

The above table uses one of the in-built style theme options. It looks clean and polished. But sometimes the table to be published needs a high degree of customisation to match, for example, a specific branding. gt offers this as we’ll demonstrate by attempting to replicate the style employed by the market data in the Financial Times.

gt_ft <- gt_tbl |> 
  tab_options(
    table.border.top.color = pal[1],
    table.border.bottom.color = pal[1],
    table.background.color = pal[1],
    table.font.size = px(10),
    table.font.color = pal[3],
    heading.align = "left",
    heading.title.font.size = px(20),
    heading.title.font.weight = "bold",
    heading.background.color = pal[1],
    row.striping.include_table_body = TRUE,
    row.striping.include_stub = TRUE,
    row.striping.background_color = pal[2],
    row_group.background.color = pal[1]
  ) |> 
  tab_header(title = html("UK Employment by Occupation  ", 
                          local_image("logo.png", height = 20))) |> 
  tab_style(
    style = list(
      cell_text(font = "Financier Display"),
      cell_borders(sides = "bottom", weight = px(3), color = "#262A33")
      ),
    locations = cells_title()
  ) |>
  tab_style(
    style = cell_text(size = px(14)),
    locations = cells_row_groups()
  ) |> 
  tab_style(
    style = cell_text(color = pal[4], weight = "bold"),
    locations = cells_stub()
  ) |> 
  tab_style(
    style = cell_text(weight = "bold"),
    locations = list(cells_column_labels(), 
                     cells_column_spanners(), 
                     cells_row_groups())
  ) |> 
  tab_style(
    style = cell_borders(style = "hidden"),
    locations = list(cells_body(),
                     cells_row_groups(),
                     cells_stub())
  ) |>
  tab_style(
    style = cell_text(color = pal[6], weight = "bold"),
    locations = cells_body(
      columns = change,
      rows = change >= 0
    )
  ) |> 
  tab_style(
    style = cell_text(color = pal[5], weight = "bold"),
    locations = cells_body(
      columns = change,
      rows = change < 0
    )
  ) |> 
  tab_style(
    style = cell_text(color = "grey40", size = px(9)),
    locations = list(cells_footnotes(), cells_source_notes())
  )

gt_ft |> as_raw_html()

	²" bgcolor="#FFF1E5" valign="bottom" align="right">soc²	¹" bgcolor="#FFF1E5" align="center"> Year¹		change
UK Employment by Occupation
	²" bgcolor="#FFF1E5" valign="bottom" align="right">soc²	2004	2021	change
³" bgcolor="#FFF1E5" valign="middle" align="left">Risers³
Industrial cleaning process occupations	9132	26,300	241,100	+817%
Health professionals n.e.c.⁴	2219	9,000	70,100	+679%
Police community support officers	3315	2,100	13,900	+562%
Business and financial project management professionals	2424	58,300	350,000	+500%
Advertising and public relations directors	1134	19,400	69,000	+256%
IT business analysts, architects and systems designers	2135	82,800	270,500	+227%
Aircraft maintenance and related trades	5235	27,200	88,300	+225%
Quality assurance and regulatory professionals	2462	43,700	138,000	+216%
Officers of non-governmental organisations	4114	41,800	127,200	+204%
Environment professionals	2142	17,500	52,100	+198%
³" bgcolor="#FFF1E5" valign="middle" align="left">Fallers³
Sheet metal workers	5213	29,100	10,900	−63%
Process operatives n.e.c.⁴	8119	22,200	8,200	−63%
Footwear and leather working trades	5413	13,000	4,800	−63%
Printing machine assistants	8127	22,600	8,100	−64%
Assemblers (electrical and electronic products)	8131	63,200	20,700	−67%
Printers	5422	63,600	8,900	−86%
Chartered architectural technologists	2435	2,400	⁵ —	⁵ —
Moulders, core makers and die casters	5212	3,900	⁵ —	⁵ —
Air-conditioning and refrigeration engineers	5225	19,400	⁵ —	⁵ —
Pre-press technicians	5421	8,600	⁵ —	⁵ —
Coal mine operatives	8122	2,600	⁵ —	⁵ —
Source: Office for National Statistics (ONS)
¹ Count of all persons
² Standard Occupational Classification 2020
³ Top & bottom 10 occupations ordered by percent change
⁴ Not elsewhere classified
⁵ Figures suppressed as statistically unreliable

R Toolbox

Summarising below the packages and functions used in this post enables me to separately create a toolbox visualisation summarising the usage of packages and functions across all posts.

used_here()

Package	Function
base	as.integer[1], c[8], is.na[1], library[6], list[5]
conflicted	conflict_prefer_all[1], conflict_scout[1]
dplyr	arrange[1], desc[1], filter[1], if_else[1], mutate[3], n[2], relocate[1], row_number[1], slice[1]
ggfoundry	display_palette[1]
ggplot2	theme_bw[1], theme_set[1]
gt	as_raw_html[2], cell_borders[2], cell_fill[1], cell_text[9], cells_body[4], cells_column_labels[4], cells_column_spanners[2], cells_footnotes[1], cells_row_groups[4], cells_source_notes[1], cells_stub[3], cells_title[1], fmt_number[1], fmt_percent[1], gt[1], html[1], local_image[1], opt_stylize[1], pct[1], px[5], sub_missing[1], tab_footnote[5], tab_header[2], tab_options[2], tab_source_note[1], tab_spanner[1], tab_style[10], tab_style_body[1]
purrr	list_rbind[1], map[1]
readxl	read_xlsx[1]
stringr	str_remove[1], str_starts[1]
tidyr	pivot_wider[1], separate_wider_regex[1]
tidyselect	contains[1], starts_with[4]
usedthese	used_here[1]

References

Iannone, Richard, Joe Cheng, Barret Schloerke, Ellis Hughes, and JooYoung Seo. 2022. “Gt: Easily Create Presentation-Ready Display Tables.”

Wickham, Hadley. 2016. “Ggplot2: Elegant Graphics for Data Analysis.” https://ggplot2.tidyverse.org.

Footnotes

Contains public sector information licensed under the Open Government Licence v3.0.↩︎

Finding Happiness in The Smoke

Carl Goodwin — Sat, 19 Mar 2022 00:00:00 GMT

The Smoke, to use London’s nickname, has 32 boroughs plus the central business district known as the City of London. What does Cluster Analysis tell us about the characteristics that bind them?

library(conflicted)
library(tidyverse)
conflict_prefer_all("dplyr", quiet = TRUE)
library(tidymodels)
library(tidytext)
library(tidyclust)
library(glue)
library(readxl)
library(janitor)
library(ggrepel)
library(sf)
library(scales)
library(ggfoundry)
library(usedthese)

conflict_scout()

The graphics will use a custom palette created in Adobe Colour.

theme_set(theme_bw())

pal <- c("#0AC449", "#CF4E0A", "#0057B7", "#FFD700", "#870AC4")

pal_name <- "Custom Palette"

display_palette(pal, pal_name)

The London Datastore provides data profiling each area.

raw_df <-
  read_xlsx("london-borough-profiles.xlsx", sheet = 2) |>
  clean_names() |>
  filter(str_starts(code, "E")) |>
  mutate(across(where(is.character), \(x) na_if(x, ".")),
    inner_outer_london = str_remove(inner_outer_london, " London")
  )

Dimensionality Reduction

These data include 81 numeric variables quantifying such things as population density, happiness and age. Way too many variables to visualise two-dimensionally. Principal Components Analysis can reduce the bulk of the information down to two variables. It is then possible to more easily visualise the relationships.

The City of London, aka “The Square Mile”, is quite distinct from the other 32 areas and has many NA values.

raw_df |> 
  rowwise() |> 
  mutate(na_count = sum(is.na(cur_data()))) |> 
  select(area_name, na_count) |>
  filter(na_count != 0) |>
  arrange(desc(na_count))

area_name	na_count
City of London	27
Kensington and Chelsea	3
Barnet	1
Camden	1
Hackney	1
Haringey	1
Harrow	1
Islington	1
Lewisham	1
Merton	1
Richmond upon Thames	1
Waltham Forest	1
Wandsworth	1

Not surprisingly, the two-dimensional visualisation sets the City of London apart. And the other 32 are broadly, albeit with some mixing, divided into inner and outer London boroughs.

pca_fit <- raw_df |>
  select(where(is.numeric)) |>
  prcomp(scale = TRUE)

pca_augmented <-
  pca_fit |>
  augment(raw_df)

pca_augmented |>
  ggplot(aes(.fittedPC1, .fittedPC2, fill = inner_outer_london)) +
  geom_label(aes(label = area_name), size = 2, hjust = "inward") +
  scale_fill_manual(values = pal) +
  labs(
    title = "33 London Areas", fill = "London",
    x = "Principal Component 1", y = "Principal Component 2",
    caption = "Source: data.london.gov.uk"
  )

After squeezing the many dimensions into two, how much of the original information was it possible to retain?

pca_tidied <- pca_fit |>
  tidy(matrix = "eigenvalues")

pct_explained <-
  pca_tidied |>
  pluck("cumulative", 2)

pca_tidied |>
  ggplot(aes(percent, factor(PC))) +
  geom_col(aes(fill = if_else(PC <= 2, TRUE, FALSE)),
    alpha = 0.8, show.legend = FALSE,
  ) +
  scale_x_continuous(labels = label_percent(1)) +
  scale_y_discrete(breaks = c(0, 5, 10, 15, 20)) +
  scale_fill_manual(values = pal) +
  labs(
    title = glue(
      "{percent(pct_explained, 0.1)} of the ",
      "Variance Explained by Principal Components 1 & 2"
    ),
    x = "Principal Component", y = NULL
  )

Whilst we do lose ease of interpretation by distilling the information in this way, it is still possible to understand which of the original variables influenced their two-dimensional positioning.

The axes depicted by the arrows below tell us that anxiety scores play a significant role in the placement of the City of London towards the upper-left. Average age pushes areas more towards the top. And happiness influences the bottom-right.

pattern <-
  str_c("_\\d{4}|_st.+|_score|_rates|^percent(_of)?_|",
        "^proportion_of_|^population(_of)?_|^number(_of)?_|", 
        "_\\d{2}_out_of_\\d{2}|_estimate|_percent")

pca_fit |>
  tidy(matrix = "rotation") |>
  pivot_wider(names_from = "PC", names_prefix = "PC", 
              values_from = "value") |>
  mutate(column = str_remove_all(column, pattern)) |>
  ggplot(aes(PC1, PC2)) +
  geom_segment(
    xend = 0, yend = 0, colour = "grey70",
    arrow = arrow(ends = "first", length = unit(8, "pt"))
  ) +
  geom_text_repel(aes(label = column), size = 3) +
  theme_minimal() +
  labs(
    x = "PC 1", y = "PC 2",
    title = "Characteristics Influencing Area Positioning",
    caption = "Source: data.london.gov.uk"
  ) +
  theme(axis.text = element_blank())

This may be validated by ranking all 33 areas by these three original variables.

pca_long <- 
  pca_augmented |>
  select(area_name, matches("happ|anx|average_age")) |>
  rename_with(~ str_remove(., "_.*")) |>
  rename("avg_age" = "average") |>
  pivot_longer(-area, values_to = "score") |>
  mutate(area = reorder_within(area, score, name)) 

pca_long |>
  ggplot(aes(score, area, colour = name)) +
  geom_point(show.legend = FALSE) +
  facet_wrap(~name, scales = "free") +
  scale_y_reordered() +
  scale_colour_manual(values = pal) +
  labs(x = NULL, caption = "Source: data.london.gov.uk")

Cluster Modelling

To collect these areas into their natural groupings, a decision is needed on the desired number of clusters. We can visualise dividing the areas into 1, 2, 3 and so forth clusters. And, per below, 3 appears to nicely capture the natural grouping of the coloured points.

set.seed(2022)

kclusts <-
  tibble(k = 1:6) |>
  mutate(
    kclust = map(k, \(k) kmeans(
      pca_augmented |> select(.fittedPC1, .fittedPC2), k)),
    tidied = map(kclust, tidy),
    glanced = map(kclust, glance),
    augmented = map(kclust, augment, pca_augmented)
  )

assignments <-
  kclusts |>
  unnest(pal = c(augmented))

clusters <-
  kclusts |>
  unnest(cols = c(tidied))

assignments |>
  ggplot(aes(x = .fittedPC1, y = .fittedPC2)) +
  geom_point(aes(color = .cluster)) +
  facet_wrap(~k, nrow = 2) +
  scale_colour_manual(values = pal[c(1:6)]) +
  geom_point(data = clusters, size = 4, shape = 13) +
  labs(
    title = "How Many Clusters Best Captures the Groupings?",
    subtitle = "X Marks the Cluster Centre",
    caption = "Source: data.london.gov.uk"
  )

The elbow method provides a more mathematical approach to the choice. The compactness of the clustering (as measured by the total within-cluster sum of squares) is significantly optimised when choosing 3 clusters, with diminishing returns thereafter.

kclusts |>
  unnest(cols = c(glanced)) |>
  ggplot(aes(k, tot.withinss)) +
  geom_line() +
  geom_point() +
  geom_label(aes(label = if_else(k == 3, "Elbow", NA_character_)),
    nudge_y = -25, fill = pal[1]
  ) +
  labs(
    title = "Elbow Method",
    x = "Clusters", y = "Within-Cluster Variance"
  )

And settling on this choice of 3 clusters, we get this split.

assignments |>
  filter(k == 3) |>
  ggplot(aes(.fittedPC1, .fittedPC2, fill = .cluster)) +
  geom_label(aes(label = area_name), 
             size = 2, hjust = "inward", overlap = FALSE) +
  scale_fill_manual(values = pal[c(1, 2, 4)]) +
  labs(
    title = "Closely-Related London Areas", fill = "Cluster",
    x = "Principal Component 1", y = "Principal Component 2",
    caption = "Source: data.london.gov.uk"
  )

Using Tidymodels

An alternative approach is to use the new tidyclust(Hvitfeldt and Bodwin 2022) package which augments the tidymodels framework with a tidy unified interface to clustering models.

First we tune the model with 1 to 6 clusters and review how well they capture the natural groupings.

kmeans_spec <- k_means(num_clusters = tune()) |> 
  set_engine("stats", algorithm = "Hartigan-Wong")

kmeans_rec <- raw_df |> 
  select(where(is.numeric)) |> 
  recipe(~ .) |> 
  step_zv(all_predictors()) |> 
  step_normalize(all_predictors()) |> 
  step_pca(all_predictors(), threshold = 0.9)

kmeans_wflow <- workflow() |>
  add_model(kmeans_spec) |>
  add_recipe(kmeans_rec)

kmeans_cv <- vfold_cv(pca_augmented, v = 5)

kmeans_res <- tune_cluster(
  kmeans_wflow,
  resamples = kmeans_cv,
  grid = crossing(
    num_clusters = seq(1, 6, 1)
  ),
  control = control_grid(save_pred = TRUE),
  metrics = cluster_metric_set(sse_total, sse_ratio)
)

kmeans_metrics <- kmeans_res |> collect_metrics()

kmeans_metrics |>
  filter(.metric == "sse_ratio") |>
  ggplot(aes(num_clusters, mean)) +
  geom_point() +
  geom_line() +
  geom_label(aes(label = if_else(num_clusters == 3, "Elbow", NA_character_)),
             nudge_y = -0.1, fill = pal[1]) +
  labs(title = "Elbow Method", x = "Clusters", y = "WSS") +
  scale_x_continuous(breaks = 1:6)

Again we can visualise the 3 clusters suggested by the elbow method.

kmeans_spec <- k_means(num_clusters = 3) |> 
  set_engine("stats", algorithm = "Hartigan-Wong")

kmeans_wflow <- kmeans_wflow |> 
  update_model(kmeans_spec)

kmeans_fit <- kmeans_wflow |> 
  fit(pca_augmented) 

kmeans_clust <- kmeans_fit |> 
  extract_centroids() |> 
  rename_with(~ str_c(".fitted", .), starts_with("PC"))

kmeans_aug <- kmeans_fit |> 
  augment(pca_augmented)

kmeans_aug |>
  mutate(.pred_cluster = str_remove(.pred_cluster, "Cluster_")) |> 
  ggplot(aes(.fittedPC1, .fittedPC2)) +
  geom_label(aes(label = area_name, colour = .pred_cluster),
             size = 2, hjust = "inward") +
  scale_colour_manual(values = pal[c(1:3, 5)]) +
  geom_point(data = kmeans_clust, size = 4, shape = 13) +
  labs(
    title = "Closely-Related London Areas", fill = "Cluster",
    subtitle = "X Marks the Cluster Centre",
    x = "Principal Component 1", y = "Principal Component 2",
    colour = "Cluster",
    caption = "Source: data.london.gov.uk"
  )

How does this look with geospatial data? And how do the clusters relate to inner and outer London?

shape_df <-
  st_read("statistical-gis-boundaries-london/ESRI",
    "London_Borough_Excluding_MHW",
    as_tibble = TRUE, quiet = TRUE
  ) |>
  left_join(assignments |> 
              filter(k == 3), by = join_by(GSS_CODE == code)) |>
  select(.cluster, inner_outer_london, NAME, geometry) |>
  pivot_longer(c(.cluster, inner_outer_london)) |>
  mutate(value = recode(value, "1" = "Cluster 1", 
                        "2" = "Cluster 2", "3" = "Cluster 3"))

shape_df |>
  mutate(name = recode(name,
    ".cluster" = "By Cluster",
    "inner_outer_london" = "By Inner/Outer"
  )) |>
  ggplot() +
  geom_sf(aes(fill = value), colour = "white") +
  geom_sf_label(aes(label = NAME), size = 2, alpha = 0.7) +
  scale_fill_manual(values = pal[c(3, 4, 1, 2, 5)]) +
  facet_wrap(~name) +
  theme_void() +
  theme(legend.position = "none") +
  labs(fill = NULL)

Not too dissimilar, but with some notable differences.

The City of London is a cluster apart in the heart of London. Kensington and Chelsea is an inner-London borough, but exhibits outer-London characteristics. And the reverse is true of the likes of Brent and Greenwich.

Dimensionality reduction is further explored in East-West Drift coupled with animation.

R Toolbox

Summarising below the packages and functions used in this post enables me to separately create a toolbox visualisation summarising the usage of packages and functions across all posts.

used_here()

Package	Function
base	c[10], factor[1], is.na[1], library[13], seq[1], set.seed[1], sum[1]
conflicted	conflict_prefer_all[1], conflict_scout[1]
dplyr	across[1], arrange[1], cur_data[1], desc[1], filter[5], if_else[3], join_by[1], left_join[1], mutate[8], na_if[1], recode[2], rename[1], rename_with[2], rowwise[1], select[6], starts_with[1], where[3]
generics	augment[2], fit[1], tidy[2]
ggfoundry	display_palette[1]
ggplot2	aes[19], arrow[1], element_blank[1], facet_wrap[3], geom_col[1], geom_label[5], geom_line[2], geom_point[6], geom_segment[1], geom_sf[1], geom_sf_label[1], ggplot[10], labs[10], scale_colour_manual[3], scale_fill_manual[4], scale_x_continuous[2], scale_y_discrete[1], theme[2], theme_bw[1], theme_minimal[1], theme_set[1], theme_void[1]
ggrepel	geom_text_repel[1]
glue	glue[1]
grid	unit[1]
hardhat	tune[1]
janitor	clean_names[1]
parsnip	set_engine[2]
purrr	map[4], pluck[1]
readxl	read_xlsx[1]
recipes	all_predictors[3], recipe[1], step_normalize[1], step_pca[1], step_zv[1]
rsample	vfold_cv[1]
scales	label_percent[1], number[1], percent[2]
sf	st_read[1]
stats	kmeans[1], prcomp[1]
stringr	str_c[2], str_remove[3], str_remove_all[1], str_starts[1]
tibble	tibble[1]
tidyclust	cluster_metric_set[1], extract_centroids[1], k_means[2], tune_cluster[1]
tidyr	crossing[1], pivot_longer[2], pivot_wider[1], population[1], unnest[3]
tidyselect	matches[1]
tidytext	reorder_within[1], scale_y_reordered[1]
tune	collect_metrics[1], control_grid[1]
usedthese	used_here[1]
workflows	add_model[1], add_recipe[1], update_model[1], workflow[1]

References

Hvitfeldt, Emil, and Kelly Bodwin. 2022. “Tidyclust: A Common API to Clustering.” https://github.com/EmilHvitfeldt/tidyclust.

Bootstraps & Bandings

Carl Goodwin — Tue, 08 Mar 2022 00:00:00 GMT

Are the residential property bands of 3 decades ago becoming less so? Would a sample of those recently-sold reveal band convergence? And what may be inferred about those not sampled?

Over the years, urban properties have been added to and divided up. And two streets of equal attractiveness, and with equivalently-banded properties, may have diverged as neighbourhoods evolved.

Whilst properties can and do move to higher or lower bands following alteration, would a sample of those recently-sold reveal band convergence after so long? And what may be inferred about the wider housing stock?

library(conflicted)
library(tidyverse)
conflict_prefer_all("dplyr", quiet = TRUE)
conflicts_prefer(lubridate::as_date)
library(rvest)
library(scales)
library(SPARQL)
library(clock)
conflicts_prefer(clock::date_format)
library(glue)
library(janitor)
library(infer)
library(tsibble)
library(ggfx)
library(paletteer)
library(ggfoundry)
library(usedthese)

conflict_scout()

Setting the theme and colour palette for all graphics (with a little help from the ggfx package).

theme_set(theme_bw())

pal_name <- "RColorBrewer::RdYlBu"

pal <- paletteer_d(pal_name, 7)

display_palette(pal, pal_name)

Property band and price-paid data are separately sourced. The free-form street address is the only way to bring the two together. The structure, content and even spelling of the address sometimes differ, for example: “FLAT C, 22 SOME STREET, SOME AREA, SW10 1AA” in one may be “22C 2ND FLR, HOUSE NAME, SOME STREET SW10 1AA” in the other.

So, a little string manipulation is needed to create a common key. And reusable patterns will enable a consistent application to both.

Tip

Hover over the numbered code annotation symbols for REGEX explanations.

remove_pattern <-
  str_c(
    ", London, SW10 .+$",
    "FLAT ",
    "APARTMENT ",
    "CHELSEA HARBOUR",
    "(?<=COURT|SANDHILLS| HOUSE|WALK|ESTATE|ROW).*",
    "[,'\\.]",
    "(?<= )AT ",
    "(?<=VINT)N",
    "(?<=FARRIER)S",
    "(1ST|2ND|3RD|4TH|5TH|6TH) FLR ",
    "FLR (1ST|2ND|3RD|4TH|5TH|6TH) ",
    " ?- ?[0-9]{1,3}",
    sep = "|"
  )

swizzle_from <- "^([0-9]{1,3})([A-Z])(?= .*)"
swizzle_to <- "\\2 \\1"

1: Looks for strings that end with 1 or more characters following the London postcode district of “SW10”.
2: Uses a positive lookbehind to find anything, for example, following the word COURT or WALK (since the postcode is stored in a separate variable and already isolates the road, so the road name is redundant).
3: Finds any occurrences of 1ST FLR, FLR 1ST etc.
4: Uses capture groups to temporarily memorise a number (capture group 1) followed by a letter (capture group 2), then swap them around. This is because a flat number may be C22 in one dataset and 22C in the other.

Council Tax band data are available for non-commercial use¹.

url1 <-
  str_c(
    "https://www.tax.service.gov.uk/",
    "check-council-tax-band/",
    "search-council-tax-advanced?",
    "postcode=Fkvms5WVQum-uX3L00_pcA&",
    "filters.councilTaxBands="
  )

url2 <- "&filters.propertyUse=N&postcode=Fkvms5WVQum-uX3L00_pcA&page="

url3 <- "&filters.bandStatus=Current"

index <- crossing(band = LETTERS[1:8], page = seq(0, 120, 1))

band_df <- map2(index$band, index$page, possibly(\(i, j) {
  str_c(url1, i, url2, j, url3) |>
    read_html() |>
    html_element("#search-results-table") |>
    html_table(convert = FALSE)
}, otherwise = NA_character_)) |> 
  list_rbind()

band_df2 <- 
  band_df |> 
  clean_names() |> 
  mutate(postcode = str_extract(address, "SW10 .+$"),
         raw_band_address = str_remove(address, ", London, SW10 .+$"),
         address = str_remove_all(address, remove_pattern),
         address = str_replace(address, swizzle_from, swizzle_to),
         address = str_squish(address)
  )

House price-paid data are similarly available for non-commercial use².

endpoint <- "https://landregistry.data.gov.uk/landregistry/query"

query <- '
PREFIX  xsd:  
PREFIX  text: 
PREFIX  ppd:  
PREFIX  lrcommon: 

SELECT  ?ppd_propertyAddress ?ppd_transactionCategory ?ppd_transactionDate ?ppd_pricePaid ?ppd_estateType ?ppd_propertyAddressCounty ?ppd_propertyAddressDistrict ?ppd_propertyAddressLocality ?ppd_propertyAddressPaon ?ppd_propertyAddressPostcode ?ppd_propertyAddressSaon ?ppd_propertyAddressStreet ?ppd_propertyAddressTown ?ppd_propertyType ?ppd_recordStatus

WHERE
  { { ?ppd_propertyAddress
                text:query               ( lrcommon:postcode "( SW10 )" 3000000 ) .
      ?item     ppd:propertyAddress      ?ppd_propertyAddress ;
                ppd:transactionCategory  ppd:standardPricePaidTransaction ;
                ppd:transactionDate      ?ppd_transactionDate ;
                ppd:pricePaid            ?ppd_pricePaid ;
      FILTER ( ?ppd_transactionDate >= "2020-01-01"^^xsd:date )
    }
    OPTIONAL{ ?item  ppd:estateType  ?ppd_estateType }
    OPTIONAL{ ?ppd_propertyAddress lrcommon:county  ?ppd_propertyAddressCounty}
    OPTIONAL{ ?ppd_propertyAddress lrcommon:district  ?ppd_propertyAddressDistrict}
    OPTIONAL{ ?ppd_propertyAddress lrcommon:locality  ?ppd_propertyAddressLocality}
    OPTIONAL{ ?ppd_propertyAddress lrcommon:paon  ?ppd_propertyAddressPaon}
    OPTIONAL{ ?ppd_propertyAddress lrcommon:postcode  ?ppd_propertyAddressPostcode}
    OPTIONAL{ ?ppd_propertyAddress lrcommon:saon  ?ppd_propertyAddressSaon}
    OPTIONAL{ ?ppd_propertyAddress lrcommon:street  ?ppd_propertyAddressStreet}
    OPTIONAL{ ?ppd_propertyAddress lrcommon:town  ?ppd_propertyAddressTown}
    OPTIONAL{ ?item  ppd:propertyType  ?ppd_propertyType }
    OPTIONAL{ ?item  ppd:recordStatus  ?ppd_recordStatus }
    BIND(ppd:standardPricePaidTransaction AS ?ppd_transactionCategory)
  }'

prices_list <- SPARQL(endpoint, query)

prices_df2 <-
  prices_list$results |>
  as_tibble() |> 
  clean_names() |>
  rename_with(~ str_remove_all(., "ppd_|property_address_")) |>
  mutate(
    transaction_date = as_datetime(transaction_date) |> as_date(),
    price_paid = price_paid / 1000000
  ) |>
  filter(transaction_date < "2022-01-01") |>
  mutate(
    raw_price_address = str_c(str_replace_na(saon, ""), 
                              paon, street, sep = " ") |> str_squish(),
    address = str_remove_all(raw_price_address, remove_pattern),
    address = str_replace(address, swizzle_from, swizzle_to)
  ) |>
  select(
    address,
    raw_price_address,
    postcode,
    price_paid,
    transaction_date,
    estate_type,
    property_type,
    transaction_category
  )

Now there’s a common key to join the data.

joined_df <-
  prices_df2 |>
  inner_join(band_df2, by = join_by(address, postcode)) |>
  relocate(raw_band_address, .after = raw_price_address) |>
  arrange(postcode, address) |>
  mutate(council_tax_band = factor(council_tax_band))

As with previous posts Digging Deep and House Sales, I’m focusing on postcodes in the SW10 part of London.

It’s not possible to assess all SW10 properties by band since only a tiny fraction will have been sold recently. Recent sales could though be used as a sample and Bootstrap Confidence Intervals then employed to draw a wider inference.

“Pulling yourself up by your bootstraps” originally meant doing something absurd. Later it came to mean succeeding with only what you have at your disposal. Hence only the sample will be used as a surrogate for the true population by making repeated random draws from it (with replacement).

A key assumption is that the sample is representative of the true population.

Even though only recent sales transactions have been selected, a small movement in market prices will have occurred. So ensuring the bands are reasonably well distributed over the period is worthwhile.

joined_df |>
  select(transaction_date, price_paid, council_tax_band) |>
  mutate(yearquarter = yearquarter(transaction_date)) |>
  count(yearquarter, council_tax_band) |>
  ggplot(aes(yearquarter, n, fill = council_tax_band)) +
  geom_col(position = position_fill()) +
  scale_x_yearquarter() +
  scale_y_continuous(labels = label_percent(1)) +
  scale_fill_manual(values = pal[c(1:7)]) +
  labs(
    title = "Distribution of Sales Transactions by Band & Quarter",
    x = "Quarter", y = "Proportion", fill = "Band"
  )

A violin plot of the property values by band shows some bimodal distribution and oddly shows bands E & F with lower mean prices than band D. This is worth closer inspection to ensure the sample is representative.

labels <- joined_df |>
  summarise(n = n(), mean_price = mean(price_paid),
            .by = council_tax_band)

transactions <-
  joined_df |>
  count() |>
  pull()

from <- joined_df |>
  summarise(min(transaction_date) |> yearquarter()) |>
  pull()

to <- joined_df |>
  summarise(max(transaction_date) |> yearquarter()) |>
  pull()

joined_df |>
  ggplot(aes(council_tax_band, price_paid)) +
  geom_violin(fill = pal[1]) +
  geom_label(aes(label = glue(
    "n = {n} \nAvg Price ",
    "{label_currency(prefix = '£', suffix = 'm', accuracy = 0.01)(mean_price)}"
  ), y = 16),
  data = labels, size = 2.3, alpha = 0.7, fill = "white"
  ) +
  scale_y_log10(labels = label_currency(
    prefix = "£",
    suffix = "m", accuracy = 0.1
  )) +
  labs(
    title = "Droopy Bandings",
    subtitle = glue(
      "Sample of {transactions} Property ",
      "Transactions in SW10 ({from} to {to})"
    ),
    x = "Council Tax Band", y = "Sale Price (log10 scale)",
    caption = "Sources: tax.service.gov.uk & landregistry.data.gov.uk"
  )

joined_df2 <- joined_df |>
  mutate(`SW10 0JR` = if_else(postcode == "SW10 0JR", "Yes", "No"))

It turns out that the unusual transactions below £0.3m are almost entirely from one postcode as shown below when isolating “SW10 0JR”. This appears to be a single large new development with all sub-units sold in 2020.

These specific transactions feel somewhat unusual at these banding levels. And irrespective of their accuracy, a sample of 173 postcodes heavily dominated by the transactions of just one would not be representative of the true population.

joined_df2 |>
  ggplot(aes(council_tax_band, price_paid, fill = `SW10 0JR`)) +
  geom_violin() +
  geom_label(aes(label = glue(
    "n = {n} \nAvg Price\n",
    "{label_currency(prefix = '£', suffix = 'm', accuracy = 0.01)(mean_price)}"
  ), y = 16),
  data = labels, size = 2.3, alpha = 0.7, fill = "white"
  ) +
  geom_hline(yintercept = 0.3, linetype = "dashed") +
  scale_y_log10(labels = label_currency(
    prefix = "£",
    suffix = "m", accuracy = 0.1
  )) +
  scale_fill_manual(values = pal[c(1, 5)]) +
  labs(
    title = "Unusual Bandings",
    subtitle = glue(
      "Sample of {transactions} Property ",
      "Transactions in SW10 ({from} to {to})"
    ),
    x = "Council Tax Band", y = "Sale Price (log10 scale)",
    caption = "Sources: tax.service.gov.uk & landregistry.data.gov.uk"
  )

joined_df2 |>
  count(postcode, sort = TRUE) |>
  slice_head(n = 10)

postcode	n
SW10 0JR	79
SW10 0HQ	10
SW10 9JP	8
SW10 0AA	7
SW10 0HG	7
SW10 0DD	6
SW10 9AD	6
SW10 0BF	5
SW10 0UY	5
SW10 9BT	5

So, I’ll remove this postcode.

joined_df3 <- joined_df |> 
  filter(postcode != "SW10 0JR")

This now feels like a representative sample of 326 property transactions. And broadly-speaking the plot shows a progression in average property values as we step through the bands. There is though substantial convergence between some, with the “drippy” band E still looking almost indistinguishable from band D.

labels <- joined_df3 |>
  summarise(n = n(), mean_price = mean(price_paid),
            .by = council_tax_band)

transactions <-
  joined_df3 |>
  count() |>
  pull()

joined_df3 |>
  ggplot(aes(council_tax_band, price_paid)) +
  geom_violin(fill = pal[1]) +
  geom_label(aes(label = glue(
    "n = {n} \nAvg Price ",
    "{label_currency(prefix = '£', suffix = 'm', accuracy = 0.01)(mean_price)}"
  ), y = 16),
  data = labels, size = 2.3, alpha = 0.7, fill = "white"
  ) +
  scale_y_log10(labels = label_currency(prefix = "£", 
                                       suffix = "m", accuracy = 0.1)) +
  labs(
    title = "Drippy Bandings",
    subtitle = glue(
      "Sample of {transactions} Property ",
      "Transactions in SW10 ({from} to {to})"
    ),
    x = "Council Tax Band", y = "Sale Price (log10 scale)",
    caption = "Sources: tax.service.gov.uk & landregistry.data.gov.uk"
  )

Some band E examples:

joined_df3 |>
  filter(council_tax_band == "E", price_paid >= 0.6) |>
  select(
    address = raw_price_address,
    postcode,
    transaction_date,
    price_paid,
    tax_band = council_tax_band,
    estate_type,
    property_type
  ) |>
  mutate(across(ends_with("type"), \(x) str_remove_all(x, "^.*mon/|>$"))) |>
  select(-address)

1: Removes the URL wrapped around the estate and property types, i.e. “” after the type.

postcode	transaction_date	price_paid	tax_band	estate_type	property_type
SW10 0AN	2020-03-18	0.83000	E	leasehold	flat-maisonette
SW10 0AP	2021-06-22	0.67500	E	leasehold	flat-maisonette
SW10 0AW	2021-03-29	0.69500	E	leasehold	flat-maisonette
SW10 0AX	2020-02-21	0.65000	E	leasehold	flat-maisonette
SW10 0BG	2021-03-30	0.76500	E	leasehold	flat-maisonette
SW10 0HP	2021-10-12	0.67500	E	leasehold	flat-maisonette
SW10 0LB	2021-04-15	0.63000	E	leasehold	flat-maisonette
SW10 0PE	2020-03-25	0.68000	E	leasehold	flat-maisonette
SW10 9AD	2021-06-21	1.07500	E	leasehold	flat-maisonette
SW10 9ED	2020-10-29	0.60000	E	leasehold	flat-maisonette
SW10 9JG	2021-11-16	0.91500	E	leasehold	flat-maisonette
SW10 9JX	2020-09-14	1.00000	E	leasehold	flat-maisonette
SW10 9JY	2021-08-30	1.00000	E	leasehold	flat-maisonette
SW10 9JY	2020-08-06	0.67950	E	leasehold	flat-maisonette
SW10 9PJ	2020-12-14	0.68925	E	leasehold	flat-maisonette

Can we infer that the true population of band Es no longer exhibits any difference in mean values with respect to band D?

bands_ef <- 
  joined_df3 |>
  filter(council_tax_band %in% c("E", "D"))

obs_stat <- 
  bands_ef |> 
  specify(price_paid ~ council_tax_band) |>
  calculate(stat = "diff in means", order = c("E", "D")) |>
  pull()

set.seed(2)

boot_dist <-
  bands_ef |> 
  specify(price_paid ~ council_tax_band) |>
  generate(reps = 2000, type = "bootstrap") |>
  calculate(stat = "diff in means", order = c("E", "D"))

perc_ci <- get_ci(boot_dist)

lower <- label_currency(prefix = "£", suffix = "m", accuracy = 0.01)(perc_ci |>
  pull(lower_ci))
upper <- label_currency(prefix = "£", suffix = "m", accuracy = 0.01)(perc_ci |>
  pull(upper_ci))

boot_dist |>
  visualise() +
  shade_confidence_interval(
    endpoints = perc_ci,
    color = pal[6], fill = pal[3]
  ) +
  geom_vline(xintercept = obs_stat, linetype = "dashed", colour = "white") +
  annotate("label",
    x = -0.12, y = 350, size = 3,
    label = glue(
      "Observed Difference\nBetween Bands D & E is ",
      "{label_currency(prefix = '£', suffix = 'm', accuracy = 0.01)(obs_stat)}"
    )
  ) +
  scale_x_continuous(labels = label_currency(
    prefix = "£",
    suffix = "m", accuracy = 0.1
  )) +
  labs(
    subtitle = glue(
      "95% Confident the Difference ",
      "in Mean Prices Between Bands D & E is {lower} to {upper}"
    ),
    x = "Difference in Means", y = "Count",
    caption = "Sources: tax.service.gov.uk & landregistry.data.gov.uk"
  )

Bootstrapping with a 95% confidence interval suggests the true difference in mean prices between all band D and E properties in SW10 is somewhere in the range -£0.09m to £0.11m. Considerable convergence compared to 3 decades ago when the band E minimum exceeded the band D maximum.

R Toolbox

Summarising below the packages and functions used in this post enables me to separately create a toolbox visualisation summarising the usage of packages and functions across all posts.

used_here()

Package	Function
SPARQL	SPARQL[1]
base	c[5], factor[1], library[14], max[1], mean[2], min[1], readRDS[1], seq[1], set.seed[2]
conflicted	conflict_prefer_all[1], conflict_scout[1], conflicts_prefer[2]
dplyr	across[1], arrange[1], count[4], filter[4], if_else[1], inner_join[1], join_by[1], mutate[7], n[2], pull[7], relocate[1], rename_with[1], select[5], slice_head[1], slice_sample[1], summarise[4]
ggfoundry	display_palette[1]
ggplot2	aes[7], annotate[1], geom_col[1], geom_hline[1], geom_label[3], geom_violin[3], geom_vline[1], ggplot[4], labs[5], position_fill[1], scale_fill_manual[2], scale_x_continuous[1], scale_y_continuous[1], scale_y_log10[3], theme_bw[1], theme_set[1]
glue	glue[8]
infer	calculate[2], generate[1], get_ci[1], shade_confidence_interval[1], specify[2], visualise[1]
janitor	clean_names[2]
lubridate	as_date[1], as_datetime[1]
paletteer	paletteer_d[1]
purrr	list_rbind[1], map2[1], possibly[1]
rvest	html_element[1], html_table[1]
scales	label_currency[10], label_percent[1]
stringr	str_c[4], str_extract[1], str_remove[1], str_remove_all[4], str_replace[2], str_replace_na[1], str_squish[2]
tibble	as_tibble[1]
tidyr	crossing[1]
tidyselect	ends_with[1]
tsibble	scale_x_yearquarter[1], yearquarter[3]
usedthese	used_here[1]
xml2	read_html[1]

Footnotes

This data is licensed under the Open Government Licence v3.0.↩︎
Contains HM Land Registry data © Crown copyright and database right 2021. This data is licensed under the Open Government Licence v3.0.↩︎

Sea Monsters that Lost their Way

Carl Goodwin — Sat, 04 Dec 2021 00:00:00 GMT

The Natural History Museum began recording cetacean (whales, dolphins and porpoises) strandings in 1913 (Natural History Museum 2019). Let’s explore this 1913-1989 dataset.

library(conflicted)
library(tidyverse)
conflict_prefer_all("dplyr", quiet = TRUE)
library(tidymodels)
library(probably)
library(finetune)
library(textrecipes)
library(stopwords)
library(clock)
library(glue)
library(janitor)
library(vip)
conflicts_prefer(vip::vi)
library(tictoc)
library(patchwork)
library(future)
library(paletteer)
library(ggfoundry)
library(usedthese)

conflict_scout()

plan(multisession, workers = 10)

theme_set(theme_bw())


pal_name <- "wesanderson::Darjeeling2"

pal <- paletteer_d(pal_name)

display_palette(pal, pal_name)

strandings_df <- read_csv("strandings.csv", show_col_types = FALSE) |>
  clean_names() |> 
  mutate(
    date_rep = date_parse(date, format = "%d/%m/%Y"),
    length = parse_number(length_et),
    species_lumped = fct_lump_n(species, 20),
    across(ends_with("_val"), as.integer),
    rep_comment = comment
  )

# glimpse(strandings_df)

Exploratory

Some of the species labels contain a question mark or forward slash. This indicates uncertainty, so it might be fun to see if a machine learning model (multi-class classification) could learn from the known species and suggest an appropriate species where it’s uncertain.

strandings_df2 <- 
  strandings_df |> 
  mutate(species_uncertainty =
      if_else(str_detect(species, "[?/]"), "Uncertain", "Known"))

strandings_df2 |> 
  filter(species_uncertainty == "Uncertain") |> 
  count(species, sort = TRUE, name = "Count") |> 
  slice_head(n = 6)

species	Count
delphis/coeruleoalba	48
phocoena?	42
melaena?	20
delphis?	18
truncatus?	18
acutorostrata?	12

The date variable has many NA’s. Fortunately, the components to construct many of these are in the year_val, month_val and day_val variables. With a little wrangling and imputation, we can coalesce these variables into a new date. This will be useful since plots of sample species by year, month and week of stranding suggest a de-constructed date could be a useful predictor.

strandings_df2 |> 
  select(date_rep, year_val, month_val, day_val) |> 
  summary()

    date_rep             year_val      month_val         day_val     
 Min.   :1913-02-13   Min.   :   0   Min.   : 0.000   Min.   : 0.00  
 1st Qu.:1933-09-09   1st Qu.:1933   1st Qu.: 4.000   1st Qu.: 9.00  
 Median :1954-04-13   Median :1955   Median : 7.000   Median :16.00  
 Mean   :1955-01-08   Mean   :1954   Mean   : 6.766   Mean   :15.66  
 3rd Qu.:1979-03-21   3rd Qu.:1979   3rd Qu.:10.000   3rd Qu.:22.00  
 Max.   :1989-12-25   Max.   :1989   Max.   :12.000   Max.   :31.00  
 NA's   :121

strandings_df3 <- strandings_df2 |>
  mutate(
    month_val = if_else(month_val == 0, mean(month_val) |> 
                          as.integer(), month_val),
    day_val = if_else(day_val == 0, mean(day_val) |> as.integer(), day_val),
    day_val = if_else(day_val == 0, 1L, day_val),
    date2 = date_build(year_val, month_val, day_val, invalid = "NA"),
    .by = species
  ) |> 
  mutate(date3 = coalesce(date_rep, date2),
         date_rep = if_else(is.na(date_rep), lag(date3), date3)
         ) |> 
  select(-date2, -date3, -ends_with("_val"))

example_species <-
  c("musculus", "melas", "crassidens", "borealis", "coeruleoalba")

known_species <- strandings_df3 |> 
  filter(species_uncertainty == "Known")

plot_date_feature <- \(var) {
  known_species |>
    mutate(
      year = get_year(date_rep),
      month = get_month(date_rep),
      week = as_iso_year_week_day(date_rep) |> get_week()
    ) |>
    filter(species %in% example_species) |>
    count(species, {{ var }}) |>
    ggplot(aes({{ var }}, species)) +
    geom_violin(
      alpha = 0.7,
      fill = pal[3],
      show.legend = FALSE
    ) +
    labs(
      title = glue("Variation in {str_to_title(as.character(var))}",
                   " of Stranding for Known Species"),
      x = NULL, y = glue("{str_to_title(as.character(var))}")
    )
}

c("year", "month", "week") |> 
  map(sym) |> 
  map(plot_date_feature) |> 
  wrap_plots(ncol = 1)

Do latitude and longitude carry useful predictive information?

A geospatial visualisation of strandings shows some species do gravitate towards particular stretches of coastline, e.g. “acutus” and “albirostris” to the east, and “coeruleoalba” to the south-west.

Some species may also be more prone to mass stranding, so something that indicates whether a species has such a history (in these data) may be worth including in the mix.

uki <- map_data("world", region = c("uk", "ireland"))

labels <- c("Mass", "Single")

uki |> 
  ggplot() +
  geom_map(aes(long, lat, map_id = region), map = uki, 
           colour = "black", fill = "grey90", size = 0.1) +
  geom_jitter(aes(longitude, latitude, colour = mass_single, 
                  size = mass_single), 
              alpha = 0.5, data = known_species) +
  facet_wrap(~ species_lumped, nrow = 3) +
  coord_map("mollweide") +
  scale_size_manual(values = c(1, 0.5), labels = labels) +
  scale_colour_manual(values = pal[c(3, 2)], labels = labels) +
  theme_void() +
  theme(legend.position = "top", 
        strip.text = element_text(colour = "grey50")) +
  labs(title = "Strandings by Species", 
       colour = NULL, size = NULL)

# Add history of mass stranding
strandings_df4 <- strandings_df3 |> 
  mutate(mass_possible = min(mass_single, na.rm = TRUE),
         .by = species)

Some records are missing the length measurement of the mammal. Nonetheless, where present, this is likely to be predictive, and may help, for example, separate species labelled as “delphis/coeruleoalba” where the length is at the extreme ends of the “delphis” range as we see below. And the range of length may differ by mammal sex.

known_species |>
  mutate(sex = case_match(
    sex,
    "M" ~ "Male",
    "F" ~ "Female",
    .default = "Unknown"
  )) |> 
  filter(species_lumped != "Other") |> 
  count(species_lumped, length, sex) |> 
  mutate(species_lumped = fct_reorder(species_lumped, 
                                      desc(length), min, na.rm = TRUE)) |> 
  ggplot(aes(length, species_lumped)) + 
  geom_violin(aes(fill = if_else(str_detect(species_lumped, "^de|^co"), 
                                 TRUE, FALSE)), show.legend = FALSE) +
  facet_wrap(~ sex) +
  scale_fill_manual(values = pal[c(1, 5)]) +
  labs(title = "Variation in Species Length by Sex", 
       x = NULL, y = "Length (metres)")

With map coordinates not always available, county could be, with a little string cleaning, a useful additional predictor.

strandings_df4 |> 
  count(county) |> 
  filter(str_detect(county, "Shet|Northumberland")) |> 
  rename(County = county, Count = n)

County	Count
Fair Isle, Shetland Isles	1
Northumberland	89
Northumberland.	1
Shetland Islands, Scotland	232
Shetland Isles, Scotland	35
Shetland, Scotland	1
Shetlands, Scotland	1

regex_pattern <-
  c("[,/].*$",
    "(?,
    " Isl.*$",
    " &.*$",
    "[-.]$")

strandings_df5 <- strandings_df4 |>
  mutate(
    county = str_remove_all(county, str_c(regex_pattern, collapse = "|")),
    county = recode(
      county,
      "Carnarvon" = "Caernarvon",
      "E.Lothian" = "East Lothian",
      "Shetlands" = "Shetland",
      "W.Glamorgan" = "West Glamorgan",
      "S.Glamorgan" = "South Glamorgan"
    )
  ) 

strandings_df4 |>
  summarise(counties_before = n_distinct(county))

counties_before
146

strandings_df5 |>
  summarise(counties_after = n_distinct(county))

counties_after
109

Whilst count also appears to hold, based on the plot pattern below, species-related information, I’m not going to use it as a predictor as we do not know enough about how it was derived, as reflected in these variable descriptions.

strandings_df5 |>
  ggplot(aes(count, species, colour = species_uncertainty)) +
  geom_jitter(alpha = 0.5, size = 2) +
  scale_x_log10() +
  scale_colour_manual(values = pal[c(1, 5)]) +
  labs(title = "How 'Count' Relates to Species", 
       x = NULL, y = "Count (log10)", colour = "Species") +
  theme(legend.position = "top")

Modelling

So, I’ll set aside the rows where the species is uncertain (to be used later for new predictions), and I’ll train a model on 75% of known species, and test it on the remaining 25%. I’ll use the following predictors:

latitude and longitude
Mammal length and sex
mass_possible indicating a species history of mass strandings
date reported converted into decimal, week, month and year
county may be useful, especially where the longitude and latitude are missing
fam_genus which narrows the range of likely species

I’d like to also make use of the textrecipes(Hvitfeldt 2022) package. I can tokenise the textual information in rep_comment and location to see if these add to the predictive power of the model.

I’ll tune the model using tune_race_anova(Kuhn 2022) which quickly discards hyperparameter combinations showing little early promise.

known_species <- strandings_df5 |>
  filter(species_uncertainty == "Known") |>
  mutate(across(
    c(
      "species",
      "mass_single",
      "mass_possible",
      "county",
      "location",
      "sex",
      "fam_genus"
    ),
    factor
  ))

set.seed(123)

data_split <-
  known_species |>
  mutate(species = fct_drop(species)) |> 
  initial_split(strata = species)

train <- data_split |> training()

test <- data_split |> testing()

predictors <-
  c(
    "latitude",
    "longitude",
    "length",
    "mass_single",
    "mass_possible",
    "county",
    "location",
    "rep_comment",
    "sex",
    "fam_genus"
  )

recipe <-
  train |>
  recipe() |>
  update_role(species, new_role = "outcome") |>
  update_role(all_of(predictors), new_role = "predictor") |>
  update_role(!has_role("outcome") & !has_role("predictor"), 
              new_role = "id") |>
  step_date(date_rep, features = c("decimal", "week", "month", "year"), 
            label = FALSE) |>
  step_tokenize(location, rep_comment) |>
  step_stopwords(location, rep_comment) |>
  step_tokenfilter(location, rep_comment, max_tokens = tune()) |> #100
  step_tf(location, rep_comment) |>
  step_zv(all_predictors()) |>
  step_dummy(all_nominal_predictors())

xgb_model <-
  boost_tree(trees = tune(), # 440
             mtry = tune(), # 0.6
             learn_rate = 0.02) |> 
  set_mode("classification") |>
  set_engine("xgboost", 
             count = FALSE,
             verbosity = 0,
             tree_method = "hist")

xgb_wflow <- workflow() |>
  add_recipe(recipe) |>
  add_model(xgb_model)

set.seed(9)

folds <- vfold_cv(train, strata = species)

set.seed(10)

tic()

tune_result <- xgb_wflow |>
  tune_race_anova(
    resamples = folds,
    grid = crossing(
      trees = seq(200, 520, 40),
      mtry = seq(0.5, 0.7, 0.1),
      max_tokens = seq(80, 120, 20)
      ),
    control = control_race(),
    metrics = metric_set(accuracy)
  )

toc()

119.753 sec elapsed

tune_result |> 
  plot_race() + 
  labs(title = "Early Elimination of Parameter Combinations")

set.seed(123)

xgb_fit <- xgb_wflow |>
  finalize_workflow(tune_result |> 
                      select_best(metric = "accuracy")) |> 
  fit(train)

Having fitted the model with the 3080 records in the training data, I’ll test its accuracy on the 1028 records of known species the model has not yet seen.

Without spending time on alternative models, we’re getting a reasonable result for the “porpoise” of this post, as reflected in both the accuracy metric and confusion matrix.

xgb_results <- xgb_fit |> 
  augment(new_data = test)

xgb_results |>
  accuracy(species, .pred_class)

.metric	.estimator	.estimate
accuracy	multiclass	0.9931907

xgb_results |>
  conf_mat(species, .pred_class) |>
  autoplot(type = "heatmap") +
  scale_fill_gradient2(
    mid = "white",
    high = pal[1],
    midpoint = 0
  ) +
  labs(title = "Confusion Matrix") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

The top variable importance scores include fam_genus, many of the rep_comment tokens, plus length, mass-possible, date_decimal, date_year, and latitude.

vi(xgb_fit |> extract_fit_parsnip()) |> 
  arrange(desc(Importance)) |> 
  mutate(ranking = row_number()) |> 
  slice_head(n = 40)

Variable	Importance	ranking
fam_genus_Phocoena	0.1122588	1
fam_genus_Globicephala	0.1024888	2
tf_rep_comment_unidentified	0.0715584	3
fam_genus_Delphinus	0.0631823	4
tf_rep_comment_false	0.0511217	5
fam_genus_Tursiops	0.0468992	6
fam_genus_Lagenorhynchus	0.0419043	7
fam_genus_Grampus	0.0297059	8
length	0.0284722	9
tf_rep_comment_sided	0.0272743	10
tf_rep_comment_lesser	0.0248649	11
fam_genus_Hyperoodon	0.0230048	12
tf_rep_comment_dolphin	0.0228118	13
tf_rep_comment_beaked	0.0219151	14
fam_genus_Pseudorca	0.0218223	15
tf_rep_comment_bottle	0.0215637	16
tf_rep_comment_porpoise	0.0194644	17
fam_genus_Orcinus	0.0188337	18
tf_rep_comment_long	0.0172326	19
tf_rep_comment_rorqual	0.0161952	20
fam_genus_Physeter	0.0158765	21
tf_rep_comment_finned	0.0156477	22
fam_genus_odontocete	0.0145794	23
tf_rep_comment_common	0.0142945	24
mass_possible_S	0.0135635	25
tf_rep_comment_white	0.0120380	26
fam_genus_Ziphius	0.0116641	27
fam_genus_Mesoplodon	0.0110397	28
tf_rep_comment_fin	0.0105581	29
tf_rep_comment_whale	0.0102145	30
tf_rep_comment_pilot	0.0093067	31
fam_genus_Stenella	0.0087473	32
date_rep_decimal	0.0074321	33
tf_rep_comment_risso’s	0.0069388	34
date_rep_year	0.0067197	35
fam_genus_cetacean	0.0066044	36
tf_rep_comment_sowerby’s	0.0055218	37
tf_rep_comment_nosed	0.0053597	38
tf_rep_comment_cuvier’s	0.0040589	39
tf_rep_comment_sperm	0.0029688	40

Do the predictions look reasonable?

The class probability is spread across 27 species. I’m going to set a high threshold of 0.9, meaning the predicted species needs to be a pretty confident prediction.

xgb_preds <- xgb_fit |> 
  augment(new_data = strandings_df5 |> 
            filter(species_uncertainty == "Uncertain"))

species_levels <- xgb_preds |> 
  select(starts_with(".pred_"), -.pred_class) |> 
  names() |> 
  as.factor()

subset_df <- xgb_preds |>
  mutate(
    .class_pred = make_class_pred(
      .pred_acutorostrata,
      .pred_acutus,
      .pred_albirostris,
      .pred_ampullatus,
      .pred_bidens,
      .pred_borealis,
      .pred_breviceps,
      .pred_cavirostris,
      .pred_coeruleoalba,
      .pred_crassidens,
      .pred_delphis,
      .pred_electra,
      .pred_europaeus,
      .pred_griseus,
      .pred_leucas,
      .pred_macrocephalus,
      .pred_melaena,
      .pred_melas,
      .pred_mirus,
      .pred_monoceros,
      .pred_musculus,
      .pred_novaeangliae,
      .pred_orca,
      .pred_phocoena,
      .pred_physalus,
      .pred_sp.indet.,
      .pred_truncatus,
      levels = levels(species_levels),
      min_prob = .9
    )
  )

subset_df |>
  summarise(n = n(), .by = c(species, .class_pred)) |> 
  arrange(species, desc(n)) |> 
  rename("Actual" = species, "Predicted" = .class_pred, "Count" = n)

Actual	Predicted	Count
acutorostrata/borealis	.pred_acutorostrata	1
acutorostrata?	.pred_acutorostrata	12
acutus?	.pred_acutus	3
albirostris?	.pred_albirostris	9
ampullatus?	.pred_ampullatus	3
bidens?	.pred_bidens	2
bidens?	[EQ]	1
cavirostris?	.pred_cavirostris	7
coeruleoalba?	.pred_coeruleoalba	1
delphis/coeruleoalba	[EQ]	48
delphis?	.pred_delphis	18
griseus?	.pred_griseus	2
macrocephalus?	.pred_macrocephalus	2
melaena?	.pred_melaena	20
orca?	.pred_orca	4
phocoena?	.pred_phocoena	42
physalus/acutorostrata	[EQ]	1
physalus?	.pred_physalus	4
truncatus/albirostris	[EQ]	5
truncatus?	.pred_truncatus	18

The majority of the 203 uncertain records are predicted to be as suspected in the original labelling. The remainder are classed as equivocal as they have not met the high bar of a 0.9-or-above probability for a single species.

R Toolbox

Summarising below the packages and functions used in this post enables me to separately create a toolbox visualisation summarising the usage of packages and functions across all posts.

used_here()

Package	Function
base	as.character[2], as.integer[2], c[13], is.na[1], levels[1], library[17], mean[2], min[1], names[1], seq[3], set.seed[4], summary[1]
clock	as_iso_year_week_day[1], date_build[1], date_parse[1], get_month[1], get_week[1], get_year[1]
conflicted	conflict_prefer_all[1], conflict_scout[1], conflicts_prefer[1]
dplyr	across[2], arrange[2], case_match[1], coalesce[1], count[4], desc[3], filter[7], if_else[6], lag[1], mutate[13], n[1], n_distinct[2], recode[1], rename[2], row_number[1], select[3], slice_head[2], starts_with[1], summarise[3]
finetune	control_race[1], plot_race[1], tune_race_anova[1]
forcats	fct_drop[1], fct_lump_n[1], fct_reorder[1]
future	plan[1]
generics	as.factor[1], augment[2], fit[1]
ggfoundry	display_palette[1]
ggplot2	aes[6], autoplot[1], coord_map[1], element_text[2], facet_wrap[2], geom_jitter[2], geom_map[1], geom_violin[2], ggplot[4], labs[6], map_data[1], scale_colour_manual[2], scale_fill_gradient2[1], scale_fill_manual[1], scale_size_manual[1], scale_x_log10[1], theme[3], theme_bw[1], theme_set[1], theme_void[1]
glue	glue[2]
hardhat	extract_fit_parsnip[1]
janitor	clean_names[1]
paletteer	paletteer_d[1]
parsnip	boost_tree[1], set_engine[1], set_mode[1]
patchwork	wrap_plots[1]
probably	make_class_pred[1]
purrr	map[2]
readr	parse_number[1], read_csv[1]
recipes	all_nominal_predictors[1], all_predictors[1], has_role[2], recipe[1], step_date[1], step_dummy[1], step_zv[1], update_role[3]
rsample	initial_split[1], testing[1], training[1], vfold_cv[1]
stringr	str_c[1], str_detect[3], str_remove_all[1], str_to_title[2]
textrecipes	step_stopwords[1], step_tf[1], step_tokenfilter[1], step_tokenize[1]
tictoc	tic[1], toc[1]
tidyr	crossing[1]
tidyselect	all_of[1], ends_with[2]
tune	finalize_workflow[1], select_best[1], tune[3]
usedthese	used_here[1]
vip	vi[1]
workflows	add_model[1], add_recipe[1], workflow[1]
yardstick	accuracy[1], conf_mat[1], metric_set[1]

References

Hvitfeldt, Emil. 2022. “Textrecipes: Extra ’Recipes’ for Text Processing.” https://CRAN.R-project.org/package=textrecipes.

Kuhn, Max. 2022. “Finetune: Additional Functions for Model Tuning.” https://CRAN.R-project.org/package=finetune.

Natural History Museum. 2019. “Query on the Natural History Museum Data Portal (Data.nhm.ac.uk) (4311 Records).” Natural History Museum. https://doi.org/10.5519/QD.IWG63595.

A Frosty Deal?

Carl Goodwin — Thu, 17 Sep 2020 23:00:00 GMT

Before the post-Brexit trade negotiations concluded, what did quantitative textual analysis and word embeddings tell us about the shifting trade-talk sentiment?

Reading news articles on the will-they-won’t-they post-Brexit trade negotiations with the EU sees days of optimism jarred by days of gloom. Do negative news articles, when one wants a positive outcome, leave a deeper impression?

Is it possible to get a more objective view from quantitative analysis of textual data? To do this, I’m going to look at hundreds of articles published in the Guardian newspaper over the course of the year to see how trade-talk sentiment changed week-to-week.

library(conflicted)
library(tidyverse)
conflict_prefer_all("dplyr", quiet = TRUE)
conflicts_prefer(lubridate::as_date)
library(paletteer)
library(guardianapi)
library(quanteda)
library(scales)
library(tictoc)
library(clock)
library(patchwork)
library(text2vec)
library(topicmodels)
library(slider)
library(glue)
library(ggfoundry)
library(usedthese)

conflict_scout()

theme_set(theme_bw())

pal_name <- "wesanderson::Chevalier1"

pal <- paletteer_d(pal_name)

display_palette(pal, pal_name)

The Withdrawal Agreement between the UK and the European Union was signed on the 24th of January 2020. Brexit-related newspaper articles will be imported from that date.

Note

Since publishing this article in September 2020, an agreement was reached on December 24th 2020.

The Guardian newspaper asks for requests to span no more than 1 month at a time. Creating a set of monthly date ranges will enable the requests to be chunked.

dates_df <- tibble(start_date = date_build(2020, 1:11, 25)) |> 
  mutate(end_date = add_months(start_date, 1) |> add_days(-1))

dates_df

start_date	end_date
2020-01-25	2020-02-24
2020-02-25	2020-03-24
2020-03-25	2020-04-24
2020-04-25	2020-05-24
2020-05-25	2020-06-24
2020-06-25	2020-07-24
2020-07-25	2020-08-24
2020-08-25	2020-09-24
2020-09-25	2020-10-24
2020-10-25	2020-11-24
2020-11-25	2020-12-24

Important

Access to the Guardian’s API via guardianapi(Odell 2019) requires a key which may be requested here and stored as GU_API_KEY= in the .Renviron file.

tic()

read_slowly <- slowly(gu_content)

article_df <-
  pmap(dates_df, \(start_date, end_date) {
    read_slowly(
      "brexit",
      from_date = start_date,
      to_date = end_date
    )
  }) |> 
  list_rbind()

toc()

The data need a little cleaning, for example, to remove multi-topic articles, html tags and non-breaking spaces.

trade_df <-
  article_df |>
  filter(!str_detect(id, "/live/"), 
         section_id %in% c("world", "politics", "business")) |>
  mutate(
    body = str_remove_all(body, "<.*?>") |> str_to_lower(),
    body = str_remove_all(body, "[^a-z0-9 .-]"),
    body = str_remove_all(body, "nbsp")
  )

A corpus then gives me a collection of texts whereby each document is a newspaper article.

trade_corp <- trade_df |> 
  corpus(docid_field = "short_url", 
         text_field = "body", unique_docnames = FALSE)

Although only articles mentioning Brexit have been imported, some of these will not be related to trade negotiations with the EU. For example, there are on-going negotiations with many countries around the world. So, word embeddings(Selivanov, Bickel, and Wang 2022) will help to narrow the focus to the specific context of the UK-EU trade deal.

The chief negotiator for the EU is Michel Barnier, so I’ll quantitatively identify words in close proximity to “Barnier” in the context of these Brexit news articles.

window <- 5

trade_fcm <-
  trade_corp |>
  tokens() |> 
  fcm(context = "window", window = window, 
      count = "weighted", weights = window:1)

glove <- GlobalVectors$new(rank = 60, x_max = 10)

set.seed(42)

wv_main <- glove$fit_transform(trade_fcm, n_iter = 10)

INFO  [11:53:21.069] epoch 1, loss 0.3797
INFO  [11:53:22.349] epoch 2, loss 0.2565
INFO  [11:53:23.648] epoch 3, loss 0.2290
INFO  [11:53:24.907] epoch 4, loss 0.2086
INFO  [11:53:26.164] epoch 5, loss 0.1919
INFO  [11:53:27.414] epoch 6, loss 0.1792
INFO  [11:53:28.669] epoch 7, loss 0.1695
INFO  [11:53:29.919] epoch 8, loss 0.1620
INFO  [11:53:31.172] epoch 9, loss 0.1558
INFO  [11:53:32.425] epoch 10, loss 0.1507

wv_context <- glove$components
word_vectors <- wv_main + t(wv_context)

search_coord <- 
  word_vectors["barnier", , drop = FALSE]

word_vectors |> 
  sim2(search_coord, method = "cosine") |> 
  as_tibble(rownames = NA) |> 
  rownames_to_column("term") |> 
  rename(similarity = 2) |> 
  slice_max(similarity, n = 10)

term	similarity
barnier	1.0000000
frost	0.8212195
michel	0.8081586
negotiator	0.7688649
brussels	0.7139891
negotiators	0.7022531
eus	0.6570144
team	0.6551399
tweeted	0.6414501
chief	0.6102063

Word embedding is a learned modelling technique placing words into a multi-dimensional vector space such that contextually-similar words may be found close by. Not surprisingly, one of the closest words contextually is “Michel”. And as he is the chief negotiator for the EU, we find “negotiator” and “brussels” also in the top most contextually-similar words.

The word embeddings algorithm, through word co-occurrence, has identified the name of Michel Barnier’s UK counterpart David Frost. So filtering articles for “Barnier”, “Frost” and “UK-EU” should help narrow the focus.

context_df <- 
  trade_df |> 
  filter(str_detect(body, "barnier|frost|uk-eu")) 

context_corp <- 
  context_df |> 
  distinct() |> 
  corpus(docid_field = "short_url", text_field = "body")

Quanteda’s(Benoit et al. 2018) kwic function shows key phrases in context to ensure we’re homing in on the required texts. Short URLs are included below so one can click on any to read the actual article as presented by The Guardian.

set.seed(123)

context_corp |>
  tokens(
    remove_punct = TRUE,
    remove_symbols = TRUE,
    remove_numbers = TRUE
  ) |>
  kwic(pattern = phrase(c("trade negotiation", "trade deal", "trade talks")), 
       valuetype = "regex", window = 7) |>
  as_tibble() |>
  left_join(article_df, by = join_by(docname == short_url)) |> 
  slice_sample(n = 10) |> 
  select(docname, pre, keyword, post, headline)

docname	pre	keyword	post	headline
https://www.theguardian.com/p/en8ec	government as incompetent failing to secure a	trade deal	would give the labour leader another front	Brexit withdrawal deal: what is No 10 playing at?
https://www.theguardian.com/p/dag4n	the uk could not have the same	trade deal	with the eu as canada he said	Brexit deal ‘a different ball game’ to Canada agreement, warns EU
https://www.theguardian.com/p/en752	a linkage between subsidy rules in free	trade deals	with common ground proving difficult to find	Von der Leyen warns UK against breaking international law over Brexit deal
https://www.theguardian.com/p/fptbj	had to choose between a relatively thin	trade deal	and no deal and to no great	Brexit talks followed common pattern but barrier-raising outcome is unique
https://www.theguardian.com/p/dpzjp	related whats at stake in britains post-brexit	trade talks	the uk government wants to include eu-derived	UK to publish draft treaty in effort to reboot Brexit process
https://www.theguardian.com/p/fmmga	its pretty clear when you do a	trade deal	that you are a sovereign nation the	EU leaders stress unity as they welcome Brexit trade talks extension
https://www.theguardian.com/p/f63be	for a no-deal outcome on january the	trade talks	are over the eu has effectively ended	What was the point of Johnson’s Brexit statement? To save face
https://www.theguardian.com/p/f7tf4	by michel barnier broke the impasse in	trade talks	the fts on that story but naturally	Thursday briefing: Iran and Russia ‘interfere’ as Obama lays into Trump
https://www.theguardian.com/p/fk5kt	companies await news of a potential uk-eu	trade deal	abf said our businesses have completed all	Primark reports ‘phenomenal’ trading since lockdowns ended
https://www.theguardian.com/p/evgxe	in talks trying to thrash out a	trade deal	before january but after the chief negotiators	Wednesday briefing: Tory revolt over Cummings piles pressure on PM

Quanteda provides a sentiment dictionary which, in addition to identifying positive and negative words, also finds negative-negatives and negative-positives such as, for example, “not effective”. For each week’s worth of articles, we can calculate the proportion of positive sentiments.

tic()

sent_df <- 
  context_corp |> 
  tokens() |> 
  dfm() |> 
  dfm_lookup(data_dictionary_LSD2015) |> 
  convert(to = "data.frame") |>
  left_join(context_df, by = join_by(doc_id == short_url)) |> 
  mutate(
    pos = positive + neg_negative,
    neg = negative + neg_positive,
    web_date = date_ceiling(as_date(web_publication_date), "week"),
    pct_pos = pos / (pos + neg)
  )

sent_df |> 
  select(Article = doc_id, "Pos Score" = pos, "Neg Score" = neg) |> 
  slice(1:10)

Article	Pos Score	Neg Score
https://www.theguardian.com/p/d6qhb	40	22
https://www.theguardian.com/p/d9e9j	27	15
https://www.theguardian.com/p/d6kzd	51	27
https://www.theguardian.com/p/d79cn	56	48
https://www.theguardian.com/p/d6t3c	27	26
https://www.theguardian.com/p/d9vjq	13	23
https://www.theguardian.com/p/d7n8b	54	34
https://www.theguardian.com/p/d9xtf	33	13
https://www.theguardian.com/p/dag4n	37	35
https://www.theguardian.com/p/d7d9t	22	11

summary_df <- sent_df |> 
  summarise(pct_pos = mean(pct_pos), 
            n = n(),
            .by = web_date)

toc()

0.616 sec elapsed

Plotting the changing proportion of positive sentiment over time did surprise me a little. The outcome was more balanced than I expected which perhaps confirms the deeper impression left on me by negative articles.

The upper plot shows a rolling 7-day mean with a narrowing ribbon representing a narrowing variation in sentiment.

The lower plot shows the volume of articles. As we drew closer to the crunch-point the volume picked up.

width <- 7

sent_df2 <- sent_df |>
  mutate(web_date = as_date(web_publication_date)) |> 
  group_by(web_date) |>
  summarise(pct_pos = sum(pos) / sum(neg + pos)) |> 
  mutate(
    roll_mean = slide_dbl(pct_pos, mean, .before = 6),
    roll_lq = slide_dbl(pct_pos, ~ quantile(.x, probs = 0.25), .before = 6),
    roll_uq = slide_dbl(pct_pos, ~ quantile(.x, probs = 0.75), .before = 6)
  )

p1 <- sent_df2 |>
  ggplot(aes(web_date)) +
  geom_line(aes(y = roll_mean), colour = pal[1]) +
  geom_ribbon(aes(ymin = roll_lq, ymax = roll_uq), 
              alpha = 0.33, fill = pal[1]) +
  geom_hline(yintercept = 0.5, linetype = "dashed", 
             colour = pal[4], linewidth = 1) +
  scale_y_continuous(labels = label_percent(accuracy = 1)) +
  labs(
    title = "Changing Sentiment Towards a UK-EU Trade Deal",
    subtitle = glue("Rolling {width} days Since the Withdrawal Agreement"),
    x = NULL, y = "Positive Sentiment"
  )

p2 <- summary_df |> 
  ggplot(aes(web_date, n)) +
  geom_line(colour = pal[1]) +
  labs(x = "Weeks", y = "Article Count",
       caption = "Source: Guardian Newspaper")

p1 / p2 + 
  plot_layout(heights = c(2, 1))

R Toolbox

Summarising below the packages and functions used in this post enables me to separately create a toolbox visualisation summarising the usage of packages and functions across all posts.

used_here()

Package	Function
Matrix	t[1]
base	c[3], library[15], mean[1], set.seed[2], sum[2]
clock	add_days[1], add_months[1], date_build[1], date_ceiling[1]
conflicted	conflict_prefer_all[1], conflict_scout[1], conflicts_prefer[1]
dplyr	distinct[1], filter[2], group_by[1], join_by[2], left_join[2], mutate[5], n[1], rename[1], select[2], slice[1], slice_max[1], slice_sample[1], summarise[2]
ggfoundry	display_palette[1]
ggplot2	aes[4], geom_hline[1], geom_line[2], geom_ribbon[1], ggplot[2], labs[2], scale_y_continuous[1], theme_bw[1], theme_set[1]
glue	glue[1]
lubridate	as_date[2]
methods	new[1]
mlapi	fit_transform[1]
paletteer	paletteer_d[1]
patchwork	plot_layout[1]
purrr	list_rbind[1], pmap[1], slowly[1]
quanteda	convert[1], corpus[2], dfm[1], dfm_lookup[1], fcm[1], kwic[1], phrase[1], tokens[3]
scales	label_percent[1]
slider	slide_dbl[3]
stats	quantile[2]
stringr	str_detect[2], str_remove_all[3], str_to_lower[1]
text2vec	sim2[1]
tibble	as_tibble[2], rownames_to_column[1], tibble[1]
tictoc	tic[2], toc[2]
usedthese	used_here[1]

References

Benoit, Kenneth, Kohei Watanabe, Haiyan Wang, Paul Nulty, Adam Obeng, Stefan Müller, and Akitaka Matsuo. 2018. “Quanteda: An r Package for the Quantitative Analysis of Textual Data” 3: 774. https://doi.org/10.21105/joss.00774.

Odell, Evan. 2019. “Guardianapi: Access the ’Guardian’ Newspaper Open Data API.” https://doi.org/10.5281/zenodo.2551001.

Selivanov, Dmitriy, Manuel Bickel, and Qing Wang. 2022. “Text2vec: Modern Text Mining Framework for r.” https://CRAN.R-project.org/package=text2vec.

The Goldilocks Principle

Carl Goodwin — Sat, 08 Aug 2020 23:00:00 GMT

The Goldilocks principle has its origins in a children’s story about a girl who tastes the bowls of porridge left by three bears. She prefers the one that is neither too hot nor too cold, but is just right.

When it comes to investing in stocks, how many is “just right”?

library(conflicted)
library(tidyverse)
conflict_prefer_all("dplyr", quiet = TRUE)
library(scales)
library(truncnorm)
library(paletteer)
library(ggfoundry)
library(usedthese)

conflict_scout()

I’ll use this palette.

theme_set(theme_bw())

pal_name <- "wesanderson::Darjeeling2"

pal <- paletteer_d(pal_name)

display_palette(pal, pal_name)

Suppose the average stock market return is around 10%. And you do extensive research, burning the midnight oil, poring over stock fundamentals. Or perhaps you develop a cool machine learning model. And you arrive at a list of 50 promising stocks you feel confident would, on average, deliver well-above-market returns.

I’ll create some randomly made up stocks with an average return close to 40%. Some will tank due to events one could not foresee; I’ll allow some to lose up to 20%. Similarly, some could generate exceptional returns.

set.seed(123)

stock_data <- tibble(
  stock = chartr("0123456789", "abcdefghij", sample(50)),
  return = rtruncnorm(50, a = -0.2, mean = 0.4, sd = 0.5)
)

mean(stock_data$return)

[1] 0.4200244

Here’s the resultant distribution I’ll use to assess the impact of portfolio size. Stock markets are fairly close to a normal distribution, albeit with fatter tails due to a few extreme outcomes.

stock_data |> 
  ggplot(aes(return)) +
  geom_histogram(fill = pal[2]) +
  scale_x_continuous(labels = label_percent()) +
  labs(title = "50 Randomly-generated Stock Returns", 
       x = "Annual Return", y = "Count")

Now suppose you share 2 stocks, selected at random, with 1,000 of your social network friends (selecting a different pair of stocks for each friend). Will they all still be friends a year later? And if you repeated the same scenario with portfolio sizes of 5, 10, 20 and 50 stocks per person, would that change the outcome? Let’s see.

portfolio <- \(x) {
  stock_data |>
    slice_sample(n = x, replace = TRUE) |>
    summarise(
      portfolio_return = mean(return),
      portfolio_size = x
    ) |>
    bind_rows()
}

set.seed(456)

portfolios <-
  map(c(
    rep(2, 1000),
    rep(5, 1000),
    rep(10, 1000),
    rep(20, 1000),
    rep(50, 1000)
  ), portfolio) |>
  list_rbind() |> 
  mutate(portfolio_size = factor(portfolio_size))

mean_returns <- portfolios |>
  summarise(
    mean_return = mean(portfolio_return),
    min_return = min(portfolio_return),
    .by = portfolio_size
  )

portfolios |>
  ggplot(aes(portfolio_size, portfolio_return, group = portfolio_size)) +
  geom_violin(aes(fill = portfolio_size), show.legend = FALSE) +
  geom_label(aes(portfolio_size, 1.5,
    label = percent(mean_return, accuracy = 1)
  ),
  data = mean_returns, fill = pal[4],
  ) +
  geom_label(aes(portfolio_size, -0.2,
    label = percent(min_return, accuracy = 1)
  ),
  data = mean_returns, fill = pal[1],
  ) +
  scale_y_continuous(labels = label_percent(), breaks = breaks_extended(9)) +
  scale_fill_manual(values = pal[c(1:5)]) +
  labs(
    x = "Portfolio Size", y = "Return",
    title = "How Portfolio Size Changes Downside & Upside Risk",
    subtitle = "BLUE Labels = Mean Return; BROWN Labels = Worst Return"
  )

So, for all portfolio sizes, the average return across your 1,000 friends is around 42%.

But, when the portfolio size is 2, you may be erased from a few Christmas card lists (or worse). If one of those two stocks has an extreme negative outcome, there’s little else in the portfolio to dissipate the effect. As the portfolio size increases, the risk (downside and upside) dramatically reduces.

But is more always better? Well, irrespective of whether your list of promising stocks resulted from desk research or a model, there will be a varying degree of confidence in the 50. A machine learning model, for example, would assign class probabilities to each stock.

So by picking a smaller number, one can select those in which one feels most confident, or which have the highest class probability. And by picking a larger number (ideally across different sectors to further reduce risk) one can weaken the effects of a bad egg or two caused by events no research or model could foresee.

So perhaps the answer is to pick a worst-case scenario one would be prepared to accept. In the plot above, accepting a small chance of only a 12% return (still better than the historical average market return), might provide the “just right” portfolio. A portfolio of a manageable size, focused on your highest-confidence stocks, and with pretty good odds of the desired return.

R Toolbox

Summarising below the packages and functions used in this post enables me to separately create a toolbox visualisation summarising the usage of packages and functions across all posts.

used_here()

Package	Function
base	c[2], chartr[1], factor[1], library[7], mean[3], min[1], rep[5], sample[1], set.seed[2]
conflicted	conflict_prefer_all[1], conflict_scout[1]
dplyr	bind_rows[1], mutate[1], slice_sample[1], summarise[2]
ggfoundry	display_palette[1]
ggplot2	aes[5], geom_histogram[1], geom_label[2], geom_violin[1], ggplot[2], labs[2], scale_fill_manual[1], scale_x_continuous[1], scale_y_continuous[1], theme_bw[1], theme_set[1]
paletteer	paletteer_d[1]
purrr	list_rbind[1], map[1]
scales	breaks_extended[1], label_percent[2], percent[2]
tibble	tibble[1]
truncnorm	rtruncnorm[1]
usedthese	used_here[1]

Weathering the Storm

Carl Goodwin — Sat, 01 Aug 2020 23:00:00 GMT

In 2020, Covid-19 began battering financial markets now further impacted by the war in Ukraine. Which sectors are faring best?

I’ll compare each sector in the S&P 500 with the overall market. Baselining each at zero as of February 19th, we’ll see which were the first to recover lost ground.

library(conflicted)
library(tidyverse)
conflict_prefer_all("dplyr", quiet = TRUE)
library(scales)
library(glue)
library(tidyquant)
library(clock)
conflicts_prefer(clock::date_format)
library(paletteer)
library(ggfoundry)
library(usedthese)

conflict_scout()

theme_set(theme_bw())

pal_name <- "wesanderson::Moonrise2"

pal <- paletteer_d(pal_name)

display_palette(pal, pal_name)

symbols <-
  c(
    "SPY",
    "XLV",
    "XLK",
    "XLE",
    "XLF",
    "XLC",
    "XLI",
    "XLY",
    "XLP",
    "XLRE",
    "XLU",
    "XLB"
  )

from <- "2020-02-19"

from_formatted <- date_parse(from, format = "%Y-%m-%d") |> 
  date_format(format = "%b %d, %Y")

eod_sectors <-
  tq_get(symbols, from = from) |>
  mutate(
    norm_close = adjusted / first(adjusted) - 1,
    type = if_else(symbol == "SPY", "Market", "Sector"),
    sector = case_match(
      symbol,
      "SPY"  ~ "S&P 500",
      "XLB"  ~ "Materials",
      "XLE"  ~ "Energy",
      "XLU"  ~ "Utilities",
      "XLI"  ~ "Industrical",
      "XLRE" ~ "Real Estate",
      "XLV"  ~ "Health",
      "XLK"  ~ "Technology",
      "XLF"  ~ "Financial",
      "XLC"  ~ "Communication",
      "XLY"  ~ "Consumer Discretionary",
      "XLP"  ~ "Consumer Staples",
      .default = "Other"
    ), .by = symbol
  ) |>
  drop_na()

Perhaps not too surprising to see that Tech led the way back from Covid. But with the further impact of the situation in Ukraine, the Energy sector is now the strongest performer relative to February 2020. Comms, with all that home-working, benefited initially during the lockdown, but has faded since.

eod_sectors |>
  mutate(
    sector = str_wrap(sector, 12),
    sector = fct_reorder(sector, norm_close, last, .desc = TRUE)
  ) |>
  ggplot(aes(date, norm_close, colour = sign(norm_close))) +
  geom_hline(yintercept = 0, linetype = "dashed", colour = "grey80") +
  geom_line() +
  facet_wrap(~sector) +
  scale_colour_gradient(low = pal[2], high = pal[1]) +
  scale_y_continuous(labels = label_percent()) +
  labs(
    title = "S&P 500 Sector Impact of Covid-19 & Ukraine",
    subtitle = glue("Relative to {from_formatted}"),
    x = NULL, y = NULL, colour = NULL
  ) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1),
        legend.position = "none")

R Toolbox

Summarising below the packages and functions used in this post enables me to separately create a toolbox visualisation summarising the usage of packages and functions across all posts.

used_here()

Package	Function
base	c[1], library[9], sign[1]
clock	date_format[1], date_parse[1]
conflicted	conflict_prefer_all[1], conflict_scout[1], conflicts_prefer[1]
dplyr	case_match[1], first[1], if_else[1], mutate[2]
forcats	fct_reorder[1]
ggfoundry	display_palette[1]
ggplot2	aes[1], element_text[1], facet_wrap[1], geom_hline[1], geom_line[1], ggplot[1], labs[1], scale_colour_gradient[1], scale_y_continuous[1], theme[1], theme_bw[1], theme_set[1]
glue	glue[1]
paletteer	paletteer_d[1]
scales	label_percent[1]
stringr	str_wrap[1]
tidyquant	tq_get[1]
tidyr	drop_na[1]
usedthese	used_here[1]

Favourite Things

Carl Goodwin — Sat, 25 Jul 2020 23:00:00 GMT

Each project closes with a table summarising the R tools used. By aggregating the package and function usage across all projects, there’s an opportunity to:

Spot the use of superseded functions like map_dfr
Check for usage consistency, e.g. clock::date_today versus Sys.Date
See where it would be most useful to keep an eye on package version updates

Since starting this in 2017, functions like tidyr’s spread and gather have been superseded by pivot_wider and pivot_longer. Newer packages have emerged like tidyclust, which brings cluster modelling to tidymodels (now used in Finding Happiness in ‘The Smoke’). bslib has brought improvements to the latest shiny app version embedded in Plots Thicken. The paletteer package has put it’s arms around the myriad palette packages out there. And scales’ cut_short_scale assisted with plot labelling.

More recently, dplyr and purrr have presented a host of enhancements. For example, the .by argument in mutate and friends offers a concise temporary alternative to group_by and ungroup in many situations. Joins have been enhanced (e.g. to support inequality conditions) with the addition of join_by to dplyr. And changes in the map_ family introduce list_rbind and associates with map_dfr, for example, now superseded.

library(conflicted)
library(tidyverse)
conflict_prefer_all("dplyr", quiet = TRUE)
library(tidytext)
library(rvest)
library(paletteer)
library(janitor)
library(glue)
library(ggwordcloud)
library(patchwork)
library(clock)
library(geomtextpath)
library(ggfoundry)
library(usedthese)

conflict_scout()

theme_set(theme_bw())

pal_name <- "LaCroixColoR::CranRaspberry"

pal <- paletteer_d(pal_name)

display_palette(pal, pal_name)

Separation of tidyverse and non-tidyverse packages may be achieved by using the likes of tidyverse_packages which lists all packages in the tidyverse.

tidy <-
  c(
    tidyverse::tidyverse_packages(),
    fpp3::fpp3_packages(),
    tidymodels::tidymodels_packages()
  ) |>
  unique()

used_here() has already been used in Quantum Jitter projects to generate a usage table at the foot of each project with the CSS class usedthese. used_there() may now be used to web-scrape all the tables with this class to aggregate package and function usage data.

base_packages <- c(
  "stats",
  "graphics",
  "grDevices",
  "utils",
  "datasets",
  "methods",
  "base"
)

used_df <-
  used_there("https://www.quantumjitter.com/project/") |>
  mutate(multiverse = case_match(
    Package,
    tidy ~ "tidy",
    base_packages ~ "base",
    .default = "special"
  ))

n_url <- used_df |> summarise(n_distinct(url)) |> pull()

pack_df <- used_df |>
  count(Package, multiverse, wt = n) |>
  mutate(name = "package")

fun_df <- used_df |>
  count(Function, multiverse, wt = n) |>
  mutate(name = "function")

packfun_df <- pack_df |>
  bind_rows(fun_df) |>
  arrange(desc(n)) |>
  mutate(
    packfun = coalesce(Package, Function),
    name = fct_rev(name),
    .by = name
  )

My most commonly used packages and functions are revealed with the help of geomtextpath (Cameron and Brand 2024) and a pair of “Catherine wheel” plots.

prep_data <- \(x, y){
  used_df |>
    count({{ x }}, multiverse, wt = n) |>
    filter(n > y) |>
    arrange(multiverse, n) |>
    mutate(row = row_number())
}

radial_df <- prep_data(Package, 10)
radial_df2 <- prep_data(Function, 20)

prep_lines <- \(data){
  data |>
    summarise(
      start = min(row),
      end = max(row),
      .by = multiverse
    )
}

lines_df <- prep_lines(radial_df)
lines_df2 <- prep_lines(radial_df2)

prep_plot <- \(data, data2, x){
  data |>
    mutate({{ x }} := fct_reorder({{ x }}, row)) |>
    ggplot(aes({{ x }}, n, fill = multiverse, colour = multiverse)) +
    geom_col(colour = pal[6]) +
    geom_textpath(aes(label = n), colour = "white", vjust = -0.2, size = 3) +
    geom_textpath(aes(label = {{ x }}),
      size = 3, colour = "black",
      text_only = TRUE, offset = unit(-10, "pt"), angle = -70, hjust = 1
    ) +
    geom_textsegment(
      aes(start, 0.6, xend = end, yend = 0.6, label = multiverse),
      data = data2,
      linewidth = 1,
      size = 2, gap = FALSE,
      offset = unit(-7, "pt")
    ) +
    coord_radial(inner.radius = 0.25) +
    scale_y_log10() +
    scale_fill_manual(values = pal[c(1, 4, 5)]) +
    scale_colour_manual(values = pal[c(1, 4, 5)]) +
    theme_void() +
    theme(
      axis.text.x = element_blank(),
      legend.position = "none"
    )
}

p1 <- prep_plot(radial_df, lines_df, Package)
p2 <- prep_plot(radial_df2, lines_df2, Function)

p1 + p2 + plot_annotation(
  title = "Top Package & Function Usage",
  subtitle = glue("Across {n_url} Projects"),
  theme = theme(
    plot.title = element_text(hjust = 0.5),
    plot.subtitle = element_text(hjust = 0.5)
  )
)

This last code chunk generates the word cloud for use as the feature image for this project.

set.seed = 123

packfun_df |>
  mutate(angle = 45 * sample(-2:2, n(), 
                             replace = TRUE, 
                             prob = c(1, 1, 4, 1, 1))) |>
  ggplot(aes(
    label = packfun,
    size = n,
    colour = multiverse,
    angle = angle
  )) +
  geom_text_wordcloud(
    eccentricity = 1,
    grid_margin = 0.95,
    seed = 789
  ) +
  scale_size_area(max_size = 20) +
  scale_colour_manual(values = pal[c(1, 6, 5)]) +
  theme_void() +
  theme(plot.background = element_rect(fill = "white"))

R Toolbox

This project’s code too should be included in my “favourite things”.

used_here()

Package	Function
base	c[6], library[13], max[1], min[1], sample[1], unique[1]
conflicted	conflict_prefer_all[1], conflict_scout[1]
dplyr	arrange[2], bind_rows[1], case_match[1], coalesce[1], count[3], desc[1], filter[1], mutate[7], n[1], n_distinct[1], pull[1], row_number[1], summarise[2]
forcats	fct_reorder[1], fct_rev[1]
geomtextpath	geom_textpath[2], geom_textsegment[1]
ggfoundry	display_palette[1]
ggplot2	aes[5], coord_radial[1], element_blank[1], element_rect[1], element_text[2], geom_col[1], ggplot[2], scale_colour_manual[2], scale_fill_manual[1], scale_size_area[1], scale_y_log10[1], theme[3], theme_bw[1], theme_set[1], theme_void[2]
ggwordcloud	geom_text_wordcloud[1]
glue	glue[1]
grid	unit[2]
paletteer	paletteer_d[1]
patchwork	plot_annotation[1]
tidymodels	tidymodels_packages[1]
tidyverse	tidyverse_packages[1]
usedthese	used_here[1], used_there[1]

References

Cameron, Allan, and Teun van den Brand. 2024. “Geomtextpath: Curved Text in ’Ggplot2’.” https://CRAN.R-project.org/package=geomtextpath.

East-West Drift

Carl Goodwin — Wed, 09 Jan 2019 00:00:00 GMT

In Finding Happiness in ‘The Smoke’, dimension reduction and cluster analysis are used to see how different characteristics group London boroughs.

Dimension reduction is used here to visualise the grouping of UN members, for example five of the founding members, based on their General Assembly voting patterns. And by using animation, it’s possible to more easily see changes over time. Are they drifting closer or farther apart?

General Assembly votes are obtained from unvotes(Robinson 2021) and the visualisation animated using gganimate(Pedersen and Robinson 2022).

library(conflicted)
library(tidyverse)
conflict_prefer_all("dplyr", quiet = TRUE)
library(tidymodels)
library(tsibble)
library(gganimate)
library(clock)
conflicts_prefer(clock::date_format)
library(unvotes)
library(patchwork)
library(rvest)
library(glue)
library(paletteer)
library(ggfoundry)
library(usedthese)

conflict_scout()

theme_set(theme_bw())

pal_name <- "wesanderson::GrandBudapest2"

pal <- paletteer_d(pal_name)
pal <- colorRampPalette(pal)(5)

display_palette(pal, pal_name)

raw_df <- un_votes |> 
  inner_join(un_roll_calls, by = join_by(rcid)) |> 
  select(vote_date = date, everything()) |> 
  filter(country_code %in% c("GB", "CN", "US", "FR", "RU")) |>
  mutate(
    country = recode(
      country_code,
      GB = "UK",
      CN = "China",
      FR = "France",
      RU = "Russia"
    ),
    vote_date = date_parse(as.character(vote_date), 
                           format = "%Y-%m-%d")
  )

from <- raw_df |>
  summarise(min(get_year(vote_date))) |>
  pull()

to <- raw_df |>
  summarise(max(get_year(vote_date))) |>
  pull()

Applying a sliding window to the roll-calls from 1946 to 2019 will make it possible to show the temporal changes.

tidy_df <- raw_df |>
  arrange(vote_date, rcid) |>
  nest(.by = c(vote_date, rcid)) |>
  mutate(vote_id = row_number(), year = get_year(vote_date)) |>
  unnest(data) |>
  complete(country, nesting(vote_id)) |>
  mutate(vote = replace_na(as.character(vote), "na"), value = 1) |>
  group_by(vote_id) |>
  fill(year, .direction = "updown") |>
  mutate(variation = n_distinct(vote)) |>
  ungroup() |>
  filter(variation != 1) |>
  select(country, vote_id, year, vote, value)

wdow_df <- tidy_df |>
  as_tsibble(key = country, index = vote_id) |>
  nest(.by = vote_id) |>
  slide_tsibble(.size = 1000, .step = 250, .id = "slide_id") |>
  unnest(data) |>
  as_tibble() |>
  arrange(slide_id, vote_id, country)

Dimensionality reduction may be performed on each window. And the voting patterns are then visualised as a two-dimensional animation.

wdows <- wdow_df |>
  summarise(max(slide_id)) |>
  pull()

slide_pca <- \(x) {
  wide_df <- wdow_df |>
    filter(slide_id == x) |>
    pivot_wider(
      id_cols = c(country, slide_id),
      names_from = c(vote_id, vote),
      values_from = value,
      values_fill = 0
    )

  pca_fit <- wide_df |>
    select(-c(country, slide_id)) |>
    prcomp(scale = TRUE) |>
    augment(wide_df) |>
    select(slide_id, country, .fittedPC1, .fittedPC2)
}

pca_windows <- map(1:wdows, slide_pca) |> list_rbind()

p <- pca_windows |>
  mutate(east_west = if_else(country %in% c("China", "Russia"), 
                             "East", "West")) |>
  ggplot(aes(.fittedPC1, .fittedPC2)) +
  geom_label(aes(label = country, fill = east_west)) +
  scale_fill_manual(values = pal[c(1, 3)]) +
  transition_time(slide_id) +
  labs(
    title = glue("P5 Distance for the Period {from} to {to}"),
    subtitle = "Frame {frame} of {nframes}",
    x = "Principal Component 1",
    y = "Principal Component 2",
    fill = NULL,
    caption = "Source: unvotes"
  ) +
  shadow_wake(wake_length = 0.1, wrap = FALSE)
  
animate(p, fps = 5, end_pause = 10)

France and the UK, for example, have remained particularly close given their historical ties and geographical proximity.

The UN’s Security Council Veto List provides further insights on the changing profile of P5 voting over the decades.

url <- "https://www.un.org/depts/dhl/resguide/scact_veto_table_en.htm"

meeting_df <- url |>
  read_html() |>
  html_element(".tablefont") |>
  html_table(fill = TRUE) |>
  select(vote_date = 1, draft = 2, meeting = 3, agenda = 4, vetoed_by = 5) |>
  slice(-c(1:2))

meeting_df2 <- meeting_df |>
  mutate(
    vote_date = str_remove(vote_date, "-(?:\\d{2}|\\d)"),
    vote_date = date_parse(vote_date, format = "%d %B %Y"),
    vote_date = if_else(get_year(vote_date) == "86", 
                        date_build(1986, 01, 01), vote_date),
    vetoed_by = str_replace(vetoed_by, "USSR", "Russia"),
    Russia = if_else(str_detect(vetoed_by, "Russia"), 1, 0),
    China = if_else(str_detect(vetoed_by, "China"), 1, 0),
    France = if_else(str_detect(vetoed_by, "France"), 1, 0),
    US = if_else(str_detect(vetoed_by, "US"), 1, 0),
    UK = if_else(str_detect(vetoed_by, "UK"), 1, 0)
  ) |>
  pivot_longer(c(Russia:UK), names_to = "country", values_to = "veto") |>
  filter(veto == 1)

country_df <- meeting_df2 |>
  count(country) |>
  mutate(country = fct_reorder(country, n))

little_plot <- country_df |>
  ggplot(aes(n, country, fill = country)) +
  geom_col() +
  scale_fill_manual(values = pal[c(1:5)]) +
  geom_label(aes(label = n), colour = "white", hjust = "inward") +
  labs(
    x = NULL, y = NULL, fill = NULL, title = "Most Vetoes",
    caption = "Source: research.un.org"
  )

year_df <- meeting_df2 |>
  mutate(year = get_year(vote_date)) |>
  count(year, country)

to_date <- format(max(meeting_df2$vote_date), "%b %d, %y")

big_plot <- year_df |>
  ggplot(aes(year, n, fill = country)) +
  geom_col(show.legend = FALSE) +
  scale_fill_manual(values = pal[c(1:5)]) +
  scale_x_continuous(breaks = (seq(1945, 2020, 5))) +
  labs(
    x = NULL, y = "Veto Count", fill = NULL,
    title = glue("Security Council Vetoes to {to_date}")
  ) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

layout <- "AAB"
big_plot + little_plot + plot_layout(design = layout)

R Toolbox

Summarising below the packages and functions used in this post enables me to separately create a toolbox visualisation summarising the usage of packages and functions across all posts.

used_here()

Package	Function
base	as.character[2], c[11], format[1], library[13], max[3], min[1], seq[1]
clock	date_build[1], date_parse[2], get_year[5]
conflicted	conflict_prefer_all[1], conflict_scout[1], conflicts_prefer[1]
dplyr	arrange[2], count[2], filter[4], group_by[1], if_else[7], inner_join[1], join_by[1], mutate[8], n_distinct[1], pull[3], recode[1], row_number[1], select[5], slice[1], summarise[3], ungroup[1]
forcats	fct_reorder[1]
generics	augment[1]
gganimate	animate[1], shadow_wake[1], transition_time[1]
ggfoundry	display_palette[1]
ggplot2	aes[5], element_text[1], geom_col[2], geom_label[2], ggplot[3], labs[3], scale_fill_manual[3], scale_x_continuous[1], theme[1], theme_bw[1], theme_set[1]
glue	glue[2]
grDevices	colorRampPalette[1]
paletteer	paletteer_d[1]
patchwork	plot_layout[1]
purrr	list_rbind[1], map[1]
rvest	html_element[1], html_table[1]
stats	prcomp[1]
stringr	str_detect[5], str_remove[1], str_replace[1]
tibble	as_tibble[1]
tidyr	complete[1], fill[1], nest[2], nesting[1], pivot_longer[1], pivot_wider[1], replace_na[1], unnest[2]
tidyselect	everything[1]
tsibble	as_tsibble[1], slide_tsibble[1]
usedthese	used_here[1]
xml2	read_html[1]

References

Pedersen, Thomas Lin, and David Robinson. 2022. “Gganimate: A Grammar of Animated Graphics.” https://CRAN.R-project.org/package=gganimate.

Robinson, David. 2021. “Unvotes: United Nations General Assembly Voting Data.” https://CRAN.R-project.org/package=unvotes.

Seeing the Wood for the Trees

Carl Goodwin — Tue, 01 Jan 2019 00:00:00 GMT

In Criminal Goings-on faceting offered a way to get a sense of the data. This is a great visualisation tool building on the principle of small multiples. There may come a point though where the sheer volume of small multiples make it harder to “see the wood for the trees”. What’s an alternative strategy?

library(conflicted)
library(tidyverse)
conflict_prefer_all("dplyr", quiet = TRUE)
library(trelliscope)
library(janitor)
library(ggfoundry)
library(paletteer)
library(usedthese)

conflict_scout()

This time I’ll use Van Gogh’s “The Starry Night” palette for the feature image and plots. And there are 12 types of criminal offence, so colorRampPalette will enable the interpolation of an extended set.

theme_set(theme_bw())

pal_name <- "vangogh::StarryNight"

pal <- paletteer_d(pal_name)
pal <- colorRampPalette(pal)(12)

display_palette(pal, pal_name)

The data need a little tidy-up.

crime_df <- str_c(
  "https://data.london.gov.uk/download/recorded_crime_summary/",
  "934f2ddb-5804-4c6a-a17c-bdd79b33430e/", 
  "MPS%20Borough%20Level%20Crime%20%28Historical%29.csv"
  ) |> 
  read_csv(show_col_types = FALSE) |> 
  clean_names() |> 
  rename_with(\(x) str_remove_all(x, "_text|look_up_|_name")) |> 
  pivot_longer(where(is.numeric), names_to = "month", values_to = "num_offences") |> 
  mutate(month = parse_number(month) |> str_c("01") |> ymd())

The original visualisation in Criminal Goings-on using ggplot’s facet_wrap is a little tricky to digest, even when limited to major categories of crime.

crime_df |>
  summarise(num_offences = sum(num_offences), .by = c(major, borough, month)) |>
  ggplot(aes(month, num_offences, colour = major, group = major)) +
  geom_line() +
  facet_wrap(~borough, scales = "free_y", ncol = 4) +
  labs(
    x = NULL, y = NULL, title = "London Crime by Borough",
    colour = "Offence", caption = "Source: data.gov.uk"
  ) +
  scale_colour_manual(values = pal) +
  guides(colour = guide_legend(nrow = 3)) +
  theme(
    strip.background = element_rect(fill = pal[4]),
    legend.position = "bottom",
    axis.text.x = element_text(angle = 45, hjust = 1)
  ) + 
  guides(col = guide_legend(ncol = 2))

This “little project” was first published using trelliscopejs which offered a really nice alternative approach to the static facet_wrap. This has been recently reimagined by the superior and easier-to-use trelliscope package. I’ve updated this post to use the “latest and greatest”.

Click top-right to pop the display out full screen. Over 1,700 time series plots may be interactively filtered and sorted (for every combination of borough, major/minor category of crime) using summary statistics such as the steepness of the linear trend line.

panels_df <- crime_df |>
  mutate(major = str_wrap(major, 16)) |> 
  ggplot(aes(month, num_offences)) +
  geom_line(show.legend = FALSE) +
  geom_smooth(method = "lm", se = FALSE, colour = pal[5]) +
  facet_panels(vars(borough, major, minor), scales = "free") + 
  labs(colour = NULL, x = NULL, y = "Offence Count")

slope <- \(x, y) coef(lm(y ~ x))[2]

summary_df <- crime_df |> 
  summarise(
    mean_count = mean(num_offences), 
    slope = slope(month, num_offences),
    .by = c(borough, major, minor))
  
panels_df |>
  as_panels_df(as_plotly = TRUE) |>
  as_trelliscope_df(
    name = "Crime in 'The Smoke'",
    description = str_c(
      "Timeseries of offences by category ",
      "across London's 33 boroughs sourced from data.gov.uk."
    )
  ) |>
  left_join(summary_df, join_by(borough, major, minor)) |>
  set_var_labels(
    major = "Major Category of Offence",
    minor = "Minor Category of Offence",
    mean_count = "Average Offences by Borough & Offence Category",
    slope = "Steepness of a Linear Trendline"
  ) |>
  set_default_sort(c("slope"), dirs = "desc") |>
  set_tags(
    stats = c("mean_count", "slope"),
    info = c("borough", "major", "minor")
  ) |>
  set_theme(
    primary = pal[1],
    primary2 = pal[1],
    primary3 = pal[5],
    text = pal[1],
    text2 = pal[4],
    bars = pal[2]
  ) |>
  view_trelliscope()

R Toolbox

Summarising below the packages and functions used in this post enables me to separately create a toolbox visualisation summarising the usage of packages and functions across all posts.

used_here()

Package	Function
base	c[5], library[7], mean[1], sum[1]
conflicted	conflict_prefer_all[1], conflict_scout[1]
dplyr	join_by[1], left_join[1], mutate[2], rename_with[1], summarise[2], vars[1]
ggfoundry	display_palette[1]
ggplot2	aes[2], element_rect[1], element_text[1], facet_wrap[1], geom_line[2], geom_smooth[1], ggplot[2], guide_legend[2], guides[2], labs[2], scale_colour_manual[1], theme[1], theme_bw[1], theme_set[1]
grDevices	colorRampPalette[1]
janitor	clean_names[1]
lubridate	ymd[1]
paletteer	paletteer_d[1]
readr	parse_number[1], read_csv[1]
stats	coef[1], lm[1]
stringr	str_c[3], str_remove_all[1], str_wrap[1]
tidyr	pivot_longer[1]
tidyselect	where[1]
trelliscope	as_panels_df[1], as_trelliscope_df[1], facet_panels[1], set_default_sort[1], set_tags[1], set_theme[1], set_var_labels[1], view_trelliscope[1]
usedthese	used_here[1]

Can Ravens Forecast?

Carl Goodwin — Sat, 28 Jul 2018 23:00:00 GMT

Humans have the magical ability to plan for future events, for future gain. It’s not quite a uniquely human trait. Because apparently ravens can match a four-year-old.

An abundance of data, and some very nice R packages, make our ability to plan all the more powerful.

In the Spring of 2018 I looked at sales from an historical perspective in Six Months Later.. Here I’ll use the data to model a time-series forecast for the year ahead. The techniques apply to any time series with characteristics of trend, seasonality or longer-term cycles.

Why forecast sales? Business plans require a budget, e.g. for resources, marketing and office space. A good projection of revenue provides the foundation for the budget. And, for an established business, with historical data, time-series forecasting is one way to deliver a robust projection.

Without exogenous data, the forecast assumes one continues to do what one’s doing. So, it provides a good starting-point. Then one might, for example, add assumptions about new products or services. And, if there is forward-looking data available, for example, market size projections (with past projections to train the model), then one could feed this into the forecast modelling too.

library(conflicted)
library(tidyverse)
conflict_prefer_all("dplyr", quiet = TRUE)
library(fpp3)
library(scales)
library(clock)
library(ggfoundry)
library(paletteer)
library(usedthese)

conflict_scout()

theme_set(theme_bw())

pal_name <- "wesanderson::IsleofDogs2"

pal <- paletteer_d(pal_name)

display_palette(pal, pal_name)

First I’ll check the encoding of the data.

url <-
  "https://www.gov.uk/government/uploads/system/uploads/attachment_data/file/"

gcloud_csv <- str_c(url, "703943/G-Cloud_spend_data_to_end_March_2018.csv")

dos_csv <- str_c(url, "703952/DOS_spend_data_to_end_March_2018.csv")

names <- c(gcloud_csv, dos_csv)

# Use walk to suppress the printing of list element numbers

walk(names, \(x) {
  p <- guess_encoding(x)
  print(p)
})

# A tibble: 2 × 2
  encoding   confidence
             
1 ISO-8859-1       0.4 
2 ISO-8859-2       0.22
# A tibble: 2 × 2
  encoding   confidence
             
1 ISO-8859-1       0.36
2 ISO-8859-2       0.24

Next I’ll set up a vector of column names to apply consistently to both files, and import the data with the suggested encoding.

colnam <- 
  c("sector",
    "lot",
    "date",
    "spend",
    "status",
    "supplier",
    "customer",
    "framework")

read_dm <- \(x){
  read_csv(
    x,
    col_names = colnam,
    skip = 1,
    locale = locale(encoding = "ISO-8859-1"),
    show_col_types = FALSE)
}

raw <- map(names, read_dm) |> 
  set_names(c("gcloud", "dos")) |> 
  bind_rows() |> 
  mutate(framework = if_else(is.na(framework), "DOS", framework))

I’d like to create some new features: Month-end dates, something to distinguish between the two frameworks (G-Cloud or DOS). The spend has a messy format and needs a bit of cleaning too.

The lot structure for G-Cloud has evolved over time, but fortunately, there is a simple mapping, i.e. PaaS and IaaS became Cloud Hosting, SaaS became Cloud Software, and Specialist Cloud Services became Cloud Support, so I’ll standardise on the latter.

both <- raw |>
  mutate(
    month_end = date_parse(str_c(date, "01", sep = "-"), 
                           format = "%b-%y-%d") |> 
      add_months(1) |> add_days(-1),
    date = yearmonth(month_end),
    framework = str_extract(framework, ".{3,7}"),
    spend = str_remove(spend, coll("£")),
    spend = str_replace(spend, "^\\(", "-"),
    spend = parse_number(spend) / 1000000,
    lot = recode(
      lot,
      "Software as a Service (SaaS)" = "Cloud Software",
      "Infrastructure as a Service (IaaS)" = "Cloud Hosting",
      "Platform as a Service (PaaS)" = "Cloud Hosting",
      "Specialist Cloud Services" = "Cloud Support"
      )
)

The tidied data now needs to be converted to a tsibble(Wang, Cook, and Hyndman 2020), the temporal equivalent of a tibble(Müller and Wickham 2022).

R has evolved since I first wrote this post. At that time, it was necessary to either split the data into the two frameworks (G-Cloud and DOS) and forecast them separately. Or, as I did with the three G-Cloud lots, use the purrr package to iterate through a forecast.

The tsibble package combined with the newer fable(O’Hara-Wild, Hyndman, and Wang 2022a) and feasts(O’Hara-Wild, Hyndman, and Wang 2022b) packages, make this easier. One of the defining feature of the tsibble is the key. I want a model for each framework, so I’m setting this as the tsibble key (and the temporal variable as the tsibble index).

both_ts <- both |>
  summarise(spend = sum(spend), .by = c(date, framework)) |> 
  as_tsibble(key = framework, index = date)

both_ts |> 
  ggplot(aes(date, spend, colour = framework)) +
  geom_line(key_glyph = "timeseries") +
  scale_y_continuous(labels = label_currency(prefix = "£", suffix = "m")) +
  scale_colour_manual(values = pal[c(3, 4)]) +
  labs(x = NULL, y = NULL, title = "Monthly Digital Marketplace Sales")

By decomposing the historical data we can tease out the underlying trend and seasonality:

Trend: The sales for both frameworks have grown over time as more Suppliers have added their services to the Government frameworks, and more Public Sector organizations have found the benefits of purchasing Cloud services through this faster, simpler, more transparent and more competitive contracting vehicle.
Seasonality: Suppliers often manage their sales and financials based on a quarterly cycle, with a particular emphasis on a strong close to the financial year. And Government Buyers may want to make optimal use of their budgets at the close of their financial year (March 31st). Consequently, we see quarterly seasonality with an extra spike at financial year-end.

both_ts |>
  model(stl = STL(spend ~ trend(window = 7) + season(window = "periodic"))) |>
  components() |>
  autoplot() +
  scale_colour_manual(values = pal[c(3, 4)]) +
  labs(x = NULL, title = "Time Series Decomposition")

I’ll use auto.arima: AutoRegressive Integrated Moving Average modelling which aims to describe the autocorrelations in the data.

By setting stepwise and approximation to FALSE, auto.arima will explore a wider range of potential models.

I’ll forecast with the default 80% and 95% prediction intervals. This means the darker-shaded 80% range should include the future sales value with an 80% probability. Likewise with a 95% probability when adding the wider and lighter-shaded area.

Use of autoplot would simplify the code, but personally I like to expose all the data, for example unpacking the prediction intervals, and have finer control over the visualisation.

mod_ts <- both_ts |>
  model(ARIMA = ARIMA(spend, stepwise = TRUE, approximation = FALSE))

mod_ts |> 
  glance() |>
  select(-ar_roots, -ma_roots)

framework	.model	sigma2	log_lik	AIC	AICc	BIC
DOS	ARIMA	23.60153	-59.93305	123.8661	124.5720	125.8576
G-Cloud	ARIMA	34.75275	-191.61547	393.2309	394.3421	403.7027

mod_ts |> 
  tidy()

framework	.model	term	estimate	std.error	statistic	p.value
DOS	ARIMA	ma1	-0.7725021	0.1718544	-4.495096	0.0002213
G-Cloud	ARIMA	ar1	0.9390150	0.0595356	15.772336	0.0000000
G-Cloud	ARIMA	ma1	-0.5777210	0.1094067	-5.280491	0.0000019
G-Cloud	ARIMA	sar1	-0.5124417	0.1142671	-4.484596	0.0000336
G-Cloud	ARIMA	constant	1.4084703	0.3168159	4.445706	0.0000385

fcast_ts <- mod_ts |>
  forecast(h = "2 years") |> 
  mutate(`95%` = hilo(spend, 95), `80%` = hilo(spend, 80)) |> 
  unpack_hilo(c("95%", "80%")) |>
  rename(fc_spend = spend) |> 
  bind_rows(both_ts)

fcast_ts |>
  ggplot(aes(date, fill = framework)) +
  geom_line(aes(y = spend), colour = pal[5]) +
  geom_ribbon(aes(ymin = `95%_lower`, ymax = `95%_upper`),
    fill = pal[1], colour = NA
  ) +
  geom_ribbon(aes(ymin = `80%_lower`, ymax = `80%_upper`),
    fill = pal[2], colour = NA
  ) +
  geom_line(aes(y = .mean), colour = "white") +
  scale_y_continuous(labels = label_currency(prefix = "£", suffix = "m")) +
  facet_wrap(~framework) +
  labs(
    title = "Digital Marketplace Sales Forecast by Framework",
    x = NULL, y = "Spend",
    subtitle = "80 & 95% Prediction Intervals"
  ) +
  theme(
    legend.position = "none",
    axis.text.x = element_text(angle = 45, hjust = 1)
  )

The G-Cloud framework compromises three lots: Cloud Hosting, Cloud Software and Cloud Support.

I previously combined auto.arima (from the forecast package) with functions from the sweep package, to create multiple forecasts in one shot. tsibble coupled fabletools handle this with the key set to the lot variable.

An alternative option is hierarchical time-series forecasting which models bottom-up, top-down or middle-out, and ensures the sum of the forecasts at the lower level sum to the top-level forecast. This approach has pros and cons and is not considered here.

gcloud_ts <- both |>
  filter(framework == "G-Cloud") |> 
  summarise(spend = sum(spend), .by = c(date, lot)) |> 
  as_tsibble(key = lot, index = date)

gc_ts <- gcloud_ts |>
  model(ARIMA = ARIMA(spend, stepwise = TRUE, approximation = FALSE))

gc_ts |> 
  glance() |>
  select(-ar_roots, -ma_roots)

lot	.model	sigma2	log_lik	AIC	AICc	BIC
Cloud Hosting	ARIMA	1.347179	-109.3173	224.6346	224.9982	231.3801
Cloud Software	ARIMA	2.275664	-107.5551	221.1102	221.5465	227.3428
Cloud Support	ARIMA	18.606529	-212.6556	435.3112	436.2342	446.6246

gc_ts |> tidy()

lot	.model	term	estimate	std.error	statistic	p.value
Cloud Hosting	ARIMA	ma1	-0.8269314	0.0765747	-10.799011	0.0000000
Cloud Hosting	ARIMA	constant	0.1713346	0.0258894	6.617935	0.0000000
Cloud Software	ARIMA	ma1	-0.9981867	0.1304425	-7.652312	0.0000000
Cloud Software	ARIMA	ma2	0.2242994	0.1224833	1.831265	0.0721114
Cloud Support	ARIMA	ma1	-0.7044948	0.0743797	-9.471597	0.0000000
Cloud Support	ARIMA	sma1	0.3878660	0.1458579	2.659205	0.0096735
Cloud Support	ARIMA	sma2	0.7866476	0.4284425	1.836064	0.0705352
Cloud Support	ARIMA	constant	0.7601155	0.2889763	2.630373	0.0104520

fcgc_ts <- gc_ts |>
  forecast(h = "2 years") |> 
  mutate(`95%` = hilo(spend, 95), `80%` = hilo(spend, 80)) |> 
  unpack_hilo(c("95%", "80%")) |> 
  rename(fc_spend = spend) |> 
  bind_rows(gcloud_ts)

fcgc_ts |>
  ggplot(aes(date, fill = lot)) +
  geom_line(aes(y = spend), colour = pal[5]) +
  geom_ribbon(aes(ymin = `95%_lower`, ymax = `95%_upper`),
    fill = pal[1], colour = NA
  ) +
  geom_ribbon(aes(ymin = `80%_lower`, ymax = `80%_upper`),
    fill = pal[2], colour = NA
  ) +
  geom_line(aes(y = .mean), colour = "white") +
  scale_y_continuous(labels = label_currency(prefix = "£", suffix = "m")) +
  facet_wrap(~lot) +
  labs(
    title = "G-Cloud Sales Forecast by Lot",
    x = NULL, y = "Spend",
    subtitle = "80 & 95% Prediction Intervals"
  ) +
  theme(
    legend.position = "none",
    axis.text.x = element_text(angle = 45, hjust = 1)
  )

So ravens are not yet ready for forecasting with R. But then neither are 4-year-olds, are they?

R Toolbox

Summarising below the packages and functions used in this post enables me to separately create a toolbox visualisation summarising the usage of packages and functions across all posts.

used_here()

Package	Function
base	c[9], is.na[1], library[8], print[1], sum[2]
clock	add_days[1], add_months[1], date_parse[1]
conflicted	conflict_prefer_all[1], conflict_scout[1]
dplyr	bind_rows[3], filter[1], if_else[1], mutate[4], recode[1], rename[2], select[2], summarise[2]
fable	ARIMA[2]
fabletools	components[1], forecast[2], glance[2], hilo[4], model[3], tidy[2], unpack_hilo[2]
feasts	STL[1]
ggfoundry	display_palette[1]
ggplot2	aes[11], autoplot[1], element_text[2], facet_wrap[2], geom_line[5], geom_ribbon[4], ggplot[3], labs[4], scale_colour_manual[2], scale_y_continuous[3], theme[2], theme_bw[1], theme_set[1]
paletteer	paletteer_d[1]
purrr	map[1], walk[1]
readr	guess_encoding[1], locale[1], parse_number[1], read_csv[1]
rlang	set_names[1]
scales	label_currency[3]
stringr	coll[1], str_c[3], str_extract[1], str_remove[1], str_replace[1]
tsibble	as_tsibble[2], yearmonth[1]
usedthese	used_here[1]

References

Müller, Kirill, and Hadley Wickham. 2022. “Tibble: Simple Data Frames.” https://CRAN.R-project.org/package=tibble.

O’Hara-Wild, Mitchell, Rob Hyndman, and Earo Wang. 2022a. “Fable: Forecasting Models for Tidy Time Series.” https://CRAN.R-project.org/package=fable.

———. 2022b. “Feasts: Feature Extraction and Statistics for Time Series.” https://CRAN.R-project.org/package=feasts.

Wang, Earo, Dianne Cook, and Rob J Hyndman. 2020. “A New Tidy Data Structure to Support Exploration and Modeling of Temporal Data” 29: 466–78. https://doi.org/10.1080/10618600.2019.1695624.

Six Months Later

Carl Goodwin — Sun, 01 Apr 2018 23:00:00 GMT

In September 2017 I wrote a post entitled Let’s Jitter. It looked at how the SME share of sales evolved over time. I revisited this topic here six months later, along the way adding a splash of colour and some faceted plots.

library(conflicted)
library(tidyverse)
conflict_prefer_all("dplyr", quiet = TRUE)
library(clock)
library(scales)
library(ggfoundry)
library(paletteer)
library(usedthese)

conflict_scout()

theme_set(theme_bw())

pal_name <- "wesanderson::Chevalier1"

pal <- paletteer_d(pal_name)
pal <- colorRampPalette(pal)(9)

display_palette(pal, pal_name, shape = "tube")

In Let’s Jitter I assumed the G-Cloud data file adopted the UK Government standard of UTF-8. I used the stringr package to fix any issues.

This time around, I’m importing the files for two frameworks (G-Cloud and DOS) after first checking the encoding to see if I can get a cleaner import. guess_encoding suggests these files use the ISO-8859-1 standard.

url <- 
  "https://www.gov.uk/government/uploads/system/uploads/attachment_data/file/"

gcloud_csv <- str_c(url, "678283/G-Cloud-spend-Dec2017.csv")

dos_csv <- str_c(url, "678286/DOS-spend-Dec2017.csv")

names <- c(gcloud_csv, dos_csv)

map(names, guess_encoding)

[[1]]
# A tibble: 2 × 2
  encoding   confidence
             
1 ISO-8859-1       0.39
2 ISO-8859-2       0.24

[[2]]
# A tibble: 2 × 2
  encoding   confidence
             
1 ISO-8859-1       0.44
2 ISO-8859-2       0.23

Next I’ll set up a vector of column names to apply consistently to both files, import the data with the suggested encoding, and bind them into one tibble.

colnam <-
  c("sector",
    "lot",
    "month",
    "spend",
    "status",
    "supplier",
    "customer",
    "framework")

read_dm <- \(x){
  read_csv(
    x,
    col_names = colnam,
    skip = 1,
    locale = locale(encoding = "ISO-8859-1"),
    col_types = NULL,
    show_col_types = FALSE)
}

combined_df <- map(names, read_dm) |> 
  set_names(c("gcloud", "dos")) |> 
  bind_rows() |> 
  mutate(framework = if_else(is.na(framework), "DOS", framework))

I’d like to create some new features: Month-end dates, something to distinguish between the two frameworks (G-Cloud or DOS) and the framework version (i.e. G-Cloud 1 to 9). The spend has a messy format and needs a bit of cleaning too.

clean_df <- combined_df |>
  mutate(
    month_end = date_parse(str_c(month, "01", sep = "-"), 
                           format = "%b-%y-%d") |> 
      add_months(1) |> add_days(-1),
    version = str_remove(framework, fixed("-Cloud ")),
    version = str_replace(version, fixed("G-Cloud"), "G1"),
    version = str_replace(version, fixed("GIII"), "G3"),
    version = str_replace(version, fixed("GServices II"), "G2"),
    framework = str_extract(framework, ".{3,7}"),
    spend = str_remove(spend, fixed("£")),
    spend = str_replace(spend, "^\\(", "-"),
    spend = parse_number(spend),
    SME_spend = if_else(status == "SME", spend, 0)
  )

Finding the interval between G-Cloud versions will enable me to calculate and print the average in the next paragraph using inline r code.

version_df <- clean_df |>
  filter(version != "DOS") |> 
  summarise(start = min(month_end), .by = version) |> 
  mutate(next_start = lead(start),
         interval = lubridate::interval(start, next_start) %/% months(1))

Every 7.8 months, on average, suppliers are asked to resubmit their G-Cloud offerings with their latest pricing and service descriptions. It’s a chance for new suppliers, often smaller ones, to join the existing list of suppliers and increase overall competitiveness for Cloud services.

Let’s visualise how each of these framework versions grows, matures and fades away as the next one takes over.

vers_summary <- clean_df |>
  filter(version != "DOS") |> 
  summarise(sales = sum(spend) / 1000000,
            .by = c(version, month_end))

vers_summary |> 
  ggplot(aes(month_end, sales, colour = version)) +
  geom_line() +
  geom_smooth() +
  scale_x_date(date_breaks = "years", date_labels = "%Y") +
  scale_y_continuous(labels = label_currency(prefix = "£", suffix = "m")) +
  scale_colour_manual(values = pal) +
  labs(x = NULL, y = NULL, title = "The Lifecycle of G-Cloud Versions", 
       subtitle = "Monthly Sales by Version") + 
  labs(caption = "\nSource: GOV.UK's Digital Marketplace")

Let’s Jitter showed signs of a weakening in the SME share of G-Cloud sales by value. This plot shows this trend to have persisted, and also reflects the Digital Outcomes & Specialists (DOS) framework exhibiting a downward trend.

fw_summary <- clean_df |>
  summarise(pct = sum(SME_spend, na.rm = TRUE) / sum(spend, na.rm = TRUE),
            .by = c(framework, month_end))

fw_summary |> 
  ggplot(aes(month_end, pct, colour = framework)) +
  geom_line() +
  geom_smooth() +
  scale_y_continuous(breaks = c(0.25, 0.5, 0.75, 1), labels = label_percent()) +
  scale_x_date(date_breaks = "years", date_labels = "%Y") +
  scale_colour_manual(values = pal[c(1, 9)]) +
  labs(x = NULL, y = NULL, 
       title = "The Waning SME Share of Sales", 
       subtitle = "% Monthly Sales Value via SME (vs Large Enterprise) Suppliers") + 
  labs(caption = "\nSource: GOV.UK's Digital Marketplace")

Overall spending via the combined frameworks however continues to grow across all parts of Public Sector. I’ll use a small multiples visualisation technique to show this using ggplot2’s(Wickham 2016) facet_wrap.

sect_summary <-
  clean_df |>
  filter(!sector %in% c(
    "Unregistered or Unknown",
    "Utility (Historic)",
    "Wider Public Sector"
  )) |>
  summarise(
    sales = sum(spend) / 1000000,
    pct = sum(SME_spend, na.rm = TRUE) / sum(spend, na.rm = TRUE),
    .by = c(sector, month_end)
  )

sect_summary |> 
  ggplot(aes(month_end, sales, colour = sector)) +
  geom_line() +
  geom_smooth() +
  facet_wrap(~ sector, scales = "free_y") +
  theme(legend.position = "none") +
  scale_x_date(date_breaks = "years", date_labels = "%Y") +
  scale_y_continuous(labels = label_currency(prefix = "£", suffix = "m")) +
  scale_colour_manual(values = pal) +
  labs(x = NULL, y = NULL, 
       title = "All Sectors Increase Digital Marketplace Spend", 
       subtitle = "G-Cloud & DOS Spend by Sector") + 
  labs(caption = "\nSource: GOV.UK's Digital Marketplace")

The decline in the proportion of spend via SMEs is also fairly broad-based.

sect_summary |> 
  ggplot(aes(month_end, pct, colour = sector)) +
  geom_line() +
  geom_smooth() +
  facet_wrap(~ sector, scales = "free_y") +
  theme(legend.position = "none") +
  scale_x_date(date_breaks = "years", date_labels = "%Y") +
  scale_y_continuous(labels = label_percent()) +
  scale_colour_manual(values = pal) +
  labs(x = NULL, y = NULL, 
       title = "Most Sectors Spend Proportionately Less on SMEs", 
       subtitle = "Pct SME G-Cloud & DOS Spend by Sector") + 
  labs(caption = "\nSource: GOV.UK's Digital Marketplace")

R Toolbox

Summarising below the packages and functions used in this post enables me to separately create a toolbox visualisation summarising the usage of packages and functions across all posts.

used_here()

Package	Function
base	c[9], is.na[1], library[7], min[1], months[1], sum[6]
clock	add_days[1], add_months[1], date_parse[1]
conflicted	conflict_prefer_all[1], conflict_scout[1]
dplyr	bind_rows[1], filter[3], if_else[2], lead[1], mutate[3], summarise[4]
ggfoundry	display_palette[1]
ggplot2	aes[4], facet_wrap[2], geom_line[4], geom_smooth[4], ggplot[4], labs[8], scale_colour_manual[4], scale_x_date[4], scale_y_continuous[4], theme[2], theme_bw[1], theme_set[1]
grDevices	colorRampPalette[1]
lubridate	interval[1]
paletteer	paletteer_d[1]
purrr	map[2]
readr	locale[1], parse_number[1], read_csv[1]
rlang	set_names[1]
scales	label_currency[2], label_percent[2]
stringr	fixed[5], str_c[3], str_extract[1], str_remove[2], str_replace[4]
usedthese	used_here[1]

References

Wickham, Hadley. 2016. “Ggplot2: Elegant Graphics for Data Analysis.” https://ggplot2.tidyverse.org.

Criminal Goings-on in a Random Forest

Carl Goodwin — Thu, 01 Mar 2018 00:00:00 GMT

When first posted in 2018 this project used the caret package to model crime in London. Since then, the newer tidymodels(Kuhn and Wickham 2020) framework, consistent with tidy data principles, has rapidly evolved.

library(conflicted)
library(tidyverse)
conflict_prefer_all("dplyr", quiet = TRUE)
library(tidymodels)
library(janitor)
library(scales)
library(vip)
library(poissonreg)
library(ggfoundry)
library(usedthese)

conflict_scout()

This custom palette was created in Adobe Colour as the basis for the feature image above and with the hex codes loaded for use in ggplot. colorRampPalette enables interpolation of an extended set of colours to support the number of offence types.

theme_set(theme_bw())

pal_name <- "Custom Palette"

pal <- c("#798E87", "#C27D38", "#CCC591", "#29211F")

pal12 <- colorRampPalette(pal)(12)

display_palette(pal12, pal_name)

# MPS Borough Level Crime (Historical).csv
url <- str_c(
  "https://data.london.gov.uk/download/recorded_crime_summary/",
  "a1b36c68-cd08-4a8a-99c2-c2313165b744/", 
  "MPS%20Borough%20Level%20Crime%20%28Historical%29.csv"
  )

crime_df <-
  read_csv(url, show_col_types = FALSE) |>
  clean_names() |>
  pivot_longer(starts_with("x"), names_to = "year", values_to = "number_of_offences") |> 
  mutate(
    year = str_sub(year, 2, 5) |> as.numeric(),
    major_text = str_to_sentence(major_text)) |>
  filter(year != 2022) |> # partial year
  rename(offences = major_text, borough = borough_name) |> 
  summarise(number_of_offences = sum(number_of_offences),
            .by = c(year, borough, offences))

A faceted plot is one way to get a sense of the data.

crime_df |>
  mutate(borough = str_wrap(borough, 11)) |>
  ggplot(aes(year, number_of_offences, 
             colour = offences, group = offences)) +
  geom_line() +
  facet_wrap(~borough, scales = "free_y", ncol = 4) +
  labs(
    x = NULL, y = NULL, title = "London Crime by Borough",
    colour = "Offence", caption = "Source: data.gov.uk"
  ) +
  scale_colour_manual(values = pal12) +
  guides(colour = guide_legend(nrow = 6, size = 4)) +
  theme(
    legend.position = "bottom",
    axis.text.x = element_text(angle = 45, hjust = 1)
  )

Visualising data in small multiples using facet_wrap or facet_grid can be a useful way to explore data. When there are a larger number of these however, as we’re starting to see in the example above, there are alternative techniques one can employ. This is explored in Seeing the Wood for the Trees.

There are 12 types of offence in 34 boroughs. The dataset covers the period 2010 to 2021.

The faceted plot hints at a potential interaction between borough and type of offence. In more affluent boroughs, and/or those attracting greater visitor numbers, e.g. Westminster and Kensington & Chelsea, “theft and handling” is the more dominant category. In Lewisham, for example, “violence against the person” exhibits higher counts. However, for the purpose of this basic model comparison, I’m going to set aside the potential interaction term.

Before modelling, I’ll visualise the dependent variable against each independent variable.

crime_df |>
  summarise(number_of_offences = sum(number_of_offences),
            .by = c(offences, borough)) |>
  mutate(
    median_offences = median(number_of_offences),
    offences = str_wrap(offences, 20),
    .by = offences
  ) |>
  ggplot(aes(fct_reorder(offences, median_offences), number_of_offences)) +
  geom_boxplot(fill = pal[1]) +
  scale_y_log10(labels = label_number(scale_cut = cut_short_scale())) +
  labs(
    x = NULL, y = NULL,
    title = "Number of Offences by Type",
    caption = "Source: data.gov.uk"
  ) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))

crime_df |>
  summarise(number_of_offences = sum(number_of_offences),
            .by = c(offences, borough)) |>
  mutate(
    median_offences = median(number_of_offences),
    offences = str_wrap(offences, 10),
    .by = borough
  ) |>
  ggplot(aes(number_of_offences, fct_reorder(borough, median_offences))) +
  geom_boxplot(fill = pal[1]) +
  scale_x_log10(labels = label_number(scale_cut = cut_short_scale())) +
  labs(
    x = NULL, y = NULL,
    title = "Number of Offences by Borough",
    caption = "Source: data.gov.uk"
  )

The offences and borough variables show significant variation in crime counts. And there is also evidence of a change over time.

crime_df |>
  summarise(number_of_offences = sum(number_of_offences), .by = year) |>
  ggplot(aes(year, number_of_offences)) +
  geom_line(colour = pal[4], linetype = "dashed") +
  geom_smooth(colour = pal[2]) +
  scale_y_continuous(labels = label_number(scale_cut = cut_short_scale())) +
  labs(
    x = NULL, y = NULL,
    title = "Number of Offences by Year",
    caption = "Source: data.gov.uk"
  )

I’ll separate out some test data so I can compare the performance of the models on data they have not see during model training.

set.seed(123)

data_split <- 
  crime_df |>
  initial_split(strata = offences)

crime_train <- data_split |>
  training()

crime_test <- data_split |>
  testing()

I’m using the recipes package to establish the role of the variables. Alternatively I could have used a formula-based approach, i.e. number_of_offences ~ borough + offences + year.

Whilst borough and offences are nominal, I’m not creating any dummy variables since I intend to use tree-based models which will anyway branch left and right based on groups of values.

crime_recipe <-
  crime_train |>
  recipe() |>
  update_role(number_of_offences, new_role = "outcome") |>
  update_role(-has_role("outcome"), new_role = "predictor")

summary(crime_recipe)

variable	type	role	source
year	double , numeric	predictor	original
borough	string , unordered, nominal	predictor	original
offences	string , unordered, nominal	predictor	original
number_of_offences	double , numeric	outcome	original

I’ll start with a Recursive Partitioning And Regression Trees (rpart) model. The feature importance plot tells me which variables are having the biggest influence on the model. The type of offence is the most important predictor in the rpart model, followed by the location of the offences. This makes intuitive sense.

Clearly there is a temporal component too otherwise there would be no trend.

rp_model <- 
  decision_tree() |>
  set_engine("rpart") |>
  set_mode("regression")

rp_wflow <- workflow() |>
  add_recipe(crime_recipe) |>
  add_model(rp_model)

rp_fit <- rp_wflow |> 
  fit(crime_train)

rp_fit |>
  extract_fit_parsnip() |> 
  vip(aesthetics = list(fill = pal[1])) +
  labs(title = "Feature Importance -- rpart")

rp_results <- rp_fit |> 
  augment(crime_test) |> 
  mutate(model = "rpart")

Ranger is an implementation of random forests or recursive partitioning that, according to the documentation, is particularly suited to high dimensional data. My data is not high-dimensional, but let’s throw it into the mix.

ranger_model <- 
  rand_forest() |>
  set_engine("ranger", importance = "impurity") |>
  set_mode("regression")

ranger_wflow <- workflow() |>
  add_recipe(crime_recipe) |>
  add_model(ranger_model)

ranger_fit <- ranger_wflow |> 
  fit(crime_train)

ranger_fit |>
  extract_fit_parsnip() |> 
  vip(aesthetics = list(fill = pal[3])) +
  labs(title = "Feature Importance -- Ranger")

ranger_results <- ranger_fit |> 
  augment(crime_test) |> 
  mutate(model = "ranger")

And of course my project title would make little sense without a Random Forest.

rf_model <- 
  rand_forest() |>
  set_engine("randomForest") |>
  set_mode("regression")

rf_wflow <- workflow() |>
  add_recipe(crime_recipe) |>
  add_model(rf_model)

rf_fit <- rf_wflow |> 
  fit(crime_train)

rf_fit |>
  extract_fit_parsnip() |> 
  vip(aesthetics = list(fill = "grey60")) +
  labs(title = "Feature Importance -- Random Forest")

rf_results <- rf_fit |> 
  augment(crime_test) |> 
  mutate(model = "random forest")

For good measure, I’ll also include a generalized linear model (glm)

poisson_model <- 
  poisson_reg() |>
  set_engine("glm") |>
  set_mode("regression")

poisson_wflow <- workflow() |>
  add_recipe(crime_recipe) |>
  add_model(poisson_model)

poisson_fit <- poisson_wflow |> 
  fit(crime_train)

poisson_fit |>
  extract_fit_parsnip() |> 
  vip(aesthetics = list(fill = pal[4])) +
  labs(title = "Feature Importance -- glm")

poisson_results <- poisson_fit |> 
  augment(crime_test) |> 
  mutate(model = "glm")

The Random Forest and the glm models performed the best here with the lower RMSE / MAE and higher R Squared.

model_results <- 
  rp_results |> 
  bind_rows(ranger_results) |> 
  bind_rows(rf_results) |> 
  bind_rows(poisson_results) |> 
  group_by(model) |> 
  metrics(truth = number_of_offences, estimate = .pred)

model_results |> 
  ggplot(aes(model, .estimate, fill = model)) +
  geom_col() +
  geom_label(aes(label = round(.estimate, 2)), size = 3, fill = "white") +
  facet_wrap(~ .metric, scales = "free_y") +
  scale_fill_manual(values = as.character(pal[c(4, 5, 3, 1)])) +
  labs(x = NULL, y = NULL, title = "Comparison of Model Metrics") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1),
        legend.position = "none")

Another way of approaching all this would be to use time-series forecasting. This would major on auto-regression, i.e. looking at how the lagged number-of-offences influence future values. And one could further include exogenous data such as, say, the numbers of police. It would be reasonable to expect that increasing police numbers would, in time, lead to decreased crime levels.

I explored time-series in other posts such as Digging Deep, so I won’t go down that path here.

What I could do though is to strengthen my tree-based models above by engineering some additional temporal features. Let’s try that just with the Random Forest to see if it improves the outcome.

temp_df <- 
  crime_df |> 
  mutate(num_lag1 = lag(number_of_offences),
         num_lag2 = lag(number_of_offences, 2),
         num_lag3 = lag(number_of_offences, 3)) |> 
  drop_na()

So, when predicting the number of offences, the model will now additionally consider, for each borough, type of offence and year, the number of offences in each of the three prior years.

set.seed(123)

data_split <- 
  temp_df |>
  initial_split(strata = offences)

temp_train <- data_split |>
  training()

temp_test <- data_split |>
  testing()

temp_recipe <-
  temp_train |>
  recipe() |>
  update_role(number_of_offences, new_role = "outcome") |>
  update_role(-has_role("outcome"), new_role = "predictor")

summary(temp_recipe)

variable	type	role	source
year	double , numeric	predictor	original
borough	string , unordered, nominal	predictor	original
offences	string , unordered, nominal	predictor	original
number_of_offences	double , numeric	outcome	original
num_lag1	double , numeric	predictor	original
num_lag2	double , numeric	predictor	original
num_lag3	double , numeric	predictor	original

temp_model <- 
  rand_forest() |>
  set_engine("randomForest") |>
  set_mode("regression")

temp_wflow <- workflow() |>
  add_recipe(temp_recipe) |>
  add_model(temp_model)

temp_fit <- temp_wflow |> 
  fit(temp_train)

temp_fit |>
  extract_fit_parsnip() |> 
  vip(aesthetics = list(fill = pal[2])) +
  labs(title = "Feature Importance -- Random Forest with Lags")

temp_results <- temp_fit |> 
  augment(temp_test) |> 
  metrics(truth = number_of_offences, estimate = .pred) |> 
  mutate(model = "rf with lags")

The recipe summary includes the three new predictors. And the feature importance plot shows the lags playing a larger role in the model than the year variable, so looks like we should anticipate a model improvement.

updated_results <- 
  model_results |> 
  bind_rows(temp_results)

updated_results |> 
  ggplot(aes(model, .estimate, fill = model)) +
  geom_col() +
  geom_label(aes(label = round(.estimate, 2)), size = 3, fill = "white") +
  facet_wrap(~ .metric, scales = "free_y") +
  scale_fill_manual(values = as.character(pal[c(4, 5, 3, 2, 1)])) +
  labs(x = NULL, y = NULL, title = "Comparison of Model Metrics") +
  theme(axis.text.x = element_text(angle = 45, hjust = 1),
        legend.position = "none")

The model metrics bear this out. The mae and rmse are markedly smaller, and the rsq marginally improved. We could have tried further lags. We could have tried tweaking some parameters. We could have tried time-series forecasting with, for example a statistical model like ARIMA, or a Neural Network model such as NNETAR.

The best approach would depend upon a more precise definition of the objective. And some trial and error, comparing approaches after more extensive feature-engineering, validation, testing and tuning. For the purposes of this post though I wanted to merely explore some techniques. So I’ll leave it there.

R Toolbox

Summarising below the packages and functions used in this post enables me to separately create a toolbox visualisation summarising the usage of packages and functions across all posts.

used_here()

Package	Function
base	as.character[2], as.numeric[1], c[6], library[9], list[5], round[2], set.seed[2], sum[4], summary[2]
conflicted	conflict_prefer_all[1], conflict_scout[1]
dplyr	bind_rows[4], filter[1], group_by[1], lag[3], mutate[10], rename[1], starts_with[1], summarise[4]
forcats	fct_reorder[2]
generics	augment[5], fit[5]
ggfoundry	display_palette[1]
ggplot2	aes[8], element_text[4], facet_wrap[3], geom_boxplot[2], geom_col[2], geom_label[2], geom_line[2], geom_smooth[1], ggplot[6], guide_legend[1], guides[1], labs[11], scale_colour_manual[1], scale_fill_manual[2], scale_x_log10[1], scale_y_continuous[1], scale_y_log10[1], theme[4], theme_bw[1], theme_set[1]
grDevices	colorRampPalette[1]
hardhat	extract_fit_parsnip[5]
janitor	clean_names[1]
parsnip	decision_tree[1], poisson_reg[1], rand_forest[3], set_engine[5], set_mode[5]
readr	read_csv[1]
recipes	has_role[2], recipe[2], update_role[4]
rsample	initial_split[2], testing[2], training[2]
scales	cut_short_scale[3], label_number[3]
stats	median[2]
stringr	str_c[1], str_sub[1], str_to_sentence[1], str_wrap[3]
tidyr	drop_na[1], pivot_longer[1]
usedthese	used_here[1]
vip	vip[5]
workflows	add_model[5], add_recipe[5], workflow[5]
yardstick	metrics[2]

References

Kuhn, Max, and Hadley Wickham. 2020. “Tidymodels: A Collection of Packages for Modeling and Machine Learning Using Tidyverse Principles.” https://www.tidymodels.org.