updates for quantile predictions

Author: topepo

NAMESPACE

@@ -22,6 +22,7 @@ S3method(predict_confint,model_fit)
 S3method(predict_num,"_elnet")
 S3method(predict_num,model_fit)
 S3method(predict_predint,model_fit)
+S3method(predict_quantile,model_fit)
 S3method(predict_raw,"_elnet")
 S3method(predict_raw,"_lognet")
 S3method(predict_raw,"_multnet")
@@ -95,6 +96,8 @@ export(predict_num)
 export(predict_num.model_fit)
 export(predict_predint)
 export(predict_predint.model_fit)
+export(predict_quantile)
+export(predict_quantile.model_fit)
 export(predict_raw)
 export(predict_raw.model_fit)
 export(rand_forest)
@@ -113,10 +116,12 @@ import(rlang)
 importFrom(dplyr,arrange)
 importFrom(dplyr,as_tibble)
 importFrom(dplyr,bind_cols)
+importFrom(dplyr,bind_rows)
 importFrom(dplyr,collect)
 importFrom(dplyr,full_join)
 importFrom(dplyr,funs)
 importFrom(dplyr,group_by)
+importFrom(dplyr,mutate)
 importFrom(dplyr,pull)
 importFrom(dplyr,rename)
 importFrom(dplyr,rename_at)
@@ -159,6 +164,7 @@ importFrom(stats,predict)
 importFrom(stats,qnorm)
 importFrom(stats,qt)
 importFrom(stats,quantile)
+importFrom(stats,setNames)
 importFrom(stats,terms)
 importFrom(stats,update)
 importFrom(tibble,as_tibble)

R/misc.R

@@ -178,3 +178,15 @@ check_args <- function(object) {
 check_args.default <- function(object) {
   invisible(object)
 }
+
+# ------------------------------------------------------------------------------
+
+# copied form recipes
+
+names0 <- function (num, prefix = "x") {
+  if (num < 1)
+    stop("`num` should be > 0", call. = FALSE)
+  ind <- format(1:num)
+  ind <- gsub(" ", "0", ind)
+  paste0(prefix, ind)
+}

R/predict.R

@@ -7,8 +7,8 @@
 #' @param object An object of class `model_fit`
 #' @param new_data A rectangular data object, such as a data frame.
 #' @param type A single character value or `NULL`. Possible values
-#'  are "numeric", "class", "probs", "conf_int", "pred_int", or
-#'  "raw". When `NULL`, `predict` will choose an appropriate value
+#'  are "numeric", "class", "probs", "conf_int", "pred_int", "quantile",
+#'  or "raw". When `NULL`, `predict` will choose an appropriate value
 #'  based on the model's mode.
 #' @param opts A list of optional arguments to the underlying
 #'  predict function that will be used when `type = "raw"`. The
@@ -45,6 +45,10 @@
 #'  produces for class probabilities (or other non-scalar outputs),
 #'  the columns will be named `.pred_lower_classlevel` and so on.
 #'
+#' Quantile predictions return a tibble with a column `.pred`, which is
+#'  a list-column. Each list element contains a tibble with columns
+#'  `.pred` and `.quantile` (and perhaps others).
+#'
 #' Using `type = "raw"` with `predict.model_fit` (or using
 #'  `predict_raw`) will return the unadulterated results of the
 #'  prediction function.
@@ -96,6 +100,7 @@ predict.model_fit <- function (object, new_data, type = NULL, opts = list(), ...
     prob     = predict_classprob(object = object, new_data = new_data, ...),
     conf_int = predict_confint(object = object, new_data = new_data, ...),
     pred_int = predict_predint(object = object, new_data = new_data, ...),
+    quantile = predict_quantile(object = object, new_data = new_data, ...),
     raw      = predict_raw(object = object, new_data = new_data, opts = opts, ...),
     stop("I don't know about type = '", "'", type, call. = FALSE)
   )
@@ -112,7 +117,8 @@ predict.model_fit <- function (object, new_data, type = NULL, opts = list(), ...
   res
 }
 
-pred_types <- c("raw", "numeric", "class", "link", "prob", "conf_int", "pred_int")
+pred_types <-
+  c("raw", "numeric", "class", "link", "prob", "conf_int", "pred_int", "quantile")
 
 #' @importFrom glue glue_collapse
 check_pred_type <- function(object, type) {

R/predict_quantile.R

@@ -0,0 +1,41 @@
+#' @keywords internal
+#' @rdname other_predict
+#' @param quant A vector of numbers between 0 and 1 for the quantile being 
+#'  predicted. 
+#' @inheritParams predict.model_fit
+#' @method predict_quantile model_fit
+#' @export predict_quantile.model_fit
+#' @export
+predict_quantile.model_fit <-
+  function (object, new_data, quantile = (1:9)/10, ...) {
+    
+    if (is.null(object$spec$method$quantile))
+      stop("No quantile prediction method defined for this ",
+           "engine.", call. = FALSE)
+    
+    new_data <- prepare_data(object, new_data)
+    
+    # preprocess data
+    if (!is.null(object$spec$method$quantile$pre))
+      new_data <- object$spec$method$quantile$pre(new_data, object)
+    
+    # Pass some extra arguments to be used in post-processor
+    object$spec$method$quantile$args$p <- quantile
+    pred_call <- make_pred_call(object$spec$method$quantile)
+    
+    res <- eval_tidy(pred_call)
+    
+    # post-process the predictions
+    if(!is.null(object$spec$method$quantile$post)) {
+      res <- object$spec$method$quantile$post(res, object)
+    }
+    
+    res
+  }
+
+#' @export
+#' @keywords internal
+#' @rdname other_predict
+#' @inheritParams predict.model_fit
+predict_quantile <- function (object, ...)
+  UseMethod("predict_quantile")