R/pivot_quantiles.R

Defines functions validate_pivot_quantiles pivot_quantiles pivot_quantiles_wider pivot_quantiles_longer nested_quantiles

Documented in nested_quantiles pivot_quantiles_longer pivot_quantiles_wider

#' 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, "quantile_pred")) {
    return(x %>% as_tibble() %>% tidyr::nest(.by = .row) %>%
      dplyr::select(data))
  }
  cli_abort(
    "`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
#' the quantile levels serving as 1 column and the values as another. If
#' multiple columns are selected, these will be prefixed with the column name.
#'
#' @param .data A data frame, or a data frame extension such as a tibble or
#'   epi_df.
#' @param ... <[`tidy-select`][dplyr::dplyr_tidy_select]> One unquoted
#'   expressions separated by commas. Variable names can be used as if they
#'   were positions in the data frame. Note that only one variable
#'   can be selected for this operation.
#'
#' @return An object of the same class as `.data`.
#' @export
#'
#' @examples
#' d1 <- quantile_pred(rbind(1:3, 2:4), 1:3 / 4)
#' d2 <- quantile_pred(rbind(2:4, 3:5), 2:4 / 5)
#' tib <- tibble(g = c("a", "b"), d1 = d1, d2 = d2)
#'
#' pivot_quantiles_longer(tib, "d1")
#' pivot_quantiles_longer(tib, dplyr::ends_with("1"))
#' pivot_quantiles_longer(tib, d2)
pivot_quantiles_longer <- function(.data, ...) {
  col <- validate_pivot_quantiles(.data, ...)
  .data$.row <- seq_len(vctrs::vec_size(.data))
  long_tib <- as_tibble(.data[[col]])
  .data <- select(.data, !all_of(col))
  names(long_tib)[1:2] <- c(glue::glue("{col}_value"), glue::glue("{col}_quantile_level"))
  left_join(.data, long_tib, by = ".row") %>%
    select(!.row)
}

#' Pivot a column containing `quantile_pred` wider
#'
#' Any selected columns that contain `quantile_pred` will be "widened" with
#' the "taus" (quantile) serving as names and the values in the data frame.
#' When pivoting multiple columns, the original column name will be used as
#' a prefix.
#'
#' @inheritParams pivot_quantiles_longer
#'
#' @return An object of the same class as `.data`
#' @export
#'
#' @examples
#' d1 <- quantile_pred(rbind(1:3, 2:4), 1:3 / 4)
#' d2 <- quantile_pred(rbind(2:4, 3:5), 2:4 / 5)
#' tib <- tibble(g = c("a", "b"), d1 = d1, d2 = d2)
#'
#' pivot_quantiles_wider(tib, "d1")
#' pivot_quantiles_wider(tib, dplyr::ends_with("2"))
#' pivot_quantiles_wider(tib, d2)
pivot_quantiles_wider <- function(.data, ...) {
  col <- validate_pivot_quantiles(.data, ...)
  .data$.row <- seq_len(vctrs::vec_size(.data))
  wide_tib <- as_tibble(.data[[col]]) %>%
    tidyr::pivot_wider(names_from = .quantile_levels, values_from = .pred_quantile)
  .data <- select(.data, !all_of(col))
  left_join(.data, wide_tib, by = ".row") %>%
    select(!.row)
}

pivot_quantiles <- function(.data, ...) {
  lifecycle::deprecate_stop("0.0.6", "pivot_quantiles()", "pivot_quantiles_wider()")
}

validate_pivot_quantiles <- function(.data, ..., call = caller_env()) {
  expr <- rlang::expr(c(...))
  cols <- names(tidyselect::eval_select(expr, .data))
  if (length(cols) > 1L) {
    cli_abort(
      "Only one column can be pivotted. Can not pivot all of: {.var {cols}}.",
      call = call
    )
  }
  if (!inherits(.data[[cols]], "quantile_pred")) {
    cli_abort(
      "{.var {cols}} is not {.cls `quantile_pred`}. Cannot pivot it.",
      call = call
    )
  }
  cols
}
cmu-delphi/epipredict documentation built on June 14, 2025, 2:41 a.m.