R/add-osm-objects.R

In ropenscilabs/osmplotr: Bespoke Images of 'OpenStreetMap' Data

#' 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)
}