1
2#' Plot well-known geometry vectors
3#'
4#' @param x A [wkb()] or [wkt()]
5#' @param add Should a new plot be created, or should `handleable` be added to the
6#'   existing plot?
7#' @param ... Passed to plotting functions for features: [graphics::points()]
8#'   for point and multipoint geometries, [graphics::lines()] for linestring
9#'   and multilinestring geometries, and [graphics::polypath()] for polygon
10#'   and multipolygon geometries.
11#' @param bbox The limits of the plot as a [rct()] or compatible object
12#' @param asp,xlab,ylab Passed to [graphics::plot()]
13#' @param rule The rule to use for filling polygons (see [graphics::polypath()])
14#' @inheritParams wk_handle
15#'
16#' @return The input, invisibly.
17#' @importFrom graphics plot
18#' @export
19#'
20#' @examples
21#' plot(as_wkt("LINESTRING (0 0, 1 1)"))
22#' plot(as_wkb("LINESTRING (0 0, 1 1)"))
23#'
24wk_plot <- function(handleable, ...,
25                    asp = 1, bbox = NULL, xlab = "", ylab = "",
26                    rule = "evenodd", add = FALSE) {
27  # this is too hard without vctrs (already in Suggests)
28  if (!requireNamespace("vctrs", quietly = TRUE)) {
29    stop("Package 'vctrs' is required for wk_plot()", call. = FALSE) # nocov
30  }
31
32  # should be refactored
33  x <- handleable
34
35  if (!add) {
36    bbox <- unclass(bbox)
37    bbox <- bbox %||% unclass(wk_bbox(x))
38    xlim <- c(bbox$xmin, bbox$xmax)
39    ylim <- c(bbox$ymin, bbox$ymax)
40
41    graphics::plot(
42      numeric(0),
43      numeric(0),
44      xlim = xlim,
45      ylim = ylim,
46      xlab = xlab,
47      ylab = ylab,
48      asp = asp
49    )
50  }
51
52  # for everything below we'll need to be able to subset
53  if (!vctrs::vec_is(x)) {
54    wk_plot(as_wkb(x), ..., rule = rule, add = TRUE) # nocov
55    return(invisible(x)) # nocov
56  }
57
58  # get some background info
59  size <- vctrs::vec_size(x)
60  meta <- wk_meta(x)
61
62  # points can be handled by as_xy()
63  if (all(meta$geometry_type == 1L)) {
64    coords <- unclass(as_xy(x))
65    graphics::points(coords, ...)
66    return(invisible(x))
67  }
68
69  # evaluate the dots
70  dots <- list(..., rule = rule)
71  is_scalar <- !vapply(dots, vctrs::vec_is, logical(1))
72  dots[is_scalar] <- lapply(dots[is_scalar], list)
73  dots_length <- vapply(dots, vctrs::vec_size, integer(1))
74  dots_constant <- all(dots_length == 1L)
75  is_rule <- length(dots)
76
77  # point + multipoint is probably faster with a single coord vector
78  if (all(meta$geometry_type %in% c(1, 4))) {
79    coords <- wk_coords(x)
80    if (dots_constant) {
81      graphics::points(coords[c("x", "y")], ...)
82    } else {
83      dots$rule <- NULL
84      dots <- vctrs::vec_recycle_common(!!!dots, .size = size)
85      dots_tbl <- vctrs::new_data_frame(dots, n = size)
86      do.call(graphics::points, c(coords[c("x", "y")], dots_tbl[coords$feature_id, , drop = FALSE]))
87    }
88    return(invisible(x))
89  }
90
91  # it's not faster to flatten big vectors into a single go for anything else
92  dots <- vctrs::vec_recycle_common(!!!dots, .size = size)
93  for (i in seq_len(size)) {
94    xi <- vctrs::vec_slice(x, i)
95    dotsi <- lapply(dots, "[[", i)
96
97    if (meta$geometry_type[i] %in% c(1, 4)) {
98      wk_plot_point_or_multipoint(xi, dotsi[-is_rule])
99    } else if (meta$geometry_type[i] %in% c(2, 5)) {
100      wk_plot_line_or_multiline(xi, dotsi[-is_rule])
101    } else if (meta$geometry_type[i] %in% c(3, 6)) {
102      wk_plot_poly_or_multi_poly(xi, dotsi)
103    } else {
104      do.call(wk_plot, c(list(wk_flatten(xi, max_depth = .Machine$integer.max)), dotsi))
105    }
106  }
107
108  invisible(x)
109}
110
111wk_plot_point_or_multipoint <- function(x, dots) {
112  coords <- wk_coords(x)
113  do.call(graphics::points, c(coords[c("x", "y")], dots))
114}
115
116wk_plot_line_or_multiline <- function(x, dots) {
117  coords <- wk_coords(x)
118  geom_id <- coords$part_id
119  geom_id_lag <- c(-1L, geom_id[-length(geom_id)])
120  new_geom <- geom_id != geom_id_lag
121  na_shift <- cumsum(new_geom) - 1L
122  coords_seq <- seq_along(geom_id)
123
124  coord_x <- rep(NA_real_, length(geom_id) + sum(new_geom) - 1L)
125  coord_y <- rep(NA_real_, length(geom_id) + sum(new_geom) - 1L)
126
127  coord_x[coords_seq + na_shift] <- coords$x
128  coord_y[coords_seq + na_shift] <- coords$y
129
130  dots$rule <- NULL
131  do.call(graphics::lines, c(list(coord_x, coord_y), dots))
132}
133
134wk_plot_poly_or_multi_poly <- function(x, dots) {
135  coords <- wk_coords(x)
136
137  # for polygons we can use the coord vectors directly
138  # because the graphics device expects open loops
139  geom_id <- coords$ring_id
140  n <- length(geom_id)
141  # leave the last loop closed the avoid a trailing NA (which results in error)
142  geom_id_lead <- c(geom_id[-1L], geom_id[n])
143  new_geom_next <- geom_id != geom_id_lead
144
145  coords$x[new_geom_next] <- NA_real_
146  coords$y[new_geom_next] <- NA_real_
147
148  do.call(graphics::polypath, c(coords[c("x", "y")], dots))
149}
150
151#' @rdname wk_plot
152#' @export
153plot.wk_wkt <- function(x, ..., asp = 1, bbox = NULL, xlab = "", ylab = "",
154                        rule = "evenodd", add = FALSE) {
155  wk_plot(
156    x,
157    ...,
158    asp = asp,
159    bbox = bbox,
160    xlab = xlab,
161    ylab = ylab,
162    rule = rule,
163    add = add
164  )
165
166  invisible(x)
167}
168
169#' @rdname wk_plot
170#' @export
171plot.wk_wkb <- function(x, ..., asp = 1, bbox = NULL, xlab = "", ylab = "",
172                        rule = "evenodd", add = FALSE) {
173  wk_plot(
174    x,
175    ...,
176    asp = asp,
177    bbox = bbox,
178    xlab = xlab,
179    ylab = ylab,
180    rule = rule,
181    add = add
182  )
183
184  invisible(x)
185}
186
187#' @rdname wk_plot
188#' @export
189plot.wk_xy <- function(x, ..., asp = 1, bbox = NULL, xlab = "", ylab = "", add = FALSE) {
190  x_bare <- unclass(x)
191
192  if (!add) {
193    graphics::plot(
194      double(), double(),
195      xlim = range(x_bare$x, finite = TRUE),
196      ylim = range(x_bare$y, finite = TRUE),
197      xlab = xlab,
198      ylab = ylab,
199      asp = asp
200    )
201  }
202
203  graphics::points(x_bare$x, x_bare$y, ...)
204
205  invisible(x)
206}
207
208#' @rdname wk_plot
209#' @export
210plot.wk_rct <- function(x, ..., asp = 1, bbox = NULL, xlab = "", ylab = "", add = FALSE) {
211  x_bare <- unclass(x)
212
213  if (!add) {
214    xlim_min <- range(x_bare$xmin, finite = TRUE)
215    xlim_max <- range(x_bare$xmax, finite = TRUE)
216    ylim_min <- range(x_bare$ymin, finite = TRUE)
217    ylim_max <- range(x_bare$ymax, finite = TRUE)
218
219    graphics::plot(
220      double(), double(),
221      xlim = range(c(xlim_min, xlim_max), finite = TRUE),
222      ylim = range(c(ylim_min, ylim_max), finite = TRUE),
223      xlab = xlab,
224      ylab = ylab,
225      asp = asp
226    )
227  }
228
229  graphics::rect(x_bare$xmin, x_bare$ymin, x_bare$xmax, x_bare$ymax, ...)
230  invisible(x)
231}
232
233#' @rdname wk_plot
234#' @export
235plot.wk_crc <- function(x, ..., asp = 1, bbox = NULL, xlab = "", ylab = "",
236                        add = FALSE) {
237  x_bare <- unclass(x)
238
239  if (!add) {
240    xlim_min <- range(x_bare$x + x_bare$r, finite = TRUE)
241    xlim_max <- range(x_bare$x - x_bare$r, finite = TRUE)
242    ylim_min <- range(x_bare$y + x_bare$r, finite = TRUE)
243    ylim_max <- range(x_bare$y - x_bare$r, finite = TRUE)
244
245    graphics::plot(
246      double(), double(),
247      xlim = range(c(xlim_min, xlim_max), finite = TRUE),
248      ylim = range(c(ylim_min, ylim_max), finite = TRUE),
249      xlab = xlab,
250      ylab = ylab,
251      asp = asp
252    )
253  }
254
255  # estimate resolution for turning circles into segments
256  usr <- graphics::par("usr")
257  usr_x <- usr[1:2]
258  usr_y <- usr[3:4]
259  device_x <- graphics::grconvertX(usr_x, to = "device")
260  device_y <- graphics::grconvertY(usr_y, to = "device")
261
262  # Use resolution of 1 at the device level, scale to usr coords.
263  # Changing this number to 2 or 4 doesn't really affect the speed
264  # at which these plot; a value of 1 tends to give very good
265  # resolution and is acceptable even when a plot in the interactive
266  # device is zoomed.
267  scale_x <- diff(device_x) / diff(usr_x)
268  scale_y <- diff(device_y) / diff(usr_y)
269  scale <- min(abs(scale_x), abs(scale_y))
270  resolution_usr <- 1 / scale
271
272  plot(
273    wk_handle(x, wkb_writer(), resolution = resolution_usr),
274    ...,
275    add = TRUE
276  )
277
278  invisible(x)
279}
280