Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

59 lines (53 sloc) 2.308 kb
#' 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)
})
}
})
Jump to Line
Something went wrong with that request. Please try again.