#187

NAMESPACE

@@ -328,6 +328,7 @@ export(SWECategoryRange)
 export(SWECount)
 export(SWECountRange)
 export(SWEDataRecord)
+export(SWEElement)
 export(SWENilValues)
 export(SWEQuantity)
 export(SWEQuantityRange)

R/ISOAbstractObject.R

@@ -611,7 +611,19 @@ ISOAbstractObject <- R6Class("ISOAbstractObject",
                 self[[fieldName]] <- gmlElem
               }
             }
-
+
+          }else if(inherits(self, "SWEAbstractObject")){ 
+            #TODO see how to improve encoding/decoding for GML/SWE objects
+            xmlNamespacePrefix <- self$getClass()$private_fields$xmlNamespacePrefix
+            if(startsWith(nsPrefix,"swe")) xmlNamespacePrefix <- toupper(nsPrefix)
+            if(is.null(xmlNamespacePrefix)) xmlNamespacePrefix <- "SWE"
+            sweElem <- SWEElement$new(element = fieldName, xmlNamespacePrefix = xmlNamespacePrefix)
+            sweElem$decode(xml = childElement)
+            if(is(self[[fieldName]], "list")){
+              self[[fieldName]] <- c(self[[fieldName]], sweElem)
+            }else{
+              self[[fieldName]] <- sweElem
+            }
           }else{
             value <- xmlValue(child)
             isList <- is.list(self$getClass()$public_fields[[fieldName]])

R/SWEAbstractDataComponent.R

@@ -40,7 +40,7 @@ SWEAbstractDataComponent <- R6Class("SWEAbstractDataComponent",
     #'@param definition definition
     initialize = function(xml = NULL, element = NULL, updatable = NULL, optional = FALSE, definition = NULL){
       if(is.null(element)) element <- private$xmlElement
-      super$initialize(xml, element = element, attrs = list(), defaults = list(), wrap = FALSE)
+      super$initialize(xml, element = element, attrs = list(), defaults = list(), wrap = FALSE, value_as_field = TRUE)
       if(!is.null(updatable)) if(is.logical(updatable)) self$setAttr("updatable", tolower(updatable))
       self$setAttr("optional", tolower(optional))
       if(!is.null(definition)) self$setAttr("definition", definition)

R/SWEAbstractObject.R

@@ -25,11 +25,13 @@ SWEAbstractObject <- R6Class("SWEAbstractObject",
      #'@param attrs attrs
      #'@param defaults defaults
      #'@param wrap wrap
-     initialize = function(xml = NULL, element = NULL, attrs = list(), defaults = list(), wrap = FALSE){
+     #'@param value_as_field whether value should be set as field
+     initialize = function(xml = NULL, element = NULL, attrs = list(), defaults = list(), wrap = FALSE,
+                           value_as_field = FALSE){
        if(is.null(element)) element <- private$xmlElement
        super$initialize(xml, element, namespace = private$xmlNamespacePrefix, 
                         attrs = attrs, defaults = defaults,
-                        wrap = wrap, value_as_field = TRUE)
+                        wrap = wrap, value_as_field = value_as_field)
      }
    )                        
 )

R/SWEAbstractSWE.R

@@ -12,7 +12,7 @@
 #' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
 #'
 SWEAbstractSWE <- R6Class("SWEAbstractSWE",
-   inherit = ISOAbstractObject,
+   inherit = SWEAbstractObject,
    private = list(
      xmlElement = "AbstractSWE",
      xmlNamespacePrefix = "SWE"
@@ -25,11 +25,13 @@ SWEAbstractSWE <- R6Class("SWEAbstractSWE",
      #'@param attrs attrs
      #'@param defaults defaults
      #'@param wrap wrap
-     initialize = function(xml = NULL, element = NULL, attrs = list(), defaults = list(), wrap = FALSE){
+     #'@param value_as_field whether value should be set as field
+     initialize = function(xml = NULL, element = NULL, attrs = list(), defaults = list(), wrap = FALSE,
+                           value_as_field = FALSE){
        if(is.null(element)) element <- private$xmlElement
-       super$initialize(xml, element, namespace = private$xmlNamespacePrefix, 
+       super$initialize(xml, element, 
                         attrs = attrs, defaults = defaults,
-                        wrap = wrap, value_as_field = TRUE)
+                        wrap = wrap, value_as_field = value_as_field)
      }
    )                        
 )

R/SWEElement.R

@@ -0,0 +1,94 @@
+#' SWEElement
+#'
+#' @docType class
+#' @importFrom R6 R6Class
+#' @export
+#' @keywords ISO GML element
+#' @return Object of \code{\link{R6Class}} for modelling an GML element
+#' @format \code{\link{R6Class}} object.
+#'
+#' @section Methods:
+#' \describe{
+#'  \item{\code{new(xml, element, attrs, defaults)}}{
+#'    This method is used to instantiate a GML element
+#'  }
+#' }
+#' 
+#' @note Class used by geometa internal XML decoder/encoder
+#' 
+#' @references
+#'  ISO/TS 19103:2005 Geographic information -- Conceptual schema language
+#' 
+#' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
+#'
+SWEElement <- R6Class("SWEElement",
+  inherit = SWEAbstractObject,
+  lock_objects = FALSE,
+  private = list(
+    xmlElement = "Element",
+    xmlNamespacePrefix = "SWE"
+  ),
+  public = list(
+    initialize = function(xml = NULL, element = NULL, attrs = list(), defaults = list(), xmlNamespacePrefix = "SWE"){
+      private$xmlNamespacePrefix <- xmlNamespacePrefix
+      super$initialize(xml = xml, element = element, attrs = attrs, defaults = defaults, wrap = FALSE)
+    },
+
+    decode = function(xml){
+      fieldName <- xmlName(xml)
+      nsPrefix <- ""
+      fNames <- unlist(strsplit(fieldName, ":"))
+      if(length(fNames)>1){
+        fieldName <- fNames[2]
+      }
+      self$element = fieldName
+
+      #set attrs if any
+      self$attrs <- as.list(xmlAttrs(xml, TRUE, FALSE))
+
+      fieldValue <- xmlValue(xml, recursive = FALSE)
+      if(length(fieldValue)>0){
+        #set value if any
+        if(fieldValue %in% c("true","false")) fieldValue <- as.logical(fieldValue)
+        fieldValue <- private$toComplexTypes(fieldValue)
+        if(!is.na(fieldValue)) self$setValue(fieldValue)
+      }else{
+        #set children if any
+        children <- xmlChildren(xml, encoding = private$encoding)
+        if(length(children)>0){
+          for(i in 1:length(children)){
+            childXML <- children[[i]]
+            childName <- names(children)[i]
+            childElem <- SWEElement$new(element = childName)
+            childElem$decode(xml = childXML)
+            if(is(self[[childName]], "list") | !is.null(self[[childName]])){
+              self[[childName]] <- c(self[[childName]], childElem)
+            }else{
+              self[[childName]] <- childElem
+            }
+          }
+        }
+      }
+    }
+  )
+)
+
+SWEElement$create <- function(element, value = NULL,  attrs = list(), href = NULL, 
+                              codeList = NULL, codeListValue = NULL, codeSpace = NULL,
+                              xmlNamespacePrefix = "SWE"){
+  #element
+  sweElem <- SWEElement$new(element = element, xmlNamespacePrefix = xmlNamespacePrefix)
+  #value
+  if(!is.null(value)) sweElem$setValue(value)
+  #general attributes
+  for(attrName in names(attrs)){
+    sweElem$setAttr(attrName, attrs[[attrName]])
+  }
+  #specific attributes
+  if(!is.null(href)) sweElem$setHref(href)
+  if(!is.null(codeList)) sweElem$setCodeList(codeList)
+  if(!is.null(codeListValue)) sweElem$setCodeListValue(codeListValue)
+  if(!is.null(codeSpace)) sweElem$setCodeSpace(codeSpace)
+
+  return(sweElem)
+}

R/SWENilValues.R

@@ -21,13 +21,24 @@ SWENilValues <- R6Class("SWENilValues",
    public = list(
 
      #'@field nilValue nil value
-     nilValue = matrix(NA_real_, 1, 1),
+     nilValue = list(),
 
-     initialize = function(xml = NULL, value = NULL){
+     #'@description Initializes a SWE Nil Values object
+     #'@param xml object of class \link{XMLInternalNode-class} from \pkg{XML}
+     #'@param values vector of numerical values to consider as nil values
+     initialize = function(xml = NULL){
        super$initialize(xml, element = private$xmlElement, 
                         attrs = list(), defaults = list(),
                         wrap = FALSE)
-        if(!is.null(value)) self$nilValue = value
+     },
+
+     #'@description Adds a nil value with a reason
+     #'@param value value
+     #'@param reason reason
+     addNilValue = function(value, reason){
+        nilValueElem <- SWEElement$create(element = "nilValue", value = value)
+        nilValueElem$setAttr("reason", reason)
+        self$nilValue <- c(self$nilValue, nilValueElem)
      }
    )                        
 )

R/SWEQuantity.R

@@ -52,7 +52,9 @@ SWEQuantity <- R6Class("SWEQuantity",
     #'@description setUom
     #'@param uom uom
     setUom = function(uom){
-      self$uom <- uom
+      uomElem <- SWEElement$create(element = "uom")
+      uomElem$setAttr("code", uom)
+      self$uom <- uomElem
     },
 
     #'@description setConstraint

R/SWEQuantityRange.R

@@ -52,7 +52,9 @@ SWEQuantityRange <- R6Class("SWEQuantityRange",
      #'@description setUom
      #'@param uom uom
      setUom = function(uom){
-       self$uom <- uom
+        uomElem <- SWEElement$create(element = "uom")
+        uomElem$setAttr("code", uom)
+        self$uom <- uomElem
      },
 
      #'@description setConstraint

R/SWETime.R

@@ -52,7 +52,9 @@ SWETime <- R6Class("SWETime",
      #'@description setUom
      #'@param uom uom
      setUom = function(uom){
-       self$uom <- uom
+        uomElem <- SWEElement$create(element = "uom")
+        uomElem$setAttr("code", uom)
+        self$uom <- uomElem
      },
 
      #'@description setConstraint

tests/testthat/test_SWENilValues.R

@@ -0,0 +1,25 @@
+# test_SWENilValues.R
+# Author: Emmanuel Blondel <emmanuel.blondel1@gmail.com>
+#
+# Description: Unit tests for classes inheriting SWENilValues.R
+#=======================
+require(geometa, quietly = TRUE)
+require(sf)
+require(testthat)
+
+context("SWENilValues")
+
+test_that("SWENilValues",{
+  testthat::skip_on_cran()
+  #encoding
+  nil <- SWENilValues$new()
+  nil$addNilValue(1,"unknown")
+  nil$addNilValue(2,"unknown")
+  xml <- nil$encode()
+  expect_is(xml, "XMLInternalNode")
+  #decoding
+  nil2 <- SWENilValues$new(xml = xml)
+  xml2 <- nil2$encode()
+  #assert object identity
+  expect_true(ISOAbstractObject$compare(nil, nil2))
+})

tests/testthat/test_SWEQuantity.R

@@ -12,7 +12,7 @@ context("SWEQuantity")
 test_that("SWEQuantity",{
   testthat::skip_on_cran()
   #encoding
-  q <- SWEQuantity$new(value = 2.56)
+  q <- SWEQuantity$new(value = 2.56, uom = "m")
   xml <- q$encode()
   expect_is(xml, "XMLInternalNode")
   #decoding

tests/testthat/test_SWEQuantityRange.R

@@ -12,7 +12,7 @@ context("SWEQuantityRange")
 test_that("SWEQuantityRange",{
   testthat::skip_on_cran()
   #encoding
-  qr <- SWEQuantityRange$new(value = matrix(c(0,1),1,2))
+  qr <- SWEQuantityRange$new(value = matrix(c(0,1),1,2), uom = "m")
   xml <- qr$encode()
   expect_is(xml, "XMLInternalNode")
   #decoding