R/enrich_opq.R

In sodascience/osmenrich: Enrich sf Data with Geographic Features from OpenStreetMaps

#' @name enrich_opq
#' @title Enrich an overpass query for column output
#'
#' @param name name of the enriched column
#' @param dataset target `sf` dataset to enrich with this package
#' @param key target OSM feature key to add, see [osmdata::add_osm_feature()]
#' @param value target value for OSM feature key to add, see
#'   [osmdata::add_osm_feature()]
#' @param type `character` the osm feature type or types to consider
#' (e.g., points, polygons), see details
#' @param measure `character` the measure metric used, see details
#' @param kernel `function` the kernel function used, see details
#' @param opq overpass query that is being enriched
#' @param r The search radius used by the `kernel` function.
#' @param reduce_fun The aggregation function used by the `kernel` function to
#'   aggregate the retrieved data objects
#' @param control The list with configuration variables for the OSRM server.
#'   It contains `timeout`, defining the number of seconds before the request
#'   to OSRM times out, and `memsize`, defining the maximum size of the query to
#'   OSRM.
#' @param .verbose `bool` whether to print info during enrichment
#' @param ... Additional parameters to be passed into the OSM query, such as
#'   a user-defined kernel.
#'
#' @importFrom methods is
#'
#' @seealso [enrich_osm()]
#'
#' @export
enrich_opq <- function(
                       dataset,
                       name = NULL,
                       key = NULL,
                       value = NULL,
                       type = "points",
                       measure = "spherical",
                       r = NULL,
                       kernel = "uniform",
                       reduce_fun = sum,
                       control = list(),
                       .verbose = TRUE,
                       ...) {
  opq <-
    dataset %>%
    add_bbox(r, control) %>%
    add_feature(key, value) %>%
    add_type(type) %>%
    add_measure(measure) %>%
    add_kernel(kernel, r, reduce_fun, ...)
  opq$kernel <- as.character(substitute(kernel))
  opq$name <- name
  opq$key <- key
  opq$value <- value
  invisible(opq)
}

#' @rdname enrich_opq
#' @export
add_bbox <- function(dataset, r, control) {
  if (is.null(dataset)) {
    stop("Specify a dataset to enrich.")
  }
  # Extract bbox and transform 3488 (meters)
  bbox_tmp <- sf::st_transform(sf::st_as_sfc(sf::st_bbox(dataset)), 3488)
  # Add buffer of distance
  bbox_tmp <- sf::st_buffer(x = bbox_tmp, dist = r)
  # Convert back to 4326  (lat, lon) and find bbox of polygon
  bbox <- sf::st_bbox(sf::st_transform(bbox_tmp, 4326))
  # Find bbox "limits", Overpass ignores after 7 digits
  ymax <- as.double(formatC(bbox["ymax"], digits = 7, format = "f"))
  ymin <- as.double(formatC(bbox["ymin"], digits = 7, format = "f"))
  xmax <- as.double(formatC(bbox["xmax"], digits = 7, format = "f"))
  xmin <- as.double(formatC(bbox["xmin"], digits = 7, format = "f"))
  # Set timeout 300 seconds, memsize = 1GiB if not set
  opq <- osmdata::opq(
    bbox = c(xmin, ymin, xmax, ymax),
    timeout = control$timeout,
    memsize = control$memsize
  )
  if (!is(opq, "enriched_overpass_query")) {
    class(opq) <- c(class(opq), "enriched_overpass_query")
  }
  invisible(opq)
}

#' @rdname enrich_opq
#' @export
add_feature <- function(opq, key, value) {
  if ((!is.character(key)) && (!is.character(value))) {
    stop("Key and value of the feature should be characters.")
  }
  keys <- data.frame(words = osmdata::available_features())
  sub_key <- substring(key, 1, 3)
  suggestions <- keys[grep(sub_key, keys$words), ]
  if (!key %in% osmdata::available_features()) {
    stop(paste0(
      "\nThe feature key '", key, "' is not recognized or not",
      "available in OSM.",
      "\nOtherwise, you can use `osmdata::available_features()`",
      "to display the list of supported features.",
      "\nThere might be similar options: \n",
      paste(suggestions, collapse = ", ")
    ))
  }
  # Check for "catch-all" term NULL to `osmdata`:
  # osmdata uses NULL as a wildcard "*" indicator to retrieve
  # all the tags attached to the `key`.
  if (!is.null(value)) {
    values <- data.frame(words = osmdata::available_tags(key))
    sub_val <- substring(value, 1, 3)
    suggestions_val <- values[grep(sub_val, values$words), ]
    if (!value %in% osmdata::available_tags(key)) {
      stop(paste0(
        "\nThe feature value '", value, "' is not recognized ",
        "or not available in OSM.",
        "\nYou can use `osmdata::available_tags(<feature_key>)`",
        "to retrieve a list of supported values for each key.",
        "\nSimilar values for feature key `", key, "``: \n",
        paste(suggestions_val, collapse = ", ")
      ))
    }
  }
  if (is.null(opq$bbox)) {
    stop("Bbox not present in overpass query.")
  }
  # Use bbox in opq to add feature
  opq <- osmdata::add_osm_feature(opq, key, value,
    key_exact = TRUE, value_exact = FALSE,
    match_case = FALSE
  )
  if (!is(opq, "enriched_overpass_query")) {
    class(opq) <- c(class(opq), "enriched_overpass_query")
  }
  invisible(opq)
}

#' @rdname enrich_opq
#' @export
add_type <- function(opq, type) {
  if (!is.character(type)) {
    stop("Type should be a character or character vector.")
  }
  if (!all(type %in% osm_types)) {
    stop(
      "Type(s) \"", paste0(type[!type %in% osm_types], collapse = "\", \""),
      "\" not available. Available options: \n- ",
      paste(osm_types, collapse = "\n- ")
    )
  }
  opq$type <- type
  if (!is(opq, "enriched_overpass_query")) {
    class(opq) <- c(class(opq), "enriched_overpass_query")
  }
  invisible(opq)
}

#' @rdname enrich_opq
#' @export
add_measure <- function(opq, measure) {
  if (!is.character(measure)) stop("Metric should be a character.")
  if (!measure %in% names(osmenrich_measurefuns)) {
    stop(
      "Measure ", measure, " not available. Available options: \n- ",
      paste(names(osmenrich_measurefuns), collapse = "\n- ")
    )
  }
  opq$measure <- measure
  opq$measurefun <- osmenrich_measurefuns[[measure]]
  if (!is(opq, "enriched_overpass_query")) {
    class(opq) <- c(class(opq), "enriched_overpass_query")
  }
  invisible(opq)
}

#' @rdname enrich_opq
#' @export
add_kernel <- function(opq, kernel, r, reduce_fun, ...) {
  if (!(class(kernel) == "function") && !is.character(kernel)) {
    stop(
      "Kernel should be either be chosen among the available options:\n- ",
      paste(names(osmenrich_kernelfuns), collapse = "\n- "),
      "\nOr should be a function of the form: `function(d, r, fun) fun(d,r)`"
    )
  }
  if (!is.function(reduce_fun)) {
    stop("The reduce function should be a function (E.g. 'sum')")
  }
  if (class(kernel) == "function") {
    kernelfun <- kernel
    tryCatch(
      {
        isFALSE(length(kernelfun(c(1, 1, 1))) != 1)
      },
      error = function(e) {
        message("The kernel is not a recognized function.\n
  It should be of the form `function(d, r, fun) fun(d,r).\n
  Error: \n", e)
      }
    )
  }
  if (is.character(kernel)) {
    if (kernel %in% names(osmenrich_kernelfuns)) {

      # Match kernel function among pre-defined ones
      kernelfun <- osmenrich_kernelfuns[[kernel]]

      if (length(kernelfun(c(1, 1, 1))) != 1) {
        stop("Kernel should output scalar for vector input.")
      }
    } else {
      warning(
        "Kernel ", kernel, " not within default options. Available",
        "options: \n- ",
        paste(names(osmenrich_kernelfuns), collapse = "\n- "),
        "\nTrying to recognize kernel as custom function."
      )
    }
  }
  opq$kernel <- as.character(substitute(kernel))
  opq$kernelpars <- list(r, reduce_fun, ...)
  opq$kernelfun <- kernelfun
  if (!is(opq, "enriched_overpass_query")) {
    class(opq) <- c(class(opq), "enriched_overpass_query")
  }
  invisible(opq)
}

#' @keywords internal
check_enriched_opq <- function(opq) {
  if (!is(opq, "enriched_overpass_query")) {
    stop("Query is not an enriched overpass query. See ?enrich_opq.")
  }
  required <- c("type", "measure", "kernel")
  missings <- !required %in% names(opq)
  if (any(missings)) {
    stop(
      "Fields \"", paste0(required[missings], collapse = "\", \""),
      "\" missing from the query. See ?enrich_opq."
    )
  }
  return(TRUE)
}

#' @keywords internal
osmenrich_measurefuns <- list(
  "spherical" = sf::st_distance,
  "distance_by_foot" = distance_by_foot,
  "duration_by_foot" = duration_by_foot,
  "distance_by_car" = distance_by_car,
  "duration_by_car" = duration_by_car,
  "distance_by_bike" = distance_by_bike,
  "duration_by_bike" = duration_by_bike
)

#' @keywords internal
osm_types <- c("points", "lines", "polygons", "multilines", "multipolygons")

#' @keywords internal
osmenrich_kernelfuns <- list(
  "gaussian" = kernel_gaussian,
  "parabola" = kernel_parabola,
  "uniform" = kernel_uniform
)

#' @method print enriched_overpass_query
#' @export
print.enriched_overpass_query <- function(x, ...) {
  kernelpars_string <- ifelse(
    length(x$kernelpars) > 0,
    paste0("[", names(x$kernelpars), ": ", x$kernelpars, "]", collapse = ", "),
    ""
  )
  cat(
    "<enriched overpass query> \n",
    "\u00B7 Name:        ", x$name, "\n",
    "\u00B7 Features:    'key': ", x$key, "; 'value': ", x$value, "\n",
    "\u00B7 Type:        ", paste0(x$type, collapse = ", "), "\n",
    "\u00B7 Measure:    ", x$measure, "\n",
    "\u00B7 Kernel:      ", x$kernel, kernelpars_string,
    "\n ---\n",
    "\u00B7 BBox:        ", x$bbox, "\n"
  )
}