#4 refactoring of requests + #3 CSW GetRecordById

DESCRIPTION

@@ -6,7 +6,7 @@ Authors@R: c(person("Emmanuel", "Blondel", role = c("aut", "cre"), email = "emma
              person("Norbert", "Billet", role = c("ctb")))
 Maintainer: Emmanuel Blondel <[email protected]>
 Depends: R (>= 2.15)
-Imports: R6, httr, XML (>= 3.96-1.1), sf, rgdal
+Imports: R6, httr, XML (>= 3.96-1.1), sf, rgdal, geometa
 Suggests: testthat
 Description: Provides an interface to OGC Web-Services (OWS). In a first step, the package supports the Common
  OGC Web-Services specifications the Web Feature Service (WFS). ows4R will progressively support other OGC web

NAMESPACE

@@ -2,6 +2,7 @@
 
 export(CSWCapabilities)
 export(CSWClient)
+export(CSWGetRecordById)
 export(OWSCapabilities)
 export(OWSClient)
 export(OWSOperation)
@@ -16,6 +17,7 @@ export(WFSFeatureType)
 export(WFSFeatureTypeElement)
 export(WFSGetFeature)
 import(XML)
+import(geometa)
 import(httr)
 import(rgdal)
 import(sf)

R/CSWClient.R

@@ -24,6 +24,9 @@
 #'  \item{\code{getCapabilities()}}{
 #'    Get service capabilities. Inherited from OWS Client
 #'  }
+#'  \item{\code{getRecordById(id, ...)}}{
+#'    Get a record by Id.
+#'  }
 #' }
 #' 
 #' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
@@ -46,8 +49,17 @@ CSWClient <- R6Class("CSWClient",
      },
 
      #getRecordById
-     getRecordById = function(id, outputSchema){
-       stop("Not yet implemented")
+     getRecordById = function(id, ...){
+       message(sprintf("Fetching record '%s' ...", id))
+       operations <- self$capabilities$getOperationsMetadata()$getOperations()
+       op <- operations[sapply(operations,function(x){x$getName()=="GetRecordById"})]
+       if(length(op)>0){
+         op <- op[[1]]
+       }else{
+         stop("Operation 'GetRecordById' not supported by this service")
+       }
+       request <- CSWGetRecordById$new(op, self$getUrl(), self$getVersion(), id = id, ...)
+       return(request$response)
      },
 
      #getRecords

R/CSWGetRecordById.R

@@ -0,0 +1,86 @@
+#' CSWGetRecordById
+#'
+#' @docType class
+#' @export
+#' @keywords OGC CSW GetRecordById
+#' @return Object of \code{\link{R6Class}} for modelling a CSW GetRecordById request
+#' @format \code{\link{R6Class}} object.
+#'
+#' @section Methods:
+#' \describe{
+#'  \item{\code{new(url, version, id)}}{
+#'    This method is used to instantiate a CSWGetRecordById object
+#'  }
+#'  \item{\code{getRequest()}}{
+#'    Get GetRecordById request
+#'  }
+#' }
+#' 
+#' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
+#'
+CSWGetRecordById <- R6Class("CSWGetRecordById",
+    inherit = OWSRequest,
+    private = list(
+      name = "GetRecordById",
+      defaultOutputSchema = "http://www.opengis.net/cat/csw/2.0.2"
+    ),
+    public = list(
+      initialize = function(op, url, version, id, ...) {
+        namedParams <- list(request = private$name, version = version, id = id)
+        outputSchema <- list(...)$outputSchema
+        if(is.null(outputSchema)){
+          outputSchema <- private$defaultOutputSchema
+          namedParams <- c(namedParams, outputSchema = outputSchema)
+        }
+        super$initialize(op, url, namedParams, mimeType = "text/xml", ...)
+
+        #check response in case of ISO
+        isoSchemas <- c("http://www.isotc211.org/2005/gmd","http://www.isotc211.org/2005/gfc")
+        if(outputSchema %in% isoSchemas){
+          xmltxt <- as(self$response, "character")
+          isMetadata <- regexpr("MD_Metadata", xmltxt)>0
+          isFeatureCatalogue <- regexpr("FC_FeatureCatalogue", xmltxt)>0
+          if(isMetadata && outputSchema == isoSchemas[2]){
+            outputSchema <- isoSchemas[1]
+            message(sprintf("Metadata detected! Switch to schema '%s'!", outputSchema))
+          }
+          if(isFeatureCatalogue && outputSchema == isoSchemas[1]){
+            outputSchema <- isoSchemas[2]
+            message(sprintf("FeatureCatalogue detected! Switch to schema '%s'!", outputSchema))
+          }
+        }
+
+        #bindings
+        self$response <- switch(outputSchema,
+          "http://www.isotc211.org/2005/gmd" = {
+            out <- NULL
+            xmlObjs <- getNodeSet(self$response, "//ns:MD_Metadata", c(ns = outputSchema))
+            if(length(xmlObjs)>0){
+              xmlObj <- xmlObjs[[1]]
+              out <- geometa::ISOMetadata$new()
+              out$decode(xml = xmlObj)
+            }
+            out
+          },
+          "http://www.isotc211.org/2005/gfc" = {
+            out <- NULL
+            xmlObjs <- getNodeSet(self$response, "//ns:FC_FeatureCatalogue", c(ns = outputSchema))
+            if(length(xmlObjs)>0){
+              xmlObj <- xmlObjs[[1]]
+              out <- geometa::ISOFeatureCatalogue$new()
+              out$decode(xml = xml)
+            }
+            out
+          },
+          "http://www.opengis.net/cat/csw/2.0.2" = {
+            warnings(sprintf("R binding not yet supported for '%s'", outputSchema))
+            self$response
+          },
+          "http://www.w3.org/ns/dcat#" = {
+            warnings(sprintf("R binding not yet supported for '%s'", outputSchema))
+            self$response
+          }
+        )
+      }
+    )
+)

R/OWSCapabilities.R

@@ -49,7 +49,7 @@ OWSCapabilities <- R6Class("OWSCapabilities",
      #buildRequest
      buildRequest = function(url, service, version){
        namedParams <- list(request = "GetCapabilities", service, version = version)
-       request <- OWSRequest$new(url, namedParams, "text/xml")
+       request <- OWSRequest$new(op = NULL, url, namedParams, "text/xml")
        return(request)
      }
    ),

R/OWSClient.R

@@ -6,6 +6,7 @@
 #' @import XML
 #' @import sf
 #' @import rgdal
+#' @import geometa
 #' @export
 #' @keywords OGC Common OWS
 #' @return Object of \code{\link{R6Class}} with methods for interfacing

R/OWSOperation.R

@@ -11,6 +11,15 @@
 #'  \item{\code{new(xmlObj, service, version)}}{
 #'    This method is used to instantiate an OWSOperation object
 #'  }
+#'  \item{\code{getName()}}{
+#'    Get name
+#'  }
+#'  \item{\code{getParameters()}}{
+#'    Get the list of parameters
+#'  }
+#'  \item{\code{getParameter(name)}}{
+#'    Get a given parameter
+#'  }
 #' }
 #' 
 #' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
@@ -41,6 +50,11 @@ OWSOperation <-  R6Class("OWSOperation",
     #getParameters
     getParameters = function(){
       return(private$parameters)
+    },
+
+    #getParameter
+    getParameter = function(name){
+      return(private$parameters[[name]])
     }
   )
 )

R/OWSRequest.R

@@ -30,12 +30,12 @@ OWSRequest <- R6Class("OWSRequest",
       r <- GET(request)
       responseContent <- NULL
       if(is.null(mimeType)){
-        responseContent <- content(r)
+        responseContent <- content(r, encoding = "UTF-8")
       }else{
         if(regexpr("xml",mimeType)>0){
-          responseContent <- xmlParse(content(r, type = "text"))
+          responseContent <- xmlParse(content(r, type = "text", encoding = "UTF-8"))
         }else{
-          responseContent <- content(r, type = mimeType)
+          responseContent <- content(r, type = mimeType, encoding = "UTF-8")
         }
       }
       response <- list(request = request, status = status_code(r), response = responseContent)
@@ -48,12 +48,28 @@ OWSRequest <- R6Class("OWSRequest",
     status = NA,
     response = NA,
     #initialize
-    initialize = function(url, namedParams, mimeType = "text/xml") {
+    initialize = function(op, url, namedParams, mimeType = "text/xml", ...) {
+      vendorParams <- list(...)
+      if(!is.null(op)){
+        for(param in names(vendorParams)){
+          if(!(param %in% names(op$getParameters()))){
+            stop(sprintf("Parameter '%s' is not among allowed parameters [%s]",
+                         param, paste(paste0("'",names(op$getParameters()),"'"), collapse=",")))
+          }
+          value <- vendorParams[[param]]
+          paramAllowedValues <- op$getParameter(param)
+          if(!(value %in% paramAllowedValues)){
+            stop(sprintf("'%s' parameter value '%s' is not among allowed values [%s]",
+                         param, value, paste(paste0("'",paramAllowedValues,"'"), collapse=",")))
+          }
+        }
+      }
+      namedParams <- c(namedParams, vendorParams)
       req <- private$buildRequest(url, namedParams, mimeType)
       self$request <- req$request
       self$status <- req$status
       self$response <- req$response
     }
-  ),
+  )
 
 )

R/WFSCapabilities.R

@@ -45,7 +45,7 @@ WFSCapabilities <- R6Class("WFSCapabilities",
        featureTypesXML <- getNodeSet(xmlObj, "//ns:FeatureType", wfsNs)
        featureTypesList <- lapply(featureTypesXML,
                                   function(x){
-                                    WFSFeatureType$new(x, url, version)
+                                    WFSFeatureType$new(x, self, url, version)
                                   })
 
        return(featureTypesList)

R/WFSClient.R

@@ -28,7 +28,7 @@
 #'    Get the description of a given featureType
 #'  }
 #'  \item{\code{getFeatures(typeName)}}{
-#'    Retrieves the features for a given feature type
+#'    Retrieves the features for a given feature type.
 #'  }
 #' }
 #' 

R/WFSDescribeFeatureType.R

@@ -8,56 +8,22 @@
 #'
 #' @section Methods:
 #' \describe{
-#'  \item{\code{new(url, version, typeName)}}{
+#'  \item{\code{new(op, url, version, typeName)}}{
 #'    This method is used to instantiate a WFSDescribeFeatureType object
 #'  }
-#'  \item{\code{getRequest()}}{
-#'    Get DescribeFeatureType request
-#'  }
-#'  \item{\code{getContent()}}{
-#'    Get content
-#'  }
 #' }
 #' 
 #' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
 #'
 WFSDescribeFeatureType <- R6Class("WFSDescribeFeatureType",
+  inherit = OWSRequest,
   private = list(
-    request = NA,
-    content = NA,
-
-    #buildRequest
-    buildRequest = function(url, version, typeName){ 
-      namedParams <- list(request = "DescribeFeatureType", version = version, typeName = typeName)
-      request <- OWSRequest$new(url, namedParams, "text/xml")
-      return(request)
-    },
-
-    #fetchFeatureTypeDescription
-    fetchFeatureTypeDescription = function(xmlObj){
-      namespaces <- OWSUtils$getNamespaces(xmlObj)
-      xsdNs <- OWSUtils$findNamespace(namespaces, "XMLSchema")
-      elementXML <- getNodeSet(xmlObj, "//ns:sequence/ns:element", xsdNs)
-      elements <- lapply(elementXML, WFSFeatureTypeElement$new)
-      return(elements)
-    }
+    name = "DescribeFeatureType"
   ),
   public = list(
-    initialize = function(url, version, typeName) {
-      private$request <- private$buildRequest(url, version, typeName)
-      xmlObj <- private$request$response
-      private$content = private$fetchFeatureTypeDescription(xmlObj)
-    },
-
-    #getRequest
-    getRequest = function(){
-      return(private$request)
-    },
-
-    #getContent
-    getContent = function(){
-      return(private$content)
+    initialize = function(op, url, version, typeName, ...) {
+      namedParams <- list(request = private$name, version = version, typeName = typeName)
+      super$initialize(op, url, namedParams, mimeType = "text/xml", ...)
     }
   )
-
 )