Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
471 lines (406 sloc) 15.7 KB
#' @export
#' @rdname ggsf
#' @usage NULL
#' @format NULL
CoordSf <- ggproto("CoordSf", CoordCartesian,
# Find the first CRS if not already supplied
setup_params = function(self, data) {
if (!is.null(self$crs)) {
return(list(crs = self$crs))
}
for (layer_data in data) {
if (is_sf(layer_data)) {
geometry <- sf::st_geometry(layer_data)
} else
next
crs <- sf::st_crs(geometry)
if (is.na(crs))
next
return(list(crs = crs))
}
list(crs = NULL)
},
# Transform all layers to common CRS (if provided)
setup_data = function(data, params) {
if (is.null(params$crs))
return(data)
lapply(data, function(layer_data) {
if (! is_sf(layer_data)) {
return(layer_data)
}
sf::st_transform(layer_data, params$crs)
})
},
transform = function(self, data, panel_params) {
data[[ geom_column(data) ]] <- sf_rescale01(
data[[ geom_column(data) ]],
panel_params$x_range,
panel_params$y_range
)
# Assume x and y supplied directly already in common CRS
data <- transform_position(
data,
function(x) sf_rescale01_x(x, panel_params$x_range),
function(x) sf_rescale01_x(x, panel_params$y_range)
)
transform_position(data, squish_infinite, squish_infinite)
},
# internal function used by setup_panel_params,
# overrides the graticule labels based on scale settings if necessary
fixup_graticule_labels = function(self, graticule, scale_x, scale_y, params = list()) {
needs_parsing <- rep(FALSE, nrow(graticule))
needs_autoparsing <- rep(FALSE, nrow(graticule))
x_breaks <- graticule$degree[graticule$type == "E"]
if (is.null(scale_x$labels)) {
x_labels <- rep(NA, length(x_breaks))
} else if (is.waive(scale_x$labels)) {
x_labels <- graticule$degree_label[graticule$type == "E"]
needs_autoparsing[graticule$type == "E"] <- TRUE
} else {
if (is.function(scale_x$labels)) {
x_labels <- scale_x$labels(x_breaks)
} else {
x_labels <- scale_x$labels
}
# all labels need to be temporarily stored as character vectors,
# but expressions need to be parsed afterwards
needs_parsing[graticule$type == "E"] <- !(is.character(x_labels) || is.factor(x_labels))
x_labels <- as.character(x_labels)
}
if (length(x_labels) != length(x_breaks)) {
stop("Breaks and labels along x direction are different lengths", call. = FALSE)
}
graticule$degree_label[graticule$type == "E"] <- x_labels
y_breaks <- graticule$degree[graticule$type == "N"]
if (is.null(scale_y$labels)) {
y_labels <- rep(NA, length(y_breaks))
} else if (is.waive(scale_y$labels)) {
y_labels <- graticule$degree_label[graticule$type == "N"]
needs_autoparsing[graticule$type == "N"] <- TRUE
} else {
if (is.function(scale_y$labels)) {
y_labels <- scale_y$labels(y_breaks)
} else {
y_labels <- scale_y$labels
}
# all labels need to be temporarily stored as character vectors,
# but expressions need to be parsed afterwards
needs_parsing[graticule$type == "N"] <- !(is.character(y_labels) || is.factor(y_labels))
y_labels <- as.character(y_labels)
}
if (length(y_labels) != length(y_breaks)) {
stop("Breaks and labels along y direction are different lengths", call. = FALSE)
}
graticule$degree_label[graticule$type == "N"] <- y_labels
# Parse labels if requested/needed
has_degree <- grepl("\\bdegree\\b", graticule$degree_label)
needs_parsing <- needs_parsing | (needs_autoparsing & has_degree)
if (any(needs_parsing)) {
labels <- as.list(graticule$degree_label)
labels[needs_parsing] <- parse_safe(graticule$degree_label[needs_parsing])
graticule$degree_label <- labels
}
graticule
},
setup_panel_params = function(self, scale_x, scale_y, params = list()) {
# Bounding box of the data
expansion_x <- default_expansion(scale_x, expand = self$expand)
x_range <- expand_limits_scale(scale_x, expansion_x, coord_limits = self$limits$x)
expansion_y <- default_expansion(scale_y, expand = self$expand)
y_range <- expand_limits_scale(scale_y, expansion_y, coord_limits = self$limits$y)
bbox <- c(
x_range[1], y_range[1],
x_range[2], y_range[2]
)
# Generate graticule and rescale to plot coords
graticule <- sf::st_graticule(
bbox,
crs = params$crs,
lat = scale_y$breaks %|W|% NULL,
lon = scale_x$breaks %|W|% NULL,
datum = self$datum,
ndiscr = self$ndiscr
)
# override graticule labels provided by sf::st_graticule() if necessary
graticule <- self$fixup_graticule_labels(graticule, scale_x, scale_y, params)
sf::st_geometry(graticule) <- sf_rescale01(sf::st_geometry(graticule), x_range, y_range)
graticule$x_start <- sf_rescale01_x(graticule$x_start, x_range)
graticule$x_end <- sf_rescale01_x(graticule$x_end, x_range)
graticule$y_start <- sf_rescale01_x(graticule$y_start, y_range)
graticule$y_end <- sf_rescale01_x(graticule$y_end, y_range)
list(
x_range = x_range,
y_range = y_range,
graticule = graticule,
crs = params$crs,
label_axes = self$label_axes,
label_graticule = self$label_graticule
)
},
backtransform_range = function(panel_params) {
# this does not actually return backtransformed ranges in the general case, needs fixing
warning(
"range backtransformation not implemented in this coord; results may be wrong.",
call. = FALSE
)
list(x = panel_params$x_range, y = panel_params$y_range)
},
range = function(panel_params) {
list(x = panel_params$x_range, y = panel_params$y_range)
},
# CoordSf enforces a fixed aspect ratio -> axes cannot be changed freely under faceting
is_free = function() FALSE,
aspect = function(self, panel_params) {
if (isTRUE(sf::st_is_longlat(panel_params$crs))) {
# Contributed by @edzer
mid_y <- mean(panel_params$y_range)
ratio <- cos(mid_y * pi / 180)
} else {
# Assume already projected
ratio <- 1
}
diff(panel_params$y_range) / diff(panel_params$x_range) / ratio
},
render_bg = function(self, panel_params, theme) {
el <- calc_element("panel.grid.major", theme)
# we don't draw the graticules if the major panel grid is
# turned off
if (inherits(el, "element_blank")) {
grobs <- list(element_render(theme, "panel.background"))
} else {
line_gp <- gpar(
col = el$colour,
lwd = len0_null(el$size*.pt),
lty = el$linetype
)
grobs <- c(
list(element_render(theme, "panel.background")),
lapply(sf::st_geometry(panel_params$graticule), sf::st_as_grob, gp = line_gp)
)
}
ggname("grill", do.call("grobTree", grobs))
},
render_axis_h = function(self, panel_params, theme) {
graticule <- panel_params$graticule
# top axis
id1 <- id2 <- integer(0)
# labels based on panel side
id1 <- c(id1, which(graticule$type == panel_params$label_axes$top & graticule$y_start > 0.999))
id2 <- c(id2, which(graticule$type == panel_params$label_axes$top & graticule$y_end > 0.999))
# labels based on graticule direction
if ("S" %in% panel_params$label_graticule) {
id1 <- c(id1, which(graticule$type == "E" & graticule$y_start > 0.999))
}
if ("N" %in% panel_params$label_graticule) {
id2 <- c(id2, which(graticule$type == "E" & graticule$y_end > 0.999))
}
if ("W" %in% panel_params$label_graticule) {
id1 <- c(id1, which(graticule$type == "N" & graticule$y_start > 0.999))
}
if ("E" %in% panel_params$label_graticule) {
id2 <- c(id2, which(graticule$type == "N" & graticule$y_end > 0.999))
}
ticks1 <- graticule[unique(id1), ]
ticks2 <- graticule[unique(id2), ]
tick_positions <- c(ticks1$x_start, ticks2$x_end)
tick_labels <- c(ticks1$degree_label, ticks2$degree_label)
if (length(tick_positions) > 0) {
top <- draw_axis(
tick_positions,
tick_labels,
axis_position = "top",
theme = theme
)
} else {
top <- zeroGrob()
}
# bottom axis
id1 <- id2 <- integer(0)
# labels based on panel side
id1 <- c(id1, which(graticule$type == panel_params$label_axes$bottom & graticule$y_start < 0.001))
id2 <- c(id2, which(graticule$type == panel_params$label_axes$bottom & graticule$y_end < 0.001))
# labels based on graticule direction
if ("S" %in% panel_params$label_graticule) {
id1 <- c(id1, which(graticule$type == "E" & graticule$y_start < 0.001))
}
if ("N" %in% panel_params$label_graticule) {
id2 <- c(id2, which(graticule$type == "E" & graticule$y_end < 0.001))
}
if ("W" %in% panel_params$label_graticule) {
id1 <- c(id1, which(graticule$type == "N" & graticule$y_start < 0.001))
}
if ("E" %in% panel_params$label_graticule) {
id2 <- c(id2, which(graticule$type == "N" & graticule$y_end < 0.001))
}
ticks1 <- graticule[unique(id1), ]
ticks2 <- graticule[unique(id2), ]
tick_positions <- c(ticks1$x_start, ticks2$x_end)
tick_labels <- c(ticks1$degree_label, ticks2$degree_label)
if (length(tick_positions) > 0) {
bottom <- draw_axis(
tick_positions,
tick_labels,
axis_position = "bottom",
theme = theme
)
} else {
bottom <- zeroGrob()
}
list(top = top, bottom = bottom)
},
render_axis_v = function(self, panel_params, theme) {
graticule <- panel_params$graticule
# right axis
id1 <- id2 <- integer(0)
# labels based on panel side
id1 <- c(id1, which(graticule$type == panel_params$label_axes$right & graticule$x_end > 0.999))
id2 <- c(id2, which(graticule$type == panel_params$label_axes$right & graticule$x_start > 0.999))
# labels based on graticule direction
if ("N" %in% panel_params$label_graticule) {
id1 <- c(id1, which(graticule$type == "E" & graticule$x_end > 0.999))
}
if ("S" %in% panel_params$label_graticule) {
id2 <- c(id2, which(graticule$type == "E" & graticule$x_start > 0.999))
}
if ("E" %in% panel_params$label_graticule) {
id1 <- c(id1, which(graticule$type == "N" & graticule$x_end > 0.999))
}
if ("W" %in% panel_params$label_graticule) {
id2 <- c(id2, which(graticule$type == "N" & graticule$x_start > 0.999))
}
ticks1 <- graticule[unique(id1), ]
ticks2 <- graticule[unique(id2), ]
tick_positions <- c(ticks1$y_end, ticks2$y_start)
tick_labels <- c(ticks1$degree_label, ticks2$degree_label)
if (length(tick_positions) > 0) {
right <- draw_axis(
tick_positions,
tick_labels,
axis_position = "right",
theme = theme
)
} else {
right <- zeroGrob()
}
# left axis
id1 <- id2 <- integer(0)
# labels based on panel side
id1 <- c(id1, which(graticule$type == panel_params$label_axes$left & graticule$x_end < 0.001))
id2 <- c(id2, which(graticule$type == panel_params$label_axes$left & graticule$x_start < 0.001))
# labels based on graticule direction
if ("N" %in% panel_params$label_graticule) {
id1 <- c(id1, which(graticule$type == "E" & graticule$x_end < 0.001))
}
if ("S" %in% panel_params$label_graticule) {
id2 <- c(id2, which(graticule$type == "E" & graticule$x_start < 0.001))
}
if ("E" %in% panel_params$label_graticule) {
id1 <- c(id1, which(graticule$type == "N" & graticule$x_end < 0.001))
}
if ("W" %in% panel_params$label_graticule) {
id2 <- c(id2, which(graticule$type == "N" & graticule$x_start < 0.001))
}
ticks1 <- graticule[unique(id1), ]
ticks2 <- graticule[unique(id2), ]
tick_positions <- c(ticks1$y_end, ticks2$y_start)
tick_labels <- c(ticks1$degree_label, ticks2$degree_label)
if (length(tick_positions) > 0) {
left <- draw_axis(
tick_positions,
tick_labels,
axis_position = "left",
theme = theme
)
} else {
left <- zeroGrob()
}
list(left = left, right = right)
}
)
sf_rescale01 <- function(x, x_range, y_range) {
if (is.null(x)) {
return(x)
}
sf::st_normalize(x, c(x_range[1], y_range[1], x_range[2], y_range[2]))
}
sf_rescale01_x <- function(x, range) {
(x - range[1]) / diff(range)
}
#' @param crs Use this to select a specific coordinate reference system (CRS).
#' If not specified, will use the CRS defined in the first layer.
#' @param datum CRS that provides datum to use when generating graticules
#' @param label_axes Character vector or named list of character values
#' specifying which graticule lines (meridians or parallels) should be labeled on
#' which side of the plot. Meridians are indicated by `"E"` (for East) and
#' parallels by `"N"` (for North). Default is `"--EN"`, which specifies
#' (clockwise from the top) no labels on the top, none on the right, meridians
#' on the bottom, and parallels on the left. Alternatively, this setting could have been
#' specified with `list(bottom = "E", left = "N")`.
#'
#' This parameter can be used alone or in combination with `label_graticule`.
#' @param label_graticule Character vector indicating which graticule lines should be labeled
#' where. Meridians run north-south, and the letters `"N"` and `"S"` indicate that
#' they should be labeled on their north or south end points, respectively.
#' Parallels run east-west, and the letters `"E"` and `"W"` indicate that they
#' should be labeled on their east or west end points, respectively. Thus,
#' `label_graticule = "SW"` would label meridians at their south end and parallels at
#' their west end, whereas `label_graticule = "EW"` would label parallels at both
#' ends and meridians not at all. Because meridians and parallels can in general
#' intersect with any side of the plot panel, for any choice of `label_graticule` labels
#' are not guaranteed to reside on only one particular side of the plot panel.
#'
#' This parameter can be used alone or in combination with `label_axes`.
#' @param ndiscr number of segments to use for discretising graticule lines;
#' try increasing this when graticules look unexpected
#' @inheritParams coord_cartesian
#' @export
#' @rdname ggsf
coord_sf <- function(xlim = NULL, ylim = NULL, expand = TRUE,
crs = NULL, datum = sf::st_crs(4326),
label_graticule = waiver(),
label_axes = waiver(),
ndiscr = 100, default = FALSE, clip = "on") {
if (is.waive(label_graticule) && is.waive(label_axes)) {
# if both `label_graticule` and `label_axes` are set to waive then we
# use the default of labels on the left and at the bottom
label_graticule <- ""
label_axes <- "--EN"
} else {
# if at least one is set we ignore the other
label_graticule <- label_graticule %|W|% ""
label_axes <- label_axes %|W|% ""
}
if (is.character(label_axes)) {
label_axes <- parse_axes_labeling(label_axes)
} else if (!is.list(label_axes)) {
stop(
"Panel labeling format not recognized.",
call. = FALSE
)
label_axes <- list(left = "N", bottom = "E")
}
if (is.character(label_graticule)) {
label_graticule <- unlist(strsplit(label_graticule, ""))
} else {
stop(
"Graticule labeling format not recognized.",
call. = FALSE
)
label_graticule <- ""
}
ggproto(NULL, CoordSf,
limits = list(x = xlim, y = ylim),
datum = datum,
crs = crs,
label_axes = label_axes,
label_graticule = label_graticule,
ndiscr = ndiscr,
expand = expand,
default = default,
clip = clip
)
}
parse_axes_labeling <- function(x) {
labs = unlist(strsplit(x, ""))
list(top = labs[1], right = labs[2], bottom = labs[3], left = labs[4])
}
You can’t perform that action at this time.