Merge pull request #6 from cboettig/treeparse

Treeparse

NAMESPACE

@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+export(eml_validate)
 export(read_eml)
 export(write_eml)
 import(XML)

R/S4Toeml.R

@@ -12,24 +12,36 @@
 #' @import methods
 S4Toeml <- function(obj,
                     node = NULL,
-                    excluded_slots = c("namespaces", "dirname", "xmlNodeName")){
+                    excluded_slots = c("namespaces", "dirname", "xmlNodeName"),
+                    ns = character()){
 
     who <- slotNames(obj)
+    if("namespaces" %in% who & length(ns) == 0){
+      ns <- obj@namespaces
+    }
 
-    slot_classes <- get_slots(obj)
+    slot_classes <- get_slots(class(obj))
     is_attribute <- sapply(slot_classes, function(x) x == "xml_attribute")
 
     attribute_elements <- who[is_attribute]
 
     ## Allow XML node name to be defined using a special slot (instead of class name)
-    if(is.null(node)){
-      if("xmlNodeName" %in% who)
-        node <- newXMLNode(slot(obj, "xmlNodeName"))
-      else
-        node <- newXMLNode(class(obj)[1])
+
+    if("xmlNodeName" %in% who){
+      node_name <- slot(obj, "xmlNodeName")
+    } else {
+      node_name <- class(obj)[1]
     }
 
 
+    if(length(ns) > 0)
+      node_name <- paste0("eml:", node_name)
+
+    if(is.null(node))
+      node <- newXMLNode(node_name, namespaceDefinitions = ns)
+
+
+
 
     who <- who[!(who %in% excluded_slots)] # drop excluded slots
     for(s in who){
@@ -40,13 +52,20 @@ S4Toeml <- function(obj,
           names(attrs) <- s
           addAttributes(node, .attrs = attrs)
         }
+
+      ## Capitalized slots are meta-types, and should not create a new xmlNode but instead
+      ## pass their children directly to their parent node.
+      } else if(grepl("^[A-Z]", s)){
+        X = slot(obj, s)
+        if(!isEmpty(X)){
+          addChildren(node, S4Toeml(X, node = node))
+        }
       } else {
         ## Complex child nodes
         X = slot(obj, s)
-
         if(!isEmpty(X)){
           if(is(X, "list")){
-            if(is.character(X[[1]]) & length(get_slots(X[[1]])) <= 1)
+            if(is.character(X[[1]]) & length(get_slots(class(X[[1]]))) <= 1)
               addChildren(node, lapply(X, function(x) newXMLNode(class(x), x)))
             else
               addChildren(node, lapply(X, as, "XMLInternalElementNode"))
@@ -65,6 +84,8 @@ S4Toeml <- function(obj,
         }
       }
     }
+
+
     node
 }
 
@@ -99,6 +120,6 @@ isEmpty <- function(obj){
 }
 
 
-get_slots <- function(s4){
-  getSlots(getClass(class(s4)))
+get_slots <- function(class_name){
+  getClass(class_name)@slots
 }

R/eml.R

@@ -1,4 +1,21 @@
 
+## Default XML namespaces -- consider moving to separate file
+eml_namespaces = c(eml = "eml://ecoinformatics.org/eml-2.1.1",
+                   ds = "eml://ecoinformatics.org/dataset-2.1.1",
+                   xs = "http://www.w3.org/2001/XMLSchema",
+                   xsi = "http://www.w3.org/2001/XMLSchema-instance",
+                   stmml = "http://www.xml-cml.org/schema/stmml_1.1")
+
+
+
+setClass("eml:eml",
+         slots = c(namespaces = "character", "xsi:schemaLocation" = "xml_attribute", xmlNodeName = "character"),
+         contains = "eml",
+         prototype = list(namespaces = eml_namespaces,
+                          xmlNodeName = "eml",
+                          "xsi:schemaLocation" =
+                            new("xml_attribute", "eml://ecoinformatics.org/eml-2.1.1 eml.xsd")))
+
 #' read_eml
 #'
 #' read_eml
@@ -34,5 +51,22 @@ read_eml <- function(file, ...){
 #' eml <- read_eml(f)
 #' write_eml(eml)
 write_eml <- function(eml, file = NULL, ...){
-  XML::saveXML(as(eml, "XMLInternalElementNode"), file = file, ...)
+  node <- as(as(eml, "eml:eml"), "XMLInternalElementNode")
+
+  XML::saveXML(node, file = file, ...)
+}
+
+#' validate_eml
+#'
+#' validate_eml
+#' @param eml an eml class object, file, or xml document
+#' @export
+eml_validate <- function(eml){
+
+  schema <- system.file("xsd/eml.xsd", package = "eml2") #"http://ropensci.github.io/EML/eml.xsd"
+
+  if(is(eml, "eml"))
+    eml <- write_eml(eml)
+
+  xmlSchemaValidate(schema, eml)
 }

R/emlToS4.R

@@ -10,39 +10,70 @@
 emlToS4 <- function (node, obj = new(xmlName(node)), ...){
 
   node_name <- xmlName(node)
+  attrs <- xmlAttrs(node)
+  children <- drop_comment_nodes(xmlChildren(node))
+  xml_names <- names(children)
+
+
   s4 <- new(node_name)
 
-  slot_classes <- getClass(node_name)@slots
-  attrs <- xmlAttrs(node)
+  slot_classes <- get_slots(node_name)
+  s4_names <- names(slot_classes)
+  subclasses <- xml_names[!xml_names %in% s4_names]
+  not_sub <- xml_names[xml_names %in% s4_names]
+
+  metanames <- s4_names[grepl("^[A-Z]", s4_names)]
+  metaclasses <- lapply(metanames, get_slots)
+  names(metaclasses) <- metanames
+
 
-  children <- drop_comment_nodes(xmlChildren(node))
 
   for(child in names(attrs)){
     slot(s4, child) <- new("xml_attribute",attrs[[child]])
   }
 
-
-  for(child in unique(names(children))){
-    if(is(children[[child]], "XMLInternalTextNode")){
+  ## consider xmlValue assignment if no matches for class
+  if(length(metaclasses) == 0 && length(subclasses) > 0){
       s4 <- new(node_name)
       s4@.Data <- xmlValue(node)
-    } else {
-      cls <- slot_classes[[child]]
+  } else {
+
+
+    ## These elements, like "title", go to s4@ResourceGroup@title,
+    ## rather than s4@title, where ResourceGroup is metaclass
+    for(child in unique(subclasses)){
+      y = lapply(metaclasses, function(x) match(child, names(x)))
+      s = names(y)[!is.na(y)]
+      cls <- metaclasses[[s]][[ y[[s]] ]]
       if(grepl("^ListOf", cls))
-        slot(s4,child) <- listof(children, child)
+        slot(slot(s4, s), child) <- listof(children, child)
       else if(cls == "character")
-        slot(s4,child) <- xmlValue(children[[child]])
+        slot(slot(s4, s), child) <- xmlValue(children[[child]])
       else
+        slot(slot(s4, s), child) <- as(children[[child]], child)
+    }
+
+    ## These are the normal s4@slot items
+    for(child in unique(not_sub)){
+      cls <- slot_classes[[child]]
+      if(grepl("^ListOf", cls)){
+        slot(s4,child) <- listof(children, child)
+      } else if(cls == "character"){
+        slot(s4,child) <- xmlValue(children[[child]])
+      } else {
         slot(s4,child) <- as(children[[child]], child)
+      }
     }
+
+
   }
 
   s4
 }
 
 ##
 listof <- function(kids, element, listclass = paste0("ListOf", element))
-  new(listclass, lapply(kids[names(kids) == element], as, element))  ## subsets already
+  new(listclass, lapply(kids[names(kids) == element], emlToS4))  ## subsets already
 
 
 ##  HTML-style comments create: XMLInternalCommentNode as xmlChildren, which we don't want
@@ -51,3 +82,4 @@ drop_comment_nodes <- function(nodes){
   nodes[!drop]
   }
 
+