tests pass, checks don't

Author: dajmcdon

NAMESPACE

@@ -119,6 +119,7 @@ S3method(vec_arith,quantile_pred)
 S3method(vec_arith.numeric,quantile_pred)
 S3method(vec_arith.quantile_pred,numeric)
 S3method(vec_math,quantile_pred)
+S3method(vec_proxy_equal,quantile_pred)
 S3method(weighted_interval_score,quantile_pred)
 export("%>%")
 export(Add_model)
@@ -137,7 +138,6 @@ export(arx_class_epi_workflow)
 export(arx_classifier)
 export(arx_fcast_epi_workflow)
 export(arx_forecaster)
-export(as_epi_df)
 export(as_tibble)
 export(autoplot)
 export(bake)
@@ -149,12 +149,14 @@ export(climate_args_list)
 export(climatological_forecaster)
 export(default_epi_recipe_blueprint)
 export(detect_layer)
+export(dist_quantiles)
 export(epi_recipe)
 export(epi_recipe_blueprint)
 export(epi_workflow)
 export(extract_argument)
 export(extract_frosting)
 export(extract_layers)
+export(extract_quantile_levels)
 export(extrapolate_quantiles)
 export(filter)
 export(fit)
@@ -182,13 +184,15 @@ export(layer_quantile_distn)
 export(layer_residual_quantiles)
 export(layer_threshold)
 export(layer_unnest)
+export(nested_quantiles)
 export(new_default_epi_recipe_blueprint)
 export(new_epi_recipe_blueprint)
 export(pivot_longer)
 export(pivot_quantiles_longer)
 export(pivot_quantiles_wider)
 export(pivot_wider)
 export(prep)
+export(quantile_pred)
 export(quantile_reg)
 export(rand_id)
 export(remove_epi_recipe)
@@ -276,6 +280,7 @@ importFrom(ggplot2,geom_linerange)
 importFrom(ggplot2,geom_point)
 importFrom(ggplot2,geom_ribbon)
 importFrom(glue,glue)
+importFrom(hardhat,extract_quantile_levels)
 importFrom(hardhat,extract_recipe)
 importFrom(hardhat,quantile_pred)
 importFrom(hardhat,refresh_blueprint)
@@ -284,6 +289,7 @@ importFrom(lubridate,"%m-%")
 importFrom(lubridate,leap_year)
 importFrom(lubridate,month)
 importFrom(lubridate,yday)
+importFrom(lifecycle,deprecated)
 importFrom(magrittr,"%>%")
 importFrom(magrittr,extract2)
 importFrom(recipes,bake)
@@ -330,8 +336,12 @@ importFrom(tidyr,pivot_wider)
 importFrom(tidyr,unnest)
 importFrom(tidyselect,all_of)
 importFrom(utils,capture.output)
+importFrom(vctrs,as_list_of)
+importFrom(vctrs,new_vctr)
 importFrom(vctrs,vec_arith)
 importFrom(vctrs,vec_arith.numeric)
 importFrom(vctrs,vec_cast)
 importFrom(vctrs,vec_math)
+importFrom(vctrs,vec_proxy_equal)
+importFrom(vctrs,vec_recycle_common)
 importFrom(workflows,extract_preprocessor)

R/epipredict-package.R

@@ -10,6 +10,7 @@
 #' @importFrom dplyr inner_join
 #' @importFrom dplyr summarize filter mutate select left_join rename ungroup
 #' @importFrom epiprocess growth_rate growth_rate_params is_epi_df
+#' @importFrom lifecycle deprecated
 #' @importFrom magrittr extract2
 #' @importFrom rlang := !! %||% as_function global_env set_names !!! caller_arg
 #' @importFrom rlang is_logical is_true inject enquo enquos expr sym arg_match

R/extrapolate_quantiles.R

@@ -18,9 +18,9 @@
 #' @export
 #'
 #' @examples
-#' dstn <- quantile_dstn(rbind(1:4, 8:11), c(.2, .4, .6, .8))
+#' dstn <- quantile_pred(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)))
+#' as_tibble(extrapolate_quantiles(dstn, probs = c(.25, 0.5, .75)))
 extrapolate_quantiles <- function(x, probs, replace_na = TRUE, ...) {
   UseMethod("extrapolate_quantiles")
 }

R/layer_point_from_distn.R

@@ -78,10 +78,10 @@ layer_point_from_distn_new <- function(type, name, id) {
 slather.layer_point_from_distn <-
   function(object, components, workflow, new_data, ...) {
     dstn <- components$predictions$.pred
-    if (!inherits(dstn, "distribution")) {
-      rlang::warn(
+    if (!(inherits(dstn, "quantile_pred") | inherits(dstn, "distribution"))) {
+      cli_warn(
         c("`layer_point_from_distn` requires distributional predictions.",
-          i = "These are of class {class(dstn)}. Ignoring this layer."
+          i = "These are of class {.cls {class(dstn)}}. Ignoring this layer."
         )
       )
       return(components)

R/layer_threshold_preds.R

@@ -63,6 +63,7 @@ layer_threshold_new <-
 
 # restrict various objects to the interval [lower, upper]
 #' @export
+#' @keywords internal
 snap <- function(x, lower, upper, ...) {
   UseMethod("snap")
 }

R/pivot_quantiles.R

@@ -1,3 +1,53 @@
+#' Turn a vector of quantile distributions into a list-col
+#'
+#' `r lifecycle::badge("deprecated")`
+#'
+#' This function is deprecated. The recommended alternative is
+#' [hardhat::quantile_pred()] with [tibble::as_tibble()]
+
+#'
+#' @param x a `distribution` containing `dist_quantiles`
+#'
+#' @return a list-col
+#' @export
+#'
+#' @examples
+#' .pred_quantile <- quantile_pred(matrix(rnorm(20), 5), c(.2, .4, .6, .8))
+#' nested_quantiles(.pred_quantile)
+#'
+#' .pred_quantile %>%
+#'   as_tibble() %>%
+#'   tidyr::nest(.by = .row) %>%
+#'   dplyr::select(-.row)
+#'
+nested_quantiles <- function(x) {
+  lifecycle::deprecate_warn("0.1.11", "nested_quantiles()", "hardhat::quantile_pred()")
+  if (inherits(x, "distribution")) {
+    if (requireNamespace("distributional")) {
+      x <- vctrs::vec_data(x)
+      return(distributional:::dist_apply(x, .f = function(z) {
+        as_tibble(vctrs::vec_data(z)) %>%
+          mutate(across(everything(), as.double)) %>%
+          vctrs::list_of()
+      }))
+    } else {
+      cli_abort(c(
+        "`nested_quantiles()` is deprecated and the {.pkg distributional}",
+        `!` = "package is not installed.",
+        i = "See {.fn hardhat::quantile_pred}."
+      ))
+    }
+  }
+  if (inherits(x, "quantile_pred")) {
+    return(x %>% as_tibble() %>% tidyr::nest(.by = .row) %>%
+      dplyr::select(data))
+  }
+  cli_abort(c(
+    "`nested_quantiles()` is deprecated. See {.fn hardhat::quantile_pred}."
+  ))
+}
+
+
 #' Pivot a column containing `quantile_pred` longer
 #'
 #' A column that contains `quantile_pred` will be "lengthened" with

R/quantile_pred-methods.R

@@ -1,3 +1,40 @@
+#' A distribution parameterized by a set of quantiles
+#'
+#' `r lifecycle::badge("deprecated")`
+#'
+#' This function is deprecated. The recommended alternative is
+#' [hardhat::quantile_pred()].
+#'
+#' @param values A vector (or list of vectors) of values.
+#' @param quantile_levels A vector (or list of vectors) of probabilities
+#'   corresponding to `values`.
+#'
+#' When creating multiple sets of `values`/`quantile_levels` resulting in
+#' different distributions, the sizes must match. See the examples below.
+#'
+#' @return A vector of class `"distribution"`.
+#'
+#' @export
+#' @keywords internal
+#'
+#' @importFrom vctrs as_list_of vec_recycle_common new_vctr
+dist_quantiles <- function(values, quantile_levels) {
+  lifecycle::deprecate_warn("0.1.11", "dist_quantiles()", "hardhat::quantile_pred()")
+  if (is.list(values)) {
+    n <- length(values)
+    values <- unlist(values)
+    return(quantile_pred(matrix(values, nrow = n, byrow = TRUE), quantile_levels))
+  } else if (is.matrix(values)) {
+    return(quantile_pred(values, quantile_levels))
+  } else if (is.vector(values)) {
+    return(quantile_pred(matrix(values, nrow = 1), quantile_levels))
+  }
+  cli_abort(c(
+    "`dist_quantiles()` is deprecated and the format of `values` could not",
+    `!` = "be automatically converted to work with the replacement.",
+    i = "See {.fn hardhat::quantile_pred}."
+  ))
+}
 
 # placeholder to avoid errors, but not ideal
 #' @importFrom hardhat quantile_pred
@@ -6,6 +43,74 @@ mean.quantile_pred <- function(x, na.rm = FALSE, ...) {
   median(x, ...)
 }
 
+# These next 3 functions should probably be added via PR to {hardhat}
+# Only the third is actually *needed* at the moment.
+# The second doesn't work correctly (not sure why), but leaving here for the
+# future.
+#
+# We only export the third.
+#
+# self-self method, should work only if attr(quantile_levels) are compatible
+# #' @importFrom vctrs vec_ptype2 vec_cast
+# #' @importFrom hardhat extract_quantile_levels
+# #' @export
+# #' @keywords internal
+# vec_ptype2.quantile_pred.quantile_pred <- function(
+#     x, y, ..., x_arg = "", y_arg = "", call = caller_env()
+# ) {
+#   if (all(extract_quantile_levels(y) %in% extract_quantile_levels(x))) {
+#     return(x)
+#   }
+#   if (all(extract_quantile_levels(x) %in% extract_quantile_levels(y))) {
+#     return(y)
+#   }
+#   vctrs::stop_incompatible_type(
+#     x, y, x_arg = x_arg, y_arg = y_arg,
+#     details = "`quantile_levels` must be compatible (a superset/subset relation)."
+#   )
+# }
+
+# currently doesn't work
+# #' @export
+# vec_cast.quantile_pred.quantile_pred <- function(
+#     x, to, ..., x_arg = caller_arg(x), to_arg = caller_arg(to),
+#     call = caller_env()
+# ) {
+#   to_ql <- extract_quantile_levels(to)
+#   x_ql <- extract_quantile_levels(x)
+#   x_in_to <- x_ql %in% to_ql
+#   to_in_x <- to_ql %in% x_ql
+#   if (all(x_in_to)) {
+#     mat <- matrix(NA, ncol = length(to_ql))
+#     mat[ , to_in_x] <- c(as.matrix(x))
+#   } else if (all(to_in_x)) {
+#     mat <- as.matrix(x)[ , x_in_to, drop = FALSE]
+#   } else {
+#     vctrs::stop_incompatible_type(
+#       x, to, x_arg = x_arg, y_arg = to_arg,
+#       details = "`quantile_levels` must be compatible (a superset/subset relation)."
+#     )
+#   }
+#   quantile_pred(mat, to_ql)
+# }
+
+
+# Convert the quantile_pred to a data frame (named with the .quantile_levels)
+# This powers vec_proxy_equal (and hence ==, !=, is.na, etc)
+# It also powers vec_proxy_compare, so, given matching colnames, these should
+# work out of the box.
+#
+#' @importFrom vctrs vec_proxy_equal
+#' @export
+vec_proxy_equal.quantile_pred <- function(x, ...) {
+  as_tibble(x) %>%
+    tidyr::pivot_wider(
+      names_from = .quantile_levels,
+      values_from = .pred_quantile
+    ) %>%
+    dplyr::select(-.row)
+}
+
 
 # quantiles by treating quantile_pred like a distribution -----------------
 

R/reexports-tidymodels.R

@@ -0,0 +1,37 @@
+#' @importFrom generics fit
+#' @export
+generics::fit
+
+#' @importFrom generics forecast
+#' @export
+generics::forecast
+
+#' @importFrom recipes prep
+#' @export
+recipes::prep
+
+#' @importFrom recipes bake
+#' @export
+recipes::bake
+
+#' @importFrom recipes rand_id
+#' @export
+recipes::rand_id
+
+#' @importFrom tibble tibble as_tibble
+#' @export
+tibble::tibble
+
+#' @export
+tibble::as_tibble
+
+#' @importFrom generics tidy
+#' @export
+generics::tidy
+
+#' @importFrom hardhat quantile_pred extract_quantile_levels
+#' @export
+hardhat::quantile_pred
+
+#' @export
+hardhat::extract_quantile_levels

R/utils-misc.R

@@ -47,7 +47,7 @@ format_varnames <- function(x, empty = "*none*") {
   if (length(x) == 0L) {
     empty
   } else {
-    as.character(syms(x))
+    as.character(rlang::syms(x))
   }
 }