Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

200 lines (175 sloc) 6.014 kb
#' Map projections.
#'
#' This coordinate system provides the full range of map projections available
#' in the mapproj package.
#'
#' This is still experimental, and if you have any advice to offer regarding
#' a better (or more correct) way to do this, please let me know
#'
#' @export
#' @param projection projection to use, see
#' \code{\link[mapproj]{mapproject}} for list
#' @param ... other arguments passed on to
#' \code{\link[mapproj]{mapproject}}
#' @param orientation projection orientation, which defaults to
#' \code{c(90, 0, mean(range(x)))}. This is not optimal for many
#' projections, so you will have to supply your own.
#' @param xlim manually specific x limits (in degrees of lontitude)
#' @param ylim manually specific y limits (in degrees of latitude)
#' @export
#' @examples
#' if (require("maps")) {
#' # Create a lat-long dataframe from the maps package
#' nz <- data.frame(map("nz", plot=FALSE)[c("x","y")])
#' (nzmap <- qplot(x, y, data=nz, geom="path"))
#'
#' nzmap + coord_map()
#' nzmap + coord_map(project="cylindrical")
#' nzmap + coord_map(project='azequalarea',orientation=c(-36.92,174.6,0))
#'
#' states <- data.frame(map("state", plot=FALSE)[c("x","y")])
#' (usamap <- qplot(x, y, data=states, geom="path"))
#' usamap + coord_map()
#' # See ?mapproject for coordinate systems and their parameters
#' usamap + coord_map(project="gilbert")
#' usamap + coord_map(project="lagrange")
#'
#' # For most projections, you'll need to set the orientation yourself
#' # as the automatic selection done by mapproject is not available to
#' # ggplot
#' usamap + coord_map(project="orthographic")
#' usamap + coord_map(project="stereographic")
#' usamap + coord_map(project="conic", lat0 = 30)
#' usamap + coord_map(project="bonne", lat0 = 50)
#' }
coord_map <- function(projection="mercator", ..., orientation = NULL, xlim = NULL, ylim = NULL) {
try_require("mapproj")
coord(
projection = projection,
orientation = orientation,
limits = list(x = xlim, y = ylim),
params = list(...),
subclass = "map"
)
}
#' @S3method coord_transform map
coord_transform.map <- function(coord, data, details) {
trans <- mproject(coord, data$x, data$y, details$orientation)
out <- cunion(trans[c("x", "y")], data)
out$x <- rescale(out$x, 0:1, details$x.proj)
out$y <- rescale(out$y, 0:1, details$y.proj)
out
}
mproject <- function(coord, x, y, orientation) {
suppressWarnings(mapproject(x, y,
projection = coord$projection,
parameters = coord$params,
orientation = orientation
))
}
#' @S3method coord_distance map
coord_distance.map <- function(coord, x, y, details) {
max_dist <- dist_central_angle(details$x.range, details$y.range)
dist_central_angle(x, y) / max_dist
}
#' @S3method coord_aspect map
coord_aspect.map <- function(coord, ranges) {
diff(ranges$y.proj) / diff(ranges$x.proj)
}
#' @S3method coord_train map
coord_train.map <- function(coord, scales) {
# range in scale
ranges <- list()
for (n in c("x", "y")) {
scale <- scales[[n]]
limits <- coord$limits[[n]]
if (is.null(limits)) {
expand <- coord_expand_defaults(coord, scale, n)
range <- scale_dimension(scale, expand)
} else {
range <- range(scale_transform(scale, limits))
}
ranges[[n]] <- range
}
orientation <- coord$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 = 50),
y = seq(ranges$y[1], ranges$y[2], length = 50)
)
ret <- list(x = list(), y = list())
# range in map
proj <- mproject(coord, grid$x, grid$y, orientation)$range
ret$x$proj <- proj[1:2]
ret$y$proj <- proj[3:4]
for (n in c("x", "y")) {
out <- scale_break_info(scales[[n]], 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
}
#' @S3method coord_render_bg map
coord_render_bg.map <- function(coord, details, theme) {
xrange <- expand_range(details$x.range, 0.2)
yrange <- expand_range(details$y.range, 0.2)
xgrid <- with(details, expand.grid(
y = c(seq(yrange[1], yrange[2], len = 50), NA),
x = x.major
))
ygrid <- with(details, expand.grid(
x = c(seq(xrange[1], xrange[2], len = 50), NA),
y = y.major
))
xlines <- coord_transform(coord, xgrid, details)
ylines <- coord_transform(coord, ygrid, 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
))
}
#' @S3method coord_render_axis_h map
coord_render_axis_h.map <- function(coord, details, theme) {
if (is.null(details$x.major)) return(zeroGrob())
x_intercept <- with(details, data.frame(
x = x.major,
y = y.range[1]
))
pos <- coord_transform(coord, x_intercept, details)
guide_axis(pos$x, details$x.labels, "bottom", theme)
}
#' @S3method coord_render_axis_v map
coord_render_axis_v.map <- function(coord, details, theme) {
if (is.null(details$y.major)) return(zeroGrob())
x_intercept <- with(details, data.frame(
x = x.range[1],
y = y.major
))
pos <- coord_transform(coord, x_intercept, details)
guide_axis(pos$y, details$y.labels, "left", theme)
}
Jump to Line
Something went wrong with that request. Please try again.