Nothing
#' ISOAbstractObject
#'
#' @docType class
#' @importFrom utils packageDescription
#' @importFrom R6 R6Class
#' @importFrom methods is
#' @importFrom methods as
#' @importFrom utils read.csv
#' @import XML
#' @import httr
#' @import readr
#' @import jsonlite
#' @import keyring
#' @import crayon
#' @export
#' @keywords ISO metadata element
#' @return Object of \code{\link{R6Class}} for modelling an ISO Metadata Element
#' @format \code{\link{R6Class}} object.
#'
#' @section Static Methods:
#' \describe{
#' \item{\code{getISOStandardByPrefix(prefix)}}{
#' Inherit the ISO (and/or OGC) standard reference for a given standard prefix (e.g. GMD).
#' The object returned is a \code{data.frame} containing the specification reference
#' and title.
#' }
#' \item{\code{getISOStandard(clazz)}}{
#' Inherit the ISO (and/or OGC) standard reference for a given \pkg{geometa} class.
#' The object returned is a \code{data.frame} containing the specification reference
#' and title.
#' }
#' \item{\code{getISOClasses(extended, pretty)}}{
#' Get the list of classes supported by \pkg{geometa}. By default, \code{extended} is
#' set to \code{FALSE} (restrained to \pkg{geometa} environment). If \code{TRUE}, this
#' allows to list eventual classes loaded in your global environment and that extend
#' \pkg{geometa} classes. The argument \code{pretty} gives a the list of classes and
#' associated ISO/OGC standard information as \code{data.frame}.
#' }
#' \item{\code{getISOClassByNode(node)}}{
#' Inherit the ISO class matching an XML document or node
#' }
#' \item{\code{compare(metadataElement1, metadataElement2)}}{
#' Compares two metadata elements objects. Returns TRUE if they are equal,
#' FALSE otherwise. The comparison of object is done by comparing the XML
#' representation of the objects (since no R6 object comparison method seems
#' to exist)
#' }
#' }
#'
#' @note Abstract ISO Metadata class used internally by geometa
#'
#' @author Emmanuel Blondel <emmanuel.blondel1@@gmail.com>
#'
ISOAbstractObject <- R6Class("ISOAbstractObject",
inherit = geometaLogger,
cloneable = FALSE,
private = list(
xmlElement = "AbstractObject",
xmlNamespacePrefix = "GCO",
encoding = options("encoding"),
document = FALSE,
system_fields = c("wrap", "value_as_field", "valueDescription",
"element", "namespace", "defaults", "attrs", "printAttrs", "parentAttrs",
"codelistId", "measureType", "isNull", "anyElement"),
xmlComments = function(isoCompliant = NA, inspireReport = NULL){
comments <- list()
geometa <- packageDescription("geometa")
title <- paste0("ISO 19139 XML generated by geometa R package - Version ", geometa$Version)
isISOCompliant <- ifelse(is.na(isoCompliant),"NOT TESTED", ifelse(isoCompliant, "YES", "NO"))
ISOCompliance <- paste0("ISO 19139 XML compliance: ", isISOCompliant)
isINSPIRECompliant <- ifelse(is.null(inspireReport), "NOT TESTED", ifelse(inspireReport$Status=="PASSED", "YES", "NO"))
INSPIRECompliance <- paste0("INSPIRE compliance: ", isINSPIRECompliant)
createdOn <- paste0("Metadata Creation date/time: ", format(Sys.time(), "%Y-%m-%dT%H:%M:%S"))
geometaAuthor <- gsub(">","",gsub("<","",unlist(strsplit(as.character(eval(parse(text=geometa$Authors)))," \\["))[1]))
author <- paste0("\tContact: ", geometaAuthor)
infoPage <- paste0("\tURL: ", geometa$URL)
bugReport <- paste0("\tBugReports: ", geometa$BugReports)
idx <- 1
comments[[idx]] <- createdOn; idx <- idx+1
comments[[idx]] <- title; idx <- idx+1
comments[[idx]] <- ISOCompliance; idx <- idx+1
if(!is.null(inspireReport)){
comments[[idx]] <- INSPIRECompliance; idx <- idx+1
for(inspireAttr in names(inspireReport)){
if(!(inspireAttr %in% c("raw", "status"))){
comments[[idx]] <- sprintf("INSPIRE %s : %s", inspireAttr, inspireReport[[inspireAttr]])
idx <- idx+1
}
}
}
comments[[idx]] <- paste("geometa R package information:", author, infoPage, bugReport, sep="\n")
return(comments)
},
toComplexTypes = function(value){
newvalue <- value
#datetime types
if(regexpr(pattern = "^(\\d{4})-(\\d{2})-(\\d{2})T(\\d{2}):(\\d{2}):(\\d{2})", value)>0){
if(endsWith(value, "Z")){
newvalue <- as.POSIXct(strptime(value, "%Y-%m-%dT%H:%M:%S"), tz = "UTC")
}else{
if(regexpr(pattern = "[[:space:]]", value)){
splits <- unlist(strsplit(value, " "))
value <- splits[1]
#TODO find a way to fetch "tzone" attribute -not solved for now
newvalue <- as.POSIXct(strptime(value, "%Y-%m-%dT%H:%M:%S"), tz = "")
}else{
newvalue <- as.POSIXct(strptime(value, "%Y-%m-%dT%H:%M:%S"), tz = "")
}
}
}else if(regexpr(pattern = "^(\\d{4})-(\\d{2})-(\\d{2})$", value)>0){
newvalue <- as.Date(as.POSIXct(strptime(value, "%Y-%m-%d"), tz = "UTC"))
}
return(newvalue)
},
fromComplexTypes = function(value){
#datetime types
if(suppressWarnings(all(class(value)==c("POSIXct","POSIXt")))){
tz <- attr(value, "tzone")
if(length(tz)>1){
if(tz %in% c("UTC","GMT")){
value <- format(value,"%Y-%m-%dT%H:%M:%S")
value <- paste0(value,"Z")
}else{
utc_offset <- format(value, "%z")
utc_offset <- paste0(substr(utc_offset,1,3),":",substr(utc_offset,4,5))
value <- paste0(format(value,"%Y-%m-%dT%H:%M:%S"), utc_offset)
}
}else{
value <- format(value,"%Y-%m-%dT%H:%M:%S")
}
}else if(class(value)[1] == "Date"){
value <- format(value,"%Y-%m-%d")
}
return(value)
},
xmlNodeToCharacter = function (x, ..., indent = "", tagSeparator = "\n")
{
out <- ""
if (length(xmlAttrs(x))) {
tmp <- paste(names(xmlAttrs(x)), paste("\"", XML:::insertEntities(xmlAttrs(x)),
"\"", sep = ""), sep = "=", collapse = " ")
} else{
tmp <- ""
}
if (length(x$namespaceDefinitions) > 0) {
k = as(x$namespaceDefinitions, "character")
ns = paste("xmlns", ifelse(nchar(names(k)), ":", ""),
names(k), "=", ddQuote(k), sep = "", collapse = " ")
} else{
ns <- ""
}
subIndent <- paste(indent, " ", sep = "")
if (is.logical(indent) && !indent) {
indent <- ""
subIndent <- FALSE
}
if (length(xmlChildren(x)) == 0) {
out <- paste(out,indent, paste("<", xmlName(x, TRUE), ifelse(tmp !=
"", " ", ""), tmp, ifelse(ns != "", " ", ""), ns,
"/>", tagSeparator, sep = ""), sep = "")
} else if (length(xmlChildren(x)) == 1 && inherits(xmlChildren(x)[[1]], "XMLTextNode")) {
out <- paste(out,indent, paste("<", xmlName(x, TRUE), ifelse(tmp !=
"", " ", ""), tmp, ifelse(ns != "", " ", ""), ns,
">", sep = ""), sep = "")
kid = xmlChildren(x)[[1]]
if (inherits(kid, "EntitiesEscaped"))
txt = xmlValue(kid)
else txt = XML:::insertEntities(xmlValue(kid))
out <- paste(out,txt, sep = "")
out <- paste(out,paste("</", xmlName(x, TRUE), ">", tagSeparator,
sep = ""), sep = "")
} else {
out <- paste(out,indent, paste("<", xmlName(x, TRUE), ifelse(tmp !=
"", " ", ""), tmp, ifelse(ns != "", " ", ""), ns,
">", tagSeparator, sep = ""), sep = "")
for (i in xmlChildren(x)){
out_child <- NULL
if(is(i,"XMLNode")){
if(is(i,"XMLCommentNode")){
out_child <- paste0(capture.output(i),collapse="")
}else{
out_child <- private$xmlNodeToCharacter(i)
}
}else{
out_child <- paste(as(i,"character"),tagSeparator,sep="")
}
if(!is.null(out_child)) out <- paste(out, out_child, sep="")
}
out<-paste(out,indent, paste("</", xmlName(x, TRUE), ">", tagSeparator,
sep = ""), sep = "")
}
return(out)
}
),
public = list(
#fields
#---------------------------------------------------------------------------
#'@field wrap wrap
wrap = TRUE,
#'@field element element
element = NA,
#'@field namespace namespace
namespace = NA,
#'@field defaults defaults
defaults = list(),
#'@field attrs attributes
attrs = list(),
#'@field printAttrs attributes to print
printAttrs = list(),
#'@field parentAttrs parent attributes
parentAttrs = NULL,
#'@field value value
value = NULL,
#'@field value_as_field value as field?
value_as_field = FALSE,
#'@field isNull is null?
isNull = FALSE,
#'@field anyElement any element?
anyElement = FALSE,
#'@description Initializes object
#'@param xml object of class \link{XMLInternalNode-class}
#'@param element element name
#'@param namespace namespace
#'@param attrs attrs
#'@param defaults defaults
#'@param wrap wrap?
#'@param value_as_field value as field?
initialize = function(xml = NULL, element = NULL, namespace = NULL,
attrs = list(), defaults = list(),
wrap = TRUE, value_as_field = FALSE){
if(!is.null(element)){ private$xmlElement <- element }
if(!is.null(namespace)){ private$xmlNamespacePrefix <- toupper(namespace)}
self$element = private$xmlElement
self$namespace = getISOMetadataNamespace(private$xmlNamespacePrefix)
self$attrs = attrs
self$defaults = defaults
self$wrap = wrap
self$value_as_field = value_as_field
if(!is.null(xml)){
self$decode(xml)
}
},
#Main methods
#---------------------------------------------------------------------------
#'@description Provides a custom print output (as tree) of the current class
#'@param ... args
#'@param depth class nesting depth
#'@param add_codelist_description Add codelist description. Default is \code{TRUE}
print = function(..., depth = 1, add_codelist_description = TRUE){
#list of fields to encode as XML
fields <- rev(names(self))
#fields
fields <- fields[!sapply(fields, function(x){
(class(self[[x]])[1] %in% c("environment", "function")) ||
(x %in% private$system_fields)
})]
if(!inherits(self, "GMLElement") && !inherits(self, "SWEElement")) cat(crayon::white(paste0("<", crayon::underline(self$getClassName()), ">")))
if(is(self, "ISOCodeListValue")){
clVal <- self$printAttrs$codeListValue
clDes <- self$codelistId$entries[self$codelistId$entries$value == clVal,"description"]
if(length(clDes)==0){
clDes <- self$valueDescription
}
cat(paste0(": ", clVal, if(add_codelist_description) crayon::cyan(paste0(" {",clDes,"}")) else ""))
}
for(field in fields){
fieldObj <- self[[field]]
#default values management
if(is.null(fieldObj) || (is.list(fieldObj) & length(fieldObj)==0)){
if(field %in% names(self$defaults)){
fieldObj <- self$defaults[[field]]
}
}
print_attrs <- function(obj){
paste(
sapply(names(obj$attrs), function(attrName){
paste0( crayon::magenta(attrName,"=",sep=""), crayon::green(obj$attrs[[attrName]]))
}
),
collapse=",")
}
#user values management
shift <- "...."
if(!is.null(fieldObj)){
if(is(fieldObj, "ISOAbstractObject")){
attrs_str <- ""
if(length(fieldObj$attrs)>0){
attrs <- print_attrs(fieldObj)
attrs_str <- paste0(" [",attrs,"] ")
}
cat(paste0("\n", paste(rep(shift, depth), collapse=""),"|-- ", crayon::italic(field), " ", attrs_str))
fieldObj$print(depth = depth+1, add_codelist_description = add_codelist_description)
}else if(is(fieldObj, "ISOAttributes")){
attrs <- print_attrs(fieldObj)
cat(paste0("\n",paste(rep(shift, depth), collapse=""),"|-- ", crayon::italic(field), " [",attrs,"]"))
}else if(is(fieldObj, "list")){
for(item in fieldObj){
if(is(item, "ISOAbstractObject")){
attrs_str <- ""
if(length(item$attrs)>0){
attrs <- print_attrs(item)
attrs_str <- paste0(" [",attrs,"] ")
}
cat(paste0("\n", paste(rep(shift, depth), collapse=""),"|-- ", crayon::italic(field), " ", attrs_str))
item$print(depth = depth+1, add_codelist_description = add_codelist_description)
if(is(item, "ISOCodeListValue")){
clVal <- item$printAttrs$codeListValue
clDes <- item$codelistId$entries[item$codelistId$entries$value == clVal,"description"]
cat(paste0(": ", clVal, if(add_codelist_description) crayon::cyan(paste0(" {",clDes,"}")) else ""))
}
}else if(is(item, "ISOAttributes")){
attrs <- print_attrs(item)
cat(paste0("\n",paste(rep(shift, depth), collapse=""),"|-- ", crayon::italic(field), " [",attrs,"]"))
}else if(is(item, "matrix")){
m <- paste(apply(item, 1L, function(x){
x <- lapply(x, function(el){
if(is.na(suppressWarnings(as.numeric(el))) & !all(sapply(item,class)=="character")){
el <- paste0("\"",el,"\"")
}else{
if(!is.na(suppressWarnings(as.numeric(el)))){
el <- as.numeric(el)
}
}
return(el)
})
return(paste(x, collapse = " "))
}), collapse = " ")
cat(paste0("\n",paste(rep(shift, depth), collapse=""),"|-- ", crayon::italic(field), ": ", crayon::bgWhite(m)))
}else{
cat(paste0("\n", paste(rep(shift, depth), collapse=""),"|-- ", crayon::italic(field), ": ", crayon::bgWhite(item)))
}
}
}else if (is(fieldObj,"matrix")){
m <- paste(apply(fieldObj, 1L, function(x){
x <- lapply(x, function(el){
if(is.na(suppressWarnings(as.numeric(el)))& !all(sapply(fieldObj,class)=="character")){
el <- paste0("\"",el,"\"")
}else{
if(!is.na(suppressWarnings(as.numeric(el)))){
el <- as.numeric(el)
}
}
return(el)
})
return(paste(x, collapse = " "))
}), collapse = " ")
cat(paste0("\n",paste(rep(shift, depth), collapse=""),"|-- ", crayon::italic(field), ": ", crayon::bgWhite(m)))
}else{
fieldObjP <- fieldObj
if(is(fieldObjP,"Date")|is(fieldObjP, "POSIXt")){
fieldObjP <- private$fromComplexTypes(fieldObjP)
}
cat(paste0("\n",paste(rep(shift, depth), collapse=""),"|-- ", crayon::italic(field), ": ", crayon::bgWhite(fieldObjP)))
}
}
}
invisible(self)
},
#'@description Decodes object from XML
#'@param xml object of class \link{XMLInternalNode-class}
decode = function(xml){
#remove comments if any (in case of document)
if(is(xml, "XMLInternalDocument")){
children <- xmlChildren(xml, encoding = private$encoding, addFinalizer = FALSE)
xml <- children[names(children) != "comment"][[1]]
}
xml_children <- xmlChildren(xml, encoding = private$encoding, addFinalizer = FALSE)
for(child in xml_children){
fieldName <- xmlName(child)
childElement <- child
nsPrefix <- ""
fNames <- unlist(strsplit(fieldName, ":"))
if(length(fNames)>1){
fieldName <- fNames[2]
}
if(!is(self, "ISOElementSequence")) {
if(!(fieldName %in% names(self)) & fieldName != "text" & !self$anyElement) next
}
wrap_fields <- FALSE
fieldClass <- NULL
parentAttrs <- NULL
if(!is(child, "XMLInternalTextNode")){
fieldClass <- ISOAbstractObject$getISOClassByNode(child)
nsPrefix <- names(xmlNamespace(child))
if(is.null(nsPrefix)){
#try to grab from ns prefix
childName <- xmlName(child, full = TRUE)
preftag <- unlist(strsplit(as(childName, "character"),":"))[1]
if(preftag!=childName) nsPrefix <- substring(preftag, 2, nchar(preftag))
}
if(is.null(fieldClass)){
parentAttrs <- as.list(xmlAttrs(child, TRUE, FALSE))
if(length(parentAttrs)>0) parentAttrs <- parentAttrs[names(parentAttrs) != "xsi:type"]
if(length(parentAttrs)==0) parentAttrs <- NULL
children <- xmlChildren(child, encoding = private$encoding, addFinalizer = FALSE)
if(length(children)>0){
if(length(children)==1){
childroot <- children[[1]]
if(!is(childroot, "XMLInternalTextNode")){
child <- childroot
fieldClass <- ISOAbstractObject$getISOClassByNode(childroot)
}
}else{
#more than one child, consider it as sequence
fieldClass <- ISOElementSequence
}
}else{
#if xlink:href attr available attempt to
#href <- xmlGetAttr(child, "xlink:href")
#if(!is.null(href)){
# self$INFO(sprintf("Fetching child element from xlink:href attribute '%s'", href))
# childXML <- try(XML::xmlParse(href))
# if(!is(childXML,"try-error")){
# child <- XML::xmlRoot(childXML)
# fieldClass <- ISOAbstractObject$getISOClassByNode(child)
# }
#}
}
if(!is.null(fieldClass)) wrap_fields <- TRUE
}
}
#coercing
fieldValue <- xmlValue(child, recursive = FALSE)
if(length(fieldValue)>0){
fieldValue <- private$toComplexTypes(fieldValue)
}
if(!is.null(fieldClass)){
if(regexpr("^ISOBase.+", fieldClass$classname)>0){
fieldValue <- switch(fieldClass$classname,
"ISOBaseBoolean" = as.logical(fieldValue),
"ISOBaseInteger" = as.integer(fieldValue),
"ISOBaseReal" = as.numeric(fieldValue),
"ISOBaseDecimal" = {
fieldValue <- as.numeric(fieldValue)
class(fieldValue) <- "decimal"
fieldValue
},
fieldValue
)
if(length(fieldValue)==0) fieldValue = NA
}else{
fieldValue <- fieldClass$new(xml = child)
fieldValue$parentAttrs <- parentAttrs
attrs <- as.list(xmlAttrs(child, TRUE, FALSE))
if(length(attrs)>0) attrs <- attrs[attrs != "gmd:PT_FreeText_PropertyType"]
fieldValue$attrs <- attrs
}
if(is(self[[fieldName]], "list")){
self[[fieldName]] <- c(self[[fieldName]], fieldValue)
}else{
if(is(self, "ISOElementSequence")){
if(!wrap_fields){
#means no wrapping of ElementSequence fields
self[["_internal_"]] <- c(self[["_internal_"]], fieldValue)
}else{
self[[fieldName]] <- fieldValue
}
}else{
self[[fieldName]] <- fieldValue
}
}
}else{
if(is.null(nsPrefix)) nsPrefix <- ""
if(startsWith(nsPrefix,"gml") |inherits(self, "GMLAbstractObject")){
if(is(self[[fieldName]], "matrix") &
(inherits(self,"GMLAbstractRing")|
inherits(self,"GMLAbstractGeometricPrimitive")|
inherits(self,"GMLEnvelope")|
inherits(self,"GMLGridEnvelope")|
inherits(self,"GMLGeneralGridAxis"))){
value <- xmlValue(child)
if(value=="") value <- NA
if(!is.na(value)){
value_split <- unlist(strsplit(value," "))
coercable <- !suppressWarnings(is.na(as.numeric(value_split)))
values <- lapply(1:length(value_split), function(i){
out <- value_split[i]
if(coercable[i]) out <- as.numeric(out)
return(out)
})
if(all(!is.na(values)) & length(values)>1){
values <- lapply(values, function(x){if(is.character(x)){x <- gsub("\"","",x)};x})
if(is(self,"GMLEnvelope")){
m.values <- t(matrix(values))
}else{
dimension <- xmlGetAttr(xml, "srsDimension")
if(!is.null(dimension)) dimension <- as.integer(dimension)
if(is.null(dimension)){
dimension <- 1
if(inherits(self,"GMLAbstractGeometricPrimitive")){
if(is(self, "GMLPoint")){
dimension <- length(values)
}else{
self$WARN("No 'srsDimension' on geometry object. Impossible to decode coordinates!")
}
}
}
m.values <- matrix(values, length(values)/dimension, dimension, byrow = TRUE)
}
if(is(self[[fieldName]], "list")){
self[[fieldName]] <- c(self[[fieldName]], m.values)
}else{
self[[fieldName]] <- m.values
}
}
}else{
#xmlNamespacePrefix <- "GML"
xmlNamespacePrefix <- self$getClass()$private_fields$xmlNamespacePrefix
if(startsWith(nsPrefix,"gml")) xmlNamespacePrefix <- toupper(nsPrefix)
if(is.null(xmlNamespacePrefix)) xmlNamespacePrefix <- "GML"
gmlElem <- GMLElement$new(element = fieldName, xmlNamespacePrefix = xmlNamespacePrefix)
gmlElem$decode(xml = childElement)
if(is(self[[fieldName]], "list")){
self[[fieldName]] <- c(self[[fieldName]], gmlElem)
}else{
self[[fieldName]] <- gmlElem
}
}
}else{
#xmlNamespacePrefix <- "GML"
#if(startsWith(nsPrefix,"gml")) xmlNamespacePrefix <- toupper(nsPrefix)
xmlNamespacePrefix <- self$getClass()$private_fields$xmlNamespacePrefix
if(startsWith(nsPrefix,"gml")) xmlNamespacePrefix <- toupper(nsPrefix)
if(is.null(xmlNamespacePrefix)) xmlNamespacePrefix <- "GML"
gmlElem <- GMLElement$new(element = fieldName, xmlNamespacePrefix = xmlNamespacePrefix)
gmlElem$decode(xml = childElement)
if(is(self[[fieldName]], "list")){
self[[fieldName]] <- c(self[[fieldName]], gmlElem)
}else{
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]])
if(value==""){
value <- ifelse(isList, list(), NA)
attrs <- xmlAttrs(child)
if(!is.null(attrs)){
attrNs <- attr(attrs,"namespaces")
if(!is.null(attrNs)){
attr(attrs,"namespaces") <- NULL
names(attrs) <- paste(attrNs, names(attrs), sep=":")
#control mal-formed attributes (starting with :)
names(attrs) <- lapply(names(attrs), function(x){
out <- x
if(startsWith(x,":")) out <- substr(x, 2, nchar(x))
return(out)
})
}
if(length(attrs)==1 && names(attrs)== "gco:nilReason"){
#if only gco:nilReason attribute we resolve value as NA
value <- NA
}else{
#if others attributes we keep them
value <- ISOAttributes$new(attrs[names(attrs)!="gco:nilReason"])
}
}
}
if(fieldName == "text") fieldName <- "value"
self[[fieldName]] <- if(is.list(self[[fieldName]])) c(self[[fieldName]], value) else value
}
}
}
#inherit attributes if any
xmlattrs <- NULL
if(!self$isDocument()) xmlattrs <- xmlAttrs(xml, TRUE, FALSE)
if(is(self, "ISOFeatureCatalogue")){
xmlattrs <- xmlAttrs(xml, TRUE, FALSE)
if("uuid" %in% names(xmlattrs)){
xmlattrs <- xmlattrs[names(xmlattrs)=="uuid"]
}
}
attrs <- as.list(xmlattrs)
if(length(attrs)>0) attrs <- attrs[attrs != "gmd:PT_FreeText_PropertyType"]
self$attrs <- attrs
if("gco:nilReason" %in% names(xmlattrs)) self$isNull <- TRUE
},
#'@description Encodes object as XML.
#'
#' 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}.
#'
#' 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).
#'
#' Setting \code{inspire} to TRUE (default FALSE), the metadata will be checked with
#' the INSPIRE metadata validator (online web-service provided by INSPIRE). To check
#' metadata with the INSPIRE metadata validator, setting an INSPIRE metadata validator
#' is now required, and should be specified with the \code{inspireValidator}. See
#' \code{\link{INSPIREMetadataValidator}} for more details
#'
#'@param addNS add namespace? Default is \code{TRUE}
#'@param validate validate XML output against schemas?
#'@param strict strict validation? Default is \code{FALSE}.
#'@param inspire perform INSPIRE validation? Default is \code{FALSE}
#'@param inspireValidator an object of class \link{INSPIREMetadataValidator} to perform INSPIRE metadata validation
#'@param resetSerialID reset Serial ID? Default is \code{TRUE}
#'@param setSerialID set serial ID? Default is \code{TRUE}
#'@param encoding encoding. Default is \code{UTF-8}
encode = function(addNS = TRUE, validate = TRUE, strict = FALSE, inspire = FALSE, inspireValidator = NULL,
resetSerialID = TRUE, setSerialID = TRUE,
encoding = "UTF-8"){
#management of GML ids
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
}
}
}
#list of fields to encode as XML
fields <- rev(names(self))
#root XML
rootXML <- NULL
rootXMLAttrs <- list()
if("attrs" %in% fields){
rootXMLAttrs <- self[["attrs"]]
rootXMLAttrs <- rootXMLAttrs[!is.na(rootXMLAttrs)]
}
freeTextAttr <- list("xsi:type" = "gmd:PT_FreeText_PropertyType")
#fields
fields <- fields[!sapply(fields, function(x){
(class(self[[x]])[1] %in% c("environment", "function")) ||
(x %in% private$system_fields)
})]
if(self$isDocument()){
rootNamespaces <- sapply(getISOMetadataNamespaces(), function(x){x$getDefinition()})
rootXML <- xmlOutputDOM(
tag = self$element,
nameSpace = self$namespace$id,
nsURI = rootNamespaces
)
}else{
wrapperAttrs <- self$attrs
if(self$isNull){
wrapperAttrs <- self$attrs
if(length(wrapperAttrs)>1) wrapperAttrs <- wrapperAttrs[names(wrapperAttrs)!="gco:nilReason"]
}
if(addNS){
nsdefs <- self$getNamespaceDefinition(recursive = TRUE)
if(!("xsi" %in% names(nsdefs))) nsdefs <- c(nsdefs, ISOMetadataNamespace$XSI$getDefinition())
if(!("xlink" %in% names(nsdefs))) nsdefs <- c(nsdefs, ISOMetadataNamespace$XLINK$getDefinition())
nsdefs <- nsdefs[order(names(nsdefs))]
rootXML <- xmlOutputDOM(
tag = self$element,
nameSpace = self$namespace$id,
nsURI = nsdefs,
attrs = wrapperAttrs
)
}else{
rootXML <- xmlOutputDOM(
tag = self$element,
nameSpace = self$namespace$id,
attrs = wrapperAttrs
)
}
}
if(!self$isNull) for(field in fields){
fieldObj <- self[[field]]
#default values management
if(is.null(fieldObj) || (is.list(fieldObj) & length(fieldObj)==0)){
if(field %in% names(self$defaults)){
fieldObj <- self$defaults[[field]]
}
}
#user values management
ns <- self$namespace$getDefinition()
if(field != "value"){
klass <- self$isFieldInheritedFrom(field)
if(!is.null(klass)){
ns <- ISOMetadataNamespace[[klass$private_fields$xmlNamespacePrefix]]$getDefinition()
}
}
namespaceId <- names(ns)
if(!is.null(fieldObj)){
if(is(fieldObj, "ISOAbstractObject")){
fieldObjXml <- fieldObj$encode(addNS = FALSE, validate = FALSE,
resetSerialID = FALSE, setSerialID = setSerialID)
if(is(fieldObj, "ISOElementSequence")){
fieldObjXml.children <- xmlChildren(fieldObjXml, addFinalizer = FALSE)
hasLocales <- FALSE
if(!is.null(fieldObj[["_internal_"]])){
if(any(sapply(fieldObj[["_internal_"]],function(x){class(x)[1]})=="ISOFreeText")){
hasLocales <- TRUE
}
}
if(self$wrap){
wrapperAttrs <- self$parentAttrs
if(hasLocales) wrapperAttrs <- c(wrapperAttrs, freeTextAttr)
wrapperNode <- xmlOutputDOM(
tag = field,
nameSpace = namespaceId,
attrs = wrapperAttrs
)
for(child in fieldObjXml.children){
wrapperNode$addNode(child)
}
rootXML$addNode(wrapperNode$value())
}else{
if(hasLocales && !("xsi:type" %in% names(rootXMLAttrs))) rootXMLAttrs <- c(rootXMLAttrs, freeTextAttr)
for(child in fieldObjXml.children){
rootXML$addNode(child)
}
}
#fieldObjNames <- names(fieldObj)
#fieldObjNames <- fieldObjNames[sapply(fieldObjNames, function(name){
# return(which(fieldObjNames == name) < which(fieldObjNames == ".__enclos_env__"))
#})]
}else{
if(fieldObj$wrap){
wrapperAttrs <- fieldObj$parentAttrs
if(fieldObj$isNull){
wrapperAttrs <- fieldObj$attrs
if(length(wrapperAttrs)>1) wrapperAttrs <- wrapperAttrs[names(wrapperAttrs)!="gco:nilReason"]
}
wrapperNode <- xmlOutputDOM(
tag = field,
nameSpace = namespaceId,
attrs = wrapperAttrs
)
if(!fieldObj$isNull) wrapperNode$addNode(fieldObjXml)
rootXML$addNode(wrapperNode$value())
}else{
rootXML$addNode(fieldObjXml)
}
}
}else if(is(fieldObj, "list")){
for(item in fieldObj){
nodeValue <- NULL
if(length(item)==0) item <- NA
if(is(item, "ISOAttributes")){
emptyNodeAttrs <- item$attrs
emptyNode <- xmlOutputDOM(tag = field,nameSpace = namespaceId, attrs = emptyNodeAttrs)
rootXML$addNode(emptyNode$value())
}else if(suppressWarnings(all(is.na(item)))){
emptyNodeAttrs <- c("gco:nilReason" = "missing")
emptyNode <- xmlOutputDOM(tag = field,nameSpace = namespaceId, attrs = emptyNodeAttrs)
rootXML$addNode(emptyNode$value())
}else if(is(item, "matrix")){
matrix_NA <- all(is.na(item))
if(matrix_NA){
emptyNode <- xmlOutputDOM(tag = field,nameSpace = namespaceId)
rootXML$addNode(emptyNode$value())
}else{
mts <- paste(apply(item, 1L, function(x){
x <- lapply(x, function(el){
if(!is.na(suppressWarnings(as.numeric(el)))){
el <- as.numeric(el)
}
return(el)
})
x <- lapply(x, function(el){
if(is.na(suppressWarnings(as.numeric(el))) & !all(sapply(x,class)=="character")){
el <- paste0("\"",el,"\"")
}
return(el)
})
return(paste(x, collapse = " "))
}), collapse = " ")
txtNode <- xmlTextNode(mts)
if(field == "value"){
rootXML$addNode(txtNode)
}else{
wrapperNode <- xmlOutputDOM(tag = field, nameSpace = namespaceId)
wrapperNode$addNode(txtNode)
rootXML$addNode(wrapperNode$value())
}
}
}else{
if(is(item, "ISOAbstractObject")){
nodeValue <- item
}else{
nodeValue <- self$wrapBaseElement(field, item)
}
nodeValueXml <- nodeValue$encode(addNS = FALSE, validate = FALSE,
resetSerialID = FALSE, setSerialID = setSerialID)
if(is(item, "ISOElementSequence")){
nodeValueXml.children <- xmlChildren(nodeValueXml, addFinalizer = FALSE)
hasLocales <- FALSE
if(!is.null(item[["_internal_"]])){
if(any(sapply(item[["_internal_"]],function(x){class(x)[1]})=="ISOFreeText")){
hasLocales <- TRUE
}
}
if(nodeValue$wrap){
wrapperAttrs <- nodeValue$parentAttrs
if(nodeValue$isNull){
wrapperAttrs <- nodeValue$attrs
if(length(wrapperAttrs)>1) wrapperAttrs <- wrapperAttrs[names(wrapperAttrs)!="gco:nilReason"]
}
wrapperAttrs <- c(wrapperAttrs,freeTextAttr)
wrapperNode <- xmlOutputDOM(tag = field,nameSpace = namespaceId, attrs = wrapperAttrs)
if(!nodeValue$isNull){
for(child in nodeValueXml.children){
wrapperNode$addNode(child)
}
}
rootXML$addNode(wrapperNode$value())
}else{
if(hasLocales && !("xsi:type" %in% names(rootXMLAttrs))) rootXMLAttrs <- c(rootXMLAttrs, freeTextAttr)
for(child in nodeValueXml.children){
rootXML$addNode(child)
}
}
}else{
if(nodeValue$wrap && field != "_internal_"){
wrapperAttrs <- nodeValue$parentAttrs
if(nodeValue$isNull){
wrapperAttrs <- nodeValue$attrs
if(length(wrapperAttrs)>1) wrapperAttrs <- wrapperAttrs[names(wrapperAttrs)!="gco:nilReason"]
}
wrapperNode <- xmlOutputDOM(
tag = field,
nameSpace = namespaceId,
attrs = wrapperAttrs
)
if(!nodeValue$isNull) wrapperNode$addNode(nodeValueXml)
rootXML$addNode(wrapperNode$value())
}else{
rootXML$addNode(nodeValueXml)
}
}
}
}
}else if(is(fieldObj, "matrix")){
matrix_NA <- all(is.na(fieldObj))
if(matrix_NA){
emptyNode <- xmlOutputDOM(tag = field,nameSpace = namespaceId)
rootXML$addNode(emptyNode$value())
}else{
mts <- paste(apply(fieldObj, 1L, function(x){
x <- lapply(x, function(el){
if(!is.na(suppressWarnings(as.numeric(el)))){
el <- as.numeric(el)
}
return(el)
})
x <- lapply(x, function(el){
if(is.na(suppressWarnings(as.numeric(el))) & !all(sapply(x,class)=="character")){
el <- paste0("\"",el,"\"")
}
return(el)
})
return(paste(x, collapse = " "))
}), collapse = " ")
txtNode <- xmlTextNode(mts)
if(field == "value"){
if(field == "value" && self$value_as_field){
wrapperNode <- xmlOutputDOM(
tag = field,
nameSpace = namespaceId
)
wrapperNode$addNode(txtNode)
rootXML$addNode(wrapperNode$value())
}else{
rootXML$addNode(txtNode)
}
}else{
wrapperNode <- xmlOutputDOM(tag = field, nameSpace = namespaceId)
wrapperNode$addNode(txtNode)
rootXML$addNode(wrapperNode$value())
}
}
}else{
if(length(fieldObj)==0) fieldObj <- NA
if(is(fieldObj, "ISOAttributes")){
emptyNodeAttrs <- fieldObj$attrs
emptyNode <- xmlOutputDOM(tag = field,nameSpace = namespaceId, attrs = emptyNodeAttrs)
rootXML$addNode(emptyNode$value())
}else if(is.na(fieldObj)){
emptyNodeAttrs <- c("gco:nilReason" = "missing")
emptyNode <- xmlOutputDOM(tag = field,nameSpace = namespaceId, attrs = emptyNodeAttrs)
rootXML$addNode(emptyNode$value())
}else{
if((field == "value"|| field == "_internal_")){
if(is.logical(fieldObj)) fieldObj <- tolower(as.character(is.logical(fieldObj)))
fieldObj <- private$fromComplexTypes(fieldObj)
if(field == "value" && self$value_as_field){
wrapperNode <- xmlOutputDOM(
tag = field,
nameSpace = namespaceId
)
wrapperNode$addNode(xmlTextNode(fieldObj))
rootXML$addNode(wrapperNode$value())
}else{
rootXML$addNode(xmlTextNode(fieldObj))
}
}else{
dataObj <- self$wrapBaseElement(field, fieldObj)
if(!is.null(dataObj)){
if(dataObj$wrap){
#general case of gco wrapper element
wrapperNode <- xmlOutputDOM(
tag = field,
nameSpace = namespaceId
)
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,
resetSerialID = FALSE, setSerialID = setSerialID))
}
}
}
}
}
}
}
#toXML (required for validation)
out <- rootXML$value()
out <- private$xmlNodeToCharacter(out)
if(Encoding(out)!="UTF-8") out <- iconv(out, to = "UTF-8")
out <- xmlParse(out, encoding = Encoding(out), error = function (msg, ...) {})
out <- as(out, "XMLInternalNode") #to XMLInternalNode
if(length(rootXMLAttrs)>0){
suppressWarnings(xmlAttrs(out) <- rootXMLAttrs)
}
#validation vs. ISO 19139 XML schemas + eventually INSPIRE
compliant <- NA
if(validate){
compliant <- self$validate(xml = out, strict = strict, inspire = inspire, inspireValidator = inspireValidator)
}
if(self$isDocument()){
if(!inspire){
header_comments <- private$xmlComments(compliant)
}else{
if(is.list(compliant)){
header_comments <- private$xmlComments(compliant$ISO, compliant$INSPIRE)
}else{
header_comments <- private$xmlComments(compliant)
}
}
#process XML comments
for(comment in header_comments){
rootXML$addNode(xmlCommentNode(comment))
}
#toXML (regeneration with comments)
out <- rootXML$value()
out <- private$xmlNodeToCharacter(out)
if(Encoding(out)!="UTF-8") out <- iconv(out, to = "UTF-8")
out <- xmlParse(out, encoding = Encoding(out), error = function (msg, ...) {})
out <- as(out, "XMLInternalNode") #to XMLInternalNode
if(length(rootXMLAttrs)>0){
suppressWarnings(xmlAttrs(out) <- rootXMLAttrs)
}
}
return(out)
},
#'@description Validates an XML object resulting from object encoding
#'@param xml object of class \link{XMLInternalNode-class}
#'@param strict strict validation? If \code{TRUE}, a invalid XML will return an error
#'@param inspire perform INSPIRE validation? Default is \code{FALSE}
#'@param inspireValidator an object of class \link{INSPIREMetadataValidator} to perform INSPIRE metadata validation
#'@return \code{TRUE} if valid, \code{FALSE} otherwise
validate = function(xml = NULL, strict = FALSE, inspire = FALSE, inspireValidator = NULL){
#xml
schemaNamespaceId <- NULL
if(is.null(xml)){
schemaNamespaceId <- self$namespace$id
xml <- self$encode(addNS = TRUE, validate = FALSE, strict = strict)
}else{
#remove comments if any
content <- as(xml, "character")
content <- gsub("<!--.*?-->", "", content)
xml <- xmlParse(content, encoding = private$encoding)
schemaNamespaceId <- names(xmlNamespace(xmlRoot(xml)))
}
#proceed with schema xml schema validation
xsd <- getISOMetadataSchemas()
if(is(xml, "XMLInternalNode")) xml <- xmlDoc(xml)
report <- xmlSchemaValidate(xsd, xml)
#check validity on self
isValid <- report$status == 0
if(!isValid){
loggerType <- ifelse(strict, "ERROR", "WARN")
for(error in report$errors){
errorMsg <- paste0(substr(error$msg, 1, nchar(error$msg)-2), " at line ", error$line, ".")
self[[loggerType]](errorMsg)
}
msg <- sprintf("Object '%s' is INVALID according to ISO 19139 XML schemas!", self$getClassName())
if(strict){
self$ERROR(msg)
stop(msg)
}else{
self$WARN(msg)
}
}else{
self$INFO(sprintf("Object '%s' is VALID according to ISO 19139 XML schemas!", self$getClassName()))
}
if(inspire){
if(!is.null(inspireValidator) && is(inspireValidator, "INSPIREMetadataValidator")){
if(inspireValidator$running){
inspireReport <- inspireValidator$getValidationReport(obj = self)
isValid <- list(
ISO = isValid,
INSPIRE = inspireReport
)
}else{
self$WARN(sprintf("INSPIRE Metadata validator service (%s) is not running", inspireValidator$url))
}
}else{
self$WARN("No INSPIRE Metadata validator set, aborting INSPIRE metadata validation!")
}
}
return(isValid)
},
#'@description Save XML representation resulting from \code{$encode(...)} method to a file
#'@param file file
#'@param ... any other argument from \code{$encode(...)} method
save = function(file, ...){
#encode as xml
xml <- self$encode(...)
xml_str <- as(xml, "character")
#write file with writeBin to overcome writeChar size limitation
writeBin(xml_str, con = file, useBytes = TRUE)
#read file to replace C-style zero-terminated string
r = readBin(file, raw(), file.info(file)$size)
r[r==as.raw(0)] = as.raw(0x20) ## replace with 0x20 = <space>
writeBin(r, file)
},
#Util & internal methods
#---------------------------------------------------------------------------
#'@description Get namespace definition
#'@param recursive recursive namespace definitions? Default is \code{FALSE}
#'@return the list of XML namespace definitions
getNamespaceDefinition = function(recursive = FALSE){
nsdefs <- NULL
if(recursive){
#list of fields
fields <- rev(names(self))
fields <- fields[!sapply(fields, function(x){
(class(self[[x]])[1] %in% c("environment", "function")) ||
(x %in% private$system_fields)
})]
selfNsdef <- self$getNamespaceDefinition()
nsdefs <- list()
if(length(fields)>0){
invisible(lapply(fields, function(x){
xObj <- self[[x]]
if(is.null(xObj) || (is.list(xObj) & length(xObj) == 0)){
if(x %in% names(self$defaults)){
xObj <- self$defaults[[x]]
}
}
hasContent <- !is.null(xObj)
if(is(xObj, "ISOAbstractObject")){
hasContent <- any(hasContent, length(xObj$attrs)>0)
}
if(hasContent){
#add parent namespaces if any parent field
if(x != "value"){
klass <- self$isFieldInheritedFrom(x)
if(!is.null(klass)){
ns <- ISOMetadataNamespace[[klass$private_fields$xmlNamespacePrefix]]$getDefinition()
if(!(ns %in% nsdefs)){
nsdefs <<- c(nsdefs, ns)
}
}
}
#add namespaces
nsdef <- NULL
if(is(xObj, "ISOAbstractObject")){
nsdef <- xObj$getNamespaceDefinition(recursive = recursive)
}else if(is(xObj, "list")){
nsdef <- list()
invisible(lapply(xObj, function(xObj.item){
nsdef.item <- NULL
if(is(xObj.item, "ISOAbstractObject")){
nsdef.item <- xObj.item$getNamespaceDefinition(recursive = recursive)
}else{
if(!is(xObj.item, "matrix")) nsdef.item <- ISOMetadataNamespace$GCO$getDefinition()
}
for(item in names(nsdef.item)){
nsd <- nsdef.item[[item]]
if(!(nsd %in% nsdef)){
nsdef.new <- c(nsdef, nsd)
names(nsdef.new) <- c(names(nsdef), item)
nsdef <<- nsdef.new
}
}
}))
}else{
if(!startsWith(names(selfNsdef)[1],"gml")){
nsdef <- ISOMetadataNamespace$GCO$getDefinition()
}
}
for(item in names(nsdef)){
nsdef.item <- nsdef[[item]]
if(!(nsdef.item %in% nsdefs)){
nsdefs.new <- c(nsdefs, nsdef.item)
names(nsdefs.new) <- c(names(nsdefs), item)
nsdefs <<- nsdefs.new
}
}
}
}))
}
if(!(selfNsdef[[1]] %in% nsdefs)) nsdefs <- c(selfNsdef, nsdefs)
nsdefs <- nsdefs[!sapply(nsdefs, is.null)]
}else{
nsdefs <- self$namespace$getDefinition()
}
invisible(lapply(names(self$attrs), function(attr){
str <- unlist(strsplit(attr,":", fixed=T))
if(length(str)>1){
nsprefix <- str[1]
namespace <- ISOMetadataNamespace[[toupper(nsprefix)]]
if(!is.null(namespace)){
ns <- namespace$getDefinition()
if(!(ns %in% nsdefs)) nsdefs <<- c(nsdefs, ns)
}
}
}))
nsdefs <- nsdefs[!duplicated(names(nsdefs))]
return(nsdefs)
},
#'@description Get class name
#'@param level level of class
#'@return the class name
getClassName = function(level = 1L){
return(class(self)[level])
},
#'@description Get class
#'@return the corresponding class, as \link{R6Class} reference object generator
getClass = function(){
class <- try(eval(parse(text = self$getClassName())), silent = TRUE)
level <- 1L
class_is_error <- is(class, "try-error")
while(class_is_error){
class <- try(eval(parse(text = paste0("geometa::",self$getClassName(level)))), silent = TRUE)
class_is_error <- is(class, "try-error")
if(class_is_error) level <- level + 1
}
return(class)
},
#'@description Wraps base element
#'@param field field name
#'@param fieldObj field object
#'@param an object of class \link{R6Class}
wrapBaseElement = function(field, fieldObj){
dataType <- class(fieldObj)[1]
#specific coercing
if(is(fieldObj, "POSIXt")) dataType <- "datetime"
#re-encoding (if needed)
if(tolower(dataType)=="character"){
if(Encoding(fieldObj)!="UTF-8") fieldObj <- iconv(fieldObj, to = "UTF-8")
}
#wrapping
dataObj <- switch(tolower(dataType),
"character" = ISOBaseCharacterString$new(value = fieldObj),
"numeric" = ISOBaseReal$new(value = fieldObj),
"decimal" = ISOBaseDecimal$new(value = fieldObj), #Requires specific class call
"integer" = ISOBaseInteger$new(value = fieldObj),
"unlimitedinteger" = ISOUnlimitedInteger$new(value = fieldObj),
"logical" = ISOBaseBoolean$new(value = fieldObj),
"datetime" = ISOBaseDateTime$new(value = fieldObj),
"date" = ISOBaseDate$new(value = fieldObj),
NULL
)
return(dataObj)
},
#'@description Set Is Null
#'@param isNull object of class \link{logical}
#'@param reason reason why object is Null
setIsNull = function(isNull, reason = "missing"){
if(isNull){
allowedReasons <- c("inapplicable", "missing", "template", "unknown", "withheld")
if(!(reason %in% allowedReasons)){
stop(sprintf("The reason should be a value among [%s]", paste(allowedReasons, collapse=",")))
}
}
self$isNull <- isNull
if(self$isNull){
self$setAttr("gco:nilReason", reason)
}else{
self$attrs <- self$attrs[names(self$attrs)!="gco:nilReason"]
}
},
#'@description Util to know if a field contain a metadata element
#'@param field field name
#'@param metadataElement metadata element
#'@return \code{TRUE} if contains, \code{FALSE} otherwise
contains = function(field, metadataElement){
out = FALSE
if(length(self[[field]]) == 0){
out = FALSE
}else{
out = any(sapply(self[[field]], function(x){
ISOAbstractObject$compare(x, metadataElement)
}))
}
return(out)
},
#'@description Util to add an element to a list of elements for N cardinality of a target element name
#'@param field field
#'@param metadataElement metadata element
#'@return \code{TRUE} if added, \code{FALSE} otherwise
addListElement = function(field, metadataElement){
startNb <- length(self[[field]])
if(!self$contains(field, metadataElement)){
self[[field]] = c(self[[field]], metadataElement)
}
endNb = length(self[[field]])
return(endNb == startNb+1)
},
#'@description Util to deleted an element to a list of elements for N cardinality of a target element name
#'@param field field
#'@param metadataElement metadata element
#'@return \code{TRUE} if deleted, \code{FALSE} otherwise
delListElement = function(field, metadataElement){
startNb <- length(self[[field]])
if(self$contains(field, metadataElement)){
self[[field]] = self[[field]][!sapply(self[[field]], ISOAbstractObject$compare, metadataElement)]
}
endNb = length(self[[field]])
return(endNb == startNb-1)
},
#'@description Util to set an attribute
#'@param attrKey attribute key
#'@param attrValue attribute value
setAttr = function(attrKey, attrValue){
self$attrs[[attrKey]] <- attrValue
},
#'@description Util add field attributes, over the XML field wrapping element instead of the element itself
#'@param field field
#'@param ... list of attributes
addFieldAttrs = function(field, ...){
hasfield <- field %in% names(self$getClass()$public_fields)
if(hasfield){
if(is.list(self$getClass()$public_fields[[field]])){
self[[field]] <- c(self[[field]], ISOAttributes$new(...))
}else{
self[[field]] <- ISOAttributes$new(...)
}
}else{
stop(sprintf("Field '%s' is not a property of class '%s'", field, self$getClassName()))
}
},
#'@description Set id
#'@param id id
#'@param addNS add namespace definition? Default is \code{FALSE}
setId = function(id, addNS = FALSE){
attrKey <- "id"
prefix <- tolower(private$xmlNamespacePrefix)
if(startsWith(prefix, "gml")) prefix <- "gml"
if(addNS) attrKey <- paste(prefix, attrKey, sep=":")
self$attrs[[attrKey]] <- id
},
#'@description Set Href attribute
#'@param href href
setHref = function(href){
self$attrs[["xlink:href"]] <- href
},
#'@description Set codelist attribute
#'@param codeList codelist
setCodeList = function(codeList){
self$attrs[["codeList"]] <- codeList
},
#'@description Set codelist value
#'@param codeListValue codelist value
setCodeListValue = function(codeListValue){
self$attrs[["codeListValue"]] <- codeListValue
},
#'@description Set codeSpace
#'@param codeSpace codespace
setCodeSpace = function(codeSpace){
self$attrs[["codeSpace"]] <- codeSpace
},
#'@description Set value
#'@param value value
setValue = function(value){
self$value <- value
},
#'@description Util to check where object refers to a emetadata document (eg. \link{ISOMetadata} or \link{ISOFeatureCatalogue})
#'@return \code{TRUE} if a document, \code{FALSE} otherwise
isDocument = function(){
return(private$document)
},
#'@description Indicates the class a field inherits from
#'@param field field
#'@return an object generator of class \link{R6Class}
isFieldInheritedFrom = function(field){
parentClass <- NULL
inherited <- !(field %in% names(self$getClass()$public_fields))
if(inherited){
classes <- class(self)
classes <- classes[c(-1,-length(classes))]
for(i in 1:length(classes)){
cl <- eval(parse(text=classes[i]))
if(field %in% names(cl$public_fields)){
parentClass <- cl
break
}
}
}
return(parentClass)
},
#'@description Creates a localised property
#'@param text text
#'@param locales a list of localized names
createLocalisedProperty = function(text, locales){
if(!is(locales, "list")){
stop("The argument 'locales' should be an object of class 'list'")
}
ft <- ISOFreeText$new()
for(locale in names(locales)){
localeValue <- locales[[locale]]
if(!is(localeValue, "character")){
stop("Each locale value should be of class 'character'")
}
localised <- ISOLocalisedCharacterString$new(locale = locale, value = localeValue)
if(!is.null(attr(localeValue, "uri"))){
localised$parentAttrs <- list("xlink:href" = attr(localeValue, "uri"))
}
ft$addTextGroup(localised)
}
seq <- ISOElementSequence$new(xml=NULL, text, ft)
return(seq)
}
)
)
ISOAbstractObject$getStandardByPrefix = function(prefix){
std <- switch(prefix,
"GCO" = data.frame(specification = "ISO/TS 19103:2005", title = "Geographic Common extensible markup language", stringsAsFactors = FALSE),
"GFC" = data.frame(specification = "ISO/TC211 19110:2005", title = "Geographic Information - Methodology for feature cataloguing", stringsAsFactors = FALSE),
"GMD" = data.frame(specification = "ISO/TC211 19115-1:2003", title = "Geographic Information - Metadata", stringsAsFactors = FALSE),
"GMI" = data.frame(specification = "ISO/TC211 19115-2:2009", title = "Geographic Information - Metadata - Part 2: Extensions for imagery and gridded data", stringsAsFactors = FALSE),
"GTS" = data.frame(specification = "ISO/TC211 19139:2007", title = "Geographic Metadata XML Schema - Geographic Temporal Schema (GTS)", stringsAsFactors = FALSE),
"SRV" = data.frame(specification = "ISO/TC211 19119:2005", title = "Geographic Information - Service Metadata", stringsAsFactors = FALSE),
"GMX" = data.frame(specification = "ISO/TC211 19139:2007", title = "Geographic Metadata XML Schema", stringsAsFactors = FALSE),
"GML" = data.frame(specification = "GML 3.2.1 (ISO 19136)", title = "Geographic Markup Language", stringsAsFactors = FALSE),
"GMLCOV" = data.frame(specification = "GML 3.2.1 Coverage (OGC GMLCOV)", title = "OGC GML Coverage Implementation Schema", stringsAsFactors = FALSE),
"GMLRGRID" = data.frame(specification = "GML 3.3 Referenceable Grid (OGC GML)", title = "OGC GML Referenceable Grid", stringsAsFactors = FALSE),
"SWE" = data.frame(specification = "SWE 2.0", title = "Sensor Web Enablement (SWE) Common Data Model", stringsAsFactors = FALSE)
)
return(std)
}
ISOAbstractObject$getISOStandard = function(clazz){
std <- NA
if(is.null(clazz$private_fields)) return(std)
if(is.null(clazz$private_fields$xmlNamespacePrefix)) return(std)
std <- ISOAbstractObject$getStandardByPrefix(clazz$private_fields$xmlNamespacePrefix)
return(std)
}
ISOAbstractObject$getISOClasses = function(extended = FALSE, pretty = FALSE){
list_of_classes <- unlist(sapply(search(), ls))
list_of_classes <- list_of_classes[sapply(list_of_classes, function(x){
clazz <- invisible(try(eval(parse(text=x)),silent=TRUE))
r6Predicate <- class(clazz)[1]=="R6ClassGenerator"
envPredicate <- extended
if(r6Predicate & !extended){
if(is.environment(clazz$parent_env)){
envPredicate <- environmentName(clazz$parent_env)=="geometa"
}
}
includePredicate <- TRUE
if(r6Predicate){
if(!is.null(clazz$classname)){
includePredicate <- !(clazz$classname %in% c("geometaLogger", "INSPIREMetadataValidator",
"ISOCodelist", "ISOCodeListValue", "ISOMetadataNamespace", "ISOTimePeriod","ISOAttributes",
"pivot_format"))
}
}
return(r6Predicate & envPredicate & includePredicate)
})]
list_of_classes <- as.vector(list_of_classes)
list_of_classes <- list_of_classes[!startsWith(list_of_classes, "pivot")]
if(pretty){
std_info <- do.call("rbind",lapply(list_of_classes, function(x){
clazz <- invisible(try(eval(parse(text=x)),silent=TRUE))
std <- ISOAbstractObject$getISOStandard(clazz)
std_info <- cbind(
std,
ns_prefix = clazz$private_fields$xmlNamespacePrefix,
ns_uri = ISOMetadataNamespace[[clazz$private_fields$xmlNamespacePrefix]]$uri,
element = clazz$private_fields$xmlElement,
stringsAsFactors = FALSE
)
return(std_info)
}))
list_of_classes <- data.frame(
geometa_class = list_of_classes,
std_info,
stringsAsFactors = FALSE
)
}
return(list_of_classes)
}
ISOAbstractObject$getISOClassByNode = function(node){
outClass <- NULL
if(!is(node, "XMLInternalDocument")) node <- xmlDoc(node)
nodeElement <- xmlRoot(node)
nodeElementName <- xmlName(nodeElement)
nodeElementNames <- unlist(strsplit(nodeElementName, ":"))
if(length(nodeElementNames)>1){
nodeElementName <- nodeElementNames[2]
}
list_of_classes <- getISOClasses()
if(is.null(list_of_classes))
list_of_classes <- ISOAbstractObject$getISOClasses(extended = TRUE, pretty = FALSE)
for(classname in list_of_classes){
clazz <- try(eval(parse(text=classname)))
if(nodeElementName %in% clazz$private_fields$xmlElement){
geometa_inherits <- FALSE
superclazz <- clazz
while(!geometa_inherits && !is.null(superclazz)){
clazz_fields <- names(superclazz)
if(!is.null(clazz_fields)) if(length(clazz_fields)>0) if("parent_env" %in% clazz_fields){
if(environmentName(superclazz$parent_env)=="geometa"){
geometa_inherits <- TRUE
break
}else{
if("get_inherit" %in% clazz_fields){
superclazz <- superclazz$get_inherit()
}
}
}
}
if(!geometa_inherits) next
if(length(clazz$private_fields)>0
&& !is.null(clazz$private_fields$xmlElement)
&& !is.null(clazz$private_fields$xmlNamespacePrefix)){
outClass <- clazz
break
}
}
}
return(outClass)
}
ISOAbstractObject$compare = function(metadataElement1, metadataElement2, method = NULL){
if(is.null(method)) method <- getGeometaOption("object_comparator")
same <- FALSE
switch(method,
"xml" = {
#base on XML representation
text1 <- NULL
if(is(metadataElement1, "ISOAbstractObject")){
xml1 <-metadataElement1$encode(addNS = TRUE, validate = FALSE,
resetSerialID = FALSE, setSerialID = FALSE)
if(metadataElement1$isDocument()){
content1 <- as(xml1, "character")
content1 <- gsub("<!--.*?-->", "", content1)
xml1 <- xmlParse(content1)
}else{
xml1 <- XML::xmlDoc(xml1)
}
text1 <- as(xml1, "character")
}else{
text1 <- as.character(metadataElement1)
}
text2 <- NULL
if(is(metadataElement2, "ISOAbstractObject")){
xml2 <- metadataElement2$encode(addNS = TRUE, validate = FALSE, setSerialID = FALSE)
if(metadataElement2$isDocument()){
content2 <- as(xml2, "character")
content2 <- gsub("<!--.*?-->", "", content2)
xml2 <- xmlParse(content2)
}else{
xml2 <- XML::xmlDoc(xml2)
}
text2 <- as(xml2, "character")
}else{
text2 <- as.character(metadataElement2)
}
same <- (text1 == text2)
},
"print" = {
#based on simplified print representation
text1 <- NULL
if(is(metadataElement1, "ISOAbstractObject")){
text1 <- paste(utils::capture.output(metadataElement1$print( add_codelist_description = F)), collapse="")
}else{
text1 <- as.character(metadataElement1)
}
text2 <- NULL
if(is(metadataElement2, "ISOAbstractObject")){
text2 <- paste(utils::capture.output(metadataElement2$print( add_codelist_description = F)), collapse="")
}else{
text2 <- as.character(metadataElement2)
}
same <- (text1 == text2)
}
)
return(same)
}
#' @name getClassesInheriting
#' @aliases getClassesInheriting
#' @title getClassesInheriting
#'
#' @param classname the name of the superclass for which inheriting sub-classes have to be listed
#' @param extended whether we want to look at user namespace for third-party sub-classes
#' @param pretty prettify the output as \code{data.frame}
#' @export
#' @description get the list of classes inheriting a given super class provided by its name
#'
#' @usage getClassesInheriting(classname, extended, pretty)
#'
#' @examples
#' getClassesInheriting("ISAbstractObject")
getClassesInheriting <- function(classname, extended = FALSE, pretty = FALSE){
list_of_classes <- ls(getNamespaceInfo("geometa", "exports"))
if(extended) {
search_envs <- search()
search_envs <- search_envs[search_envs!="package:geometa"]
list_of_other_classes <- unlist(sapply(search_envs, ls))
list_of_classes <- c(list_of_classes, list_of_other_classes)
}
list_of_classes <- list_of_classes[sapply(list_of_classes, function(x){
clazz <- try(eval(parse(text=x)),silent=TRUE)
if(is(clazz, "try-error")) clazz <- try(eval(parse(text=paste0("geometa::",x))),silent=TRUE)
r6Predicate <- class(clazz)[1]=="R6ClassGenerator"
if(!r6Predicate) return(FALSE)
geometaObjPredicate <- FALSE
superclazz <- clazz
while(!geometaObjPredicate && !is.null(superclazz)){
clazz_fields <- names(superclazz)
if(!is.null(clazz_fields)) if(length(clazz_fields)>0){
if("get_inherit" %in% clazz_fields){
superclazz <- superclazz$get_inherit()
geometaPredicate <- FALSE
if("parent_env" %in% clazz_fields) geometaPredicate <- environmentName(superclazz$parent_env)=="geometa"
geometaObjPredicate <- superclazz$classname == classname && geometaPredicate
}else{
break
}
}
}
return(geometaObjPredicate)
})]
list_of_classes <- as.vector(list_of_classes)
if(pretty){
std_infos <- do.call("rbind",lapply(list_of_classes, function(x){
clazz <- try(eval(parse(text=x)),silent=TRUE)
if(is(clazz,"try-error")) clazz <- try(eval(parse(text=paste0("geometa::",x))),silent=TRUE)
std_info <- data.frame(
environment = environmentName(clazz$parent_env),
ns_prefix = if(!is.null(clazz$private_fields$xmlNamespacePrefix))clazz$private_fields$xmlNamespacePrefix else NA,
ns_uri = if(!is.null(clazz$private_fields$xmlNamespacePrefix)) ISOMetadataNamespace[[clazz$private_fields$xmlNamespacePrefix]]$uri else NA,
element = if(!is.null(clazz$private_fields$xmlElement)) clazz$private_fields$xmlElement else NA,
stringsAsFactors = FALSE
)
return(std_info)
}))
list_of_classes <- cbind(
class = list_of_classes,
std_infos,
stringsAsFactors = FALSE
)
}
return(list_of_classes)
}
#' @name cacheISOClasses
#' @aliases cacheISOClasses
#' @title cacheISOClasses
#' @export
#' @description \code{\link{cacheISOClasses}} allows to cache the list of
#' \pkg{geometa} classes or extended. This is especially required to fasten
#' the decoding of metadata elements from an XML file. It is called internally
#' by \pkg{geometa} the first function \code{\link{getISOClasses}} is called
#' and each time the function \code{\link{readISO19139}} function is called to
#' integrate eventually new classes added by user to extend \pkg{geometa} model
#' (case of ISO profiles).
#'
#' @usage cacheISOClasses()
#'
#' @examples
#' cacheISOClasses()
#'
#' @author Emmanuel Blondel, \email{emmanuel.blondel1@@gmail.com}
#
cacheISOClasses <- function(){
.geometa.iso$classes <- getClassesInheriting(classname = "ISOAbstractObject", extended = TRUE, pretty = FALSE)
}
#' @name getISOClasses
#' @aliases getISOClasses
#' @title getISOClasses
#' @export
#' @description get the list of cached ISO classes
#'
#' @usage getISOClasses()
#'
#' @examples
#' getISOClasses()
#'
#' @author Emmanuel Blondel, \email{emmanuel.blondel1@@gmail.com}
#
getISOClasses <- function(){
if(length(.geometa.iso$classes)==0) cacheISOClasses()
return(.geometa.iso$classes)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.