Skip to content
This repository
branch: dev
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 64 lines (58 sloc) 2.386 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63
##' Calculate components of a five-number summary
##'
##' The five number summary of a sample is the minimum, first quartile,
##' median, third quartile, and maximum.
##'
##' @section Aesthetics:
##' \Sexpr[results=rd,stage=build]{ggthemes:::rd_aesthetics("stat_fivenumber", ggthemes:::StatFivenumber)}
##'
##' @param na.rm If \code{FALSE} (the default), removes missing values with
##' a warning. If \code{TRUE} silently removes missing values.
##' @inheritParams ggplot2::stat_identity
##' @return A data frame with additional columns:
##' \item{width}{width of boxplot}
##' \item{ymin}{minimum}
##' \item{lower}{lower hinge, 25\% quantile}
##' \item{notchlower}{lower edge of notch = median - 1.58 * IQR / sqrt(n)}
##' \item{middle}{median, 50\% quantile}
##' \item{notchupper}{upper edge of notch = median + 1.58 * IQR / sqrt(n)}
##' \item{upper}{upper hinge, 75\% quantile}
##' \item{ymax}{maximum}
##' @seealso \code{\link{stat_boxplot}}
##' @export
stat_fivenumber <- function (mapping = NULL, data = NULL,
                             geom = "boxplot", position = "dodge",
                             na.rm = FALSE, ...) {
  StatFivenumber$new(mapping = mapping, data = data, geom = geom,
  position = position, na.rm = na.rm, ...)
}

StatFivenumber <- proto(ggplot2:::Stat, {
  objname <- "fivenumber"

  required_aes <- c("x", "y")
  default_geom <- function(.) GeomBoxplot

  calculate_groups <- function(., data, na.rm = FALSE, width = NULL, ...) {
    data <- remove_missing(data, na.rm, c("y", "weight"), name="stat_fivenumber",
      finite = TRUE)
    data$weight <- data$weight %||% 1
    width <- width %||% resolution(data$x) * 0.75

    .super$calculate_groups(., data, na.rm = na.rm, width = width, ...)
  }

  calculate <- function(., data, scales, width=NULL, na.rm = FALSE, ...) {
    with(data, {
      qs <- c(0, 0.25, 0.5, 0.75, 1)
      if (length(unique(weight)) != 1) {
        try_require("quantreg")
        stats <- as.numeric(coef(rq(y ~ 1, weights = weight, tau=qs)))
      } else {
        stats <- as.numeric(quantile(y, qs))
      }
      names(stats) <- c("ymin", "lower", "middle", "upper", "ymax")
      if (length(unique(x)) > 1) width <- diff(range(x)) * 0.9
      df <- as.data.frame(as.list(stats))
      transform(df,
        x = if (is.factor(x)) x[1] else mean(range(x)),
        width = width
      )
    })
  }
})
Something went wrong with that request. Please try again.