R/SOS-methods-util.R

Defines functions sosCheatSheet .encodeAdditionalKVPs .sosFilterDCPs .cleanupColumnName .cleanupFileName .getCRSfromOM .handleExceptionReport .isExceptionReport .sosCreateEventTimeListFromPeriod .sosCreateEventTimeListFromInstance sosConvertFactor sosConvertInteger sosConvertLogical sosConvertString sosConvertDouble sosConvertTime

Documented in sosCheatSheet sosConvertDouble sosConvertFactor sosConvertInteger sosConvertLogical sosConvertString sosConvertTime

############################################################################## #
# 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-21                                                          #
# Project: sos4R - https://github.com/52North/sos4R                            #
#                                                                              #
############################################################################## #
#
# conversion methods ----
#
sosConvertTime <- function(x, sos) {
  parsedTimestamp <- parsedate::parse_iso_8601(x)
  if (any(is.na(parsedTimestamp)))
    warning("Error converting string '", x, "' to 'ISO8601' format! Returning 'NA'")
  attributes(parsedTimestamp) <- c(attributes(parsedTimestamp), "original_value" = x)
  return(parsedTimestamp)
}

sosConvertDouble <- function(x, sos) {
  return(as.double(x = x))
}

sosConvertString <- function(x, sos) {
  return(as.character(x = x))
}

sosConvertLogical <- function(x, sos) {
  return(as.logical(x = x))
}

sosConvertInteger <- function(x, sos) {
  return(as.integer(x = x))
}

sosConvertFactor <- function(x, sos) {
  return(as.factor(x = x))
}


#
# convenience functions time class creation ----
#
setMethod(f = "sosCreateTimeInstant",
          signature = signature(sos = "SOS", time = "POSIXt"),
          definition = function(sos, time, frame, calendarEraName,
                                indeterminatePosition) {
            .timePos <- GmlTimePosition(
              time = time,
              frame = frame, calendarEraName = calendarEraName,
              indeterminatePosition = indeterminatePosition)
            .ti <- GmlTimeInstant(timePosition = .timePos)
            return(.ti)
          }
)

setMethod(f = "sosCreateTimePeriod",
          signature = signature(sos = "SOS", begin = "POSIXt", end = "POSIXt"),
          definition = function(sos, begin, end, frame, calendarEraName,
                                indeterminatePosition, duration, timeInterval) {
            .beginPos <- GmlTimePosition(
              time = begin,
              frame = frame, calendarEraName = calendarEraName,
              indeterminatePosition = indeterminatePosition
            )
            .endPos <- GmlTimePosition(
              time = end,
              frame = frame, calendarEraName = calendarEraName,
              indeterminatePosition = indeterminatePosition
            )
            .tp <- GmlTimePeriod(beginPosition = .beginPos,
                                 endPosition = .endPos,
                                 duration = duration,
                                 timeInterval = timeInterval)
            return(.tp)
          }
)

setMethod(f = "sosCreateEventTimeList",
          signature = signature(time = "GmlTimeGeometricPrimitive"),
          definition = function(time, operator) {
            .et <- list(sosCreateEventTime(time = time, operator = operator))
            return(.et)
          }
)

setMethod(f = "sosCreateTime",
          signature = signature(sos = "SOS", time = "character"),
          definition = function(sos, time, operator) {
            .l <- NULL
            if (regexpr(pattern = "::", text = time) > -1) {
              .l <- .sosCreateEventTimeListFromPeriod(sos = sos, time = time,
                                                      operator = operator, seperator = "::")
            }
            else if (regexpr(pattern = "/", text = time) > -1) {
              .l <- .sosCreateEventTimeListFromPeriod(sos = sos, time = time,
                                                      operator = operator, seperator = "/")
            }
            else {
              # not a period
              .l <- .sosCreateEventTimeListFromInstance(sos = sos, time = time,
                                                        operator = operator)
            }

            if (is.null(.l)) stop("[sosCreateTime] could not create time.")

            return(.l)
          }
)

.sosCreateEventTimeListFromInstance <- function(sos, time,
                                                operator = SosSupportedTemporalOperators()[["TM_Equals"]]) {
  .ti <- sosCreateTimeInstant(sos = sos, time = parsedate::parse_iso_8601(time))
  .l <- sosCreateEventTimeList(time = .ti,
                               operator = SosSupportedTemporalOperators()[[operator]])

  return(.l)
}

.sosCreateEventTimeListFromPeriod <- function(sos, time, operator, seperator) {
  .times <- strsplit(x = time, split = seperator)[[1]]
  .start <- .times[[1]]
  if (length(.times) > 1)
    .end <- .times[[2]]
  else .end <- NULL

  if (is.null(.start) && is.null(.end)) {
    warning("Both start and endtime are null based on given time. Returning empty list!")
    return(list())
  }
  else {
    if (is.null(.end)) {
      # no end time:
      .ti <- sosCreateTimeInstant(sos = sos, time = parsedate::parse_iso_8601(.start))
      .l <- sosCreateEventTimeList(time = .ti,
                                   operator = SosSupportedTemporalOperators()[[ogcTempOpTMAfterName]])
    }
    else if (nchar(.start) > 0) {
      .tp <- sosCreateTimePeriod(sos = sos, begin = parsedate::parse_iso_8601(.start),
                                 end = parsedate::parse_iso_8601(.end))
      .l <- sosCreateEventTimeList(.tp)
    }
    else if (nchar(.start) < 1) {
      # no start time:
      .ti <- sosCreateTimeInstant(sos = sos, time = parsedate::parse_iso_8601(.end))
      .l <- sosCreateEventTimeList(time = .ti,
                                   operator = SosSupportedTemporalOperators()[[ogcTempOpTMBeforeName]])
    }
  }
  return(.l)
}

setMethod(f = "sosCreateEventTime",
          signature = signature(time = "GmlTimeObject"),
          definition = function(time, operator) {

            if (operator == ogcTempOpTMAfterName) {
              .tOps <- TM_After(time = time)
            }
            else if (operator == ogcTempOpTMBeforeName) {
              .tOps <- TM_Before(time = time)
            }
            else if (operator == ogcTempOpTMDuringName) {
              .tOps <- TM_During(time = time)
            }
            else if (operator == ogcTempOpTMEqualsName) {
              .tOps <- TM_Equals(time = time)
            }
            else {
              stop(paste("Given operator", operator, "is not supported,",
                         "choose one of",
                         toString(SosSupportedTemporalOperators())))
            }

            .et <- SosEventTime(.tOps)
            return(.et)
          }
)

#
# convenience function FOI ----
#
setMethod(f = "sosCreateFeatureOfInterest",
          signature = signature(),
          definition = function(objectIDs, spatialOps, bbox, srsName) {
            # switch cases, either objectIDs or one of the spatialOps shortcuts
            if (!any(is.na(objectIDs))) {
              .foi <- SosFeatureOfInterest(objectIDs = objectIDs)
            }
            else if (!is.null(spatialOps)) {
              .foi <- SosFeatureOfInterest(spatialOps = spatialOps)
            }
            else if (!is.null(bbox)) {
              if (is.matrix(bbox)) {
                .env <- GmlEnvelope(
                  lowerCorner = GmlDirectPositionLatLon(lat = bbox[2,1],
                                                        lon = bbox[1,1]),
                  upperCorner = GmlDirectPositionLatLon(lat = bbox[2,2],
                                                        lon = bbox[1,2]),
                  srsName = srsName)
                .bbox <- OgcBBOX(envelope = .env)
                .foi <- SosFeatureOfInterest(spatialOps = .bbox)
              }
              else {
                stop("bbox must be matrix!")
              }
            }
            else {
              stop("At least one of objectIDs or spatialOps has to be set!")
            }

            return(.foi)
          }
)

#
# convenience functions BBOX ----
#
setMethod(f = "sosCreateBBOX",
          signature = signature(lowLat = "numeric", lowLon = "numeric",
                                uppLat = "numeric", uppLon = "numeric"),
          definition = function(lowLat, lowLon, uppLat, uppLon, srsName,
                                srsDimension = NA_integer_, axisLabels = NA_character_,
                                uomLabels = NA_character_,
                                propertyName = sosDefaultSpatialOpPropertyName) {
            .env <- GmlEnvelope(
              lowerCorner = GmlDirectPosition(
                pos = paste(lowLat, lowLon, sep = " ")),
              upperCorner = GmlDirectPosition(
                pos = paste(uppLat, uppLon, sep = " ")),
              srsName = srsName, srsDimension = srsDimension,
              axisLabels = axisLabels, uomLabels = uomLabels)

            .bbox <- OgcBBOX(propertyName = propertyName, envelope = .env)
            return(.bbox)
          }
)

setMethod(f = "sosCreateBBoxMatrix",
          signature = signature(lowLat = "numeric", lowLon = "numeric",
                                uppLat = "numeric", uppLon = "numeric"),
          definition = function(lowLat, lowLon, uppLat, uppLon) {
            .m <- matrix(data = c(lowLon, lowLat, uppLon, uppLat),
                         nrow = 2, ncol = 2,
                         dimnames = list(
                           c("longitude", "latitude"),
                           c("lowerCorner", "upperCorner")))
            return(.m)
          }
)

#
# helpers capabilities ----
#
setMethod(f = "sosCapabilitiesDocumentOriginal",
          signature = signature(sos = "SOS"),
          definition = function(sos, verbose = FALSE) {
            verbose <- sos@verboseOutput || verbose
            gc <- OwsGetCapabilities(service = sosService,
                                     acceptVersions = c(sos@version))
            response = sosRequest(sos = sos,
                                  request = gc,
                                  verbose = verbose,
                                  inspect = FALSE)
            return(response)
          }
)

setMethod(f = "sosCapabilitiesUrl",
          signature = signature(sos = "SOS"),
          definition = function(sos) {
            gc <- OwsGetCapabilities(service = sosService,
                                     acceptVersions = c(sos@version))
            request <- paste0(sosUrl(sos), "?", encodeRequestKVP(gc, sos))
            return(request)
          }
)

#
# helpers for exception response handling ----
#
.isExceptionReport <- function(obj) {
  if (inherits(obj, "xml_document")) {
    name <- xml2::xml_name(x = xml2::xml_root(x = obj)) # intentionally without namespaces
    return(owsExceptionReportNameOnly == name)
  }
  else if (is.raw(obj) && startsWith(rawToChar(obj), "<?xml")) {
    return(grepl("ExceptionReport", rawToChar(obj), fixed = TRUE))
  }
  else if (is.character(obj) && startsWith(obj, "<?xml")) {
    return(grepl("ExceptionReport", obj, fixed = TRUE))
  }
  else if (is.list(obj)) {
    return(!is.null(obj[["exceptions"]]))
  }
  stop("Unsupported input for function .isExceptionReport")
}

.handleExceptionReport <- function(sos, obj) {
  if (sos@verboseOutput) warning("Received ExceptionReport!")
  .parsingFunction <- sosParsers(sos)[[owsExceptionReportName]]
  .er <- .parsingFunction(obj, sos = sos)
  if (any(class(.er) == "OwsExceptionReport"))
    warning(toString(.er))
  return(.er)
}

setMethod(f = "sosExceptionCodeMeaning",
          signature = c(exceptionCode = "character"),
          definition = function(exceptionCode) {
            .meaning <- as.character(
              .owsStandardExceptions[
                .owsStandardExceptions$exceptionCode == exceptionCode,
                2])
            return(.meaning)
          }
)

#
# encoding functions ----
#
setMethod(f = "encodeXML", signature = signature(obj = "xml_node", sos = "SOS"),
          definition = function(obj, sos, verbose = FALSE) {
            if (verbose) cat("[encodeXML] from xml_node: just returning it.\n")
            return(obj)
          }
)

setMethod(f = "encodeXML", signature = signature(obj = "xml_document", sos = "SOS"),
          definition = function(obj, sos, verbose = FALSE) {
            if (verbose) cat("[encodeXML] from xml_document: just returning it.\n")
            return(obj)
          }
)

setMethod(f = "encodeXML", signature = signature(obj = "character", sos = "SOS"),
          definition = function(obj, sos, verbose = FALSE) {
            if (verbose) cat("[encodeXML] from character string\n")
            .xml <- xml2::read_xml(x = obj, options = SosDefaultParsingOptions())
            if (verbose) cat("[encodeXML] Created XML from string:\n", toString(.xml))
            return(.xml)
          }
)

#
# convenience function CRS ----
#
setMethod(f = "sosGetCRS",
          signature = c(obj = "character"),
          definition = function(obj, verbose = FALSE) {
            if (verbose) cat("[sosGetCRS] from '", obj, "'\n", sep = "")

            .epsg <- NA
            # URN
            if (grepl(pattern = "urn:ogc", x = obj)) {
              .epsg <- sub(pattern = "(.*)epsg:[0-9]*(:?)",
                           replacement = "",
                           x = tolower(obj))[[1]]
            }
            # URL
            if (grepl(pattern = "opengis.net", x = obj)) {
              .epsg <- sub(pattern = "(.*)epsg/[0-9]*(/?)",
                           replacement = "",
                           x = tolower(obj))[[1]]
            }

            if (is.na(.epsg)) {
              warning("Could not create CRS from string ", obj)
              return(NA)
            }

            .initString <- paste("+init=epsg", .epsg, sep = ":")

            if (verbose) cat("[sosGetCRS] .initString:", .initString, "\n")

            .rgdal <- requireNamespace("rgdal", quietly = TRUE)
            if (!.rgdal)
              # if (!("rgdal" %in% .packages())) does only check loaded pkgs
              warning("[sosGetCRS] rgdal not present: CRS values will not be validated.",
                      immediate. = TRUE)
            else
              if (verbose) cat("[sosGetCRS] rgdal loaded! \n")

            crs <- NULL
            tryCatch({
              crs <- sp::CRS(.initString)
            }, error = function(err) {
              warning("[sosGetCRS] error was detected, probably the ",
                      "EPSG code ", .epsg, " is not recognized ",
                      "(returning NULL):", toString(err))
            })


            if (verbose) {
              cat("[sosGetCRS] found: ")
              show(crs)
            }

            return(crs)
          }
)
setMethod(f = "sosGetCRS",
          signature = c(obj = "OmObservationCollection"),
          definition = function(obj, verbose = FALSE) {
            .l <- lapply(X = obj, FUN = sosGetCRS, verbose = verbose)
            .l <- unique(.l)

            if (length(.l) == 1)
              return(.l[[1]])
            else return(.l)
          }
)
setMethod(f = "sosGetCRS",
          signature = c(obj = "OmObservation"),
          definition = function(obj, verbose = FALSE) {
            crs <- .getCRSfromOM(obj)
            return(crs)
          }
)
setMethod(f = "sosGetCRS",
          signature = c(obj = "OmMeasurement"),
          definition = function(obj, verbose = FALSE) {
            crs <- .getCRSfromOM(obj)
            return(crs)
          }
)
setMethod(f = "sosGetCRS",
          signature = c(obj = "SosObservationOffering"),
          definition = function(obj, verbose = FALSE) {
            .srsName <- sosBoundedBy(obj)[["srsName"]]
            if (is.null(.srsName))
              crs <- NULL
            else crs <- sosGetCRS(.srsName, verbose = verbose)
            return(crs)
          }
)
setMethod(f = "sosGetCRS",
          signature = c(obj = "SOS"),
          definition = function(obj, verbose = FALSE) {
            .offs <- sosOfferings(obj)
            crss <- lapply(.offs, sosGetCRS, verbose = verbose)
            if (length(crss) == 1)
              return(crss[[1]])
            return(crss)
          }
)
setMethod(f = "sosGetCRS",
          signature = c(obj = "list"),
          definition = function(obj, verbose = FALSE) {
            crs <- lapply(X = obj, FUN = sosGetCRS, verbose = verbose)
            return(crs)
          }
)
setMethod(f = "sosGetCRS",
          signature = c(obj = "GmlDirectPosition"),
          definition = function(obj, verbose = FALSE) {
            crs <- sosGetCRS(obj = obj@srsName)
            return(crs)
          }
)
setMethod(f = "sosGetCRS",
          signature = c(obj = "GmlPoint"),
          definition = function(obj, verbose = FALSE) {
            crs <- sosGetCRS(obj = obj@pos)
            return(crs)
          }
)
setMethod(f = "sosGetCRS",
          signature = c(obj = "GmlPointProperty"),
          definition = function(obj, verbose = FALSE) {
            crs <- sosGetCRS(obj = obj@point)
            return(crs)
          }
)
setMethod(f = "sosGetCRS",
          signature = c(obj = "GmlEnvelope"),
          definition = function(obj, verbose = FALSE) {
            crs <- sosGetCRS(obj = obj@srsName)
            return(crs)
          }
)
.getCRSfromOM <- function(obj) {
  .char <- as.vector(sosCoordinates(obj)[[sosDefaultColumnNameSRS]])
  .l <- sapply(X = .char, FUN = sosGetCRS)
  .l <- unique(.l)

  if (length(.l) == 1)
    return(.l[[1]])
  else return(.l)
}


#
# internal utils ----
#
.cleanupFileName <- function(obj) {
  # cleans up ", *, :, /, <, >, ?, \, and |
  .clean <- gsub(
    pattern = "[\\/:\"|?<>*,]+",
    x = obj,
    replacement = "_")
  return(.clean)
}

.illegalColumnNameCharacters <- list("\\[", "\\]", "@", "\\$", "~",
                                     "\\+", "-", "\\*")
.illegalColumnNameEscapeCharacter <- "."

.cleanupColumnName <- function(name) {
  # replace illegal characters
  .name <- name

  for (.x in .illegalColumnNameCharacters) {
    # replace multiple escape characters with one
    .name <- gsub(pattern = .x,
                  replacement = .illegalColumnNameEscapeCharacter,
                  x = .name)
  }

  .name <- gsub(pattern = paste("(\\",
                                .illegalColumnNameEscapeCharacter, ")+", sep = ""),
                replacement = .illegalColumnNameEscapeCharacter, x = .name)
  return(.name)
}

.sosFilterDCPs <- function(dcp, pattern, verbose = FALSE) {
  if (length(pattern) == 0) {
    if (verbose) cat("[.sosFilterDCPs] Pattern is empty (for this binding), returning DCPs unchanged.\n")
    return(dcp)
  }

  if (verbose)
    cat("[.sosFilterDCPs] Applying pattern", toString(pattern), "to",
        toString(dcp), "\n")

  .idx <- grep(pattern = pattern, x = dcp)
  .filtered <- dcp[.idx]
  if (verbose) cat("[.sosFilterDCPs] Filtered from\n\t",
                   toString(dcp), "\n\tto\n\t", toString(.filtered), "\n")

  if (length(.filtered) != 1) warnings("DCP filtering did not lead to unique result: ",
                                       toString(.filtered))

  return(.filtered)
}

.encodeAdditionalKVPs <- function(kvps) {
  .kvpsString <- ""
  for (i in seq(1:length(kvps))) {
    .kvp <- paste(names(kvps)[[i]], kvps[[i]], sep = "=")
    .kvpsString <- paste(.kvpsString, .kvp, sep = "&")
  }
  # remove starting &
  .kvpsString <- substring(.kvpsString, 2, nchar(.kvpsString))

  return(.kvpsString)
}


#
# cheat sheet ----
#
sosCheatSheet <- function() {
  path <- file.path(find.package("sos4R", lib.loc = NULL),
                    "sos4r_cheat-sheet.pdf")

  cat("Cheat sheet file available at ", path,"\n")
  return(path)
}
52North/sos4R documentation built on Jan. 30, 2021, 11:42 p.m.