R/bingmaps.R

Defines functions bmaps.restquery bmaps.sourcefromrest bmaps.types bmaps.plot bmaps.attribute

Documented in bmaps.plot bmaps.types

# use an internal environment to cache REST information
bing_rest_queries <- new.env(parent = emptyenv())

bmaps.restquery <- function(bingtype, key=NULL) {
  # http://dev.virtualearth.net/REST/v1/Imagery/Metadata/Aerial?key=KEY
  # get a key at https://msdn.microsoft.com/en-us/library/ff428642.aspx

  # use cached information first
  if(bingtype %in% names(bing_rest_queries)) {
    result <- bing_rest_queries[[bingtype]]
  } else {

    if(is.null(key)) {
      key <- "Aut49nhp5_Twwf_5RHF6wSGk7sEzpcSA__niIXCHowQZLMeC-m8cdy7EmZd2r7Gs"
    }
    urlstring <- paste0("http://dev.virtualearth.net/REST/v1/Imagery/Metadata/", bingtype, "?key=", key)

    connect <- curl::curl(urlstring)
    lines <- try(readLines(connect, warn = FALSE), silent = TRUE)
    close(connect)

    if(class(lines) == "try-error") stop("  Bing REST query failed for type: ", bingtype)

    # convert to a list
    result <- rjson::fromJSON(paste(lines, collapse = ""))
    # cache the result
    bing_rest_queries[[bingtype]] <- result
  }
  # display the copyright notice
  message(result$copyright)

  # return only the relevant node
  result$resourceSets[[1]]$resources[[1]]
}

bmaps.sourcefromrest <- function(rest, name) {
  force(rest); force(name)
  create_tile_source(
    get_tile_url = function(xtile, ytile, zoom, quadkey) {
      gsub("{quadkey}", quadkey, gsub("{subdomain}", sample(rest$imageUrlSubdomains, 1),
                                      rest$imageUrl, fixed = TRUE),
           fixed = TRUE)
    },
    get_max_zoom = function() rest$zoomMax,
    get_min_zoom = function() rest$zoomMin,
    get_attribution = function() NULL,
    get_extension = function() {
      tools::file_ext(gsub("\\?.*$", "", rest$imageUrl[1]))
    },
    name = name
  )
}

#' List types of Bing Maps
#'
#'
#' @return A list of valid bing map types
#' @export
#'
#' @examples
#' bmaps.types()
#'
bmaps.types <- function() {
  c("Aerial", "AerialWithLabels", "Road")
}

#' Plot Bing Maps
#'
#' Identical syntax to \link{osm.plot}, but using Bing maps (\url{https://www.bing.com/maps/})
#' instead of Open Street Map.
#'
#' @param bbox A bounding box as generated by \code{sp::bbox()} or \code{prettymapr::searchbbox()}
#' @param type Use \code{Aerial}, \code{AerialWithLabels}, or \code{Road}.
#' @param key If plotting a large number of images, consider getting your own (free) key at
#' the \href{https://msdn.microsoft.com/en-us/library/ff428642.aspx}{Microsoft Website}.
#' @param ... Arguments passed on to \link{osm.plot}.
#'
#' @export
#'
#' @examples
#' \donttest{
#' library(prettymapr)
#' bmaps.plot(makebbox(47.2, -59.7, 43.3, -66.4))
#' bmaps.plot(makebbox(47.2, -59.7, 43.3, -66.4), type="Road")
#' }
#'
bmaps.plot <- function(bbox, type="Aerial", key=NULL, ...) {
  if(!(type %in% bmaps.types())) stop("type must be one of Aerial, AerialWithLabels, or Road")

  # get REST information
  rest <- bmaps.restquery(type, key)
  # plot using OSM.plot
  osm.plot(bbox=bbox, type=bmaps.sourcefromrest(rest, paste0("bing_", type)), ...)
  # plot the little bing logo
  extraargs <- list(...)
  bmaps.attribute(res=extraargs$res, cachedir=extraargs$cachedir)
}


bmaps.attribute <- function(padin=c(0.05,0.05), res=NULL, cachedir=NULL, scale = 0.7) {
  if(is.null(res)) {
    res <- 80
  }
  #http://dev.virtualearth.net/Branding/logo_powered_by.png
  bingfile <- file.path(tile.cachedir(list(name="bing")), "bing.png")
  if(!file.exists(bingfile)) {
    curl::curl_download("http://dev.virtualearth.net/Branding/logo_powered_by.png",
                  bingfile, quiet=TRUE, mode = "wb")
  }
  binglogo <- png::readPNG(bingfile)
  ext <- graphics::par("usr")
  rightin <- graphics::grconvertX(ext[2], from="user", to="inches")
  bottomin <- graphics::grconvertY(ext[3], from="user", to="inches")
  widthin <- dim(binglogo)[2]/res * scale
  heightin <- dim(binglogo)[1]/res * scale
  leftusr <- graphics::grconvertX(rightin-padin[1]-widthin, from="inches", to="user")
  bottomusr <- graphics::grconvertY(bottomin+padin[2], from="inches", to="user")
  topusr <- graphics::grconvertY(bottomin+padin[2]+heightin, from="inches", to="user")
  rightusr <- graphics::grconvertX(rightin-padin[1], from="inches", to="user")

  graphics::rasterImage(binglogo, leftusr, bottomusr, rightusr, topusr)
}

Try the rosm package in your browser

Any scripts or data that you put into this service are public.

rosm documentation built on July 22, 2019, 9:04 a.m.