hrbrmstr
9 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