R/wdcs.R

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

wdcs_supported_version <- numeric_version("0.1.999")

.wdcs_check <- function(data) {

  if (is.null(data$wdcs_version))
    stop("Invalid `wdcs` data.", call. = TRUE)

  if (is.null(data$wdcs_provider))
    stop("Invalid `wdcs` data.", call. = TRUE)

  version <-
    tryCatch(numeric_version(data$wdcs_version),
             error = function(e) {

               stop("Invalid `wdcs` data.", call. = TRUE)
             })

  if (version > wdcs_supported_version)
    stop(sprintf("The wdcs version '%s' is not supported.",
                 data$wdcs_version), call. = TRUE)

  invisible(NULL)
}

#### S3 generics wdcs ####

#' @title wdcs functions
#'
#' @param pr     An \code{wdcs} or \code{eo_local} object.
#' @param ...    Any additional parameter (not used).
#'
#' @examples
#' pr <- wdcs("http://brazildatacube.dpi.inpe.br/api/wdcs/")
#' list_cubes(pr)
#'
#' @export
list_cubes <- function(pr, ...) {

  UseMethod("list_cubes", pr)
}

#' @title wdcs functions
#'
#' @param pr     An \code{wdcs} or \code{eo_local} object.
#' @param name   A \code{character} value with cube name.
#' @param ...    Any additional parameter (not used).
#'
#' @examples
#' pr <- wdcs("http://brazildatacube.dpi.inpe.br/api/wdcs/")
#' describe_cube(pr, name = "C6416d:STACK")
#'
#' @export
describe_cube <- function(pr, name, ...) {

  UseMethod("describe_cube", pr)
}

#' @title wdcs functions
#'
#' @param pr          An \code{wdcs} or \code{eo_local} object.
#' @param name        A \code{character} value with cube name.
#' @param bands       A \code{character} vector with band names.
#' @param interval    An \code{eo_interval} object to filter cube items dates.
#' @param bbox        An \code{eo_bbox} object to filter cube tiles.
#' @param slices      An \code{eo_interval} object which
#' defines how the cube time dimension must be sliced.
#' @param period      An period \code{character} to which the slices interval
#' will slide through timeline. The accepted format, expressed in regular
#' expression, is ^P([1-9\][0-9]*)(D|W|M|Y)$, where
#' D is 'day', W is 'week', M is 'month', and Y is 'year'.
#' Examples: 'P16D', P4W, 'P1M', P2Y.
#' @param ...         Any additional parameter.
#'
#' @examples
#' pr <- wdcs("http://brazildatacube.dpi.inpe.br/api/wdcs/")
#' cb <- get_cube(pr, name = "C6416d:STACK",
#'                bbox = eo_bbox(-46.6368,-13.2415,-45.0221,-12.2565),
#'                slices = eo_interval("2019-01-01", "2019-03-01"),
#'                period = "P2M")
#'
#' @export
get_cube <- function(pr, name, bands = NULL,
                     interval = NULL, bbox = NULL,
                     slices = NULL, period = "P1Y", ...) {

  UseMethod("get_cube", pr)
}

##### implementation wdcs #####

#' @title wdcs functions
#'
#' @param url    A \code{character} with the wdcs service url.
#' @param ...    Any additional parameter (not used yet).
#'
#' @examples
#' pr <- wdcs("http://brazildatacube.dpi.inpe.br/api/wdcs/")
#'
#' @export
wdcs <- function(url, ...) {

  if (!is.character(url))
    stop("Invalid `url` parameter.", call. = FALSE)

  res <- .open_json_url(url)

  .wdcs_check(data = res)

  class(res) <- "wdcs"

  return(res)
}

#' @describeIn list_cubes This function lists all cubes served in a
#' given wdcs.
#'
#' @return A \code{list} with available cubes.
#'
#' @export
list_cubes.wdcs <- function(pr, ...) {

  if (!inherits(pr, "wdcs"))
    stop("Invalid `wdcs` object.", call. = FALSE)

  url <- .make_url(base = pr$base, verb = "list_cubes")

  res <- .open_json_url(url)

  .wdcs_check(data = res)

  return(res$list_cubes)
}

#' @describeIn describe_cube This function describes a cube informing
#' its metadata.
#'
#' @return A \code{list} describing the cube.
#'
#' @export
describe_cube.wdcs <- function(pr, name, ...) {

  if (!inherits(pr, "wdcs"))
    stop("Invalid `wdcs` object.", call. = FALSE)

  if (!is.character(name))
    stop("Invalid `name` parameter.", call. = FALSE)

  url <- .make_url(base = pr$base, verb = "describe_cube", name = name)

  res <- .open_json_url(url)

  .wdcs_check(data = res)

  return(res$describe_cube)
}

#' @describeIn get_cube This function retrieves the references
#' (url) of the cube assets sliced according to informed parameters.
#'
#' @return An \code{eo_cube} object.
#'
#' @export
get_cube.wdcs <- function(pr, name, bands = NULL,
                             interval = NULL, bbox = NULL,
                             slices = NULL, period = "P1Y", ...) {

  if (!inherits(pr, "wdcs"))
    stop("Invalid `wdcs` object.", call. = FALSE)

  if (!is.character(name))
    stop("Invalid `name` parameter.", call. = FALSE)

  if (!is.null(bands) && !is.character(bands))
    stop("Invalid `bands` parameter.")

  if (!is.null(interval) && !inherits(interval, "eo_interval"))
    stop("Invalid `interval` parameter.")

  if (!is.null(bbox) && !inherits(bbox, "eo_bbox"))
    stop("Invalid `bbox` parameter.", call. = FALSE)

  if (!is.null(slices) && !inherits(slices, "eo_interval"))
    stop("Invalid `slices` parameter.", call. = FALSE)

  if (!is.character(period))
    stop("Invalid `period` value.", call. = TRUE)

  if (!grepl("^P([1-9][0-9]*)(D|W|M|Y)$", period))
    stop("Invalid `period` value.", call. = TRUE)

  url <- .make_url(base = pr$base, verb = "get_cube", name = name,
                   bands = bands, interval = interval, bbox = bbox,
                   slices = slices, period = period)

  res <- .open_json_url(url)

  .wdcs_check(data = res)

  return(res$get_cube)
}


#### implementation of static_wdcs ####

#' @describeIn get_cube This function retrieves the references
#' (url) of the cube assets sliced according to informed parameters.
#'
#' @return An \code{eo_cube} object.
#'
#' @export
get_cube.static_wdcs <- function(pr, name, bands = NULL,
                                    interval = NULL, bbox = NULL,
                                    slices = NULL, period = "P1Y", ...) {

  if (!inherits(pr, "wdcs"))
    stop("Invalid `wdcs` object.", call. = FALSE)

  if (!is.character(name))
    stop("Invalid `name` parameter.", call. = FALSE)

  if (!is.null(bands) && !is.character(bands))
    stop("Invalid `bands` parameter.")

  if (!is.null(interval) && !inherits(interval, "eo_interval"))
    stop("Invalid `interval` parameter.")

  if (!is.null(bbox) && !inherits(bbox, "eo_bbox"))
    stop("Invalid `bbox` parameter.", call. = FALSE)

  if (!is.null(slices) && !inherits(slices, "eo_interval"))
    stop("Invalid `slices` parameter.", call. = FALSE)

  if (!is.character(period))
    stop("Invalid `period` value.", call. = TRUE)

  if (!grepl("^P([1-9][0-9]*)(D|W|M|Y)$", period))
    stop("Invalid `period` value.", call. = TRUE)

  url <- .make_url(base = pr$base, verb = get_cube, name = name, bands = bands,
                   interval = interval, bbox = bbox, composite = "STACK")

  data <- .open_json_url(url)

  .geojson_stac_check(geojson = data)

  # slice features
  intervals <- .geojson_get_intervals(geojson = data, slices = slices)

  res <- lapply(intervals, function(x) {

    data <- .geojson_filter_features_interval(geojson = data, interval = x)
    data <- .geojson_filter_assets_bands(geojson = data, bands = .feature_bands(data$features[[1]]))
    tiles <- .geojson_get_tiles(geojson = data)

    tile_features <- tapply(data$features, tiles, c)
    res <- list(timeline = unique(.geojson_get_dates(geojson = data)),
                tiles = lapply(tile_features, .as_cube_tile))

    return(res)
  })

  names(res) <- sapply(intervals, as.character)

  class(res) <- "eo_cube"

  # .check_regular_cube(res)

  return(res)
}