fix GML encoding/decoding

R/GMLAbstractCRS.R

@@ -41,7 +41,7 @@ GMLAbstractCRS <- R6Class("GMLAbstractCRS",
      #+ scope [1..*]: character
      scope = list(),
 
-     initialize = function(xml = NULL, defaults = list(), id = NA){
+     initialize = function(xml = NULL, defaults = list(), id = NULL){
        super$initialize(xml = xml, defaults = defaults)
        if(is.null(xml)){
          self$setId(id, addNS = TRUE)

R/GMLAbstractCoordinateOperation.R

@@ -59,7 +59,7 @@ GMLAbstractCoordinateOperation <- R6Class("GMLAbstractCoordinateOperation",
      #+ targetCRS [0..1]: subclass of GMLAbstractCRS
      targetCRS = NULL,
 
-     initialize = function(xml = NULL, defaults = list(), id = NA){
+     initialize = function(xml = NULL, defaults = list(), id = NULL){
        super$initialize(xml = xml, defaults = defaults)
        if(is.null(xml)){
          self$setId(id, addNS = TRUE)

R/GMLAbstractCoordinateSystem.R

@@ -41,7 +41,7 @@ GMLAbstractCoordinateSystem <- R6Class("GMLAbstractCoordinateSystem",
     #+ axis [1..*]: GMLCoordinateSystemAxis
     axis = list(),
 
-    initialize = function(xml = NULL, defaults = list(), id = NA){
+    initialize = function(xml = NULL, defaults = list(), id = NULL){
       super$initialize(xml = xml, defaults = defaults)
       if(is.null(xml)){
         self$setId(id, addNS = TRUE)
@@ -53,17 +53,15 @@ GMLAbstractCoordinateSystem <- R6Class("GMLAbstractCoordinateSystem",
       if(!is(axis, "GMLCoordinateSystemAxis")){
         stop("The argument value should be an object of class 'GMLCoordinateSystemAxis")
       }
-      gmlElem <- GMLElement$create("axis", value = axis)
-      return(self$addListElement("axis", gmlElem))
+      return(self$addListElement("axis", axis))
     },
 
     #delAxis
     delAxis = function(axis){
       if(!is(axis, "GMLCoordinateSystemAxis")){
         stop("The argument value should be an object of class 'GMLCoordinateSystemAxis")
       }
-      gmlElem <- GMLElement$create("axis", value = axis)
-      return(self$delListElement("axis", gmlElem))
+      return(self$delListElement("axis", axis))
     }
   )
 )

R/GMLAbstractGML.R

@@ -53,7 +53,7 @@ GMLAbstractGML <- R6Class("GMLAbstractGML",
      identifier = NULL,
      #+ name [0..*]: character
      name = list(),
-     initialize = function(xml = NULL, element = NULL, attrs = list(), defaults = list(), wrap = FALSE){
+     initialize = function(xml = NULL, element = NULL, attrs = list(), defaults = list(), wrap = TRUE){
        if(is.null(element)) element <- private$xmlElement
        super$initialize(xml, element = element, attrs = attrs, defaults = defaults, wrap = wrap)
      },

R/GMLBaseUnit.R

@@ -46,7 +46,7 @@ GMLBaseUnit <- R6Class("GMLBaseUnit",
    public = list(
      #+ unitsSystem [1..1]: character
      unitsSystem = NULL,
-     initialize = function(xml = NULL, defaults = list(), id = NA){
+     initialize = function(xml = NULL, defaults = list(), id = NULL){
        super$initialize(xml, defaults)
        if(is.null(xml)){
          self$setId(id, addNS = TRUE)

R/GMLConventionalUnit.R

@@ -60,7 +60,7 @@ GMLConventionalUnit <- R6Class("GMLConventionalUnit",
     roughConversionToPreferredUnit = NULL,
     #+ derivationUnitTerm [1..*]: character
     derivationUnitTerm = NULL,
-    initialize = function(xml = NULL, defaults = list(), id = NA){
+    initialize = function(xml = NULL, defaults = list(), id = NULL){
       super$initialize(xml, defaults)
       if(is.null(xml)){
         self$setId(id, addNS = TRUE)

R/GMLCoordinateSystemAxis.R

@@ -62,7 +62,7 @@ GMLCoordinateSystemAxis <- R6Class("GMLCoordinateSystemAxis",
      #+ rangeMeaning [0..1]: character (with codeSpace)
      rangeMeaning = NA,
 
-     initialize = function(xml = NULL, defaults = list(), id = NA, uom = NA){
+     initialize = function(xml = NULL, defaults = list(), id = NULL, uom = NA){
        super$initialize(xml = xml, defaults = defaults)
        if(is.null(xml)){
          self$setId(id, addNS = TRUE)

R/GMLDefinition.R

@@ -14,9 +14,6 @@
 #'  \item{\code{new(xml, defaults)}}{
 #'    This method is used to instantiate a GML Definition
 #'  }
-#'  \item{\code{setId(id)}}{
-#'    Sets the id
-#'  }
 #'  \item{\code{addRemark(remark)}}{
 #'    Adds a remark
 #'  }
@@ -41,19 +38,16 @@
 #' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
 #'
 GMLDefinition <- R6Class("GMLDefinition",
-  inherit = GMLElement,
+  inherit = GMLAbstractGML,
   private = list(
     xmlElement = "Definition",
     xmlNamespacePrefix = "GML"
   ),
   public = list(
     #+ remarks [0..*]: character
     remarks = list(),
-    initialize = function(xml = NULL, defaults = list(), id = NA){
+    initialize = function(xml = NULL, defaults = list()){
       super$initialize(xml, element = private$xmlElement, defaults)
-      if(is.null(xml)){
-        self$setId(id, addNS = TRUE)
-      }
     },
 
     #addRemark

R/GMLDerivedUnit.R

@@ -49,7 +49,7 @@ GMLDerivedUnit <- R6Class("GMLDerivedUnit",
    public = list(
      #+ derivationUnitTerm [1..*]: character
      derivationUnitTerm = NULL,
-     initialize = function(xml = NULL, defaults = list(), id = NA){
+     initialize = function(xml = NULL, defaults = list(), id = NULL){
        super$initialize(xml, defaults)
        if(is.null(xml)){
          self$setId(id, addNS = TRUE)

R/GMLElement.R

@@ -30,7 +30,7 @@ GMLElement <- R6Class("GMLElement",
     ),
     public = list(
       initialize = function(xml = NULL, element = NULL, attrs = list(), defaults = list()){
-        super$initialize(xml = xml, element = element, attrs = attrs, defaults = defaults)
+        super$initialize(xml = xml, element = element, attrs = attrs, defaults = defaults, wrap = FALSE)
       },
 
       decode = function(xml){

R/GMLOperationParameterGroup.R

@@ -70,15 +70,15 @@ GMLOperationParameterGroup <- R6Class("GMLOperationParameterGroup",
        if(!inherits(param, "GMLAbstractGeneralOperationParameter")){
          stop("The argument value should be an object of class 'GMLOperationParameter' or 'GMLOperationParameterGroup'")
        }
-       return(self$addListElement("parameter", GMLElement$create("parameter", value = param)))
+       return(self$addListElement("parameter", param))
      },
 
      #delParameter
      delParameter = function(param){
        if(!inherits(param, "GMLAbstractGeneralOperationParameter")){
          stop("The argument value should be an object of class 'GMLOperationParameter' or 'GMLOperationParameterGroup'")
        }
-       return(self$delListElement("parameter", GMLElement$create("parameter", value = param)))
+       return(self$delListElement("parameter", param))
      }
 
    )

R/GMLPoint.R

@@ -33,7 +33,6 @@ GMLPoint <- R6Class("GMLPoint",
      xmlNamespacePrefix = "GML"
    ),
    public = list(
-     attrs = list("gml:id" = NA),
      pos = matrix(NA_real_, 1, 2),
      initialize = function(xml = NULL, sfg){
        super$initialize(xml, element = private$xmlElement, wrap = TRUE)

R/GMLPolygon.R

@@ -33,7 +33,6 @@ GMLPolygon <- R6Class("GMLPolygon",
     xmlNamespacePrefix = "GML"
   ),
   public = list(
-    attrs = list("gml:id" = NA),
     exterior = NA,
     interior = list(),
     initialize = function(xml = NULL, sfg){

R/GMLTimePeriod.R

@@ -50,7 +50,6 @@ GMLTimePeriod <- R6Class("GMLTimePeriod",
     xmlNamespacePrefix = "GML"
   ),
   public = list(
-    attrs = list("gml:id" = NA),
     #+ beginPosition [1]: 'POSIXct','POSIXt'
     beginPosition = NULL,
     #+ endPosition [1]: 'POSIXct','POSIXt'

R/GMLUnitDefinition.R

@@ -52,7 +52,7 @@ GMLUnitDefinition <- R6Class("GMLUnitDefinition",
      quantityTypeReference = NULL,
      #+ catalogSymbol [0..1]: character
      catalogSymbol = NULL,
-     initialize = function(xml = NULL, defaults = list(), id = NA){
+     initialize = function(xml = NULL, defaults = list(), id = NULL){
        super$initialize(xml, defaults)
        if(is.null(xml)){
          self$setId(id, addNS = TRUE)

R/ISOAbstractObject.R

@@ -43,12 +43,17 @@
 #'  \item{\code{decode(xml)}}{
 #'    Decodes a ISOMetadata* R6 object from XML representation
 #'  }
-#'  \item{\code{encode(addNS, validate, strict)}}{
+#'  \item{\code{encode(addNS, validate, strict, resetSerialID, setSerialID)}}{
 #'    Encodes a ISOMetadata* R6 object to XML representation. By default, namespace
 #'    definition will be added to XML root (\code{addNS = TRUE}), and validation
 #'    of object will be performed (\code{validate = TRUE}) prior to its XML encoding.
 #'    The argument \code{strict} allows to stop the encoding in case object is not
-#'    valid, with a default value set to \code{FALSE}.
+#'    valid, with a default value set to \code{FALSE}. The argument \code{setSerialID}
+#'    is used by \pkg{geometa} to generate automatically serial IDs associated to
+#'    XML elements, in particular for GML, default value is \code{TRUE} (recommended value).
+#'    The argument \code{resetSerialID} is used by \pkg{geometa} for reseting mandatory IDs
+#'    associated to XML elements, such as GML objects, default value is \code{TRUE} 
+#'    (recommended value).
 #'  }
 #'  \item{\code{validate(xml, strict)}}{
 #'    Validates the encoded XML against ISO 19139 XML schemas. If \code{strict} is
@@ -376,14 +381,18 @@ ISOAbstractObject <- R6Class("ISOAbstractObject",
     },
 
     #encode
-    encode = function(addNS = TRUE, validate = TRUE, strict = FALSE){
+    encode = function(addNS = TRUE, validate = TRUE, strict = FALSE,
+                      resetSerialID = TRUE, setSerialID = TRUE){
 
       #management of GML ids
-      if(addNS) .geometa.gml$serialId <- 1L
-      if(inherits(self, "GMLAbstractGML")){
-        if(is.null(self$attrs[["gml:id"]])){
-          self$setId(paste0("ID",.geometa.gml$serialId),TRUE)
-          .geometa.gml$serialId <- .geometa.gml$serialId+1
+      if(resetSerialID) .geometa.gml$serialId <- 1L
+      if(setSerialID){
+        if(inherits(self, "GMLAbstractGML")){
+          if(is.null(self$attrs[["gml:id"]])){
+            serialId <- paste0("ID",.geometa.gml$serialId)
+            self$setId(serialId,TRUE)
+            .geometa.gml$serialId <- .geometa.gml$serialId+1
+          }
         }
       }
 
@@ -395,6 +404,7 @@ ISOAbstractObject <- R6Class("ISOAbstractObject",
       rootXMLAttrs <- list()
       if("attrs" %in% fields){
         rootXMLAttrs <- self[["attrs"]]
+        rootXMLAttrs <- rootXMLAttrs[!is.na(rootXMLAttrs)]
       }
 
       #fields
@@ -447,7 +457,8 @@ ISOAbstractObject <- R6Class("ISOAbstractObject",
         namespaceId <- names(ns)
         if(!is.null(fieldObj)){
           if(is(fieldObj, "ISOAbstractObject")){
-            fieldObjXml <- fieldObj$encode(addNS = FALSE, validate = FALSE)
+            fieldObjXml <- fieldObj$encode(addNS = FALSE, validate = FALSE,
+                                           resetSerialID = FALSE, setSerialID = setSerialID)
             if(is(fieldObj, "ISOElementSequence")){
               fieldObjXml.children <- xmlChildren(fieldObjXml)
               if(self$wrap){
@@ -467,7 +478,7 @@ ISOAbstractObject <- R6Class("ISOAbstractObject",
               #  return(which(fieldObjNames == name) < which(fieldObjNames == ".__enclos_env__"))
               #})]
             }else{
-              if(self$wrap){
+              if(fieldObj$wrap){
                 wrapperNode <- xmlOutputDOM(
                   tag = field,
                   nameSpace = namespaceId
@@ -486,7 +497,8 @@ ISOAbstractObject <- R6Class("ISOAbstractObject",
               }else{
                 nodeValue <- self$wrapBaseElement(field, item)
               }
-              nodeValueXml <- nodeValue$encode(addNS = FALSE, validate = FALSE)
+              nodeValueXml <- nodeValue$encode(addNS = FALSE, validate = FALSE,
+                                               resetSerialID = FALSE, setSerialID = setSerialID)
               if(is(item, "ISOElementSequence")){
                 nodeValueXml.children <- xmlChildren(nodeValueXml)
                 #if(self$wrap){
@@ -544,10 +556,12 @@ ISOAbstractObject <- R6Class("ISOAbstractObject",
                       tag = field,
                       nameSpace = namespaceId
                     )
-                    wrapperNode$addNode(dataObj$encode(addNS = FALSE, validate = FALSE))
+                    wrapperNode$addNode(dataObj$encode(addNS = FALSE, validate = FALSE,
+                                                       resetSerialID = FALSE, setSerialID = setSerialID))
                     rootXML$addNode(wrapperNode$value())
                   }else{
-                    rootXML$addNode(dataObj$encode(addNS = FALSE, validate = FALSE))
+                    rootXML$addNode(dataObj$encode(addNS = FALSE, validate = FALSE,
+                                                   resetSerialID = FALSE, setSerialID = setSerialID))
                   }
                 }
               }
@@ -877,7 +891,8 @@ ISOAbstractObject$getISOClassByNode = function(node){
 ISOAbstractObject$compare = function(metadataElement1, metadataElement2){
   text1 <- NULL
   if(is(metadataElement1, "ISOAbstractObject")){
-    xml1 <-metadataElement1$encode(addNS = TRUE, validate = FALSE)
+    xml1 <-metadataElement1$encode(addNS = TRUE, validate = FALSE,
+                                   resetSerialID = FALSE, setSerialID = FALSE)
     if(metadataElement1$isDocument()){
       content1 <- as(xml1, "character")
       content1 <- gsub("<!--.*?-->", "", content1)
@@ -891,7 +906,7 @@ ISOAbstractObject$compare = function(metadataElement1, metadataElement2){
   }
   text2 <- NULL
   if(is(metadataElement2, "ISOAbstractObject")){
-    xml2 <- metadataElement2$encode(addNS = TRUE, validate = FALSE)
+    xml2 <- metadataElement2$encode(addNS = TRUE, validate = FALSE, setSerialID = FALSE)
     if(metadataElement2$isDocument()){
       content2 <- as(xml2, "character")
       content2 <- gsub("<!--.*?-->", "", content2)

tests/testthat/test_GMLAbstractCRS.R

@@ -12,7 +12,7 @@ context("GMLAbstractCRS")
 test_that("encoding",{
 
   #encoding
-  gml <- GMLAbstractCRS$new(id = "ID")
+  gml <- GMLAbstractCRS$new()
   gml$setDescriptionReference("someref")
   gml$setIdentifier("test", "codespace")
   gml$addScope("somescope")

tests/testthat/test_GMLAbstractGeneralDerivedCRS.R

@@ -12,7 +12,7 @@ context("GMLAbstractGeneralDerivedCRS")
 test_that("encoding",{
 
   #encoding
-  gml <- GMLAbstractGeneralDerivedCRS$new(id = "ID")
+  gml <- GMLAbstractGeneralDerivedCRS$new()
   gml$setDescriptionReference("someref")
   gml$setIdentifier("test", "codespace")
   gml$addScope("somescope")

tests/testthat/test_GMLAbstractSingleCRS.R

@@ -12,7 +12,7 @@ context("GMLAbstractSingleCRS")
 test_that("encoding",{
 
   #encoding
-  gml <- GMLAbstractSingleCRS$new(id = "ID")
+  gml <- GMLAbstractSingleCRS$new()
   gml$setDescriptionReference("someref")
   gml$setIdentifier("test", "codespace")
   gml$addScope("somescope")

tests/testthat/test_GMLOperationParameter.R

@@ -58,19 +58,19 @@ test_that("GMLOperationParameterGroup",{
   gml$setMinimumOccurs(2L)
   gml$setMaximumOccurs(4L)
 
-  param1 <- GMLOperationParameter$new(id = "ID1")
+  param1 <- GMLOperationParameter$new()
   param1$setDescriptionReference("someref")
   param1$setIdentifier("identifier", "codespace")
   param1$addName("name1", "codespace")
   param1$addName("name2", "codespace")
   param1$setMinimumOccurs(2L)
   gml$addParameter(param1)
 
-  param2 <- GMLOperationParameter$new(id = "ID2")
+  param2 <- GMLOperationParameter$new()
   param2$setDescriptionReference("someref")
   param2$setIdentifier("identifier", "codespace")
-  param2$addName("name1", "codespace")
-  param2$addName("name2", "codespace")
+  param2$addName("name3", "codespace")
+  param2$addName("name4", "codespace")
   param2$setMinimumOccurs(2L)
   gml$addParameter(param2)