[rkward/releases/0.6.4] packages/XiMpLe: began working on validity checks for XML objects

[m.eik michalke]

Git commit d5f5a284e5058da6125c4e646cb654706803d766 by m.eik michalke.
Committed on 07/12/2015 at 15:05.
Pushed by meikm into branch 'releases/0.6.4'.

began working on validity checks for XML objects

  - doesn't work at all yet
  - valid.child() is borrowed from rkwarddev
  - planning to add a new class to define validity checks

M  +2    -0    packages/XiMpLe/ChangeLog
A  +75   -0    packages/XiMpLe/R/01_method_04_validXML.R
M  +46   -0    packages/XiMpLe/R/XiMpLe-internal.R

http://commits.kde.org/rkward/d5f5a284e5058da6125c4e646cb654706803d766

diff --git a/packages/XiMpLe/ChangeLog b/packages/XiMpLe/ChangeLog
index 336c603..f8d869d 100644
--- a/packages/XiMpLe/ChangeLog
+++ b/packages/XiMpLe/ChangeLog
@@ -3,6 +3,8 @@ ChangeLog for package XiMpLe
 changes in version 0.03-24 (2015-11-24)
 unreleased:
   - this release is under development
+added:
+  - new method validXML() for some basic validity checks (WIP)
 
 changes in version 0.03-23 (2015-11-24)
 changed:
diff --git a/packages/XiMpLe/R/01_method_04_validXML.R b/packages/XiMpLe/R/01_method_04_validXML.R
new file mode 100644
index 0000000..3dbd90e
--- /dev/null
+++ b/packages/XiMpLe/R/01_method_04_validXML.R
@@ -0,0 +1,75 @@
+# Copyright 2015 Meik Michalke <meik.michalke at hhu.de>
+#
+# This file is part of the R package XiMpLe.
+#
+# XiMpLe is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# XiMpLe is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with XiMpLe.  If not, see <http://www.gnu.org/licenses/>.
+
+
+#' Validate S4 objects of XiMpLe XML classes
+#' 
+#' Check whether objects of class \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}}
+#' or \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}} have valid child nodes.
+#' 
+#' XiMpLe can't handle DOM specifications yet, but this method can be used to construct
+#' validation schemes.
+#'
+#' @param obj An object of class \code{XiMpLe.doc} or \code{XiMpLe.node}. If \code{parent=NULL}, this object
+#'    will be checked for validity, including its child nodes. If \code{parent} is either a character string
+#'    or another XiMpLe node, it will be checked whether \code{obj} is a valid child node of \code{parent}.
+## TODO: validity class objects
+#' @param validity A list with validity information.
+#' @param parent Either a character string (name of the parent node) or a XiMpLe node, whose name will be used
+#'    as name of the parent node.
+#' @param warn Logical, whether invalid objects should cause a warning or stop with an error.
+#' @param section Either a character string (name of the section) or a XiMpLe node, whose name will be used
+#'    as name of the XML section this check refers to. This is only relevant for warnings and error messages,
+#'    in case you want to use something different than the actual parent node name.
+#' @node.names 
+#' @return Returns \code{TRUE} if tests pass, and depending on the setting of \code{warn} either \code{FALSE} or
+#'    an error if a test fails.
+#' @aliases
+#'    validXML,-methods
+#'    validXML,XiMpLe.doc-method
+#'    validXML,XiMpLe.node-method
+#'    validXML,XiMpLe.XML-method
+#' @seealso  
+#'    \code{\link[XiMpLe:XiMpLe.doc-class]{XiMpLe.doc}}
+#'    \code{\link[XiMpLe:XiMpLe.node-class]{XiMpLe.node}}
+#' @keywords methods
+#' @docType methods
+#' @export
+#' @rdname validXML
+#' @include 00_class_01_XiMpLe.node.R
+#' @include 00_class_02_XiMpLe.doc.R
+setGeneric("validXML", function(obj, validity, parent=NULL, warn=FALSE, section=parent){standardGeneric("validXML")})
+
+#' @rdname validXML
+#' @export
+setMethod("validXML", signature(obj="XiMpLe.XML"), function(obj, validity, parent=NULL, warn=FALSE, section=parent){
+  # see if we're checking the parent node or child node for a given parent
+  if(is.null(parent)){
+    parentName <- XMLName(obj)
+  } else if(is.XiMpLe.node(parent)){
+    parentName <- XMLName(parent)
+  } else if(is.character(parent) & length(parent) == 1){
+    parentName <- parent
+  } else {
+    stop(simpleError("'parent' must be a XiMpLe node or single character string!"))
+  }
+  
+  ## more checks
+  
+  ## call internal when ready valid.child()
+  
+})
diff --git a/packages/XiMpLe/R/XiMpLe-internal.R b/packages/XiMpLe/R/XiMpLe-internal.R
index b0490b5..773ad60 100644
--- a/packages/XiMpLe/R/XiMpLe-internal.R
+++ b/packages/XiMpLe/R/XiMpLe-internal.R
@@ -556,3 +556,49 @@ XML.nodes <- function(single.tags, end.here=NA, start=1){
   }
   return(list(children=children, tag.no=tag.no))
 } ## end function XML.nodes()
+
+
+## function valid.child()
+# - parent: character string, name of the parent node
+# - children: (list of) XiMpLe.node objects, child nodes to check
+# - warn: warning or stop?
+# - section: an optional name for the section for the warning/error
+#   (if it shouldn't be the parent name)
+# - node names: can alternatively be given instead of 'children', as character vector
+valid.child <- function(parent, children, warn=FALSE, section=parent, node.names=NULL){
+  if(is.null(node.names)){
+    # check the node names and allow only valid ones
+    node.names <- unlist(sapply(child.list(children), function(this.child){
+        # if this is a plot options object, by default extract the XML slot
+        # and discard the rest
+        this.child <- stripXML(this.child)
+
+        if(is.XiMpLe.node(this.child)){
+          this.child.name <- XMLName(this.child)
+          if(identical(this.child.name, "")){
+            # special case: empty node name; this is used to combine
+            # comments with the node they belong to, so rather check
+            # the children of this special node
+            return(unlist(sapply(XMLChildren(this.child), XMLName)))
+          } else {
+            return(this.child.name)
+          }
+        } else {
+          stop(simpleError(paste0("Invalid object for ", section, " section, must be of class XiMpLe.node, but got class ", class(this.child), "!")))
+        }
+      }))
+  } else {}
+
+  invalid.sets <- !node.names %in% all.valid.children[[parent]]
+  if(any(invalid.sets)){
+    return.message <- paste0("Invalid XML nodes for ", section, " section: ", paste(node.names[invalid.sets], collapse=", "))
+    if(isTRUE(warn)){
+      warning(return.message)
+      return(FALSE)
+    } else {
+      stop(simpleError(return.message))
+    }
+  } else {
+    return(TRUE)
+  }
+} ## end function valid.child()