Skip to content

Commit 49d13ea

Browse files
teunbrandteunbrand
authored
Guides for coord_sf() (#5293)
* Convert graticules to viewscales * Forward viewscales to setup panel guides * Don't reproject positions from graticules * Decommission render_axis_h/v * Sort ticks * Add test * Add news bullet * Readability improvements * Suggestions from code review
1 parent ea6e1c5 commit 49d13ea

File tree

5 files changed

+325
-158
lines changed

5 files changed

+325
-158
lines changed

‎NEWS.md

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,8 @@
11
# ggplot2 (development version)
22

3+
* `coord_sf()` now uses customisable guides provided in the scales or
4+
`guides()` function (@teunbrand).
5+
36
* Legends in `scale_*_manual()` can show `NA` values again when the `values` is
47
a named vector (@teunbrand, #5214, #5286).
58

‎R/coord-sf.R

Lines changed: 158 additions & 158 deletions
Original file line numberDiff line numberDiff line change
@@ -235,6 +235,20 @@ CoordSf <- ggproto("CoordSf", CoordCartesian,
235235
# override graticule labels provided by sf::st_graticule() if necessary
236236
graticule <- self$fixup_graticule_labels(graticule, scale_x, scale_y, params)
237237

238+
# Convert graticule to viewscales for axis guides
239+
viewscales <- Map(
240+
view_scales_from_graticule,
241+
scale = list(x = scale_x, y = scale_y, x.sec = scale_x, y.sec = scale_y),
242+
aesthetic = c("x", "y", "x.sec", "y.sec"),
243+
label = self$label_axes[c("bottom", "left", "top", "right")],
244+
MoreArgs = list(
245+
graticule = graticule,
246+
bbox = bbox,
247+
label_graticule = self$label_graticule
248+
)
249+
)
250+
251+
# Rescale graticule for panel grid
238252
sf::st_geometry(graticule) <- sf_rescale01(sf::st_geometry(graticule), x_range, y_range)
239253
graticule$x_start <- sf_rescale01_x(graticule$x_start, x_range)
240254
graticule$x_end <- sf_rescale01_x(graticule$x_end, x_range)
@@ -247,11 +261,15 @@ CoordSf <- ggproto("CoordSf", CoordCartesian,
247261
graticule = graticule,
248262
crs = params$crs,
249263
default_crs = params$default_crs,
250-
label_axes = self$label_axes,
251-
label_graticule = self$label_graticule
264+
viewscales = viewscales
252265
)
253266
},
254267

268+
setup_panel_guides = function(self, panel_params, guides, params = list()) {
269+
params <- Coord$setup_panel_guides(panel_params$viewscales, guides, params)
270+
c(params, panel_params)
271+
},
272+
255273
backtransform_range = function(self, panel_params) {
256274
target_crs <- panel_params$default_crs
257275
source_crs <- panel_params$crs
@@ -314,162 +332,6 @@ CoordSf <- ggproto("CoordSf", CoordCartesian,
314332
)
315333
}
316334
ggname("grill", inject(grobTree(!!!grobs)))
317-
},
318-
319-
render_axis_h = function(self, panel_params, theme) {
320-
graticule <- panel_params$graticule
321-
322-
# top axis
323-
id1 <- id2 <- integer(0)
324-
# labels based on panel side
325-
id1 <- c(id1, which(graticule$type == panel_params$label_axes$top & graticule$y_start > 0.999))
326-
id2 <- c(id2, which(graticule$type == panel_params$label_axes$top & graticule$y_end > 0.999))
327-
328-
# labels based on graticule direction
329-
if ("S" %in% panel_params$label_graticule) {
330-
id1 <- c(id1, which(graticule$type == "E" & graticule$y_start > 0.999))
331-
}
332-
if ("N" %in% panel_params$label_graticule) {
333-
id2 <- c(id2, which(graticule$type == "E" & graticule$y_end > 0.999))
334-
}
335-
if ("W" %in% panel_params$label_graticule) {
336-
id1 <- c(id1, which(graticule$type == "N" & graticule$y_start > 0.999))
337-
}
338-
if ("E" %in% panel_params$label_graticule) {
339-
id2 <- c(id2, which(graticule$type == "N" & graticule$y_end > 0.999))
340-
}
341-
342-
ticks1 <- graticule[unique0(id1), ]
343-
ticks2 <- graticule[unique0(id2), ]
344-
tick_positions <- c(ticks1$x_start, ticks2$x_end)
345-
tick_labels <- c(ticks1$degree_label, ticks2$degree_label)
346-
347-
if (length(tick_positions) > 0) {
348-
top <- draw_axis(
349-
tick_positions,
350-
tick_labels,
351-
axis_position = "top",
352-
theme = theme
353-
)
354-
} else {
355-
top <- zeroGrob()
356-
}
357-
358-
# bottom axis
359-
id1 <- id2 <- integer(0)
360-
# labels based on panel side
361-
id1 <- c(id1, which(graticule$type == panel_params$label_axes$bottom & graticule$y_start < 0.001))
362-
id2 <- c(id2, which(graticule$type == panel_params$label_axes$bottom & graticule$y_end < 0.001))
363-
364-
# labels based on graticule direction
365-
if ("S" %in% panel_params$label_graticule) {
366-
id1 <- c(id1, which(graticule$type == "E" & graticule$y_start < 0.001))
367-
}
368-
if ("N" %in% panel_params$label_graticule) {
369-
id2 <- c(id2, which(graticule$type == "E" & graticule$y_end < 0.001))
370-
}
371-
if ("W" %in% panel_params$label_graticule) {
372-
id1 <- c(id1, which(graticule$type == "N" & graticule$y_start < 0.001))
373-
}
374-
if ("E" %in% panel_params$label_graticule) {
375-
id2 <- c(id2, which(graticule$type == "N" & graticule$y_end < 0.001))
376-
}
377-
378-
ticks1 <- graticule[unique0(id1), ]
379-
ticks2 <- graticule[unique0(id2), ]
380-
tick_positions <- c(ticks1$x_start, ticks2$x_end)
381-
tick_labels <- c(ticks1$degree_label, ticks2$degree_label)
382-
383-
if (length(tick_positions) > 0) {
384-
bottom <- draw_axis(
385-
tick_positions,
386-
tick_labels,
387-
axis_position = "bottom",
388-
theme = theme
389-
)
390-
} else {
391-
bottom <- zeroGrob()
392-
}
393-
394-
list(top = top, bottom = bottom)
395-
},
396-
397-
render_axis_v = function(self, panel_params, theme) {
398-
graticule <- panel_params$graticule
399-
400-
# right axis
401-
id1 <- id2 <- integer(0)
402-
# labels based on panel side
403-
id1 <- c(id1, which(graticule$type == panel_params$label_axes$right & graticule$x_end > 0.999))
404-
id2 <- c(id2, which(graticule$type == panel_params$label_axes$right & graticule$x_start > 0.999))
405-
406-
# labels based on graticule direction
407-
if ("N" %in% panel_params$label_graticule) {
408-
id1 <- c(id1, which(graticule$type == "E" & graticule$x_end > 0.999))
409-
}
410-
if ("S" %in% panel_params$label_graticule) {
411-
id2 <- c(id2, which(graticule$type == "E" & graticule$x_start > 0.999))
412-
}
413-
if ("E" %in% panel_params$label_graticule) {
414-
id1 <- c(id1, which(graticule$type == "N" & graticule$x_end > 0.999))
415-
}
416-
if ("W" %in% panel_params$label_graticule) {
417-
id2 <- c(id2, which(graticule$type == "N" & graticule$x_start > 0.999))
418-
}
419-
420-
ticks1 <- graticule[unique0(id1), ]
421-
ticks2 <- graticule[unique0(id2), ]
422-
tick_positions <- c(ticks1$y_end, ticks2$y_start)
423-
tick_labels <- c(ticks1$degree_label, ticks2$degree_label)
424-
425-
if (length(tick_positions) > 0) {
426-
right <- draw_axis(
427-
tick_positions,
428-
tick_labels,
429-
axis_position = "right",
430-
theme = theme
431-
)
432-
} else {
433-
right <- zeroGrob()
434-
}
435-
436-
# left axis
437-
id1 <- id2 <- integer(0)
438-
# labels based on panel side
439-
id1 <- c(id1, which(graticule$type == panel_params$label_axes$left & graticule$x_end < 0.001))
440-
id2 <- c(id2, which(graticule$type == panel_params$label_axes$left & graticule$x_start < 0.001))
441-
442-
# labels based on graticule direction
443-
if ("N" %in% panel_params$label_graticule) {
444-
id1 <- c(id1, which(graticule$type == "E" & graticule$x_end < 0.001))
445-
}
446-
if ("S" %in% panel_params$label_graticule) {
447-
id2 <- c(id2, which(graticule$type == "E" & graticule$x_start < 0.001))
448-
}
449-
if ("E" %in% panel_params$label_graticule) {
450-
id1 <- c(id1, which(graticule$type == "N" & graticule$x_end < 0.001))
451-
}
452-
if ("W" %in% panel_params$label_graticule) {
453-
id2 <- c(id2, which(graticule$type == "N" & graticule$x_start < 0.001))
454-
}
455-
456-
ticks1 <- graticule[unique0(id1), ]
457-
ticks2 <- graticule[unique0(id2), ]
458-
tick_positions <- c(ticks1$y_end, ticks2$y_start)
459-
tick_labels <- c(ticks1$degree_label, ticks2$degree_label)
460-
461-
if (length(tick_positions) > 0) {
462-
left <- draw_axis(
463-
tick_positions,
464-
tick_labels,
465-
axis_position = "left",
466-
theme = theme
467-
)
468-
} else {
469-
left <- zeroGrob()
470-
}
471-
472-
list(left = left, right = right)
473335
}
474336
)
475337

@@ -716,3 +578,141 @@ parse_axes_labeling <- function(x) {
716578
labs = unlist(strsplit(x, ""))
717579
list(top = labs[1], right = labs[2], bottom = labs[3], left = labs[4])
718580
}
581+
582+
583+
#' ViewScale from graticule
584+
#'
585+
#' This function converts a graticule and other CoordSf's settings to a
586+
#' ViewScale with the appropriate `breaks` and `labels` to be rendered by a
587+
#' guide.
588+
#'
589+
#' @param graticule A graticule as produced by `sf::st_graticule()`.
590+
#' @param scale An x or y position scale for a panel.
591+
#' @param aesthetic One of `"x"`, `"y"`, `"x.sec"` or `"y.sec'` specifying the
592+
#' plot position of the guide.
593+
#' @param label One of `"E"` for meridians or `"N"` for parallels. If neither,
594+
#' no tick information will be produced.
595+
#' @param label_graticule See `?coord_sf`.
596+
#' @param bbox A `numeric(4)` bounding box with 'xmin', 'ymin', 'xmax' and
597+
#' 'ymax' positions.
598+
#'
599+
#' @return A `ViewScale` object.
600+
#' @noRd
601+
#' @keywords internal
602+
view_scales_from_graticule <- function(graticule, scale, aesthetic,
603+
label, label_graticule, bbox) {
604+
605+
# Setup position specific parameters
606+
# Note that top/bottom doesn't necessarily mean to label the meridians and
607+
# left/right doesn't necessarily mean to label the parallels.
608+
position <- switch(
609+
arg_match0(aesthetic, c("x", "x.sec", "y", "y.sec")),
610+
"x" = "bottom",
611+
"x.sec" = "top",
612+
"y" = "left",
613+
"y.sec" = "right"
614+
)
615+
axis <- gsub("\\.sec$", "", aesthetic)
616+
if (axis == "x") {
617+
orth <- "y"
618+
thres <- bbox[c(2, 4)] # To determine graticule is close to axis
619+
limits <- bbox[c(1, 3)] # To use as scale limits
620+
} else {
621+
orth <- "x"
622+
thres <- bbox[c(1, 3)]
623+
limits <- bbox[c(2, 4)]
624+
}
625+
626+
# Determine what columns in the graticule contain the starts and ends of the
627+
# axis direction and the orthogonal direction.
628+
axis_start <- paste0(axis, "_start")
629+
axis_end <- paste0(axis, "_end")
630+
orth_start <- paste0(orth, "_start")
631+
orth_end <- paste0(orth, "_end")
632+
633+
# Find the start and endpoints in the graticule that are in close proximity
634+
# to the axis position to generate 'accepted' starts and ends. Close proximity
635+
# here is defined as within 0.1% of the scale range of the *orthogonal* scale.
636+
if (position %in% c("top", "right")) {
637+
thres <- thres[1] + 0.999 * diff(thres)
638+
accept_start <- graticule[[orth_start]] > thres
639+
accept_end <- graticule[[orth_end]] > thres
640+
} else {
641+
thres <- thres[1] + 0.001 * diff(thres)
642+
accept_start <- graticule[[orth_start]] < thres
643+
accept_end <- graticule[[orth_end]] < thres
644+
}
645+
646+
# Parsing the information of the `label_axes` argument:
647+
# should we label the meridians ("E") or parallels ("N")?
648+
type <- graticule$type
649+
idx_start <- idx_end <- integer(0)
650+
idx_start <- c(idx_start, which(type == label & accept_start))
651+
idx_end <- c(idx_end, which(type == label & accept_end))
652+
653+
# Parsing the information of the `label_graticule` argument. Because
654+
# geometry can be rotated, not all meridians are guaranteed to intersect the
655+
# top/bottom axes and likewise not all parallels are guaranteed to intersect
656+
# the left/right axes.
657+
if ("S" %in% label_graticule) {
658+
idx_start <- c(idx_start, which(type == "E" & accept_start))
659+
}
660+
if ("N" %in% label_graticule) {
661+
idx_end <- c(idx_end, which(type == "E" & accept_end))
662+
}
663+
if ("W" %in% label_graticule) {
664+
idx_start <- c(idx_start, which(type == "N" & accept_start))
665+
}
666+
if ("E" %in% label_graticule) {
667+
idx_end <- c(idx_end, which(type == "N" & accept_end))
668+
}
669+
670+
# Combine start and end positions for tick marks and labels
671+
tick_start <- vec_slice(graticule, unique0(idx_start))
672+
tick_end <- vec_slice(graticule, unique0(idx_end))
673+
positions <- c(field(tick_start, axis_start), field(tick_end, axis_end))
674+
labels <- c(tick_start$degree_label, tick_end$degree_label)
675+
676+
# The positions/labels need to be ordered for axis dodging
677+
ord <- order(positions)
678+
positions <- positions[ord]
679+
labels <- labels[ord]
680+
681+
# Find out if the scale has defined guides
682+
if (scale$position != position) {
683+
# Try to use secondary axis' guide
684+
guide <- scale$secondary.axis$guide %||% waiver()
685+
if (is.derived(guide)) {
686+
guide <- scale$guide
687+
}
688+
} else {
689+
guide <- scale$guide
690+
}
691+
# Instruct default guides: no ticks or labels should default to no guide
692+
if (length(positions) > 0) {
693+
guide <- guide %|W|% "axis"
694+
} else {
695+
guide <- guide %|W|% "none"
696+
}
697+
698+
ggproto(
699+
NULL, ViewScale,
700+
scale = scale,
701+
guide = guide,
702+
position = position,
703+
aesthetics = scale$aesthetics,
704+
name = scale$name,
705+
scale_is_discrete = scale$is_discrete(),
706+
limits = limits,
707+
continuous_range = limits,
708+
breaks = positions,
709+
minor_breaks = NULL,
710+
711+
# This viewscale has fixed labels, not dynamic ones as other viewscales
712+
# might have.
713+
labels = labels,
714+
get_labels = function(self, breaks = self$get_breaks()) {
715+
self$labels
716+
}
717+
)
718+
}

‎R/guide-axis.R

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -135,6 +135,11 @@ GuideAxis <- ggproto(
135135
return(params)
136136
}
137137

138+
if (inherits(coord, "CoordSf")) {
139+
# Positions already given in target crs
140+
panel_params$default_crs <- panel_params$crs
141+
}
142+
138143
aesthetics <- names(key)[!grepl("^\\.", names(key))]
139144
if (!all(c("x", "y") %in% aesthetics)) {
140145
other_aesthetic <- setdiff(c("x", "y"), aesthetics)

0 commit comments

Comments
 (0)