## ----include = FALSE----------------------------------------------------------
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>",
  fig.width = 6,
  fig.height = 3.5
)
set.seed(2024)
library(bridgr)

## ----simulation---------------------------------------------------------------
n_quarters <- 40
quarter_index <- rep(seq_len(n_quarters), each = 3)
slot <- rep(1:3, times = n_quarters)
monthly_time <- seq(
  as.Date("2010-01-01"),
  by = "month",
  length.out = n_quarters * 3
)
monthly_indicator <- dplyr::tibble(
  time = monthly_time,
  value = 15 + quarter_index * 0.35 +
    ifelse(slot == 1, 0.8 * sin(quarter_index / 2), 0) +
    ifelse(slot == 2, -0.6 * cos(quarter_index / 3), 0) +
    ifelse(slot == 3, 0.7 * sin(quarter_index / 4 + 0.3), 0)
)

quarter_time <- monthly_time[seq(1, length(monthly_time), by = 3)]
quarter_target <- dplyr::tibble(
  time = quarter_time,
  value = 0.5 +
    vapply(
      seq_along(quarter_time),
      function(i) {
        block <- monthly_indicator$value[((i - 1) * 3 + 1):(i * 3)]
        0.2 * block[[1]] + 0.6 * block[[2]] + 0.2 * block[[3]]
      },
      numeric(1)
    ) +
    rep(c(0.1, -0.05, 0.08, -0.02), length.out = length(quarter_time))
)

## ----deterministic------------------------------------------------------------
mean_model <- mf_model(
  target = quarter_target,
  indic = monthly_indicator,
  indic_predict = "last",
  indic_aggregators = "mean",
  h = 1
)

last_model <- mf_model(
  target = quarter_target,
  indic = monthly_indicator,
  indic_predict = "last",
  indic_aggregators = "last",
  h = 1
)

summary(mean_model)

## ----numeric-weights----------------------------------------------------------
fixed_model <- mf_model(
  target = quarter_target,
  indic = monthly_indicator,
  indic_predict = "last",
  indic_aggregators = list(c(0.1, 0.7, 0.2)),
  h = 1
)

stats::coef(fixed_model)

## ----unrestricted-------------------------------------------------------------
unrestricted_model <- mf_model(
  target = quarter_target,
  indic = monthly_indicator,
  indic_predict = "last",
  indic_aggregators = "unrestricted",
  h = 1
)

stats::coef(unrestricted_model)

## ----parametric---------------------------------------------------------------
expalmon_model <- mf_model(
  target = quarter_target,
  indic = monthly_indicator,
  indic_predict = "last",
  indic_aggregators = "expalmon",
  solver_options = list(seed = 123, n_starts = 1, maxiter = 100),
  h = 1
)

beta_model <- mf_model(
  target = quarter_target,
  indic = monthly_indicator,
  indic_predict = "last",
  indic_aggregators = "beta",
  solver_options = list(
    seed = 123,
    n_starts = 1,
    maxiter = 100,
    start_values = c(2, 2)
  ),
  h = 1
)

## ----weight-accessors---------------------------------------------------------
indicators(expalmon_model)
weights(expalmon_model, indicator = 1)
aggregation_parameters(expalmon_model, indicator = 1)

## ----weight-comparison--------------------------------------------------------
equal_weights <- rep(1 / 3, 3)
last_weights <- c(0, 0, 1)
true_weights <- c(0.2, 0.6, 0.2)

weights_df <- dplyr::bind_rows(
  dplyr::tibble(model = "mean",        month = 1:3, weight = equal_weights),
  dplyr::tibble(model = "last",        month = 1:3, weight = last_weights),
  dplyr::tibble(model = "true DGP",    month = 1:3, weight = true_weights),
  dplyr::tibble(model = "expalmon",    month = 1:3,
                weight = weights(expalmon_model, indicator = 1)),
  dplyr::tibble(model = "beta",        month = 1:3,
                weight = weights(beta_model, indicator = 1))
)

ggplot2::ggplot(
  weights_df,
  ggplot2::aes(x = .data$month, y = .data$weight, color = .data$model)
) +
  ggplot2::geom_line(linewidth = 0.8) +
  ggplot2::geom_point(size = 2) +
  ggplot2::scale_x_continuous(breaks = 1:3) +
  ggplot2::labs(
    title = "Within-quarter weight profiles",
    x = "Month within quarter",
    y = "Weight"
  ) +
  theme_bridgr()

## ----forecast-comparison------------------------------------------------------
forecasts_df <- dplyr::bind_rows(
  dplyr::tibble(model = "mean",
                forecast = as.numeric(forecast(mean_model)$mean)),
  dplyr::tibble(model = "last",
                forecast = as.numeric(forecast(last_model)$mean)),
  dplyr::tibble(model = "unrestricted",
                forecast = as.numeric(forecast(unrestricted_model)$mean)),
  dplyr::tibble(model = "expalmon",
                forecast = as.numeric(forecast(expalmon_model)$mean)),
  dplyr::tibble(model = "beta",
                forecast = as.numeric(forecast(beta_model)$mean))
)

ggplot2::ggplot(
  forecasts_df,
  ggplot2::aes(x = .data$model, y = .data$forecast, fill = .data$model)
) +
  ggplot2::geom_col(width = 0.6, show.legend = FALSE) +
  ggplot2::labs(
    title = "One-step-ahead forecast by aggregation strategy",
    x = NULL, y = "Forecast"
  ) +
  theme_bridgr()

## ----evaluation, message = FALSE, warning = FALSE-----------------------------
origins <- (n_quarters - 13):(n_quarters - 4)
methods <- c("mean", "unrestricted", "expalmon")

eval_rows <- list()
for (m in methods) {
  for (origin in origins) {
    train <- dplyr::slice(quarter_target, seq_len(origin))
    truth <- quarter_target$value[[origin + 1]]
    fit <- mf_model(
      target = train,
      indic = monthly_indicator,
      indic_predict = "last",
      indic_aggregators = m,
      h = 1,
      solver_options = if (m == "expalmon") {
        list(seed = 1, n_starts = 1, maxiter = 100)
      } else {
        NULL
      }
    )
    fc <- as.numeric(forecast(fit)$mean)[[1]]
    eval_rows[[length(eval_rows) + 1]] <- dplyr::tibble(
      method = m, origin = origin, forecast = fc, actual = truth
    )
  }
}

eval_df <- dplyr::bind_rows(eval_rows)
eval_summary <- eval_df |>
  dplyr::group_by(.data$method) |>
  dplyr::summarise(
    rmse = sqrt(mean((.data$forecast - .data$actual)^2)),
    mae = mean(abs(.data$forecast - .data$actual)),
    .groups = "drop"
  )

eval_summary