R/RcppExports.R

Defines functions make_hat_matrix2 make_basis_matrix2 make_basis_matrix make_hat_matrix penalty wt_delta make_knots oracle optimize_betas optimize_weights sample_int loss_grad_wrt_w loss batch_rcpp

Documented in oracle penalty

# 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, 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, forget_past_performance, allow_quantile_crossing, trace)
}

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)
}

make_knots <- function(kstep, a = 1, deg = 3L, even = FALSE) {
    .Call(`_profoc_make_knots`, kstep, a, deg, even)
}

wt_delta <- function(h) {
    .Call(`_profoc_wt_delta`, h)
}

#' @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.
#'
#' @param knots Vector of knots.
#' @param order Order of the Basis (degree + 1).
#' @param max_diff Maximum difference order to calculate.
#'
#' @return Returns a list of (order - 1) penalty matrices.
#'
#' @examples
#' \dontrun{
#' # Equidisan 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
#' }
#'
#' @export
penalty <- function(knots, order, max_diff = 999L) {
    .Call(`_profoc_penalty`, knots, order, max_diff)
}

make_hat_matrix <- function(x, kstep, lambda, bdiff, deg, a, even) {
    .Call(`_profoc_make_hat_matrix`, x, kstep, lambda, bdiff, deg, a, even)
}

make_basis_matrix <- function(x, kstep, deg, a, even) {
    .Call(`_profoc_make_basis_matrix`, x, kstep, deg, a, even)
}

make_basis_matrix2 <- function(x, knots, deg) {
    .Call(`_profoc_make_basis_matrix2`, x, knots, deg)
}

make_hat_matrix2 <- function(x, knots, deg, bdiff, lambda) {
    .Call(`_profoc_make_hat_matrix2`, x, knots, deg, bdiff, lambda)
}

Try the profoc package in your browser

Any scripts or data that you put into this service are public.

profoc documentation built on Jan. 13, 2023, 5:10 p.m.