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