R/add-osm-objects.R

In 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 Size 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
#' @export
#'
#' @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)

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 (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, size = 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, size = 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, size = 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 (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)
}