############################################################################## #
# Copyright (C) 2019 by 52 North #
# Initiative for Geospatial Open Source Software GmbH #
# #
# Contact: Andreas Wytzisk #
# 52 North Initiative for Geospatial Open Source Software GmbH #
# Martin-Luther-King-Weg 24 #
# 48155 Muenster, Germany #
# info@52north.org #
# #
# This program is free software; you can redistribute and/or modify it under #
# the terms of the GNU General Public License version 2 as published by the #
# Free Software Foundation. #
# #
# This program is distributed WITHOUT ANY WARRANTY; even without 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 #
# this program (see gpl-2.0.txt). If not, write to the Free Software #
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA or #
# visit the Free Software Foundation web page, http://www.fsf.org. #
# #
# Author: Daniel Nuest (daniel.nuest@uni-muenster.de) #
# Created: 2010-09-15 #
# Project: sos4R - https://github.com/52North/sos4R #
# #
############################################################################## #
#
# position parsing ----
#
parsePosition <- function(obj, sos) {
.position <- NULL
# has href attribute?
href <- xml2::xml_attr(x = obj, attr = "href")
if (!is.na(href)) {
# position is referenced
position <- GmlPointProperty(href = href)
}
else {
# must be point
pointXml <- xml2::xml_child(x = obj, search = gmlPointName, ns = sos@namespaces)
position <- GmlPointProperty(point = parsePoint(pointXml, sos = sos))
}
return(position)
}
parsePoint <- function(obj, sos) {
point <- NA
pos <- xml2::xml_child(x = obj, search = gmlPosName, ns = SosAllNamespaces(sos@version))
posString <- xml2::xml_text(x = pos)
id <- xml2::xml_attr(x = obj, attr = "id")
if (sosSwitchCoordinates(sos)) {
warning("Switching coordinates in Point!")
orig <- strsplit(x = posString, split = " ")
posString <- paste(orig[[1]][[2]], orig[[1]][[1]])
}
# optional attributes:
srsName <- xml2::xml_attr(x = pos, attr = "srsName")
srsDimension <- xml2::xml_attr(x = pos, attr = "srsDimension", default = NA_integer_)
axisLabels <- xml2::xml_attr(x = pos, attr = "axisLabels")
uomLabels <- xml2::xml_attr(x = pos, attr = "uomLabels")
pos <- GmlDirectPosition(pos = posString,
srsName = srsName,
srsDimension = as.integer(srsDimension),
axisLabels = axisLabels,
uomLabels = uomLabels)
point <- GmlPoint(id = id, pos = pos)
return(point)
}
#
# time parsing ----
#
parseTimeInstant <- function(obj, sos) {
.timePosXML <- xml2::xml_find_first(x = obj, xpath = gmlTimePositionName,
ns = sos@namespaces)
.timePos <- parseTimePosition(obj = .timePosXML, sos = sos)
# optionals
.id = xml2::xml_attr(x = obj, attr = "id", default = NA_character_)
.frame = xml2::xml_attr(x = obj, attr = "frame", default = NA_character_)
.relatedTimes <- xml2::xml_find_all(x = obj, xpath = gmlRelatedTimeName)
if (length(.relatedTimes) < 1)
.relatedTimes <- list()
.ti <- GmlTimeInstant(timePosition = .timePos,
id = .id,
relatedTimes = .relatedTimes,
frame = .frame)
return(.ti)
}
parseTimeInstantProperty <- function(obj, sos) {
.timeProp <- NULL
# check if reference or inline phenomenon
.href <- xml2::xml_attr(x = obj, attr = "href")
if (!is.na(.href)) {
.timeProp <- GmlTimeInstantProperty(href = .href)
}
else {
.time <- parseTimeInstant(obj = xml2::xml_child(x = obj), sos = sos)
.timeProp <- GmlTimeInstantProperty(time = .time)
}
return(.timeProp)
}
parseTimePosition <- function(obj, sos) {
.indeterminatePosition <- xml2::xml_attr(x = obj, attr = "indeterminatePosition", default = NA_character_)
if (is.na(.indeterminatePosition))
.time <- sosConvertTime(xml2::xml_text(x = obj), sos = sos)
else .time <- parsedate::parse_iso_8601(NA)
# optional:
.frame <- xml2::xml_attr(x = obj, attr = "frame", default = NA_character_)
.calendarEraName <- xml2::xml_attr(x = obj, attr = "calendarEraName", default = NA_character_)
.timePosition <- GmlTimePosition(time = .time, frame = .frame,
calendarEraName = .calendarEraName,
indeterminatePosition = .indeterminatePosition)
return(.timePosition)
}
parseTimePeriod <- function(obj, sos) {
.timeObject <- NULL
# optionals
.id = xml2::xml_attr(x = obj, attr = "id", default = NA_character_)
.frame = xml2::xml_attr(x = obj, attr = "frame", default = NA_character_)
.relatedTimes <- xml2::xml_find_all(x = obj, xpath = gmlRelatedTimeName, ns = sos@namespaces)
if (length(.relatedTimes) < 1)
.relatedTimes <- list()
# TODO parse gml:timeLength
.duration <- NA_character_
.timeInterval <- NULL
# begin and end
if (!is.na(xml2::xml_child(x = obj, search = gmlBeginName, ns = sos@namespaces)) ||
!is.na(xml2::xml_child(x = obj, search = gmlEndName, ns = sos@namespaces))) {
.begin <- parseTimeInstantProperty(obj = xml2::xml_child(x = obj,
search = gmlBeginName,
ns = sos@namespaces),
sos = sos)
.end <- parseTimeInstantProperty(xml2::xml_child(x = obj, search = gmlEndName, ns = sos@namespaces),
sos = sos)
.timeObject <- GmlTimePeriod(begin = .begin, end = .end, duration = .duration,
timeInterval = .timeInterval, id = .id,
relatedTimes = .relatedTimes, frame = .frame)
}
# beginPosition and endPosition
else if (!is.na(xml2::xml_child(x = obj, search = gmlBeginPositionName))
|| !is.na(xml2::xml_child(x = obj, search = gmlEndPositionName))) {
.beginPosition <- parseTimePosition(
obj = xml2::xml_child(x = obj, search = gmlBeginPositionName),
sos = sos)
.endPosition <- parseTimePosition(
obj = xml2::xml_child(x = obj, search = gmlEndPositionName),
sos = sos)
.timeObject <- GmlTimePeriod(beginPosition = .beginPosition,
endPosition = .endPosition, duration = .duration,
timeInterval = .timeInterval, id = .id,
relatedTimes = .relatedTimes, frame = .frame)
}
return(.timeObject)
}
parseTimeGeometricPrimitiveFromParent <- function(obj, sos) {
tiXML <- xml2::xml_find_first(x = obj, xpath = gmlTimeInstantName)
tpXML <- xml2::xml_find_first(x = obj, xpath = gmlTimePeriodName)
timeObject <- NULL
if (!is.na(tiXML)) {
timeObject <- parseTimeInstant(obj = tiXML, sos = sos)
}
else if (!is.na(tpXML)) {
timeObject <- parseTimePeriod(obj = tpXML, sos = sos)
}
else {
timeObject <- GmlTimeInstant(
timePosition = GmlTimePosition(
time = parsedate::parse_iso_8601(NA)))
}
return(timeObject)
}
#
# feature collection parsing ----
#
parseFeatureCollection <- function(obj, sos) {
.members <- xml2::xml_find_all(x = obj, xpath = gmlFeatureMemberName, ns = sos@namespaces)
.id <- xml2::xml_attr(x = obj, attr = "id", default = NA_character_)
if (length(.members) > 0) {
.members <- lapply(.members, .parseFeatureMember, sos = sos)
.fc <- GmlFeatureCollection(featureMembers = .members, id = .id)
return(.fc)
}
else {
warning("gml:FeatureCollection could not be parsed, only gml:featureMember elements can be handled.")
return(NULL)
}
}
.parseFeatureMember <- function(obj, sos) {
.member <- xml2::xml_child(x = obj)
.name <- xml2::xml_name(x = .member, ns = sos@namespaces)
if (.name == saSamplingPointName) {
.sp <- parseSamplingPoint(.member, sos = sos)
.member.parsed <- GmlFeatureProperty(feature = .sp)
}
else if (.name == gmlFeatureCollectionName) {
.member.parsed <- parseFeatureCollection(.member, sos = sos)
}
else {
warning("No handling for given gml:featureMember available, only sa:SamplingPoint is supported!")
}
return(.member.parsed)
}
#
# value parsing ----
#
parseMeasure <- function(obj) {
.value <- as.numeric(xml2::xml_text(x = obj))
.uom <- xml2::xml_attr(x = obj, attr = "uom", default = NA_character_)
.result <- GmlMeasure(.value, .uom)
return(.result)
}
#
# spatial parsing ----
#
parseEnvelope <- function(obj, sos, namespaces = xml2::xml_ns(obj), verbose = FALSE) {
env <- list(
srsName = xml2::xml_attr(x = obj, attr = "srsName"),
lowerCorner = xml2::xml_text(x = xml2::xml_child(x = obj,
search = gmlLowerCornerName,
ns = namespaces)),
upperCorner = xml2::xml_text(x = xml2::xml_child(x = obj,
search = gmlUpperCornerName,
ns = namespaces))
)
if (verbose) cat("[parseObservationCollection] Parsed envelope:", toString(env), "\n")
if (sosSwitchCoordinates(sos)) {
warning("Switching coordinates in envelope!")
.origLC <- strsplit(x = env[["lowerCorner"]], split = " ")
.lC <- paste(.origLC[[1]][[2]], .origLC[[1]][[1]])
.origUC <- strsplit(x = env[["upperCorner"]], split = " ")
.uC <- paste(.origUC[[1]][[2]], .origUC[[1]][[1]])
env <- list(srsName = xml2::xml_attr(x = obj, attr = "srsName"),
lowerCorner = .lC, upperCorner = .uC)
}
return(env)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.