Merge pull request #51 from mlr-org/pinball

feat: add pinball
mlr-org · Aug 20, 2024 · 0da8bbb · 0da8bbb
2 parents ec92d86 + 5901c4b
commit 0da8bbb
Show file tree

Hide file tree

Showing 32 changed files with 159 additions and 1 deletion.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -76,6 +76,7 @@ Collate:
     'regr_mse.R'
     'regr_msle.R'
     'regr_pbias.R'
+    'regr_pinball.R'
     'regr_rae.R'
     'regr_rmse.R'
     'regr_rmsle.R'

diff --git a/NAMESPACE b/NAMESPACE
@@ -43,6 +43,7 @@ export(npv)
 export(one_zero)
 export(pbias)
 export(phi)
+export(pinball)
 export(ppv)
 export(prauc)
 export(precision)

diff --git a/R/regr_pinball.R b/R/regr_pinball.R
@@ -0,0 +1,32 @@
+#' @title Average Pinball Loss
+#'
+#' @details
+#' The pinball loss for quantile regression is defined as \deqn{
+#' \text{Average Pinball Loss} = \frac{1}{n} \sum_{i=1}^{n} w_{i}
+#' \begin{cases}
+#' q \cdot (t_i - r_i) & \text{if } t_i \geq r_i \\
+#'(1 - q) \cdot (r_i - t_i) & \text{if } t_i < r_i
+#' \end{cases}
+#' }
+#' where \eqn{q} is the quantile and \eqn{w_i} are normalized sample weights.
+#'
+#'
+#' @templateVar mid pinball
+#' @template regr_template
+#'
+#' @inheritParams regr_params
+#'
+#' @param alpha `numeric(1)`\cr
+#'  The quantile to compute the pinball loss.
+#'
+#' @template regr_example
+#' @export
+pinball = function(truth, response, sample_weights = NULL, alpha = 0.5, ...) {
+  assert_regr(truth, response = response)
+
+  diff = truth - response
+  wmean(ifelse(diff >= 0, alpha * diff, (1 - alpha) * -diff), sample_weights)
+}
+
+#' @include measures.R
+add_measure(pinball, "Pinball", "regr", -Inf, Inf, TRUE)
diff --git a/man/ae.Rd b/man/ae.Rd
diff --git a/man/ape.Rd b/man/ape.Rd
diff --git a/man/bias.Rd b/man/bias.Rd
diff --git a/man/ktau.Rd b/man/ktau.Rd
diff --git a/man/linex.Rd b/man/linex.Rd
diff --git a/man/mae.Rd b/man/mae.Rd
diff --git a/man/mape.Rd b/man/mape.Rd
diff --git a/man/maxae.Rd b/man/maxae.Rd
diff --git a/man/maxse.Rd b/man/maxse.Rd
diff --git a/man/measures.Rd b/man/measures.Rd
diff --git a/man/medae.Rd b/man/medae.Rd
diff --git a/man/medse.Rd b/man/medse.Rd
diff --git a/man/mse.Rd b/man/mse.Rd
diff --git a/man/msle.Rd b/man/msle.Rd
diff --git a/man/pbias.Rd b/man/pbias.Rd
diff --git a/man/pinball.Rd b/man/pinball.Rd
diff --git a/man/rae.Rd b/man/rae.Rd
diff --git a/man/rmse.Rd b/man/rmse.Rd
diff --git a/man/rmsle.Rd b/man/rmsle.Rd
diff --git a/man/rrse.Rd b/man/rrse.Rd
diff --git a/man/rse.Rd b/man/rse.Rd
diff --git a/man/rsq.Rd b/man/rsq.Rd
diff --git a/man/sae.Rd b/man/sae.Rd
diff --git a/man/se.Rd b/man/se.Rd
diff --git a/man/sle.Rd b/man/sle.Rd
diff --git a/man/smape.Rd b/man/smape.Rd
diff --git a/man/srho.Rd b/man/srho.Rd
diff --git a/man/sse.Rd b/man/sse.Rd
diff --git a/tests/testthat/test_regr.R b/tests/testthat/test_regr.R
@@ -85,4 +85,10 @@ test_that("tests from Metrics", {
   expect_equal(rsq(0:10, 2:12), 0.6)
   expect_equal(rsq(seq(0, 2, 0.5), seq(0, 2, 0.5)), 1.0)
   expect_equal(rsq(1:4, c(1, 2, 3, 5)), 0.8)
+
+  expect_equal(pinball(1:3, 1:3), 0)
+  expect_equal(pinball(1:3, c(0, 2, 3)), 1 / 6)
+  expect_equal(pinball(1:3, c(1, 2, 4)), 1 / 6)
+  expect_equal(pinball(1:3, c(1, 2, 4), alpha = 0.1), 0.3)
+  expect_equal(pinball(1:3, c(1, 2, 4), alpha = 0.4), 0.2)
 })