R/geolocate_polygon.R

In galah: Biodiversity Data from the GBIF Node Network

#' @rdname geolocate
#' @order 3
#' @export
geolocate_polygon <- function(...){
  # check to see if any of the inputs are a data request
  query <- list(...)
  if(length(query) > 1 & inherits(query[[1]], "data_request")){
    dr <- query[[1]]
    query <- query[-1]
  }else{
    dr <- NULL
  }
  # check that only 1 WKT is supplied at a time
  check_n_inputs(query)
  # parse
  out_query <- parse_polygon(query)
  # if a data request was supplied, return one
  if(!is.null(dr)){
    update_request_object(dr,
                          geolocate = out_query)
  }else{
    out_query
  }   
}

#' parser for polygons
#' @noRd
#' @keywords Internal
parse_polygon <- function(query, 
                          error_call = rlang::caller_env()){
  # make sure shapefiles are processed correctly
  if (!inherits(query, "sf")) {
    query <- query[[1]]
  } else {
    query <- query
  }
  
  # check object is accepted class
  accepted_classes <-  c("character",
                         "list",
                         "matrix",
                         "data.frame",
                         "tbl",
                         "sf",
                         "sfc",
                         "XY")
  if (!inherits(query, accepted_classes)) {
    
    unrecognised_class <- class(query)
    c("Invalid object detected.",
      i = "Did you provide a polygon or WKT in the right format?",
      x = "`galah_polygon` cannot use object of class '{unrecognised_class}'.") |>
    cli::cli_abort(call = error_call)
  }
  
  # handle shapefiles
  if (inherits(query, "XY")){
    query <- sf::st_as_sfc(query) 
  } 
  
  # make sure spatial object or wkt is valid
  if (!inherits(query, c("sf", "sfc"))) {
    check_wkt_length(query)
    
    # handle errors from converting impossible WKTs
    query <- rlang::try_fetch(
      query |> sf::st_as_sfc(), 
      error = function(cnd) {
        c("Invalid WKT detected.",
          i = "Check that the spatial feature or WKT in `galah_polygon` is correct.") |>
        cli::cli_abort(call = error_call)
      })
  }
  
  # validate that wkt/spatial object is real
  valid <- query |> sf::st_is_valid() 
  
  if(any(is.na(valid))) {
    c("Invalid spatial object or WKT detected.",
      i = "Check that the spatial feature or WKT in `galah_polygon` is correct.") |>
    cli::cli_abort(call = error_call)
  }
  
  # check number of vertices of WKT
  if(any(n_points(query) > 500)) {
    n_verts <- n_points(query)
    c("Polygon has too many vertices.",
      i = "`galah_polygon` only accepts simple polygons.",
      i = "See `?sf::st_simplify` for how to simplify geospatial objects.",
      x = "Polygon must have 500 or fewer vertices, not {n_verts}.") |>
    cli::cli_abort(call = error_call)
  }
  
  check_crs(query)  # check whether crs is epsg:4326
  
  # currently a bug where the ALA doesn't accept some polygons
  # to avoid any issues, any polygons are converted to multipolygons
  if(inherits(query, "sf") || inherits(query, "sfc")) {

    if(length(query$geometry) < 2) {
    out_query <- build_wkt(query)
    } else {
    # multiple polygons
      n_polygons <- length(query$geometry)
      c("Too many polygons.",
        i = "`galah_polygon` cannot accept more than 1 polygon at a time.",
        x = "{n_polygons} polygons detected in spatial object.") |>
      cli::cli_abort(call = error_call)
      
      ## NOTE: Code below parses multiple polygons. 
      ##       Please do not remove!
      ##       Code works but unsure how to pass to ALA query just yet
    
      # out_query <- query |>
      #   mutate(
      #     wkt_string = map_chr(.x = query$geometry,
      #                          .f = build_wkt),
      #     row_id = dplyr::row_number()) |>
      #   as_tibble() |>
      #   select(row_id, wkt_string)
    }
  } else {
    
    # remove space after "POLYGON" if present
    if(stringr::str_detect(query, "POLYGON \\(\\("))
      query <- stringr::str_replace(query, "POLYGON \\(\\(", "POLYGON\\(\\(")
    
    if (stringr::str_detect(query, "POLYGON") &
        !stringr::str_detect(query, "MULTIPOLYGON")) {
      # change start of string
      query <- stringr::str_replace(query, "POLYGON\\(\\(", "MULTIPOLYGON\\(\\(\\(")
      # add an extra bracket
      query <- glue::glue("{query})")
    }
    out_query <- query
  }
  out_query
}

#' Internal function to `galah_polygon`
#' @noRd
#' @keywords Internal
n_points <- function(x) {
  count_vertices(sf::st_geometry(x))
}

#' Internal function to `galah_polygon`
#' @noRd
#' @keywords Internal
count_vertices <- function(wkt_string) {
  out <- if (is.list(wkt_string)) 
    sapply(sapply(wkt_string, count_vertices), sum) 
  else {
    if (is.matrix(wkt_string))
        nrow(wkt_string)
    else {
      if (!sf::st_is_empty(wkt_string)) 1 else
        0
      }
  }
  unname(out)
}

#' Internal function to `galah_polygon`
#' @noRd
#' @keywords Internal
check_wkt_length <- function(wkt,
                             error_call = rlang::caller_env()) {
  if (rlang::is_string(wkt) == TRUE |
      is.matrix(wkt) == TRUE  | 
      rlang::is_list(wkt) == TRUE | 
      is.data.frame(wkt) == TRUE) {
    # make sure strings aren't too long for API call
    if(!inherits(wkt, "character")){
      cli::cli_abort("Argument `wkt` must be of class 'character'",
                     call = error_call)
    }
    n_char_wkt <- nchar(wkt)
    max_char <- 10000
    if (n_char_wkt > max_char) {
      c("Invalid WKT detected.",
        x = "WKT string can be maximum {max_char} characters. WKT supplied has {n_char_wkt}.") |>
      cli::cli_abort(call = error_call)
    }
  } 
}