get_grayscale_map <- function(
center = c(lon = -95.3632715, lat = 29.7632836), zoom = 10, size = c(640,640),
scale = 2, format = c("png8", "gif", "jpg", "jpg-baseline","png32"),
maptype = c("terrain", "satellite", "roadmap", "hybrid"),
language = "en-EN",
messaging = FALSE, urlonly = FALSE, filename = "ggmapTemp",
color = c("color","bw"),
force = FALSE, where = tempdir(), archiving = FALSE,
ext = "com", inject = "",
region, markers, path, visible, style, snazzy.style = NULL, ...
){
##### do argument checking
############################################################
args <- as.list(match.call(expand.dots = TRUE)[-1])
argsgiven <- names(args)
if("center" %in% argsgiven){
if(!(
(is.numeric(center) && length(center) == 2) ||
(is.character(center) && length(center) == 1)
)){
stop("center of map misspecified, see ?get_googlemap.", call. = FALSE)
}
if(all(is.numeric(center))){
lon <- center[1]; lat <- center[2]
if(lon < -180 || lon > 180){
stop("longitude of center must be between -180 and 180 degrees.",
" note ggmap uses lon/lat, not lat/lon.", call. = FALSE)
}
if(lat < -90 || lat > 90){
stop("latitude of center must be between -90 and 90 degrees.",
" note ggmap uses lon/lat, not lat/lon.", call. = FALSE)
}
}
}
if("zoom" %in% argsgiven){
if(!(is.numeric(zoom) && zoom == round(zoom) && zoom > 0)){
stop("zoom must be a whole number between 1 and 21", call. = FALSE)
}
}
if("size" %in% argsgiven){
stopifnot(all(is.numeric(size)) && all(size == round(size)) && all(size > 0))
}
if("scale" %in% argsgiven) stopifnot(scale %in% c(1,2,4))
# format arg checked by match.arg
# maptype arg checked by match.arg
if("markers" %in% argsgiven){
markers_stop <- TRUE
if(is.data.frame(markers) && all(apply(markers[,1:2],2,is.numeric))) markers_stop <- FALSE
if(
class(markers) == "list" &&
all(sapply(markers, function(elem){
is.data.frame(elem) && all(apply(elem[,1:2],2,is.numeric))
}))
) markers_stop <- FALSE
if(is.character(markers) && length(markers) == 1) markers_stop <- FALSE
if(markers_stop) stop("improper marker specification, see ?get_googlemap.", call. = FALSE)
}
if("path" %in% argsgiven){
path_stop <- TRUE
if(is.data.frame(path) && all(apply(path[,1:2],2,is.numeric))) path_stop <- FALSE
if(
class(path) == "list" &&
all(sapply(path, function(elem){
is.data.frame(elem) && all(apply(elem[,1:2],2,is.numeric))
}))
) path_stop <- FALSE
if(is.character(path) && length(path) == 1) path_stop <- FALSE
if(path_stop) stop("improper path specification, see ?get_googlemap.", call. = FALSE)
}
if("visible" %in% argsgiven){
message("visible argument untested.")
visible_stop <- TRUE
if(is.data.frame(visible) && all(apply(visible[,1:2],2,is.numeric))) visible_stop <- FALSE
if(is.character(visible)) visible_stop <- FALSE
if(visible_stop) stop("improper visible specification, see ?get_googlemap.", call. = FALSE)
}
if("style" %in% argsgiven){
style_stop <- TRUE
if(is.list(style)) style <- unlist(style)
if(is.character(style)){
if(length(style) > 1){
style <- paste(
paste(names(style), style, sep = ":"),
collapse = "|"
)
}
style_stop <- FALSE
}
if(style_stop) stop("improper style specification, see ?get_googlemap.", call. = FALSE)
}
# if( "sensor" %in% argsgiven) stopifnot(is.logical( sensor))
if("messaging" %in% argsgiven) stopifnot(is.logical(messaging))
if( "urlonly" %in% argsgiven) stopifnot(is.logical( urlonly))
if("filename" %in% argsgiven){
filename_stop <- TRUE
if(is.character(filename) && length(filename) == 1) filename_stop <- FALSE
if(filename_stop) stop("improper filename specification, see ?get_googlemap.", call. = FALSE)
}
# argument checking (no checks for language, region, markers, path, visible, style)
#args <- as.list(match.call(expand.dots = TRUE)[-1])
#if(checkargs) get_googlemap_checkargs(args)
format <- match.arg(format)
if(format != "png8") stop("currently only the png format is supported.", call. = FALSE)
maptype <- match.arg(maptype)
color <- match.arg(color)
if(!missing(markers) && class(markers) == "list") markers <- list_to_dataframe(markers)
if(!missing(path) && is.data.frame(path)) path <- list(path)
##### construct url
############################################################
base_url <- sprintf("https://maps.googleapis.%s/maps/api/staticmap?", ext)
center_url <- if(all(is.numeric(center))){ # lon/lat specification
center <- round(center, digits = 6)
lon <- center[1]; lat <- center[2]
paste0("center=", paste(lat,lon,sep = ","))
} else { # address specification
centerPlus <- gsub(" ", "+", center)
paste0("center=", centerPlus)
}
fmteq <- function (x, f = function(.) ., ...) {
paste0(deparse(substitute(x)), "=", f(x, ...))
}
size_url <- fmteq(size, paste, collapse = "x")
format_url <- if(!missing(format) && format != "png8"){ fmteq(format) } else { "" }
language_url <- if(!missing(language)){ fmteq(language) } else { "" }
region_url <- if(!missing(region)){ fmteq(region) } else { "" }
markers_url <- if(!missing(markers)){
if(is.data.frame(markers)){
markers <- apply(markers, 1, function(v) paste(rev(round(v,6)), collapse = ","))
fmteq(markers, paste, collapse = "|")
} else {
fmteq(markers)
}
} else { "" }
path_url <- if(!missing(path)){
if(is.list(path)){
ps <- vapply(path, function(one_path){
path <- apply(one_path, 1, function(v) paste(rev(round(v,6)), collapse = ","))
fmteq(path, paste, collapse = "|")
}, character(1))
paste(ps, collapse = "&")
} else {
fmteq(path)
}
} else { "" }
visible_url <- if(!missing(visible)){
if(is.data.frame(visible)){
visible <- apply(visible, 1, function(v) paste(rev(round(v,6)), collapse = ","))
fmteq(visible, paste0, collapse = "|")
} else {
fmteq(visible, paste0, collapse = "|")
}
} else { "" }
style_url <- if(!missing(style)){ fmteq(style) } else { "" }
# sensor_url <- fmteq(sensor, function(x) tolower(as.character(x)))
# format url proper
post_url <- paste(center_url, fmteq(zoom), size_url, fmteq(scale),
format_url, fmteq(maptype), language_url, region_url, markers_url,
path_url, visible_url, style_url, # sensor_url, # sensor no longer required
sep = "&")
# # add google account stuff
# if (has_goog_client() && has_goog_signature()) {
# client <- goog_client()
# signature <- goog_signature()
# post_url <- paste(post_url, fmteq(client), fmteq(signature), sep = "&")
# } else if (has_goog_key()) {
# key <- goog_key()
# post_url <- paste(post_url, fmteq(key), sep = "&")
# }
url <- paste0(base_url, post_url)
url <- gsub("[&]+","&",url) # removes missing arguments
if(substr(url, nchar(url), nchar(url)) == "&"){ # if ends with &
url <- substr(url, 1, nchar(url)-1)
}
# inject any remaining stuff
if(inject != "") url <- paste(url, inject, sep = "&")
# Add style to URL:
snazzy.url <- "&style=feature:poi|element:all|hue:0x000000|saturation:-100|lightness:-100|visibility:off&style=feature:poi|element:all|hue:0x000000|saturation:-100|lightness:-100|visibility:off&style=feature:administrative|element:all|hue:0x000000|saturation:0|lightness:-100|visibility:off&style=feature:road|element:labels|hue:0xffffff|saturation:-100|lightness:100|visibility:off&style=feature:water|element:labels|hue:0x000000|saturation:-100|lightness:-100|visibility:off&style=feature:road.local|element:all|hue:0xffffff|saturation:-100|lightness:100|visibility:on&style=feature:water|element:geometry|hue:0xffffff|saturation:-100|lightness:100|visibility:on&style=feature:transit|element:labels|hue:0x000000|saturation:0|lightness:-100|visibility:off&style=feature:landscape|element:labels|hue:0x000000|saturation:-100|lightness:-100|visibility:off&style=feature:road|element:geometry|hue:0xbbbbbb|saturation:-100|lightness:26|visibility:off&style=feature:landscape|element:geometry|hue:0xdddddd|saturation:-100|lightness:-3|visibility:on"
url <- paste0(url, snazzy.url)
url <- URLencode( enc2utf8(url) )
if(urlonly) return(url)
# if(nchar(url) > 2048) stop("max url length is 2048 characters.", call. = FALSE)
##### get map
############################################################
# check to see if url is on file
map <- ggmap:::file_drawer_get(url)
if (!is.null(map) && !force) return(map)
# finalize filename
tmp <- tempfile()
download.file(url, destfile = tmp, quiet = !messaging, mode = "wb")
message(paste0("Source : ", url))
##### read in map and format, add meta data
############################################################
map <- png::readPNG(tmp)
map <- aperm(map, c(2, 1, 3))
# format file
if(color == "color"){
map <- apply(map, 2, rgb)
} else if(color == "bw"){
mapd <- dim(map)
map <- gray(.30 * map[,,1] + .59 * map[,,2] + .11 * map[,,3])
dim(map) <- mapd[1:2]
}
map <- matrix(map, nrow = scale*size[2], ncol = scale*size[1])
class(map) <- c("ggmap","raster")
# plot(map)
# map spatial info
if(is.character(center)) {
center <- as.numeric(ggmap::geocode(center, source = "google"))
}
ll <- RgoogleMaps::XY2LatLon(
list(lat = center[2], lon = center[1], zoom = zoom),
-size[1]/2 + 0.5,
-size[2]/2 - 0.5
)
ur <- RgoogleMaps::XY2LatLon(
list(lat = center[2], lon = center[1], zoom = zoom),
size[1]/2 + 0.5,
size[2]/2 - 0.5
)
attr(map, "bb") <- data.frame(
ll.lat = ll[1], ll.lon = ll[2],
ur.lat = ur[1], ur.lon = ur[2]
)
# additional map meta-data
attr(map, "source") <- "google"
attr(map, "maptype") <- maptype
attr(map, "zoom") <- zoom
# transpose
out <- map # t(map)
# archive map for future use
fileNameCenter <- as.character(center)
fileNameCenter <- paste0(gsub("\\.", "_", fileNameCenter),collapse = "-")
if (archiving) file_drawer_set(url, out)
# kick out
out
}
get_googlemap_checkargs <- function(args){
eargs <- lapply(args, eval)
argsgiven <- names(args)
with(eargs,{
# center arg
if("center" %in% argsgiven){
if(!(
(is.numeric(center) && length(center) == 2) ||
(is.character(center) && length(center) == 1)
)){
stop("center of map misspecified, see ?get_googlemap.", call. = FALSE)
}
if(all(is.numeric(center))){
lon <- center[1]; lat <- center[2]
if(lon < -180 || lon > 180){
stop("longitude of center must be between -180 and 180 degrees.",
" note ggmap uses lon/lat, not lat/lon.", call. = FALSE)
}
if(lat < -90 || lat > 90){
stop("latitude of center must be between -90 and 90 degrees.",
" note ggmap uses lon/lat, not lat/lon.", call. = FALSE)
}
}
}
# zoom arg
if("zoom" %in% argsgiven){
if(!(is.numeric(zoom) && zoom == round(zoom) && zoom > 0)){
stop("zoom must be a whole number between 1 and 21", call. = FALSE)
}
}
# size arg
if("size" %in% argsgiven){
stopifnot(all(is.numeric(size)) && all(size == round(size)) && all(size > 0))
}
# scale arg
if("scale" %in% argsgiven) stopifnot(scale %in% c(1,2,4))
# format arg checked by match.arg
# maptype arg checked by match.arg
# markers arg (optional)
if("markers" %in% argsgiven){
markers_stop <- TRUE
if(is.data.frame(markers) && all(apply(markers[,1:2],2,is.numeric))) markers_stop <- FALSE
if(
class(markers) == "list" &&
all(sapply(markers, function(elem){
is.data.frame(elem) && all(apply(elem[,1:2],2,is.numeric))
}))
) markers_stop <- FALSE
if(is.character(markers) && length(markers) == 1) markers_stop <- FALSE
if(markers_stop) stop("improper marker specification, see ?get_googlemap.", call. = FALSE)
}
# path arg (optional)
if("path" %in% argsgiven){
path_stop <- TRUE
if(is.data.frame(path) && all(apply(path[,1:2],2,is.numeric))) path_stop <- FALSE
if(
class(path) == "list" &&
all(sapply(path, function(elem){
is.data.frame(elem) && all(apply(elem[,1:2],2,is.numeric))
}))
) path_stop <- FALSE
if(is.character(path) && length(path) == 1) path_stop <- FALSE
if(path_stop) stop("improper path specification, see ?get_googlemap.", call. = FALSE)
}
# visible arg (optional)
if("visible" %in% argsgiven){
message("visible argument untested.")
visible_stop <- TRUE
if(is.data.frame(visible) && all(apply(visible[,1:2],2,is.numeric))) visible_stop <- FALSE
if(is.character(visible)) visible_stop <- FALSE
if(visible_stop) stop("improper visible specification, see ?get_googlemap.", call. = FALSE)
}
# style arg (optional)
if("style" %in% argsgiven){
message("style argument untested.")
style_stop <- TRUE
if(is.character(style) && length(style) == 1) style_stop <- FALSE
if(style_stop) stop("improper style specification, see ?get_googlemap.", call. = FALSE)
}
# sensor, messaging, urlonly args
# if("sensor" %in% argsgiven) stopifnot(is.logical(sensor))
if("messaging" %in% argsgiven) stopifnot(is.logical(messaging))
if("urlonly" %in% argsgiven) stopifnot(is.logical(urlonly))
# filename arg
if("filename" %in% argsgiven){
filename_stop <- TRUE
if(is.character(filename) && length(filename) == 1) filename_stop <- FALSE
if(filename_stop) stop("improper filename specification, see ?get_googlemap.", call. = FALSE)
}
# color arg checked by match.arg
}) # end with
}
get_greyscale_map <- get_grayscale_map
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.