library(tidyverse)
library(rlang)
##
## Attaching package: 'rlang'
## The following objects are masked from 'package:purrr':
##
## %@%, flatten, flatten_chr, flatten_dbl, flatten_int, flatten_lgl,
## flatten_raw, invoke, splice
data_frame0 <- ggplot2:::data_frame0
unique0 <- ggplot2:::unique0
geom-bar.R
#' Bar charts
#'
#' There are two types of bar charts: `geom_bar()` and `geom_col()`.
#' `geom_bar()` makes the height of the bar proportional to the number of
#' cases in each group (or if the `weight` aesthetic is supplied, the sum
#' of the weights). If you want the heights of the bars to represent values
#' in the data, use `geom_col()` instead. `geom_bar()` uses `stat_count()` by
#' default: it counts the number of cases at each x position. `geom_col()`
#' uses `stat_identity()`: it leaves the data as is.
#'
#' A bar chart uses height to represent a value, and so the base of the
#' bar must always be shown to produce a valid visual comparison.
#' Proceed with caution when using transformed scales with a bar chart.
#' It's important to always use a meaningful reference point for the base of the bar.
#' For example, for log transformations the reference point is 1. In fact, when
#' using a log scale, `geom_bar()` automatically places the base of the bar at 1.
#' Furthermore, never use stacked bars with a transformed scale, because scaling
#' happens before stacking. As a consequence, the height of bars will be wrong
#' when stacking occurs with a transformed scale.
#'
#' By default, multiple bars occupying the same `x` position will be stacked
#' atop one another by [position_stack()]. If you want them to be dodged
#' side-to-side, use [position_dodge()] or [position_dodge2()]. Finally,
#' [position_fill()] shows relative proportions at each `x` by stacking the
#' bars and then standardising each bar to have the same height.
#'
#' @eval rd_orientation()
#'
#' @eval rd_aesthetics("geom", "bar")
#' @eval rd_aesthetics("geom", "col")
#' @eval rd_aesthetics("stat", "count")
#' @seealso
#' [geom_histogram()] for continuous data,
#' [position_dodge()] and [position_dodge2()] for creating side-by-side
#' bar charts.
#' @export
#' @inheritParams layer
#' @inheritParams geom_point
#' @param orientation The orientation of the layer. The default (`NA`)
#' automatically determines the orientation from the aesthetic mapping. In the
#' rare event that this fails it can be given explicitly by setting `orientation`
#' to either `"x"` or `"y"`. See the *Orientation* section for more detail.
#' @param just Adjustment for column placement. Set to `0.5` by default, meaning
#' that columns will be centered about axis breaks. Set to `0` or `1` to place
#' columns to the left/right of axis breaks. Note that this argument may have
#' unintended behaviour when used with alternative positions, e.g.
#' `position_dodge()`.
#' @param geom,stat Override the default connection between `geom_bar()` and
#' `stat_count()`. For more information about overriding these connections,
#' see how the [stat][layer_stats] and [geom][layer_geoms] arguments work.
#' @examples
#' # geom_bar is designed to make it easy to create bar charts that show
#' # counts (or sums of weights)
#' g <- ggplot(mpg, aes(class))
#' # Number of cars in each class:
#' g + geom_bar()
#' # Total engine displacement of each class
#' g + geom_bar(aes(weight = displ))
#' # Map class to y instead to flip the orientation
#' ggplot(mpg) + geom_bar(aes(y = class))
#'
#' # Bar charts are automatically stacked when multiple bars are placed
#' # at the same location. The order of the fill is designed to match
#' # the legend
#' g + geom_bar(aes(fill = drv))
#'
#' # If you need to flip the order (because you've flipped the orientation)
#' # call position_stack() explicitly:
#' ggplot(mpg, aes(y = class)) +
#' geom_bar(aes(fill = drv), position = position_stack(reverse = TRUE)) +
#' theme(legend.position = "top")
#'
#' # To show (e.g.) means, you need geom_col()
#' df <- data.frame(trt = c("a", "b", "c"), outcome = c(2.3, 1.9, 3.2))
#' ggplot(df, aes(trt, outcome)) +
#' geom_col()
#' # But geom_point() displays exactly the same information and doesn't
#' # require the y-axis to touch zero.
#' ggplot(df, aes(trt, outcome)) +
#' geom_point()
#'
#' # You can also use geom_bar() with continuous data, in which case
#' # it will show counts at unique locations
#' df <- data.frame(x = rep(c(2.9, 3.1, 4.5), c(5, 10, 4)))
#' ggplot(df, aes(x)) + geom_bar()
#' # cf. a histogram of the same data
#' ggplot(df, aes(x)) + geom_histogram(binwidth = 0.5)
#'
#' # Use `just` to control how columns are aligned with axis breaks:
#' df <- data.frame(x = as.Date(c("2020-01-01", "2020-02-01")), y = 1:2)
#' # Columns centered on the first day of the month
#' ggplot(df, aes(x, y)) + geom_col(just = 0.5)
#' # Columns begin on the first day of the month
#' ggplot(df, aes(x, y)) + geom_col(just = 1)
geom_bar <- function(mapping = NULL, data = NULL,
stat = "count", position = "stack",
...,
just = 0.5,
na.rm = FALSE,
orientation = NA,
show.legend = NA,
inherit.aes = TRUE) {
layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomBar,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list2(
just = just,
na.rm = na.rm,
orientation = orientation,
...
)
)
}
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
#' @include geom-rect.R
GeomBar <- ggproto("GeomBar", GeomRect,
required_aes = c("x", "y"),
# These aes columns are created by setup_data(). They need to be listed here so
# that GeomRect$handle_na() properly removes any bars that fall outside the defined
# limits, not just those for which x and y are outside the limits
non_missing_aes = c("xmin", "xmax", "ymin", "ymax"),
default_aes = aes(!!!GeomRect$default_aes, width = NULL),
setup_params = function(data, params) {
params$flipped_aes <- has_flipped_aes(data, params)
params
},
extra_params = c("just", "na.rm", "orientation"),
setup_data = function(data, params) {
data$flipped_aes <- params$flipped_aes
data <- flip_data(data, params$flipped_aes)
data$width <- data$width %||%
params$width %||% (min(vapply(
split(data$x, data$PANEL, drop = TRUE),
resolution, numeric(1), zero = FALSE
)) * 0.9)
data$just <- params$just %||% 0.5
data <- transform(data,
ymin = pmin(y, 0), ymax = pmax(y, 0),
xmin = x - width * just, xmax = x + width * (1 - just),
width = NULL, just = NULL
)
flip_data(data, params$flipped_aes)
},
rename_size = TRUE
)
stat-count.R
#' @eval rd_computed_vars(
#' count = "number of points in bin.",
#' prop = "groupwise proportion"
#' )
#' @seealso [stat_bin()], which bins data in ranges and counts the
#' cases in each range. It differs from `stat_count()`, which counts the
#' number of cases at each `x` position (without binning into ranges).
#' [stat_bin()] requires continuous `x` data, whereas
#' `stat_count()` can be used for both discrete and continuous `x` data.
#'
#' @export
#' @rdname geom_bar
stat_count <- function(mapping = NULL, data = NULL,
geom = "bar", position = "stack",
...,
na.rm = FALSE,
orientation = NA,
show.legend = NA,
inherit.aes = TRUE) {
params <- list2(
na.rm = na.rm,
orientation = orientation,
...
)
layer(
data = data,
mapping = mapping,
stat = StatCount,
geom = geom,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = params
)
}
#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
#' @include stat-.R
StatCount <- ggproto("StatCount", Stat,
required_aes = "x|y",
default_aes = aes(x = after_stat(count), y = after_stat(count), weight = 1),
setup_params = function(self, data, params) {
params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE)
has_x <- !(is.null(data$x) && is.null(params$x))
has_y <- !(is.null(data$y) && is.null(params$y))
if (!has_x && !has_y) {
cli::cli_abort("{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic.")
}
if (has_x && has_y) {
cli::cli_abort("{.fn {snake_class(self)}} must only have an {.field x} {.emph or} {.field y} aesthetic.")
}
if (is.null(params$width)) {
x <- if (params$flipped_aes) "y" else "x"
params$width <- resolution(data[[x]], discrete = TRUE) * 0.9
}
params
},
extra_params = c("na.rm", "orientation"),
compute_group = function(self, data, scales, width = NULL, flipped_aes = FALSE) {
data <- flip_data(data, flipped_aes)
x <- data$x
weight <- data$weight %||% rep(1, length(x))
count <- as.vector(rowsum(weight, x, na.rm = TRUE))
bars <- data_frame0(
count = count,
prop = count / sum(abs(count)),
x = sort(unique0(x)),
width = width,
flipped_aes = flipped_aes,
.size = length(count)
)
flip_data(bars, flipped_aes)
},
dropped_aes = "weight"
)
diamonds |>
dplyr::sample_n(15) |>
ggplot() +
aes(fill = color) +
aes(y = "all") +
geom_bar()
last_plot() +
coord_polar()
diamonds |>
dplyr::sample_n(15) |>
ggplot() +
aes(fill = color) +
aes(y = "all") +
geom_bar()
Start fiddling
GeomBar$required_aes <- "fill"
StatCount <- ggproto("StatCount", Stat,
required_aes = "fill",
default_aes = aes(x = NULL, y = after_stat(count), weight = 1),
setup_params = function(self, data, params) {
# params$flipped_aes <- has_flipped_aes(data, params, main_is_orthogonal = FALSE)
params$flipped_aes <- FALSE
# has_x <- !(is.null(data$x) && is.null(params$x))
# has_y <- !(is.null(data$y) && is.null(params$y))
# if (!has_x && !has_y) {
# cli::cli_abort("{.fn {snake_class(self)}} requires an {.field x} or {.field y} aesthetic.")
# }
# if (has_x && has_y) {
# cli::cli_abort("{.fn {snake_class(self)}} must only have an {.field x} {.emph or} {.field y} aesthetic.")
# }
# if (is.null(params$width)) {
# # x <- if (params$flipped_aes) "y" else "x"
# x <- "x"
params$width <- resolution(data[[x]]) * 0.9
# }
params
},
extra_params = c("na.rm", "orientation"),
compute_group = function(self, data, scales, width = NULL, flipped_aes = FALSE) {
data$x <- .5
data <- flip_data(data, flipped_aes)
x <- data$x
weight <- data$weight %||% rep(1, length(x))
count <- as.vector(rowsum(weight, x, na.rm = TRUE))
bars <- data_frame0(
count = count,
prop = count / sum(abs(count)),
x = sort(unique0(x)),
width = width,
flipped_aes = flipped_aes,
.size = length(count)
)
flip_data(bars, flipped_aes)
},
dropped_aes = "weight"
)
diamonds |>
dplyr::sample_n(15) |>
ggplot() +
aes(fill = color) +
aes(x = "all") +
geom_bar() +
coord_polar(theta = "y")
diamonds |>
dplyr::sample_n(15) |>
ggplot() +
aes(fill = color) +
aes(x = "all") +
geom_bar() +
# layer(geom = GeomBar, stat = StatCount, position = "stack") +
coord_polar(theta = "y")
