R/stac.R

In brazil-data-cube/eocubes.R: Web Data Cubes Service client for R

##### STAC functions #####

.stac_check_version <- function(stac, version) {

  if (is.null(stac$stac_version))
    stop("Invalid `stac` file.", call. = TRUE)

  if (!stac$stac_version == version)
    stop("`stac` version is not supported.", call. = TRUE)

  invisible(NULL)
}

.stac_get_links_child <- function(stac) {

  index <- which(sapply(stac$links, function(x) x$rel) == "child")

  if (length(index) == 0)
    stop("Invalid `stac` file", call. = TRUE)

  links <- stac$links[index]
  res <- lapply(links, function(x) x$href)

  child_names <- sapply(links, function(x) x$title)
  if (any(is.na(child_names)))
    stop("Invalid `stac` file.", call. = TRUE)

  names(res) <- child_names
  return(res)
}

.geojson_stac_check <- function(geojson) {

  if (is.null(geojson$type))
    stop("Invalid `stac` file.", call. = TRUE)

  if (is.null(geojson$features))
    stop("Invalid `stac` file.", call. = TRUE)

  invisible(NULL)
}

.feature_datetime <- function(f) {

  res <- f$properties$datetime
  return(res)
}

.feature_tile <- function(f) {

  res <- f$properties$`bdc:tile`
  return(res)
}

.feature_composite <- function(f) {

  res <- f$properties$`bdc:time_aggregation`
  return(res)
}

.feature_bbox <- function(f) {

  res <- unlist(f$bbox)
  return(res)
}

.feature_polygon <- function(f) {

  if (f$geometry$type != "Polygon")
    stop("Geometry type must be a polygon.", call. = FALSE)

  res <- sf::st_polygon(list(matrix(unlist(f$geometry$coordinates[[1]]),
                                    ncol = 2, byrow = TRUE)))

  return(res)
}

.feature_bands <- function(f) {

  if (is.null(f$assets))
    stop("Invalid `stac` file.", call. = TRUE)

  res <- names(f$assets)
  return(res)
}

.feature_assets <- function(f, bands = NULL) {

  if (is.null(f$assets))
    stop("Invalid `stac` file.", call. = TRUE)

  if (is.null(bands))
    return(f$assets)

  if (!all(bands %in% names(f$assets)))
    stop("Invalid `bands` values.", call. = FALSE)

  res <- f$assets[bands]
  return(res)
}

.geojson_filter_assets_bands <- function(geojson, bands) {

  geojson$features <- lapply(geojson$features, function(f) {

    f$assets <- .feature_assets(f, bands = bands)
    return(f)
  })

  return(geojson)
}

.geojson_filter_features_interval <- function(geojson, interval) {

  dates <- .geojson_get_dates(geojson = geojson)

  select <- .interval_intersects(x = interval,
                                 dates = dates)
  geojson$features <- geojson$features[select]

  dates <- .geojson_get_dates(geojson = geojson)
  ordered <- sort.int(dates, index.return = TRUE)$ix
  geojson$features <- geojson$features[ordered]

  return(geojson)
}

.geojson_get_dates <- function(geojson) {

  res <- as.Date(sapply(geojson$features, .feature_datetime))
  return(res)
}

.geojson_get_tiles <- function(geojson) {

  res <- sapply(geojson$features, .feature_tile)
  return(res)
}

.geojson_get_intervals <- function(geojson, slices) {

  dates <- .geojson_get_dates(geojson = geojson)

  tiles <- .geojson_get_tiles(geojson = geojson)

  tiles_timeline <- unname(tapply(dates, tiles, c))

  res <- unique(unlist(lapply(tiles_timeline,
                              .slices, s = slices), recursive = FALSE))

  if (length(res) == 0)
    stop("No interval selected.", call. = FALSE)

  return(res)
}

.as_cube_tile <- function(tile_features) {

  if (length(tile_features) < 1)
    return(vector("list", length = 0))

  assets_href <- do.call(what = mapply,
                         args = c(list(SIMPLIFY = F, FUN = c),
                                  lapply(tile_features, .feature_assets)))
  res <- lapply(assets_href, unlist, use.names = FALSE, recursive = FALSE)

  return(res)
}