Skip to content

Commit 70aa2d1

Browse files
paleolimbotpaleolimbot
committed
fix #15 
1 parent c743fe2 commit 70aa2d1

File tree

4 files changed

+359
-0
lines changed

4 files changed

+359
-0
lines changed

‎NAMESPACE

+2
Original file line numberDiff line numberDiff line change
@@ -41,8 +41,10 @@ S3method(spatial_geom,Raster)
4141
S3method(spatial_geom,sf)
4242
S3method(spatial_geom,sfc)
4343
export(GeomMapTile)
44+
export(GeomNorthArrow)
4445
export(GeomScaleBar)
4546
export(annotation_map_tile)
47+
export(annotation_north_arrow)
4648
export(annotation_scale)
4749
export(annotation_spatial)
4850
export(annotation_spraster)

‎R/annotation-north-arrow.R

+224
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,224 @@
1+
2+
#' Spatial-aware north arrow
3+
#'
4+
#' @param line_width,line_col,fill Parameters for north arrow polygons
5+
#' @param text_col,text_family,text_face,text_angle Parameters for the "N" text
6+
#' @param height,width Height and width of north arrow
7+
#' @param pad_x,pad_y Padding between north arrow and edge of frame
8+
#' @param which_north "grid" results in a north arrow always pointing up; "true" always points to the
9+
#' north pole from whichever corner of the map the north arrow is in.
10+
#' @param rotation Override the rotation of the north arrow (degrees conterclockwise)
11+
#' @param location Where to put the north arrow ("tl" for top left, etc.)
12+
#'
13+
#' @return A ggplot2 layer
14+
#' @export
15+
#' @importFrom grid unit
16+
#'
17+
annotation_north_arrow <- function(line_width = 1, line_col = "black", fill = c("white", "black"),
18+
text_col = "black", text_family = "", text_face = NULL,
19+
text_angle = NULL,
20+
height = unit(1.5, "cm"), width = unit(1.5, "cm"),
21+
pad_x = unit(0.25, "cm"), pad_y = unit(0.25, "cm"),
22+
which_north = c("grid", "true"), rotation = NULL,
23+
location = c("tr", "bl", "br", "tl")) {
24+
which_north <- match.arg(which_north)
25+
location <- match.arg(location)
26+
27+
stopifnot(
28+
is.numeric(line_width), length(line_width) == 1,
29+
length(line_col) == 1, is.atomic(line_col),
30+
grid::is.unit(height), length(height) == 1,
31+
grid::is.unit(width), length(width) == 1,
32+
grid::is.unit(pad_x), length(pad_x) == 1,
33+
grid::is.unit(pad_y), length(pad_y) == 1,
34+
length(text_col) == 1, is.atomic(text_col),
35+
length(fill) == 2, is.atomic(fill)
36+
)
37+
38+
ggplot2::layer(
39+
data = data.frame(x = NA),
40+
mapping = NULL,
41+
stat = ggplot2::StatIdentity,
42+
geom = GeomNorthArrow,
43+
position = ggplot2::PositionIdentity,
44+
show.legend = FALSE,
45+
inherit.aes = FALSE,
46+
params = list(
47+
line_width = line_width,
48+
line_col = line_col,
49+
fill = fill,
50+
text_col = text_col,
51+
text_family = text_family,
52+
text_face = text_face,
53+
height = height,
54+
width = width,
55+
pad_x = pad_x,
56+
pad_y = pad_y,
57+
which_north = which_north,
58+
location = location
59+
)
60+
)
61+
}
62+
63+
#' @rdname annotation_north_arrow
64+
#' @export
65+
GeomNorthArrow <- ggplot2::ggproto(
66+
"GeomNorthArrow",
67+
ggplot2::Geom,
68+
69+
extra_params = "",
70+
71+
handle_na = function(data, params) {
72+
data
73+
},
74+
75+
draw_panel = function(data, panel_params, coordinates,
76+
line_width = 1, line_col = "black", fill = c("white", "black"),
77+
text_col = "black", text_family = "", text_face = NULL,
78+
text_angle = NULL,
79+
height = unit(1.5, "cm"), width = unit(1.5, "cm"),
80+
pad_x = unit(0.25, "cm"), pad_y = unit(0.25, "cm"), which_north = "grid",
81+
rotation = NULL, location = "tr") {
82+
83+
if(is.null(rotation)) {
84+
rotation <- 0 # degrees anticlockwise
85+
86+
if((which_north == "true") && inherits(coordinates, "CoordSf")) {
87+
# calculate bearing from centre of map to the north pole?
88+
bounds <- c(
89+
l = panel_params$x_range[1],
90+
r = panel_params$x_range[2],
91+
b = panel_params$y_range[1],
92+
t = panel_params$y_range[2]
93+
)
94+
95+
rotation <- -1 * true_north(
96+
x = bounds[substr(location, 2, 2)],
97+
y = bounds[substr(location, 1, 1)],
98+
crs = sf::st_crs(panel_params$crs)
99+
)
100+
} else if(which_north == "true") {
101+
warning("True north is not meaningful without coord_sf()")
102+
}
103+
}
104+
105+
if(is.null(text_angle)) {
106+
text_angle <- -rotation
107+
}
108+
109+
# north arrow grob in npc coordinates
110+
sub_grob <- north_arrow_grob_default(
111+
line_width = line_width,
112+
line_col = line_col,
113+
fill = fill,
114+
text_col = text_col,
115+
text_family = text_family,
116+
text_face = text_face,
117+
text_angle = text_angle
118+
)
119+
120+
# position of origin (centre of arrow) based on padding, width, height
121+
adj_x <- as.numeric(grepl("r", location))
122+
adj_y <- as.numeric(grepl("t", location))
123+
origin_x <- unit(adj_x, "npc") + (0.5 - adj_x) * 2 * (pad_x + 0.5 * width)
124+
origin_y <- unit(adj_y, "npc") + (0.5 - adj_y) * 2 * (pad_y + 0.5 * height)
125+
126+
# gtree with a custom viewport
127+
grid::gTree(
128+
children = sub_grob,
129+
vp = grid::viewport(
130+
x = origin_x,
131+
y = origin_y,
132+
height = height,
133+
width = width,
134+
angle = rotation
135+
)
136+
)
137+
}
138+
)
139+
140+
# I'm sure there is an easier way to do this...
141+
true_north <- function(x, y, crs, delta_crs = 0.1, delta_lat = 0.1) {
142+
143+
pt_crs <- sf::st_sfc(sf::st_point(c(x, y)), crs = crs)
144+
pt_crs_coords <- as.data.frame(sf::st_coordinates(pt_crs))
145+
146+
pt_latlon <- sf::st_transform(pt_crs, crs = 4326)
147+
pt_latlon_coords <- as.data.frame(sf::st_coordinates(pt_latlon))
148+
149+
150+
# point directly grid north of x, y
151+
pt_grid_north <- sf::st_sfc(sf::st_point(c(x, y + delta_crs)), crs = crs)
152+
pt_grid_north_coords <- as.data.frame(sf::st_coordinates(pt_grid_north))
153+
154+
# point directly true north of x, y
155+
pt_true_north <- sf::st_transform(
156+
sf::st_sfc(
157+
sf::st_point(c(pt_latlon_coords$X, pt_latlon_coords$Y + delta_lat)),
158+
crs = 4326
159+
),
160+
crs = crs
161+
)
162+
pt_true_north_coords <- as.data.frame(sf::st_coordinates(pt_true_north))
163+
164+
a <- c(
165+
x = pt_true_north_coords$X - pt_crs_coords$X,
166+
y = pt_true_north_coords$Y - pt_crs_coords$Y
167+
)
168+
169+
b <- c(
170+
x = pt_grid_north_coords$X - pt_crs_coords$X,
171+
y = pt_grid_north_coords$Y - pt_crs_coords$Y
172+
)
173+
174+
# https://stackoverflow.com/questions/1897704/angle-between-two-vectors-in-r
175+
theta <- acos( sum(a*b) / ( sqrt(sum(a * a)) * sqrt(sum(b * b)) ) )
176+
177+
# use sign of cross product to indicate + or - rotation
178+
cross_product <- a[1]*b[2] - a[2]*b[1]
179+
180+
# return in degrees
181+
rot_degrees <- theta * 180 / pi * sign(cross_product)[1]
182+
183+
rot_degrees
184+
}
185+
186+
187+
# this creates a grob with N arrow and text (using 0...1 coordinates)
188+
# must return a gList()
189+
north_arrow_grob_default <- function(line_width = 1, line_col = "black", fill = c("white", "black"),
190+
text_col = "black", text_family = "", text_face = NULL,
191+
arrow_x = c(0, 0.5, 0.5, 1, 0.5, 0.5),
192+
arrow_y = c(0.1, 1, 0.5, 0.1, 1, 0.5),
193+
arrow_id = c(1, 1, 1, 2, 2, 2),
194+
text_x = 0.5, text_y = 0.1, text_size = 18, text_adj = c(0.5, 0.5),
195+
text_label = "N", text_angle = 0) {
196+
197+
grid::gList(
198+
grid::polygonGrob(
199+
x = arrow_x,
200+
y = arrow_y,
201+
id = arrow_id,
202+
default.units = "npc",
203+
gp = grid::gpar(
204+
linewidth = line_width,
205+
col = line_col,
206+
fill = fill
207+
)
208+
),
209+
grid::textGrob(
210+
label = "N",
211+
x = text_x,
212+
y = text_y,
213+
hjust = text_adj[0],
214+
vjust = text_adj[1],
215+
rot = text_angle,
216+
gp = grid::gpar(
217+
fontfamily = text_family,
218+
fontface = text_face,
219+
fontsize = text_size
220+
)
221+
)
222+
)
223+
224+
}

‎man/annotation_north_arrow.Rd

+41
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎tests/testthat/test-annotation-north-arrow.R

+92
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,92 @@
1+
context("test-annotation-north-arrow.R")
2+
3+
test_that("north arrow drawing works", {
4+
load_longlake_data()
5+
6+
print(
7+
ggplot() +
8+
geom_point(aes(x, y), data = data.frame(x = 0:4, y = -(0:4))) +
9+
annotation_north_arrow() +
10+
labs(caption = "default behaviour of north arrow in cartesian coordinates")
11+
)
12+
13+
print(
14+
ggplot() +
15+
geom_sf(data = longlake_waterdf) +
16+
annotation_north_arrow() +
17+
labs(caption = "default behaviour of north arrow in sf coordinates")
18+
)
19+
20+
expect_true(TRUE)
21+
})
22+
23+
test_that("north arrow math is correct", {
24+
# -63 longitude is the centre of the UTM 20 timezone
25+
crs_points <- sf::st_sfc(
26+
sf::st_point(c(-63, 45)),
27+
sf::st_point(c(-63, 60)),
28+
sf::st_point(c(-63, 80)),
29+
30+
sf::st_point(c(-66, 45)),
31+
sf::st_point(c(-66, 60)),
32+
sf::st_point(c(-66, 80)),
33+
34+
sf::st_point(c(-60, 45)),
35+
sf::st_point(c(-60, 60)),
36+
sf::st_point(c(-60, 80)),
37+
38+
crs = 4326
39+
) %>%
40+
sf::st_transform(26920) %>%
41+
sf::st_coordinates() %>%
42+
as.data.frame()
43+
44+
crs_points$north_angle <- mapply(true_north, crs_points$X, crs_points$Y, crs = 26920)
45+
46+
expect_true(all(crs_points$north_angle[c(1, 2, 3)] == 0))
47+
expect_true(all(crs_points$north_angle[c(4, 5, 6)] > 0))
48+
expect_equal(sum(crs_points$north_angle[c(4, 5, 6)], crs_points$north_angle[c(7, 8, 9)]), 0)
49+
})
50+
51+
test_that("true north arrow points in the right direction", {
52+
load_longlake_data()
53+
54+
print(
55+
ggplot() +
56+
geom_sf(data = longlake_waterdf) +
57+
annotation_north_arrow(location = "tl", which_north = "grid") +
58+
annotation_north_arrow(location = "tr", which_north = "grid") +
59+
annotation_north_arrow(location = "bl", which_north = "grid") +
60+
annotation_north_arrow(location = "br", which_north = "grid") +
61+
coord_sf(crs = 26922) + # utm zone 22...has some angle to it
62+
labs(caption = "North arrow pointing to 'grid' north")
63+
)
64+
65+
print(
66+
ggplot() +
67+
geom_sf(data = longlake_waterdf) +
68+
annotation_north_arrow(location = "tl", which_north = "true") +
69+
annotation_north_arrow(location = "tr", which_north = "true") +
70+
annotation_north_arrow(location = "bl", which_north = "true") +
71+
annotation_north_arrow(location = "br", which_north = "true") +
72+
coord_sf(crs = 26922) + # utm zone 22...has some angle to it
73+
labs(caption = "North arrow pointing to 'true' north, 'N' is straight up and down")
74+
)
75+
76+
print(
77+
ggplot() +
78+
geom_spatial_point(
79+
mapping = aes(x, y),
80+
data = data.frame(x = c(-63.58595, 116.41214), y = c(44.64862, 40.19063), city = c("Halifax", "Beijing")),
81+
crs = 4326
82+
) +
83+
annotation_north_arrow(location = "tl", which_north = "true") +
84+
annotation_north_arrow(location = "tr", which_north = "true") +
85+
annotation_north_arrow(location = "bl", which_north = "true") +
86+
annotation_north_arrow(location = "br", which_north = "true") +
87+
coord_sf(crs = 3995) +
88+
labs(caption = "All four arrows should point to the north pole")
89+
)
90+
91+
expect_true(TRUE)
92+
})

0 commit comments

Comments
 (0)