R/loss.R

In twolodzko/twextras: twextras

#' Weighted loss functions
#'
#' @param x        vector of target values.
#' @param y        vector of predictions.
#' @param w        optional weight parameter.
#' @param epsilon  threshold parameter.
#' 
#' @details
#' 
#' The loss functions in this package are defined as following:
#' 
#' threshold \eqn{L_0}{L0} loss
#' 
#' \deqn{
#' L_0 = \boldsymbol{1} \left( |x-y| \le \varepsilon \right)
#' }{
#' L0 = |x-y| <= \epsilon
#' }
#' 
#' \eqn{L_1}{L1} loss
#' 
#' \deqn{
#' L_1 = |x-y|
#' }{
#' L1 = |x-y|
#' }
#' 
#' \eqn{L_2}{L2} loss
#'  
#' \deqn{
#' L_2 = (x-y)^2
#' }{
#' L2 = (x-y)^2
#' }
#' 
#' \eqn{\varepsilon}{\epsilon}-insensitive loss
#'  
#' \deqn{
#' L_{\varepsilon} =
#' \left\{\begin{array}{ll}
#' 0 & |x-y| \le \varepsilon \\
#' |x-y| - \varepsilon & |x-y| > \varepsilon
#' \end{array}\right.
#' }{
#' L\epsilon =
#' [if |x-y| <= \epsilon: ] 0
#' [else:] |x-y| - \epsilon
#' }
#' 
#' Huber loss
#' 
#' \deqn{
#' L_{\delta} =
#' \left\{\begin{array}{ll}
#' \frac{1}{2} (x-y)^2 & |x-y| \le \delta \\
#' \delta(|x-y| - \frac{1}{2}\delta) & |x-y| > \delta
#' \end{array}\right.
#' }{
#' L\delta =
#' [if |x-y| <= \delta: ] 1/2 * (x-y)^2
#' [else:] \delta*(|x-y| - \delta/2)
#' }
#' 
#' Percentile loss
#' 
#' \deqn{
#' L_{\alpha} = \alpha (x-y) I(x-y \ge 0) - (1-\alpha) (x-y) I(x-y < 0)
#' }{
#' L\alpha = \alpha * (x-y) * I(x-y \ge 0) - (1-\alpha) * (x-y) * I(x-y < 0)
#' }
#' 
#' The whole-data weighted loss functions are defined in terms of \eqn{x}
#' and \eqn{y} vectors, as \eqn{\sum_i w_i L(x_i, y_i)}{sum(loss(x, y) * w)}.
#'
#' @export

loss <- function(name = c("l1", "l2", "huber", "threshold",
                          "insensitive", "percentile"), ...) {
  name <- match.arg(name)
  switch(name,
         l1 = l1loss(),
         huber = huberloss(...),
         threshold = thresholdloss(...),
         insensitive = insensitiveloss(...),
         percentile = percloss(...),
         l2 = l2loss())
}

#' @rdname loss
#' @export

l1loss <- function() {
  function(x, y, w = 1) sum(w * abs(x - y))
}

#' @rdname loss
#' @export

l2loss <- function() {
  function(x, y, w = 1) sum(w * (x - y)^2)
}

#' @rdname loss
#' @export

huberloss <- function(epsilon) {
  function(x, y, w = 1) {
    r <- abs(x-y)
    out <- numeric(length(r))
    out[r <= epsilon] <- r[r <= epsilon]^2/2
    out[r > epsilon] <- epsilon*(r[r > epsilon] - epsilon/2)
    sum(w * out)
  }
} 

#' @rdname loss
#' @export

thresholdloss <- function(epsilon = sqrt(.Machine$double.eps)) {
  function(x, y, w = 1) {
    sum(w * (abs(x-y) <= epsilon))
  }
}

#' @rdname loss
#' @export

insensitiveloss <- function(epsilon) {
  function(x, y, w = 1) {
    r <- abs(x-y)
    out <- numeric(length(r))
    out[r > epsilon] <- r[r > epsilon] - epsilon
    sum(w * out)
  }
} 

#' @rdname loss
#' @export

percloss <- function(alpha) {
  function(x, y, w = 1) {
    r <- x-y
    out <- alpha * r * (r >= 0) - (1-alpha) * r * (r < 0)
    sum(w * out)
  }
}