#' @importFrom grid grobTree
GeomHdr <- ggplot2::ggproto("GeomHdr", ggplot2::Geom,
required_aes = c("xmin", "xmax", "ymin", "ymax"),
default_aes = ggplot2::aes(weight = 1, colour = "grey40", fill = "grey60", size = 0.5,
alpha = 0.5, width = 0.75, shape = 16, linetype = "solid", outlier.colour = "black",
outlier.shape = 19, outlier.size = 1.5, outlier.stroke = 0.5),
draw_key = ggplot2::draw_key_rect,
draw_group = function(data, panel_scales, coord, fatten = 2, ...) {
common <- unique(data.frame(
colour = data$colour,
size = data$size,
linetype = data$linetype,
fill = alpha(data$fill, data$alpha),
group = 1,
stringsAsFactors = FALSE
))
outliers <- data$out[[1]]
if (!is.null(outliers) && length(outliers) >= 1) {
outliers <- data.frame(
y = outliers,
x = data$x[1],
colour = data$outlier.colour[1] %||% data$colour[1],
shape = data$outlier.shape[1] %||% data$shape[1],
size = data$outlier.size[1] %||% data$size[1],
stroke = data$outlier.stroke[1] %||% data$stroke[1],
fill = NA,
alpha = NA,
stringsAsFactors = FALSE)
outliers_grob <- GeomPoint$draw_panel(outliers, panel_scales, coord)
} else {
outliers_grob <- NULL
}
medians <- unique(data[,c("xmin", "xmax", "mode", "size")])
medians$alpha <- NA
medians <- data.frame(medians, common, row.names=NULL)
medians$size <- medians$size * fatten
medians <- transform(medians,
x = xmin,
xend = xmax,
y = mode,
yend = mode)
data$linetype <- "blank"
ggplot2:::ggname("geom_hdr", grobTree(
outliers_grob,
GeomRect$draw_panel(data, panel_scales, coord),
GeomSegment$draw_panel(medians, panel_scales, coord)
))
},
draw_legend = function(data, ...) {
with(data, grobTree(
rectGrob(gp = gpar(col = colour, fill = alpha(fill, alpha), lty = linetype))
))
}
)
#' @rdname stat_hdr
#'
#' @inheritParams ggplot2::geom_point
#' @inheritParams ggplot2::geom_boxplot
#' @inheritParams ggplot2::geom_violin
#' @export
#' @examples
#' \donttest{
#' require(ggplot2)
#' data(diamonds)
#' gghdr(diamonds, color, price)
#' ggplot(data=diamonds, aes(x=color, y=price)) + geom_hdr(alpha=0.5)
#' gghdr(diamonds, cut, price, probs=c(50,25,12.5, 6.25, 1), fill=cut) +
#' scale_fill_brewer(palette="Set1") +
#' scale_colour_brewer(palette="Set1")
#'
#' p <- ggplot(mtcars, aes(factor(cyl), mpg))
#'
#' p + geom_hdr()
#' p + geom_hdr(aes(fill=factor(..probs..)), probs=c(.5, .25, .125)) + scale_fill_brewer()
#' gghdr(mtcars, factor(cyl), mpg, probs=c(50,25,12.5))
#'
#' qplot(factor(cyl), mpg, data = mtcars, geom = "hdr")
#'
#' p + geom_hdr() + geom_jitter(height = 0)
#' p + geom_hdr() + coord_flip()
#' qplot(factor(cyl), mpg, data = mtcars, geom = "hdr") +
#' coord_flip()
#'
#' # Add aesthetic mappings
#' # Note that hdrs are automatically dodged when any aesthetic is
#' # a factor
#' p + geom_hdr(aes(fill = cyl))
#' p + geom_hdr(aes(fill = factor(cyl)))
#' p + geom_hdr(aes(fill = factor(vs)))
#' p + geom_hdr(aes(fill = factor(am)))
#'
#' # Set aesthetics to fixed value
#' p + geom_hdr(fill = "grey80", colour = "#3366FF")
#' qplot(factor(cyl), mpg, data = mtcars, geom = "hdr",
#' colour = I("#3366FF"))
#'
#' x <- rnorm(2000)
#' group <- rep(1:20, 100)
#' y <- factor(rep(c(1,2),1000))
#' qplot(y,x,facets=~group, fill=factor(y), geom="hdr")
#' qplot(y,x,facets=~group, fill=factor(..probs..), geom="hdr") + scale_fill_brewer()
#' }
geom_hdr <- function (mapping = NULL, data = NULL, stat = "hdr", position = "dodge", show.legend = NA, inherit.aes = TRUE, width = 0.9, alpha = 0.25,
...) {
layer(
geom = GeomHdr, mapping = mapping, data = data, stat = stat,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(width = width, ...)
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.