### Subversion checkout URL

You can clone with HTTPS or Subversion.

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") }
Something went wrong with that request. Please try again.