hrbrmstr
8 years ago
14 changed files with 567 additions and 12 deletions
@ -0,0 +1,209 @@ |
|||
#' Like \code{coord_map} only better :-) |
|||
#' |
|||
#' The representation of a portion of the earth, which is approximately |
|||
#' spherical, onto a flat 2D plane requires a projection. This is what |
|||
#' \code{coord_proj} does, using the \link[proj4]{project()} function from |
|||
#' the \code{proj4} package. |
|||
#' |
|||
#' @param proj projection definition |
|||
#' @param inverse if \code{TRUE} inverse projection is performed (from a |
|||
#' cartographic projection into lat/long), otherwise projects from |
|||
#' lat/long into a cartographic projection. |
|||
#' @param degrees if \code{TRUE} then the lat/long data is assumed to be in |
|||
#' degrees, otherwise in radians |
|||
#' @param ellps.default default ellipsoid that will be added if no datum or |
|||
#' ellipsoid parameter is specified in proj. Older versions of PROJ.4 |
|||
#' didn't require a datum (and used sphere by default), but 4.5.0 and |
|||
#' higher always require a datum or an ellipsoid. Set to \code{NA} if no |
|||
#' datum should be added to proj (e.g. if you specify an ellipsoid |
|||
#' directly). |
|||
#' @param xlim manually specific x limits (in degrees of longitude) |
|||
#' @param ylim manually specific y limits (in degrees of latitude) |
|||
#' @export |
|||
coord_proj <- function(proj="+proj=robin +lon_0=0 +x_0=0 +y_0=0 +ellps=WGS84 +datum=WGS84 +units=m +no_defs", |
|||
inverse = FALSE, degrees = TRUE, |
|||
ellps.default="sphere", xlim = NULL, ylim = NULL) { |
|||
|
|||
ggproto(NULL, CoordProj, |
|||
proj = proj, |
|||
inverse = inverse, |
|||
ellps.default = ellps.default, |
|||
degrees = degrees, |
|||
limits = list(x = xlim, y = ylim), |
|||
params= list() |
|||
) |
|||
|
|||
} |
|||
|
|||
#' @export |
|||
CoordProj <- ggproto("CoordProj", Coord, |
|||
|
|||
transform = function(self, data, scale_details) { |
|||
|
|||
trans <- project4(self, data$x, data$y) |
|||
out <- cunion(trans[c("x", "y")], data) |
|||
|
|||
out$x <- rescale(out$x, 0:1, scale_details$x.proj) |
|||
out$y <- rescale(out$y, 0:1, scale_details$y.proj) |
|||
out |
|||
|
|||
}, |
|||
|
|||
distance = function(x, y, scale_details) { |
|||
max_dist <- dist_central_angle(scale_details$x.range, scale_details$y.range) |
|||
dist_central_angle(x, y) / max_dist |
|||
}, |
|||
|
|||
aspect = function(ranges) { |
|||
diff(ranges$y.proj) / diff(ranges$x.proj) |
|||
}, |
|||
|
|||
train = function(self, scale_details) { |
|||
|
|||
# range in scale |
|||
ranges <- list() |
|||
for (n in c("x", "y")) { |
|||
|
|||
scale <- scale_details[[n]] |
|||
limits <- self$limits[[n]] |
|||
|
|||
if (is.null(limits)) { |
|||
range <- scale$dimension(expand_default(scale)) |
|||
} else { |
|||
range <- range(scale_transform(scale, limits)) |
|||
} |
|||
ranges[[n]] <- range |
|||
} |
|||
|
|||
orientation <- self$orientation %||% c(90, 0, mean(ranges$x)) |
|||
|
|||
# Increase chances of creating valid boundary region |
|||
grid <- expand.grid( |
|||
x = seq(ranges$x[1], ranges$x[2], length.out = 50), |
|||
y = seq(ranges$y[1], ranges$y[2], length.out = 50) |
|||
) |
|||
|
|||
ret <- list(x = list(), y = list()) |
|||
|
|||
# range in map |
|||
proj <- project4(self, grid$x, grid$y)$range |
|||
ret$x$proj <- proj[1:2] |
|||
ret$y$proj <- proj[3:4] |
|||
|
|||
for (n in c("x", "y")) { |
|||
out <- scale_details[[n]]$break_info(ranges[[n]]) |
|||
ret[[n]]$range <- out$range |
|||
ret[[n]]$major <- out$major_source |
|||
ret[[n]]$minor <- out$minor_source |
|||
ret[[n]]$labels <- out$labels |
|||
} |
|||
|
|||
details <- list( |
|||
orientation = orientation, |
|||
x.range = ret$x$range, y.range = ret$y$range, |
|||
x.proj = ret$x$proj, y.proj = ret$y$proj, |
|||
x.major = ret$x$major, x.minor = ret$x$minor, x.labels = ret$x$labels, |
|||
y.major = ret$y$major, y.minor = ret$y$minor, y.labels = ret$y$labels |
|||
) |
|||
details |
|||
}, |
|||
|
|||
render_bg = function(self, scale_details, theme) { |
|||
xrange <- expand_range(scale_details$x.range, 0.2) |
|||
yrange <- expand_range(scale_details$y.range, 0.2) |
|||
|
|||
# Limit ranges so that lines don't wrap around globe |
|||
xmid <- mean(xrange) |
|||
ymid <- mean(yrange) |
|||
xrange[xrange < xmid - 180] <- xmid - 180 |
|||
xrange[xrange > xmid + 180] <- xmid + 180 |
|||
yrange[yrange < ymid - 90] <- ymid - 90 |
|||
yrange[yrange > ymid + 90] <- ymid + 90 |
|||
|
|||
xgrid <- with(scale_details, expand.grid( |
|||
y = c(seq(yrange[1], yrange[2], length.out = 50), NA), |
|||
x = x.major |
|||
)) |
|||
ygrid <- with(scale_details, expand.grid( |
|||
x = c(seq(xrange[1], xrange[2], length.out = 50), NA), |
|||
y = y.major |
|||
)) |
|||
|
|||
xlines <- self$transform(xgrid, scale_details) |
|||
ylines <- self$transform(ygrid, scale_details) |
|||
|
|||
if (nrow(xlines) > 0) { |
|||
grob.xlines <- element_render( |
|||
theme, "panel.grid.major.x", |
|||
xlines$x, xlines$y, default.units = "native" |
|||
) |
|||
} else { |
|||
grob.xlines <- zeroGrob() |
|||
} |
|||
|
|||
if (nrow(ylines) > 0) { |
|||
grob.ylines <- element_render( |
|||
theme, "panel.grid.major.y", |
|||
ylines$x, ylines$y, default.units = "native" |
|||
) |
|||
} else { |
|||
grob.ylines <- zeroGrob() |
|||
} |
|||
|
|||
ggname("grill", grobTree( |
|||
element_render(theme, "panel.background"), |
|||
grob.xlines, grob.ylines |
|||
)) |
|||
}, |
|||
|
|||
render_axis_h = function(self, scale_details, theme) { |
|||
if (is.null(scale_details$x.major)) return(zeroGrob()) |
|||
|
|||
x_intercept <- with(scale_details, data.frame( |
|||
x = x.major, |
|||
y = y.range[1] |
|||
)) |
|||
pos <- self$transform(x_intercept, scale_details) |
|||
|
|||
guide_axis(pos$x, scale_details$x.labels, "bottom", theme) |
|||
}, |
|||
|
|||
render_axis_v = function(self, scale_details, theme) { |
|||
if (is.null(scale_details$y.major)) return(zeroGrob()) |
|||
|
|||
x_intercept <- with(scale_details, data.frame( |
|||
x = x.range[1], |
|||
y = y.major |
|||
)) |
|||
pos <- self$transform(x_intercept, scale_details) |
|||
|
|||
guide_axis(pos$y, scale_details$y.labels, "left", theme) |
|||
} |
|||
|
|||
) |
|||
|
|||
|
|||
project4 <- function(coord, x, y) { |
|||
|
|||
df <- data.frame(x=x, y=y) |
|||
|
|||
# map extremes cause issues with projections both with proj4 & |
|||
# spTransform. this compensates for them. |
|||
|
|||
df$x <- ifelse(df$x <= -180, -179.999999999, df$x) |
|||
df$x <- ifelse(df$x >= 180, 179.999999999, df$x) |
|||
df$y <- ifelse(df$y <= -90, -89.999999999, df$y) |
|||
df$y <- ifelse(df$y >= 90, 89.999999999, df$y) |
|||
|
|||
suppressWarnings({ |
|||
res <- proj4::project(list(x=df$x, y=df$y), |
|||
proj = coord$proj, |
|||
inverse = coord$inverse, |
|||
degrees = coord$degrees, |
|||
ellps.default = coord$ellps.default) |
|||
res$range <- c(range(res$x, na.rm=TRUE), range(res$y, na.rm=TRUE)) |
|||
res$error <- 0 |
|||
res |
|||
}) |
|||
} |
|||
|
|||
@ -0,0 +1,47 @@ |
|||
#' Absolute grob |
|||
#' |
|||
#' This grob has fixed dimensions and position. |
|||
#' |
|||
#' It's still experimental |
|||
#' |
|||
#' @keywords internal |
|||
absoluteGrob <- function(grob, width = NULL, height = NULL, |
|||
xmin = NULL, ymin = NULL, vp = NULL) { |
|||
|
|||
gTree( |
|||
children = grob, |
|||
width = width, height = height, |
|||
xmin = xmin, ymin = ymin, |
|||
vp = vp, cl = "absoluteGrob" |
|||
) |
|||
} |
|||
|
|||
#' @export |
|||
#' @method grobHeight absoluteGrob |
|||
grobHeight.absoluteGrob <- function(x) { |
|||
x$height %||% grobHeight(x$children) |
|||
} |
|||
#' @export |
|||
#' @method grobWidth absoluteGrob |
|||
grobWidth.absoluteGrob <- function(x) { |
|||
x$width %||% grobWidth(x$children) |
|||
} |
|||
|
|||
#' @export |
|||
#' @method grobX absoluteGrob |
|||
grobX.absoluteGrob <- function(x, theta) { |
|||
if (!is.null(x$xmin) && theta == "west") return(x$xmin) |
|||
grobX(x$children, theta) |
|||
} |
|||
#' @export |
|||
#' @method grobY absoluteGrob |
|||
grobY.absoluteGrob <- function(x, theta) { |
|||
if (!is.null(x$ymin) && theta == "south") return(x$ymin) |
|||
grobY(x$children, theta) |
|||
} |
|||
|
|||
#' @export |
|||
#' @method grid.draw absoluteGrob |
|||
grid.draw.absoluteGrob <- function(x, recording = TRUE) { |
|||
NextMethod() |
|||
} |
|||
@ -0,0 +1,115 @@ |
|||
# Grob for axes |
|||
# |
|||
# @param position of ticks |
|||
# @param labels at ticks |
|||
# @param position of axis (top, bottom, left or right) |
|||
# @param range of data values |
|||
guide_axis <- function(at, labels, position = "right", theme) { |
|||
if (length(at) == 0) |
|||
return(zeroGrob()) |
|||
|
|||
at <- unit(at, "native") |
|||
position <- match.arg(position, c("top", "bottom", "right", "left")) |
|||
|
|||
zero <- unit(0, "npc") |
|||
one <- unit(1, "npc") |
|||
|
|||
label_render <- switch(position, |
|||
top = , bottom = "axis.text.x", |
|||
left = , right = "axis.text.y" |
|||
) |
|||
|
|||
label_x <- switch(position, |
|||
top = , |
|||
bottom = at, |
|||
right = theme$axis.ticks.length, |
|||
left = one - theme$axis.ticks.length |
|||
) |
|||
label_y <- switch(position, |
|||
top = theme$axis.ticks.length, |
|||
bottom = one - theme$axis.ticks.length, |
|||
right = , |
|||
left = at |
|||
) |
|||
|
|||
if (is.list(labels)) { |
|||
if (any(sapply(labels, is.language))) { |
|||
labels <- do.call(expression, labels) |
|||
} else { |
|||
labels <- unlist(labels) |
|||
} |
|||
} |
|||
|
|||
labels <- switch(position, |
|||
top = , |
|||
bottom = element_render(theme, label_render, labels, x = label_x, expand_y = TRUE), |
|||
right = , |
|||
left = element_render(theme, label_render, labels, y = label_y, expand_x = TRUE)) |
|||
|
|||
line <- switch(position, |
|||
top = element_render(theme, "axis.line.x", c(0, 1), c(0, 0), id.lengths = 2), |
|||
bottom = element_render(theme, "axis.line.x", c(0, 1), c(1, 1), id.lengths = 2), |
|||
right = element_render(theme, "axis.line.y", c(0, 0), c(0, 1), id.lengths = 2), |
|||
left = element_render(theme, "axis.line.y", c(1, 1), c(0, 1), id.lengths = 2) |
|||
) |
|||
|
|||
nticks <- length(at) |
|||
|
|||
ticks <- switch(position, |
|||
top = element_render(theme, "axis.ticks.x", |
|||
x = rep(at, each = 2), |
|||
y = rep(unit.c(zero, theme$axis.ticks.length), nticks), |
|||
id.lengths = rep(2, nticks)), |
|||
bottom = element_render(theme, "axis.ticks.x", |
|||
x = rep(at, each = 2), |
|||
y = rep(unit.c(one - theme$axis.ticks.length, one), nticks), |
|||
id.lengths = rep(2, nticks)), |
|||
right = element_render(theme, "axis.ticks.y", |
|||
x = rep(unit.c(zero, theme$axis.ticks.length), nticks), |
|||
y = rep(at, each = 2), |
|||
id.lengths = rep(2, nticks)), |
|||
left = element_render(theme, "axis.ticks.y", |
|||
x = rep(unit.c(one - theme$axis.ticks.length, one), nticks), |
|||
y = rep(at, each = 2), |
|||
id.lengths = rep(2, nticks)) |
|||
) |
|||
|
|||
# Create the gtable for the ticks + labels |
|||
gt <- switch(position, |
|||
top = gtable_col("axis", |
|||
grobs = list(labels, ticks), |
|||
width = one, |
|||
heights = unit.c(grobHeight(labels), theme$axis.ticks.length) |
|||
), |
|||
bottom = gtable_col("axis", |
|||
grobs = list(ticks, labels), |
|||
width = one, |
|||
heights = unit.c(theme$axis.ticks.length, grobHeight(labels)) |
|||
), |
|||
right = gtable_row("axis", |
|||
grobs = list(ticks, labels), |
|||
widths = unit.c(theme$axis.ticks.length, grobWidth(labels)), |
|||
height = one |
|||
), |
|||
left = gtable_row("axis", |
|||
grobs = list(labels, ticks), |
|||
widths = unit.c(grobWidth(labels), theme$axis.ticks.length), |
|||
height = one |
|||
) |
|||
) |
|||
|
|||
# Viewport for justifying the axis grob |
|||
justvp <- switch(position, |
|||
top = viewport(y = 0, just = "bottom", height = gtable_height(gt)), |
|||
bottom = viewport(y = 1, just = "top", height = gtable_height(gt)), |
|||
right = viewport(x = 0, just = "left", width = gtable_width(gt)), |
|||
left = viewport(x = 1, just = "right", width = gtable_width(gt)) |
|||
) |
|||
|
|||
absoluteGrob( |
|||
gList(line, gt), |
|||
width = gtable_width(gt), |
|||
height = gtable_height(gt), |
|||
vp = justvp |
|||
) |
|||
} |
|||
@ -0,0 +1,67 @@ |
|||
"%||%" <- function(a, b) { |
|||
if (!is.null(a)) a else b |
|||
} |
|||
|
|||
"%|W|%" <- function(a, b) { |
|||
if (!is.waive(a)) a else b |
|||
} |
|||
|
|||
is.waive <- function(x) inherits(x, "waiver") |
|||
|
|||
# Compute central angle between two points. |
|||
# Multiple by radius of sphere to get great circle distance |
|||
# @arguments longitude |
|||
# @arguments latitude |
|||
dist_central_angle <- function(lon, lat) { |
|||
# Convert to radians |
|||
lat <- lat * pi / 180 |
|||
lon <- lon * pi / 180 |
|||
|
|||
hav <- function(x) sin(x / 2) ^ 2 |
|||
ahav <- function(x) 2 * asin(x) |
|||
|
|||
n <- length(lat) |
|||
ahav(sqrt(hav(diff(lat)) + cos(lat[-n]) * cos(lat[-1]) * hav(diff(lon)))) |
|||
} |
|||
|
|||
|
|||
expand_default <- function(scale, discrete = c(0, 0.6), continuous = c(0.05, 0)) { |
|||
scale$expand %|W|% if (scale$is_discrete()) discrete else continuous |
|||
} |
|||
|
|||
|
|||
# Col union |
|||
# Form the union of columns in a and b. If there are columns of the same name in both a and b, take the column from a. |
|||
# |
|||
# @param data frame a |
|||
# @param data frame b |
|||
# @keyword internal |
|||
cunion <- function(a, b) { |
|||
if (length(a) == 0) return(b) |
|||
if (length(b) == 0) return(a) |
|||
|
|||
cbind(a, b[setdiff(names(b), names(a))]) |
|||
} |
|||
|
|||
# Given a theme object and element name, return a grob for the element |
|||
element_render <- function(theme, element, ..., name = NULL) { |
|||
|
|||
# Get the element from the theme, calculating inheritance |
|||
el <- calc_element(element, theme) |
|||
if (is.null(el)) { |
|||
message("Theme element ", element, " missing") |
|||
return(zeroGrob()) |
|||
} |
|||
|
|||
ggname(paste(element, name, sep = "."), element_grob(el, ...)) |
|||
} |
|||
|
|||
|
|||
# Name ggplot grid object |
|||
# Convenience function to name grid objects |
|||
# |
|||
# @keyword internal |
|||
ggname <- function(prefix, grob) { |
|||
grob$name <- grobName(grob, prefix) |
|||
grob |
|||
} |
|||
|
Before Width: | Height: | Size: 272 KiB After Width: | Height: | Size: 272 KiB |
|
Before Width: | Height: | Size: 272 KiB After Width: | Height: | Size: 272 KiB |
|
After Width: | Height: | Size: 172 KiB |
@ -0,0 +1,17 @@ |
|||
% Generated by roxygen2 (4.1.1): do not edit by hand |
|||
% Please edit documentation in R/grob_absolute.r |
|||
\name{absoluteGrob} |
|||
\alias{absoluteGrob} |
|||
\title{Absolute grob} |
|||
\usage{ |
|||
absoluteGrob(grob, width = NULL, height = NULL, xmin = NULL, |
|||
ymin = NULL, vp = NULL) |
|||
} |
|||
\description{ |
|||
This grob has fixed dimensions and position. |
|||
} |
|||
\details{ |
|||
It's still experimental |
|||
} |
|||
\keyword{internal} |
|||
|
|||
@ -0,0 +1,39 @@ |
|||
% Generated by roxygen2 (4.1.1): do not edit by hand |
|||
% Please edit documentation in R/coord_proj.r |
|||
\name{coord_proj} |
|||
\alias{coord_proj} |
|||
\title{Like \code{coord_map} only better :-)} |
|||
\usage{ |
|||
|
|||
coord_proj(proj = "+proj=robin +lon_0=0 +x_0=0 +y_0=0 +ellps=WGS84 +datum=WGS84 +units=m +no_defs", |
|||
inverse = FALSE, degrees = TRUE, ellps.default = "sphere", |
|||
xlim = NULL, ylim = NULL) |
|||
} |
|||
\arguments{ |
|||
\item{proj}{projection definition} |
|||
|
|||
\item{inverse}{if \code{TRUE} inverse projection is performed (from a |
|||
cartographic projection into lat/long), otherwise projects from |
|||
lat/long into a cartographic projection.} |
|||
|
|||
\item{degrees}{if \code{TRUE} then the lat/long data is assumed to be in |
|||
degrees, otherwise in radians} |
|||
|
|||
\item{ellps.default}{default ellipsoid that will be added if no datum or |
|||
ellipsoid parameter is specified in proj. Older versions of PROJ.4 |
|||
didn't require a datum (and used sphere by default), but 4.5.0 and |
|||
higher always require a datum or an ellipsoid. Set to \code{NA} if no |
|||
datum should be added to proj (e.g. if you specify an ellipsoid |
|||
directly).} |
|||
|
|||
\item{xlim}{manually specific x limits (in degrees of longitude)} |
|||
|
|||
\item{ylim}{manually specific y limits (in degrees of latitude)} |
|||
} |
|||
\description{ |
|||
The representation of a portion of the earth, which is approximately |
|||
spherical, onto a flat 2D plane requires a projection. This is what |
|||
\code{coord_proj} does, using the \link[proj4]{project()} function from |
|||
the \code{proj4} package. |
|||
} |
|||
|
|||
Loading…
Reference in new issue