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