Media Inflation Projection

Libraries

library(tidyverse)
library(kableExtra)

Dataset

## ---- helpers --------------------------------------------------------
big <- function(x, mark = ".") ifelse(is.na(x), "–", formatC(x, format = "d", big.mark = mark))
chg <- function(x, d = 1) ifelse(is.na(x), "–", sprintf(paste0("%+.", d, "f%%"), x * 100))

sty <- function(x, cap, align)
  kbl(x, caption = cap, align = align, row.names = FALSE, booktabs = TRUE) |>
    kable_styling(full_width        = FALSE, position = "left",
                  bootstrap_options = c("striped", "hover", "condensed"),
                  latex_options     = c("striped", "hold_position")) |>
    column_spec(1, bold = TRUE)

## ---- data -----------------------------------------------------------
media_rates <- data.frame(
  channel = c("TV", "Print", "OOH", "Digital", "Social"),
  `2023`  = c(44350, 36420171, 59390260, 2341, 3986),
  `2024`  = c(45767, 37972992, 61251834, 2600, 3682),
  `2025`  = c(46519, 34194301, 59104413, 2990, 5003),
  `2026`  = c(50832,  3310887, 58615144, 3640, 4897),
  check.names = FALSE, stringsAsFactors = FALSE
)

yrs <- c("2023", "2024", "2025", "2026")

## ---- table ----------------------------------------------------------
data.frame(Channel = media_rates$channel,
           lapply(media_rates[yrs], big),
           check.names = FALSE, stringsAsFactors = FALSE) |>
  sty("Media rate card, 2023–2026 (Rp)", c("l", rep("r", 4))) |>
  column_spec(2:5, width = "7em", monospace = TRUE)

Media rate card, 2023–2026 (Rp)

Channel	2023	2024	2025	2026
TV	44.350	45.767	46.519	50.832
Print	36.420.171	37.972.992	34.194.301	3.310.887
OOH	59.390.260	61.251.834	59.104.413	58.615.144
Digital	2.341	2.600	2.990	3.640
Social	3.986	3.682	5.003	4.897

Data Visualization

## ---- long format ----------------------------------------------------
rates_long <- media_rates |>
  pivot_longer(-channel, names_to = "year", values_to = "rate") |>
  mutate(year    = as.integer(year),
         channel = factor(channel, levels = media_rates$channel))

## ---- shared plot layers ---------------------------------------------
obs <- list(geom_line(colour = "#2c6fbb", linewidth = 0.8),
            geom_point(colour = "#2c6fbb", size = 2))

facet_y <- function(expand = expansion(mult = c(0.05, 0.05)))
  list(facet_wrap(~ channel, nrow = 2, scales = "free_y"),
       scale_y_continuous(
         labels = scales::label_number(scale_cut = scales::cut_short_scale()),
         expand = expand),
       theme_minimal(base_size = 11),
       theme(panel.grid.minor = element_blank(),
             strip.text       = element_text(face = "bold")))

ggplot(rates_long, aes(year, rate)) +
  obs +
  scale_x_continuous(breaks = 2023:2026) +
  facet_y(expansion(mult = c(0.18, 0.18))) +
  labs(title = "Media rate card by channel, 2023–2026", x = NULL, y = "Rate (Rp)")

Regression Model

Regression with trend

h         <- 2027                                  # projection horizon
pred_grid <- tibble(year = seq(2023, h, by = 0.05))

fmt      <- scales::label_number(scale_cut = scales::cut_short_scale(), accuracy = 0.1)
num_full <- function(x, d = 15)
  vapply(x, function(z) format(z, digits = d, scientific = FALSE, trim = TRUE),
         character(1))

## ---- the model, defined once ----------------------------------------
fit_lm <- function(df) lm(rate ~ I(year - 2023), data = df)

fit_one <- function(df, newdata) {
  m  <- fit_lm(df)
  ci <- predict(m, newdata = newdata, interval = "confidence")
  pi <- predict(m, newdata = newdata, interval = "prediction")
  tibble(year   = newdata$year, fit = ci[, "fit"],
         ci_lwr = ci[, "lwr"], ci_upr = ci[, "upr"],
         pi_lwr = pi[, "lwr"], pi_upr = pi[, "upr"])
}

fits <- rates_long |>
  group_by(channel) |>
  group_modify(~ fit_one(.x, pred_grid)) |>
  ungroup()

models <- rates_long |>
  group_by(channel) |>
  group_modify(~ {
    m <- fit_lm(.x)
    tibble(b0 = coef(m)[[1]], b1 = coef(m)[[2]], r2 = summary(m)$r.squared)
  }) |>
  ungroup() |>
  mutate(sgn   = ifelse(b1 < 0, "\u2212", "+"),
         label = sprintf("\u0177 = %s %s %s\u00B7(year \u2212 2023)\nR\u00B2 = %.2f",
                         fmt(b0), sgn, fmt(abs(b1)), r2),
         eq    = sprintf("\u0177 = %s %s %s \u00B7 (year \u2212 2023)",
                         num_full(b0), sgn, num_full(abs(b1))))

## ---- CI/PI band layers ----------------------------------------------
bands <- function(d) list(
  geom_ribbon(data = d, aes(x = year, ymin = pi_lwr, ymax = pi_upr),
              inherit.aes = FALSE, fill = "#c0392b", alpha = 0.05),
  geom_ribbon(data = d, aes(x = year, ymin = ci_lwr, ymax = ci_upr),
              inherit.aes = FALSE, fill = "#c0392b", alpha = 0.12),
  geom_line(data = d, aes(x = year, y = fit), inherit.aes = FALSE,
            colour = "#c0392b", linewidth = 0.7, linetype = "22"))

ggplot(rates_long, aes(year, rate)) +
  bands(filter(fits, year <= 2026)) +
  obs +
  geom_text(data = models, aes(label = label), x = -Inf, y = Inf,
            hjust = -0.05, vjust = 1.25, size = 2.8, lineheight = 1.05,
            colour = "#c0392b", inherit.aes = FALSE) +
  scale_x_continuous(breaks = 2023:2026) +
  facet_y(expansion(mult = c(0.10, 0.40))) +
  labs(title    = "OLS fit with 95% confidence and prediction intervals",
       subtitle = "Dark band: mean response (CI) \u00B7 Light band: new observation (PI)",
       x = NULL, y = "Rate (Rp)")

models |>
  transmute(Channel = channel, Equation = eq) |>
  sty("Fitted model per channel (rate ~ year, n = 4)", c("l", "l")) |>
  column_spec(2, monospace = TRUE, extra_css = "white-space: nowrap;")

Fitted model per channel (rate ~ year, n = 4)

Channel	Equation
TV	ŷ = 43837.3 + 2019.8 · (year − 2023)
Print	ŷ = 43440569.2 − 10310654.3 · (year − 2023)
OOH	ŷ = 60261328.1 − 447276.899999999 · (year − 2023)
Digital	ŷ = 2249.7 + 428.7 · (year − 2023)
Social	ŷ = 3783.9 + 405.4 · (year − 2023)

Projection for year 2027

pred_h <- filter(fits, year == max(year))

ggplot(rates_long, aes(year, rate)) +
  geom_vline(xintercept = h - 0.5, linetype = "dotted", colour = "grey45") +
  bands(fits) +
  obs +
  geom_point(data = pred_h, aes(x = year, y = fit), inherit.aes = FALSE,
             shape = 21, size = 2.4, stroke = 0.9,
             colour = "#c0392b", fill = "white") +
  scale_x_continuous(breaks = 2023:h) +
  facet_y() +
  labs(title    = sprintf("Media rates with %d projection", h),
       subtitle = "Right of the dotted line is extrapolated \u00B7 hollow point = projection",
       x = NULL, y = "Rate (Rp)")

pred_h |>
  left_join(media_rates |> select(channel, last = `2026`), by = "channel") |>
  transmute(
    Channel  = channel,
    `2026`   = big(round(last)),
    `2027`   = big(round(fit)),
    Change   = chg(fit / last - 1),
    `95% CI` = sprintf("%s \u2013 %s", big(round(ci_lwr)), big(round(ci_upr))),
    `95% PI` = sprintf("%s \u2013 %s", big(round(pi_lwr)), big(round(pi_upr)))) |>
  sty("2027 projection from the linear trend (Rp)", c("l", rep("r", 5))) |>
  column_spec(2:4, monospace = TRUE)

2027 projection from the linear trend (Rp)

Channel	2026	2027	Change	95% CI	95% PI
TV	50.832	51.916	+2.1%	45.474 – 58.359	43.599 – 60.234
Print	3.310.887	2.197.952	-33.6%	-60.898.397 – 65.294.301	-79.259.084 – 83.654.988
OOH	58.615.144	58.472.220	-0.2%	52.031.762 – 64.912.679	50.157.625 – 66.786.816
Digital	3.640	3.964	+8.9%	3.228 – 4.701	3.014 – 4.915
Social	4.897	5.405	+10.4%	2.836 – 7.975	2.088 – 8.723