diff --git a/R/wfs_intersect.R b/R/wfs_intersect.R index d84bb9a..9168663 100644 --- a/R/wfs_intersect.R +++ b/R/wfs_intersect.R @@ -35,6 +35,10 @@ wfs_intersect <- function(df, stop("x_lam and y_lam should be columns in the df") } + # add x_lam & y_lam to the df #### + df$x_lam <- df[[x_lam]] + df$y_lam <- df[[y_lam]] + # check if x_lam & y_lam are numeric #### # if (!all(sapply(df[, c(x_lam, y_lam)], is.numeric))) { # warning("x_lam and y_lam should be numeric >> converting to numeric") @@ -44,20 +48,31 @@ wfs_intersect <- function(df, # check if geometry is in the df #### if ("sf" %in% class(df)) { - print("sf object detected >> dropping geometry") + print("sf object detected >> testing crs & dropping geometry") + + ## check if crs is provided #### + if (is.null(sf::st_crs(df))) { + warning("crs is not provided in the sf object >> skipping crs test") + } else { + ### check if crs is the same as the provided crs #### + if (sf::st_crs(df) != crs) { + warning("crs of the sf object is not the same as the provided crs >> converting to the provided crs & + recalculating points") + df <- sf::st_transform(df, crs) %>% + dplyr::mutate(x_lam := sf::st_coordinates(.)[,1], + y_lam := sf::st_coordinates(.)[,2]) + } + } + ## drop the geometry #### df <- df %>% sf::st_drop_geometry() } - # add x_lam & y_lam to the df #### - df$x_lam <- df[[x_lam]] - df$y_lam <- df[[y_lam]] - # check if x_lam & y_lam are provided ## ## filter missing x_lam & y_lam values #### missing_x_y <- df %>% dplyr::filter(is.na(x_lam) | - is.na(y_lam)) + is.na(y_lam)) if (nrow(missing_x_y) > 0) { warning(paste(nrow(missing_x_y), "rows with missing x_lam & y_lam values")) @@ -107,33 +122,51 @@ wfs_intersect <- function(df, pb$tick() ### make the query #### - query <- list( + par_url <- httr::parse_url(url) + par_url$query <- list( service = "WFS", version = "2.0.0", request = "GetFeature", typeName = layer, - crs = "EPSG:6.9:31370", + crs = crs, CQL_FILTER = sprintf( "INTERSECTS(geom,POINT(%s %s))", df$x_lam[i], df$y_lam[i] ), - outputFormat = "csv", resultType = "results", maxFeatures = 1, - uniqueParam = runif(1) # Adding a unique parameter to bypass cache + uniqueParam = as.numeric(Sys.time()) # Adding a unique parameter to bypass cache ) - response <- httr::GET(url, query = query) - # Check if the request was successful - if (httr::http_type(response) != "text/csv") { + response <- httr::GET(httr::build_url(par_url)) + + ### Check if the request was successful #### + if (httr::status_code(response) != 200) { + stop("Failed to get data from WFS. Status code: ", httr::status_code(response)) + } + + ### Check if the response content is of a allowed type #### + allowed_content_types <- c("text/csv", "text/plain", "application/xml") + + if (!httr::http_type(response) %in% allowed_content_types) { stop("Failed to get data from WFS. Status code: ", httr::status_code(response), - "http_type: ", httr::http_type(response), " expects text/csv") + "http_type: ", httr::http_type(response), " expects ", + paste(allowed_content_types, colapse = ", "), " response. + >> check wfs metadata if output is supported") } - # Parse the result - wfs_info <- read.csv(textConnection(httr::content(response, "text"))) %>% - as.data.frame() %>% - dplyr::rename(geometry = Shape) + ### Parse the result #### + # response is a csv file or a text file + if(httr::http_type(response) == "text/csv" | httr::http_type(response) == "text/plain") { + wfs_info <- read.csv(textConnection(httr::content(response, "text"))) %>% + as.data.frame() + } + + # response is a xml file + if(httr::http_type(response) == "application/xml") { + wfs_info <- xml2::read_xml(httr::content(response, "text")) %>% + xml2::as_list() + } ### recombine the data #### @@ -169,6 +202,10 @@ wfs_intersect <- function(df, rm(wfs_info) rm(response) } + + ### add the wfs_info_df to the df #### + wfs_info_df <- cbind(df, wfs_info_df) + return(wfs_info_df) }