The British Library Funding Crisis: A Three-Part Analysis

From variable income streams through external shocks to cumulative impact

TidyTuesday
2025
A comprehensive analysis of British Library funding from 1998-2023 revealing a 42% decline from peak levels. Using coefficient of variation analysis, event timeline mapping, and cumulative gap visualization to explore funding reliability, external economic shocks, and the long-term impact of austerity policies on the UK’s national library.
Author

Steven Ponce

Published

July 14, 2025

Figure 1: Three-panel chart showing the British Library funding crisis from 1998-2023. The top panel shows total funding declining from £150M peak in 2007 to £85M by 2023, with vertical lines marking major events like the financial crisis and austerity. The bottom left shows funding source reliability with ‘Other’ most variable (CV=2.9) and Grant-in-Aid most stable (CV=0.1). The bottom right displays the cumulative funding gap reaching 42% below the historical peak by 2023.

Steps to Create this Graphic

1. Load Packages & Setup

Show code
```{r}
#| label: load
#| warning: false
#| message: false
#| results: "hide"

## 1. LOAD PACKAGES & SETUP ----
suppressPackageStartupMessages({
if (!require("pacman")) install.packages("pacman")
pacman::p_load(
    tidyverse,  # Easily Install and Load the 'Tidyverse'
    ggtext,     # Improved Text Rendering Support for 'ggplot2'
    showtext,   # Using Fonts More Easily in R Graphs
    janitor,    # Simple Tools for Examining and Cleaning Dirty Data
    scales,     # Scale Functions for Visualization
    glue,       # Interpreted String Literals
    patchwork   # The Composer of Plots
  )})

### |- figure size ----
camcorder::gg_record(
  dir    = here::here("temp_plots"),
  device = "png",
  width  = 10,
  height = 12,
  units  = "in",
  dpi    = 320
)

# Source utility functions
suppressMessages(source(here::here("R/utils/fonts.R")))
source(here::here("R/utils/social_icons.R"))
source(here::here("R/utils/image_utils.R"))
source(here::here("R/themes/base_theme.R"))
```

2. Read in the Data

Show code
```{r}
#| label: read
#| include: true
#| eval: true
#| warning: false

tt <- tidytuesdayR::tt_load(2025, week = 28)

bl_funding <- tt$bl_funding |> clean_names()

tidytuesdayR::readme(tt)
rm(tt)
```

3. Examine the Data

Show code
```{r}
#| label: examine
#| include: true
#| eval: true
#| results: 'hide'
#| warning: false

glimpse(bl_funding)
```

4. Tidy Data

Show code
```{r}
#| label: tidy
#| warning: false

# Plot 1 Data ----
calculate_variability <- function(data, columns, type_name) {
  data |>
    select(year, all_of(columns)) |>
    pivot_longer(cols = -year, names_to = "source", values_to = "amount") |>
    group_by(source) |>
    summarise(
      mean_val = mean(amount, na.rm = TRUE),
      sd_val = sd(amount, na.rm = TRUE),
      cv = sd_val / mean_val,
      .groups = "drop"
    ) |>
    mutate(type = type_name) |>
    arrange(desc(cv))
}

# Calculate variability for both nominal and inflation-adjusted
nominal_cols <- c(
  "gia_gbp_millions", "voluntary_gbp_millions", "investment_gbp_millions",
  "services_gbp_millions", "other_gbp_millions"
)

adjusted_cols <- c(
  "gia_y2000_gbp_millions", "voluntary_y2000_gbp_millions",
  "investment_y2000_gbp_millions", "services_y2000_gbp_millions",
  "other_y2000_gbp_millions"
)

nominal_var <- calculate_variability(bl_funding, nominal_cols, "Nominal")
adjusted_var <- calculate_variability(bl_funding, adjusted_cols, "Inflation-Adjusted")

# Plot data
variability_comparison <- bind_rows(nominal_var, adjusted_var) |>
  mutate(
    source_clean = str_remove(source, "_gbp_millions|_y2000_gbp_millions") |>
      str_replace("gia", "grant-in-aid") |>
      str_replace_all("_", " ") |>
      str_to_sentence()
  ) |>
  group_by(source_clean) |>
  mutate(avg_cv = mean(cv)) |>
  ungroup() |>
  mutate(source_clean = fct_reorder(source_clean, avg_cv))

# Plot 2 Data ----
# Define key events
events <- tibble(
  year = c(2001, 2007, 2008, 2010, 2013, 2016, 2020),
  event = c(
    "9/11 Economic\nUncertainty", "Pre-Crisis\nPeak",
    "Financial\nCrisis", "Austerity\nBegins", "Digital Legal\nDeposit",
    "Brexit\nVote", "COVID-19\nPandemic"
  ),
  type = c("negative", "positive", "negative", "negative", "neutral", "negative", "negative"),
  label_offset = c(1.08, 1.02, 1.12, 0.98, 1.06, 1.01, 1.09)
)

max_funding_value <- bl_funding |>
  filter(!is.na(total_y2000_gbp_millions)) |>
  pull(total_y2000_gbp_millions) |>
  max()

events <- events |>
  mutate(y_pos = max_funding_value * label_offset)

# Plot 3 Data ----
gap_analysis <- bl_funding |>
  mutate(
    peak_total = max(total_y2000_gbp_millions, na.rm = TRUE),
    peak_gia = max(gia_y2000_gbp_millions, na.rm = TRUE),
    funding_gap = peak_total - total_y2000_gbp_millions,
    gia_gap = peak_gia - gia_y2000_gbp_millions,
    gap_percentage = funding_gap / peak_total * 100
  )

# Plot data
gap_data <- gap_analysis |>
  select(year, funding_gap, gia_gap) |>
  pivot_longer(-year, names_to = "gap_type", values_to = "gap_amount") |>
  mutate(gap_type = factor(case_when(
    gap_type == "funding_gap" ~ "Total Funding Gap",
    gap_type == "gia_gap" ~ "Grant-in-Aid Gap"
  ), levels = c("Grant-in-Aid Gap", "Total Funding Gap")))

# Key milestone annotations
key_years_data <- gap_analysis |>
  filter(year %in% c(2010, 2015, 2020, 2023)) |>
  select(year, funding_gap, gap_percentage)
```

5. Visualization Parameters

Show code
```{r}
#| label: params
#| include: true
#| warning: false

### |-  plot aesthetics ----
colors <- get_theme_colors(
  palette = c(
    primary = 'gray20',
    secondary = "#8B0000",
    accent = "#DAA520",
    neutral = "#666666",
    background = '#FDFDFD',
    success = "#2d5a27",
    warning = "#d73027"
  )
)

### |- titles and caption ----
title_text <- str_glue("The British Library Funding Crisis: A Three-Part Analysis")

subtitle_text <- str_glue("From variable income streams through external shocks to cumulative impact")

caption_text <- create_social_caption(
  tt_year = 2025,
  tt_week = 28,
  source_text =  "BL Funding Over Time"
)

### |-  fonts ----
setup_fonts()
fonts <- get_font_families()

### |-  plot theme ----

# Start with base theme
base_theme <- create_base_theme(colors)

# Add weekly-specific theme elements
weekly_theme <- extend_weekly_theme(
  base_theme,
  theme(
    # Axis elements
    axis.text = element_text(color = colors$text, size = rel(0.7)),
    axis.title.x = element_text(color = colors$text, face = "bold", size = rel(0.8), margin = margin(t = 15)),
    axis.title.y = element_text(color = colors$text, face = "bold", size = rel(0.8), margin = margin(r = 10)),

    # Grid elements
    panel.grid.major.y = element_line(color = "gray50", linewidth = 0.05),
    panel.grid.minor = element_blank(),
    panel.grid.major.x = element_blank(),

    # Legend elements
    legend.position = "plot",
    legend.title = element_text(family = fonts$tsubtitle, color = colors$text, size = rel(0.8), face = "bold"),
    legend.text = element_text(family = fonts$tsubtitle, color = colors$text, size = rel(0.7)),

    # Plot margin
    plot.margin = margin(t = 15, r = 15, b = 15, l = 15),
  )
)

# Set theme
theme_set(weekly_theme)
```

6. Plot

Show code
```{r}
#| label: plot
#| warning: false

# Plot 1: Variability Analysis ----
p1_subtitle <- str_glue(
    "Coefficient of variation: <span style='color:{colors$palette[\"accent\"]}'>**Nominal values**</span> vs ",
    "<span style='color:{colors$palette[\"primary\"]}'>**inflation<br>adjusted values**</span><br>",
    "Higher values = less predictable funding"
)

p1 <- variability_comparison |>
  ggplot(aes(x = source_clean, y = cv, fill = type)) +
  # Geoms
  geom_col(position = "dodge", alpha = 0.85, width = 0.7) +
  geom_text(aes(label = sprintf("%.3f", cv)),
    position = position_dodge(width = 0.7),
    vjust = -0.3, hjust = -0.25, size = 3.2,
    color = colors$palette["neutral"], fontface = "bold"
  ) +
  # Scales
  scale_fill_manual(
    values = setNames(
      c(colors$palette["accent"], colors$palette["primary"]),
      unique(variability_comparison$type)
    )
  ) +
  scale_y_continuous(expand = expansion(mult = c(0, 0.15))) +
  coord_flip() +
  # Labs
  labs(
    title = "Funding Source Reliability",
    subtitle = p1_subtitle,
    x = NULL,
    y = "Coefficient of Variation"
  ) +
  # Theme
  theme(
    plot.title = element_text(
      size = 16, family = fonts$title,
      face = "bold", color = colors$title, lineheight = 1.1,
      margin = margin(t = 5, b = 5)
    ),
    plot.subtitle = element_markdown(
      size = 11, family = fonts$subtitle,
      color = colors$palette["neutral"], lineheight = 1.1,
      margin = margin(t = 5, b = 10)
    ),
    panel.grid.major.y = element_blank(),
    panel.grid.major.x = element_line(color = "gray90", linewidth = 0.25)
  )

# Plot 2: Event Timeline ----
p2 <- bl_funding |>
  ggplot(aes(x = year, y = total_y2000_gbp_millions)) +
  # Geoms
  geom_line(color = colors$palette["primary"], linewidth = 1.5, alpha = 0.9) +
  geom_point(color = colors$palette["primary"], size = 2.8, alpha = 0.8) +
  geom_vline(
    data = events,
    aes(xintercept = year, color = type),
    linetype = "dashed", alpha = 0.7, linewidth = 0.6
  ) +
  geom_text(
    data = events,
    aes(x = year, y = y_pos, label = event, color = type),
    angle = 90, hjust = 0, vjust = -0.2, size = 2.9, fontface = "bold",
    lineheight = 0.9
  ) +
  # Scales
    scale_color_manual(
        values = setNames(
            c(colors$palette["success"], colors$palette["warning"], colors$palette["neutral"]),
            c("positive", "negative", "neutral")
        )
    ) +
  scale_y_continuous(
    labels = label_dollar(prefix = "£", suffix = "M"),
    expand = expansion(mult = c(0.02, 0.28))
  ) +
  scale_x_continuous(
    breaks = seq(1998, 2023, 5),
    limits = c(1997, 2024)
  ) +
  # Labs
  labs(
    title = "External Shocks Shape Funding Trajectory",
    subtitle = "Major economic and political events coincide with funding changes",
    x = "Year",
    y = "Total Funding (2000 GBP)"
  ) +
  # Theme
  theme(
      plot.title = element_text(
          size = 16, family = fonts$title,
          face = "bold", color = colors$title, lineheight = 1.1,
          margin = margin(t = 5, b = 5)
      ),
      plot.subtitle = element_markdown(
          size = 11, family = fonts$subtitle,
          color = colors$palette["neutral"], lineheight = 1.1,
          margin = margin(t = 5, b = 10)
      ),
    panel.grid.major.y = element_line(color = "gray90", linewidth = 0.25),
    panel.grid.major.x = element_blank()
  )

# Plot 3: Funding Gap ----
p3_subtitle <- str_glue(
  "<span style='color:{colors$palette[\"warning\"]}'>**Total funding gap**</span> and ",
  "<span style='color:{colors$palette[\"secondary\"]}'>**Grant-in-Aid gap**</span> from historical peak<br>",
  "Dotted line shows trend • Percentages show scale of loss"
)

p3 <- gap_data |>
  ggplot(aes(x = year, y = gap_amount, fill = gap_type)) +
  # Geoms
  geom_area(alpha = 0.75, position = "identity") +
  geom_smooth(
    data = gap_analysis, aes(x = year, y = funding_gap),
    inherit.aes = FALSE, method = "loess", se = FALSE,
    color = "darkred", linetype = "dotted", linewidth = 1.2, alpha = 0.8
  ) +
  geom_text(
    data = key_years_data,
    aes(x = year, y = funding_gap, label = paste0(round(gap_percentage, 0), "%")),
    inherit.aes = FALSE, vjust = -0.5, size = 3.3,
    color = colors$palette["secondary"], fontface = "bold"
  ) +
  # Scales
  scale_fill_manual(
        values = setNames(
            c(colors$palette["secondary"], colors$palette["warning"]),
            unique(gap_data$gap_type)
        )
    ) +
  scale_y_continuous(
    labels = label_dollar(prefix = "£", suffix = "M"),
    expand = expansion(mult = c(0, 0.15))
  ) +
  scale_x_continuous(
    breaks = seq(1998, 2023, 5),
    limits = c(1997, 2024)
  ) +
  # Labs
  labs(
    title = "The Cumulative Cost of Underfunding",
    subtitle = p3_subtitle,
    x = "Year",
    y = "Funding Gap from Peak (2000 GBP)"
  ) +
  # Theme
  theme(plot.title = element_text(
      size = 16, family = fonts$title,
      face = "bold", color = colors$title, lineheight = 1.1,
      margin = margin(t = 5, b = 5)
  ),
  plot.subtitle = element_markdown(
      size = 11, family = fonts$subtitle,
      color = colors$palette["neutral"], lineheight = 1.1,
      margin = margin(t = 5, b = 10)
  ),
    panel.grid.major.y = element_line(color = "gray90", linewidth = 0.25),
    panel.grid.major.x = element_blank()
  )

# Plot 3: Funding Gap ----
combined_plot <- p2 / (p1 + p3) +
  plot_layout(heights = c(1.1, 1)) +
  plot_annotation(
    title = title_text,
    subtitle = subtitle_text,
    caption = caption_text,
    theme = theme(
      plot.title = element_text(
        size = 24, face = "bold", color = colors$palette["primary"],
        hjust = 0, margin = margin(b = 8), family = fonts$title,
      ),
      plot.subtitle = element_text(
        size = 14, color = colors$palette["neutral"],
        hjust = 0, margin = margin(b = 10), family = fonts$subtitle
      ),
      plot.caption = element_markdown(
        size = 9, color = colors$palette["neutral"],
        hjust = 0.5, margin = margin(t = 15), family = fonts$caption,
      ),
      plot.background = element_rect(fill = colors$palette["background"], color = NA),
      plot.margin = margin(20, 20, 20, 20)
    )
  )
```

7. Save

Show code
```{r}
#| label: save
#| warning: false

### |-  plot image ----  
save_plot_patchwork(
  plot = combined_plot, 
  type = "tidytuesday", 
  year = 2025, 
  week = 28, 
  width  = 10,
  height = 12
)
```

8. Session Info

R version 4.4.1 (2024-06-14 ucrt)
Platform: x86_64-w64-mingw32/x64
Running under: Windows 11 x64 (build 22631)

Matrix products: default


locale:
[1] LC_COLLATE=English_United States.utf8 
[2] LC_CTYPE=English_United States.utf8   
[3] LC_MONETARY=English_United States.utf8
[4] LC_NUMERIC=C                          
[5] LC_TIME=English_United States.utf8    

time zone: America/New_York
tzcode source: internal

attached base packages:
[1] stats     graphics  grDevices datasets  utils     methods   base     

other attached packages:
 [1] here_1.0.1      patchwork_1.3.0 glue_1.8.0      scales_1.3.0   
 [5] janitor_2.2.0   showtext_0.9-7  showtextdb_3.0  sysfonts_0.8.9 
 [9] ggtext_0.1.2    lubridate_1.9.3 forcats_1.0.0   stringr_1.5.1  
[13] dplyr_1.1.4     purrr_1.0.2     readr_2.1.5     tidyr_1.3.1    
[17] tibble_3.2.1    ggplot2_3.5.1   tidyverse_2.0.0 pacman_0.5.1   

loaded via a namespace (and not attached):
 [1] tidyselect_1.2.1   farver_2.1.2       fastmap_1.2.0      gh_1.4.1          
 [5] digest_0.6.37      timechange_0.3.0   lifecycle_1.0.4    rsvg_2.6.1        
 [9] magrittr_2.0.3     compiler_4.4.0     rlang_1.1.6        tools_4.4.0       
[13] utf8_1.2.4         yaml_2.3.10        knitr_1.49         labeling_0.4.3    
[17] htmlwidgets_1.6.4  bit_4.5.0          curl_6.0.0         xml2_1.3.6        
[21] camcorder_0.1.0    tidytuesdayR_1.1.2 withr_3.0.2        grid_4.4.0        
[25] fansi_1.0.6        colorspace_2.1-1   gitcreds_0.1.2     cli_3.6.4         
[29] rmarkdown_2.29     crayon_1.5.3       generics_0.1.3     rstudioapi_0.17.1 
[33] tzdb_0.5.0         commonmark_1.9.2   splines_4.4.0      parallel_4.4.0    
[37] ggplotify_0.1.2    vctrs_0.6.5        yulab.utils_0.1.8  Matrix_1.7-0      
[41] jsonlite_1.8.9     gridGraphics_0.5-1 hms_1.1.3          bit64_4.5.2       
[45] systemfonts_1.1.0  magick_2.8.5       gifski_1.32.0-1    codetools_0.2-20  
[49] stringi_1.8.4      gtable_0.3.6       munsell_0.5.1      pillar_1.9.0      
[53] rappdirs_0.3.3     htmltools_0.5.8.1  R6_2.5.1           httr2_1.0.6       
[57] rprojroot_2.0.4    lattice_0.22-6     vroom_1.6.5        evaluate_1.0.1    
[61] markdown_1.13      gridtext_0.1.5     snakecase_0.11.1   renv_1.0.3        
[65] Rcpp_1.0.13-1      svglite_2.1.3      nlme_3.1-164       mgcv_1.9-1        
[69] xfun_0.49          fs_1.6.5           pkgconfig_2.0.3

9. GitHub Repository

The complete code for this analysis is available in tt_2025_28.qmd.

For the full repository, click here.

10. References

  1. Data Sources:
  • TidyTuesday 2025 Week 28: [British Library Funding](https://github.com/rfordatascience/tidytuesday/blob/main/data/2025/2025-07-15)
Back to top