Nothing
############################################################################## #
# 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-06-18 #
# Project: sos4R - https://github.com/52North/sos4R #
# #
############################################################################## #
#
# construction functions ----
#
SOS <- function(url, binding = SosDefaultBinding(),
version = sos100_version,
parsers = SosParsingFunctions(),
encoders = SosEncodingFunctions(),
dataFieldConverters = SosDataFieldConvertingFunctions(),
timeFormat = sosDefaultTimeFormat,
verboseOutput = FALSE,
switchCoordinates = FALSE,
useDCPs = TRUE,
dcpFilter = SosDefaultDCPs(),
additionalKVPs = list(),
namespaces = SosAllNamespaces(version = version),
...) {
if (version == sos100_version) {
.sos <- new("SOS_1.0.0",
url = url,
binding = binding,
version = version,
# dummy capabilities to be replaced below
capabilities = new("OwsCapabilities", version = "NA",
updateSequence = as.character(NA),
owsVersion = sosDefaultGetCapOwsVersion),
parsers = parsers,
encoders = encoders,
dataFieldConverters = dataFieldConverters,
timeFormat = timeFormat,
verboseOutput = verboseOutput,
switchCoordinates = switchCoordinates,
useDCPs = useDCPs,
dcpFilter = dcpFilter,
additionalKVPs = additionalKVPs,
namespaces = namespaces)
caps <- sos4R::getCapabilities(sos = .sos, verbose = verboseOutput, ...)
if (!is(caps, "OwsCapabilities")) {
stop("ERROR: Did not receive a Capabilities response!")
}
.sos@capabilities <- caps
if (verboseOutput) cat("[SOS] Created new SOS:\n", toString(.sos), "\n")
return(.sos)
}
else if (version == sos200_version) {
.sos <- new("SOS_2.0.0",
url = url,
binding = binding,
version = version,
# dummy capabilities to be replaced below
capabilities = new("OwsCapabilities", version = "NA",
updateSequence = as.character(NA),
owsVersion = sosDefaultGetCapOwsVersion),
parsers = parsers,
encoders = encoders,
dataFieldConverters = dataFieldConverters,
timeFormat = timeFormat,
verboseOutput = verboseOutput,
switchCoordinates = switchCoordinates,
useDCPs = useDCPs,
dcpFilter = dcpFilter,
additionalKVPs = additionalKVPs,
namespaces = namespaces)
caps <- sos4R::getCapabilities(sos = .sos, verbose = verboseOutput, ...)
if (!is(caps, "OwsCapabilities")) {
stop("ERROR: Did not receive a Capabilities response!")
}
.sos@capabilities <- caps
if (verboseOutput) cat("[SOS] Created new SOS:\n", toString(.sos), "\n")
return(.sos)
}
stop("Service version not supported!")
}
SosFilter_Capabilities <- function(spatial = list(NA_character_),
temporal = list(NA_character_),
scalar = list(NA_character_),
id = list(NA_character_)) {
new("SosFilter_Capabilities", spatial = spatial, temporal = temporal,
scalar = scalar, id = id)
}
SosCapabilities <- function(version, updateSequence = NA, owsVersion = "1.1.0",
identification = NULL, provider = NULL, operations = NULL,
filterCapabilities = NULL, contents = NULL) {
if (version == "1.0.0") {
new("SosCapabilities_1.0.0",
version = version, updateSequence = updateSequence,
owsVersion = owsVersion,
identification = identification,
provider = provider, operations = operations,
filterCapabilities = filterCapabilities, contents = contents)
}
else if (version == "2.0.0") {
new("SosCapabilities_2.0.0",
version = version, updateSequence = updateSequence,
owsVersion = owsVersion,
identification = identification,
provider = provider, operations = operations,
filterCapabilities = filterCapabilities, contents = contents)
}
else {
new("OwsCapabilities",
version = version, updateSequence = updateSequence,
owsVersion = owsVersion)
}
}
SosObservationOffering <- function(id,
name = as.character(NA),
time,
procedure,
observedProperty,
featureOfInterest,
responseFormat,
intendedApplication = as.character(NA),
resultModel = as.character(NA),
responseMode = as.character(NA),
boundedBy = list()) {
new("SosObservationOffering",
id = id,
name = name,
time = time,
procedure = procedure,
observedProperty = observedProperty,
featureOfInterest = featureOfInterest,
responseFormat = responseFormat,
intendedApplication = intendedApplication,
resultModel = resultModel,
responseMode = responseMode,
boundedBy = boundedBy)
}
SosContents <- function(observationOfferings) {
new("SosContents", observationOfferings = observationOfferings)
}
SosEventTime <- function(temporalOps) {
new("SosEventTime", temporalOps = temporalOps)
}
SosFeatureOfInterest <- function(objectIDs = list(NA), spatialOps = NULL) {
new("SosFeatureOfInterest", objectIDs = objectIDs, spatialOps = spatialOps)
}
SosDescribeSensor <- function(
service,
version,
procedure,
outputFormat = NA_character_,
procedureDescriptionFormat = NA_character_,
validTime = NULL) {
new("SosDescribeSensor",
request = ifelse(version == sos100_version, sosDescribeSensorName, swesDescribeSensorName),
service = service,
version = version,
procedure = procedure,
outputFormat = outputFormat,
procedureDescriptionFormat = procedureDescriptionFormat,
validTime = validTime)
}
SosGetObservation <- function(
service,
version,
offering,
observedProperty,
responseFormat,
srsName = as.character(NA),
eventTime = list(),
procedure = as.character(NA),
featureOfInterest = NULL,
result = NULL,
resultModel = as.character(NA),
responseMode = as.character(NA),
BBOX = as.character(NA),
valueReferenceTemporalFilter = as.character(NA)
) {
new("SosGetObservation",
request = sosGetObservationName,
service = service,
version = version,
offering = offering,
observedProperty = observedProperty,
responseFormat = responseFormat,
srsName = srsName,
eventTime = eventTime,
procedure = procedure,
featureOfInterest = featureOfInterest,
result = result,
resultModel = resultModel,
responseMode = responseMode,
BBOX = BBOX,
valueReferenceTemporalFilter = valueReferenceTemporalFilter)
}
SosGetObservationById <- function(
service,
version,
observationId,
# next four only for SOS 1.0.0
responseFormat = as.character(NA),
srsName = as.character(NA),
resultModel = as.character(NA),
responseMode = as.character(NA)) {
new("SosGetObservationById",
request = sosGetObservationByIdName,
service = service,
version = version,
observationId = observationId,
responseFormat = responseFormat,
srsName = srsName,
resultModel = resultModel,
responseMode = responseMode)
}
#
# main internal request method ----
#
.sosRequest_1.0.0 <- function(sos, request, verbose = FALSE, inspect = FALSE) {
# get encoding function for the respective method
.encodingFunction <- sos@encoders[[sos@binding]]
if (verbose) {
.f <- functionBody(.encodingFunction)
cat("[.sosRequest_1.0.0] Encoding Function (beginning of function body): ",
substring(text = .f, first = 0, last = 60), " ... [",
max((length(.f) - 60), 0), " more chrs].\n")
}
# encode!
.encodedRequest = .encodingFunction(obj = request, sos = sos, verbose = verbose)
if (sos@binding == .sosBindingKVP) {
dcp <- list("Get", "application/x-kvp", sos@url)
if (sos@useDCPs) {
if (verbose) cat("[.sosRequest_1.0.0] Using DCP from operation description.\n")
dcp <- sosGetDCP(sos, sosName(request), owsGetName)
if (is.list(dcp) && length(dcp) && is.list(dcp[[1]])) {
dcp <- .sosFilterDCPs(dcp = dcp,
pattern = sos@dcpFilter[[.sosBindingKVP]],
verbose = verbose)
dcp <- unlist(dcp)
}
if (any(is.null(dcp)) || any(is.na(dcp)) || !length(dcp)) {
dcp <- list("Get", "application/x-kvp", sos@url)
if (verbose) cat("[.sosRequest_1.0.0] Could not get DCP from operation description. This is OK for first GetCapabilities request, using ", toString(dcp), "\n")
}
if (verbose) cat("[.sosRequest_1.0.0] Using DCP:", toString(dcp), "\n")
}
else if (verbose) cat("[.sosRequest_1.0.0] Not using DCP from capabilities.\n", dcp, "\n")
if (isTRUE(grep(pattern = "[\\?]", x = dcp[[owsDcpUrlIndex]]) > 0)) {
if (verbose) cat("Given url already contains a '?', appending arguments!\n")
.url = paste0(dcp[[owsDcpUrlIndex]], .encodedRequest)
}
else .url = paste(dcp[[owsDcpUrlIndex]], .encodedRequest, sep = "?")
if (!is.na(sos@additionalKVPs) && length(sos@additionalKVPs) > 0) {
.kvps <- sos@additionalKVPs
if (verbose) cat("[.sosRequest_1.0.0] adding extra KVP parameters:\n\t", toString(.kvps))
.kvpsString <- .encodeAdditionalKVPs(.kvps)
.url <- paste(.url, .kvpsString, sep = "&")
}
if (inspect) cat("[.sosRequest_1.0.0] GET!\n[.sosRequest_1.0.0] REQUEST:\n\t", .url, "\n")
if (verbose) cat("[.sosRequest_1.0.0] Do request...\n")
response = httr::GET(url = .url)
.content <- .processResponse(response, verbose)
if (verbose) cat("[.sosRequest_1.0.0] ... done.\n")
}
else if (sos@binding == .sosBindingPOX) {
if (inspect) {
cat("[.sosRequest_1.0.0] REQUEST:\n")
print(.encodedRequest)
}
dcp <- list("Post", "application/xml", sos@url)
if (sos@useDCPs) {
dcp <- sosGetDCP(sos, sosName(request), owsPostName) #sos@url as fallback
if (is.list(dcp) && length(dcp) && is.list(dcp[[1]])) {
dcp <- .sosFilterDCPs(dcp = dcp,
pattern = sos@dcpFilter[[.sosBindingPOX]],
verbose = verbose)
dcp <- unlist(dcp)
}
if (any(is.null(dcp)) || any(is.na(dcp)) || !length(dcp)) {
dcp <- list("Post", "application/xml", sos@url)
if (verbose) cat("[.sosRequest_1.0.0] Could not get DCP from operation description. This is OK for first GetCapabilities request. Using", toString(dcp), "\n")
}
else {
if (verbose) cat("[.sosRequest_1.0.0] Got DCPs from capabilites:", toString(dcp), "\n")
}
if (verbose) cat("[.sosRequest_1.0.0] Using DCP:", toString(dcp), "\n")
}
else if (verbose) cat("[.sosRequest_1.0.0] *NOT* using DCP from capabilities, but", toString(dcp), "\n")
.requestString <- toString(.encodedRequest)
# using 'POST' for application/xml content
if (verbose) cat("[.sosRequest_1.0.0] Do request...\n")
response <- httr::POST(url = dcp[[owsDcpUrlIndex]],
httr::content_type_xml(),
httr::accept_xml(),
body = .requestString )
.content <- .processResponse(response, verbose)
if (verbose) cat("[.sosRequest_1.0.0] ... done.")
}
else if (sos@binding == .sosBindingSOAP) {
if (inspect) {
print("[.sosRequest_1.0.0] SOAP! REQUEST:\n")
print(.encodedRequest)
}
stop("[sos4R] ERROR: SOAP is not implemented for SOS 1.0.0.\n")
}
else {
stop(paste0("Unsupported method, has to be one of '",
SosSupportedBindings(), "' but is '", sos@binding, "'."))
}
if (verbose) {
cat("[.sosRequest_1.0.0] RESPONSE:\n")
print(.content)
}
return(.content)
}
setMethod(f = "sosRequest",
signature = signature(sos = "SOS_1.0.0", request = "OwsServiceOperation",
verbose = "logical", inspect = "logical"),
definition = function(sos, request, verbose, inspect) {
.sosRequest_1.0.0(sos = sos,
request = request,
verbose = verbose,
inspect = inspect)
}
)
#
# internal SOS operations ----
#
.getCapabilities_1.0.0 <- function(sos, verbose, inspect, sections,
acceptFormats, updateSequence, owsVersion, acceptLanguages) {
if (verbose) {
cat("[.getCapabilities_1.0.0] of", sosUrl(sos), "\n")
}
gc <- OwsGetCapabilities(service = sosService,
acceptVersions = c(sosVersion(sos)),
sections = sections,
acceptFormats = acceptFormats,
updateSequence = updateSequence,
owsVersion = owsVersion,
acceptLanguages = acceptLanguages)
if (verbose) cat("[.getCapabilities_1.0.0] REQUEST:\n", toString(gc), "\n")
response = sosRequest(sos = sos,
request = gc,
verbose = verbose,
inspect = inspect)
if (inspect) {
cat("[.getCapabilities_1.0.0] RESPONSE DOC:\n")
print(response)
}
if (.isExceptionReport(response)) {
return(.handleExceptionReport(sos, response))
}
else {
parsingFunction <- sosParsers(sos)[[sosGetCapabilitiesName]]
caps <- parsingFunction(obj = response, sos = sos)
if (verbose) {
cat("[.getCapabilities_1.0.0] DONE WITH PARSING!\n")
}
return(caps)
}
}
#
# getCapabilities ----
#
setMethod(f = "getCapabilities", signature = signature(sos = "SOS_1.0.0"),
definition = function(sos, verbose, inspect, sections, acceptFormats,
updateSequence, owsVersion, acceptLanguages) {
return(.getCapabilities_1.0.0(sos = sos, verbose = verbose,
inspect = inspect, sections = sections,
acceptFormats = acceptFormats,
updateSequence = updateSequence,
owsVersion = owsVersion,
acceptLanguages = acceptLanguages))
}
)
#
# describeSensor ----
#
setMethod(f = "describeSensor",
signature = signature(sos = "SOS_1.0.0", procedure = "character"),
definition = function(sos, procedure, outputFormat, verbose, inspect, saveOriginal) {
.result <- .describeSensor_1.0.0(sos = sos, procedure = procedure,
outputFormat = outputFormat, verbose = verbose,
inspect = inspect, saveOriginal = saveOriginal)
return(.result)
}
)
.describeSensor_1.0.0 <- function(sos, procedure, outputFormat, verbose,
inspect, saveOriginal) {
if (verbose) cat("[.describeSensor_1.0.0] ", procedure, "@", sos@url, "\n")
# check inputs: procedure
procedures = unique(unlist(sosProcedures(sos)))
if (!any(procedure %in% procedures)) warning("Requested procedure(s) not listed in capablities, service might return error!")
# check inputs: output format is supported by sos
supportedFormats <- sosOperation(sos, sosDescribeSensorName)@parameters[["outputFormat"]];
format <- gsub(outputFormat, pattern = "\\"", replacement = '"')
if (!(format %in% supportedFormats))
warning(paste("outputFormat has to be one of", paste(supportedFormats, sep = ", ",
collapse = "', '"),
"'. Requested format is '", outputFormat, "'."))
# check if multiple sensors
if (length(procedure) > 1) {
if (verbose) cat("[.describeSensor_1.0.0] multiple sensors: ", procedure, "\n")
.descriptions <- list()
for (p in procedure) {
.description <- .describeSensor_1.0.0(sos = sos, procedure = p,
outputFormat = outputFormat, verbose = verbose,
inspect = inspect, saveOriginal = saveOriginal)
.descriptions <- c(.descriptions, .description)
}
return(.descriptions)
}
.ds <- SosDescribeSensor(service = sosService, version = sos@version,
procedure = procedure, outputFormat = outputFormat)
if (verbose) cat("[.describeSensor_1.0.0] REQUEST:\n", toString(.ds), "\n")
response = sosRequest(sos = sos,
request = .ds,
verbose = verbose,
inspect = inspect)
if (inspect) cat("[.describeSensor_1.0.0] RESPONSE:\n", toString(response), "\n")
.filename <- NULL
if (!is.null(saveOriginal)) {
if (is.character(saveOriginal)) {
.filename <- saveOriginal
if (verbose) cat("Using saveOriginal parameter for file name:", .filename, "\n")
}
else if (is.logical(saveOriginal)) {
if (saveOriginal) .filename <- paste(.cleanupFileName(procedure), ".xml", sep = "")
if (verbose) cat("Generated file name:", .filename, "\n")
}
if (verbose) cat("[.describeSensor_1.0.0] Saving original document...", .filename, "in", getwd(), "\n")
xml2::write_xml(x = response, file = .filename)
cat("[sos4R] Original document saved:", .filename, "\n")
}
if (.isExceptionReport(response)) {
return(.handleExceptionReport(sos, response))
}
else {
parsingFunction <- sosParsers(sos)[[sosDescribeSensorName]]
.sml <- parsingFunction(obj = response, sos = sos, verbose = verbose)
return(.sml)
}
}
#
# getObservationById ----
#
setMethod(f = "getObservationById",
signature = signature(sos = "SOS_1.0.0", observationId = "character"),
definition = function(sos, observationId, responseFormat, srsName,
resultModel, responseMode, verbose, inspect, saveOriginal) {
return(.getObservationById_1.0.0(sos = sos,
observationId = observationId,
responseFormat = responseFormat, srsName = srsName,
resultModel = resultModel,
responseMode = responseMode, verbose = verbose,
inspect = inspect, saveOriginal = saveOriginal))
}
)
.getObservationById_1.0.0 <- function(sos, observationId, responseFormat, srsName,
resultModel, responseMode, verbose, inspect, saveOriginal) {
if (verbose) cat("[.getObservationById_1.0.0] ID", observationId, "\n")
.filename <- NULL
if (!is.null(saveOriginal)) {
if (is.character(saveOriginal)) {
.filename <- saveOriginal
if (verbose) cat("[.getObservationById_1.0.0] Using saveOriginal parameter for file name:", .filename, "\n")
}
else if (is.logical(saveOriginal)) {
if (saveOriginal) .filename <- paste(observationId,
format(Sys.time(), sosDefaultFilenameTimeFormat),
".xml",
sep = "_")
if (verbose) cat("[.getObservationById_1.0.0] Generating file name:", .filename, "\n")
}
}
go <- SosGetObservationById(service = sosService,
version = sos@version,
observationId = observationId,
responseFormat = responseFormat,
srsName = srsName,
resultModel = resultModel,
responseMode = responseMode)
if (inspect) cat("[.getObservationById_1.0.0] REQUEST:\n", toString(go), "\n")
response = sosRequest(sos = sos,
request = go,
verbose = verbose,
inspect = inspect)
if (inspect) cat("[.getObservationById_1.0.0] RESPONSE:\n", toString(response), "\n")
if (!is.null(.filename)) {
xml2::write_xml(x = response, file = .filename)
cat("[sos4R] Original document saved:", .filename, "\n")
}
if (.isExceptionReport(response)) {
return(.handleExceptionReport(sos, response))
}
else {
parsingFunction <- sosParsers(sos)[[sosGetObservationByIdName]]
.obs <- parsingFunction(obj = response, sos = sos, verbose = verbose)
# remove list if only one element
if (is.list(.obs) && length(.obs) == 1)
.obs <- .obs[[1]]
if (verbose) {
cat("[.getObservationById_1.0.0] PARSED RESPONSE:\n")
print(.obs)
}
return(.obs)
}
}
.createGetObservation_1.0.0 <- function(sos, offeringId, observedProperty,
responseFormat, srsName, eventTime, procedure, featureOfInterest,
result, resultModel, responseMode, BBOX, verbose, inspect,
saveOriginal) {
go <- SosGetObservation(service = sosService, version = sos@version,
offering = offeringId, observedProperty = observedProperty,
responseFormat = responseFormat, srsName = srsName,
eventTime = eventTime, procedure = procedure,
featureOfInterest = featureOfInterest, result = result,
resultModel = resultModel, responseMode = responseMode,
BBOX = BBOX)
if (verbose) cat("[.createGetObservation_1.0.0] Done:\n", toString(go), "\n")
return(go)
}
.getObservation_1.0.0 <- function(sos, offeringId, observedProperty,
responseFormat, srsName, eventTime, procedure, featureOfInterest,
result, resultModel, responseMode, BBOX, verbose, inspect,
saveOriginal) {
.filename <- NULL
if (!is.null(saveOriginal)) {
if (is.character(saveOriginal)) {
.filename <- saveOriginal
if (verbose) cat("[.getObservation_1.0.0] Using saveOriginal parameter for file name:", .filename, "\n")
}
else if (is.logical(saveOriginal)) {
if (saveOriginal) .filename <- paste(.cleanupFileName(offeringId),
format(Sys.time(), sosDefaultFilenameTimeFormat),
".xml",
sep = "_")
if (verbose) cat("[.getObservation_1.0.0] Generated file name:", .filename, "\n")
}
}
if (verbose) cat("[.getObservation_1.0.0] to ", sos@url, " with offering ", offeringId, "\n")
go <- .createGetObservation_1.0.0(sos, offeringId, observedProperty,
responseFormat, srsName, eventTime, procedure, featureOfInterest,
result, resultModel, responseMode, BBOX, verbose, inspect,
saveOriginal)
if (verbose) cat("[.getObservation_1.0.0] REQUEST:\n\n", toString(go), "\n")
response = sosRequest(sos = sos,
request = go,
verbose = verbose,
inspect = inspect)
if (verbose) cat("[sos4R] Received response (object size:", utils::object.size(response), "bytes), parsing ...\n")
if (inherits(response, "xml_document")) {
if (verbose) cat("[.getObservation_1.0.0] Got XML document as response.\n")
if (inspect) {
cat("[.getObservation_1.0.0] RESPONSE DOC:\n")
print(response)
}
if (!is.null(.filename)) {
xml2::write_xml(x = response, file = .filename)
if (verbose) cat("[.getObservation_1.0.0] Saved original document:", .filename, "\n")
}
if (.isExceptionReport(response)) {
return(.handleExceptionReport(sos, response))
}
parsingFunction <- sosParsers(sos)[[sosGetObservationName]]
if (verbose) {
cat("[.getObservation_1.0.0] Parsing with function ")
print(parsingFunction)
}
.obs <- parsingFunction(obj = response,
sos = sos,
verbose = verbose)
# calculate result length vector
if (inherits(.obs, "OmObservationCollection")) {
if (verbose) cat("[.getObservationById_1.0.0] Got OmObservationCollection",
"... calculating length with sosResult()")
.result <- sosResult(.obs, bind = FALSE, coordinates = FALSE)
if (verbose) cat("[.getObservationById_1.0.0] result: ", toString(.result))
.resultLength <- sapply(.result, nrow)
if (length(.resultLength) == 0) # nothing
.resultLength = 0
}
else .resultLength <- NA
if (verbose) {
cat("[.getObservation_1.0.0] PARSED RESPONSE:", class(.obs), "\n")
cat("[.getObservation_1.0.0] Result length(s): ", toString(.resultLength), "\n")
}
if (is.list(.obs) && any(sapply(.obs, is.null))) {
.countInfo <- paste("NO DATA, turn on 'verbose' for more information.")
}
else {
.nonNulls <- Filter(Negate(function(x) is.null(unlist(x))), .resultLength)
.sum <- sum(unlist(.nonNulls))
.countInfo <- paste(.sum, "result values [", toString(.resultLength), "].")
}
if (verbose) cat("[sos4R] Finished getObservation to", sos@url,
"\n\t--> received", length(.obs), "observation(s) having", .countInfo , "\n")
if (!is.null(.filename)) cat("[sos4R] Original document saved:", .filename, "\n")
return(.obs)
}
else {# response is NOT an XML document:
if (verbose) cat("[.getObservation_1.0.0] Did NOT get XML document as response, trying to parse with", responseFormat, "\n")
if (is.na(responseFormat) || is.null(responseFormat)) {
if (verbose) cat("[.getObservation_1.0.0] responseFormat is ",
responseFormat, " >>> returning response string...\n")
return(response)
}
if (mimeTypeCSV == responseFormat) {
if (inspect) {
cat("[.getObservation_1.0.0] CSV RESPONSE:\n")
print(response)
}
parsingFunction <- sosParsers(sos)[[mimeTypeCSV]]
.csv <- parsingFunction(obj = response, verbose = verbose)
if (!is.null(.filename)) {
.filename <- paste(file = .filename, ".csv", sep = "")
utils::write.csv(.csv, .filename)
}
if (verbose) cat("[sos4R] Finished getObservation to", sos@url, "\n\t",
"--> received observations with dimensions", toString(dim(.csv)), "\n")
if (!is.null(.filename)) cat("[sos4R] Original document saved:", .filename, "\n")
return(.csv)
}
} # else
# not xml nor csv nore otherwise handled
if (inspect) {
cat("[.getObservation_1.0.0] UNKNOWN RESPONSE FORMAT; Response:\n'", response, "'\n")
warning("Unknown response format!")
}
if (!is.null(.filename)) {
save(response, file = .filename)
cat("[sos4R] Saved original document:", .filename)
}
return(response)
}
#
# getObservation ----
#
setMethod(f = "getObservation",
signature = signature(sos = "SOS_1.0.0",
offering = "SosObservationOffering"),
definition = function(sos,
offering,
observedProperty,
responseFormat,
srsName,
eventTime,
procedure = NA_character_,
featureOfInterest,
result,
resultModel,
responseMode,
BBOX,
verbose,
inspect,
saveOriginal) {
offeringId <- offering@id
if (verbose) cat("[getObservation] Requesting offering", offeringId, "with SosObservationOffering.\n")
if (is.na(responseFormat))
responseFormat <- sosDefaultGetObsResponseFormat
if (length(observedProperty) == 0) {
obsProps <- sosObservedProperties(sosOfferings(sos)[[offeringId]])
if (verbose) cat("[getObservation] Got observation(s) from offering because none given:", toString(obsProps), "\n")
}
else {
obsProps <- observedProperty
}
if (is.list(procedure) && length(procedure) == 0)
proc <- NA_character_
else proc <- procedure
return(.getObservation_1.0.0(sos = sos,
offeringId = offeringId,
observedProperty = obsProps,
responseFormat = responseFormat,
srsName = srsName,
eventTime = eventTime,
procedure = proc,
featureOfInterest = featureOfInterest,
result = result,
resultModel = resultModel,
responseMode = responseMode,
BBOX = BBOX,
verbose = verbose,
inspect = inspect,
saveOriginal = saveOriginal))
}
)
setMethod(f = "getObservation",
signature = signature(sos = "SOS_1.0.0",
offering = "character"),
definition = function(sos,
offering,
observedProperty,
responseFormat = sosDefaultGetObsResponseFormat,
srsName,
eventTime,
procedure,
featureOfInterest,
result,
resultModel,
responseMode,
BBOX,
verbose,
inspect,
saveOriginal) {
if (verbose) cat("[getObservation] Requesting offering", offering, "by name.\n")
if (is.na(responseFormat))
responseFormat <- sosDefaultGetObsResponseFormat
if (length(observedProperty) == 0) {
obsProps <- sosObservedProperties(sosOfferings(sos)[[offering]])
if (verbose) cat("[getObservation] Got observation(s) from offering because none given:", toString(obsProps), "\n")
}
else {
obsProps <- observedProperty
}
if (is.list(procedure) && length(procedure) == 0)
proc <- NA_character_
else proc <- procedure
return(.getObservation_1.0.0(sos = sos,
offeringId = offering,
observedProperty = obsProps,
responseFormat = responseFormat,
srsName = srsName,
eventTime = eventTime,
procedure = proc,
featureOfInterest = featureOfInterest,
result = result,
resultModel = resultModel,
responseMode = responseMode,
BBOX = BBOX,
verbose = verbose,
inspect = inspect,
saveOriginal = saveOriginal))
}
)
# see: http://www.oostethys.org/best-practices/best-practices-get
setMethod(f = "encodeRequestKVP", signature = signature(obj = "SosDescribeSensor"),
definition = function(obj, sos, verbose = FALSE) {
if (sos@version == sos100_version) {
return(.sosEncodeRequestKVPDescribeSensor_1.0.0(obj = obj,
sos = sos, verbose = verbose))
}
else if (sos@version == sos200_version) {
return(.sosEncodeRequestKVPDescribeSensor_2.0.0(obj = obj,
sos = sos, verbose = verbose))
}
else {
stop("Version not supported!")
}
}
)
.kvpBuildRequestBase <- function(sos, operation = sosGetCapabilitiesName) {
paste(
paste("service", .kvpEscapeSpecialCharacters(x = sosService), sep = "="),
paste("version", .kvpEscapeSpecialCharacters(x = sos@version), sep = "="),
paste("request", .kvpEscapeSpecialCharacters(x = operation), sep = "="),
sep = "&")
}
.sosEncodeRequestKVPDescribeSensor_1.0.0 <- function(obj, sos,
verbose = FALSE) {
# mandatory:
requestBase <- .kvpBuildRequestBase(sos, sosDescribeSensorName)
procedure <- paste("procedure", .kvpEscapeSpecialCharacters(x = obj@procedure), sep = "=")
format <- paste("outputFormat",
.kvpEscapeSpecialCharacters(x = gsub(obj@outputFormat,
pattern = """,
replacement = '"')),
sep = "=")
kvpString <- paste(requestBase,
procedure,
format,
sep = "&")
if (verbose) cat("[.sosEncodeRequestKVPDescribeSensor_1.0.0] ", kvpString)
return(kvpString)
}
setMethod(f = "encodeRequestKVP", signature = signature(obj = "SosGetObservation"),
definition = function(obj, sos, verbose = FALSE) {
if (sos@version == sos100_version) {
return(.sosEncodeRequestKVPGetObservation_1.0.0(obj, sos,
verbose))
} else if (sos@version == sos200_version) {
return(.sosEncodeRequestKVPGetObservation_2.0.0(obj, sos,
verbose))
}
else {
stop("Version not supported!")
}
}
)
.sosEncodeRequestKVPGetObservation_1.0.0 <- function(obj, sos,
verbose = FALSE) {
if (verbose) cat("[.sosEncodeRequestKVPGetObservation_1.0.0] encoding",
toString(obj), "\n")
# required:
.requestBase <- .kvpBuildRequestBase(sos, sosGetObservationName)
.offering <- paste(sosKVPParamNameOffering,
.kvpEscapeSpecialCharacters(x = obj@offering), sep = "=")
.observedProperty <- .kvpKeyAndValues(sosKVPParamNameObsProp,
obj@observedProperty)
.mandatory <- paste(.requestBase, .offering,
.observedProperty, sep = "&")
if (verbose) cat("[.sosEncodeRequestKVPGetObservation_1.0.0]",
"mandatory elements: ", .mandatory, "\n")
# optional:
optionals = ""
# is optional for GET
if (!is.na(obj@responseFormat)) {
if (verbose) cat("[.sosEncodeRequestKVPGetObservation_1.0.0] Adding response format ",
obj@responseFormat, "\n")
.noHTMLquotes <- gsub(obj@responseFormat,
pattern = """,
replacement = '"')
#.singleQuotes <- gsub(.noHTMLquotes,
# pattern = "\"",
# replacement = "'")
responseFormat <- paste(
sosKVPParamNameResponseFormat,
.kvpEscapeSpecialCharacters(x = .noHTMLquotes),
sep = "=")
optionals <- paste(optionals, responseFormat, sep = "&")
}
if (!is.na(obj@srsName)) {
if (verbose) cat("[.sosEncodeRequestKVPGetObservation_1.0.0] Adding SRS name ",
obj@srsName, "\n")
optionals <- paste(optionals, paste(sosKVPParamNameSrsName,
.kvpEscapeSpecialCharacters(x = obj@srsName),
sep = "="),
sep = "&")
}
if (!length(obj@eventTime) == 0) {
if (verbose) cat("[.sosEncodeRequestKVPGetObservation_1.0.0] Adding event time",
toString(obj@eventTime), "\n")
if (length(obj@eventTime) > 1)
warning("Only first event time in the list is used for KVP!")
timeString <- encodeKVP(obj = obj@eventTime[[1]],
sos = sos, verbose = verbose)
# if the eventTime is a latest request, it returns NA, the GET binding
# says for the latest observation eventTime is omitted
if (!is.na(timeString)) {
optionals <- paste(optionals, paste("eventTime",
.kvpEscapeSpecialCharacters(x = timeString),
sep = "="),
sep = "&")
}
else {
if (verbose) cat("[.sosEncodeRequestKVPGetObservation_1.0.0] ",
"encodeKVP returned NA for eventTime, omitting",
"parameter for request for latest observation.")
}
}
if (!any(sapply(obj@procedure, "is.na"), na.rm = TRUE)) {
if (verbose) cat("[.sosEncodeRequestKVPGetObservation_1.0.0] Adding procedures ",
obj@procedure, "\n")
optionals <- paste(optionals,
.kvpKeyAndValues(sosKVPParamNameProcedure, obj@procedure),
sep = "&")
}
if (!is.null(obj@featureOfInterest)) {
foiIDs <- obj@featureOfInterest@objectIDs
if (verbose) cat("[.sosEncodeRequestKVPGetObservation_1.0.0] Adding features ",
toString(obj@featureOfInterest), "by IDs ", toString(foiIDs), "\n")
optionals <- paste(optionals,
.kvpKeyAndValues(sosKVPParamNameFoi, foiIDs),
sep = "&")
# warning("'featureOfInterest' is not supported for 'GET' - parameter is discarded, use another method to include it!")
}
if (!is.null(obj@result)) {
warning("'result' is not supported for 'GET' - parameter is discarded, use another method to include it!")
}
if (!is.na(obj@resultModel)) {
if (verbose) cat("[.sosEncodeRequestKVPGetObservation_1.0.0] Adding result model ",
obj@resultModel, "\n")
optionals <- paste(optionals, paste(sosKVPParamNameResultModel,
.kvpEscapeSpecialCharacters(x = obj@resultModel),
sep = "="),
sep = "&")
}
if (!is.na(obj@responseMode)) {
if (verbose) cat("[.sosEncodeRequestKVPGetObservation_1.0.0] Adding response mode ",
obj@responseMode, "\n")
optionals <- paste(optionals, paste(sosKVPParamNameResponseMode,
.kvpEscapeSpecialCharacters(x = obj@responseMode),
sep = "="),
sep = "&")
}
if (!is.na(obj@BBOX)) {
if (verbose) cat("[.sosEncodeRequestKVPGetObservation_1.0.0] Adding BBOX ",
obj@BBOX, "\n")
optionals <- paste(optionals, paste(sosKVPParamNameBBOX,
.kvpEscapeSpecialCharacters(x = obj@BBOX), sep = "="),
sep = "&")
}
if (verbose) cat("[.sosEncodeRequestKVPGetObservation_1.0.0]",
"optional elements: ", optionals, "\n")
kvpString <- paste(.mandatory, optionals, sep = "")
if (verbose) cat("[.sosEncodeRequestKVPGetObservation_1.0.0]",
"Finished KVP string creation:\n", kvpString, "\n")
return(kvpString)
}
setMethod(f = "encodeRequestKVP", signature = signature(obj = "SosGetObservationById"),
definition = function(obj, sos, verbose = FALSE) {
if (sos@version == sos100_version) {
stop("KVP encoding of operation 'GetObservationById' not supported!")
} else if (sos@version == sos200_version) {
return(.sosEncodeRequestKVPGetObservationById_2.0.0(obj = obj,
sos = sos,
verbose = verbose))
} else {
stop("Version not supported!")
}
}
)
setMethod(f = "encodeRequestXML", signature = signature(obj = "SosGetObservation"),
definition = function(obj, sos, verbose = FALSE) {
if (verbose) {
cat("[encodeRequestXML]", class(obj), "\n")
}
if (sos@version == sos100_version) {
return(.sosEncodeRequestXMLGetObservation_1.0.0(obj = obj,
sos = sos,
verbose = verbose))
}
else if (sos@version == sos200_version) {
return(.sosEncodeRequestXMLGetObservation_2.0.0(obj = obj,
sos = sos,
verbose = verbose))
} else {
stop("Version not supported!")
}
}
)
.sosEncodeRequestXMLGetObservation_1.0.0 <- function(obj, sos, verbose = FALSE) {
xmlDoc <- xml2::xml_new_root(sosGetObservationName)
xml2::xml_set_attrs(x = xmlDoc,
value = c(xmlns = sos100Namespace,
service = obj@service,
version = sos@version,
"xmlns:xsi" = xsiNamespace,
"xmlns:ows" = owsNamespace,
"xmlns:sos" = sos100Namespace,
"xmlns:om" = omNamespace,
"xmlns:ogc" = ogcNamespace,
"xmlns:gml" = gmlNamespace))
# required and optional are mixed - schema requires a particular order:
xml2::xml_add_child(xmlDoc, sosOfferingName, obj@offering)
if (!length(obj@eventTime) == 0) {
eventTimeList <- lapply(X = obj@eventTime,
FUN = encodeXML,
sos = sos,
verbose = verbose)
for (et in eventTimeList) {
xml2::xml_add_child(xmlDoc, et)
}
}
if (!any(sapply(obj@procedure, "is.na"), na.rm = TRUE)) {
for (p in obj@procedure) {
xml2::xml_add_child(xmlDoc, sosProcedureName, p)
}
}
for (op in obj@observedProperty) {
xml2::xml_add_child(xmlDoc, sosObservedPropertyName, op)
}
if (!is.null(obj@featureOfInterest)) {
foi <- encodeXML(obj = obj@featureOfInterest,
sos = sos,
verbose = verbose)
xml2::xml_add_child(xmlDoc, foi)
}
if (!is.null(obj@result)) {
if (is.character(obj@result)) {
result <- encodeXML(obj = obj@result,
sos = sos,
addNamespaces = TRUE,
verbose = verbose)
}
else {
result <- encodeXML(obj = obj@result,
sos = sos,
verbose = verbose)
}
xml2::xml_add_child(xmlDoc, result)
}
if (!is.na(obj@responseFormat)) {
rF <- gsub(obj@responseFormat, pattern = """, replacement = "\"")
xml2::xml_add_child(xmlDoc, sosResponseFormatName, rF)
}
if (!is.na(obj@resultModel)) {
xml2::xml_add_child(xmlDoc, sosResultModelName, obj@resultModel)
}
if (!is.na(obj@responseMode)) {
xml2::xml_add_child(xmlDoc, sosResponseModeName, obj@responseMode)
}
if (!is.na(obj@srsName)) {
xml2::xml_set_attr(x = xmlDoc, attr = "srsName", value = obj@updateSequence)
}
if (!is.na(obj@BBOX)) {
warning("GetObservation contains BBOX, but that is not supported for 'POST' and ignored.",
"This is also not in the SOS Specification - use featureOfInterest instead!")
}
return(xmlDoc)
}
setMethod(f = "encodeRequestXML", signature = signature(obj = "SosGetObservationById"),
definition = function(obj, sos, verbose = FALSE) {
if (verbose) {
cat("[encodeRequestXML]", class(obj), "\n")
}
if (sos@version == sos100_version) {
return(.sosEncodeRequestXMLGetObservationById_1.0.0(obj = obj,
sos = sos))
}
if (sos@version == sos200_version) {
return(.sosEncodeRequestXMLGetObservationById_2.0.0(obj = obj,
sos = sos))
}
else {
stop("Version not supported!")
}
}
)
.sosEncodeRequestXMLGetObservationById_1.0.0 <- function(obj, sos) {
xmlDoc <- xml2::xml_new_root(sosGetObservationByIdName)
xml2::xml_set_attrs(x = xmlDoc,
value = c(xmlns = sos100Namespace,
service = obj@service,
version = obj@version,
"xmlns:xsi" = xsiNamespace,
"xmlns:sos" = sos100Namespace))
xml2::xml_add_child(xmlDoc, sosObservationIdName, obj@observationId)
rF <- gsub(obj@responseFormat, pattern = """, replacement = "\"")
xml2::xml_add_child(xmlDoc, sosResponseFormatName, rF)
if (!is.na(obj@resultModel)) {
xml2::xml_add_child(xmlDoc, sosResultModelName, obj@resultModel)
}
if (!is.na(obj@responseMode)) {
xml2::xml_add_child(xmlDoc, sosResponseModeName, obj@responseMode)
}
if (!is.na(obj@srsName)) {
xml2::xml_set_attr(x = xmlDoc, attr = "srsName", value = obj@updateSequence)
}
return(xmlDoc)
}
setMethod(f = "encodeRequestXML", signature = signature(obj = "SosDescribeSensor"),
definition = function(obj, sos, verbose = FALSE) {
if (verbose) {
cat("[encodeRequestXML]", class(obj), "\n")
}
if (sos@version == sos100_version) {
if (verbose) cat("[encodeRequestXML] encoding for SOS 1.0.0\n")
return(.sosEncodeRequestXMLDescribeSensor_1.0.0(obj = obj, sos = sos))
}
else if (sos@version == sos200_version) {
if (verbose) cat("[encodeRequestXML] encoding for SOS 1.0.0\n")
return(.sosEncodeRequestXMLDescribeSensor_2.0.0(obj = obj, sos = sos))
}
else {
stop("[encodeRequestXML] Version not supported for operation DescribeSensor!")
}
}
)
.sosEncodeRequestXMLDescribeSensor_1.0.0 <- function(obj, sos) {
xmlDoc <- xml2::xml_new_root(sosDescribeSensorName)
xml2::xml_set_attrs(x = xmlDoc,
value = c(xmlns = sos100Namespace,
"xmlns:xsi" = xsiNamespace,
service = obj@service,
outputFormat = obj@outputFormat,
version = sos@version),
ns = sos@namespaces)
xml2::xml_add_child(xmlDoc, "procedure", obj@procedure)
return(xmlDoc)
}
#
# encoding functions for SOAP ----
#
setMethod("encodeRequestSOAP", "SosDescribeSensor",
function(obj, sos, verbose = FALSE) {
if (verbose) {
cat("ENCODE SOAP ", class(obj), "\n")
}
stop("Method not implemented yet!")
}
)
setMethod("encodeRequestSOAP", "SosGetObservation",
function(obj, sos, verbose = FALSE) {
if (verbose) {
cat("ENCODE SOAP ", class(obj), "\n")
}
stop("Method not implemented yet!")
}
)
setMethod("encodeRequestSOAP", "SosGetObservationById",
function(obj, sos, verbose = FALSE) {
if (verbose) {
cat("ENCODE SOAP ", class(obj), "\n")
}
stop("Method not implemented yet!")
}
)
#
# encoding functions XML ----
#
setMethod(f = "encodeXML",
signature = signature(obj = "SosEventTime", sos = "SOS"),
function(obj, sos, verbose = FALSE) {
if (verbose) cat("[encodeXML] SosEventTime", class(obj), "\n")
.temporalOpsClass <- class(obj@temporalOps)
if (!is.null(SosSupportedTemporalOperators()[[.temporalOpsClass]])) {
# FIXME: https://github.com/r-lib/xml2/issues/239
#eventTime <- xml2::xml_new_root(sosEventTimeName, xmlns = sos100Namespace)
eventTime <- xml2::read_xml(paste0("<", sosEventTimeName,
" xmlns:", sos100NamespacePrefix, "=\"", sos100Namespace,
"\" />"))
temporalOpsXML <- encodeXML(obj = obj@temporalOps, sos = sos, verbose = verbose)
xml2::xml_add_child(eventTime, temporalOpsXML)
return(eventTime)
}
else {
stop(paste("temporalOps type not supported:",
.temporalOpsClass))
}
}
)
setMethod(f = "encodeXML",
signature = signature(obj = "SosFeatureOfInterest", sos = "SOS"),
function(obj, sos, verbose = FALSE) {
if (verbose) cat("[encodeXML]", class(obj), "\n")
# FIXME: https://github.com/r-lib/xml2/issues/239
#foi <- xml2::xml_new_root(sosEventTimeName, xmlns = sos100Namespace)
foi <- xml2::read_xml(paste0("<", sosFeatureOfInterestName,
" xmlns:", sos100NamespacePrefix, "=\"", sos100Namespace,
"\" />"))
# switch between objectIDs and spatialOps
if (!any(is.na(obj@objectIDs))) {
for (id in obj@objectIDs) {
xml2::xml_add_child(foi, sosObjectIDName, id)
}
}
else if (!is.null(obj@spatialOps)) {
spOp <- encodeXML(obj = obj@spatialOps, sos = sos, verbose = verbose)
xml2::xml_add_child(foi, spOp)
}
return(foi)
}
)
#
# to make just the time encoding interchangeable by users
#
# encodeXML(POSIXt, SOS) ----
#
setMethod(f = "encodeXML",
signature = signature(obj = "POSIXt", sos = "SOS"),
definition = function(obj, sos, verbose = FALSE) {
if (verbose) cat("[encodeXML] POSIXt with value", toString(obj), "\n")
formatted <- parsedate::format_iso_8601(obj)
if (verbose) cat("Formatted ", obj, " to ", formatted)
return(formatted)
}
)
#
# encodeKVP(SosEventTime, SOS) ----
#
setMethod(f = "encodeKVP",
signature = signature(obj = "SosEventTime", sos = "SOS"),
function(obj, sos, verbose = FALSE) {
if (verbose) cat("[encodeKVP] ", class(obj), "\n")
temporalOpsKVP <- encodeKVP(obj = obj@temporalOps,
sos = sos,
verbose = verbose)
return(temporalOpsKVP)
}
)
#
# to make just the time encoding interchangeable by users
#
# encodeKVP(POSIXt, SOS) ----
#
setMethod(f = "encodeKVP",
signature = signature(obj = "POSIXt", sos = "SOS"),
definition = function(obj, sos, verbose) {
if (verbose) cat("[encodeKVP] POSIXt with value", toString(obj), "\n")
formatted <- parsedate::format_iso_8601(obj)
if (verbose) cat("Formatted ", obj, " to ", formatted, "\n")
return(formatted)
}
)
#
# util functions for getting content from response ----
#
.processResponse <- function(response, verbose) {
contentType <- httr::http_type(response)
if (!httr::has_content(response)) {
warning("Response has no content: ", toString(response),
" | headers: ", paste(names(httr::headers(response)),
httr::headers(response),
sep = ": ",
collapse = "; "))
}
if (verbose) cat("[.processResponse] Response status: ", httr::status_code(response),
" | type: ", contentType, "\n")
if (httr::status_code(response) == 405)
warning("Response is HTTP 405 - Method Not Allowed: Please check if endpoint and binding match.")
httr::stop_for_status(response, "sending request to SOS")
if (contentType == "text/plain") {
text <- httr::content(response)
if (length(text) > 0 &
regexpr("(<html>|<HTML>|<!DOCTYPE HTML|<!DOCTYPE html)", text) > 0) {
stop(paste("[sos4R] ERROR: Got HTML response!:\n", text, "\n\n"))
}
xml <- xml2::read_xml(text)
return(xml)
}
else if (contentType == "text/csv") {
if (!requireNamespace("readr", quietly = TRUE))
stop("package readr required to handle text/csv format, please install")
tibble <- httr::content(x = response, encoding = sosDefaultCharacterEncoding)
return(tibble)
}
else if (contentType == "application/xml" || contentType == "text/xml") {
xml <- httr::content(x = response, encoding = sosDefaultCharacterEncoding)
return(xml)
}
else if (contentType == "application/octet-stream") {
content <- httr::content(response)
if (is.raw((content))) {
content <- rawToChar(content)
}
xml <- xml2::read_xml(content)
if (!inherits(xml, c("xml_node", "xml_document", "xml_nodeset"))) {
stop(paste("[sos4R]: ERROR: Received content as 'application/octet-stream' that could not be parsed to xml:\n",
content, "\n\n"))
}
return(xml)
}
stop(paste0("Unsupported content type in response: '", contentType, "'."))
}
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.