remove the distributional package

Author: dajmcdon

DESCRIPTION

@@ -30,7 +30,6 @@ Depends:
 Imports:
     checkmate,
     cli,
-    distributional,
     dplyr,
     epiprocess (>= 0.10.4),
     generics,
@@ -51,6 +50,7 @@ Imports:
     workflows (>= 1.0.0)
 Suggests:
     data.table,
+    distributional,
     epidatr (>= 1.0.0),
     fs,
     grf,

NAMESPACE

@@ -110,9 +110,7 @@ S3method(slather,layer_residual_quantiles)
 S3method(slather,layer_threshold)
 S3method(slather,layer_unnest)
 S3method(snap,default)
-S3method(snap,dist_default)
-S3method(snap,dist_quantiles)
-S3method(snap,distribution)
+S3method(snap,quantile_pred)
 S3method(tidy,check_enough_train_data)
 S3method(tidy,frosting)
 S3method(tidy,layer)
@@ -184,8 +182,6 @@ export(layer_quantile_distn)
 export(layer_residual_quantiles)
 export(layer_threshold)
 export(layer_unnest)
-export(mutate)
-export(nested_quantiles)
 export(new_default_epi_recipe_blueprint)
 export(new_epi_recipe_blueprint)
 export(pivot_longer)
@@ -202,6 +198,7 @@ export(rename)
 export(select)
 export(slather)
 export(smooth_quantile_reg)
+export(snap)
 export(step_adjust_latency)
 export(step_climate)
 export(step_epi_ahead)
@@ -280,6 +277,7 @@ importFrom(ggplot2,geom_point)
 importFrom(ggplot2,geom_ribbon)
 importFrom(glue,glue)
 importFrom(hardhat,extract_recipe)
+importFrom(hardhat,quantile_pred)
 importFrom(hardhat,refresh_blueprint)
 importFrom(hardhat,run_mold)
 importFrom(lubridate,"%m-%")

R/autoplot.R

@@ -243,7 +243,7 @@ plot_bands <- function(
   ntarget_dates <- dplyr::n_distinct(predictions$time_value)
 
   predictions <- predictions %>%
-    mutate(.pred_distn = dist_quantiles(quantile(.pred_distn, levels), levels)) %>%
+    mutate(.pred_distn = quantile_pred(quantile(.pred_distn, levels), levels)) %>%
     pivot_quantiles_wider(.pred_distn)
   qnames <- setdiff(names(predictions), innames)
 

R/extrapolate_quantiles.R

@@ -1,32 +1,26 @@
 #' Summarize a distribution with a set of quantiles
 #'
-#' @param x a `distribution` vector
+#' This function takes a `quantile_pred` vector and returns the same
+#' type of object, expanded to include
+#' *additional* quantiles computed at `probs`. If you want behaviour more
+#' similar to [stats::quantile()], then `quantile(x,...)` may be more
+#' appropriate.
+#'
+#' @param x A vector of class `quantile_pred`.
 #' @param probs a vector of probabilities at which to calculate quantiles
 #' @param replace_na logical. If `x` contains `NA`'s, these are imputed if
-#'   possible (if `TRUE`) or retained (if `FALSE`). This only effects
-#'   elements of class `dist_quantiles`.
+#'   possible (if `TRUE`) or retained (if `FALSE`).
 #' @param ... additional arguments passed on to the `quantile` method
 #'
-#' @return a `distribution` vector containing `dist_quantiles`. Any elements
-#'   of `x` which were originally `dist_quantiles` will now have a superset
+#' @return a `quantile_pred` vector. Each element
+#'   of `x` will now have a superset
 #'   of the original `quantile_values` (the union of those and `probs`).
 #' @export
 #'
 #' @examples
-#' library(distributional)
-#' dstn <- dist_normal(c(10, 2), c(5, 10))
-#' extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75))
-#'
-#' dstn <- dist_quantiles(list(1:4, 8:11), list(c(.2, .4, .6, .8)))
-#' # because this distribution is already quantiles, any extra quantiles are
-#' # appended
-#' extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75))
-#'
-#' dstn <- c(
-#'   dist_normal(c(10, 2), c(5, 10)),
-#'   dist_quantiles(list(1:4, 8:11), list(c(.2, .4, .6, .8)))
-#' )
-#' extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75))
+#' dstn <- quantile_dstn(rbind(1:4, 8:11), c(.2, .4, .6, .8))
+#' # extra quantiles are appended
+#' as.tibble(extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75)))
 extrapolate_quantiles <- function(x, probs, replace_na = TRUE, ...) {
   UseMethod("extrapolate_quantiles")
 }

R/flusight_hub_formatter.R

@@ -104,12 +104,11 @@ flusight_hub_formatter.data.frame <- function(
 
   object <- object %>%
     # combine the predictions and the distribution
-    mutate(.pred_distn = nested_quantiles(.pred_distn)) %>%
-    tidyr::unnest(.pred_distn) %>%
+    pivot_quantiles_longer(.pred_distn) %>%
     # now we create the correct column names
     rename(
-      value = values,
-      output_type_id = quantile_levels,
+      value = .pred_distn_value,
+      output_type_id = .pred_distn_quantile_level,
       reference_date = forecast_date
     ) %>%
     # convert to fips codes, and add any constant cols passed in ...

R/layer_cdc_flatline_quantiles.R

@@ -51,7 +51,7 @@
 #'   in an additional `<list-col>` named `.pred_distn_all` containing 2-column
 #'   [tibble::tibble()]'s. For each
 #'   desired combination of `key`'s, the tibble will contain one row per ahead
-#'   with the associated [dist_quantiles()].
+#'   with the associated [quantile_pred()].
 #' @export
 #'
 #' @examples
@@ -265,11 +265,10 @@ propagate_samples <- function(
     }
   }
   res <- res[aheads]
+  res_quantiles <- map(res, quantile, probs = quantile_levels)
   list(tibble(
     ahead = aheads,
-    .pred_distn = map_vec(
-      res, ~ dist_quantiles(quantile(.x, quantile_levels), quantile_levels)
-    )
+    .pred_distn = quantile_pred(do.call(rbind, res_quantiles), quantile_levels)
   ))
 }
 

R/layer_predictive_distn.R

@@ -45,6 +45,12 @@ layer_predictive_distn <- function(frosting,
                                    truncate = c(-Inf, Inf),
                                    name = ".pred_distn",
                                    id = rand_id("predictive_distn")) {
+  if (!requireNamespace("distributional", quietly = TRUE)) {
+    cli_abort(paste(
+      "You must install the {.pkg distributional} package for",
+      "this functionality."
+    ))
+  }
   rlang::check_dots_empty()
   arg_is_chr_scalar(name, id)
   dist_type <- match.arg(dist_type)

R/layer_quantile_distn.R

@@ -78,15 +78,23 @@ layer_quantile_distn_new <- function(quantile_levels, truncate, name, id) {
 slather.layer_quantile_distn <-
   function(object, components, workflow, new_data, ...) {
     dstn <- components$predictions$.pred
-    if (!inherits(dstn, "distribution")) {
-      cli_abort(c(
-        "`layer_quantile_distn()` requires distributional predictions.",
-        "These are of class {.cls {class(dstn)}}."
-      ))
+    is_supported <- inherits(dstn, "distribution") ||
+      inherits(dstn, "quantile_pred")
+    if (!is_supported) {
+      cli_abort(
+        "`layer_quantile_distn()` requires distributional or quantile
+        predictions. These are of class {.cls {class(dstn)}}."
+      )
+    }
+    if (inherits(dstn, "distribution") && !requireNamespace("distributional", quietly = TRUE)) {
+      cli_abort(
+        "You must install the {.pkg distributional} package for this
+        functionality."
+      )
     }
     rlang::check_dots_empty()
 
-    dstn <- dist_quantiles(
+    dstn <- quantile_pred(
       quantile(dstn, object$quantile_levels),
       object$quantile_levels
     )

R/layer_residual_quantiles.R

@@ -125,24 +125,19 @@ slather.layer_residual_quantiles <-
     }
 
     r <- r %>%
-      summarise(
-        dstn = list(quantile(
-          c(.resid, s * .resid),
-          probs = object$quantile_levels, na.rm = TRUE
-        ))
-      )
+      summarize(dstn = quantile_pred(matrix(quantile(
+        c(.resid, s * .resid), probs = object$quantile_levels, na.rm = TRUE
+      ), nrow = 1), quantile_levels = object$quantile_levels))
     # Check for NA
-    if (any(sapply(r$dstn, is.na))) {
+    if (anyNA(as.matrix(r$dstn)))  {
       cli_abort(c(
         "Residual quantiles could not be calculated due to missing residuals.",
         i = "This may be due to `n_train` < `ahead` in your {.cls epi_recipe}."
       ))
     }
 
     estimate <- components$predictions$.pred
-    res <- tibble(
-      .pred_distn = dist_quantiles(map2(estimate, r$dstn, "+"), object$quantile_levels)
-    )
+    res <- tibble(.pred_distn = r$dstn + estimate)
     res <- check_pname(res, components$predictions, object)
     components$predictions <- mutate(components$predictions, !!!res)
     components

R/layer_threshold_preds.R

@@ -62,6 +62,7 @@ layer_threshold_new <-
 
 
 # restrict various objects to the interval [lower, upper]
+#' @export
 snap <- function(x, lower, upper, ...) {
   UseMethod("snap")
 }
@@ -74,25 +75,11 @@ snap.default <- function(x, lower, upper, ...) {
 }
 
 #' @export
-snap.distribution <- function(x, lower, upper, ...) {
-  rlang::check_dots_empty()
-  arg_is_scalar(lower, upper)
-  dstn <- lapply(vec_data(x), snap, lower = lower, upper = upper)
-  distributional:::wrap_dist(dstn)
-}
-
-#' @export
-snap.dist_default <- function(x, lower, upper, ...) {
-  rlang::check_dots_empty()
-  x
-}
-
-#' @export
-snap.dist_quantiles <- function(x, lower, upper, ...) {
-  values <- field(x, "values")
-  quantile_levels <- field(x, "quantile_levels")
-  values <- snap(values, lower, upper)
-  new_quantiles(values = values, quantile_levels = quantile_levels)
+snap.quantile_pred <- function(x, lower, upper, ...) {
+  values <- as.matrix(x)
+  quantile_levels <- x %@% "quantile_levels"
+  values <- map(vctrs::vec_chop(values), ~ snap(.x, lower, upper))
+  quantile_pred(do.call(rbind, values), quantile_levels = quantile_levels)
 }
 
 #' @export

R/make_grf_quantiles.R

@@ -162,12 +162,12 @@ make_grf_quantiles <- function() {
     )
   )
 
-  # turn the predictions into a tibble with a dist_quantiles column
+  # turn the predictions into a tibble with a quantile_pred column
   process_qrf_preds <- function(x, object) {
     quantile_levels <- parsnip::extract_fit_engine(object)$quantiles.orig %>% sort()
     x <- x$predictions
     out <- lapply(vctrs::vec_chop(x), function(x) sort(drop(x)))
-    out <- dist_quantiles(out, list(quantile_levels))
+    out <- hardhat::quantile_pred(do.call(rbind, out), quantile_levels)
     return(dplyr::tibble(.pred = out))
   }
 

R/make_quantile_reg.R

@@ -110,21 +110,11 @@ make_quantile_reg <- function() {
 
   process_rq_preds <- function(x, object) {
     object <- parsnip::extract_fit_engine(object)
-    type <- class(object)[1]
-
-    # can't make a method because object is second
-    out <- switch(type,
-      rq = dist_quantiles(unname(as.list(x)), object$tau), # one quantile
-      rqs = {
-        x <- lapply(vctrs::vec_chop(x), function(x) sort(drop(x)))
-        dist_quantiles(x, list(object$tau))
-      },
-      cli_abort(c(
-        "Prediction is not implemented for this `rq` type.",
-        i = "See {.fun quantreg::rq}."
-      ))
-    )
-    return(dplyr::tibble(.pred = out))
+    if (!is.matrix(x)) x <- as.matrix(x)
+    rownames(x) <- NULL
+    n_pred_quantiles <- ncol(x)
+    quantile_levels <- object$tau
+    tibble(.pred = hardhat::quantile_pred(x, quantile_levels))
   }
 
   parsnip::set_pred(

R/make_smooth_quantile_reg.R

@@ -47,7 +47,7 @@
 #'     x = x[length(x) - 20] + ahead / 100 * 2 * pi,
 #'     ahead = NULL
 #'   ) %>%
-#'   pivot_wider(names_from = quantile_levels, values_from = values)
+#'   pivot_wider(names_from = distn_quantile_levels, values_from = distn_value)
 #' plot(x, y, pch = 16, xlim = c(pi, 2 * pi), col = "lightgrey")
 #' curve(sin(x), add = TRUE)
 #' abline(v = fd, lty = 2)
@@ -171,7 +171,7 @@ make_smooth_quantile_reg <- function() {
       x <- lapply(unname(split(
         p, seq(nrow(p))
       )), function(q) unname(sort(q, na.last = TRUE)))
-      dist_quantiles(x, list(object$tau))
+      quantile_pred(do.call(rbind, x), object$tau)
     })
     n_preds <- length(list_of_pred_distns[[1]])
     nout <- length(list_of_pred_distns)