R/wfs_api.R

In rOpenGov/helsinki: R Tools for Helsinki Open Data

#' @title WFS API
#'
#' @description Requests to various WFS API.
#'
#' @details Make a request to the spesific WFS API. The base url is
#'    https://kartta.hsy.fi/geoserver/wfs to which other
#'    components defined by the arguments are appended.
#'
#'    This is a low-level function intended to be used by other higher level
#'    functions in the package.
#'
#' @source Gracefully failing HTTP request code (slightly adapted by Pyry
#'    Kantanen) from RStudio community member kvasilopoulos. Many thanks!
#'
#'    Source of the original RStudio community discussion:
#'    \url{https://community.rstudio.com/t/internet-resources-should-fail-gracefully/49199}
#'
#' @param base.url WFS url, for example "https://kartta.hsy.fi/geoserver/wfs"
#' @param queries List of query parameters
#' @param ... For passing parameters to embedded functions, for example
#' *timeout.s* (timeout in seconds) in the case of **gracefully_fail()**
#' internal function
#'
#' @return wfs_api (S3) object with the following attributes:
#'        \describe{
#'           \item{content}{XML payload.}
#'           \item{path}{path provided to get the resonse.}
#'           \item{response}{the original response object.}
#'         }
#'
#' @author Joona Lehtomäki <joona.lehtomaki@@iki.fi>, Kostas Vasilopoulos,
#'    Pyry Kantanen
#'
#' @examples
#' \dontrun{
#' wfs_api(
#'   base.url = "https://kartta.hsy.fi/geoserver/wfs",
#'   queries = c(
#'     "service" = "WFS",
#'     "version" = "1.0.0",
#'     "request" = "getFeature",
#'     "typeName" = "ilmanlaatu:Ilmanlaatu_nyt"
#'   )
#' )
#' }
#'
#' @importFrom xml2 read_xml xml_text xml_has_attr xml_children
#' @importFrom httr GET timeout user_agent modify_url http_error message_for_status
#' @importFrom curl has_internet
#'
#' @export
wfs_api <- function(base.url = NULL, queries, ...) {
  if (!is.character(base.url)) {
    base.url <- as.character(base.url)
  }

  if (is.null(base.url)) {
    stop("base.url = NULL. Please input a valid WFS url")
  }

  if (!grepl("^http", base.url)) {
    stop("Invalid base URL")
  }

  if (is.null(names(queries))) {
    message("Please input the list in name-value pairs: c(\"name1\" = \"value1\", \"name2\" = \"value2\", ...)")
    invisible(return(NULL))
  }

  # Test if queries is a named "Named num" or "Named chr" vector
  if (is.vector(queries, mode = "character") || is.vector(queries, mode = "numeric")) {
    queries <- as.list(queries)
  }

  if (!is.list(queries)) {
    message("Please input the list in name-value pairs: c(\"name1\" = \"value1\", \"name2\" = \"value2\", ...)")
    invisible(return(NULL))
  }

  # Set the user agent
  ua <- httr::user_agent("https://github.com/rOpenGov/helsinki")

  # Construct the query URL
  url <- httr::modify_url(base.url, query = queries)

  # Print out the URL
  message("Requesting response from: ", url)

  graceful_result <- gracefully_fail(url)

  if (is.null(graceful_result)) {
    message("Please check your settings or function parameters \n")
    return(invisible(NULL))
  }

  # Get the response and check the response.
  resp <- httr::GET(url, ua)

  # Parse the response XML content
  content <- xml2::read_xml(resp$content)

  # Object for checking exceptions
  content_child <- xml2::xml_children(content)
  truth_table <- vapply(
    X = content_child,
    FUN = xml2::xml_has_attr,
    FUN.VALUE = logical(1),
    "exceptionCode"
  )

  # Even if GET and read_xml work properly, content can be unusable
  if (any(truth_table)) {
    message(paste(
      "Please check your download parameters.",
      "Detected following exception(s):\n",
      xml2::xml_text(content)
    ))
    return(invisible(NULL))
  }

  api_obj <- structure(
    list(
      url = url,
      response = resp
    ),
    class = "wfs_api"
  )

  # Attach the nodes to the API object
  api_obj$content <- content

  return(api_obj)
}

#' @title Gracefully fail internet resources
#'
#' @description Function for gracefully failing internet resources
#'
#' @author Kostas Vasilopoulos
#'
#' @source Gracefully failing HTTP request code (slightly adapted by Pyry
#'    Kantanen) from RStudio community member kvasilopoulos. Many thanks!
#'
#'    Source of the original RStudio community discussion:
#'    \url{https://community.rstudio.com/t/internet-resources-should-fail-gracefully/49199}
#'
#' @importFrom httr GET http_error message_for_status
#' @importFrom curl has_internet
#'
#' @keywords internal
gracefully_fail <- function(remote.file, timeout.s = NULL) {
  if (is.null(timeout.s)) {
    timeout.s <- 10
  }

  try_GET <- function(x, ...) {
    tryCatch(
      httr::GET(url = x, timeout(timeout.s), ...),
      error = function(e) conditionMessage(e),
      warning = function(w) conditionMessage(w)
    )
  }

  is_response <- function(x) {
    class(x) == "response"
  }

  # First check internet connection
  if (!curl::has_internet()) {
    message("No internet connection")
    return(invisible(NULL))
  }
  # Then try for timeout problems
  resp <- try_GET(remote.file)
  if (!is_response(resp)) {
    message(resp)
    return(invisible(NULL))
  }
  # Then stop if status > 400
  if (httr::http_error(resp)) {
    httr::message_for_status(resp)
    message("\n")
    return(invisible(NULL))
  }

  x <- "all ok"
  invisible(x)
}