Skip to content

Commit

Permalink
#29 start testing WCS GetCoverage as POST
Browse files Browse the repository at this point in the history
  • Loading branch information
@eblondel
eblondel committed Mar 16, 2022
1 parent 37f89eb commit 195cea1
Show file tree
Hide file tree
Showing 5 changed files with 148 additions and 111 deletions.
2 changes: 1 addition & 1 deletion R/OWSHttpRequest.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -227,7 +227,7 @@ OWSHttpRequest <- R6Class("OWSHttpRequest",
}
}
if(private$type == "POST"){
if(!is.null(xmlNamespaces(req$response)$ows)){
if(endsWith(private$mimeType, "xml")) if(!is.null(xmlNamespaces(req$response)$ows)){
exception <- getNodeSet(req$response, "//ows:ExceptionText", c(ows = xmlNamespaces(req$response)$ows$uri))
if(length(exception)>0){
exception <- exception[[1]]
Expand Down
4 changes: 4 additions & 0 deletions R/OWSNamespace.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -43,6 +43,8 @@ OWSNamespace$FES = OWSNamespace$new("fes", "http://www.opengis.net/fes/2.0")
OWSNamespace$OGC <- OWSNamespace$new("ogc", "http://www.opengis.net/ogc")
OWSNamespace$OWS <- OWSNamespace$new("ows", "http://www.opengis.net/ows")
OWSNamespace$OWS_1_1 = OWSNamespace$new("ows", "http://www.opengis.net/ows/1.1")
OWSNamespace$WCS_2_0 = OWSNamespace$new("wcs", "http://www.opengis.net/wcs/2.0")
OWSNamespace$WCS_2_1 = OWSNamespace$new("wcs", "http://www.opengis.net/wcs/2.1")
OWSNamespace$WMS_1_0_0 = OWSNamespace$new("wms", "http://www.opengis.net/wms")
OWSNamespace$WMS_1_1_0 = OWSNamespace$new("wms", "http://www.opengis.net/wms")
OWSNamespace$WMS_1_1_1 = OWSNamespace$new("wms", "http://www.opengis.net/wms")
Expand All @@ -61,6 +63,8 @@ setOWSNamespaces <- function(){
OWSNamespace$OGC,
OWSNamespace$OWS,
OWSNamespace$OWS_1_1,
OWSNamespace$WCS_2_0,
OWSNamespace$WCS_2_1,
OWSNamespace$WMS_1_0_0,
OWSNamespace$WMS_1_1_0,
OWSNamespace$WMS_1_1_1,
Expand Down
2 changes: 1 addition & 1 deletion R/WCSCoverageFilenameHandler.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,7 +19,7 @@ WCSCoverageFilenameHandler <- function(identifier, time, elevation, bbox, format
filename <- identifier
if(!is.null(time)) filename <- paste0(filename, "_", gsub(":", "_", time))
if(!is.null(elevation)) filename <- paste0(filename, "_", elevation)
if(!is.null(bbox)) filename <- paste0(filename, "_", paste0(bbox, collapse=","))
if(!is.null(bbox)) filename <- paste0(filename, "_", gsub(":", "_",paste0(bbox, collapse=",")))
file_ext <- "tif"
if(!is.null(format)){
file_ext <- switch(format,
Expand Down
6 changes: 4 additions & 2 deletions R/WCSCoverageSummary.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -342,6 +342,7 @@ WCSCoverageSummary <- R6Class("WCSCoverageSummary",
#'@param gridCS grid CS. Default is \code{NULL}
#'@param gridorigin grid origin. Default is \code{NULL}
#'@param gridoffsets grid offsets. Default is \code{NULL}
#'@param method method to get coverage, either 'GET' or 'POST' (experimental - under development)
#'@param filename filename. Optional filename to download the coverage
#'@param ... any other argument to \link{WCSGetCoverage}
#'@return an object of class \code{SpatRaster} from \pkg{terra}
Expand All @@ -350,7 +351,7 @@ WCSCoverageSummary <- R6Class("WCSCoverageSummary",
format = NULL, rangesubset = NULL,
gridbaseCRS = NULL, gridtype = NULL, gridCS = NULL,
gridorigin = NULL, gridoffsets = NULL,
filename = NULL, ...){
method = "GET", filename = NULL, ...){
coverage_data <- NULL
op <- NULL
operations <- private$capabilities$getOperationsMetadata()$getOperations()
Expand Down Expand Up @@ -564,6 +565,7 @@ WCSCoverageSummary <- R6Class("WCSCoverageSummary",
getCoverageRequest <- WCSGetCoverage$new(capabilities = private$capabilities, op = op,
url = private$url,
serviceVersion = private$version,
method = method,
coverage = self, logger = self$loggerType,
envelope = envelope, crs = crs,
time = time, elevation = elevation,
Expand Down Expand Up @@ -631,7 +633,7 @@ WCSCoverageSummary <- R6Class("WCSCoverageSummary",
#'@param bbox bbox
#'@param filename_handler Optional filename handling function with arguments 'identifier', 'time', 'elevation', 'bbox', 'format'
#' See \link{WCSCoverageFilenameHandler} as genric filename handler that can be used.
#'@param ... any other parameter to pass to \code{getCoverage} method
#'@param ... any other parameter to pass to \code{getCoverage}
#'@return an object of class \link{stack} from \pkg{raster}
getCoverageStack = function(time = NULL, elevation = NULL, bbox = NULL,
filename_handler = NULL, ...){
Expand Down
245 changes: 138 additions & 107 deletions R/WCSGetCoverage.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,13 +9,19 @@
#' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
#'
WCSGetCoverage <- R6Class("WCSGetCoverage",
lock_objects = FALSE,
inherit = OWSHttpRequest,
private = list(
xmlElement = "GetCoverage",
xmlNamespacePrefix = "WCS"
),
public = list(

#'@field CoverageId coverage identifier
CoverageId = NULL,
#'@field format coverage format
format = NULL,

#'@description Initializes a \link{WCSGetCoverage} service request
#'@param capabilities an object of class \link{WCSCapabilities}
#'@param op object of class \link{OWSOperation} as retrieved from capabilities
Expand All @@ -38,6 +44,7 @@ WCSGetCoverage <- R6Class("WCSGetCoverage",
#'@param token token
#'@param headers headers
#'@param config config
#'@param method method
#'@param logger logger
#'@param ... any parameter to pass to the service request
initialize = function(capabilities, op, url, serviceVersion,
Expand All @@ -46,128 +53,152 @@ WCSGetCoverage <- R6Class("WCSGetCoverage",
gridbaseCRS = NULL, gridtype = NULL, gridCS = NULL,
gridorigin = NULL, gridoffsets = NULL,
user = NULL, pwd = NULL, token = NULL, headers = c(), config = httr::config(),
method = "GET",
logger = NULL, ...) {
namedParams <- list(service = "WCS", version = serviceVersion)

#coverageId
coverageId <- coverage$getId()
if(startsWith(serviceVersion, "1.0")) namedParams <- c(namedParams, coverage = coverageId)
if(startsWith(serviceVersion, "1.1")) namedParams <- c(namedParams, identifier = coverageId)
if(startsWith(serviceVersion, "2")) namedParams <- c(namedParams, coverageId = coverageId)

if(startsWith(serviceVersion,"1.0")){
if(!is.null(envelope)) namedParams$BBOX <- paste0(as(envelope, "character"), collapse=",")
if(!is.null(crs)) namedParams$CRS <- crs
if(!is.null(time)) namedParams$time <- paste0(time, collapse=",")
}
if(startsWith(serviceVersion,"1.1")){
#envelope object as matrix
#if(!is.null(crs)) if(endsWith(crs, "EPSG::4326")) {
# envelope <- rbind(envelope[2,],envelope[1,])
#}
#if(!is.null(envelope)) namedParams$boundingbox <- paste0(as(envelope, "character"), collapse=",")
if(!is.null(envelope)){
namedParams$boundingbox <- paste(c(envelope$lowerCorner, envelope$upperCorner), collapse=",")
if(!is.null(crs)) if(endsWith(crs, "EPSG::4326")) {
namedParams$boundingbox <- paste(c(rev(envelope$lowerCorner), rev(envelope$upperCorner)), collapse=",")
#For WCS 1.x we still do a GET request
if(startsWith(serviceVersion, "1")) method <- "GET"

if(method == "GET"){
#GET WCS GetCoverage
namedParams <- list(service = "WCS", version = serviceVersion)

#coverageId
if(startsWith(serviceVersion, "1.0")) namedParams <- c(namedParams, coverage = coverageId)
if(startsWith(serviceVersion, "1.1")) namedParams <- c(namedParams, identifier = coverageId)
if(startsWith(serviceVersion, "2")) namedParams <- c(namedParams, coverageId = coverageId)

if(startsWith(serviceVersion,"1.0")){
if(!is.null(envelope)) namedParams$BBOX <- paste0(as(envelope, "character"), collapse=",")
if(!is.null(crs)) namedParams$CRS <- crs
if(!is.null(time)) namedParams$time <- paste0(time, collapse=",")
}
if(startsWith(serviceVersion,"1.1")){
#envelope object as matrix
#if(!is.null(crs)) if(endsWith(crs, "EPSG::4326")) {
# envelope <- rbind(envelope[2,],envelope[1,])
#}
#if(!is.null(envelope)) namedParams$boundingbox <- paste0(as(envelope, "character"), collapse=",")
if(!is.null(envelope)){
namedParams$boundingbox <- paste(c(envelope$lowerCorner, envelope$upperCorner), collapse=",")
if(!is.null(crs)) if(endsWith(crs, "EPSG::4326")) {
namedParams$boundingbox <- paste(c(rev(envelope$lowerCorner), rev(envelope$upperCorner)), collapse=",")
}
}
if(!is.null(crs)) namedParams$boundingbox <- paste(namedParams$boundingbox, crs, sep=",")
if(!is.null(time)) namedParams$Timesequence <- paste0(time, collapse=",")
}
if(!is.null(crs)) namedParams$boundingbox <- paste(namedParams$boundingbox, crs, sep=",")
if(!is.null(time)) namedParams$Timesequence <- paste0(time, collapse=",")
}
if(startsWith(serviceVersion, "2")){
if(!is.null(envelope)){
print(envelope)
dims <- coverage$getDimensions()
subsetParams <- unlist(strsplit(envelope$attrs$axisLabels, " "))
subsets <- lapply(subsetParams, function(subset){
i <- which(subsetParams == subset)
dimension <- dims[sapply(dims, function(x){x$label == subset})][[1]]
subsetKvp <- NULL
if(!is.null(dimension)){
if(dimension$type == "geographic"){
subsetKvp <- sprintf("%s(%s,%s)",subset,
format(unlist(envelope$lowerCorner[,i]), scientific = FALSE),
format(unlist(envelope$upperCorner[,i]), scientific = FALSE))
}else{
value <- switch(dimension$type,
"temporal" = time,
"elevation" = elevation,
envelope$lowerCorner[,i]
)
if(!is.null(value)){
if(is(value, "numeric")){
if(length(value)==1){
subsetKvp <- sprintf("%s(%s)",subset, format(value, scientific = FALSE))
}else if(length(value)==2){
subsetKvp <- sprintf("%s(%s,%s)",subset, format(value, scientific = FALSE), format(value, scientific = FALSE))
}

}else{
if(length(value)==1){
subsetKvp <- sprintf("%s(\"%s\")",subset, value)
}else if(length(value)==2){
subsetKvp <- sprintf("%s(\"%s\",\"%s\")",subset, value, value)
if(startsWith(serviceVersion, "2")){
if(!is.null(envelope)){
print(envelope)
dims <- coverage$getDimensions()
subsetParams <- unlist(strsplit(envelope$attrs$axisLabels, " "))
subsets <- lapply(subsetParams, function(subset){
i <- which(subsetParams == subset)
dimension <- dims[sapply(dims, function(x){x$label == subset})][[1]]
subsetKvp <- NULL
if(!is.null(dimension)){
if(dimension$type == "geographic"){
subsetKvp <- sprintf("%s(%s,%s)",subset,
format(unlist(envelope$lowerCorner[,i]), scientific = FALSE),
format(unlist(envelope$upperCorner[,i]), scientific = FALSE))
}else{
value <- switch(dimension$type,
"temporal" = time,
"elevation" = elevation,
envelope$lowerCorner[,i]
)
if(!is.null(value)){
if(is(value, "numeric")){
if(length(value)==1){
subsetKvp <- sprintf("%s(%s)",subset, format(value, scientific = FALSE))
}else if(length(value)==2){
subsetKvp <- sprintf("%s(%s,%s)",subset, format(value, scientific = FALSE), format(value, scientific = FALSE))
}

}else{
if(length(value)==1){
subsetKvp <- sprintf("%s(\"%s\")",subset, value)
}else if(length(value)==2){
subsetKvp <- sprintf("%s(\"%s\",\"%s\")",subset, value, value)
}
}
}
}
}
}else{
subsetKvp <- sprintf("%s(%s,%s)",subset, unlist(envelope$lowerCorner[,i]), unlist(envelope$upperCorner[,i]))
if(tolower(subset) %in% c("time","elevation")){
value <- NULL
if(tolower(subset)=="time") value <- time
if(tolower(subset)=="elevation") value <- elevation
if(is.null(value)) value <- envelope$lowerCorner[,i]
if(!is.null(value)){
if(is(value, "numeric")){
if(length(value)==1){
subsetKvp <- sprintf("%s(%s)",subset, value)
}else if(length(value)==2){
subsetKvp <- sprintf("%s(%s,%s)",subset, value, value)
}

}else{
if(length(value)==1){
subsetKvp <- sprintf("%s(\"%s\")",subset, value)
}else if(length(value)==2){
subsetKvp <- sprintf("%s(\"%s\",\"%s\")",subset, value, value)
}else{
subsetKvp <- sprintf("%s(%s,%s)",subset, unlist(envelope$lowerCorner[,i]), unlist(envelope$upperCorner[,i]))
if(tolower(subset) %in% c("time","elevation")){
value <- NULL
if(tolower(subset)=="time") value <- time
if(tolower(subset)=="elevation") value <- elevation
if(is.null(value)) value <- envelope$lowerCorner[,i]
if(!is.null(value)){
if(is(value, "numeric")){
if(length(value)==1){
subsetKvp <- sprintf("%s(%s)",subset, value)
}else if(length(value)==2){
subsetKvp <- sprintf("%s(%s,%s)",subset, value, value)
}
}else{
if(length(value)==1){
subsetKvp <- sprintf("%s(\"%s\")",subset, value)
}else if(length(value)==2){
subsetKvp <- sprintf("%s(\"%s\",\"%s\")",subset, value, value)
}
}
}
}
}
}

if(!is.null(subsetKvp)) subsetKvp = URLencode(subsetKvp)
return(subsetKvp)
})
subsets <- subsets[!sapply(subsets, is.null)]
names(subsets) <- rep("subset", length(subsets))
namedParams <- c(namedParams, subsets)
if(!is.null(subsetKvp)) subsetKvp = URLencode(subsetKvp)
return(subsetKvp)
})
subsets <- subsets[!sapply(subsets, is.null)]
names(subsets) <- rep("subset", length(subsets))
namedParams <- c(namedParams, subsets)
}
}

if(!is.null(format)) namedParams$format <- format
if(!is.null(rangesubset)) namedParams$Rangesubset <- rangesubset
if(!is.null(gridbaseCRS)) namedParams$gridbaseCRS <- gridbaseCRS
if(!is.null(gridtype)) namedParams$gridtype <- gridtype
if(!is.null(gridCS)) namedParams$gridCS <- gridCS
if(!is.null(gridorigin)) namedParams$gridorigin <- gridorigin
if(!is.null(gridoffsets)) namedParams$gridoffsets <- gridoffsets

vendorParams <- list(...)
if(length(vendorParams)>0){
namedParams <- c(namedParams, vendorParams)
}

mimeType <- format
if(substr(serviceVersion,1,3)=="1.1") mimeType <- "text/xml"

super$initialize(element = private$xmlElement, namespacePrefix = private$xmlNamespacePrefix,
capabilities, op, "GET", url, request = private$xmlElement,
user = user, pwd = pwd, token = token, headers = headers, config = config,
namedParams = namedParams, mimeType = mimeType,
logger = logger, ...)

}else if(method == "POST"){
#for WCS 2.x we support POST request
nsVersion <- substr(serviceVersion,1,3)
private$xmlNamespacePrefix = paste(private$xmlNamespacePrefix, gsub("\\.", "_", nsVersion), sep="_")
super$initialize(element = private$xmlElement, namespacePrefix = private$xmlNamespacePrefix,
capabilities, op, "POST", url, request = private$xmlElement,
user = user, pwd = pwd, token = token, headers = headers, config = config,
contentType = "text/xml", mimeType = format,
logger = logger, ...)
self$wrap <- TRUE
self$attrs <- list(service = "WCS", version = serviceVersion)
self$CoverageId <- coverageId
self$format <- format
}

if(!is.null(format)) namedParams$format <- format
if(!is.null(rangesubset)) namedParams$Rangesubset <- rangesubset
if(!is.null(gridbaseCRS)) namedParams$gridbaseCRS <- gridbaseCRS
if(!is.null(gridtype)) namedParams$gridtype <- gridtype
if(!is.null(gridCS)) namedParams$gridCS <- gridCS
if(!is.null(gridorigin)) namedParams$gridorigin <- gridorigin
if(!is.null(gridoffsets)) namedParams$gridoffsets <- gridoffsets

vendorParams <- list(...)
if(length(vendorParams)>0){
namedParams <- c(namedParams, vendorParams)
}

mimeType <- format
if(substr(serviceVersion,1,3)=="1.1") mimeType <- "text/xml"

super$initialize(element = private$xmlElement, namespacePrefix = private$xmlNamespacePrefix,
capabilities, op, "GET", url, request = "GetCoverage",
user = user, pwd = pwd, token = token, headers = headers, config = config,
namedParams = namedParams, mimeType = mimeType,
logger = logger, ...)

self$execute()
}
)
Expand Down

0 comments on commit 195cea1

Please sign in to comment.