Merge pull request #18 from paleolimbot/development

Add north arrow

Author: paleolimbot

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)

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
+      )
+    )
+  )
+
+}

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
       )
     )
   )