diff --git a/NAMESPACE b/NAMESPACE index ec9294f..9c55534 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -41,8 +41,10 @@ S3method(spatial_geom,Raster) S3method(spatial_geom,sf) S3method(spatial_geom,sfc) export(GeomMapTile) +export(GeomNorthArrow) export(GeomScaleBar) export(annotation_map_tile) +export(annotation_north_arrow) export(annotation_scale) export(annotation_spatial) export(annotation_spraster) diff --git a/R/annotation-north-arrow.R b/R/annotation-north-arrow.R new file mode 100644 index 0000000..226a3c3 --- /dev/null +++ b/R/annotation-north-arrow.R @@ -0,0 +1,224 @@ + +#' Spatial-aware north arrow +#' +#' @param line_width,line_col,fill Parameters for north arrow polygons +#' @param text_col,text_family,text_face,text_angle Parameters for the "N" text +#' @param height,width Height and width of north arrow +#' @param pad_x,pad_y Padding between north arrow and edge of frame +#' @param which_north "grid" results in a north arrow always pointing up; "true" always points to the +#' north pole from whichever corner of the map the north arrow is in. +#' @param rotation Override the rotation of the north arrow (degrees conterclockwise) +#' @param location Where to put the north arrow ("tl" for top left, etc.) +#' +#' @return A ggplot2 layer +#' @export +#' @importFrom grid unit +#' +annotation_north_arrow <- function(line_width = 1, line_col = "black", fill = c("white", "black"), + text_col = "black", text_family = "", text_face = NULL, + text_angle = NULL, + height = unit(1.5, "cm"), width = unit(1.5, "cm"), + pad_x = unit(0.25, "cm"), pad_y = unit(0.25, "cm"), + which_north = c("grid", "true"), rotation = NULL, + location = c("tr", "bl", "br", "tl")) { + which_north <- match.arg(which_north) + location <- match.arg(location) + + stopifnot( + is.numeric(line_width), length(line_width) == 1, + length(line_col) == 1, is.atomic(line_col), + grid::is.unit(height), length(height) == 1, + grid::is.unit(width), length(width) == 1, + grid::is.unit(pad_x), length(pad_x) == 1, + grid::is.unit(pad_y), length(pad_y) == 1, + length(text_col) == 1, is.atomic(text_col), + length(fill) == 2, is.atomic(fill) + ) + + ggplot2::layer( + data = data.frame(x = NA), + mapping = NULL, + stat = ggplot2::StatIdentity, + geom = GeomNorthArrow, + position = ggplot2::PositionIdentity, + show.legend = FALSE, + inherit.aes = FALSE, + params = list( + line_width = line_width, + line_col = line_col, + fill = fill, + text_col = text_col, + text_family = text_family, + text_face = text_face, + height = height, + width = width, + pad_x = pad_x, + pad_y = pad_y, + which_north = which_north, + location = location + ) + ) +} + +#' @rdname annotation_north_arrow +#' @export +GeomNorthArrow <- ggplot2::ggproto( + "GeomNorthArrow", + ggplot2::Geom, + + extra_params = "", + + handle_na = function(data, params) { + data + }, + + draw_panel = function(data, panel_params, coordinates, + line_width = 1, line_col = "black", fill = c("white", "black"), + text_col = "black", text_family = "", text_face = NULL, + text_angle = NULL, + height = unit(1.5, "cm"), width = unit(1.5, "cm"), + pad_x = unit(0.25, "cm"), pad_y = unit(0.25, "cm"), which_north = "grid", + rotation = NULL, location = "tr") { + + if(is.null(rotation)) { + rotation <- 0 # degrees anticlockwise + + if((which_north == "true") && inherits(coordinates, "CoordSf")) { + # calculate bearing from centre of map to the north pole? + bounds <- c( + l = panel_params$x_range[1], + r = panel_params$x_range[2], + b = panel_params$y_range[1], + t = panel_params$y_range[2] + ) + + rotation <- -1 * true_north( + x = bounds[substr(location, 2, 2)], + y = bounds[substr(location, 1, 1)], + crs = sf::st_crs(panel_params$crs) + ) + } else if(which_north == "true") { + warning("True north is not meaningful without coord_sf()") + } + } + + if(is.null(text_angle)) { + text_angle <- -rotation + } + + # north arrow grob in npc coordinates + sub_grob <- north_arrow_grob_default( + line_width = line_width, + line_col = line_col, + fill = fill, + text_col = text_col, + text_family = text_family, + text_face = text_face, + text_angle = text_angle + ) + + # position of origin (centre of arrow) based on padding, width, height + adj_x <- as.numeric(grepl("r", location)) + adj_y <- as.numeric(grepl("t", location)) + origin_x <- unit(adj_x, "npc") + (0.5 - adj_x) * 2 * (pad_x + 0.5 * width) + origin_y <- unit(adj_y, "npc") + (0.5 - adj_y) * 2 * (pad_y + 0.5 * height) + + # gtree with a custom viewport + grid::gTree( + children = sub_grob, + vp = grid::viewport( + x = origin_x, + y = origin_y, + height = height, + width = width, + angle = rotation + ) + ) + } +) + +# I'm sure there is an easier way to do this... +true_north <- function(x, y, crs, delta_crs = 0.1, delta_lat = 0.1) { + + pt_crs <- sf::st_sfc(sf::st_point(c(x, y)), crs = crs) + pt_crs_coords <- as.data.frame(sf::st_coordinates(pt_crs)) + + pt_latlon <- sf::st_transform(pt_crs, crs = 4326) + pt_latlon_coords <- as.data.frame(sf::st_coordinates(pt_latlon)) + + + # point directly grid north of x, y + pt_grid_north <- sf::st_sfc(sf::st_point(c(x, y + delta_crs)), crs = crs) + pt_grid_north_coords <- as.data.frame(sf::st_coordinates(pt_grid_north)) + + # point directly true north of x, y + pt_true_north <- sf::st_transform( + sf::st_sfc( + sf::st_point(c(pt_latlon_coords$X, pt_latlon_coords$Y + delta_lat)), + crs = 4326 + ), + crs = crs + ) + pt_true_north_coords <- as.data.frame(sf::st_coordinates(pt_true_north)) + + a <- c( + x = pt_true_north_coords$X - pt_crs_coords$X, + y = pt_true_north_coords$Y - pt_crs_coords$Y + ) + + b <- c( + x = pt_grid_north_coords$X - pt_crs_coords$X, + y = pt_grid_north_coords$Y - pt_crs_coords$Y + ) + + # https://stackoverflow.com/questions/1897704/angle-between-two-vectors-in-r + theta <- acos( sum(a*b) / ( sqrt(sum(a * a)) * sqrt(sum(b * b)) ) ) + + # use sign of cross product to indicate + or - rotation + cross_product <- a[1]*b[2] - a[2]*b[1] + + # return in degrees + rot_degrees <- theta * 180 / pi * sign(cross_product)[1] + + rot_degrees +} + + +# this creates a grob with N arrow and text (using 0...1 coordinates) +# must return a gList() +north_arrow_grob_default <- function(line_width = 1, line_col = "black", fill = c("white", "black"), + text_col = "black", text_family = "", text_face = NULL, + arrow_x = c(0, 0.5, 0.5, 1, 0.5, 0.5), + arrow_y = c(0.1, 1, 0.5, 0.1, 1, 0.5), + arrow_id = c(1, 1, 1, 2, 2, 2), + text_x = 0.5, text_y = 0.1, text_size = 18, text_adj = c(0.5, 0.5), + text_label = "N", text_angle = 0) { + + grid::gList( + grid::polygonGrob( + x = arrow_x, + y = arrow_y, + id = arrow_id, + default.units = "npc", + gp = grid::gpar( + linewidth = line_width, + col = line_col, + fill = fill + ) + ), + grid::textGrob( + label = "N", + x = text_x, + y = text_y, + hjust = text_adj[0], + vjust = text_adj[1], + rot = text_angle, + gp = grid::gpar( + fontfamily = text_family, + fontface = text_face, + fontsize = text_size + ) + ) + ) + +} diff --git a/R/annotation-scale.R b/R/annotation-scale.R index 0a69501..9544b7c 100644 --- a/R/annotation-scale.R +++ b/R/annotation-scale.R @@ -12,7 +12,7 @@ #' @param line_col Line colour for scale bar #' @param height Height of scale bar #' @param pad_x,pad_y Distance between scale bar and edge of panel -#' @param text_pad,text_cex,text_col Parameters for label +#' @param text_pad,text_cex,text_col,text_face,text_family Parameters for label #' @param tick_height Height of ticks relative to height of scale bar #' #' @return A ggplot2 layer. @@ -32,6 +32,8 @@ annotation_scale <- function(plot_unit = NULL, width_hint = 0.25, unit_category text_pad = unit(0.15, "cm"), text_cex = 0.7, text_col = "black", + text_face = NULL, + text_family = "", tick_height = 0.6) { unit_category <- match.arg(unit_category) style <- match.arg(style) @@ -74,6 +76,8 @@ annotation_scale <- function(plot_unit = NULL, width_hint = 0.25, unit_category text_pad = text_pad, text_cex = text_cex, text_col = text_col, + text_face = text_face, + text_family = text_family, tick_height = tick_height ) ) @@ -103,6 +107,8 @@ GeomScaleBar <- ggplot2::ggproto( text_pad = unit(0.15, "cm"), text_cex = 0.7, text_col = "black", + text_face = NULL, + text_family = "", tick_height = 0.6) { if(inherits(coordinates, "CoordSf")) { @@ -144,6 +150,8 @@ GeomScaleBar <- ggplot2::ggproto( text_pad = text_pad, text_cex = text_cex, text_col = text_col, + text_face = text_face, + text_family = text_family, tick_height = tick_height ) } @@ -162,6 +170,8 @@ scalebar_grobs <- function( text_pad = unit(0.15, "cm"), text_cex = 0.7, text_col = "black", + text_face = NULL, + text_family = "", tick_height = 0.6 ) { style <- match.arg(style) @@ -228,7 +238,9 @@ scalebar_grobs <- function( vjust = 0.5, gp = grid::gpar( cex = text_cex, - col = text_col + col = text_col, + fontfamily = text_family, + fontface = text_face ) ) ) diff --git a/man/annotation_map_tile.Rd b/man/annotation_map_tile.Rd index 24759e0..9aa1ed7 100644 --- a/man/annotation_map_tile.Rd +++ b/man/annotation_map_tile.Rd @@ -5,7 +5,7 @@ \alias{annotation_map_tile} \alias{GeomMapTile} \title{Add background OSM tiles} -\format{An object of class \code{GeomMapTile} (inherits from \code{Geom}, \code{ggproto}, \code{gg}) of length 3.} +\format{An object of class \code{GeomMapTile} (inherits from \code{Geom}, \code{ggproto}, \code{gg}) of length 5.} \usage{ annotation_map_tile(type = "osm", zoom = NULL, zoomin = -2, forcedownload = FALSE, cachedir = NULL, progress = c("text", "none"), diff --git a/man/annotation_north_arrow.Rd b/man/annotation_north_arrow.Rd new file mode 100644 index 0000000..57195ef --- /dev/null +++ b/man/annotation_north_arrow.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/annotation-north-arrow.R +\docType{data} +\name{annotation_north_arrow} +\alias{annotation_north_arrow} +\alias{GeomNorthArrow} +\title{Spatial-aware north arrow} +\format{An object of class \code{GeomNorthArrow} (inherits from \code{Geom}, \code{ggproto}, \code{gg}) of length 4.} +\usage{ +annotation_north_arrow(line_width = 1, line_col = "black", + fill = c("white", "black"), text_col = "black", text_family = "", + text_face = NULL, text_angle = NULL, height = unit(1.5, "cm"), + width = unit(1.5, "cm"), pad_x = unit(0.25, "cm"), pad_y = unit(0.25, + "cm"), which_north = c("grid", "true"), rotation = NULL, + location = c("tr", "bl", "br", "tl")) + +GeomNorthArrow +} +\arguments{ +\item{line_width, line_col, fill}{Parameters for north arrow polygons} + +\item{text_col, text_family, text_face, text_angle}{Parameters for the "N" text} + +\item{height, width}{Height and width of north arrow} + +\item{pad_x, pad_y}{Padding between north arrow and edge of frame} + +\item{which_north}{"grid" results in a north arrow always pointing up; "true" always points to the +north pole from whichever corner of the map the north arrow is in.} + +\item{rotation}{Override the rotation of the north arrow (degrees conterclockwise)} + +\item{location}{Where to put the north arrow ("tl" for top left, etc.)} +} +\value{ +A ggplot2 layer +} +\description{ +Spatial-aware north arrow +} +\keyword{datasets} diff --git a/man/annotation_scale.Rd b/man/annotation_scale.Rd index 48a6f5e..e3583ad 100644 --- a/man/annotation_scale.Rd +++ b/man/annotation_scale.Rd @@ -13,7 +13,7 @@ annotation_scale(plot_unit = NULL, width_hint = 0.25, line_width = 1, line_col = "black", height = unit(0.25, "cm"), pad_x = unit(0.25, "cm"), pad_y = unit(0.25, "cm"), text_pad = unit(0.15, "cm"), text_cex = 0.7, text_col = "black", - tick_height = 0.6) + text_face = NULL, text_family = "", tick_height = 0.6) GeomScaleBar } @@ -39,7 +39,7 @@ Must be one of km, m, cm, mi, ft, or in.} \item{pad_x, pad_y}{Distance between scale bar and edge of panel} -\item{text_pad, text_cex, text_col}{Parameters for label} +\item{text_pad, text_cex, text_col, text_face, text_family}{Parameters for label} \item{tick_height}{Height of ticks relative to height of scale bar} } diff --git a/tests/testthat/test-annotation-north-arrow.R b/tests/testthat/test-annotation-north-arrow.R new file mode 100644 index 0000000..2608c8b --- /dev/null +++ b/tests/testthat/test-annotation-north-arrow.R @@ -0,0 +1,92 @@ +context("test-annotation-north-arrow.R") + +test_that("north arrow drawing works", { + load_longlake_data() + + print( + ggplot() + + geom_point(aes(x, y), data = data.frame(x = 0:4, y = -(0:4))) + + annotation_north_arrow() + + labs(caption = "default behaviour of north arrow in cartesian coordinates") + ) + + print( + ggplot() + + geom_sf(data = longlake_waterdf) + + annotation_north_arrow() + + labs(caption = "default behaviour of north arrow in sf coordinates") + ) + + expect_true(TRUE) +}) + +test_that("north arrow math is correct", { + # -63 longitude is the centre of the UTM 20 timezone + crs_points <- sf::st_sfc( + sf::st_point(c(-63, 45)), + sf::st_point(c(-63, 60)), + sf::st_point(c(-63, 80)), + + sf::st_point(c(-66, 45)), + sf::st_point(c(-66, 60)), + sf::st_point(c(-66, 80)), + + sf::st_point(c(-60, 45)), + sf::st_point(c(-60, 60)), + sf::st_point(c(-60, 80)), + + crs = 4326 + ) %>% + sf::st_transform(26920) %>% + sf::st_coordinates() %>% + as.data.frame() + + crs_points$north_angle <- mapply(true_north, crs_points$X, crs_points$Y, crs = 26920) + + expect_true(all(crs_points$north_angle[c(1, 2, 3)] == 0)) + expect_true(all(crs_points$north_angle[c(4, 5, 6)] > 0)) + expect_equal(sum(crs_points$north_angle[c(4, 5, 6)], crs_points$north_angle[c(7, 8, 9)]), 0) +}) + +test_that("true north arrow points in the right direction", { + load_longlake_data() + + print( + ggplot() + + geom_sf(data = longlake_waterdf) + + annotation_north_arrow(location = "tl", which_north = "grid") + + annotation_north_arrow(location = "tr", which_north = "grid") + + annotation_north_arrow(location = "bl", which_north = "grid") + + annotation_north_arrow(location = "br", which_north = "grid") + + coord_sf(crs = 26922) + # utm zone 22...has some angle to it + labs(caption = "North arrow pointing to 'grid' north") + ) + + print( + ggplot() + + geom_sf(data = longlake_waterdf) + + annotation_north_arrow(location = "tl", which_north = "true") + + annotation_north_arrow(location = "tr", which_north = "true") + + annotation_north_arrow(location = "bl", which_north = "true") + + annotation_north_arrow(location = "br", which_north = "true") + + coord_sf(crs = 26922) + # utm zone 22...has some angle to it + labs(caption = "North arrow pointing to 'true' north, 'N' is straight up and down") + ) + + print( + ggplot() + + geom_spatial_point( + mapping = aes(x, y), + data = data.frame(x = c(-63.58595, 116.41214), y = c(44.64862, 40.19063), city = c("Halifax", "Beijing")), + crs = 4326 + ) + + annotation_north_arrow(location = "tl", which_north = "true") + + annotation_north_arrow(location = "tr", which_north = "true") + + annotation_north_arrow(location = "bl", which_north = "true") + + annotation_north_arrow(location = "br", which_north = "true") + + coord_sf(crs = 3995) + + labs(caption = "All four arrows should point to the north pole") + ) + + expect_true(TRUE) +}) diff --git a/tests/testthat/test-annotation-scale.R b/tests/testthat/test-annotation-scale.R index c036769..6d114a8 100644 --- a/tests/testthat/test-annotation-scale.R +++ b/tests/testthat/test-annotation-scale.R @@ -128,3 +128,16 @@ test_that("annotation scale works as intended", { }) +test_that("font items are passed on to annotation_scale()", { + print( + ggplot() + + geom_point(aes(x, y), data = data.frame(x = 0:4, y = -(0:4))) + + annotation_scale(plot_unit = "m", text_face = "bold") + + annotation_scale(plot_unit = "m", pad_y = unit(1, "cm")) + + annotation_scale(plot_unit = "m", pad_y = unit(2, "cm"), text_family = "serif") + + labs(caption = "serif label, default label, bold label") + + coord_fixed() + ) + + expect_true(TRUE) +})