Skip to content

Commit

Permalink
Merge pull request #163 from rolfsimoes/dev
Browse files Browse the repository at this point in the history
Pre-release version 1.0.1
  • Loading branch information
rolfsimoes authored Jun 10, 2024
2 parents f10126e + 7eb8ec9 commit 6d253ab
Show file tree
Hide file tree
Showing 15 changed files with 356 additions and 33 deletions.
13 changes: 11 additions & 2 deletions DESCRIPTION
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
Package: rstac
Title: Client Library for SpatioTemporal Asset Catalog
Version: 1.0.0
Version: 1.0.1
Authors@R:
c(person("Rolf", "Simoes",
email = "rolfsimoes@gmail.com",
Expand Down Expand Up @@ -38,7 +38,14 @@ Imports:
Suggests:
lifecycle,
testthat,
knitr
knitr,
tmap,
leaflet,
stars,
slider,
ggplot2,
purrr,
dplyr
Collate:
'cql2-expr-funs.R'
'cql2-types.R'
Expand All @@ -54,6 +61,7 @@ Collate:
'assets-funs.R'
'check-utils.R'
'conformance-query.R'
'collections-funs.R'
'collections-query.R'
'deprec-funs.R'
'doc-funs.R'
Expand All @@ -80,3 +88,4 @@ Collate:
'rstac.R'
'rstac-funs.R'
Roxygen: list(markdown = TRUE)
VignetteBuilder: knitr
4 changes: 4 additions & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -174,6 +174,10 @@ export(assets_rename)
export(assets_select)
export(assets_url)
export(collections)
export(collections_fetch)
export(collections_length)
export(collections_matched)
export(collections_next)
export(conformance)
export(cql2_bbox_as_geojson)
export(cql2_date)
Expand Down
2 changes: 2 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
@@ -1,3 +1,5 @@
# rstac (development version)

# rstac 1.0.0 (Released 2024-02-14)

* Add support to static catalogs;
Expand Down
10 changes: 8 additions & 2 deletions R/assets-funs.R
Original file line number Diff line number Diff line change
Expand Up @@ -43,6 +43,9 @@
#' @param progress a `logical` indicating if a progress bar must be
#' shown or not. Defaults to `TRUE`.
#'
#' @param use_gdal a `logical` indicating if the file should be downloaded
#' by GDAL instead httr package.
#'
#' @param download_fn a `function` to handle download of assets for
#' each item to be downloaded. Using this function, you can change the
#' hrefs for each asset, as well as the way download is done.
Expand Down Expand Up @@ -182,6 +185,7 @@ assets_download <- function(items,
asset_names = NULL,
output_dir = getwd(),
overwrite = FALSE, ...,
use_gdal = FALSE,
download_fn = NULL) {
# check output dir
if (!dir.exists(output_dir))
Expand All @@ -197,6 +201,7 @@ assets_download.doc_item <- function(items,
asset_names = NULL,
output_dir = getwd(),
overwrite = FALSE, ...,
use_gdal = FALSE,
create_json = FALSE,
download_fn = NULL) {
if (!is.null(asset_names)) {
Expand All @@ -209,7 +214,7 @@ assets_download.doc_item <- function(items,
}
items$assets <- lapply(
items$assets, asset_download, output_dir = output_dir,
overwrite = overwrite, ..., download_fn = download_fn
overwrite = overwrite, use_gdal = use_gdal, download_fn = download_fn, ...
)
if (create_json) {
file <- "item.json"
Expand All @@ -228,6 +233,7 @@ assets_download.doc_items <- function(items,
asset_names = NULL,
output_dir = getwd(),
overwrite = FALSE, ...,
use_gdal = FALSE,
download_fn = NULL,
create_json = TRUE,
items_max = Inf,
Expand All @@ -249,7 +255,7 @@ assets_download.doc_items <- function(items,
items$features[[i]] <- assets_download(
items = items$features[[i]], asset_names = asset_names,
output_dir = output_dir, overwrite = overwrite,
create_json = FALSE, download_fn = download_fn, ...
use_gdal = use_gdal, create_json = FALSE, download_fn = download_fn, ...
)
}
if (create_json)
Expand Down
37 changes: 27 additions & 10 deletions R/assets-utils.R
Original file line number Diff line number Diff line change
Expand Up @@ -56,19 +56,36 @@ select_exec <- function(key, asset, select_fn) {
asset_download <- function(asset,
output_dir,
overwrite, ...,
use_gdal = FALSE,
download_fn = NULL) {
if (!is.null(download_fn))
return(download_fn(asset))
# create a full path name
path <- url_get_path(asset$href)
out_file <- path_normalize(output_dir, path)
dir_create(out_file)
make_get_request(
url = asset$href,
httr::write_disk(path = out_file, overwrite = overwrite),
...,
error_msg = "Error while downloading"
)
asset$href <- path
out_file <- path_normalize(output_dir, url_get_path(asset$href))
out_dir <- dirname(out_file)
if (!dir.exists(out_dir))
dir.create(out_dir, recursive = TRUE)
stopifnot(dir.exists(out_dir))
if (use_gdal) {
if (file.exists(out_file) && !overwrite)
.error("File already exists. Use `overwrite=TRUE`.")
if (file.exists(out_file))
unlink(out_file)
sf::gdal_utils(
util = "translate",
source = gdalvsi_append(asset$href),
destination = out_file, ...
)
if (!file.exists(out_file)) {
.error("Download failed. File: '%s'.", asset$href)
}
} else {
make_get_request(
url = asset$href,
httr::write_disk(path = out_file, overwrite = overwrite),
error_msg = "Error while downloading", ...
)
}
asset$href <- out_file
asset
}
8 changes: 8 additions & 0 deletions R/check-utils.R
Original file line number Diff line number Diff line change
Expand Up @@ -74,6 +74,14 @@ check_collection <- function(collection) {
collection
}

check_collections <- function(collections) {
if (!is.list(collections) || is.null(names(collections)))
.error("Invalid doc_collections object.")
if (!"links" %in% names(collections))
.error("Invalid doc_collections object. Expecting `links` key.")
collections
}

check_character <- function(x, msg, ...) {
if (!is.character(x))
.error(msg, ...)
Expand Down
161 changes: 161 additions & 0 deletions R/collections-funs.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,161 @@
#' @title Collections functions
#'
#' @description
#' These functions provide support to work with
#' `doc_collections`objects.
#'
#' \itemize{
#' \item `collections_length()`: `r lifecycle::badge('experimental')`
#' shows how many items there are in the `doc_items` object.
#'
#' \item `collections_matched()`: `r lifecycle::badge('experimental')`
#' shows how many items matched the search criteria.
#'
#' \item `collections_fetch()`: `r lifecycle::badge('experimental')`
#' request all STAC Items through pagination.
#'
#' \item `collections_next()`: `r lifecycle::badge('experimental')`
#' fetches a new page from STAC service.
#'
#' }
#'
#' @param collections a `doc_collections` object.
#'
#' @param matched_field a `character` vector with the path
#' where is the number of collections returned.
#'
#' @param progress a `logical` indicating if a progress bar must be
#' shown or not. Defaults to `TRUE`.
#'
#' @param ... additional arguments. See details.
#'
#' @details
#' Ellipsis argument (`...`) appears in different items functions and
#' has distinct purposes:
#'
#' \itemize{
#' \item `collections_fetch()` and `collections_next()`: ellipsis is used to
#' pass additional `httr` options to [GET][httr::GET] method, such as
#' [add_headers][httr::add_headers] or [set_cookies][httr::set_cookies].
#'
#' }
#'
#' @return
#'
#' \itemize{
#' \item `collections_length()`: an `integer` value.
#'
#' \item `collections_matched()`: returns an `integer` value if the STAC web
#' server does support this extension. Otherwise returns `NULL`.
#'
#' \item `collections_fetch()`: a `doc_items` with all matched items.
#'
#' \item `collections_next()`: fetches a new page from STAC service.
#'
#' }
#'
#' @examples
#' \dontrun{
#' # doc_items object
#' stac("https://cmr.earthdata.nasa.gov/stac/LPCLOUD") |>
#' collections() |>
#' get_request() |>
#' collections_fetch()
#' }
#'
#' @name collections_functions
NULL



#' @rdname collections_functions
#'
#' @export
collections_next <- function(collections, ...) {
check_collection(collections)
# get url of the next page
rel <- NULL
next_link <- links(collections, rel == "next")
if (length(next_link) == 0)
.error("Cannot get next link URL.", class = "next_error")
next_link <- next_link[[1]]
res <- make_get_request(
url = next_link$href,
headers = next_link$headers,
...,
error_msg = "Error while requesting next page"
)
content <- content_response_json(res)
# return items
doc_collections(content)
}

#' @rdname collections_functions
#'
#' @export
collections_matched <- function(collections, matched_field) {
check_collections(collections)
matched <- NULL
if (is.character(matched_field) && matched_field %in% names(collections))
matched <- as.numeric(collections[[matched_field]])
matched
}

#' @rdname collections_functions
#'
#' @export
collections_length <- function(collections) {
check_collections(collections)
return(length(collections$collections))
}

#' @rdname collections_functions
#'
#' @export
collections_fetch <- function(collections, ...,
progress = TRUE,
matched_field = NULL) {
check_collections(collections)
matched <- collections_matched(collections, matched_field)
# verify if progress bar can be shown
progress <- progress &
(!is.null(matched) && (collections_fetch(collections) < matched))
if (progress) {
pb <- utils::txtProgressBar(
min = collections_length(collections),
max = matched,
style = 3
)
# close progress bar when exit
on.exit({
if (progress) {
utils::setTxtProgressBar(pb, matched)
close(pb)
}
})
}
# Initialize the items
next_collections <- collections
while (TRUE) {
# check if features is complete
if (!is.null(matched) && (collections_length(collections) == matched))
break
# protect against infinite loop
if (!is.null(matched) && (collections_length(collections) > matched))
.error(paste(
"Length of returned collections (%s) is different",
"from matched collections (%s)."),
collections_length(collections), matched)
next_collections <- tryCatch({
collections_next(next_collections, ...)
}, next_error = function(e) NULL)
if (is.null(next_collections))
break
collections$collections <- c(collections$collections,
next_collections$collections)
# update progress bar
if (progress)
utils::setTxtProgressBar(pb, length(next_collections))
}
collections
}
9 changes: 7 additions & 2 deletions R/collections-query.R
Original file line number Diff line number Diff line change
Expand Up @@ -14,11 +14,14 @@
#' Collection object
#' }
#'
#' @param q a `rstac_query` object expressing a STAC query
#' @param q a `rstac_query` object expressing a STAC query
#' criteria.
#'
#' @param collection_id a `character` collection id to be retrieved.
#'
#' @param limit an `integer` defining the maximum number of results
#' to return. If not informed, it defaults to the service implementation.
#'
#' @seealso
#' [get_request()], [post_request()], [items()]
#'
Expand All @@ -40,7 +43,7 @@
#' }
#'
#' @export
collections <- function(q, collection_id = NULL) {
collections <- function(q, collection_id = NULL, limit = NULL) {
check_query(q, "stac")
params <- list()
subclass <- "collections"
Expand All @@ -49,6 +52,8 @@ collections <- function(q, collection_id = NULL) {
.error("Parameter `collection_id` must be a single value.")
params$collection_id <- collection_id
subclass <- "collection_id"
} else if (!is.null(limit)) {
params$limit <- limit
}
rstac_query(
version = q$version,
Expand Down
Loading

0 comments on commit 6d253ab

Please sign in to comment.