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