don't sort models (#23)

* don't sort models

* Increment version number to 0.1.2.9000

* add news item

* update snapshot

Author: sbfnk

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: qrensemble
 Title: Forecast ensembles using Quantile Regression Average (QRA)
-Version: 0.1.2
+Version: 0.1.2.9000
 Authors@R: 
     c(person(given = "Sebastian",
              family = "Funk",

NEWS.md

@@ -1,3 +1,8 @@
+# qrensemble (development version)
+
+- fixed a bug in model labelling
+- fixed a bug where the `group` argument could not be empty
+
 # qrensemble 0.1.2
 
 - The package was renamed to qrensemble to avoid a conflict with the existing qra package on CRAN

R/qra.r

@@ -66,7 +66,8 @@ qra_create_ensemble <- function(x, target, per_quantile_weights, intercept,
   ## create return tibbles
   wtb <- CJ(
     model = unique(x$model),
-    quantile = unique(x$quantile_level)
+    quantile = unique(x$quantile_level),
+    sorted = FALSE
   )[, weight := weights]
 
   itb <- data.table(
@@ -221,8 +222,12 @@ qra <- function(forecast, target, group = c(),
   forecast <- as.data.table(forecast)
   forecast <- forecast[!is.na(predicted)]
 
-  ## first, split by group
-  ensemble <- split(forecast, by = group)
+  if (length(group) > 1) {
+    ## first, split by group
+    ensemble <- split(forecast, by = group)
+  } else {
+    ensemble <- list(forecast)
+  }
   ## next, re-convert to forecast format
   ensemble <- map(ensemble, as_forecast_quantile, forecast_unit = forecast_unit)
   ## next, split off target forecasts and check for completeness

tests/testthat/test-qra.R

@@ -9,3 +9,18 @@ test_that("qra works", {
   )
   expect_snapshot(res)
 })
+
+test_that("qra produces sensible results in trivial cases", {
+  forecasts <- scoringutils::as_forecast_quantile(data.frame(
+    model = rep(c("model2", "model1"), each = 2),
+    observed = rep(1, 4),
+    predicted = rep(c(0, 1), each = 2),
+    quantile_level = rep(0.5, 4),
+    time = rep(c(0, 1), time = 2)
+  ))
+  res <- qra(
+    forecasts,
+    target = c(time = 1)
+  )
+  expect_equal(attr(res, "weights")[model == "model1"]$weight, 1)
+})