1#' @include stat-.r
2NULL
3
4#' Reference lines: horizontal, vertical, and diagonal
5#'
6#' These geoms add reference lines (sometimes called rules) to a plot, either
7#' horizontal, vertical, or diagonal (specified by slope and intercept).
8#' These are useful for annotating plots.
9#'
10#' These geoms act slightly differently from other geoms. You can supply the
11#' parameters in two ways: either as arguments to the layer function,
12#' or via aesthetics. If you use arguments, e.g.
13#' `geom_abline(intercept = 0, slope = 1)`, then behind the scenes
14#' the geom makes a new data frame containing just the data you've supplied.
15#' That means that the lines will be the same in all facets; if you want them
16#' to vary across facets, construct the data frame yourself and use aesthetics.
17#'
18#' Unlike most other geoms, these geoms do not inherit aesthetics from the plot
19#' default, because they do not understand x and y aesthetics which are
20#' commonly set in the plot. They also do not affect the x and y scales.
21#'
22#' @section Aesthetics:
23#' These geoms are drawn using with [geom_line()] so support the
24#' same aesthetics: `alpha`, `colour`, `linetype` and
25#' `size`. They also each have aesthetics that control the position of
26#' the line:
27#'
28#'   - `geom_vline()`: `xintercept`
29#'   - `geom_hline()`: `yintercept`
30#'   - `geom_abline()`: `slope` and `intercept`
31#'
32#' @seealso See [geom_segment()] for a more general approach to
33#'   adding straight line segments to a plot.
34#' @inheritParams layer
35#' @inheritParams geom_point
36#' @param mapping Set of aesthetic mappings created by [aes()] or [aes_()].
37#' @param xintercept,yintercept,slope,intercept Parameters that control the
38#'   position of the line. If these are set, `data`, `mapping` and
39#'   `show.legend` are overridden.
40#' @export
41#' @examples
42#' p <- ggplot(mtcars, aes(wt, mpg)) + geom_point()
43#'
44#' # Fixed values
45#' p + geom_vline(xintercept = 5)
46#' p + geom_vline(xintercept = 1:5)
47#' p + geom_hline(yintercept = 20)
48#'
49#' p + geom_abline() # Can't see it - outside the range of the data
50#' p + geom_abline(intercept = 20)
51#'
52#' # Calculate slope and intercept of line of best fit
53#' coef(lm(mpg ~ wt, data = mtcars))
54#' p + geom_abline(intercept = 37, slope = -5)
55#' # But this is easier to do with geom_smooth:
56#' p + geom_smooth(method = "lm", se = FALSE)
57#'
58#' # To show different lines in different facets, use aesthetics
59#' p <- ggplot(mtcars, aes(mpg, wt)) +
60#'   geom_point() +
61#'   facet_wrap(~ cyl)
62#'
63#' mean_wt <- data.frame(cyl = c(4, 6, 8), wt = c(2.28, 3.11, 4.00))
64#' p + geom_hline(aes(yintercept = wt), mean_wt)
65#'
66#' # You can also control other aesthetics
67#' ggplot(mtcars, aes(mpg, wt, colour = wt)) +
68#'   geom_point() +
69#'   geom_hline(aes(yintercept = wt, colour = wt), mean_wt) +
70#'   facet_wrap(~ cyl)
71geom_abline <- function(mapping = NULL, data = NULL,
72                        ...,
73                        slope,
74                        intercept,
75                        na.rm = FALSE,
76                        show.legend = NA) {
77
78  # If nothing set, default to y = x
79  if (is.null(mapping) && missing(slope) && missing(intercept)) {
80    slope <- 1
81    intercept <- 0
82  }
83
84  # Act like an annotation
85  if (!missing(slope) || !missing(intercept)) {
86
87    # Warn if supplied mapping and/or data is going to be overwritten
88    if (!is.null(mapping)) {
89      warn_overwritten_args("geom_abline()", "mapping", c("slope", "intercept"))
90    }
91    if (!is.null(data)) {
92      warn_overwritten_args("geom_abline()", "data", c("slope", "intercept"))
93    }
94
95    if (missing(slope)) slope <- 1
96    if (missing(intercept)) intercept <- 0
97    n_slopes <- max(length(slope), length(intercept))
98
99    data <- new_data_frame(list(
100      intercept = intercept,
101      slope = slope
102    ), n = n_slopes)
103    mapping <- aes(intercept = intercept, slope = slope)
104    show.legend <- FALSE
105  }
106
107  layer(
108    data = data,
109    mapping = mapping,
110    stat = StatIdentity,
111    geom = GeomAbline,
112    position = PositionIdentity,
113    show.legend = show.legend,
114    inherit.aes = FALSE,
115    params = list(
116      na.rm = na.rm,
117      ...
118    )
119  )
120}
121
122#' @rdname ggplot2-ggproto
123#' @format NULL
124#' @usage NULL
125#' @export
126GeomAbline <- ggproto("GeomAbline", Geom,
127  draw_panel = function(data, panel_params, coord) {
128    ranges <- coord$backtransform_range(panel_params)
129
130    if (coord$clip == "on" && coord$is_linear()) {
131      # Ensure the line extends well outside the panel to avoid visible line
132      # ending for thick lines
133      ranges$x <- ranges$x + c(-1, 1) * diff(ranges$x)
134    }
135
136    data$x    <- ranges$x[1]
137    data$xend <- ranges$x[2]
138    data$y    <- ranges$x[1] * data$slope + data$intercept
139    data$yend <- ranges$x[2] * data$slope + data$intercept
140
141    GeomSegment$draw_panel(unique(data), panel_params, coord)
142  },
143
144  default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = NA),
145  required_aes = c("slope", "intercept"),
146
147  draw_key = draw_key_abline
148)
149
150warn_overwritten_args <- function(fun_name, overwritten_arg, provided_args, plural_join = " and/or ") {
151  overwritten_arg_text <- paste0("`", overwritten_arg, "`")
152
153  n_provided_args <- length(provided_args)
154  if (n_provided_args == 1) {
155    provided_arg_text <- paste0("`", provided_args, "`")
156    verb <- "was"
157  } else if (n_provided_args == 2) {
158    provided_arg_text <- paste0("`", provided_args, "`", collapse = plural_join)
159    verb <- "were"
160  } else {
161    provided_arg_text <- paste0(
162      paste0("`", provided_args[-n_provided_args], "`", collapse = ", "),
163      ",", plural_join,
164      "`", provided_args[n_provided_args], "`"
165    )
166    verb <- "were"
167  }
168
169  warn(glue("{fun_name}: Ignoring {overwritten_arg_text} because {provided_arg_text} {verb} provided."))
170}
171