Julius's Blog - R Posts

Conway–Maxwell–Binomial regression: two-directional dispersion for bounded counts

Julius Bogomolovas — Sun, 24 May 2026 07:00:00 GMT

How I got here

For a long time I was fitting cell proliferation counts with Conway-Maxwell-Poisson and a log(n) offset. It worked fine. Counts behaved like rates, the dispersion parameter ν gave me a handle on whether the data were over or underdispersed relative to Poisson, and the offset turned an unbounded count distribution into something that read like a proportion model. Standard applied stats move, nothing exotic.

Then I tried to build a simulator. In the previous post I wrote a CMP-with-offset data generator so I could check coverage and power before running real experiments. And the simulator started producing counts above the biological ceiling. Cells dividing more times than there are cells. The unbounded count distribution does not know my data has an upper bound, and the offset trick does not enforce one.

In my real data this had not bitten me because proliferation rarely hits the ceiling. So the bound was a silent assumption I had been getting away with for years. The simulator surfaced it.

That sent me reading. The right answer for bounded counts with flexible dispersion is the Conway-Maxwell-Binomial distribution, the bounded analogue of CMP. It spans both dispersion directions through the same ν parameter, and it respects the bound by construction.

The puzzle is why CMB is not a standard tool. Underdispersion in proportion data is a known headache and the workarounds in common use are all unsatisfying. The oldest is the arcsine square-root transformation: apply a variance-stabilizing transform to the observed proportions and fit a Gaussian regression on the transformed values. This throws away the bounded discrete structure of the data, produces coefficients on a scale that does not map cleanly back to rates, and offers no way to model dispersion separately from the mean. The coral fertilization paper we work through later in this post takes exactly this route, and we will see why it leaves a real biological signal on the table. A second workaround is quasi-binomial, which allows the dispersion parameter to fall below 1 but does so without a proper likelihood behind it, so AIC comparisons, likelihood ratio tests, and random effects are all off the table. A third option is to fit a binomial GLM and ignore the underdispersion, accepting standard errors that are wrong in a direction that is hard to predict from the output alone. None of these is what someone would reach for if a clean alternative were sitting in their toolkit.

R support for CMB is thin. The COMMultReg package by Andrew Raim (Raim, n.d.) provides distribution-level utilities for CMB (density, sampling, normalizing constant, mean, variance) and a full regression interface for the multinomial generalization. The package name is honest about its scope: Conway-Maxwell-Multinomial Regression. The binomial case sits in the distribution module only, in the canonical (m, p, ν) parameterization (Kadane 2016), with no regression interface, no formula syntax, no dispersion submodel, and no random effects.

So that is what I built. CMB now lives on two public forks: the TMB-side family definition with the auto-differentiable likelihood, and the glmmTMB-side integration that wires it into the formula interface so you can write family = compbinomial, dispformula = ~ ... like any other family. It is not on CRAN. Maybe one day. For now if you want to follow along you install from those forks.

This post is two things. First, a short explanation of why CMB is the right tool when your data are bounded and your dispersion is heterogeneous or two-sided. Second, two worked examples: a simulated three-group dataset where you can see the machinery work in controlled conditions, and a real coral fertilization study where CMB sharpens the biological finding the original analysis could not formally test.

The dispersion landscape

A short conceptual section before code.

You have a bounded count: successes out of trials. The default model is binomial, which fixes the variance at once you condition on the mean. Real data are often more variable than this, sometimes less. The deviation from binomial variance, in either direction, is what people call dispersion.

The standard fix for more variance than binomial is the beta-binomial. It writes the variance as

The dispersion parameter inflates the binomial variance. When you recover binomial. When the variance approaches the maximum possible for a bounded count. So beta-binomial covers everything from binomial up to the upper bound.

What it does not cover is anything below the binomial line. The constraint is not a numerical artifact, it is a property of the family. If your data are less variable than binomial, the BB likelihood pushes against zero and either pegs there (silently behaving as binomial) or fails to converge with a non-positive-definite Hessian. There is no way to wiggle through it.

The Conway-Maxwell-Binomial family does cover both sides. Its variance, approximately, behaves like , with the dispersion parameter on a multiplicative scale: is binomial, is overdispersed (more variance), is underdispersed (less variance). One parameter, two directions, the bound preserved.

The other natural alternative for rate-like data, CMP with a log(n) offset, fails for a different reason. It is an unbounded count distribution, so the bound is not part of the model. In situations where counts rarely approach the offset trick can be a decent approximation, but it is not a principled choice for bounded data and it breaks at the ceiling.

A picture of what these three families look like for the same mean and different ν values:

Show code

Conway–Maxwell–Poisson vs Welch’s t-test for proliferation count data

Julius Bogomolovas — Tue, 19 May 2026 07:00:00 GMT

There is a Chinese saying, 物尽其用, which approximately translates as “make the best use of everything.” I first came across it as the title of a Song Dong installation at MoMA. So in this post I am testing whether a 物尽其用 approach to quantifying cell proliferation actually does better than the standard one.

In my work I count proliferating cardiomyocytes and compare proliferation rates between wild-type and knockout hearts. The data comes from tissue sections stained for a cardiomyocyte marker and a proliferation marker, which gives me, per microscopy field, the total number of CMs and the number of proliferating CMs.

The standard analysis is a t-test on per-animal proliferation ratios. The moment you take that path, three things get thrown away: the within-animal variation sitting right there across the multiple fields per heart; the statistical weight that should come with larger denominators (1/10 and 100/1000 are not equally trustworthy estimates of 0.1); and the awkward fact that ratios live in [0,1], which is not where a t-test wants its data. None of these are catastrophic on their own. Together they motivate an obvious question: what if we kept the information instead?

Two of the three losses, the statistical weight and the bounded distribution, are about how you model the count itself, and count regression fixes both. Instead of collapsing into a ratio, you model the raw counts directly, with total cells counted entering as an offset. The offset is what carries the credibility of each estimate into the analysis, and the model respects the discrete, bounded-below, often-overdispersed nature of count data. The third loss, within-animal variation, is about how you treat the nesting. It is fixed by adding a random intercept per animal, so the model separates between-animal from within-animal variance instead of averaging it away.

These are two orthogonal decisions. Crossed, they give a 2×2 of methods, all of which I’ll evaluate side by side:

Animal-level (no random effects). Aggregate fields to one number per animal, then test. Welch’s t-test (on ratios) vs Conway–Maxwell–Poisson (CMP) GLM (on counts). This is the standard biologist workflow.
Field-level (with random effects). Keep the field structure, add a random intercept per animal. Linear mixed model (LMM) on ratios vs CMP GLMM on counts.

I argued the count-regression half of this case in my previous publication (Bogomolovas et al., 2022), where I walked from raw microscopy images through AI-based cell counts to count-regression statistics. But I kept saying “I should formally test this.” Here it is. I believe the 物尽其用 approach is the better one, but is it always better than the default? Where does it shine? Are there regimes where the simpler approach holds up just fine?

I build the comparison from scratch: a data generator, four fitters in one place, a Latin-hypercube sweep of the realistic experimental design space, and Gaussian process emulators that let me ask questions about method behaviour anywhere in that space, not just at the handful of points I simulated. The post is organised by metric — Type-I error, statistical power, CI precision — comparing all four methods on each in turn, then a practical recommendation at the end.

Setup

Show code

“And I’m looking for the funnies”: sentiment in Lithuanian news headlines

Julius Bogomolovas — Sat, 02 May 2026 07:00:00 GMT

There’s a moment in Suzanne Vega’s Tom’s Diner where the narrator picks up a newspaper, skips the stories, and goes straight to the funnies. It’s a small, accurate observation about reading the news: most of it doesn’t feel good, so you protect yourself.

I wanted to know how true that is, in numbers. Are Lithuanian news headlines as relentlessly negative as they feel? Are some outlets more negative than others?

To find out, I built a small system that hourly pulls RSS feeds from 7 Lithuanian outlets, deduplicates by URL, and sends each new headline to Claude Sonnet 4.6. The model returns three things: a sentiment score in [-1, +1], an IPTC Media Topic label (one of 17 international press categories like politics, sport, crime, law and justice), and up to three named entities.

Two things made this approach attractive. First, Lithuanian is heavily inflected and has limited classical NLP tooling, so a frontier multilingual model handles it cleanly without needing to train anything. Second, using IPTC’s controlled vocabulary instead of letting the model invent topic labels makes per-topic comparisons coherent across outlets. Cost is about $0.001 per headline.

After a week, I had 4,832 scored headlines spanning 9 days. Here’s the distribution of sentiment scores:

Examples below appear in the original Lithuanian with English translations.

To make the score concrete, here are real processed headlines from the dataset at three different sentiment levels and topics. Claude does a pretty good job.

Example headlines at three sentiment levels
Score	Topic	Lithuanian	English
-0.7	disaster, accident and emergency incident	Vilkaviškyje dingo iš ligoninės pasišalinęs nepilnametis	A minor went missing after leaving a hospital in Vilkaviškis
0.0	economy, business and finance	Klausiate, atsakome. Ar antstoliai nuskaitys atgautas antrosios pensijų pakopos lėšas?	Q&A on whether bailiffs will deduct recovered second-pillar pension funds
+0.7	education	Klaipėdos Vydūno gimnazijos pirmokai Lietuvai atstovaus robotikos čempionate Honkonge	Klaipėda’s Vydūnas Gymnasium first-years will represent Lithuania at a robotics championship in Hong Kong

The distribution is clearly bimodal, with two humps separated by a trough at zero. Headlines exist to provoke; pure neutrality is rare. Most lean one way or the other, and few are ambivalent.

So I went looking for differences between outlets. The chart said 15min.lt was the most negative outlet in Lithuania. The chart was wrong. Not because the number was wrong, but because the comparison wasn’t fair. Here’s what went wrong, and what the data actually shows.

The first (wrong) finding

I plotted mean sentiment per outlet, ranked them, and got this:

By this measure, 15min sits noticeably below everyone else. If I had published this as the result, it would have looked clean and confident, and it would have been misleading.

What I missed

Outlets cover different mixes of topics, and topics carry their own sentiment baseline. Crime headlines are negative everywhere; sport headlines are positive everywhere. So a fair comparison has to account for what each outlet writes about, not just how their headlines score on average.

What the model says

The right tool is partial pooling with a hierarchical Bayesian model. The intuition: every headline’s sentiment is a sum of effects, namely what topic it’s about, which outlet wrote it, and whether this particular outlet treats this particular topic differently from average. The model estimates each piece simultaneously and shrinks small-sample estimates toward the population mean. So an outlet with three crime headlines doesn’t get to claim a wildly different “crime tone” from one with three hundred. Its estimate gets pulled toward what we know about crime coverage in general.

Three modelling choices need a brief defence:

Why ordinal, not Gaussian? A linear regression on sentiment treats the score as if it were continuous and normally distributed. It isn’t. The scores live on 21 discrete rungs from -1.0 to +1.0 in steps of 0.1, and the histogram you saw earlier is bimodal, not bell-shaped. Fitting a Gaussian model gives sensible rankings but unreliable uncertainty estimates and ugly posterior predictive checks. Cumulative ordinal regression handles the discrete, bimodal structure natively.

Why Bayesian, not frequentist? I fit several frequentist models first as sanity checks (lm, polr, clmm), and they all agreed on the substantive answer. The Bayesian fit adds three things the frequentist alternatives can’t: honest credible intervals on variance components (especially important when the source-level variance is genuinely small and a frequentist point estimate near zero is misleading), proper partial pooling that’s robust to sparse cells in the source by topic interaction, and posterior distributions that visualise uncertainty as shape rather than as a confidence-interval bar.

Why the source by topic interaction? Without it, “outlets are similar on average” would be the only thing the model could say. The interaction term is what lets us ask the more interesting question: does any outlet treat any specific topic unusually, even if it doesn’t differ on average? That’s where editorial fingerprints actually live, and we’ll come back to it.

I fit the model in brms with weakly informative priors and 8 chains by 2000 iterations. All R-hat values came in below 1.01. Diagnostics are in the appendix.

The first thing the model tells us is the variance budget, namely how much of headline-level sentiment variation lives at each level:

Topic-level variation is roughly 12 times outlet-level variation. The story is overwhelmingly: what a headline is about determines how it reads, far more than who wrote it.

Topic effects, the dominant signal

Here’s how each topic shifts sentiment, regardless of outlet. Crime and disaster anchor the negative end across the board; sport and culture anchor the positive end:

The pattern matches intuition: arts, lifestyle, sport, and science cluster at the top. These are stories of achievement, performance, and discovery. Crime and disaster anchor the bottom, with conflict close behind. Politics sits in mildly negative territory, while weather, economy, and health hover near zero, where the framing depends almost entirely on the specific event.

The range is what matters most. Topic effects span more than 5 log-odds top to bottom, a huge range, meaning a sport headline is many times more likely to land in the upper sentiment categories than a crime headline, regardless of who wrote it. Outlet effects, as we’ll see next, span barely a tenth of that.

Outlet effects, what’s left after topic

Once the model accounts for topic mix, the gap between outlets nearly disappears:

These are the same outlets that looked dramatically different in the naive chart. After the model accounts for what each one covers, they’re nearly indistinguishable. Lrytas and 15min lean slightly negative; LRT and Verslo žinios lean slightly positive; the credible intervals overlap heavily and most include zero.

Notice also that the order has shifted from the naive chart. Vakaru ekspresas was at the top of the raw ranking on the strength of just 133 headlines; partial pooling now pulls that small-sample estimate toward the population mean, and Verslo žinios takes the top spot. The differences remain small either way.

The naive ranking didn’t lie about the numbers. It lied about what those numbers meant.

Where outlets actually differ

But “outlets are similar on average” doesn’t mean “outlets are interchangeable.” The interaction term, does this outlet cover this specific topic differently from how that topic is treated on average?, is where editorial fingerprints actually live.

These are the cells that survive the strictest filter, namely combinations where we are 95% confident the effect is nonzero. They’re not the only differences between outlets, just the ones we can be confident about given the data we have.

On the positive side: LRT covers human interest and sport more positively than other outlets do, and 15min covers health more positively than the cross-outlet average for health. On the negative side: Lrytas covers disaster more negatively, LRT covers conflict more negatively, and Delfi covers sport more negatively than the cross-outlet baseline. The Delfi sport finding is notable because sport runs positive everywhere else.

The story isn’t “this outlet is negative.” The story is “this outlet covers this thing unusually.”

What I can and can’t say

This analysis supports:

Lithuanian news headlines on average sit slightly below sentiment-neutral.
Topic is by far the strongest determinant of headline sentiment, about an order of magnitude larger than the outlet effect.
After controlling for topic mix, outlets are far more similar in tone than the raw chart suggests.
Editorial differences between outlets exist, but live mostly in which topics they cover unusually, not in average tone.
Crime, conflict, and disaster anchor the negative end across all outlets; sport and culture anchor the positive end.

This analysis does not support:

Causal claims about why outlets cover what they do.
Claims about framing in any deep sense. Sentiment of a headline is not the same as bias of a story.
Generalisation beyond the specific RSS feeds I sampled.
Anything about audience response. Sentiment of headlines is not sentiment of readers.

Methodology

4,832 headlines from 7 Lithuanian outlets (15min, Bernardinai, Delfi, LRT, Lrytas, Vakaru ekspresas, Verslo zinios) over 9 days. Sentiment scores live on 21 discrete rungs from -1.0 to +1.0 in steps of 0.1, assigned by Claude Sonnet 4.6. Topic labels come from the IPTC Media Topics taxonomy (17 top-level categories). The statistical model is a cumulative ordinal Bayesian regression with random intercepts for source, topic, and source by topic, fit with brms using 8 chains by 2000 iterations (1000 warmup). Priors: normal(0, 5) for thresholds, normal(0, 1) for random-effect SDs. All R-hat values were below 1.01 and effective sample sizes above 1500 across parameters of interest. Pipeline and code are open source.

Software and packages

We used R v. 4.5.2 (R Core Team 2025) and the following R packages: brms v. 2.23.0 (Bürkner 2017, 2018, 2021), grateful v. 0.3.0 (Rodriguez-Sanchez and Jackson 2025), patchwork v. 1.3.2 (Pedersen 2025), scales v. 1.4.0 (Wickham, Pedersen, and Seidel 2025), tidybayes v. 3.0.7 (Kay 2024), tidyverse v. 2.0.0 (Wickham et al. 2019).

Appendix: model diagnostics

If the simulated intervals cover the observed bars, the model is generating data that looks like the data we have.

Variance components: posterior summaries
Parameter	Estimate	Est.Error	95% CI lower	95% CI upper
sd_source__Intercept	0.120	0.098	0.005	0.362
sd_topic__Intercept	1.412	0.245	1.019	1.969
sd_source:topic__Intercept	0.423	0.061	0.314	0.554

References

Bürkner, Paul-Christian. 2017. “brms: An R Package for Bayesian Multilevel Models Using Stan.” Journal of Statistical Software 80 (1): 1–28. https://doi.org/10.18637/jss.v080.i01.

———. 2018. “Advanced Bayesian Multilevel Modeling with the R Package brms.” The R Journal 10 (1): 395–411. https://doi.org/10.32614/RJ-2018-017.

———. 2021. “Bayesian Item Response Modeling in R with brms and Stan.” Journal of Statistical Software 100 (5): 1–54. https://doi.org/10.18637/jss.v100.i05.

Kay, Matthew. 2024. tidybayes: Tidy Data and Geoms for Bayesian Models. https://doi.org/10.5281/zenodo.1308151.

Pedersen, Thomas Lin. 2025. patchwork: The Composer of Plots. https://doi.org/10.32614/CRAN.package.patchwork.

R Core Team. 2025. R: A Language and Environment for Statistical Computing. Vienna, Austria: R Foundation for Statistical Computing. https://www.R-project.org/.

Rodriguez-Sanchez, Francisco, and Connor P. Jackson. 2025. grateful: Facilitate Citation of R Packages. https://pakillo.github.io/grateful/.

Wickham, Hadley, Mara Averick, Jennifer Bryan, Winston Chang, Lucy D’Agostino McGowan, Romain François, Garrett Grolemund, et al. 2019. “Welcome to the tidyverse.” Journal of Open Source Software 4 (43): 1686. https://doi.org/10.21105/joss.01686.

Wickham, Hadley, Thomas Lin Pedersen, and Dana Seidel. 2025. scales: Scale Functions for Visualization. https://doi.org/10.32614/CRAN.package.scales.

Six Years of Daily Steps: When Did Things Actually Change?

Julius Bogomolovas — Sun, 19 Apr 2026 07:00:00 GMT

Show code

Three Years of Daily Weight: What the Patterns Actually Are

Julius Bogomolovas — Sun, 12 Apr 2026 07:00:00 GMT

Show code

What’s Your Base? Estimating Swimming Fitness from Routine Training Data

Julius Bogomolovas — Sat, 04 Apr 2026 07:00:00 GMT

The Question Every Swimmer Gets Asked

I swim a lot, and like most swimmers, I am a little obsessive about tracking progress.

Garmin is great in many ways, but when it comes to swimming, the readouts are a bit underwhelming. You get average pace, effort score, SWOLF, and a few other summary numbers, but none of them really answer the question swimmers actually care about: how fast am I, really, right now?

There are formal ways to get at that. You can do time trials, swim a CSS test, or race. But those are just occasional snapshots. What I wanted was something more automatic: some kind of session-by-session measure that tells me how fast, or how fit, I was swimming in an ordinary workout.

In swimming, that idea is usually captured by base pace. If you join a masters team, one of the first questions people ask is: what’s your base? Roughly speaking, it is the pace you can hold steadily for repeat 100s on short rest. Not easy, not all-out, just your solid training pace. It is close to CSS, usually a bit slower, and it is one of the most practical ways swimmers think about fitness.

So I started wondering: could I estimate something like that automatically from routine workout data?

That is harder than it sounds, because swim workouts are messy on purpose. Within a single session you swim at different efforts, different distances, with different rest, and at different stages of fatigue. Sometimes you are sprinting, sometimes cruising, sometimes just surviving the set. So the average pace Garmin gives you is not really a fitness metric. It is heavily shaped by the structure of the workout itself.

That was really the whole motivation for this project.

In a previous post, I showed that GAMs can do a pretty good job modeling swim speed from workout structure and pulling out broad trends over time. That was a useful first step, but it still had a big limitation: it could not really separate swimming slow because I was tired from swimming slow because I was intentionally taking it easy. Effort and fitness were still tangled together.

This post is my attempt to go one step further. The idea is to use GAMs to tease apart lap speed by accounting for the main things that distort it — repeat length, position within a rep, accumulated fatigue, rest, stroke rate, heart rate, and so on — and then smooth the cleaned-up signal over time to get an estimate of base pace.

And because any homemade metric needs some kind of reality check, I have a couple of built-in positive controls. During this period I was training consistently toward the La Jolla Rough Water Swim relay on September 27, 2025, so if this metric is capturing something real, I should be getting faster into that race. I also had a stretch in spring 2025 when I was training with a swim buddy, which reliably made me swim harder and better than usual. So, at the very least, I would hope this thing can detect those signals and not just produce a fancy-looking curve.

In other words, the goal here is pretty simple: take messy routine swim data and turn it into a number swimmers already understand intuitively — a proxy for how fast, or how fit, I really was in a given session.

The Pipeline at a Glance

The pipeline has two stages, each built around a generalized additive model:

Structural GAM — reduces the influence of within-session mechanics (pacing, fatigue, rest, pool length) and effort (stroke rate, heart rate) on raw speed
Density surface GAM — smooths the adjusted pace distribution over calendar time, with peak extraction via parabolic interpolation

The output is a continuous fitness curve expressed in pace per 100 yards — the unit swimmers think in.

Data

FIT File Extraction

All data comes from Garmin FIT files recorded during pool swimming sessions, read via the FITfileR package (Smith 2025). The extraction pulls three message types per file: session-level metadata (date, pool length), per-length timing and stroke data, and per-lap heart rate. The full extraction runs in parallel across 7 cores and takes a few minutes.

Block 1: FIT file extraction (not evaluated — requires local FIT files)

Cherry Bloom Prediction

Julijus Bogomolovas — Mon, 07 Jul 2025 07:00:00 GMT

Cherry Blossom day prediction

So earlier this year I participated in International Cherry Blossom Prediction Competition, which invites you to predict this years bloom date of cherry trees in 5 different locations based on provided historical bloom dates provided and any data you dig out. Now that cherry trees bloomed long time ago, I am sharing my entry. As good ideas come after, I enhanced last modelling step by introducing State-Space framework into GAM model, allowing to deal with observation poor sites. Lets load all required packages.

# Load all required packages
library(nasapower)
library(grateful)
library(tidyverse)
library(lubridate)
library(ggplot2)
library(data.table)
library(missForest)
library(spls)
library(stringr)
library(mvgam)
library(tibble)

Cherry Blossom Data Engineering

The historical cherry blossom data was provided by the competition organizers at https://competition.statistics.gmu.edu/. For New York City, which had only one historical record in the competition dataset, I augmented it with observations from the USA National Phenology Network.

Import cherry blossom data

# Import cherry blossom data and filter for records from 1981 onward
Vancouver <- read_csv("data/vancouver.csv",show_col_types = FALSE)
Washington <- read_csv("data/washingtondc.csv",show_col_types = FALSE)
Kyoto <- read_csv("data/kyoto.csv",show_col_types = FALSE)
Swiss <- read_csv("data/liestal.csv",show_col_types = FALSE)
Nyc <- read_csv("data/nyc.csv",show_col_types = FALSE)

combined_blossom_dates <- rbind(Vancouver, Washington, Kyoto, Swiss, Nyc)
combined_blossom_dates <- combined_blossom_dates[order(combined_blossom_dates$location, combined_blossom_dates$year), ]
combined_blossom_dates <- combined_blossom_dates[combined_blossom_dates$year >= 1981, ]

Augment New York data with USA-NPN observations

# Read USA-NPN individual phenometrics data
USA_NPN_status_intensity <- read_csv('data/USA-NPN_status_intensity_observations_data.csv', show_col_types = FALSE)

# Convert to data frame and prepare Intensity_Value as factor
USA_status <- as.data.frame(USA_NPN_status_intensity)
USA_status$Intensity_Value <- as.factor(USA_status$Intensity_Value)

# Filter out records with intensity values that do not match our criteria
USA_status_filtered <- USA_status[!(USA_status$Intensity_Value %in% 
  c("-9999", "Little", "25-49%", "5-24%", "Less than 5%", "More than 10", "50-74%")), ]

# Convert dates and extract Year and Day of Year
USA_status_filtered$Date <- mdy(USA_status_filtered$Observation_Date)
USA_status_filtered$Year <- year(USA_status_filtered$Date)
USA_status_filtered$Day_of_Year <- yday(USA_status_filtered$Date)

# Create a scatter plot to visualize Day of Year vs. Year, colored by Intensity_Value
ggplot(USA_status_filtered, aes(x = Year, y = Day_of_Year, color = Intensity_Value)) +
  geom_point(size = 3, alpha = 0.8) +
  scale_color_brewer(palette = "Set1") +
  labs(title = "Day of Year vs Year for USA-NPN Data",
       x = "Year",
       y = "Day of Year",
       color = "Intensity Value") +
  theme_minimal()

# Summarize the filtered data by year
year_summary_NY_individual <- USA_status_filtered %>%
  group_by(Year) %>%
  summarize(
    Min = min(Day_of_Year, na.rm = TRUE),
    Q1 = quantile(Day_of_Year, 0.25, na.rm = TRUE),
    Median = median(Day_of_Year, na.rm = TRUE),
    Mean = mean(Day_of_Year, na.rm = TRUE),
    Q3 = quantile(Day_of_Year, 0.75, na.rm = TRUE),
    Max = max(Day_of_Year, na.rm = TRUE),
    Count = n()
  )
print(year_summary_NY_individual)

# A tibble: 13 × 8
    Year   Min    Q1 Median  Mean    Q3   Max Count
           
 1  2012    89  89      89    89    89     89     2
 2  2013   104 110     142   137.  150    170     9
 3  2014    98 108.    141   132.  156    160    11
 4  2015   101 138     148   141.  153    156    24
 5  2016   110 128.    135   134   143.   153     6
 6  2017    87 110     138   128.  143    146     9
 7  2018    79  99     101   103.  107    140    66
 8  2019    96 101     106.  115.  124.   151    24
 9  2020    78  90.5   100   107.  117.   243    32
10  2021    86  99     106   111.  116    148    41
11  2022    97 110.    122.  122.  136.   154    10
12  2023    92 104     130.  130.  139.   255    18
13  2024    88  94     106   110.  124    147    11

# Create new NY data frame from the yearly summary (excluding 2024)
ny_data <- data.frame(
  location = "newyorkcity",
  lat = 40.73040,
  long = -73.99809,
  alt = 8.5,
  year = year_summary_NY_individual$Year[year_summary_NY_individual$Year != 2024],
  bloom_date = NA,
  bloom_doy = year_summary_NY_individual$Min[year_summary_NY_individual$Year != 2024]
)

# Convert day-of-year to actual dates
ny_data$bloom_date <- as.Date(ny_data$bloom_doy - 1, origin = paste0(ny_data$year, "-01-01"))

# Merge with existing combined blossom dates
combined_blossom_dates <- rbind(combined_blossom_dates, ny_data)
combined_blossom_dates <- combined_blossom_dates[order(combined_blossom_dates$location, combined_blossom_dates$year), ]

Let’s examine the distribution of bloom dates across locations to determine an appropriate modeling timeframe:

# Summarize blossom dates by location
blossom_summary <- combined_blossom_dates %>%
  group_by(location) %>%
  summarise(
    Min = min(bloom_doy),
    Q1 = quantile(bloom_doy, 0.25),
    Median = median(bloom_doy),
    Q3 = quantile(bloom_doy, 0.75),
    Max = max(bloom_doy),
    Range = max(bloom_doy) - min(bloom_doy)
  )
print(blossom_summary)

# A tibble: 5 × 7
  location       Min    Q1 Median    Q3   Max Range
                
1 kyoto           84  93       95    99   109    25
2 liestal         75  87       93   101   121    46
3 newyorkcity     78  87       92    98   110    32
4 vancouver       83  84.5     86    91    96    13
5 washingtondc    74  86       91    95   101    27

The maximum third quartile (Q3) at day 100 represents when 75% of historical blooms have occurred in late–bloomer locations effectively marking the end of the bloom season across all locations. While I could theoretically calculate predictors from one recorded bloom date to the next, this creates a circular dependency: to predict next year’s bloom date, we’d need to know it already to determine when to stop accumulating our weather predictors. By using day 100 as our universal cutoff, I establish a “cherry year” that runs from April 10 to April 9, nicely matching historical bloom cycles. ### 2. Weather Feature Engineering

With our cherry year defined (April 10 to April 9), we now need to engineer weather features that align with this timeframe. The challenge is creating predictors that capture cumulative weather effects leading up to bloom, without knowing when the bloom will occur.

I used NASA POWER for continuous weather data from 1981-2025, calculated daily anomalies to normalize across locations, created 30-day rolling sums to capture cumulative effects, and transformed everything to cherry year coordinates. Missing values (~2.4%) were imputed using random forest.

Download weather data from NASA POWER

# Retrieve weather data using nasapower for each location
Kyoto_temp <- get_power(
       community = "ag",
       lonlat = c(135.6761, 35.0120),
       pars = c("T2M", "T2M_MAX","T2M_MIN", "PRECTOTCORR"),
       dates = c("1981-01-01", "2025-02-15"),
       temporal_api = "daily"
)

Swiss_temp <- get_power(
  community = "ag",
  lonlat = c(7.730519, 47.4814),
  pars = c("T2M", "T2M_MAX","T2M_MIN", "PRECTOTCORR"),
  dates = c("1981-01-01", "2025-02-15"),
  temporal_api = "daily"
)

Washington_temp <- get_power(
  community = "ag",
  lonlat = c(-77.0386, 38.8853),
  pars = c("T2M", "T2M_MAX","T2M_MIN", "PRECTOTCORR"),
  dates = c("1981-01-01", "2025-02-15"),
  temporal_api = "daily"
)

Vancouver_temp <- get_power(
  community = "ag",
  lonlat = c(-123.1636, 49.2237),
   pars = c("T2M", "T2M_MAX","T2M_MIN", "PRECTOTCORR"),
  dates = c("1981-01-01", "2025-02-15"),
  temporal_api = "daily"
)

NY_temp <- get_power(
  community = "ag",
  lonlat = c(-73.99809, 40.73040),
  pars = c("T2M", "T2M_MAX","T2M_MIN", "PRECTOTCORR"),
  dates = c("1981-01-01", "2025-02-15"),
  temporal_api = "daily"
)

Calculate daily weather anomalies

# Function to calculate daily climate anomalies
calculate_climate_anomalies <- function(data, 
                                        baseline_start = 1981, 
                                        baseline_end = 2024, 
                                        vars = c("T2M", "T2M_MAX", "T2M_MIN", "PRECTOTCORR")) {
  
  # Validate input variables
  if (!all(vars %in% names(data))) {
    stop("Not all specified variables are present in the dataset.")
  }
  if (!all(c("YEAR", "DOY") %in% names(data))) {
    stop("Dataset must include 'YEAR' and 'DOY' columns.")
  }
  
  # Create baseline subset
  baseline_data <- data[data$YEAR >= baseline_start & data$YEAR <= baseline_end, ]
  
  # Calculate daily climatology (mean for each day-of-year)
  climatology <- aggregate(baseline_data[vars], 
                           by = list(DOY = baseline_data$DOY), 
                           FUN = mean, 
                           na.rm = TRUE)
  
  # Merge climatology with original data and compute anomalies
  result <- merge(data, climatology, by = "DOY", suffixes = c("", "_mean"))
  for (var in vars) {
    mean_col <- paste0(var, "_mean")
    anom_col <- paste0(var, "_anomaly")
    result[[anom_col]] <- result[[var]] - result[[mean_col]]
  }
  
  # Attach attributes and sort by date
  attr(result, "baseline_period") <- paste(baseline_start, "-", baseline_end)
  attr(result, "variables") <- vars
  result <- result[order(result$YYYYMMDD), ]
  
  return(result)
}

# Calculate anomalies for each location
NY_temp_anomalies <- calculate_climate_anomalies(NY_temp)
Vancouver_temp_anomalies <- calculate_climate_anomalies(Vancouver_temp)
Swiss_temp_anomalies <- calculate_climate_anomalies(Swiss_temp)
Washington_temp_anomalies <- calculate_climate_anomalies(Washington_temp)
Kyoto_temp_anomalies <- calculate_climate_anomalies(Kyoto_temp)

# Append location identifiers and combine
NY_temp_anomalies$location <- "New York, USA"
Vancouver_temp_anomalies$location <- "Vancouver, Canada"
Swiss_temp_anomalies$location <- "Liestal-Weideli, Switzerland"
Washington_temp_anomalies$location <- "Washington DC, USA"
Kyoto_temp_anomalies$location <- "Kyoto, Japan"

combined_anomalies <- rbind(
  NY_temp_anomalies,
  Vancouver_temp_anomalies,
  Swiss_temp_anomalies,
  Washington_temp_anomalies,
  Kyoto_temp_anomalies
)
combined_anomalies <- combined_anomalies[order(combined_anomalies$location, combined_anomalies$YYYYMMDD), ]

Create rolling sums and transform to cherry years

# Convert to data.table and compute 30-day rolling sums for each anomaly type
combined_anomalies <- as.data.table(combined_anomalies)
combined_anomalies[, temp_ave_pos_rollsum := frollsum(ifelse(T2M_anomaly > 0, T2M_anomaly, 0), n = 30, align = "right"), by = location]
combined_anomalies[, temp_ave_neg_rollsum := frollsum(ifelse(T2M_anomaly < 0, T2M_anomaly, 0), n = 30, align = "right"), by = location]
combined_anomalies[, temp_max_pos_rollsum := frollsum(ifelse(T2M_MAX_anomaly > 0, T2M_MAX_anomaly, 0), n = 30, align = "right"), by = location]
combined_anomalies[, temp_max_neg_rollsum := frollsum(ifelse(T2M_MAX_anomaly < 0, T2M_MAX_anomaly, 0), n = 30, align = "right"), by = location]
combined_anomalies[, temp_min_pos_rollsum := frollsum(ifelse(T2M_MIN_anomaly > 0, T2M_MIN_anomaly, 0), n = 30, align = "right"), by = location]
combined_anomalies[, temp_min_neg_rollsum := frollsum(ifelse(T2M_MIN_anomaly < 0, T2M_MIN_anomaly, 0), n = 30, align = "right"), by = location]
combined_anomalies[, prcp_pos_rollsum := frollsum(ifelse(PRECTOTCORR_anomaly > 0, PRECTOTCORR_anomaly, 0), n = 30, align = "right"), by = location]
combined_anomalies[, prcp_neg_rollsum := frollsum(ifelse(PRECTOTCORR_anomaly < 0, PRECTOTCORR_anomaly, 0), n = 30, align = "right"), by = location]

# Create a numeric day-of-year and adjust to form a 'cherry_year'
combined_anomalies[, doy := as.numeric(format(YYYYMMDD, "%j"))]
combined_anomalies[, cherry_year := ifelse(doy >= 100, year(YYYYMMDD) + 1, year(YYYYMMDD))]
combined_anomalies[, day_number := ifelse(doy >= 100, doy - 99, doy + (366 - 99))]

small_anomaly_df <- combined_anomalies %>%
  select(-c(DOY, LON, LAT, YEAR, MM, DD, T2M, T2M_MAX, T2M_MIN, PRECTOTCORR,
            T2M_mean, T2M_MAX_mean, T2M_MIN_mean, PRECTOTCORR_mean,
            T2M_anomaly, T2M_MAX_anomaly, T2M_MIN_anomaly, PRECTOTCORR_anomaly))

Reshape to wide format and impute missing values

# Example for positive temperature average anomalies - repeated for all 8 variables
wide_temp_ave_pos <- dcast(small_anomaly_df[!is.na(temp_ave_pos_rollsum)], 
                           cherry_year + location ~ day_number, 
                           value.var = "temp_ave_pos_rollsum")
setnames(wide_temp_ave_pos, 
         old = setdiff(names(wide_temp_ave_pos), c("cherry_year", "location")), 
         new = paste0("temp_ave_pos_rollsum_", seq_along(setdiff(names(wide_temp_ave_pos), c("cherry_year", "location")))))

numeric_cols <- setdiff(names(wide_temp_ave_pos), c("cherry_year", "location"))
numeric_matrix <- as.matrix(wide_temp_ave_pos[, ..numeric_cols])
imputed_result <- missForest(numeric_matrix, maxiter = 5, verbose = TRUE)
imputed_matrix <- imputed_result$ximp
wide_temp_ave_pos_imputed <- cbind(wide_temp_ave_pos[, .(cherry_year, location)], imputed_matrix)

# Repeat for all 8 rolling sum variables...
# [Similar code blocks for temp_ave_neg, temp_max_pos, temp_max_neg, 
#  temp_min_pos, temp_min_neg, prcp_pos, prcp_neg]

# Merge all wide-format datasets by cherry_year and location
final_wide <- Reduce(function(x, y) merge(x, y, by = c("cherry_year", "location"), all = TRUE),
                     list(wide_temp_ave_pos_imputed, wide_temp_ave_neg_imputed, 
                          wide_temp_max_pos_imputed, wide_temp_max_neg_imputed,
                          wide_temp_min_pos_imputed, wide_temp_min_neg_imputed,
                          wide_prcp_pos_imputed, wide_prcp_neg_imputed))

Merge with bloom dates

final_wide <- as_tibble(final_wide)

# Map location names to match blossom data format
location_mapping <- c(
  "Kyoto, Japan"                = "kyoto",
  "Liestal-Weideli, Switzerland" = "liestal",
  "New York, USA"               = "newyorkcity",
  "Vancouver, Canada"           = "vancouver",
  "Washington DC, USA"          = "washingtondc"
)
final_wide$location_mapped <- location_mapping[final_wide$location]

# Merge with bloom dates
final_wide <- merge(
  final_wide,
  combined_blossom_dates[, c("location", "year", "bloom_doy")],
  by.x = c("location_mapped", "cherry_year"),
  by.y = c("location", "year"),
  all.x = TRUE
)

# Reorder columns to put key variables first
keep_vars <- c("cherry_year", "location", "bloom_doy")
existing_keep_vars <- keep_vars[keep_vars %in% colnames(final_wide)]
other_vars <- setdiff(names(final_wide), c(existing_keep_vars, "location_mapped"))
final_wide <- final_wide[, c(existing_keep_vars, other_vars)]

# Save the final dataset
write.csv(final_wide, "data/final_wide_with_bloom.csv", row.names = TRUE)

The final dataset contains 2,928 weather predictors (8 rolling sums × 366 days) aligned to our cherry year timeframe, plus the actual bloom dates. You can download the pre-processed data from final_wide_with_bloom.csv or recreate it using the code above.

To use the pre-processed data in your analysis:

# Load the pre-processed data
final_wide <- read.csv("data/final_wide_with_bloom.csv", row.names = 1)

Selecting and Engineering features for blossom date prediction using sparse Partial Least Squares

In this section, I use Sparse Partial Least Squares (SPLS) to identify key predictors and extract latent factors that summarize the high-dimensional weather data. SPLS is particularly well-suited for our case: we have nearly 3,000 highly correlated rolling-sum features and just a few hundred samples. This method not only reduces dimensionality but also performs variable selection by introducing a sparsity penalty—so we can focus on the most relevant time windows and weather patterns that drive blooming. I first convert our wide-format dataset into a matrix form and define predictors (X) and the response (Y, i.e., bloom day). Then, I run a grid search with 10-fold cross-validation to find the best combination of latent factor count (K) and sparsity level (eta). Once the optimal parameters are selected, I fit the SPLS model to the training data. This gives me both a sparse projection matrix and a subset of predictors contributing to each latent factor. Finally, I use the trained model to compute latent scores (latent1, latent2, etc.) for all observations—these represent condensed weather signatures that track with bloom timing and will be used for downstream modeling. For now, I’ll treat all locations as pooled, ignoring site-specific effects (which I’ll handle later with GAMs).

# Prepare data for SPLS
my_data <- as.data.frame(final_wide)
id_cols <- c("cherry_year", "location", "bloom_doy")

predictor_cols <- setdiff(names(my_data), id_cols)
train_data <- subset(my_data, !is.na(bloom_doy))

X_train <- as.matrix(train_data[, predictor_cols])
Y_train <- train_data$bloom_doy

# Cross-validation for optimal parameters
set.seed(123)
cv.out <- cv.spls(
  X_train, 
  Y_train,
  K   = 1:10,
  eta = seq(0.1, 0.9, 0.1),
  fold = 10
)

eta = 0.1 
eta = 0.2 
eta = 0.3 
eta = 0.4 
eta = 0.5 
eta = 0.6 
eta = 0.7 
eta = 0.8 
eta = 0.9 

Optimal parameters: eta = 0.3, K = 3

optimal_K   <- cv.out$K.opt
optimal_eta <- cv.out$eta.opt

# Fit final SPLS model and extract latent factors
final_model <- spls(X_train, Y_train, K = optimal_K, eta = optimal_eta)
X_all <- as.matrix(my_data[, predictor_cols])
X_all_std <- sweep(X_all, 2, final_model$meanx, FUN = "-")
X_all_std <- sweep(X_all_std, 2, final_model$normx, FUN = "/")
X_all_sub <- X_all_std[, final_model$A, drop = FALSE]
latent_all <- X_all_sub %*% final_model$projection

num_latent <- ncol(latent_all)
colnames(latent_all) <- paste0("latent", seq_len(num_latent))

latent_df <- data.frame(
  cherry_year = my_data$cherry_year,
  location    = my_data$location,
  bloom_doy   = my_data$bloom_doy,
  latent_all
)

So our optimization left us with 3 latent factors. Not bad. Lets as LLMs like to say delve deeper. ### Performance of our Sparse PLS model I first assess the performance of our Sparse PLS model using training data. I compute key statistics—such as R², RMSE, and MAE—to gauge how well the model explains the variance in the bloom day (with a higher R² indicating a better fit).

# Predict on training data
y_pred_train <- predict(final_model, X_train)
SST <- sum((Y_train - mean(Y_train))^2)
SSE <- sum((Y_train - y_pred_train)^2)
R2_train <- 1 - SSE/SST

MAE_train <- mean(abs(Y_train - y_pred_train))
RMSE_train <- sqrt(mean((Y_train - y_pred_train)^2))
n_selected_vars <- length(final_model$A)
percent_vars_selected <- (n_selected_vars / length(predictor_cols)) * 100

# Diagnostic plot with unified styling
stats_text <- paste0(
  "R² = ", round(R2_train, 3), "\n",
  "RMSE = ", round(RMSE_train, 1), " days\n",
  "MAE = ", round(MAE_train, 1), " days\n",
  "Variables: ", n_selected_vars, "/", length(predictor_cols), 
  " (", round(percent_vars_selected, 0), "%)"
)

ggplot(data.frame(Actual = Y_train, Predicted = y_pred_train), aes(x = Actual, y = Predicted)) +
  geom_point(color = "#1f77b4", alpha = 0.6, size = 2.5) +
  geom_abline(intercept = 0, slope = 1, linetype = "dashed", color = "#d62728") +
  annotate("text", x = max(Y_train) - 5, y = min(y_pred_train) + 10, 
           label = stats_text, hjust = 1, vjust = 0, size = 4.2, color = "black") +
  labs(
    title = "Predicted vs Actual Bloom Day",
    x = "Actual Bloom DOY",
    y = "Predicted Bloom DOY"
  ) +
  theme_minimal(base_size = 13) +
  theme(
    plot.title = element_text(face = "bold"),
    legend.position = "right"
  )

Not so shabby! Now lets examine the latent factors:

Latent Factor Interpretation

# Parse the projection matrix from the SPLS model
proj_mat <- final_model$projection
# Each row name is in the form "temp_ave_pos_rollsum_123"
parsed <- str_match(rownames(proj_mat), "^(.*)_(\\d+)$")
group_names <- parsed[, 2]           # e.g., "temp_ave_pos_rollsum"
day_indices <- as.numeric(parsed[, 3])  # day number

# Create a data frame of loadings with associated group and day
df_proj <- as.data.frame(proj_mat)
df_proj$group <- group_names
df_proj$day   <- day_indices

# Rename factor columns for clarity
n_fac <- ncol(proj_mat)
colnames(df_proj)[1:n_fac] <- paste0("Factor", seq_len(n_fac))

# Pivot the data to long format: each row becomes (group, day, factor, loading)
df_long <- pivot_longer(df_proj, 
                        cols = starts_with("Factor"),
                        names_to = "factor",
                        values_to = "loading")

# Build a complete grid for all groups, days (1:366), and factors
all_groups <- c("temp_ave_pos_rollsum", "temp_ave_neg_rollsum", 
                "temp_max_pos_rollsum", "temp_max_neg_rollsum", 
                "temp_min_pos_rollsum", "temp_min_neg_rollsum", 
                "prcp_pos_rollsum", "prcp_neg_rollsum")
all_factors <- unique(df_long$factor)
grid_df <- expand.grid(group = all_groups, day = 1:366, factor = all_factors, 
                       stringsAsFactors = FALSE)

# Merge grid with loadings to include missing combinations as NA
df_plot <- left_join(grid_df, df_long, by = c("group", "day", "factor"))

# Convert day index to a date for plotting; day 1 corresponds to April 10
base_date <- as.Date("2020-04-10")
df_plot$date <- base_date + (df_plot$day - 1)

# Extract variable type and anomaly direction from group name
df_plot <- df_plot %>%
  mutate(
    type = gsub("_pos_rollsum.*|_neg_rollsum.*", "", group),
    anomaly = ifelse(grepl("_pos_", group), "pos", "neg")
  ) %>%
  mutate(type = factor(type, levels = c("temp_min", "temp_ave", "temp_max", "prcp")),
         anomaly = factor(anomaly, levels = c("pos", "neg")))

# Heatmap of latent factor loadings
ggplot(df_plot, aes(x = date, y = anomaly, fill = loading)) +
  geom_tile() +
  facet_grid(type ~ factor) +
  scale_x_date(date_breaks = "2 months", date_labels = "%b") +
  scale_fill_gradient2(
    low = "#313695", mid = "white", high = "#a50026", midpoint = 0,
    na.value = "grey90",
    labels = scales::label_number(accuracy = 0.0001)
  ) +
  labs(
    title = "Heatmap of SPLS Loadings by Factor and Variable Type",
    x = "Date (within cherry year)",
    y = "Anomaly Direction",
    fill = "Loading"
  ) +
  theme_minimal(base_size = 13) +
  theme(
    strip.text = element_text(face = "bold"),
    axis.text.x = element_text(angle = 45, hjust = 1),
    plot.title = element_text(face = "bold")
  )

These factors summarize the original rolling sum predictors, showing clear patterns. Negative temperature anomalies accumulated before the median bloom date load negatively; since these sums are negative, a larger accumulation of cold days actually delays blooming. In contrast, higher rolling sums of positive temperature anomalies—indicating warmer days—load negatively, which means that more warm days speed up the bloom. Additionally, the model captures a dormancy effect: a buildup of cold days in October and November tends to lead to an earlier bloom the following year. Similarly, lower-than-average precipitation starting in December is associated with earlier blooming. This interpretation confirms that the latent factors meaningfully reflect the influence of weather on cherry blossom timing.

Now let’s examine how these latent factors cluster by location.

# Cleaned and pivoted as before
latent_clean <- latent_df %>%
  pivot_longer(starts_with("latent"), names_to = "factor", values_to = "score") %>%
  filter(!is.na(bloom_doy), !is.na(score), is.finite(bloom_doy), is.finite(score))

ggplot(latent_clean, aes(x = bloom_doy, y = score, color = factor)) +
  geom_point(alpha = 0.6, size = 2, na.rm = TRUE) +
  geom_smooth(method = "lm", se = FALSE, linetype = "dashed", linewidth = 0.8, na.rm = TRUE) +
  
  # wrap long facet labels at ~12 characters
  facet_grid(
    location ~ factor,
    scales  = "free_y",
    switch  = "y",
    labeller = labeller(location = label_wrap_gen(width = 12))
  ) +
  
  scale_color_brewer(palette = "Set1") +
  labs(
    title = "Latent Factor Scores vs Bloom Day by Location",
    x     = "Bloom Day of Year",
    y     = "Latent Score",
    color = "Latent Factor"
  ) +
  theme_minimal(base_size = 13) +
  theme(
    # move the y-strips to the left side
    strip.placement        = "outside",
    # make left strip text horizontal and a bit smaller
    strip.text.y.left      = element_text(angle = 0, size = 10, face = "bold", margin = margin(r = 6)),
    # standard strip text for top
    strip.text             = element_text(face = "bold"),
    # tighten the panels
    panel.spacing          = unit(0.6, "lines"),
    # legend at bottom
    legend.position        = "bottom",
    # bold title
    plot.title             = element_text(face = "bold", hjust = 0.5)
  )

`geom_smooth()` using formula = 'y ~ x'

Even though each latent factor shows an almost linear relationship with bloom day, you can see that the fitted lines for different sites sit at slightly different levels (and in some cases have different slopes). Those location-specific shifts tell us that bloom–weather relationships aren’t identical everywhere—so in the next step we’ll fit a GAM with separate smooths for each site to capture those nuances.

Dynamic GAM Modeling for Forecasting

Dynamic GAM Modeling for Location-Specific Latent Factor Adaptation

I now have three powerful latent factors from our SPLS analysis that capture the main weather patterns driving cherry blossom variability. However, these factors were derived as linear predictors from data pooled across all five locations, assuming each site responds identically to the same weather patterns.

The problem: Real cherry trees don’t follow universal rules. Each location likely has its own unique sensitivity to weather - Kyoto’s cherry blossoms might respond differently to warming than Vancouver’s, and some locations have frustratingly sparse observations that make traditional modeling challenging.

The approach: So I decided to go with mvgam (Clark and Wells 2023). mvgam stands for MultiVariate (Dynamic) Generalized Additive Models and is specifically designed for time series analysis like ours:

Time series focus: Specifically designed for time series prediction with built-in capabilities to model autocorrelation if needed.
GAM flexibility: At its core, it’s still a GAM, making it ideal for bending our otherwise linear latent factors to each location individually.
State-space robustness: The state-space modeling framework is perfect for time series with missing observations. It models the underlying bloom process separately from the observations, so our sparse New York and Vancouver data doesn’t break the model—missing data areas handled by modeling the latent bloom process as it evolves through time.
Bayesian uncertainty: The Bayesian framework provides natural uncertainty quantification for both parameters and predictions.

Data preparation and model setup

First, I split my data into training and testing sets at 2024 to ensure at least one bloom date for each location in our forecast evaluation. For state-space modeling, I need both series (to identify different time series) and trend (for the process formula) variables.

My model structure uses shrinkage smooths (bs="sz") to handle the location-specific responses. For example, s(latent1, k=3) creates the main smooth effect of latent1, while s(trend, latent1, bs="sz", k=3) adds location-specific deviations. The “sz” basis applies shrinkage - locations with sparse data have their specific effects shrunk toward zero, essentially borrowing the response pattern from data-rich locations. Meanwhile, Kyoto and others with complete records can maintain their unique response curves.

Let’s prepare the data and fit the model:

df <- latent_df
df$location <- as.factor(df$location)
df$series <- df$location  # Keep series for identifying time series
df$trend <- df$location   # Add trend for trend_formula
df$time <- df$cherry_year - 1981 #For numerical stability

# Split data into training (<2024) and testing (>=2024)
train_mvgam <- df[df$cherry_year < 2024, ]
test_mvgam  <- df[df$cherry_year >= 2024, ]


# Now fit with tweaked priors
model_gaussian <- mvgam(formula = bloom_doy ~ series,
                     trend_formula = ~ s(latent1, k=3) + s(trend, latent1, bs="sz",k=3) +
                           s(latent2, k=3) + s(trend, latent2, bs="sz",k=3) +
                           s(latent3, k=3) + s(trend, latent3, bs="sz",k=3),
                     data = train_mvgam,
                     newdata = test_mvgam,
                     noncentred = TRUE,
                     family = gaussian(),silent = 2)

Let’s examine the model diagnostics:

summary(model_gaussian, include_betas = FALSE)

GAM observation formula:
bloom_doy ~ series

GAM process formula:
~s(latent1, k = 3) + s(trend, latent1, bs = "sz", k = 3) + s(latent2, 
    k = 3) + s(trend, latent2, bs = "sz", k = 3) + s(latent3, 
    k = 3) + s(trend, latent3, bs = "sz", k = 3)

Family:
gaussian

Link function:
identity

Trend model:
None

N process models:
5 

N series:
5 

N timepoints:
45 

Status:
Fitted using Stan 
4 chains, each with iter = 1000; warmup = 500; thin = 1 
Total post-warmup draws = 2000


Observation error parameter estimates:
             2.5%  50% 97.5% Rhat n_eff
sigma_obs[1] 0.98 2.30   3.1 1.08    50
sigma_obs[2] 2.50 3.50   4.6 1.02   209
sigma_obs[3] 5.70 8.30  14.0 1.00   996
sigma_obs[4] 0.16 0.95   5.2 1.00  1024
sigma_obs[5] 1.10 3.40   4.3 1.08    37

GAM observation model coefficient (beta) estimates:
                                   2.5%   50% 97.5% Rhat n_eff
(Intercept)                        89.0 94.00  99.0 1.00  1271
seriesLiestal-Weideli, Switzerland -5.0 -1.80   1.1 1.00  1047
seriesNew York, USA                -2.6  0.82   4.7 1.00  1492
seriesVancouver, Canada            -4.3 -1.30   1.4 1.00  1147
seriesWashington DC, USA           -5.6 -1.70   2.1 1.01   593

Process error parameter estimates:
           2.5%  50% 97.5% Rhat n_eff
sigma[1] 0.0069 0.48   2.1 1.07    54
sigma[2] 0.0170 0.41   2.3 1.02   156
sigma[3] 0.0150 0.34   1.9 1.00  1205
sigma[4] 0.0110 0.50   2.0 1.00   959
sigma[5] 0.0190 0.44   3.2 1.09    35

GAM process model coefficient (beta) estimates:
                  2.5%   50% 97.5% Rhat n_eff
(Intercept)_trend -5.1 0.016   4.8    1  1350

Approximate significance of GAM process smooths:
                   edf Ref.df  Chi.sq p-value    
s(latent1)        1.03      2 4723.06 < 2e-16 ***
s(series,latent1) 7.18     12  132.36    0.37    
s(latent2)        1.02      2  640.80 < 2e-16 ***
s(series,latent2) 3.75     12    2.03    1.00    
s(latent3)        0.99      2  326.97 7.1e-06 ***
s(series,latent3) 1.22     12    2.26    1.00    
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Stan MCMC diagnostics:
✔ No issues with effective samples per iteration
✖ Rhats above 1.05 found for some parameters
    Use pairs() and mcmc_plot() to investigate
✖ 132 of 2000 iterations ended with a divergence (6.6%)
    Try a larger adapt_delta to remove divergences
✔ No issues with maximum tree depth

Samples were drawn using sampling(hmc). For each parameter, n_eff is a
  crude measure of effective sample size, and Rhat is the potential scale
  reduction factor on split MCMC chains (at convergence, Rhat = 1)

Use how_to_cite() to get started describing this model

The model shows severe convergence issues. Several variance parameters (sigmas) from both the observation and process models are poorly identified, with terrible effective sample sizes and Rhat values. Let me unpack what’s happening here. In our state-space formulation:

The baseline: Without weather effects, each location would bloom on roughly the same day every year (captured by the location intercepts) The process model: Our SPLS-derived latent factors predict deviations from this baseline. The process error represents additional year-to-year variation not captured by weather - perhaps soil conditions, tree age, or other unmeasured factors The observation model: This is where bloom dates actually get recorded. The observation error represents how much our weather-based predictions miss the true bloom dates

The identifiability crisis occurs because the model can explain the same bloom variability in multiple ways. High process error + low observation error? Low process error + high observation error? Without constraints, the model can’t decide. Here’s the key insight: Our SPLS model achieved good R² and MAE when fitted on pooled data from all locations. This means it captures the “average” weather-bloom relationship well, but likely misses location-specific nuances by roughly the same amount everywhere. The observation error is essentially quantifying “how wrong is our one-size-fits-all weather model?” By setting share_obs_params = TRUE, I enforce this logic: all locations share the same observation variance because they all use the same pooled SPLS model. This constraint breaks the identifiability problem while still allowing location-specific process errors to capture unique temporal patterns. Additionally, with 19% of iterations ending in divergences, I’ll increase adapt_delta to 0.99, max_treedepth to 12, and number of iterations for more careful exploration of the posterior:

model_shared_sz <- mvgam(formula = bloom_doy ~ series,
                       trend_formula = ~ s(latent1, k=3) + s(trend, latent1, bs="sz",k=3) +
                           s(latent2, k=3) + s(trend, latent2, bs="sz",k=3) +
                           s(latent3, k=3) + s(trend, latent3, bs="sz",k=3),
                     data = train_mvgam,
                     newdata = test_mvgam,
                     share_obs_params = TRUE,
                     noncentred = TRUE,
                     control = list(adapt_delta = 0.99, max_treedepth = 12),
                     burnin = 500,
                     samples = 2000,
                     family = gaussian(),silent = 2)

summary(model_shared_sz, include_betas = FALSE)

GAM observation formula:
bloom_doy ~ series

GAM process formula:
~s(latent1, k = 3) + s(trend, latent1, bs = "sz", k = 3) + s(latent2, 
    k = 3) + s(trend, latent2, bs = "sz", k = 3) + s(latent3, 
    k = 3) + s(trend, latent3, bs = "sz", k = 3)

Family:
gaussian

Link function:
identity

Trend model:
None

N process models:
5 

N series:
5 

N timepoints:
45 

Status:
Fitted using Stan 
4 chains, each with iter = 2500; warmup = 500; thin = 1 
Total post-warmup draws = 8000


Observation error parameter estimates:
          2.5% 50% 97.5% Rhat n_eff
sigma_obs  2.7 3.2   3.7    1  2401

GAM observation model coefficient (beta) estimates:
                                   2.5%   50% 97.5% Rhat n_eff
(Intercept)                        89.0 94.00  99.0    1  3503
seriesLiestal-Weideli, Switzerland -5.1 -1.60   1.6    1  4643
seriesNew York, USA                -2.4  0.81   4.5    1  4682
seriesVancouver, Canada            -4.8 -0.85   2.6    1  9138
seriesWashington DC, USA           -5.7 -1.30   2.5    1  4568

Process error parameter estimates:
          2.5%  50% 97.5% Rhat n_eff
sigma[1] 0.012 0.26   1.1    1  7048
sigma[2] 0.016 0.47   2.2    1  2022
sigma[3] 2.100 4.50   6.8    1  2254
sigma[4] 0.013 0.34   1.8    1 11527
sigma[5] 0.016 0.44   2.0    1  2386

GAM process model coefficient (beta) estimates:
                  2.5%    50% 97.5% Rhat n_eff
(Intercept)_trend -5.1 -0.036   5.1    1  3722

Approximate significance of GAM process smooths:
                   edf Ref.df  Chi.sq p-value    
s(latent1)        1.01      2 4085.94 < 2e-16 ***
s(series,latent1) 7.64     12  239.55    0.18    
s(latent2)        1.09      2  655.87 < 2e-16 ***
s(series,latent2) 1.97     12    2.81    1.00    
s(latent3)        1.01      2  305.76 1.7e-05 ***
s(series,latent3) 2.12     12    1.27    1.00    
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Stan MCMC diagnostics:
✔ No issues with effective samples per iteration
✔ Rhat looks good for all parameters
✔ No issues with divergences
✔ No issues with maximum tree depth

Samples were drawn using sampling(hmc). For each parameter, n_eff is a
  crude measure of effective sample size, and Rhat is the potential scale
  reduction factor on split MCMC chains (at convergence, Rhat = 1)

Use how_to_cite() to get started describing this model

gratia::draw(model_shared_sz, trend_effects=TRUE)

The enhanced sampling and shared observation parameters completely fixed our convergence issues. All parameters now have excellent effective sample sizes and Rhat values of 1.00. The shared observation error settled at about 3.2 days (pretty much as MAE of joint SPLS model) - this represents how much our weather-based predictions typically miss the actual bloom dates. Looking at the smooth effects, the main patterns are beautifully linear, exactly as expected from our SPLS-derived factors. Each latent factor shows a strong linear relationship with bloom timing (all p < 0.001). The location-specific deviations (s(series,latent) terms) aren’t statistically significant, which isn’t surprising given our limited data. However, they still capture subtle location-specific responses that contribute to more accurate predictions. Lets look at series themselves:

plot(model_shared_sz, type="forecast",trend_effects = TRUE,series=1)

Out of sample CRPS:
0.817677993584371

plot(model_shared_sz, type="forecast",trend_effects = TRUE,series=2)

Out of sample CRPS:
3.94968940550937

plot(model_shared_sz, type="forecast",trend_effects = TRUE,series=3)

Out of sample CRPS:
1.3673925550625

plot(model_shared_sz, type="forecast",trend_effects = TRUE,series=4)

Out of sample CRPS:
5.40008450334061

plot(model_shared_sz, type="forecast",trend_effects = TRUE,series=5)

Out of sample CRPS:
2.59631972186406

Pretty groowy. So lets now run predictions for 2025 and compare with real data.

# Forecast
fc <- forecast(model_shared_sz, test_mvgam)

# Map full location names to short names for predictions
location_mapping <- c(
  "Kyoto, Japan"                = "kyoto",
  "Liestal-Weideli, Switzerland" = "liestal",
  "New York, USA"               = "newyorkcity",
  "Vancouver, Canada"           = "vancouver",
  "Washington DC, USA"          = "washingtondc"
)

# Create dataframe with actual 2025 bloom dates
actual_2025 <- data.frame(
  location = c("liestal", "vancouver", "kyoto", "washingtondc", "newyorkcity"),
  actual_date = as.Date(c("2025-03-27", "2025-04-03", "2025-04-04", "2025-03-28", "2025-04-04")),
  actual_doy = c(86, 93, 94, 87, 94),
  stringsAsFactors = FALSE
)

# Extract posterior draws for all locations
posterior_draws <- list()
for (i in seq_along(fc$series_names)) {
  full_name <- as.character(fc$series_names[i])
  short_name <- location_mapping[full_name]
  posterior_draws[[short_name]] <- fc$forecasts[[i]][, 2]  # 2025 predictions
}

# Convert to long format for plotting
draws_df <- data.frame(
  value = unlist(posterior_draws),
  location = rep(names(posterior_draws), each = length(posterior_draws[[1]]))
)

# Add actual values
draws_df <- merge(draws_df, actual_2025[, c("location", "actual_doy")], by = "location", all.x = TRUE)

# Add proper location names
draws_df$location_full <- factor(draws_df$location, 
  levels = c("kyoto", "liestal", "newyorkcity", "vancouver", "washingtondc"),
  labels = c("Kyoto, Japan", 
             "Liestal, Switzerland", 
             "New York City, USA", 
             "Vancouver, Canada", 
             "Washington DC, USA"))

# Calculate summary statistics with rounded differences
summary_stats <- draws_df %>%
  group_by(location_full, actual_doy) %>%
  summarise(
    median_pred = median(value),
    mean_pred = mean(value),
    .groups = 'drop'
  ) %>%
  mutate(
    diff = round(median_pred - actual_doy, 0),
    diff_text = case_when(
      diff > 0 ~ paste0("+", diff, " days"),
      diff < 0 ~ paste0(diff, " days"),
      TRUE ~ "Perfect!"
    )
  )

# Create the plot
# Define a unified fill palette (you can swap in your custom hexes if you prefer)
palette5 <- RColorBrewer::brewer.pal(5, "Set1")

# Clean data if needed (optional defensive step)
draws_df_clean <- draws_df %>% filter(is.finite(value))
summary_stats_clean <- summary_stats %>% filter(is.finite(actual_doy))

p_presentation <- ggplot() +
  # Density curves
  geom_density(
    data    = draws_df_clean,
    aes(x = value, fill = location_full),
    alpha   = 0.8,
    color   = "white",
    linewidth = 0.5,
    na.rm   = TRUE
  ) +
  # Vertical line at actual bloom date
  geom_segment(
    data = summary_stats_clean,
    aes(x = actual_doy, xend = actual_doy, y = 0, yend = Inf),
    color    = "black",
    linewidth = 1.2
  ) +
  # Label with error text
  geom_label(
    data = summary_stats_clean,
    aes(x = actual_doy + 2, y = Inf, label = ifelse(diff == 0, "Spot on!", diff_text)),
    vjust         = 1.5,
    size          = 3.2,
    fontface      = "bold",
    fill          = "white",
    alpha         = 0.9,
    label.padding = unit(0.2, "lines"),
    label.size    = 0.25,
    na.rm         = TRUE
  ) +
  # Facet by location
  facet_wrap(~ location_full, scales = "free_y", nrow = 1) +
  # Unified fill palette
  scale_fill_manual(values = palette5) +
  # X axis limits and breaks
  coord_cartesian(xlim = c(78, 112)) +
  scale_x_continuous(breaks = seq(80, 110, by = 10)) +
  # Labels
  labs(
    title = "2025 Cherry Blossom Predictions vs Reality",
    x     = "Day of Year\n(vertical line = actual bloom date)",
    y     = NULL
  ) +
  # Unified theme
  theme_minimal(base_size = 13) +
  theme(
    plot.title       = element_text(face = "bold", size = 16, hjust = 0.5),
    strip.text       = element_text(face = "bold", size = 11),
    axis.text.x      = element_text(size = 9),
    axis.text.y      = element_blank(),
    axis.ticks.y     = element_blank(),
    panel.grid.major = element_line(color = "grey85", size = 0.3),
    panel.grid.minor = element_blank(),
    panel.spacing    = unit(0.6, "lines"),
    legend.position  = "none",
    plot.margin      = margin(12, 12, 12, 12)
  )

Warning: The `size` argument of `element_line()` is deprecated as of ggplot2 3.4.0.
ℹ Please use the `linewidth` argument instead.

print(p_presentation)

Two perfect predictions (Kyoto and Vancouver), and the rest within a week - not bad for a model predicting a complex biological phenomenon months in advance. What started as a challenge to predict cherry blossoms using weather anomalies has demonstrated the power of combining dimensional reduction (SPLS) with flexible modeling (mvgam). The approach successfully handled the twin challenges of high-dimensional weather data and sparse observations, delivering predictions with well-calibrated uncertainty. Most satisfying is that the locations with the least data (New York and Vancouver) performed just as well as data-rich sites - proof that our shrinkage approach effectively borrowed strength across locations. Cherry trees may not follow universal rules, but with the right modeling framework, I can still capture their unique responses to weather patterns

We used R version 4.5.1 (R Core Team 2025) and the following R packages: data.table v. 1.17.8 (Barrett et al. 2025), gratia v. 0.10.0 (Simpson 2024), missForest v. 1.5 (Stekhoven and Buehlmann 2012; Stekhoven 2022), mvgam v. 1.1.51 (Clark and Wells 2023), nasapower v. 4.2.5 (Sparks 2018), RColorBrewer v. 1.1.3 (Neuwirth 2022), rmarkdown v. 2.29 (Xie, Allaire, and Grolemund 2018; Xie, Dervieux, and Riederer 2020; Allaire et al. 2024), scales v. 1.4.0 (Wickham, Pedersen, and Seidel 2025), spls v. 2.3.2 (Chung, Chun, and Keles 2025), tidyverse v. 2.0.0 (Wickham et al. 2019).

References

Allaire, JJ, Yihui Xie, Christophe Dervieux, Jonathan McPherson, Javier Luraschi, Kevin Ushey, Aron Atkins, et al. 2024. rmarkdown: Dynamic Documents for r. https://github.com/rstudio/rmarkdown.

Barrett, Tyson, Matt Dowle, Arun Srinivasan, Jan Gorecki, Michael Chirico, Toby Hocking, Benjamin Schwendinger, and Ivan Krylov. 2025. data.table: Extension of “data.frame”. https://doi.org/10.32614/CRAN.package.data.table.

Chung, Dongjun, Hyonho Chun, and Sunduz Keles. 2025. spls: Sparse Partial Least Squares (SPLS) Regression and Classification. https://doi.org/10.32614/CRAN.package.spls.

Clark, Nicholas J, and Konstans Wells. 2023. “Dynamic Generalized Additive Models (DGAMs) for Forecasting Discrete Ecological Time Series.” Methods in Ecology and Evolution 14: 771–84. https://doi.org/10.18637/jss.v100.i05.

Neuwirth, Erich. 2022. RColorBrewer: ColorBrewer Palettes. https://doi.org/10.32614/CRAN.package.RColorBrewer.

R Core Team. 2025. R: A Language and Environment for Statistical Computing. Vienna, Austria: R Foundation for Statistical Computing. https://www.R-project.org/.

Simpson, Gavin L. 2024. gratia: Graceful ggplot-Based Graphics and Other Functions for GAMs Fitted Using mgcv. https://gavinsimpson.github.io/gratia/.

Sparks, Adam H. 2018. “nasapower: A NASA POWER Global Meteorology, Surface Solar Energy and Climatology Data Client for r.” The Journal of Open Source Software 3 (30): 1035. https://doi.org/10.21105/joss.01035.

Stekhoven, Daniel J. 2022. missForest: Nonparametric Missing Value Imputation Using Random Forest.

Stekhoven, Daniel J., and Peter Buehlmann. 2012. “MissForest - Non-Parametric Missing Value Imputation for Mixed-Type Data.” Bioinformatics 28 (1): 112–18.

Wickham, Hadley, Thomas Lin Pedersen, and Dana Seidel. 2025. scales: Scale Functions for Visualization. https://doi.org/10.32614/CRAN.package.scales.

Xie, Yihui, J. J. Allaire, and Garrett Grolemund. 2018. R Markdown: The Definitive Guide. Boca Raton, Florida: Chapman; Hall/CRC. https://bookdown.org/yihui/rmarkdown.

Xie, Yihui, Christophe Dervieux, and Emily Riederer. 2020. R Markdown Cookbook. Boca Raton, Florida: Chapman; Hall/CRC. https://bookdown.org/yihui/rmarkdown-cookbook.

Swimming speed Analysis With Generalized Additive Models

Julius Bogomolovas — Mon, 23 Jun 2025 07:00:00 GMT

As a swimmer seeking to enhance performance, tracking workout data can offer valuable insights into progress over time. Analysis options for swimming compared to running in Garmin are instead week. I enjoy swimming and data analysis. In this analysis, I’ll explore several years of swimming data extracted from Garmin FIT files to figure out if I am getting faster.

Data Extraction from FIT Files

First, I’ll extract swimming data from all available FIT files. The FITfileR (Smith 2025) package allows us to read Garmin workout files and identify pool swimming sessions.

library(FITfileR)
library(dplyr)
library(purrr)
library(utils)
library(ggplot2)
library(hexbin)
library(viridis)
library(gratia)
library(mgcv)
library(tidyr)
library(performance)
library(lubridate)

Identifying Pool Swimming Sessions

So, one can ask Garmin to download all the files. Swim session or activity files are stored in .fit format and located in the DI_CONNECT folder, specifically in the subfolder DI-Connect-Uploaded-Files. File names are rather cryptical, so I first look for files that have “lap_swimming” attribute within.

# Scan directory for all .fit files
all_files <- list.files("/Users/jb/Documents/BW_analysis/Swim",
                        pattern    = "\\.fit$",
                        full.names = TRUE)

# Check each file to identify pool swimming sessions
n  <- length(all_files)
ok <- logical(n)
pb <- txtProgressBar(min = 0, max = n, style = 3)

for (i in seq_along(all_files)) {
  path <- all_files[i]
  # Safely check if file contains pool swimming data
  ok[i] <- possibly(function(p) {
    sp <- getMessagesByType(readFitFile(p), "sport")
    isTRUE(any(sp$sport == "swimming" & sp$sub_sport == "lap_swimming",
               na.rm = TRUE))
  }, otherwise = FALSE)(path)
  setTxtProgressBar(pb, i)
}

close(pb)

pool_lap_fits <- all_files[ok]
cat("\nFound", length(pool_lap_fits), "pool-lap swim files\n")

Extracting Session Information

Now, by examining several lap_swimming attributes containing files, I found that pool length in meters and activity data are stored in session, and length contains the workout information.

sessions <- map_dfr(pool_lap_fits, function(f) {
  sess <- tryCatch(getMessagesByType(readFitFile(f), "session"),
                   error = function(e) NULL)
  if (is.null(sess)) return(NULL)
  tibble(
    file          = f,
    session_date  = as.Date(sess$start_time),
    pool_length   = sess$pool_length
  )
}) %>%
  group_by(session_date) %>%
  mutate(session_number = row_number()) %>%
  ungroup()

# Extract individual length (lap) data
raw_laps <- map_dfr(pool_lap_fits, function(f) {
  lengths <- tryCatch(getMessagesByType(readFitFile(f), "length"),
                      error = function(e) NULL)
  if (is.null(lengths)) return(NULL)
  lengths %>% mutate(file = f)
})

Data Processing and Set Detection

Swimming workouts typically consist of multiple sets with rest periods between each set. I’ll identify these sets and calculate the relative positions of each lap within the workout and set itself:

#Identify sets based on idle periods
laps_with_sets <- raw_laps %>%
  group_by(file) %>%
  mutate(
    lap_index          = row_number(),
    total_laps         = n(),
    pos_within_workout = lap_index / total_laps,
    # New set starts after each idle period
    set_id             = cumsum(length_type == "idle") + 1
  ) %>%
  ungroup()

# Process active laps only and calculate set-specific metrics
final_tbl <- laps_with_sets %>%
  filter(length_type == "active", swim_stroke != "drill") %>%
  group_by(file, set_id) %>%
  mutate(
    lap_in_set     = row_number(),
    set_size       = n(),
    pos_within_set = lap_in_set / set_size
  ) %>%
  ungroup() %>%
  left_join(sessions, by = "file") %>%
  select(
    session_date,
    session_number,
    pool_length,
    total_elapsed_time,
    set_id,
    lap_index,
    lap_in_set,
    pos_within_workout,
    pos_within_set,
    swim_stroke
  )

# Save processed data
write.csv(final_tbl, "all_swim_laps.csv", row.names = FALSE)

You can load it directly in R:

final_tbl <- read.csv("https://jbogomolovas2.github.io/julius-blog/posts/post-with-code/all_swim_laps.csv")

I’ll identify gaps in training and analyze data from July 2020 onward to have a nice, recent, and consistent training segment to analyze.

# Identify training gaps
sessions_df <- final_tbl %>%
  distinct(session_date) %>%
  arrange(session_date)

gaps_df <- sessions_df %>%
  # 1) make sure session_date is a Date
  mutate(session_date = as.Date(session_date)) %>%
  # 2) grab the “previous” date
  mutate(prev_date = lag(session_date)) %>%
  # 3) compute gap in days
  mutate(gap_days = as.numeric(difftime(session_date, prev_date, units = "days"))) %>%
  # 4) drop the first row (where lag was NA)
  filter(!is.na(gap_days))

# Show top 5 largest training gaps
top5_gaps <- gaps_df %>%
  arrange(desc(gap_days)) %>%
  slice(1:5) %>%
  rename(
    end_date   = session_date,
    start_date = prev_date
  )

print(top5_gaps)

Let’s perform some data cleaning: select a segment, calculate swim speeds, remove super-fast laps (I wish they were real!), and create a simple time variable.

final_tbl_2020 <- final_tbl %>%
  # 1) ensure session_date is Date
  mutate(session_date = as.Date(session_date)) %>%
  
  # 2) filter from July 7, 2020 onward
  filter(session_date >= ymd("2020-07-07")) %>%
  
  # 3) compute speed and factor columns
  mutate(
    speed       = pool_length / total_elapsed_time,
    swim_stroke = factor(swim_stroke),
    session_id  = factor(session_date)   # or combine with session_number if you need uniqueness
  ) %>%
  
  # 4) remove unrealistically fast laps
  filter(speed < 2.5) %>%
  
  # 5) sort and compute days since first session
  arrange(session_date) %>%
  mutate(
    days_since_start = as.integer(
      difftime(session_date,
               min(session_date),
               units = "days")
    )
  )

Visualizing Speed Distributions

Let’s examine how swimming speed varies over time for different strokes. As I have a bunch of laps, let’s plot them as densities.

p_contour <- ggplot() +
  geom_point(data = final_tbl_2020, 
             aes(x = session_date, y = speed),
             alpha = 0.05, size = 0.5, color = "grey50") +
  geom_density_2d(data = final_tbl_2020, 
                  aes(x = session_date, y = speed),
                  color = "darkblue", bins = 10, linewidth = 0.5) +
  facet_wrap(~ swim_stroke, scales = "free_y", ncol = 2) +
  labs(x = "Session Date",
       y = "Speed (m/s)",
       title = "Swimming Speed Over Time by Stroke Type",
       subtitle = "Density contours showing speed distribution") +
  theme_minimal() +
  theme(legend.position = "none",
        panel.grid.minor = element_blank(),
        strip.text = element_text(size = 12, face = "bold"))

print(p_contour)

Statistical Modeling with GAMs

I have something that is more or less monomodal. Therefore, my average swim speed would be a good indicator of my progress. However, in workouts, I do different sets, such as sprints, cooldowns, etc. Which vary in intensity, length, and position within the workout. I hypothesize that these factors significantly affect “average” swim speed and need to be accounted for. I don’t expect them to be linearly related, so I enter the magical world of Generalized Additive Models (GAMs). I will be using mgcv (Wood 2011) for fitting, gratia (Simpson 2024) for visualization, and performance (Lüdecke et al. 2021) for model assessment. I will start with a simple speed ~ time model and try to add covariates to get a better fit, closer to “average” swim speed. As I am working with a rather large dataset, I will use the bam function and a few corresponding tweaks: discrete = TRUE and method = "fREML" which enables faster computation for extensive datasets. By examining the swimming speed distribution, I clearly see some tails, so I will use the scaled t-distribution family = scat().

# Model 1: Simple time trend by stroke
simple <- bam(
    speed ~ swim_stroke + pool_length + 
            s(days_since_start, by = swim_stroke, bs = "gp"),
    data     = final_tbl_2020,
    discrete = TRUE,
    family   = scat(),  # Scaled t-distribution for robustness
    method   = "fREML"
)

# Model 2: Add position effects (fatigue within workout/set)
set_location <- bam(
    speed ~ swim_stroke + pool_length + 
            s(days_since_start, by = swim_stroke, bs = "gp") + 
            s(pos_within_workout, by = swim_stroke) +
            s(pos_within_set, by = swim_stroke),
    data     = final_tbl_2020,
    discrete = TRUE,
    family   = scat(),
    method   = "fREML"
)

# Model 3: Add session random effects
set_location_re <- bam(
    speed ~ swim_stroke + pool_length + 
            s(days_since_start, by = swim_stroke, bs = "gp") +
            s(pos_within_workout, by = swim_stroke) +
            s(pos_within_set, by = swim_stroke) +
            s(session_id, bs = "re"),  # Random effect for sessions
    data     = final_tbl_2020,
    discrete = TRUE,
    family   = scat(),
    method   = "fREML"
)

# Compare model performance
model_comparison <- compare_performance(simple, set_location, set_location_re)
print(model_comparison)

# Comparison of Model Performance Indices

Name            | Model |    AIC (weights) |   AICc (weights)
-------------------------------------------------------------
simple          |   bam | -60982.5 (<.001) | -60982.4 (<.001)
set_location    |   bam | -78903.1 (<.001) | -78902.5 (<.001)
set_location_re |   bam | -81777.9 (>.999) | -81765.5 (>.999)

Name            |    BIC (weights) |    R2 |  RMSE | Sigma
----------------------------------------------------------
simple          | -60631.1 (<.001) | 0.204 | 0.123 | 1.000
set_location    | -78017.1 (>.999) | 0.449 | 0.101 | 1.000
set_location_re | -77560.3 (<.001) | 0.475 | 0.099 | 1.000

model_summary<- summary(set_location_re)
print(model_summary)


Family: Scaled t(3.729,0.064) 
Link function: identity 

Formula:
speed ~ swim_stroke + pool_length + s(days_since_start, by = swim_stroke, 
    bs = "gp") + s(pos_within_workout, by = swim_stroke) + s(pos_within_set, 
    by = swim_stroke) + s(session_id, bs = "re")

Parametric coefficients:
                          Estimate Std. Error t value Pr(>|t|)    
(Intercept)              0.8914292  0.0049522  180.01   <2e-16 ***
swim_strokebreaststroke  0.0613416  0.0052787   11.62   <2e-16 ***
swim_strokebutterfly     0.2525302  0.0047424   53.25   <2e-16 ***
swim_strokefreestyle     0.2141422  0.0031635   67.69   <2e-16 ***
pool_length             -0.0017971  0.0001487  -12.09   <2e-16 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

Approximate significance of smooth terms:
                                                  edf  Ref.df        F  p-value
s(days_since_start):swim_strokebackstroke       6.088   6.963    7.448  < 2e-16
s(days_since_start):swim_strokebreaststroke     5.747   6.583    4.031 0.000274
s(days_since_start):swim_strokebutterfly        7.962   8.641    7.520  < 2e-16
s(days_since_start):swim_strokefreestyle        8.047   8.390    7.933  < 2e-16
s(pos_within_workout):swim_strokebackstroke     2.495   3.100    4.059 0.006375
s(pos_within_workout):swim_strokebreaststroke   7.311   8.292   20.984  < 2e-16
s(pos_within_workout):swim_strokebutterfly      6.725   7.816   12.175  < 2e-16
s(pos_within_workout):swim_strokefreestyle      8.375   8.888  312.136  < 2e-16
s(pos_within_set):swim_strokebackstroke         8.232   8.778  163.531  < 2e-16
s(pos_within_set):swim_strokebreaststroke       8.347   8.804  514.321  < 2e-16
s(pos_within_set):swim_strokebutterfly          8.474   8.888  500.872  < 2e-16
s(pos_within_set):swim_strokefreestyle          8.838   8.990 1051.382  < 2e-16
s(session_id)                                 390.899 449.000    8.486  < 2e-16
                                                 
s(days_since_start):swim_strokebackstroke     ***
s(days_since_start):swim_strokebreaststroke   ***
s(days_since_start):swim_strokebutterfly      ***
s(days_since_start):swim_strokefreestyle      ***
s(pos_within_workout):swim_strokebackstroke   ** 
s(pos_within_workout):swim_strokebreaststroke ***
s(pos_within_workout):swim_strokebutterfly    ***
s(pos_within_workout):swim_strokefreestyle    ***
s(pos_within_set):swim_strokebackstroke       ***
s(pos_within_set):swim_strokebreaststroke     ***
s(pos_within_set):swim_strokebutterfly        ***
s(pos_within_set):swim_strokefreestyle        ***
s(session_id)                                 ***
---
Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1

R-sq.(adj) =  0.475   Deviance explained = 42.7%
fREML =  65732  Scale est. = 1         n = 39572

appraise(set_location_re)

Based on model comparison, the most complex one seems to be doing the best. Some sanity check: indeed, backstroke is my slowest stroke, whereas butterfly is the fastest, and swimming in a 50 m pool vs. a 25-yard pool slows me a bit. In terms of fixed effects, the model effectively captured them. Smooth terms revealed significant nonlinear trends over time for all strokes, even when accounted for lap temporal position and session as a random factor. So let’s have a look.

gratia::draw(set_location_re,select=1:4 )

I am getting faster with my strokes, but I am plateauing with my freestyle. Let’s create predictions from our best model and overlay them on the actual data:

# Create prediction dataset
pred_data <- expand.grid(
  days_since_start = seq(min(final_tbl_2020$days_since_start), 
                        max(final_tbl_2020$days_since_start), 
                        length.out = 200),
  swim_stroke = levels(final_tbl_2020$swim_stroke),
  stringsAsFactors = FALSE
)

# Set other variables to median/reference values
pred_data$pool_length <- min(final_tbl_2020$pool_length) #most of my workouts are in 25 yards
pred_data$pos_within_workout <- median(final_tbl_2020$pos_within_workout)
pred_data$pos_within_set <- median(final_tbl_2020$pos_within_set)
pred_data$session_id <- levels(final_tbl_2020$session_id)[1]

# Generate predictions (excluding random effects)
predictions <- predict(set_location_re, 
                      newdata = pred_data, 
                      exclude = "s(session_id)",
                      se.fit = TRUE)

pred_data$fit <- predictions$fit
pred_data$se <- predictions$se.fit
# Validation plot
p_validation <- ggplot() +
  # Scatter with very low alpha for context
  geom_point(data = final_tbl_2020, 
             aes(x = days_since_start, y = speed),
             alpha = 0.05, size = 0.5, color = "grey50") +
  # 2D density contour lines
  geom_density_2d(data = final_tbl_2020, 
                  aes(x = days_since_start, y = speed),
                  color = "darkblue", bins = 10, size = 0.5) +
  # Model smooth lines only - no CI
  geom_line(data = pred_data,
            aes(x = days_since_start, y = fit),
            color = "red", size = 1.5) +
  # Facet by stroke type
  facet_wrap(~ swim_stroke, scales = "free_y", ncol = 2) +
  # Labels and theme
  labs(x = "Days Since Start",
       y = "Speed (m/s)",
       title = "Swimming Speed Over Time by Stroke Type",
       subtitle = "Density contours with GAM smooth curves") +
  theme_minimal() +
  theme(legend.position = "none",
        panel.grid.minor = element_blank(),
        strip.text = element_text(size = 12, face = "bold"))

Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
ℹ Please use `linewidth` instead.

print(p_validation)

Although structured test sets would be ideal for tracking progress, even this messy lap-level data can already provide some insights. Overall, the model indicates that my backstroke, breaststroke, and butterfly are improving (which I have noticed myself), while freestyle still lags behind. Extending the analysis to quartiles or deciles of lap speeds should provide a more comprehensive picture of training progress and pacing strategies.

References

Lüdecke, Daniel, Mattan S. Ben-Shachar, Indrajeet Patil, Philip Waggoner, and Dominique Makowski. 2021. “Performance: An r Package for Assessment, Comparison and Testing of Statistical Models” 6: 3139. https://doi.org/10.21105/joss.03139.

Simpson, Gavin L. 2024. “Gratia: Graceful Ggplot-Based Graphics and Other Functions for GAMs Fitted Using Mgcv.” https://gavinsimpson.github.io/gratia/.

Smith, Mike. 2025. “FITfileR: Read FIT Files Using Only Native r Code.” https://github.com/grimbough/FITfileR.git.

Wood, S. N. 2011. “Fast Stable Restricted Maximum Likelihood and Marginal Likelihood Estimation of Semiparametric Generalized Linear Models” 73. https://doi.org/10.1111/j.1467-9868.2010.00749.x.