tests/testthat/test-threshold_batch.R

In profoc: Probabilistic Forecast Combination Using CRPS Learning

skip_if(debug_mode)

# %% Test threshold batch - unconstrained
set.seed(1)

# Experts
N <- 2
# Observations
T <- 100
# Size of probability grid
P <- 1
prob_grid <- 1:P / (P + 1)

threshold_val <- 0.3

dev <- c(-1, 4)
experts_sd <- c(1, 1)

# Realized observations
y <- rnorm(n = T)

# Expert predictions
experts <- array(dim = c(T, P, N))
for (t in 1:T) {
    experts[t, , 1] <- qnorm(prob_grid, mean = dev[1], sd = experts_sd[1])
    experts[t, , 2] <- qnorm(prob_grid, mean = dev[2], sd = experts_sd[2])
}

results_unconstrained <- batch(
    matrix(y),
    experts,
    prob_grid,
    trace = FALSE
)

results_unconstrained_hard <- batch(
    matrix(y),
    experts,
    prob_grid,
    hard_threshold = threshold_val,
    trace = FALSE
)

results_unconstrained_soft <- batch(
    matrix(y),
    experts,
    prob_grid,
    soft_threshold = threshold_val,
    trace = FALSE
)

# ts.plot(results_unconstrained$weights[, 1, ],
#     ylim = c(0, 1),
#     main = "Results_unconstrained as is"
# )
# abline(h = threshold_val, col = "grey")

# ts.plot(results_unconstrained_hard$weights[, 1, ],
#     ylim = c(0, 1),
#     main = "Threshold Hard"
# )
# abline(h = threshold_val, col = "grey")

# ts.plot(results_unconstrained_soft$weights[, 1, ],
#     ylim = c(0, 1),
#     main = "Threshold Soft"
# )
# abline(h = threshold_val, col = "grey")
# %%

# %% Test threshold batch - convex
results_convex <- batch(
    matrix(y),
    experts,
    prob_grid,
    positive = TRUE,
    affine = TRUE,
    trace = FALSE
)

results_convex_hard <- batch(
    matrix(y),
    experts,
    prob_grid,
    hard_threshold = threshold_val,
    positive = TRUE,
    affine = TRUE,
    trace = FALSE
)

results_convex_soft <- batch(
    matrix(y),
    experts,
    prob_grid,
    soft_threshold = threshold_val,
    positive = TRUE,
    affine = TRUE,
    trace = FALSE
)

# ts.plot(results_convex$weights[, 1, ],
#     ylim = c(0, 1),
#     main = "Results_convex as is"
# )
# abline(h = threshold_val, col = "grey")

# ts.plot(results_convex_hard$weights[, 1, ],
#     ylim = c(0, 1),
#     main = "Threshold Hard Convex"
# )
# abline(h = threshold_val, col = "grey")

# ts.plot(results_convex_soft$weights[, 1, ],
#     ylim = c(0, 1),
#     main = "Threshold Soft Convex"
# )
# abline(h = threshold_val, col = "grey")
# %%

# %% Test threshold batch - convex + intercept
results_convex_intercept <- batch(
    matrix(y),
    experts,
    prob_grid,
    positive = TRUE,
    affine = TRUE,
    intercept = TRUE,
    trace = FALSE
)

results_convex_intercept_hard <- batch(
    matrix(y),
    experts,
    prob_grid,
    hard_threshold = threshold_val,
    positive = TRUE,
    affine = TRUE,
    intercept = TRUE,
    trace = FALSE
)

results_convex_intercept_soft <- batch(
    matrix(y),
    experts,
    prob_grid,
    soft_threshold = threshold_val,
    positive = TRUE,
    affine = TRUE,
    intercept = TRUE,
    trace = FALSE
)

# ts.plot(results_convex_intercept$weights[, 1, ],
#     col = 1:3,
#     ylim = c(0, 1),
#     main = "Results convex + intercept as is"
# )
# abline(h = threshold_val, col = "grey")

# ts.plot(results_convex_intercept_hard$weights[, 1, ],
#     col = 1:3,
#     ylim = c(0, 1),
#     main = "Threshold Hard Convex + Intercept"
# )
# abline(h = threshold_val, col = "grey")

# ts.plot(results_convex_intercept_soft$weights[, 1, ],
#     ylim = c(0, 1),
#     col = 1:3,
#     main = "Threshold Soft Convex + Intercept"
# )
# abline(h = threshold_val, col = "grey")
# %%

# %% Test intercept influnence in convex setting

# Test if intercept weights are in the threshold region
expect_true(
    any(results_convex_intercept$weights[, , 1] < threshold_val &
        results_convex_intercept$weights[, , 1] > 0.01)
)

# Thresholds shouldn't influence intercept
expect_true(
    any(threshold_val < results_convex_intercept_hard$weights[, , 1] &
        results_convex_intercept_hard$weights[, , 1] > 0.01)
)

# %%

# %% Thresholds should influence experts in convex setting
# Test if expert weights are in the threshold region
expect_true(
    any(results_convex_intercept$weights[, , 3] < threshold_val &
        results_convex_intercept$weights[, , 3] > 0.01)
)

# Weights removed from the threshold region? (either set to > threshold or 0)
expect_false(
    any(results_convex_intercept_hard$weights[, , 3] < threshold_val &
        results_convex_intercept_hard$weights[, , 3] > 0.01)
)
# %%