1#' @param quantiles conditional quantiles of y to calculate and display
2#' @param formula formula relating y variables to x variables
3#' @param method Quantile regression method to use. Available options are `"rq"` (for
4#'    [`quantreg::rq()`]) and `"rqss"` (for [`quantreg::rqss()`]).
5#' @inheritParams layer
6#' @inheritParams geom_point
7#' @section Computed variables:
8#' \describe{
9#'   \item{quantile}{quantile of distribution}
10#' }
11#' @export
12#' @rdname geom_quantile
13stat_quantile <- function(mapping = NULL, data = NULL,
14                          geom = "quantile", position = "identity",
15                          ...,
16                          quantiles = c(0.25, 0.5, 0.75),
17                          formula = NULL,
18                          method = "rq",
19                          method.args = list(),
20                          na.rm = FALSE,
21                          show.legend = NA,
22                          inherit.aes = TRUE) {
23  layer(
24    data = data,
25    mapping = mapping,
26    stat = StatQuantile,
27    geom = geom,
28    position = position,
29    show.legend = show.legend,
30    inherit.aes = inherit.aes,
31    params = list(
32      quantiles = quantiles,
33      formula = formula,
34      method = method,
35      method.args = method.args,
36      na.rm = na.rm,
37      ...
38    )
39  )
40}
41
42
43#' @rdname ggplot2-ggproto
44#' @format NULL
45#' @usage NULL
46#' @export
47StatQuantile <- ggproto("StatQuantile", Stat,
48  required_aes = c("x", "y"),
49
50  compute_group = function(data, scales, quantiles = c(0.25, 0.5, 0.75),
51                           formula = NULL, xseq = NULL, method = "rq",
52                           method.args = list(), lambda = 1, na.rm = FALSE) {
53    check_installed("quantreg", reason = "for `stat_quantile()`")
54
55    if (is.null(formula)) {
56      if (method == "rqss") {
57        formula <- eval(
58          substitute(y ~ qss(x, lambda = lambda)),
59          list(lambda = lambda)
60        )
61        # make qss function available in case it is needed;
62        # works around limitation in quantreg
63        qss <- quantreg::qss
64      } else {
65        formula <- y ~ x
66      }
67      message("Smoothing formula not specified. Using: ",
68        deparse(formula))
69    }
70
71    if (is.null(data$weight)) data$weight <- 1
72
73    if (is.null(xseq)) {
74      xmin <- min(data$x, na.rm = TRUE)
75      xmax <- max(data$x, na.rm = TRUE)
76      xseq <- seq(xmin, xmax, length.out = 100)
77    }
78    grid <- new_data_frame(list(x = xseq))
79
80    # if method was specified as a character string, replace with
81    # the corresponding function
82    if (identical(method, "rq")) {
83      method <- quantreg::rq
84    } else if (identical(method, "rqss")) {
85      method <- quantreg::rqss
86    } else {
87      method <- match.fun(method) # allow users to supply their own methods
88    }
89
90    rbind_dfs(lapply(quantiles, quant_pred, data = data, method = method,
91      formula = formula, weight = weight, grid = grid, method.args = method.args))
92  }
93)
94
95quant_pred <- function(quantile, data, method, formula, weight, grid,
96                       method.args = method.args) {
97  args <- c(list(quote(formula), data = quote(data), tau = quote(quantile),
98    weights = quote(weight)), method.args)
99  model <- do.call(method, args)
100
101  grid$y <- stats::predict(model, newdata = grid)
102  grid$quantile <- quantile
103  grid$group <- paste(data$group[1], quantile, sep = "-")
104
105  grid
106}
107