R/RcppExports.R

In profoc: Probabilistic Forecast Combination Using CRPS Learning

# Generated by using Rcpp::compileAttributes() -> do not edit by hand
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393

batch_rcpp <- function(y, experts, tau, affine, positive, intercept, debias, lead_time, initial_window, rolling_window, loss_function, loss_parameter, qw_crps, param_grid, knots, forget_past_performance, allow_quantile_crossing, trace) {
    .Call(`_profoc_batch_rcpp`, y, experts, tau, affine, positive, intercept, debias, lead_time, initial_window, rolling_window, loss_function, loss_parameter, qw_crps, param_grid, knots, forget_past_performance, allow_quantile_crossing, trace)
}

test_class_input <- function(obj) {
    .Call(`_profoc_test_class_input`, obj)
}

test_class_output <- function() {
    .Call(`_profoc_test_class_output`)
}

loss <- function(y, x, pred = 0, method = "quantile", tau = 0.5, a = 1, gradient = TRUE) {
    .Call(`_profoc_loss`, y, x, pred, method, tau, a, gradient)
}

loss_grad_wrt_w <- function(expert, pred, truth, tau, loss_function, a, w) {
    .Call(`_profoc_loss_grad_wrt_w`, expert, pred, truth, tau, loss_function, a, w)
}

sample_int <- function(N, size, seed) {
    .Call(`_profoc_sample_int`, N, size, seed)
}

optimize_weights <- function(truth, experts, affine = FALSE, positive = FALSE, intercept = FALSE, debias = TRUE, loss_function = "quantile", tau = 0.5, forget = 0, loss_scaling = 1) {
    .Call(`_profoc_optimize_weights`, truth, experts, affine, positive, intercept, debias, loss_function, tau, forget, loss_scaling)
}

optimize_betas <- function(truth, experts, affine, positive, intercept, debias, loss_function, tau_vec, forget, loss_scaling, basis, beta, qw_crps) {
    .Call(`_profoc_optimize_betas`, truth, experts, affine, positive, intercept, debias, loss_function, tau_vec, forget, loss_scaling, basis, beta, qw_crps)
}

#' @template function_oracle
#'
#' @template param_y
#' @template param_experts
#' @template param_tau
#' @template param_affine
#' @template param_positive
#' @template param_intercept
#' @template param_debias
#' @template param_loss_function
#' @template param_loss_parameter
#' @template param_forget
#' @usage oracle(y, experts, tau, affine = FALSE,
#' positive = FALSE, intercept = FALSE, debias = TRUE,
#' loss_function = "quantile", loss_parameter = 1, forget = 0)
#' @examples
#' \dontrun{
#' T <- 50 # Observations
#' N <- 2 # Experts
#' P <- 9 # Quantiles
#' prob_grid <- 1:P / (P + 1)
#'
#' y <- rnorm(n = T) # Realized
#' experts <- array(dim = c(T, P, N)) # Predictions
#' for (t in 1:T) {
#'     experts[t, , 1] <- qnorm(prob_grid, mean = -1, sd = 1)
#'     experts[t, , 2] <- qnorm(prob_grid, mean = 3, sd = sqrt(4))
#' }
#'
#' model <- oracle(
#'     y = matrix(y),
#'     experts = experts
#' )
#' }
#'
#' @export
oracle <- function(y, experts, tau = as.numeric( c()), affine = FALSE, positive = FALSE, intercept = FALSE, debias = TRUE, loss_function = "quantile", loss_parameter = 1, forget = 0) {
    .Call(`_profoc_oracle`, y, experts, tau, affine, positive, intercept, debias, loss_function, loss_parameter, forget)
}

#' @title Create B-Spline basis
#'
#' @description This function creates a B-Spline matrix.
#'
#' @param x Vector of values.
#' @param knots Vector of knots.
#' @param deg Degree of the Spline functions.
#' @param periodic Whether the basis should be periodic or not.
#' @param intercept Whether the firs column should be kept.
#' @return Returns a matrix of B-Spline basis functions.
#' @examples
#' n <- 9
#' deg <- 3
#' mu <- 0.35
#' x <- 0:1000 / 1000
#'
#' knots <- make_knots(n, mu = mu, deg = deg)
#'
#' B <- splines2_basis(x, knots, deg)
#' ts.plot(B, col = 1:dim(B)[2])
#'
#' # Periodic Case
#' B <- splines2_basis(x, knots, deg, periodic = TRUE)
#' ts.plot(B, col = 1:dim(B)[2])
#'
#' @export
splines2_basis <- function(x, knots, deg, periodic = FALSE, intercept = TRUE) {
    .Call(`_profoc_splines2_basis`, x, knots, deg, periodic, intercept)
}

#' @title B-Spline penalty
#'
#' @description This function calculates the B-Spline basis penalty.
#' It follows the procedure outlined in the paper by Zheyuan Li, Jiguo
#' Cao, 2022 "General P-Splines for Non-Uniform B-Splines"
#' \doi{10.48550/arXiv.2201.06808}.
#' For equidistant knots it coincides with the usual penalty based
#' on the identitiy. For non-equidistant knots it is a weighted penalty
#' with respect to the knot distances.
#' In addition to the above, we added the possibility to calculate
#' periodic penalties which are based on the periodic differencing matrices.
#'
#' @param knots Vector of knots.
#' @param order Order of the Basis (degree + 1).
#' @param periodic Whether the penalties should be periodic or not.
#' @param max_diff Maximum difference order to calculate.
#'
#' @return Returns a list of (order - 1) penalty matrices.
#'
#' @examples
#' \dontrun{
#' # Equidistant knots with order 2
#' knots <- 1:10
#'
#' P <- penalty(knots, order = 2)
#'
#' print(P[[1]]) # First differences
#'
#' # Non equidistant knots
#' knots <- c(0, 0, 0, 0, 1, 3, 4, 4, 4, 4)
#'
#' P <- penalty(knots, order = 4)
#'
#' print(P[[1]]) # First differences
#' print(P[[2]]) # Second differences
#' print(P[[3]]) # Third differences
#'
#' # Periodic penalty for equidistant knots
#' oder <- 4
#' deg <- order - 1
#' knots <- 1:15
#'
#' penalty(knots, order = order, periodic = TRUE)[[1]]
#' penalty(knots, order = order, periodic = TRUE)[[2]]
#' penalty(knots, order = order, periodic = TRUE)[[3]]
#' }
#'
#' @export
penalty <- function(knots, order, periodic = FALSE, max_diff = 999L) {
    .Call(`_profoc_penalty`, knots, order, periodic, max_diff)
}

periodic_adjacency <- function(size) {
    .Call(`_profoc_periodic_adjacency`, size)
}

adjacency_to_incidence <- function(adj) {
    .Call(`_profoc_adjacency_to_incidence`, adj)
}

make_basis_matrix <- function(x, knots, deg, periodic = FALSE) {
    .Call(`_profoc_make_basis_matrix`, x, knots, deg, periodic)
}

make_hat_matrix <- function(x, knots, deg, bdiff, lambda, periodic) {
    .Call(`_profoc_make_hat_matrix`, x, knots, deg, bdiff, lambda, periodic)
}