#4 OWS 1.1.0 ServiceProvider

.travis.yml

@@ -16,6 +16,10 @@ before_install:
   - sudo apt-get install --yes libudunits2-dev libproj-dev libgeos-dev libgdal-dev
   - Rscript -e 'update.packages(ask = FALSE)'
   # docker images for integration tests
+  # --> pycsw
+  - docker pull geopython/pycsw:2.2.0
+  - docker run --name pycsw --publish 8000:8000 --detach geopython/pycsw
+  # --> GeoNetwork
   - docker pull kartoza/postgis
   - docker run -d --name="postgis" kartoza/postgis
   - docker pull oscarfonts/geoserver

NAMESPACE

@@ -11,6 +11,7 @@ export(OWSOperation)
 export(OWSOperationsMetadata)
 export(OWSRequest)
 export(OWSServiceIdentification)
+export(OWSServiceProvider)
 export(OWSUtils)
 export(WFSCapabilities)
 export(WFSClient)

R/OWSCapabilities.R

@@ -29,6 +29,9 @@
 #'  \item{\code{getServiceIdentification()}}{
 #'    Get the service identification
 #'  }
+#'  \item{\code{getServiceProvider()}}{
+#'    Get the service provider
+#'  }
 #'  \item{\code{getOperationsMetadata()}}{
 #'    Get the service operations metadata
 #'  }
@@ -43,6 +46,7 @@ OWSCapabilities <- R6Class("OWSCapabilities",
      version = NA,
      request = NA,
      serviceIdentification = NULL,
+     serviceProvider = NULL,
      operationsMetadata = NULL
    ),
 
@@ -55,6 +59,7 @@ OWSCapabilities <- R6Class("OWSCapabilities",
        private$request <- OWSRequest$new(op = NULL, url, namedParams, "text/xml", logger = logger)
        xmlObj <- private$request$response
        private$serviceIdentification <- OWSServiceIdentification$new(xmlObj, service, version)
+       private$serviceProvider <- OWSServiceProvider$new(xmlObj, service, version)
        private$operationsMetadata <- OWSOperationsMetadata$new(xmlObj, service, version)
      },
 
@@ -78,6 +83,11 @@ OWSCapabilities <- R6Class("OWSCapabilities",
        return(private$serviceIdentification)
      },
 
+     #getServiceProvider
+     getServiceProvider = function(){
+       return(private$serviceProvider)
+     },
+
      #getOperationsMetadata
      getOperationsMetadata = function(){
        return(private$operationsMetadata)

R/OWSServiceIdentification.R

@@ -109,7 +109,10 @@ OWSServiceIdentification <-  R6Class("OWSServiceIdentification",
              serviceKeywords <- strsplit(gsub(" ", "", xmlValue(children$Keywords)), ",")[[1]]
            }else{
              serviceKeywordListXML <- xmlChildren(children$Keywords)
-             serviceKeywords <- as.vector(sapply(serviceKeywordListXML, xmlValue))
+             serviceKeywords <- sapply(serviceKeywordListXML, function(x){
+               if(xmlName(x)=="Keyword") return(xmlValue(x))})
+             serviceKeywords <- serviceKeywords[!sapply(serviceKeywords, is.null)]
+             serviceKeywords <- as.vector(unlist(serviceKeywords))
            }
 
          }

R/OWSServiceProvider.R

@@ -0,0 +1,154 @@
+#' OWSServiceProvider
+#'
+#' @docType class
+#' @export
+#' @keywords OGC OWS Service Provider
+#' @return Object of \code{\link{R6Class}} for modelling an OGC Service Provider
+#' @format \code{\link{R6Class}} object.
+#'
+#' @section Methods:
+#' \describe{
+#'  \item{\code{new(xmlObj, url, service)}}{
+#'    This method is used to instantiate a OWSServiceProvider object
+#'  }
+#'  \item{\code{getProviderName()}}{
+#'    Get the provider name
+#'  }
+#'  \item{\code{getProviderSite()}}{
+#'    Get the provide site
+#'  }
+#'  \item{\code{getServiceContact()}}{
+#'    Get the service contact, as object of class \code{ISOResponsibleParty}
+#'    from package \pkg{geometa}
+#'  }
+#' }
+#' 
+#' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
+#'
+OWSServiceProvider <-  R6Class("OWSServiceProvider",
+   private = list(
+     providerName = NA,
+     providerSite = NA,
+     serviceContact = NA,
+
+     #fetchServiceProvider
+     fetchServiceProvider = function(xmlObj, service, version){
+
+       namespaces <- NULL
+       if(all(class(xmlObj) == c("XMLInternalDocument","XMLAbstractDocument"))){
+         namespaces <- OWSUtils$getNamespaces(xmlObj)
+       }
+       namespaces <- as.data.frame(namespaces)
+       namespace <- tolower(service)
+
+       serviceXML <- NULL
+       if(nrow(namespaces) > 0){
+         ns <- OWSUtils$findNamespace(namespaces, namespace)
+         if(length(ns)>0){
+           if(namespace %in% names(ns)){
+             serviceXML <- getNodeSet(xmlObj, "//ns:ServiceProvider", ns)
+           }
+         }
+         if(length(serviceXML)==0){
+           ns <- OWSUtils$findNamespace(namespaces, "ows")
+           if(length(ns)>0){
+             serviceXML <- getNodeSet(xmlObj, "//ns:ServiceProvider", ns)
+           }
+         }
+       }else{
+         serviceXML <- getNodeSet(xmlObj, "//ServiceProvider")
+       }
+
+       providerName <- NULL
+       providerSite <- NULL
+       serviceContact <- NULL
+       if(length(serviceXML) > 0){
+         serviceXML <- serviceXML[[1]]
+         children <- xmlChildren(serviceXML)
+
+         if(!is.null(children$ProviderName)){
+           providerName <- xmlValue(children$ProviderName)
+         }
+         if(!is.null(children$ProviderSite)){
+           siteLink <- xmlGetAttr(children$ProviderSite, "xlink:href")
+           providerSite <- ISOOnlineResource$new()
+           providerSite$setLinkage(siteLink)
+         }
+         sc <- children$ServiceContact
+         if(!is.null(sc)){
+           sc.children <- xmlChildren(sc)
+           individualName <- xmlValue(sc.children$IndividualName)
+           positionName <- xmlValue(sc.children$PositionName)
+           serviceContact <- ISOResponsibleParty$new()
+           serviceContact$setIndividualName(individualName)
+           serviceContact$setPositionName(positionName)
+           contactInfo <- sc.children$ContactInfo
+           if(!is.null(contactInfo)){
+             infos <- xmlChildren(contactInfo)
+             contact <- ISOContact$new()
+
+             if(!is.null(infos$Phone)){
+               phone <- ISOTelephone$new()
+               voice <- xmlValue(xmlChildren(infos$Phone)$Voice)
+               phone$setVoice(voice)
+               facsimile <- xmlValue(xmlChildren(infos$Phone)$Facsimile)
+               phone$setFacsimile(facsimile)
+               contact$setPhone(phone)
+             }
+
+             if(!is.null(infos$Address)){
+               address <- ISOAddress$new()
+               address$setDeliveryPoint(xmlValue(xmlChildren(infos$Address)$DeliveryPoint))
+               address$setCity(xmlValue(xmlChildren(infos$Address)$City))
+               address$setPostalCode(xmlValue(xmlChildren(infos$Address)$PostalCode))
+               address$setCountry(xmlValue(xmlChildren(infos$Address)$Country))
+               address$setEmail(xmlValue(xmlChildren(infos$Address)$ElectronicMailAddress))
+               contact$setAddress(address)
+             }
+
+             if(!is.null(infos$OnlineResource)){
+               or <- ISOOnlineResource$new()
+               or$setLinkage(xmlGetAttr(infos$OnlineResource, "xlink:href"))
+               contact$setOnlineResource(or)
+             }
+
+             serviceContact$setContactInfo(contact)
+           }
+         }
+
+       }
+
+       serviceProvider <- list(
+         providerName = providerName,
+         providerSite = providerSite,
+         serviceContact = serviceContact
+       )
+
+       return(serviceProvider)
+     }
+   ),
+   public = list(
+     initialize = function(xmlObj, service, version){
+       serviceProvider <- private$fetchServiceProvider(xmlObj, service, version)
+       private$providerName <- serviceProvider$providerName
+       private$providerSite <- serviceProvider$providerSite
+       private$serviceContact <- serviceProvider$serviceContact
+     },
+
+     #getProviderName
+     getProviderName = function(){
+       return(private$providerName)
+     },
+
+     #getProviderSite
+     getProviderSite = function(){
+       return(private$providerSite)
+     },
+
+     #getServiceContact
+     getServiceContact = function(){
+       return(private$serviceContact)
+     }
+
+   )
+)

tests/testthat/test_CSWClient.R

@@ -9,30 +9,76 @@ require(testthat)
 context("CSW")
 
 #CSW 2.0.2 – GetCapabilities
-
-test_that("CSW 2.0.2 - GetCapabilities | GeoNetwork",{
-  csw <- CSWClient$new("http://localhost:8282/geonetwork/srv/eng/csw", "2.0.2", logger = "INFO")
+#--------------------------------------------------------------------------
+#--> pycsw
+test_that("CSW 2.0.2 - GetCapabilities | pycsw",{
+  csw <- CSWClient$new("http://localhost:8000/csw", "2.0.2", logger="INFO")
   expect_is(csw, "CSWClient")
   caps <- csw$getCapabilities()
   expect_is(caps, "CSWCapabilities")
+
+  #service identification
+  SI <- caps$getServiceIdentification()
+  expect_equal(SI$getTitle(), "pycsw Geospatial Catalogue")
+  expect_equal(SI$getAbstract(), "pycsw is an OGC CSW server implementation written in Python")
+  expect_equal(SI$getServiceType(), "CSW")
+  expect_equal(SI$getServiceTypeVersion(), "2.0.2")
+  expect_equal(SI$getKeywords(), c("catalogue","discovery","metadata"))
+  expect_equal(SI$getFees(), "None")
+  expect_equal(SI$getAccessConstraints(), "None")
+
+  #service provider
+  SP <- caps$getServiceProvider()
+  expect_equal(SP$getProviderName(), "Organization Name")
+  expect_is(SP$getProviderSite(), "ISOOnlineResource")
+  expect_equal(SP$getProviderSite()$linkage$value, "http://pycsw.org/")
+  rp <- SP$getServiceContact()
+  expect_is(rp, "ISOResponsibleParty")
+  expect_equal(rp$individualName, "Lastname, Firstname")
+  expect_equal(rp$positionName, "Position Title")
+  contact <- rp$contactInfo
+  expect_is(contact, "ISOContact")
+  expect_is(contact$phone, "ISOTelephone")
+  expect_equal(contact$phone$voice, "+xx-xxx-xxx-xxxx")
+  expect_equal(contact$phone$facsimile, "+xx-xxx-xxx-xxxx")
+  expect_is(contact$address, "ISOAddress")
+  expect_equal(contact$address$deliveryPoint, "Mailing Address")
+  expect_equal(contact$address$city, "City")
+  expect_equal(contact$address$postalCode, "Zip or Postal Code")
+  expect_equal(contact$address$country, "Country")
+  expect_equal(contact$address$electronicMailAddress, "[email protected]")
+  expect_is(contact$onlineResource, "ISOOnlineResource")
+  expect_equal(contact$onlineResource$linkage$value, "Contact URL")
+
+  #service operation metadata
+  OPM <- caps$getOperationsMetadata()
+  OP <- OPM$getOperations()
+  expect_is(OP, "list")
+  expect_equal(length(OP), 8L)
+  expect_equal(unique(sapply(OP, function(i){class(i)[1]})), "OWSOperation")
+  operations <- sapply(OP,function(op){op$getName()})
+  expect_equal(operations, c("GetCapabilities", "DescribeRecord", "GetDomain", "GetRecords", 
+                             "GetRecordById", "GetRepositoryItem", "Transaction", "Harvest"))
+
 })
 
-test_that("CSW 2.0.2 - GetCapabilities | pycsw",{
-  csw <- CSWClient$new("http://demo.pycsw.org/cite/csw", "2.0.2", logger="INFO")
+#--> GeoNetwork
+test_that("CSW 2.0.2 - GetCapabilities | GeoNetwork",{
+  csw <- CSWClient$new("http://localhost:8282/geonetwork/srv/eng/csw", "2.0.2", logger = "INFO")
   expect_is(csw, "CSWClient")
   caps <- csw$getCapabilities()
   expect_is(caps, "CSWCapabilities")
 })
 
 #CSW 2.0.2 – DescribeRecord
-
+#--------------------------------------------------------------------------
 #test_that("CSW 2.0.2 - DescribeRecord",{
-#  csw <- CSWClient$new("http://localhost:8282/geonetwork/srv/en/csw", "2.0.2", logger = "INFO")
-#  xsd <- csw$describeRecord(outputSchema = "http://www.isotc211.org/2005/gmd")
+#  csw <- CSWClient$new("http://localhost:8000/csw", "2.0.2", logger = "DEBUG")
+#  xsd <- csw$describeRecord(namespace = "http://www.isotc211.org/2005/gmd")
 #})
 
 #CSW 2.0.2 – GetRecordById
-
+#--------------------------------------------------------------------------
 test_that("CSW 2.0.2 - GetRecordById",{
   csw <- CSWClient$new("http://www.fao.org/geonetwork/srv/en/csw", "2.0.2", logger = "INFO")
   md <- csw$getRecordById("fao-species-map-tth", outputSchema = "http://www.isotc211.org/2005/gmd")