R/geocode_combine.R

In jessecambon/tidygeocoder: Geocoding Made Easy

get_queries_parameter_documentation <- function() {
  return(c(
    "a list of queries, each provided as a list of parameters. The queries are",
    "executed by the [geocode] function in the order provided.",
    "(ex. `list(list(method = 'osm'), list(method = 'census'), ...)`)"
  ))
}

get_global_params_parameter_documentation <- function() {
  return(c(
    "a list of parameters to be used for all queries",
    "(ex. `list(address = 'address', full_results = TRUE)`)"
  ))
}


#' Combine multiple geocoding queries
#'
#' @description Passes address inputs in character vector form to the
#'  [geocode_combine] function for geocoding.
#'
#'  Note that address inputs must be specified for queries either with the `queries` parameter (for each query)
#'  or the `global_params` parameter (for all queries). For example `global_params = list(address = 'address')`
#'  passes addresses provided in the `address` parameter to all queries.
#'
#' @param queries `r get_queries_parameter_documentation()`
#' @param global_params `r get_global_params_parameter_documentation()`
#' @inheritParams geo
#' @param ... arguments passed to the [geocode_combine] function
#' @inherit geo return
#' @examples
#' \donttest{
#'
#' options(tidygeocoder.progress_bar = FALSE)
#' example_addresses <- c("100 Main St New York, NY", "Paris", "Not a Real Address")
#'
#' geo_combine(
#'   queries = list(
#'     list(method = "census"),
#'     list(method = "osm")
#'   ),
#'   address = example_addresses,
#'   global_params = list(address = "address")
#' )
#'
#' geo_combine(
#'   queries = list(
#'     list(method = "arcgis"),
#'     list(method = "census", mode = "single"),
#'     list(method = "census", mode = "batch")
#'   ),
#'   global_params = list(address = "address"),
#'   address = example_addresses,
#'   cascade = FALSE,
#'   return_list = TRUE
#' )
#'
#' geo_combine(
#'   queries = list(
#'     list(method = "arcgis", address = "city"),
#'     list(method = "osm", city = "city", country = "country")
#'   ),
#'   city = c("Tokyo", "New York"),
#'   country = c("Japan", "United States"),
#'   cascade = FALSE
#' )
#' }
#' @seealso [geocode_combine] [geo] [geocode]
#' @export
geo_combine <- function(queries, global_params = list(), address = NULL,
                        street = NULL, city = NULL, county = NULL, state = NULL, postalcode = NULL,
                        country = NULL, lat = lat, long = long, ...) {

  # NSE - converts lat and long parameters to character values
  lat <- rm_quote(deparse(substitute(lat)))
  long <- rm_quote(deparse(substitute(long)))

  # Check address arguments -------------------------------------
  address_pack <- package_addresses(
    address, street, city, county,
    state, postalcode, country
  )

  # prepare data for geocode_combine() function -----------------
  input_df <- tibble::tibble(
    address = address,
    street = street, city = city, county = county, state = state, postalcode = postalcode, country = country
  )

  # pass arguments to geocode_combine() as a list. lat and long arguments did not work when passed directly
  arguments_to_pass <- c(
    list(
      .tbl = input_df, queries = queries, global_params = global_params, lat = lat, long = long
    ),
    list(...)
  )

  return(
    do.call(geocode_combine, arguments_to_pass)
  )
}


#' Combine multiple geocoding queries
#'
#' @description Executes multiple geocoding queries on a dataframe input and combines
#'  the results. To use a character vector input instead, see the [geo_combine] function.
#'  Queries are executed by the [geocode] function. See example usage
#'  in `vignette("tidygeocoder")`.
#'
#'  Query results are by default labelled to show which query produced each result. Labels are either
#'  placed in a `query` column (if `return_list = FALSE`) or used as the names of the returned list
#'  (if `return_list = TRUE`). By default the `method` parameter value of each query is used as a query label.
#'  If the same `method` is used in multiple queries then a number is added according
#'  to the order of the queries (ie. `osm1`, `osm2`, ...). To provide your own custom query labels
#'  use the `query_names` parameter.
#'
#' @param queries `r get_queries_parameter_documentation()`
#' @param global_params `r get_global_params_parameter_documentation()`
#' @param return_list if TRUE then results from each service will be returned as separate
#'   dataframes. If FALSE (default) then all results will be combined into a single dataframe.
#' @param cascade if TRUE (default) then only addresses that are not found by a geocoding
#'   service will be attempted by subsequent queries. If FALSE then all queries will
#'   attempt to geocode all addresses.
#' @param query_names optional vector with one label for each query provided
#'   (ex. `c('geocodio batch', 'geocodio single')`).
#' @inheritParams geocode
#' @inherit geo return
#' @examples
#' \donttest{
#'
#' library(dplyr, warn.conflicts = FALSE)
#'
#' sample_addresses %>%
#'   geocode_combine(
#'     queries = list(list(method = "census"), list(method = "osm")),
#'     global_params = list(address = "addr"), cascade = TRUE
#'   )
#'
#' more_addresses <- tibble::tribble(
#'   ~street_address, ~city, ~state, ~zip_cd,
#'   "624 W DAVIS ST #1D", "BURLINGTON", "NC", 27215,
#'   "201 E CENTER ST #268", "MEBANE", "NC", 27302,
#'   "100 Wall Street", "New York", "NY", 10005,
#'   "Bucharest", NA, NA, NA
#' )
#'
#' more_addresses %>%
#'   geocode_combine(
#'     queries = list(
#'       list(method = "census", mode = "batch"),
#'       list(method = "census", mode = "single"),
#'       list(method = "osm")
#'     ),
#'     global_params = list(
#'       street = "street_address",
#'       city = "city", state = "state", postalcode = "zip_cd"
#'     ),
#'     query_names = c("census batch", "census single", "osm")
#'   )
#'
#' more_addresses %>%
#'   geocode_combine(
#'     queries = list(
#'       list(
#'         method = "census", mode = "batch", street = "street_address",
#'         city = "city", state = "state", postalcode = "zip_cd"
#'       ),
#'       list(method = "arcgis", address = "street_address")
#'     ),
#'     cascade = FALSE,
#'     return_list = TRUE
#'   )
#' }
#' @seealso [geo_combine] [geo] [geocode]
#' @export
geocode_combine <-
  function(.tbl,
           queries,
           global_params = list(),
           return_list = FALSE,
           cascade = TRUE,
           query_names = NULL,
           lat = "lat",
           long = "long") {

    # NSE - converts lat and long parameters to character values
    lat <- rm_quote(deparse(substitute(lat)))
    long <- rm_quote(deparse(substitute(long)))

    stopifnot(
      is.data.frame(.tbl),
      is.list(queries),
      # either queries is an empty list or contains other lists
      length(queries) == 0 || all(sapply(queries, is.list)),
      is.list(global_params), is.logical(return_list), is.logical(cascade),
      is.null(query_names) || is.character(query_names)
    )

    # combine all parameter lists into a list of lists
    all_param_lists <- queries
    all_param_lists[[length(queries) + 1]] <- global_params

    # get all parameter names
    all_param_names <- unlist(sapply(all_param_lists, names))

    # which columns are used to store addresses
    used_address_colnames <- unique(unlist(sapply(
      all_param_lists,
      function(x) unlist(x[names(x) %in% pkg.globals$address_arg_names], use.names = FALSE)
    )))

    if (cascade == TRUE) {
      for (query in all_param_lists) {
        if (!is.null(query[["return_input"]]) && query[["return_input"]] == FALSE) {
          stop("return_input must be set to TRUE for geocode_combine()", call. = FALSE)
        }
      }
    }

    # add global arguments to each query
    queries_prepped <- lapply(queries, function(x) {
      c(
        list(.tbl = .tbl, lat = lat, long = long),
        global_params,
        x
      )
    })

    # Set default query names and check user input query names
    if (is.null(query_names)) {
      # default query names to the method arguments and fill in 'osm' if the method argument isn't provided
      query_names <- unlist(lapply(queries_prepped, function(q) if (!is.null(q[["method"]])) q[["method"]] else "osm"))

      # number duplicate query names if necessary (to prevent duplicates)
      # ie. 'osm1', 'osm2', etc.
      for (name in unique(query_names)) {
        # if the given name occurs more than once in query_names then iterate through and add numbers
        if ((sum(query_names == name)) > 1) {
          i <- 1
          dup_num <- 1
          for (i in 1:length(query_names)) {
            if (query_names[[i]] == name) {
              query_names[[i]] <- paste0(query_names[[i]], as.character(dup_num), collapse = "")
              dup_num <- dup_num + 1
            }
          }
        }
      }
    } else {
      if (length(query_names) != length(queries)) {
        stop("query_names parameter must contain one name per query provided. See ?geocode_combine")
      }

      if (any(duplicated(query_names)) == TRUE) {
        stop("query_names values should be unique. See ?geocode_combine")
      }

      if (any(trimws(query_names) == "")) {
        stop("query_names values should not be blank. See ?geocode_combine")
      }
    }

    # Sanity check all queries (ie. make sure no queries have a mistyped argument, etc.)
    for (query in queries_prepped) {
      query[["no_query"]] <- TRUE

      tryCatch(
        expr = {
          suppressMessages(do.call(geocode, query))
        },
        error = function(e) {
          message("The following error was produced:\n")
          message(e)

          message("\n\nBy these query parameters:\n")
          for (name in names(query)) {
            # don't display .tbl parameter for now
            if (name != ".tbl") message(paste0(name, " = ", query[[name]]))
          }
        },
        finally = {
          message("")
        }
      )
    }

    # iterate through the queries (list of lists) and execute each query
    # aggregate results in list object
    all_results <- list()
    not_found <- tibble::tibble()
    for (i in 1:length(queries_prepped)) {
      query <- queries_prepped[[i]]
      if (cascade == TRUE) {
        # adjust the input dataframe based on which addresses were not found in prior query
        if (nrow(not_found) != 0) {
          query[[".tbl"]] <- not_found
        } else if (i != 1) {
          break # break loop - all addresses are geocoded
        }
      }

      # use geocode() to execute the query
      result <- do.call(geocode, query)
      na_indices <- is.na(result[[lat]]) | is.na(result[[long]])

      # which addresses were not found
      not_found <- result[na_indices, intersect(colnames(result), colnames(.tbl))]
      found <- result[!is.na(result[[lat]]) & !is.na(result[[long]]), ]

      # aggregate results. if using cascade then separate the not-found addresses
      all_results <- if (cascade == TRUE) c(all_results, list(found)) else c(all_results, list(result))
    }

    names(all_results) <- query_names[1:length(all_results)]

    # if there are addresses that no method found then in cascade then
    # separate them into their own list item
    if (cascade == TRUE) {
      if (nrow(not_found) != 0) all_results[[length(all_results) + 1]] <- not_found
    }

    # bind all results into one dataframe if return_list == FALSE
    # otherwise return list
    if (return_list == TRUE) {
      return(all_results)
    } else {

      # label the dataframes contained in the all_results list with a 'query' column
      all_results_labeled <- mapply(function(x, y) dplyr::bind_cols(x, tibble::tibble(query = y)),
        all_results, names(all_results),
        SIMPLIFY = FALSE
      )

      # put all results into a single dataframe
      bound_data <- dplyr::bind_rows(all_results_labeled)

      # remove .id column if it is present
      bound_data <- bound_data[!names(bound_data) %in% ".id"]

      # reorder the dataset to match the order it was received in before returning it
      proper_order <- unique(.tbl[used_address_colnames])
      proper_order[[".id"]] <- 1:nrow(proper_order)

      # join to get our .id column so we can sort the output dataset
      bound_data_joined <- dplyr::left_join(bound_data, proper_order, by = used_address_colnames)

      # sort the dataset
      bound_data_joined <- bound_data_joined[order(bound_data_joined[[".id"]]), ]

      # remove .id column before returning the dataset
      return(bound_data_joined[!names(bound_data_joined) %in% ".id"])
    }
  }