1#' Connect observations
2#'
3#' `geom_path()` connects the observations in the order in which they appear
4#' in the data. `geom_line()` connects them in order of the variable on the
5#' x axis. `geom_step()` creates a stairstep plot, highlighting exactly
6#' when changes occur. The `group` aesthetic determines which cases are
7#' connected together.
8#'
9#' An alternative parameterisation is [geom_segment()], where each line
10#' corresponds to a single case which provides the start and end coordinates.
11#'
12#' @eval rd_orientation()
13#'
14#' @eval rd_aesthetics("geom", "path")
15#' @inheritParams layer
16#' @inheritParams geom_bar
17#' @param lineend Line end style (round, butt, square).
18#' @param linejoin Line join style (round, mitre, bevel).
19#' @param linemitre Line mitre limit (number greater than 1).
20#' @param arrow Arrow specification, as created by [grid::arrow()].
21#' @seealso
22#'  [geom_polygon()]: Filled paths (polygons);
23#'  [geom_segment()]: Line segments
24#' @section Missing value handling:
25#' `geom_path()`, `geom_line()`, and `geom_step()` handle `NA` as follows:
26#'
27#' * If an `NA` occurs in the middle of a line, it breaks the line. No warning
28#'   is shown, regardless of whether `na.rm` is `TRUE` or `FALSE`.
29#' * If an `NA` occurs at the start or the end of the line and `na.rm` is `FALSE`
30#'   (default), the `NA` is removed with a warning.
31#' * If an `NA` occurs at the start or the end of the line and `na.rm` is `TRUE`,
32#'   the `NA` is removed silently, without warning.
33#' @export
34#' @examples
35#' # geom_line() is suitable for time series
36#' ggplot(economics, aes(date, unemploy)) + geom_line()
37#' ggplot(economics_long, aes(date, value01, colour = variable)) +
38#'   geom_line()
39#'
40#' # You can get a timeseries that run vertically by setting the orientation
41#' ggplot(economics, aes(unemploy, date)) + geom_line(orientation = "y")
42#'
43#' # geom_step() is useful when you want to highlight exactly when
44#' # the y value changes
45#' recent <- economics[economics$date > as.Date("2013-01-01"), ]
46#' ggplot(recent, aes(date, unemploy)) + geom_line()
47#' ggplot(recent, aes(date, unemploy)) + geom_step()
48#'
49#' # geom_path lets you explore how two variables are related over time,
50#' # e.g. unemployment and personal savings rate
51#' m <- ggplot(economics, aes(unemploy/pop, psavert))
52#' m + geom_path()
53#' m + geom_path(aes(colour = as.numeric(date)))
54#'
55#' # Changing parameters ----------------------------------------------
56#' ggplot(economics, aes(date, unemploy)) +
57#'   geom_line(colour = "red")
58#'
59#' # Use the arrow parameter to add an arrow to the line
60#' # See ?arrow for more details
61#' c <- ggplot(economics, aes(x = date, y = pop))
62#' c + geom_line(arrow = arrow())
63#' c + geom_line(
64#'   arrow = arrow(angle = 15, ends = "both", type = "closed")
65#' )
66#'
67#' # Control line join parameters
68#' df <- data.frame(x = 1:3, y = c(4, 1, 9))
69#' base <- ggplot(df, aes(x, y))
70#' base + geom_path(size = 10)
71#' base + geom_path(size = 10, lineend = "round")
72#' base + geom_path(size = 10, linejoin = "mitre", lineend = "butt")
73#'
74#' # You can use NAs to break the line.
75#' df <- data.frame(x = 1:5, y = c(1, 2, NA, 4, 5))
76#' ggplot(df, aes(x, y)) + geom_point() + geom_line()
77#'
78#' \donttest{
79#' # Setting line type vs colour/size
80#' # Line type needs to be applied to a line as a whole, so it can
81#' # not be used with colour or size that vary across a line
82#' x <- seq(0.01, .99, length.out = 100)
83#' df <- data.frame(
84#'   x = rep(x, 2),
85#'   y = c(qlogis(x), 2 * qlogis(x)),
86#'   group = rep(c("a","b"),
87#'   each = 100)
88#' )
89#' p <- ggplot(df, aes(x=x, y=y, group=group))
90#' # These work
91#' p + geom_line(linetype = 2)
92#' p + geom_line(aes(colour = group), linetype = 2)
93#' p + geom_line(aes(colour = x))
94#' # But this doesn't
95#' should_stop(p + geom_line(aes(colour = x), linetype=2))
96#' }
97geom_path <- function(mapping = NULL, data = NULL,
98                      stat = "identity", position = "identity",
99                      ...,
100                      lineend = "butt",
101                      linejoin = "round",
102                      linemitre = 10,
103                      arrow = NULL,
104                      na.rm = FALSE,
105                      show.legend = NA,
106                      inherit.aes = TRUE) {
107  layer(
108    data = data,
109    mapping = mapping,
110    stat = stat,
111    geom = GeomPath,
112    position = position,
113    show.legend = show.legend,
114    inherit.aes = inherit.aes,
115    params = list(
116      lineend = lineend,
117      linejoin = linejoin,
118      linemitre = linemitre,
119      arrow = arrow,
120      na.rm = na.rm,
121      ...
122    )
123  )
124}
125
126#' @rdname ggplot2-ggproto
127#' @format NULL
128#' @usage NULL
129#' @export
130GeomPath <- ggproto("GeomPath", Geom,
131  required_aes = c("x", "y"),
132
133  default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = NA),
134
135  handle_na = function(data, params) {
136    # Drop missing values at the start or end of a line - can't drop in the
137    # middle since you expect those to be shown by a break in the line
138    complete <- stats::complete.cases(data[c("x", "y", "size", "colour", "linetype")])
139    kept <- stats::ave(complete, data$group, FUN = keep_mid_true)
140    data <- data[kept, ]
141
142    if (!all(kept) && !params$na.rm) {
143      warn(glue("Removed {sum(!kept)} row(s) containing missing values (geom_path)."))
144    }
145
146    data
147  },
148
149  draw_panel = function(data, panel_params, coord, arrow = NULL,
150                        lineend = "butt", linejoin = "round", linemitre = 10,
151                        na.rm = FALSE) {
152    if (!anyDuplicated(data$group)) {
153      message_wrap("geom_path: Each group consists of only one observation. ",
154        "Do you need to adjust the group aesthetic?")
155    }
156
157    # must be sorted on group
158    data <- data[order(data$group), , drop = FALSE]
159    munched <- coord_munch(coord, data, panel_params)
160
161    # Silently drop lines with less than two points, preserving order
162    rows <- stats::ave(seq_len(nrow(munched)), munched$group, FUN = length)
163    munched <- munched[rows >= 2, ]
164    if (nrow(munched) < 2) return(zeroGrob())
165
166    # Work out whether we should use lines or segments
167    attr <- dapply(munched, "group", function(df) {
168      linetype <- unique(df$linetype)
169      new_data_frame(list(
170        solid = identical(linetype, 1) || identical(linetype, "solid"),
171        constant = nrow(unique(df[, c("alpha", "colour","size", "linetype")])) == 1
172      ), n = 1)
173    })
174    solid_lines <- all(attr$solid)
175    constant <- all(attr$constant)
176    if (!solid_lines && !constant) {
177      abort("geom_path: If you are using dotted or dashed lines, colour, size and linetype must be constant over the line")
178    }
179
180    # Work out grouping variables for grobs
181    n <- nrow(munched)
182    group_diff <- munched$group[-1] != munched$group[-n]
183    start <- c(TRUE, group_diff)
184    end <-   c(group_diff, TRUE)
185
186    if (!constant) {
187      segmentsGrob(
188        munched$x[!end], munched$y[!end], munched$x[!start], munched$y[!start],
189        default.units = "native", arrow = arrow,
190        gp = gpar(
191          col = alpha(munched$colour, munched$alpha)[!end],
192          fill = alpha(munched$colour, munched$alpha)[!end],
193          lwd = munched$size[!end] * .pt,
194          lty = munched$linetype[!end],
195          lineend = lineend,
196          linejoin = linejoin,
197          linemitre = linemitre
198        )
199      )
200    } else {
201      id <- match(munched$group, unique(munched$group))
202      polylineGrob(
203        munched$x, munched$y, id = id,
204        default.units = "native", arrow = arrow,
205        gp = gpar(
206          col = alpha(munched$colour, munched$alpha)[start],
207          fill = alpha(munched$colour, munched$alpha)[start],
208          lwd = munched$size[start] * .pt,
209          lty = munched$linetype[start],
210          lineend = lineend,
211          linejoin = linejoin,
212          linemitre = linemitre
213        )
214      )
215    }
216  },
217
218  draw_key = draw_key_path
219)
220
221# Trim false values from left and right: keep all values from
222# first TRUE to last TRUE
223keep_mid_true <- function(x) {
224  first <- match(TRUE, x) - 1
225  if (is.na(first)) {
226    return(rep(FALSE, length(x)))
227  }
228
229  last <- length(x) - match(TRUE, rev(x)) + 1
230  c(
231    rep(FALSE, first),
232    rep(TRUE, last - first),
233    rep(FALSE, length(x) - last)
234  )
235}
236
237
238#' @export
239#' @rdname geom_path
240geom_line <- function(mapping = NULL, data = NULL, stat = "identity",
241                      position = "identity", na.rm = FALSE, orientation = NA,
242                      show.legend = NA, inherit.aes = TRUE, ...) {
243  layer(
244    data = data,
245    mapping = mapping,
246    stat = stat,
247    geom = GeomLine,
248    position = position,
249    show.legend = show.legend,
250    inherit.aes = inherit.aes,
251    params = list(
252      na.rm = na.rm,
253      orientation = orientation,
254      ...
255    )
256  )
257}
258
259#' @rdname ggplot2-ggproto
260#' @format NULL
261#' @usage NULL
262#' @export
263#' @include geom-path.r
264GeomLine <- ggproto("GeomLine", GeomPath,
265  setup_params = function(data, params) {
266    params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE)
267    params
268  },
269
270  extra_params = c("na.rm", "orientation"),
271
272  setup_data = function(data, params) {
273    data$flipped_aes <- params$flipped_aes
274    data <- flip_data(data, params$flipped_aes)
275    data <- data[order(data$PANEL, data$group, data$x), ]
276    flip_data(data, params$flipped_aes)
277  }
278)
279
280#' @param direction direction of stairs: 'vh' for vertical then horizontal,
281#'   'hv' for horizontal then vertical, or 'mid' for step half-way between
282#'   adjacent x-values.
283#' @export
284#' @rdname geom_path
285geom_step <- function(mapping = NULL, data = NULL, stat = "identity",
286                      position = "identity", direction = "hv",
287                      na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...) {
288  layer(
289    data = data,
290    mapping = mapping,
291    stat = stat,
292    geom = GeomStep,
293    position = position,
294    show.legend = show.legend,
295    inherit.aes = inherit.aes,
296    params = list(
297      direction = direction,
298      na.rm = na.rm,
299      ...
300    )
301  )
302}
303
304#' @rdname ggplot2-ggproto
305#' @format NULL
306#' @usage NULL
307#' @export
308#' @include geom-path.r
309GeomStep <- ggproto("GeomStep", GeomPath,
310  draw_panel = function(data, panel_params, coord, direction = "hv") {
311    data <- dapply(data, "group", stairstep, direction = direction)
312    GeomPath$draw_panel(data, panel_params, coord)
313  }
314)
315
316#' Calculate stairsteps for `geom_step()`
317#' Used by `GeomStep()`
318#'
319#' @noRd
320stairstep <- function(data, direction = "hv") {
321  direction <- match.arg(direction, c("hv", "vh", "mid"))
322  data <- as.data.frame(data)[order(data$x), ]
323  n <- nrow(data)
324
325  if (n <= 1) {
326    # Need at least one observation
327    return(data[0, , drop = FALSE])
328  }
329
330  if (direction == "vh") {
331    xs <- rep(1:n, each = 2)[-2*n]
332    ys <- c(1, rep(2:n, each = 2))
333  } else if (direction == "hv") {
334    ys <- rep(1:n, each = 2)[-2*n]
335    xs <- c(1, rep(2:n, each = 2))
336  } else if (direction == "mid") {
337    xs <- rep(1:(n-1), each = 2)
338    ys <- rep(1:n, each = 2)
339  } else {
340    abort("Parameter `direction` is invalid.")
341  }
342
343  if (direction == "mid") {
344    gaps <- data$x[-1] - data$x[-n]
345    mid_x <- data$x[-n] + gaps/2 # map the mid-point between adjacent x-values
346    x <- c(data$x[1], mid_x[xs], data$x[n])
347    y <- c(data$y[ys])
348    data_attr <- data[c(1,xs,n), setdiff(names(data), c("x", "y"))]
349  } else {
350    x <- data$x[xs]
351    y <- data$y[ys]
352    data_attr <- data[xs, setdiff(names(data), c("x", "y"))]
353  }
354
355  new_data_frame(c(list(x = x, y = y), data_attr))
356}
357