tests for quantreg

Author: topepo

R/aaa_quantiles.R

@@ -23,16 +23,18 @@ check_quantile_level <- function(x, object, call) {
 
 # Assumes the columns have the same order as quantile_level
 restructure_rq_pred <- function(x, object) {
+  num_quantiles <- NCOL(x)
+  if ( num_quantiles == 1L ){
+    x <- matrix(x, ncol = 1)
+  }
   n <- nrow(x)
-  p <- ncol(x)
-  # TODO check p = length(quantile_level)
-  # check p = 1 case
+
   quantile_level <- object$spec$quantile_level
   res <-
     tibble::tibble(
     .pred_quantile = as.vector(x),
     .quantile_level = rep(quantile_level, each = n),
-    .row = rep(1:n, p))
+    .row = rep(1:n, num_quantiles))
   res <- vctrs::vec_split(x = res[,1:2], by = res[, ".row"])
   res <- vctrs::vec_cbind(res$key, tibble::new_tibble(list(.pred_quantile = res$val)))
   res$.row <- NULL

tests/testthat/test-linear_reg_quantreg.R

@@ -0,0 +1,84 @@
+test_that('linear quantile regression via quantreg - single quantile', {
+  skip_if_not_installed("quantreg")
+
+  data("Sacramento")
+
+  Sacramento_small <-
+    Sacramento %>%
+    dplyr::select(price, beds, baths, sqft, latitude, longitude)
+
+  sac_train <- Sacramento_small[-(1:5), ]
+  sac_test  <- Sacramento_small[  1:5 , ]
+
+  one_quant <-
+    linear_reg() %>%
+    set_engine("quantreg") %>%
+    set_mode("quantile regression", quantile_level = .5) %>%
+    fit(price ~ ., data = sac_train)
+
+  expect_s3_class(one_quant, c("_rq", "model_fit"))
+
+  ###
+
+  one_quant_pred <- predict(one_quant, new_data = sac_test)
+  expect_true(nrow(one_quant_pred) == nrow(sac_test))
+  expect_named(one_quant_pred, ".pred_quantile")
+  expect_true(is.list(one_quant_pred[[1]]))
+  expect_s3_class(one_quant_pred$.pred_quantile[[1]], c("tbl_df", "tbl", "data.frame"))
+  expect_named(one_quant_pred$.pred_quantile[[1]], c(".pred_quantile", ".quantile_level"))
+  expect_true(nrow(one_quant_pred$.pred_quantile[[1]]) == 1L)
+
+  ###
+
+  one_quant_one_row <- predict(one_quant, new_data = sac_test[1,])
+  expect_true(nrow(one_quant_one_row) == 1L)
+  expect_named(one_quant_one_row, ".pred_quantile")
+  expect_true(is.list(one_quant_one_row[[1]]))
+  expect_s3_class(one_quant_one_row$.pred_quantile[[1]], c("tbl_df", "tbl", "data.frame"))
+  expect_named(one_quant_one_row$.pred_quantile[[1]], c(".pred_quantile", ".quantile_level"))
+  expect_true(nrow(one_quant_one_row$.pred_quantile[[1]]) == 1L)
+})
+
+test_that('linear quantile regression via quantreg - multiple quantiles', {
+  skip_if_not_installed("quantreg")
+
+  data("Sacramento")
+
+  Sacramento_small <-
+    Sacramento %>%
+    dplyr::select(price, beds, baths, sqft, latitude, longitude)
+
+  sac_train <- Sacramento_small[-(1:5), ]
+  sac_test  <- Sacramento_small[  1:5 , ]
+
+  ten_quant <-
+    linear_reg() %>%
+    set_engine("quantreg") %>%
+    set_mode("quantile regression", quantile_level = (0:9)/9) %>%
+    fit(price ~ ., data = sac_train)
+
+  expect_s3_class(ten_quant, c("_rq", "model_fit"))
+
+  ###
+
+  ten_quant_pred <- predict(ten_quant, new_data = sac_test)
+  expect_true(nrow(ten_quant_pred) == nrow(sac_test))
+  expect_named(ten_quant_pred, ".pred_quantile")
+  expect_true(is.list(ten_quant_pred[[1]]))
+  expect_s3_class(ten_quant_pred$.pred_quantile[[1]], c("tbl_df", "tbl", "data.frame"))
+  expect_named(ten_quant_pred$.pred_quantile[[1]], c(".pred_quantile", ".quantile_level"))
+  expect_true(nrow(ten_quant_pred$.pred_quantile[[1]]) == 10L)
+
+  ###
+
+  ten_quant_one_row <- predict(ten_quant, new_data = sac_test[1,])
+  expect_true(nrow(ten_quant_one_row) == 1L)
+  expect_named(ten_quant_one_row, ".pred_quantile")
+  expect_true(is.list(ten_quant_one_row[[1]]))
+  expect_s3_class(ten_quant_one_row$.pred_quantile[[1]], c("tbl_df", "tbl", "data.frame"))
+  expect_named(ten_quant_one_row$.pred_quantile[[1]], c(".pred_quantile", ".quantile_level"))
+  expect_true(nrow(ten_quant_one_row$.pred_quantile[[1]]) == 10L)
+})
+
+
+