#' Get a CloudMade map.
#'
#' [get_cloudmademap()] accesses a tile server for Stamen Maps and
#' downloads/stitches map tiles/formats a map image. This function requires an
#' api key which can be obtained for free from http://cloudmade.com/user/show,
#' now defunct. Thousands of maptypes ("styles"), including create-your-own
#' options, are available from http://maps.cloudmade.com/editor (defunct).
#'
#' @param bbox a bounding box in the format c(lowerleftlon, lowerleftlat,
#' upperrightlon, upperrightlat).
#' @param zoom a zoom level
#' @param api_key character string containing cloud made api key, see details
#' @param maptype an integer of what cloud made calls style, see details
#' @param highres double resolution
#' @param crop crop raw map tiles to specified bounding box
#' @param messaging turn messaging on/off
#' @param urlonly return url only
#' @param filename destination file for download (file extension added according
#' to format). Default `NULL` means a random [tempfile()].
#' @param color color or black-and-white
#' @param ... ...
#' @return a ggmap object (a classed raster object with a bounding box
#' attribute)
#' @author David Kahle \email{david@@kahle.io}
#' @seealso http://maps.cloudmade.com/ (defunct), [ggmap()]
#' @export
#
# \dontrun{ discontinued service
#
# api_key <- '<your api key here>'
#
# map <- get_cloudmademap(api_key = api_key)
# ggmap(map)
#
# map <- get_cloudmademap(maptype = 997, api_key = api_key)
# ggmap(map)
#
# }
#
get_cloudmademap <- function(
bbox = c(left = -95.80204, bottom = 29.38048, right = -94.92313, top = 30.14344),
zoom = 10, api_key, maptype = 1, highres = TRUE, crop = TRUE, messaging = FALSE,
urlonly = FALSE, filename = NULL, color = c('color','bw'), ...
){
.Defunct(msg = "CloudMade discontinued its static maps service; try `get_stadiamap()`.")
# enumerate argument checking (added in lieu of checkargs function)
args <- as.list(match.call(expand.dots = TRUE)[-1])
argsgiven <- names(args)
if('bbox' %in% argsgiven){
if(!(is.numeric(bbox) && length(bbox) == 4)){
cli::cli_abort("{.arg bbox} improperly specified. See {.fn ggmap::get_openstreetmap}.")
}
}
if('zoom' %in% argsgiven){
if(!(is.numeric(zoom) && length(zoom) == 1 &&
zoom == round(zoom) && zoom >= 0 && zoom <= 18)){
cli::cli_abort("{.arg scale} must be a positive integer 0-18. See {.fn ggmap::get_cloudmademap}.")
}
}
if('maptype' %in% argsgiven){
if(!(is.numeric(maptype) && length(maptype) == 1 &&
maptype == round(maptype) && maptype > 0)){
cli::cli_abort("{.arg maptype} must be a positive integer. See {.fn ggmap::get_cloudmademap}.")
}
}
if('api_key' %in% argsgiven){
if(!(is.character(api_key) && length(api_key) == 1)){
cli::cli_abort("{.arg api_key} improperly specified. See {.fn ggmap::get_cloudmademap}.")
}
} else {
cli::cli_abort("{.arg api_key} must be specified. See {.fn ggmap::get_cloudmademap}.")
}
if('highres' %in% argsgiven) stopifnot(is.logical(highres))
if('messaging' %in% argsgiven) stopifnot(is.logical(messaging))
if('urlonly' %in% argsgiven) stopifnot(is.logical(urlonly))
if(is.null(filename)){
destfile <- tempfile(fileext = ".png")
} else{
filename_stop <- TRUE
if(is.character(filename) && length(filename) == 1) filename_stop <- FALSE
if(filename_stop) cli::cli_abort("{.arg filename} improperly specified. See {.fn ggmap::get_googlemap}.")
destfile <- paste(filename, 'png', sep = '.')
}
# color arg checked by match.arg
if('checkargs' %in% argsgiven){
.Deprecated(msg = 'checkargs argument deprecated, args are always checked after v2.1.')
}
# argument checking (no checks for language, region, markers, path, visible, style)
#args <- as.list(match.call(expand.dots = TRUE)[-1])
#if(checkargs) get_cloudmademap_checkargs(args)
color <- match.arg(color)
if(is.null(names(bbox))) names(bbox) <- c('left','bottom','right','top')
if(highres) maptype <- paste(maptype, '@2x', sep = '')
# determine tiles to get
fourCorners <- expand.grid(
lon = c(bbox['left'], bbox['right']),
lat = c(bbox['bottom'], bbox['top'])
)
fourCorners$zoom <- zoom
row.names(fourCorners) <- c('lowerleft','lowerright','upperleft','upperright')
fourCornersTiles <- apply(fourCorners, 1, function(v) LonLat2XY(v[1],v[2],v[3]))
xsNeeded <- Reduce(':', sort(unique(as.numeric(sapply(fourCornersTiles, function(df) df$X)))))
numXTiles <- length(xsNeeded)
ysNeeded <- Reduce(':', sort(unique(as.numeric(sapply(fourCornersTiles, function(df) df$Y)))))
numYTiles <- length(ysNeeded)
tilesNeeded <- expand.grid(x = xsNeeded, y = ysNeeded)
if(nrow(tilesNeeded) > 40){
cli::cli_alert_info("{nrow(tilesNeeded)} tiles needed, this may take a while (try a smaller zoom?)")
}
xTileProgression <- rep(1:numXTiles, numYTiles)
yTileProgression <- rep(1:numYTiles, each = numXTiles)
# make urls
base_url <- 'http://b.tile.cloudmade.com/'
base_url <- paste(base_url, api_key, '/', maptype, '/', 256, '/', zoom, sep = '')
urls <- paste(base_url, apply(tilesNeeded, 1, paste, collapse = '/'), sep = '/')
urls <- paste(urls, '.png', sep = '')
if(messaging) cli::cli_alert_info("{length(urls)} tiles required.")
if(urlonly) return(urls)
# download and stitch
size <- 256 * c(length(xsNeeded), length(ysNeeded))
map <- matrix('NA', nrow = size[2], ncol = size[1])
for(k in seq_along(urls)){
download.file(urls[[k]], destfile = destfile, quiet = !messaging, mode = 'wb')
tile <- readPNG(destfile)
if(color == 'color'){
tile <- apply(tile, 2, rgb)
} else if(color == 'bw'){
tile_dim <- dim(tile)
tile <- gray(.30 * tile[,,1] + .59 * tile[,,2] + .11 * tile[,,3])
dim(tile) <- tile_dim[1:2]
}
map[
(1+256*(yTileProgression[k]-1)):(256*yTileProgression[k]),
(1+256*(xTileProgression[k]-1)):(256*xTileProgression[k])
] <- tile
}
# determine bbox of map. note : not the same as the argument bounding box -
# the map is only a covering of the bounding box extent the idea is to get
# the lower left tile and the upper right tile and compute their bounding boxes
# tiles are referenced by top left of tile, starting at 0,0
# see https://wiki.openstreetmap.org/wiki/Slippy_map_tilenames
bboxOfTile <- function(vXY){
lonlat_upperleft <- XY2LonLat(vXY[1],vXY[2],zoom)
lonlat_lowerright <- XY2LonLat(vXY[1]+1,vXY[2]+1,zoom)
data.frame(
left = lonlat_upperleft$lon,
bottom = lonlat_lowerright$lat,
right = lonlat_lowerright$lon,
top = lonlat_upperleft$lat
)
}
tileBboxes <- ldply(split(tilesNeeded,1:nrow(tilesNeeded)),
function(df) bboxOfTile(as.numeric(df)))
mbbox <- c(
left = min(tileBboxes$left),
bottom = min(tileBboxes$bottom),
right = max(tileBboxes$right),
top = max(tileBboxes$top)
)
# format map and return if not cropping
if(!crop){
map <- as.raster(map)
class(map) <- c('ggmap','raster')
attr(map, 'bb') <- data.frame(
ll.lat = mbbox['bottom'], ll.lon = mbbox['left'],
ur.lat = mbbox['top'], ur.lon = mbbox['right']
)
# additional map meta-data
attr(map, "source") <- "google"
attr(map, "maptype") <- maptype
attr(map, "zoom") <- zoom
# return
return(map)
}
# crop map
if(crop){
slon <- seq(mbbox['left'], mbbox['right'], length.out = size[1])
slat <- seq(mbbox['top'], mbbox['bottom'], length.out = size[2])
keep_x_ndcs <- which(bbox['left'] <= slon & slon <= bbox['right'])
keep_y_ndcs <- which(bbox['bottom'] <= slat & slat <= bbox['top'])
croppedmap <- map[keep_y_ndcs, keep_x_ndcs]
}
# format map
croppedmap <- as.raster(croppedmap)
class(croppedmap) <- c('ggmap','raster')
attr(croppedmap, 'bb') <- data.frame(
ll.lat = bbox['bottom'], ll.lon = bbox['left'],
ur.lat = bbox['top'], ur.lon = bbox['right']
)
# additional map meta-data
attr(croppedmap, "source") <- "cloudmade"
attr(croppedmap, "maptype") <- maptype
attr(croppedmap, "zoom") <- zoom
# return
croppedmap
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.