#43 WMSClient, WMSCapabilities, WMSLayer, WMSGetFeatureInfo

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: ows4R
-Version: 0.1-6
-Date: 2020-08-31
+Version: 0.2
+Date: 2020-09-03
 Title: Interface to OGC Web-Services (OWS)
 Authors@R: c(person("Emmanuel", "Blondel", role = c("aut", "cre"), email = "[email protected]", comment = c(ORCID = "0000-0002-5870-5762")),
              person("Norbert", "Billet", role = c("ctb")))

NAMESPACE

@@ -44,6 +44,10 @@ export(WFSDescribeFeatureType)
 export(WFSFeatureType)
 export(WFSFeatureTypeElement)
 export(WFSGetFeature)
+export(WMSCapabilities)
+export(WMSClient)
+export(WMSGetFeatureInfo)
+export(WMSLayer)
 import(XML)
 import(geometa)
 import(httr)

R/OWSRequest.R

@@ -90,7 +90,7 @@ OWSRequest <- R6Class("OWSRequest",
           text <- gsub("<!--.*?-->", "", text)
           responseContent <- xmlParse(text)
         }else{
-          responseContent <- content(r, type = mimeType, encoding = "UTF-8")
+          responseContent <- content(r, type = "text", encoding = "UTF-8")
         }
       }
       response <- list(request = request, requestHeaders = headers(r),

R/WMSCapabilities.R

@@ -0,0 +1,103 @@
+#' WMSCapabilities
+#'
+#' @docType class
+#' @export
+#' @keywords OGC WMS GetCapabilities
+#' @return Object of \code{\link{R6Class}} with methods for interfacing an OGC
+#' Web Map Service Get Capabilities document.
+#' @format \code{\link{R6Class}} object.
+#' 
+#' @examples
+#' \donttest{
+#'    #example based on WMS endpoint responding at http://localhost:8080/geoserver/wms
+#'    caps <- WMSCapabilities$new("http://localhost:8080/geoserver/wms", version = "1.1.1")
+#' }
+#'
+#' @section Methods:
+#' \describe{
+#'  \item{\code{new(url, version)}}{
+#'    This method is used to instantiate a WMSGetCapabilities object
+#'  }
+#'  \item{\code{getLayers(pretty)}}{
+#'    List the layers available. If \code{pretty} is TRUE,
+#'    the output will be an object of class \code{data.frame}
+#'  }
+#'  \item{\code{findLayerByName(name, exact)}}{
+#'    Find layer(s) by name.
+#'  }
+#' }
+#' 
+#' @note Class used to read a \code{WMSCapabilities} document. The use of \code{WMSClient} is
+#' recommended instead to benefit from the full set of capabilities associated to a WMS server.
+#' 
+#' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
+#'
+WMSCapabilities <- R6Class("WMSCapabilities",
+ inherit = OWSCapabilities,
+ private = list(
+
+   layers = NA,
+
+   #fetchLayers
+   fetchLayers = function(xmlObj, version){
+     wmsNs <- NULL
+     if(all(class(xmlObj) == c("XMLInternalDocument","XMLAbstractDocument"))){
+       namespaces <- OWSUtils$getNamespaces(xmlObj)
+       if(!is.null(namespaces)) wmsNs <- OWSUtils$findNamespace(namespaces, id = "wms")
+     }
+     layersXML <- list()
+     if(is.null(wmsNs)){
+       layersXML <- getNodeSet(xmlObj, "//Layer/Layer")
+     }else{
+       layersXML <- getNodeSet(xmlObj, "//ns:Layer/ns:Layer", wmsNs)
+     }
+     layersList <- lapply(layersXML, function(x){
+       WMSLayer$new(x, self, version, logger = self$loggerType)
+     })
+     return(layersList)
+   }
+
+ ),
+
+ public = list(
+
+   #initialize
+   initialize = function(url, version, logger = NULL) {
+     super$initialize(url, service = "WMS", serviceVersion = version,
+                      owsVersion = "1.1", logger = logger)
+     xmlObj <- self$getRequest()$getResponse()
+     private$layers = private$fetchLayers(xmlObj, version)
+   },
+
+   #getLayers
+   getLayers = function(pretty = FALSE){
+     layers <- private$layers
+     if(pretty){
+       layers <- do.call("rbind", lapply(layers, function(x){
+         return(data.frame(
+           name = x$getName(),
+           title = x$getTitle(),
+           stringsAsFactors = FALSE
+         ))
+       }))
+     }
+     return(layers)
+   },
+
+   #findLayerByName
+   findLayerByName = function(expr, exact = TRUE){
+     result <- lapply(private$layers, function(x){
+       ft <- NULL
+       if(attr(regexpr(expr, x$getName()), "match.length") != -1 
+          && endsWith(x$getName(), expr)){
+         ft <- x
+       }
+       return(ft)
+     })
+     result <- result[!sapply(result, is.null)]
+     if(length(result) == 1) result <- result[[1]]
+     return(result)
+   }
+
+ )
+)

R/WMSClient.R

@@ -0,0 +1,105 @@
+#' WMSClient
+#'
+#' @docType class
+#' @export
+#' @keywords OGC WMS Map GetFeatureInfo
+#' @return Object of \code{\link{R6Class}} with methods for interfacing an OGC
+#' Web Map Service.
+#' @format \code{\link{R6Class}} object.
+#' 
+#' @examples
+#' \donttest{
+#'    #example based on a WMS endpoint responding at http://localhost:8080/geoserver/wms
+#'    wms <- WMSClient$new("http://localhost:8080/geoserver/wms", serviceVersion = "1.1.1")
+#'    
+#'    #get capabilities
+#'    caps <- wms$getCapabilities()
+#'    
+#'    #get feature info
+#'    
+#'    #Advanced examples at https://github.com/eblondel/ows4R/wiki#wms
+#' }
+#'
+#' @section Methods:
+#' \describe{
+#'  \item{\code{new(url, serviceVersion, user, pwd, logger)}}{
+#'    This method is used to instantiate a WMSClient with the \code{url} of the
+#'    OGC service. Authentication (\code{user}/\code{pwd}) is not yet supported.By default, the \code{logger}
+#'    argument will be set to \code{NULL} (no logger). This argument accepts two possible 
+#'    values: \code{INFO}: to print only \pkg{ows4R} logs, \code{DEBUG}: to print more verbose logs
+#'  }
+#'  \item{\code{getCapabilities()}}{
+#'    Get service capabilities. Inherited from OWS Client
+#'  }
+#'  \item{\code{reloadCapabilities()}}{
+#'    Reload service capabilities
+#'  }
+#' }
+#' 
+#' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
+#'
+WMSClient <- R6Class("WMSClient",
+   inherit = OWSClient,
+   private = list(
+     serviceName = "WMS"
+   ),
+   public = list(
+     #initialize
+     initialize = function(url, serviceVersion = NULL, user = NULL, pwd = NULL, logger = NULL) {
+       super$initialize(url, service = private$serviceName, serviceVersion, user, pwd, logger)
+       self$capabilities = WMSCapabilities$new(self$url, self$version, logger = logger)
+     },
+
+     #getCapabilities
+     getCapabilities = function(){
+       return(self$capabilities)
+     },
+
+     #reloadCapabilities
+     reloadCapabilities = function(){
+       self$capabilities = WMSCapabilities$new(self$url, self$version, logger = self$loggerType)
+     },
+
+     #getLayers
+     getLayers = function(pretty = FALSE){
+       return(self$capabilities$getLayers(pretty = pretty))
+     },
+
+     #getMap
+     getMap = function(){
+       stop("Not yet supported")
+     },
+
+     #getFeatureInfo
+     getFeatureInfo = function(layer, styles = NULL, feature_count = 1,
+                               x, y, width, height, bbox, 
+                               info_format = "application/vnd.ogc.gml",
+                               ...){
+       wmsLayer = self$capabilities$findLayerByName(layer)
+       features <- NULL
+       if(is(wmsLayer,"WMSLayer")){
+          features <- wmsLayer$getFeatureInfo(
+             styles = styles, feature_count = feature_count,
+             x = x, y = y, width = width, height = height, bbox = bbox,
+             info_format = info_format,
+             ...
+          )
+       }else if(is(wmsLayer, "list")){
+          features <- wmsLayer[[1]]$getFeatureInfo(
+             styles = styles, feature_count = feature_count,
+             x = x, y = y, width = width, height = height, bbox = bbox,
+             info_format = info_format,
+             ...
+          )
+       }
+       return(features)
+     },
+
+     #getLegendGraphic
+     getLegendGraphic = function(){
+       stop("Not yet supported")
+     }
+
+   )
+)
+

R/WMSGetFeatureInfo.R

@@ -0,0 +1,62 @@
+#' WMSGetFeatureInfo
+#'
+#' @docType class
+#' @export
+#' @keywords OGC WMS GetFeatureInfo
+#' @return Object of \code{\link{R6Class}} for modelling a WMS GetFeatureInfo request
+#' @format \code{\link{R6Class}} object.
+#'
+#' @section Methods:
+#' \describe{
+#'  \item{\code{new(op, url, version, typeName, logger, ...)}}{
+#'    This method is used to instantiate a WMSGetFeatureInfo object
+#'  }
+#' }
+#' 
+#' @note Abstract class used by \pkg{ows4R} to trigger a WMS GetFeatureInfo request
+#' 
+#' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
+#'
+WMSGetFeatureInfo <- R6Class("WMSGetFeatureInfo",
+ inherit = OWSRequest,
+ private = list(
+   name = "GetFeatureInfo"
+ ), 
+ public = list(
+   initialize = function(op, url, version, layers, srs, styles, feature_count = 1,
+                         x, y, width, height, bbox, info_format = "application/vnd.ogc.gml",
+                         logger = NULL, ...) {
+
+     mimeType <- switch(info_format,
+      "application/vnd.ogc.gml" = "text/xml",
+      "application/vnd.ogc.gml/3.1.1" = "text/xml",
+      "application/json" = "application/json",
+      "text/xml"                 
+     )
+
+     if(is(bbox, "matrix")){
+        bbox <- paste0(bbox, collapse=",")
+     }
+     namedParams <- list(
+       service = "WMS", 
+       version = version,
+       FORMAT = "image/png",
+       TRANSPARENT = "true",
+       QUERY_LAYERS = layers,
+       LAYERS = layers,
+       STYLES = styles,
+       FEATURE_COUNT = format(feature_count, scientific = FALSE),
+       X = x, Y = y,
+       WIDTH = width, HEIGHT = height,
+       BBOX = bbox,
+       INFO_FORMAT = info_format
+     )
+     vendorParams <- list(...)
+     if(length(vendorParams)>0) namedParams <- c(namedParams, vendorParams)
+     super$initialize(op, "GET", url, request = private$name, 
+                      namedParams = namedParams, mimeType = mimeType, 
+                      logger = logger)
+     self$execute()
+   }
+ )
+)