Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

172 lines (155 sloc) 5.548 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{mapproject}} for
#' list
#' @param ... other arguments passed on to \code{\link{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,
xlim = xlim,
ylim = 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.range)
out$y <- rescale(out$y, 0:1, details$y.range)
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.raw, details$y.raw)
dist_central_angle(x, y) / max_dist
}
#' @S3method coord_aspect map
coord_aspect.map <- function(coord, ranges) {
diff(ranges$y.range) / diff(ranges$x.range)
}
#' @S3method coord_train map
coord_train.map <- function(coord, scales) {
x.raw <- coord$xlim %||% scale_dimension(scales$x)
y.raw <- coord$ylim %||% scale_dimension(scales$y)
orientation <- coord$orientation %||% c(90, 0, mean(x.raw))
# Increase chances of creating valid boundary region
grid <- expand.grid(
x = seq(x.raw[1], x.raw[2], length = 50),
y = seq(y.raw[1], y.raw[2], length = 50)
)
range <- mproject(coord, grid$x, grid$y, orientation)$range
x.range <- range[1:2]
x.major <- scale_breaks(scales$x)
x.minor <- scale_breaks_minor(scales$x)
x.labels <- scale_labels(scales$x, x.major)
y.range <- range[3:4]
y.major <- scale_breaks(scales$y)
y.minor <- scale_breaks_minor(scales$y)
y.labels <- scale_labels(scales$y, y.major)
list(
x.raw = x.raw, y.raw = y.raw, orientation = orientation,
x.range = x.range, y.range = y.range,
x.major = x.major, x.minor = x.minor, x.labels = x.labels,
y.major = y.major, y.minor = y.minor, y.labels = y.labels
)
}
#' @S3method coord_render_bg map
coord_render_bg.map <- function(coord, details, theme) {
xrange <- expand_range(details$x.raw, 0.2)
yrange <- expand_range(details$y.raw, 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)
ggname("grill", grobTree(
theme_render(theme, "panel.background"),
theme_render(
theme, "panel.grid.major", name = "x",
xlines$x, xlines$y, default.units = "native"
),
theme_render(
theme, "panel.grid.major", name = "y",
ylines$x, ylines$y, default.units = "native"
)
))
}
#' @S3method coord_render_axis_h map
coord_render_axis_h.map <- function(coord, details, theme) {
x_intercept <- with(details, data.frame(
x = x.major,
y = y.raw[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) {
x_intercept <- with(details, data.frame(
x = x.raw[1],
y = y.major
))
pos <- coord_transform(coord, x_intercept, details)
guide_axis(pos$y, details$y.labels, "left", theme)
}
icon.map <- function(.) {
nz <- data.frame(map("nz", plot=FALSE)[c("x","y")])
nz$x <- nz$x - min(nz$x, na.rm=TRUE)
nz$y <- nz$y - min(nz$y, na.rm=TRUE)
nz <- nz / max(nz, na.rm=TRUE)
linesGrob(nz$x, nz$y, default.units="npc")
}
Jump to Line
Something went wrong with that request. Please try again.