Skip to content

Commit

Permalink
httr -> httr2 for getbb for #272
Browse files Browse the repository at this point in the history
  • Loading branch information
@mpadge
mpadge committed Jun 1, 2022
1 parent 49e4c1b commit 8828dcc
Show file tree
Hide file tree
Showing 4 changed files with 77 additions and 119 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
Package: osmdata
Title: Import 'OpenStreetMap' Data as Simple Features or Spatial Objects
Version: 0.1.9.003
Version: 0.1.9.004
Authors@R: c(
person("Mark", "Padgham", , "mark.padgham@email.com", role = c("aut", "cre")),
person("Bob", "Rudis", role = "aut"),
Expand Down
48 changes: 27 additions & 21 deletions R/getbb.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -214,40 +214,46 @@ get_bb_query <- function (place_name,
base_url,
silent) {

query <- list (q = place_name)

featuretype <- tolower (featuretype)

query <- c (query, list (featuretype = featuretype))
if (base_url == "https://nominatim.openstreetmap.org") {
base_url <- "https://nominatim.openstreetmap.org/search"
}

req <- httr2::request (base_url)
req <- httr2::req_method (req, "POST")
req <- httr2::req_url_query (req, format = "json")
req <- httr2::req_url_query (req, q = place_name)
req <- httr2::req_url_query (req, featuretype = featuretype)

if (is_polygon)
query <- c (query, list (polygon_text = 1))
if (is_polygon) {
req <- httr2::req_url_query (req, polygon_text = 1)
}

query <- c (query, list (viewbox = viewbox,
format = "json",
key = key,
# bounded = 1, # seemingly not working
limit = limit))
if (!is.null (key)) {
req <- httr2::req_url_query (req, key = key)
}
if (!is.null (limit)) {
req <- httr2::req_url_query (req, limit = limit)
}

q_url <- httr::modify_url (base_url, query = query)
if (!silent) {
print (req$url)
}

if (!silent)
print(q_url)
req <- httr2::req_retry (req, max_tries = 10L)

res <- httr::RETRY ("POST", q_url, times = 10)
txt <- httr::content (res, as = "text", encoding = "UTF-8",
type = "application/xml")
obj <- tryCatch(expr = {
jsonlite::fromJSON(txt)
},
error = function(cond) {
resp <- httr2::req_perform (req)
obj <- tryCatch (
httr2::resp_body_json (resp, simplifyVector = TRUE),
error = function (e) {
# nocov start
message(paste0("Nominatim did respond as expected ",
"(e.g. due to excessive use of their api).\n",
"Please try again or use a different base_url\n",
"The url that failed was:\n", q_url))
# nocov end
}
}
)

# Code optionally select more things stored in obj...
Expand Down
2 changes: 1 addition & 1 deletion codemeta.json
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,7 +11,7 @@
"codeRepository": "https://github.com/ropensci/osmdata/",
"issueTracker": "https://github.com/ropensci/osmdata/issues",
"license": "https://spdx.org/licenses/GPL-3.0",
"version": "0.1.9.003",
"version": "0.1.9.004",
"programmingLanguage": {
"@type": "ComputerLanguage",
"name": "R",
Expand Down
144 changes: 48 additions & 96 deletions tests/testthat/test-getbb.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,46 +3,9 @@ has_internet <- curl::has_internet ()
test_all <- (identical (Sys.getenv ("MPADGE_LOCAL"), "true") |
identical (Sys.getenv ("GITHUB_WORKFLOW"), "test-coverage"))

source ("../stub.R")

get_local <- FALSE
if (get_local) {
# vcr code, for when it eventually appears on CRAN:
#bb_test <- getbb ("Salzburg")
#saveRDS (bb_test,
# file = "./tests/testthat/bb_test.Rds")

# Equivalent code using internal "stub.R" function
stub1 <- function (query) {

base_url <- "https://nominatim.openstreetmap.org"
the_url <- httr::modify_url (base_url, query = query)
cfm_output <- NULL
trace(
curl::curl_fetch_memory,
exit = function() {
cfm_output <<- returnValue()
})
res <- httr::GET (the_url)
class (cfm_output) <- "response"
untrace (curl::curl_fetch_memory)
return (cfm_output)
}

list (q = "Salzburg", viewbox = NULL, format = "json",
featuretype = "settlement", key = NULL, limit = 10) %>%
stub1 () -> cfm_output_bb
save (cfm_output_bb, file = "../cfm_output_bb1.rda")
list (q = "Salzburg", viewbox = NULL, format = "json",
polygon_text = 1,
featuretype = "settlement", key = NULL, limit = 10) %>%
stub1 () -> cfm_output_bb
save (cfm_output_bb, file = "../cfm_output_bb2.rda")
}

context ("bbox")

test_that ("bbox", {

expect_error (bbox_to_string (), "bbox must be provided")
#expect_error (bbox_to_string ("a"), "bbox must be numeric")
expect_error (bbox_to_string (1:3), "bbox must contain four elements")
Expand All @@ -52,69 +15,58 @@ test_that ("bbox", {
})

test_that ("getbb-place_name", {
if (has_internet) {
if (!test_all) {
load("../cfm_output_bb1.rda")
stub (getbb, "httr::GET", function (x) cfm_output_bb)
}
res <- getbb (place_name = "Salzburg")
expect_is (res, "matrix")
expect_length (res, 4)
res_l <- getbb (place_name = list ("Salzburg"))
expect_identical (res, res_l)
res <- getbb (place_name = "Salzburg", format_out = "string")
expect_is (res, "character")

expect_silent (res <- getbb (place_name = "Salzburg",
featuretype = "state"))
expect_output (res <- getbb (place_name = "Salzburg",
silent = FALSE))
expect_silent (res <- getbb (place_name = "Salzburg",
format_out = "data.frame"))
expect_is (res, "data.frame")
expect_error (res <- getbb (place_name = "Salzburg",
format_out = "no format"),
"format_out not recognised")
}
})
res <- getbb (place_name = "Salzburg")
expect_is (res, "matrix")
expect_length (res, 4)
# res_l <- getbb (place_name = list ("Salzburg"))
# expect_identical (res, res_l)
res <- getbb (place_name = "Salzburg", format_out = "string")
expect_is (res, "character")

skip_on_cran ()
expect_silent (res <- getbb (place_name = "Salzburg",
featuretype = "state"))
expect_output (res <- getbb (place_name = "Salzburg",
silent = FALSE))
expect_silent (res <- getbb (place_name = "Salzburg",
format_out = "data.frame"))
expect_is (res, "data.frame")
expect_error (res <- getbb (place_name = "Salzburg",
format_out = "no format"),
"format_out not recognised")
})

test_that ("getbb-polygon", {
if (has_internet) {
if (!test_all) {
load("../cfm_output_bb2.rda")
stub (getbb, "httr::GET", function (x) cfm_output_bb)
}
res <- getbb (place_name = "Salzburg",
format_out = "polygon")
expect_is (res, "list")
expect_true (all (lapply (res, nrow) > 2))
expect_true (all (vapply (res, function (i)
methods::is (i, "matrix"),
logical (1))))

expect_silent (res_str <- bbox_to_string (res [[1]]))
expect_is (res_str, "character")
res <- getbb (place_name = "Salzburg",
format_out = "polygon")
expect_is (res, "list")
expect_true (all (lapply (res, nrow) > 2))
expect_true (all (vapply (res, function (i)
methods::is (i, "matrix"),
logical (1))))

expect_silent (res_str <- bbox_to_string (res [[1]]))
expect_is (res_str, "character")

res <- getbb (place_name = "Salzburg",
format_out = "sf_polygon")
expect_is (res, "sf")
expect_is (res$geometry, "sfc_POLYGON")
expect_true (length (res$geometry) > 1)
}
})
res <- getbb (place_name = "Salzburg",
format_out = "sf_polygon")
expect_is (res, "sf")
expect_is (res$geometry, "sfc_POLYGON")
expect_true (length (res$geometry) > 1)
})

test_that ("bbox-to-string", {
bb <- cbind (1:2, 3:4)
expect_is (bbox_to_string (bb), "character")
rownames (bb) <- c ("x", "y")
colnames (bb) <- c ("min", "max")
expect_is (bbox_to_string (bb), "character")
rownames (bb) <- c ("coords.x1", "coords.x2")
colnames (bb) <- c ("min", "max")
expect_is (bbox_to_string (bb), "character")
bb <- 1:4
names (bb) <- c ("left", "bottom", "right", "top")
expect_is (bbox_to_string (bb), "character")
})

bb <- cbind (1:2, 3:4)
expect_is (bbox_to_string (bb), "character")
rownames (bb) <- c ("x", "y")
colnames (bb) <- c ("min", "max")
expect_is (bbox_to_string (bb), "character")
rownames (bb) <- c ("coords.x1", "coords.x2")
colnames (bb) <- c ("min", "max")
expect_is (bbox_to_string (bb), "character")
bb <- 1:4
names (bb) <- c ("left", "bottom", "right", "top")
expect_is (bbox_to_string (bb), "character")
})

0 comments on commit 8828dcc

Please # to comment.