#' add_osm_objects
#'
#' Adds layers of spatial objects (polygons, lines, or points generated by
#' \code{\link{extract_osm_objects}}) to a graphics object initialised with
#' \code{\link{osm_basemap}}.
#'
#' @param map A \code{ggplot2} object to which the objects are to be added.
#' @param obj A spatial (\code{sp}) data frame of polygons, lines, or points,
#' typically as returned by \code{\link{extract_osm_objects}}.
#' @param col Colour of lines or points; fill colour of polygons.
#' @param border Border colour of polygons.
#' @param hcol (Multipolygons only) Vector of fill colours for holes
#' @param size Linewidth argument passed to \code{ggplot2} (polygon, path,
#' point) functions: determines width of lines for (polygon, line), and sizes of
#' points. Respective defaults are (0, 0.5, 0.5).
#' @param shape Shape of points or lines (the latter passed as \code{linetype});
#' see \code{\link[ggplot2]{shape}}.
#' @return modified version of \code{map} to which objects have been added.
#' @importFrom ggplot2 geom_polygon geom_path aes geom_point
#'
#' @seealso \code{\link{osm_basemap}}, \code{\link{extract_osm_objects}}.
#'
#' @examples
#' bbox <- get_bbox (c (-0.13, 51.5, -0.11, 51.52))
#' map <- osm_basemap (bbox = bbox, bg = "gray20")
#'
#' \dontrun{
#' # The 'london' data used below were downloaded as:
#' dat_BNR <- extract_osm_objects (
#' bbox = bbox,
#' key = "building",
#' value = "!residential"
#' )
#' dat_HP <- extract_osm_objects (
#' bbox = bbox,
#' key = "highway",
#' value = "primary"
#' )
#' dat_T <- extract_osm_objects (bbox = bbox, key = "tree")
#' }
#' map <- add_osm_objects (
#' map,
#' obj = london$dat_BNR,
#' col = "gray40",
#' border = "yellow"
#' )
#' map <- add_osm_objects (
#' map,
#' obj = london$dat_HP,
#' col = "gray80",
#' size = 1, shape = 2
#' )
#' map <- add_osm_objects (
#' map,
#' london$dat_T,
#' col = "green",
#' size = 2, shape = 1
#' )
#' print_osm_map (map)
#'
#' # Polygons with different coloured borders
#' map <- osm_basemap (bbox = bbox, bg = "gray20")
#' map <- add_osm_objects (map, obj = london$dat_HP, col = "gray80")
#' map <- add_osm_objects (map, london$dat_T, col = "green")
#' map <- add_osm_objects (map,
#' obj = london$dat_BNR, col = "gray40",
#' border = "yellow", size = 0.5
#' )
#' print_osm_map (map)
#' @family construction
#' @export
add_osm_objects <- function (map, obj, col = "gray40", border = NA, hcol,
size, shape) {
# --------------- sanity checks and warnings ---------------
check_map_arg (map)
check_obj_arg (obj)
check_col_arg (col)
if (length (col) == 0) {
stop ("a non-null col must be provided")
}
check_col_arg (border)
# --------------- end sanity checks and warnings ---------------
obj_type <- get_obj_type (obj)
# Then a couple more checks using obj_type:
shape <- default_shape (obj_type, shape)
size <- default_size (obj_type, size)
lon <- lat <- id <- NULL # suppress 'no visible binding' error
if (obj_type == "multipolygon") { # sf
for (i in seq_len (nrow (obj))) {
# xy <- lapply (obj$geometry [[i]], function (i) i [[1]])
xy <- obj$geometry [[i]] [[1]]
# if only one polygon in multipolygon, which can happen:
if (!is.list (xy)) {
xy <- list (xy)
}
xy <- list2df (xy)
xy1 <- xy [which (xy$id == 1), ]
xy_not1 <- xy [which (xy$id != 1), ]
map <- map +
ggplot2::geom_polygon (
ggplot2::aes (group = id),
data = xy1,
linewidth = size,
fill = col,
colour = border
)
if (nrow (xy_not1) > 0) {
if (missing (hcol)) {
hcol <- map$theme$panel.background$fill
}
hcol <- rep (hcol, length.out = length (unique (xy_not1$id)))
hcols <- NULL
ids <- unique (xy_not1$id)
for (i in seq (ids)) {
n <- length (which (xy_not1$id == ids [i]))
hcols <- c (hcols, rep (hcol [i], n))
}
map <- map +
ggplot2::geom_polygon (
ggplot2::aes (group = id),
data = xy_not1,
fill = hcols
)
}
}
} else if (grepl ("polygon", obj_type)) {
xy <- geom_to_xy (obj, obj_type)
xy <- list2df (xy)
map <- map +
ggplot2::geom_polygon (
ggplot2::aes (group = id),
data = xy,
linewidth = size,
fill = col,
colour = border
)
} else if (grepl ("line", obj_type)) {
xy <- geom_to_xy (obj, obj_type)
xy <- list2df (xy, islines = TRUE)
map <- map +
ggplot2::geom_path (
data = xy,
ggplot2::aes (x = lon, y = lat),
colour = col,
linewidth = size,
linetype = shape
)
} else if (grepl ("point", obj_type)) {
xy <- geom_to_xy (obj, obj_type)
map <- map +
ggplot2::geom_point (
data = xy,
ggplot2::aes (x = lon, y = lat),
col = col,
size = size,
shape = shape
)
} else {
stop ("obj is not a spatial class")
}
return (map)
}
#' list2df
#'
#' Converts lists of coordinates to single data frames
#'
#' @param xy A list of coordinates extracted from an sp object
#' @param islines Set to TRUE for spatial lines, otherwise FALSE
#' @return data frame
#'
#' @noRd
list2df <- function (xy, islines = FALSE) {
if (islines) { # lines have to be separated by NAs
xy <- lapply (xy, function (i) rbind (i, rep (NA, 2)))
} else { # Add id column to each:
for (i in seq (xy)) {
xy [[i]] <- cbind (i, xy [[i]])
}
}
# multiline/polygon names can be very long, prompting a strange R warning
# when rbind'ing them, so
names (xy) <- NULL
# And rbind them to a single matrix.
xy <- do.call (rbind, xy)
# And then to a data.frame, for which duplicated row names flag warnings
# which are not relevant, so are suppressed by specifying new row names
xy <- data.frame (xy, row.names = seq_len (nrow (xy)))
if (islines) { # remove terminal row of NAs
xy <- xy [1:(nrow (xy) - 1), ]
} else {
names (xy) <- c ("id", "lon", "lat")
}
return (xy)
}
#' convert shape to default values dependent on class of obj
#'
#' @noRd
default_shape <- function (obj_type, shape) {
shape_default <- NULL
if (grepl ("line", obj_type)) {
shape_default <- 1
} else if (grepl ("point", obj_type)) {
shape_default <- 19
}
ret <- NULL
if (!is.null (shape_default)) {
if (!missing (shape)) {
if (!is.numeric (shape)) {
warning (
"shape should be numeric; defaulting to ",
shape_default
)
} else if (shape < 0) {
warning (
"shape should be positive; defaulting to ",
shape_default
)
}
}
ret <- shape_default
}
return (ret)
}
#' convert size to default values dependent on class of obj
#'
#' @noRd
default_size <- function (obj, size) {
size_default <- 0
if (!grepl ("polygon", get_obj_type (obj))) {
size_default <- 0.5
}
if (missing (size)) {
size <- size_default
} else if (!is.numeric (size)) {
warning ("size should be numeric; defaulting to ", size_default)
size <- size_default
} else if (size < 0) {
warning ("size should be positive; defaulting to ", size_default)
size <- size_default
}
return (size)
}
#' return geometries of sf/sp objects as lists of matrices
#'
#' @noRd
geom_to_xy <- function (obj, obj_type) {
if (obj_type == "polygon") { # sf
xy <- lapply (obj$geometry, function (i) i [[1]])
} else if (obj_type == "linestring") { # sf
xy <- lapply (obj$geometry, function (i) as.matrix (i))
} else if (obj_type == "point") { # sf
xy <- data.frame (do.call (rbind, lapply (obj$geometry, as.numeric)))
names (xy) <- c ("lon", "lat")
} else if (obj_type %in% c ("polygons", "lines")) { # sp
xy <- lapply (slot (obj, obj_type), function (x) {
slot (slot (x, cap_first (obj_type)) [[1]], "coords")
})
} else if (obj_type == "points") { # sp
xy <- data.frame (slot (obj, "coords"))
}
return (xy)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.