tests/testthat/test-reconc_MixCond.R

In bayesRecon: Probabilistic Reconciliation via Conditioning

test_that("reconc_MixCond simple example", {
  # Simple example with
  # - 12 bottom
  # - 10 upper: year, 6 bi-monthly, 3 quarterly
  A <- matrix(
    data = c(
      1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
      1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
      0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0,
      0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1,
      1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
      0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
      0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0,
      0, 0, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
      0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0,
      0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1
    ),
    nrow = 10, byrow = TRUE
  )

  # Define means and vars for the forecasts
  means <- c(90, 62, 63, 64, 31, 32, 31, 33, 31, 32, rep(15, 12))
  vars <- c(20, 8, 8, 8, 4, 4, 4, 4, 4, 4, rep(2, 12))^2

  # create the lists for reconciliation
  ## upper
  fc_upper <- list(
    mean = means[1:10],
    cov = diag(vars[1:10])
  )

  ## bottom
  fc_bottom <- list()
  for (i in seq(ncol(A))) {
    fc_bottom[[i]] <- as.integer(.distr_sample(list(mean = means[i + 10], sd = vars[i + 10]), "gaussian", 2e4))
    fc_bottom[[i]][which(fc_bottom[[i]] < 0)] <- 0 # set-negative-to-zero
  }


  res.MixCond <- reconc_MixCond(A, fc_bottom, fc_upper, bottom_in_type = "samples", seed = 42)

  bott_rec_means <- unlist(lapply(res.MixCond$bottom_rec_pmf, PMF_get_mean))
  bott_rec_vars <- unlist(lapply(res.MixCond$bottom_rec_pmf, PMF_get_var))


  # Create PMF from samples
  fc_bottom_pmf <- list()
  for (i in seq(ncol(A))) {
    fc_bottom_pmf[[i]] <- PMF_from_samples(fc_bottom[[i]])
  }

  # Reconcile from bottom PMF
  res.MixCond_pmf <- reconc_MixCond(A, fc_bottom_pmf, fc_upper, seed = 42)

  bott_rec_means_pmf <- unlist(lapply(res.MixCond_pmf$bottom_rec_pmf, PMF_get_mean))
  bott_rec_vars_pmf <- unlist(lapply(res.MixCond_pmf$bottom_rec_pmf, PMF_get_var))

  expect_equal(bott_rec_means, bott_rec_means_pmf, tolerance = 0.01)
  expect_equal(bott_rec_vars, bott_rec_vars_pmf, tolerance = 0.1)
})

test_that("reconc_MixCond and reconc_TDcond with temporal hier and params", {
  # Read samples from dataForTests (reproducibility)
  vals <- read.csv(file = "dataForTests/Monthly-Count_ts.csv", header = FALSE)

  # Create a count time series with monthly observations for 10 years
  y <- ts(data = vals, frequency = 12)

  # Create the aggregated yearly time series
  y_agg <- temporal_aggregation(y, agg_levels = c(1, 12))

  # We use a marginal forecast that computes for each month
  # the empirical mean and forecasts a Poisson with that value
  fc_bottom <- list()
  for (i in seq(12)) {
    fc_bottom[[i]] <- list(lambda = mean(y_agg$`f=12`[seq(i, 120, 12)]))
  }

  # We compute the empirical mean and variance of the yearly ts
  # we forecast with a Gaussian with those parameters
  fc_upper <- list(mean = mean(y_agg$`f=1`), cov = matrix(var(y_agg$`f=1`)))

  # Obtain the aggregation matrix for this hierarchy
  rec_mat <- get_reconc_matrices(c(1, 12), 12)

  # Do a couple of checks on S and A
  expect_no_error(.check_S(rec_mat$S))
  expect_error(.check_S(rec_mat$A))
  expect_true(.check_BU_matr(rec_mat$A))
  expect_false(.check_BU_matr(rec_mat$S))

  # We can reconcile with reconc_MixCond
  res.mixCond <- reconc_MixCond(rec_mat$A, fc_bottom, fc_upper, bottom_in_type = "params", distr = "poisson")

  # We can reconcile with reconc_TDcond
  res.TDcond <- reconc_TDcond(rec_mat$A, fc_bottom, fc_upper, bottom_in_type = "params", distr = "poisson")

  # Summary of the upper reconciled with TDcond
  pmfSum <- PMF_summary(res.TDcond$upper_rec_pmf[[1]])
  # We expect that the reconciled mean is very similar to the initial mean (should be equal)
  expect_equal(pmfSum$Mean, fc_upper$mean, tolerance = 0.01)

  # Check that all bottom and upper reconciled PMF sum to 1
  check_pmf_bott_mixCond <- sum(unlist(lapply(res.mixCond$bottom_rec_pmf, function(x) {
    sum(x)
  })))
  check_pmf_upp_mixCond <- sum(unlist(lapply(res.mixCond$upper_rec_pmf, function(x) {
    sum(x)
  })))
  expect_equal(check_pmf_bott_mixCond, 12)
  expect_equal(check_pmf_upp_mixCond, 1)

  # Check that all bottom and upper reconciled PMF sum to 1
  check_pmf_bott_TDcond <- sum(unlist(lapply(res.TDcond$bottom_rec_pmf, function(x) {
    sum(x)
  })))
  check_pmf_upp_TDcond <- sum(unlist(lapply(res.TDcond$upper_rec_pmf, function(x) {
    sum(x)
  })))
  expect_equal(check_pmf_bott_TDcond, 12)
  expect_equal(check_pmf_upp_TDcond, 1)
})