Nothing
R/argument_types.R
In openeo: Client Interface for 'openEO' Servers
Defines functions
parameterFromJson
processFromJson
findParameterGenerator
# Parameter ====
# should also be abstract
#' Parameter class
#'
#' This class defines parameters of [Process()]. They store information about the type, format and
#' pattern. A parameter class is designed to not carry any value, as opposed to an
#' [Argument()].
#'
#' The parameters are parsed from the specific description and format of the JSON
#' objects returned for the parameters in processes. Find a list of openEO-specific formats here:
#' [RFC7946](https://github.com/Open-EO/openeo-processes/blob/master/meta/subtype-schemas.json)
#'
#' @name Parameter
#'
#' @return Object of [R6Class()] which represents a parameter.
#'
#'
#' @section Methods:
#' \describe{
#' \item{`$new(name, description, required=FALSE)`}{}
#' \item{`$getName`}{returns the name of a parameter as string}
#' \item{`$setName(name)`}{sets the name of a parameter}
#' \item{`$getDescription()`}{returns the description of a parameter}
#' \item{`$setDescription(description)`}{sets the description of a parameter}
#' \item{`$getPattern()`}{returns a string with the pattern of a parameter description}
#' \item{`$setPattern(pattern)`}{sets the pattern (string) for a parameter}
#' \item{`$getDefault()`}{returns the parameter's default value}
#' \item{`$setDefault(default)`}{sets the default value of a parameter}
#' \item{`$matchesSchema(schema)`}{returns TRUE if the given schema - a list of the parsed openEO
#' API schema object - matches the parameter's schema, which is used for finding the corresponding parameter}
#' \item{`$getSchema()`}{returns the schema definition}
#' \item{`$asParameterInfo()`}{returns a list representation of this parameter for being sent in a JSON to the openEO service}
#' \item{`$isNullable()`}{returns TRUE if the parameter is allowed to be nullable, FALSE otherwise}
#' \item{`$isRequired()`}{returns whether a parameter is mandatory or not}
#' \item{`$isAny()`}{returns TRUE if this parameter describes a choice of parameters}
#' }
#' @section Arguments:
#' \describe{
#' \item{`name`}{character - The name of a parameter}
#' \item{`description`}{character - The description of a parameter}
#' \item{`required`}{logical - whether it is required or not }
#' \item{`pattern`}{the regexp as a string indicating how to formulate the value}
#' \item{`default`}{the regexp as a string indicating how to formulate the value}
#' \item{`schema`}{the parsed schema object of a process parameter as a list}
#' }
#'
#' @importFrom rlang is_na
NULL
Parameter = R6Class(
"Parameter",
public = list(
initialize=function(name=character(), description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = FALSE
},
getName = function() {
return(private$name)
},
setName = function(name) {
private$name = name
},
getDescription = function() {
return(private$description)
},
setDescription = function(description) {
private$description = description
invisible(self)
},
getPattern = function() {
return(private$schema$pattern)
},
setPattern = function(pattern) {
private$schema$pattern = pattern
},
getEnum = function() {
return(private$schema$enum)
},
setEnum = function(enum){
private$schema$enum = enum
},
setDefault = function(default) {
private$default = default
invisible(self)
},
getDefault = function() {
return(private$default)
},
matchesSchema = function(schema) {
sel = c("type","subtype")
if (is.null(schema$type)) schema$type = character()
if (is.null(schema$subtype)) schema$subtype = character()
if (length(schema$type) == 0 && length(schema$subtype) == 0) return(TRUE)
return(setequal(private$schema[sel], schema[sel]))
},
getSchema = function() {
return(private$schema)
},
asParameterInfo = function() {
# the function will serialize a parameter as in a process definition, which will be used
# when describing a parameter as some sort of a variable
info = list()
info$name = self$getName()
if (length(self$getDescription()) > 0) {
if (!is.na(self$getDescription()) || nchar(self$getDescription()) > 0) {
info$description = self$getDescription()
}
}
if (self$isNullable) {
info$optional = TRUE
info$default = NA
}
# if the parameter is required "optional" can be left out
if (all(c("Argument","Parameter","R6") %in% class(self)) &&
all(class(self) %in% c("Argument","Parameter","R6"))) {
# this is an object where anything goes in (Any)
info$schema = list(description = "Any data type")
} else if (all(c("anyOf","Argument","Parameter","R6") %in% class(self))) {
info$schema = lapply(self$getChoice(), function(param) {
param$asParameterInfo()
})
if (self$isNullable) {
info$schema = append(private$schema, list(list(type = "null")))
}
} else if (self$isNullable) {
info$schema$type = list(private$schema$type,"null")
} else {
info$schema = private$schema
}
info$schema = .clean_empty_fields(info$schema)
return(info)
}
),
active = list(
isNullable = function(value) {
if (missing(value)) {
return(private$nullable)
} else {
value = as.logical(value)
if (rlang::is_na(value)) {
warning("Cannot cast value to logical. Assume FALSE.")
value = FALSE
}
private$nullable = value
}
},
isRequired = function(value) {
if (missing(value)) {
return(private$required)
} else {
value = as.logical(value)
if (rlang::is_na(value)) {
warning("Cannot cast value to logical. Assume FALSE.")
value = FALSE
}
private$required = value
}
},
isAny = function() {
length(private$schema$type) == 0
}
),
private = list(
name=character(),
nullable = FALSE,
default = character(),
schema = list(
type=character(),
subtype = character(),
pattern = character(),
parameters = list(), # potential ProcessGraphParameter (variables)
# items are relevant for arrays
items = list(
type=NULL # type name, e.g. "string", "array","number","any", etc.
),
minItems = integer(),
maxItems = integer(),
enum = character()
),
required = logical(),
description = character()
)
)
# Argument ====
#' Argument class
#'
#' This class inherits all fields and functions from [Parameter()] adds the functionality to
#' manage a value. This includes getter/setter, validation and serialization. Since this is the parent class
#' for the type specific argument classes, the inheriting classes implement their own version of the private
#' functions `$typeCheck()` and `$typeSerialization()`.
#'
#' @name Argument
#'
#' @return Object of [R6Class()] representing an argument.
#'
#' @section Methods:
#' \describe{
#' \item{`$setValue(value)`}{Assigns a value to this argument}
#' \item{`$getValue()`}{Returns the value of this argument}
#' \item{`$serialize()`}{returns a list representation of a openEO argument}
#' \item{`$validate()`}{return TRUE if the parameter is validated positively by the type check}
#' \item{`$isEmpty()`}{returns TRUE if the value is set}
#' \item{`$getProcess()`}{returns the process this parameter belongs to}
#' \item{`$setProcess(p)`}{sets the owning process for this parameter}
#' }
#' @section Arguments:
#' \describe{
#' \item{`value`}{The value for this argument.}
#' \item{`p`}{An object of class 'Process' or inheriting like 'ProcessNode'}
#' }
#'
#' @importFrom rlang is_na
NULL
Argument = R6Class(
"Argument",
inherit=Parameter,
public = list(
setValue = function(value) {
private$value = value
},
getValue = function() {
private$value
},
serialize = function() {
# nullable / required / value = NULL
if (self$isNullable &&
(length(self$getValue()) == 0 ||
(!is.environment(self$getValue()) &&
rlang::is_na(self$getValue())))
) {
if (self$isRequired) {
return(NA)
} else {
return(NULL)
}
}
if (any(c("ProcessGraphParameter") %in% class(self$getValue()))) {
return(self$getValue()$serialize())
}
if ("ProcessNode" %in% class(self$getValue())) {
return(self$getValue()$serializeAsReference())
}
# for format specific conversion overwrite this by children
tryCatch({
return(private$typeSerialization())
}, error = function(e) {
serialization_error = paste0("Error serializing parameter '",self$getName(),
"' in process node '", self$getProcess()$getNodeId(),
"' :",e$message)
stop(serialization_error)
})
},
validate = function() {
tryCatch(
{
private$checkRequiredNotSet()
if (!self$isRequired &&
!is.environment(private$value) &&
self$isEmpty()) {
} else {
# ProcessGraphParameter -> variable
# schema$type length == 0 -> ANY
if (any(c("ProcessGraphParameter") %in% class(self$getValue()))) return(invisible(NULL))
if ("ProcessNode" %in% class(self$getValue()) && self$getValue()$getReturns()$isAny) return(invisible(NULL))
private$typeCheck()
}
invisible(NULL)
}, error = function(e) {
if (length(self$getProcess()) >0 ) {
node_id = self$getProcess()$getNodeId()
if (!is.null(node_id)) node_id = paste0("[",node_id,"] ")
message = paste0(node_id,"Parameter '",private$name,"': ",e$message)
} else {
message = e$message
}
return(message)
}
)
},
isEmpty = function() {
return(!is.environment(private$value) && !is.function(private$value) && !is.call(private$value) && (
is.null(private$value) ||
rlang::is_na(private$value) ||
length(private$value) == 0))
},
getProcess = function() {
return(private$process)
},
setProcess = function(p) {
private$process = p
return(invisible(self))
}
),
# private =====
private = list(
value=NULL,
process = NULL,
checkRequiredNotSet = function() {
if (private$required &&
!self$isNullable &&
!is.environment(private$value) &&
self$isEmpty()) stop("Argument is required, but has not been set.")
},
typeCheck = function() {
# implemented / overwritten by children
},
typeSerialization = function() {
# implemented / overwritten by children
#if nothing is done, then simply return the object
if (self$isEmpty() && !self$isRequired) return(NULL)
else return(private$value)
},
deep_clone = function(name, value) {
if (name == "process") {
return(value)
}
# this is the anyOf case
if (name == "parameter_choice") {
new_list = list()
if (is.null(names(value))) {
iterable = 1:length(value)
} else {
iterable = names(value)
}
for (list_name in iterable) {
list_elem = value[[list_name]]
if ("R6" %in% class(list_elem)) {
list_elem = list_elem$clone(deep=TRUE)
}
entry = list(list_elem)
names(entry) = list_name
new_list = append(new_list,entry)
}
return(new_list)
}
if (is.environment(value) && !is.null(value$`.__enclos_env__`)) {
return(value$clone(deep = TRUE))
}
return(value)
}
)
)
# Integer ====
#' Integer class
#'
#' Inheriting from [Argument()] in order to represent a single integer value.
#'
#' @name Integer
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing an Integer
NULL
Integer = R6Class(
"integer",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "integer"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("Integer cannot be an array.")
if (!is.na(private$value) && !is.integer(private$value)) {
suppressWarnings({
coerced = as.integer(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into integer."))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
if (self$isEmpty() && !self$isRequired) return(NULL)
else return(as.integer(private$value))
}
)
)
# EPSG-Code ====
#' EPSGCode class
#'
#' Inheriting from [Argument()] in order to represent an EPSG Code. Allowed values are single integer values like `4326` or a text containing 'EPSG:' like `EPSG:4326`.
#'
#' @name EPSGCode
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing an EPSG code as Integer
NULL
EPSGCode = R6Class(
"epsg-code",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "integer"
private$schema$subtype = "epsg-code"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("EPSG code cannot be an array.")
if (!is.na(private$value) && !is.integer(private$value)) {
suppressWarnings({
coerced = as.integer(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) {
if (is.character(private$value) && grepl(tolower(private$value),pattern = "^epsg:")) {
coerced = as.integer(gsub(x = private$value,replacement = "",pattern = "[^0-9]"))
} else {
stop(paste0("Value '", private$value,"' cannot be coerced into integer."))
}
}
# correct value if you can
private$value = coerced
return(invisible(NULL))
}
},
typeSerialization = function() {
if (self$isEmpty() && !self$isRequired) return(NULL)
else return(as.integer(private$value))
}
)
)
# Number ====
#' Number class
#'
#' Inheriting from [Argument()] in order to represent a numeric value.
#'
#' @name Number
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a number
NULL
Number = R6Class(
"number",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "number"
},
setValue = function(value) {
process_collection = self$getProcess()$getGraph()
private$value = .checkMathConstants(value,process_collection)
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("Number cannot be an array.")
if ("ProcessNode" %in% class(private$value)) {
return_value = private$value$getReturns()
if (!any(c("number","integer") %in% class(return_value) &&
length(return_value$getSchema()$type)) != 0) {
stop(paste0("Value 'ProcessNode' returns neither the ANY object nor a number."))
}
# if (!is.null(return_schema$type) && !"number" %in% unlist(return_schema$type))
} else if (!is.na(private$value) && !is.numeric(private$value)) {
suppressWarnings({
coerced = as.numeric(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a number."))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
if ("ProcessNode" %in% class(private$value)) {
return(private$value$serialize())
} else if (self$isEmpty() && !self$isRequired) {
return(NULL)
} else {
return(as.numeric(private$value))
}
}
)
)
# String ====
#' String class
#'
#' Inheriting from [Argument()] in order to represent a character string value.
#'
#' @name String
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a string.
NULL
String = R6Class(
"string",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value) &&
!any(c("CubeDimension") %in% class(private$value))) stop("String cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character string."))
# correct value if you can
private$value = coerced
}
if (length(self$getEnum()) > 0) {
if (!private$value %in% self$getEnum()) {
stop(paste0("Enum was stated, but the value does not match any enum."))
}
}
return(invisible(NULL))
},
typeSerialization = function() {
if (length(private$value) > 1 && !is.environment(private$value) &&
!any(c("CubeDimension") %in% class(private$value))) stop("String cannot be an array.")
if (is.call(private$value)) {
return(paste(deparse(private$value),collapse = "\n"))
} else if (is.character(private$value)) {
if (file.exists(private$value)) {
# if valid file path open file and attach
tryCatch({
suppressWarnings({
content = readChar(private$value, file.info(private$value)$size)
return(content)
})
}, error = function(e) {
return(private$value)
})
} else {
return(private$value)
}
} else if (self$isEmpty() && !self$isRequired) {
return(NULL)
} else if (!is.environment(private$value) && is.na(private$value)) {
return(NA)
} else {
return(as.character(private$value))
}
}
)
)
# URI ====
URI = R6Class(
"uri",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "uri"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("URI cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character string."))
# correct value if you can
private$value = coerced
}
if (!file.exists(private$value) || !grepl(private$value,pattern="\\w+:(\\/?\\/?)[^\\s]+")) stop("Value is not an URI or file.")
return(invisible(NULL))
},
typeSerialization = function() {
if (is.character(private$value)) {
if (file.exists(private$value)) {
# if valid file path open file and attach
return(readChar(private$value, file.info(private$value)$size))
} else {
return(private$value)
}
} else {
return(as.character(private$value))
}
}
)
)
# Output Format ====
#' OutputFormat class
#'
#' Inheriting from [Argument()] in order to represent an output format of a back-end as a
#' character string value.
#'
#' @name OutputFormat
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing an output format of a back-end.
NULL
OutputFormat = R6Class(
"output-format",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "output-format"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value) && !"FileFormat" %in% class(private$value)) stop("Output format cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
if ("FileFormat" %in% class(private$value)) {
# what to do?
} else {
suppressWarnings({
coerced = as.character(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character string."))
# correct value if you can
private$value = coerced
}
}
return(invisible(NULL))
},
typeSerialization = function() {
if ("FileFormat" %in% class(private$value)) {
return(private$value$name)
} else {
return(as.character(private$value))
}
}
)
)
# CollectionId ====
#' CollectionId class
#'
#' Inheriting from [Argument()] in order to represent a CollectionId on an openeo back-end.
#'
#' @name CollectionId
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a CollectionId.
NULL
CollectionId = R6Class(
"collection-id",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "collection-id"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value) && ! "Collection" %in% class(private$value)) stop("Collection ID cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
if (!"Collection" %in% class(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (length(private$schema$pattern) > 0) {
if (!grepl(pattern=private$schema$pattern,x=coerced,perl=TRUE)) stop(paste0("The provided regexpr pattern does not match the value: ",private$value))
}
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character string."))
# correct value if you can
private$value = coerced
} else {
coerced = private$value$id
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("CollectionId obtained from service is not valid, please contact the openEO service support."))
}
} else {
if (!grepl(pattern=private$schema$pattern,x=private$value,perl=TRUE)) stop(paste0("The provided value does not match the required pattern: ",private$value))
}
return(invisible(NULL))
},
typeSerialization = function() {
if (!"Collection" %in% class(private$value)) {
return(as.character(private$value))
} else {
return(private$value$id)
}
}
)
)
# JobId ====
#' JobId class
#'
#' Inheriting from [Argument()] in order to represent a jobId on an openeo back-end.
#'
#' @name JobId
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing the id of a job.
NULL
JobId = R6Class(
"job-id",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "job-id"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 &&
!is.environment(private$value) &&
!"Job" %in% class(private$value)) stop("Job id cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (!grepl(pattern=private$schema$pattern,x=private$value, perl=TRUE)) stop(paste0("The provided regexpr pattern does not match the value: ",private$value))
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character string."))
# correct value if you can
private$value = coerced
} else {
if (!grepl(pattern=private$schema$pattern,x=private$value,perl=TRUE)) stop(paste0("The provided value does not match the required pattern: ",private$value))
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(private$value))
}
)
)
# UdfRuntime argument ====
#' UdfRuntimeArgument class
#'
#' Inheriting from [Argument()] in order to represent the id of an UDF runtime object as obtainable by [list_udf_runtimes()].
#'
#' @name UdfRuntimeArgument
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing the UDF runtime in a process argument.
NULL
UdfRuntimeArgument = R6Class(
"udf-runtime",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "udf-runtime"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 &&
!is.environment(private$value) &&
!"UdfRuntime" %in% class(private$value)) stop("UDF runtime cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a runtime id."))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(private$value))
}
)
)
# UdfRuntimeVersion argument ====
#' UdfRuntimeVersionArgument class
#'
#' Inheriting from [Argument()] in order to represent the id of a UDF runtime object as obtainable by [list_udf_runtimes()].
#'
#' @name UdfRuntimeVersionArgument
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] is an argument that expects a UDF runtime version or character as value.
NULL
UdfRuntimeVersionArgument = R6Class(
"udf-runtime-version",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "udf-runtime-version"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 &&
!is.environment(private$value) &&
!"UdfRuntimeVersion" %in% class(private$value)) stop("UDF runtime version cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into an UDF runtime version string."))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(private$value))
}
)
)
# UdfCode argument ====
#' UdfCodeArgument class
#'
#' Inheriting from [Argument()] in order to represent the UDF code that will be executed in a UDF call. The script has to
#' be passed as a character string or as a local file path from which the script can be loaded.
#'
#' @name UdfCodeArgument
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] is an argument that expects an UDF code or a file path.
NULL
UdfCodeArgument = R6Class(
"udf-code",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "udf-code"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("UDF code cannot be an array cannot be an array.")
# parse
if (!self$isEmpty() && !is.character(private$value)) {
if (is.function(private$value)) {
} else {
suppressWarnings({
coerced = as.character(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character string."))
# correct value if you can
private$value = coerced
}
}
return(invisible(NULL))
},
typeSerialization = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("UDF code cannot be an array.")
if (is.call(private$value) || is.function(private$value)) {
return(deparse1(private$value,collapse = "\n"))
} else if (is.character(private$value)) {
if (file.exists(private$value)) {
# if valid file path open file and attach
tryCatch({
suppressWarnings({
content = readChar(private$value, file.info(private$value)$size)
return(content)
})
}, error = function(e) {
return(private$value)
})
} else {
return(private$value)
}
} else if (self$isEmpty() && !self$isRequired) {
return(NULL)
} else if (!is.environment(private$value) && is.na(private$value)) {
return(NA)
} else {
return(as.character(private$value))
}
}
)
)
# ProcessGraphId ====
#' ProcessGraphId
#'
#' Inheriting from [Argument()] in order to represent a process graph Id on an openeo back-end.
#'
#' @name ProcessGraphId
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing the id of a process graph.
NULL
ProcessGraphId = R6Class(
"process-graph-id",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "process-graph-id"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("Process graph id cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (!grepl(pattern=private$schema$pattern,x=private$value,perl=TRUE)) stop(paste0("The provided regexpr pattern does not match the value: ",private$value))
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character string."))
# correct value if you can
private$value = coerced
} else {
if (!grepl(pattern=private$schema$pattern,x=private$value,perl=TRUE)) stop(paste0("The provided value does not match the required pattern: ",private$value))
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(private$value))
}
)
)
# Proj-Definition ====
#' ProjDefinition
#'
#' Inheriting from [Argument()] in order to represent a projection definition as a PROJ string.
#'
#' @name ProjDefinition
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a projection definition based on PROJ.
NULL
ProjDefinition = R6Class(
"proj-definition",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "proj-definition"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("PROJ definition cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character proj definition."))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(private$value))
}
)
)
# Bounding Box ====
#' BoundingBox
#'
#' Inheriting from [Argument()] in order to represent a bounding box / extent of an area of
#' interest. Its value is usually a named list with "west","south","east" and "north". For this argument
#' the 'bbox' object of the sf package is also recognized ([sf::st_bbox()]). This holds also true for
#' classes that support [sf::st_bbox()] and return a valid 'bbox' object.
#'
#' @name BoundingBox
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a bounding box / extent.
#'
#' @examples \dontrun{
#' # most of the time BoundingBox is a choice as parameter value for
#' # spatial_extent in 'load_collection'
#' p = processes()
#'
#' # using a list
#' bbox = list(west=10.711799440170706,
#' east= 11.542794097651838,
#' south=45.92724558214729,
#' north= 46.176044942018734)
#'
#' data = p$load_collection(id = "SENTINEL2_L2A",
#' spatial_extent = bbox,
#' temporal_extent = list("2020-01-01T00:00:00Z", "2020-01-20T00:00:00Z"),
#' bands = list("B04","B08"))
#'
#' # using sf bbox
#' bbox = st_bbox(c(xmin=10.711799440170706,
#' xmax= 11.542794097651838,
#' ymin=45.92724558214729,
#' ymax= 46.176044942018734),
#' crs = 4326)
#'
#' data = p$load_collection(id = "SENTINEL2_L2A",
#' spatial_extent = bbox,
#' temporal_extent = list("2020-01-01T00:00:00Z", "2020-01-20T00:00:00Z"),
#' bands = list("B04","B08"))
#'
#' # objects supporting sf::st_bbox()
#' img = stars::read_stars(system.file("tif/L7_ETMs.tif",package = "stars"))
#' data = p$load_collection(id = "SENTINEL2_L2A",
#' spatial_extent = img,
#' temporal_extent = list("2020-01-01T00:00:00Z", "2020-01-20T00:00:00Z"),
#' bands = list("B04","B08"))
#'
#' }
NULL
BoundingBox = R6Class(
"bounding-box",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "object"
private$schema$subtype = "bounding-box"
},
setValue = function(value) {
bbox=tryCatch(sf::st_bbox(value),error=function(e) NULL)
if (is.null(bbox)) {
if (is.list(value)) {
if ("crs" %in% names(value)) {
crs_value = value[["crs"]]
if (is.character(crs_value) && grepl(tolower(crs_value),pattern = "^epsg:")) {
value[["crs"]] = as.integer(gsub(x = crs_value,replacement = "",pattern = "[^0-9]"))
}
}
}
private$value= value
} else {
private$value = bbox
}
}
),
private = list(
typeCheck = function() {
value = private$value
# should be a list
if ("bbox" %in% class(value)) {
# TODO maybe check completeness?
return(NULL)
} else if (!is.list(value)) {
tryCatch(
{
value = as.list(value)
},
error = function(e) {
stop("Cannot coerce values of bounding box into a list")
}
)
}
obj_names = names(value)
if (length(obj_names) == 0) stop("Bounding box parameter are unnamed. Cannot distinguish between values.")
# check if west, south, east, north are set and all are numeric values or coercable as numeric
required_dir_params = c("west","south","east","north")
if (!all(required_dir_params %in% obj_names)) stop(paste0(
"Bounding box parameters are missing: ", paste(required_dir_params[!required_dir_params %in% obj_names],collapse = ", ")
))
suppressWarnings({
vals = lapply(value[obj_names],as.numeric)
nas = sapply(vals, is.na)
if (any(nas)) {
stop("Not all bbox parameters are numeric or can be coerced into numeric automatically: ",paste0(obj_names[nas],collapse = ", "))
} else {
value[obj_names] = vals
}
})
# check if crs is set (either proj string or epsg code)
if ("crs" %in% obj_names) {
crs_value = value[["crs"]]
if (!is.integer(crs_value) && !is.numeric(crs_value)) {
if (!is.character(crs_value)) stop("CRS is not an EPSG identifier or a PROJ string")
# automatical conversion in this EPSG cases
if (!grepl(pattern="epsg:", tolower(crs_value))) {
stop("CRS String does not contain an EPSG identifier")
# value[["crs"]] = as.integer(sub(pattern = "epsg:",replacement = "",tolower(crs_value)))
}
}
} # else nothing, since it is not required, but its assumed to be WGS84
# check if base and height are set (both or none), also those have to be numeric
height_selector = c("base","height")
if (do.call(xor,as.list(height_selector %in% obj_names))) {
stop("Height was considered, but either 'base' or 'height' is missing.")
}
if (all(height_selector %in% obj_names)) {
height_extent = value[height_selector]
suppressWarnings({
height_extent = sapply(height_extent,as.numeric)
if (any(sapply(height_extent,is.na))) {
stop("'Base' or 'height' cannot be interpreted as numeric value")
} else {
value[height_selector] = height_extent
}
})
}
return(invisible(NULL))
},
typeSerialization = function() {
if (length(self$getValue()) == 0) {
return(NULL)
} else {
#if bbox from sf package serialize it accordingly
if ("bbox" %in% class(private$value)) {
bbox = private$value
crs = sf::st_crs(bbox)
result = list(west=unname(bbox$xmin),
east=unname(bbox$xmax),
south=unname(bbox$ymin),
north=unname(bbox$ymax))
if (crs != sf::st_crs(4326)) {
if (grepl(tolower(crs$input),pattern="^epsg:")) {
result$crs = crs$input
} else {
result$crs = crs$wkt
}
}
} else {
result = self$getValue()
}
if (is.list(result)) {
if ("crs" %in% names(result)) {
crs_value = result[["crs"]]
if (is.character(crs_value) && grepl(tolower(crs_value),pattern = "^epsg:")) {
result[["crs"]] = as.integer(gsub(x = crs_value,replacement = "",pattern = "[^0-9]"))
}
}
}
return(result)
}
}
)
)
# Boolean ====
#' Boolean
#'
#' Inheriting from [Argument()] in order to represent a boolean / logical.
#'
#' @name Boolean
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a boolean / logical.
NULL
Boolean = R6Class(
"boolean",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "boolean"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("Boolean cannot be an array.")
if (length(private$value) > 0 && "ProcessNode" %in% class(private$value)) {
if (! "boolean" %in% class(private$value$getReturns())) {
stop("No logical return from ProcessNode.")
}
return(invisible(NULL))
}
if (!is.na(private$value) && !is.logical(private$value)) {
suppressWarnings({
coerced = as.logical(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a boolean/logical."))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.logical(private$value))
}
)
)
# Date ====
#' Date
#'
#' Inheriting from [Argument()] in order to represent a date.
#'
#' @name Date
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a date.
NULL
Date = R6Class(
"date",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "date"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("Date cannot be an array.")
if (!is.na(private$value) && !is.Date(private$value)) {
suppressWarnings({
coerced = as_date(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a date"))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(format(private$value,format = "%Y-%m-%d")))
}
)
)
# DateTime ====
#' DateTime
#'
#' Inheriting from [Argument()] in order to represent a date with time component.
#'
#' @name DateTime
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a date with time component.
#'
#' @import lubridate
NULL
DateTime = R6Class(
"date-time",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "date-time"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("Timestamp cannot be an array.")
if (!is.na(private$value) && !is.POSIXct(private$value)) {
suppressWarnings({
coerced = as_datetime(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a date time object"))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(format(private$value,format = "%Y-%m-%dT%H:%M%SZ")))
}
)
)
# Time ====
#' Time
#'
#' Inheriting from [Argument()] in order to represent the time of a day.
#'
#' @name Time
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing the time of a day.
NULL
Time = R6Class(
"time",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "time"
},
setValue = function(value) {
# the value will be a posixct where we just return the time component
if (is.character(value)) {
private$value = strptime(value, format="%H:%M:%SZ")
} else {
private$value= value
}
},
getValue = function() {
return(self$serialize())
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("Time cannot be an array.")
if (!is.na(private$value) && !is.POSIXct(private$value)) {
suppressWarnings({
coerced = strptime(value, format="%H:%M:%SZ")
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a time representation"))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(format(private$value,format = "%H:%M:%SZ")))
}
)
)
# GeoJson ====
#' GeoJson
#'
#' Inheriting from [Argument()] in order to represent a GeoJson object. This class represents geospatial features.
#' Allowed values are either a list directly convertible into a valid GeoJson or polygon features of type 'sf' or 'sfc'
#' from package 'sf'. The current implementation follows the data representation of 'sf' - meaning that coordinate order is
#' XY (e.g. if CRS84 is used then lon/lat is the default order).
#'
#' As GeoJSON is defined in <https://datatracker.ietf.org/doc/html/rfc7946>{RFC7946} the coordinate reference system is
#' `urn:ogc:def:crs:OGC::CRS84`, which uses a longitude, latitude ordering of the coordinates.
#'
#'
#' @name GeoJson
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing an object in GeoJson.
#'
#' @importFrom rlang is_na
NULL
GeoJson = R6Class(
"geojson",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "object"
private$schema$subtype = "geojson"
},
setValue = function(value) {
if (!.is_package_installed("sf")) {
warnings("Package sf is not installed but required for GeoJson support.")
}
# lists are checked for each element for is.na if run under unix
if (!is.environment(value) && (is.null(value) || rlang::is_na(value))) {
private$value = value
return()
}
if (all(c("XY","POLYGON") %in% class(value))) {
private$value = sf::st_sfc(value)
return()
}
if (any(c("sf","sfc") %in% class(value))) {
private$value = value
return()
}
old_class = class(value)
value = unclass(value)
if (is.list(value) && "type" %in% names(value)) {
# this case is a geojson parsed as list
tryCatch({
tmpfile = tempfile()
jsonlite::write_json(value,tmpfile, auto_unbox=TRUE, digits = NA)
suppressWarnings({
private$value = sf::read_sf(tmpfile,crs=4326)
})
}, finally = unlink(tmpfile))
} else {
stop("Cannot set given object for argument 'GeoJSON': class ",paste(sep=",",old_class)," not supported")
}
},
getValue = function() {
return(private$value)
}
),
private = list(
typeCheck = function() {
if ("sf" %in% class(private$value)) {
return(NULL)
} else if ("sfc" %in% class(private$value)) {
return(NULL)
} else if (is.list(private$value)) {
if (!"type" %in% names(private$value)) {
#TODO better probing
stop("Value is not GeoJSON.")
}
#if list we assume that the geojson object was created as list
return(NULL)
} else {
stop("Class ",paste(class(private$value)), " not supported in GeoJson argument")
}
},
typeSerialization = function() {
if (self$isEmpty()) {
return(private$value)
}
if (any(c("sf","sfc") %in% class(private$value))) {
value = sf::st_transform(private$value,4326)
tryCatch({
t = tempfile()
sf::write_sf(value,t,driver="geojson")
obj = jsonlite::read_json(t,simplifyVector = FALSE)
# remove CRS just to be in line with the geojson specification (4326, lat/lon, no crs field)
obj["crs"] = NULL
return(obj)
}, finally = unlink(t))
} else if (is.list(private$value) && "type" %in% names(private$value)) {
return(private$value)
} else {
stop("Unsupported value type.")
}
}
)
)
# OutputFormatOptions ====
#' OutputFormatOptions
#'
#' Inheriting from [Argument()] in order to represent the additional output format options of a back-end.
#'
#' @name OutputFormatOptions
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing output format options.
NULL
OutputFormatOptions = R6Class(
"output-format-options",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "object"
private$schema$subtype = "output-format-options"
}
),
private = list(
typeCheck = function() {
if (!self$isEmpty()) {
if (!is.list(private$value)) {
stop("Output format options are not a list")
}
}
},
typeSerialization = function() {
return(as.list(private$value))
}
)
)
# RasterCube ====
#' RasterCube
#'
#' Inheriting from [Argument()] in order to represent a raster cube. This is usually the in- and
#' output format of a process unless the process operates within a ProcessGraph on reduced data.
#' The [VectorCube()] behaves comparably, but with underlying spatial feature data.
#'
#' @name RasterCube
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a raster cube.
NULL
RasterCube = R6Class(
"raster-cube",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "object"
private$schema$subtype = "raster-cube"
}
),
private = list(
typeCheck = function() {
# a raster data cube can only be derived by process, e.g. get_collection so this
# value should be a ProcessNode
if (! "ProcessNode" %in% class(private$value)) stop("RasterCube is not retreived by process.")
invisible(NULL)
},
typeSerialization = function() {
if ("ProcessNode" %in% class(private$value)) {
return(private$value$serializeAsReference())
}
return(as.character(private$value))
}
)
)
# VectorCube ====
#' VectorCube
#'
#' Inheriting from [Argument()] in order to represent a vector cube. This is analogous to
#' the [RasterCube()].
#'
#' @name VectorCube
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a vector cube.
NULL
VectorCube = R6Class(
"vector-cube",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "object"
private$schema$subtype = "vector-cube"
}
),
private = list(
typeCheck = function() {
# a vector data cube can only be derived by process, e.g. get_collection so this
# value should be a ProcessNode
if (! "ProcessNode" %in% class(private$value)) stop("VectorCube is not retreived by process.")
invisible(NULL)
},
typeSerialization = function() {
if ("ProcessNode" %in% class(private$value)) {
return(private$value$serializeAsReferences())
}
return(as.character(private$value))
}
)
)
# ProcessGraphArgument ====
#' ProcessGraphArgument
#'
#' Inheriting from [Argument()] in order to represent an argument that contains a process or a derivable value (formerly known
#' as callback). The ProcessGraphArgument operates on the reduced data of a data cube. For example reducing or aggregating over
#' the temporal dimension results in a time series that has to be reduced into a single value or aggregated into another time
#' series. The value of a ProcessGraphArgument is usually a function that will be coerced into [`Process()`]. The function
#' is required to use the same amount of parameters as `ProcessGraphParameter` objects are defined, because during the coercion
#' those `ProcessGraphParameter` are passed to function. Additional information can be found in the openEO API documentation:
#' \itemize{
#' \item <https://api.openeo.org/#section/Processes/Process-Graphs>
#' }
#'
#' @section Methods:
#' \describe{
#' \item{`$getProcessGraphParameters()`}{returns the available list [ProcessGraphParameter()]}
#' \item{`$setProcessGraphParameters(parameters)`}{assigns a list of [ProcessGraphParameter()] to the ProcessGraph}
#' }
#'
#' @section Arguments:
#' \describe{
#' \item{`parameters`}{the [ProcessGraphParameter()] list}
#' }
#'
#' @name ProcessGraphArgument
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a ProcessGraph.
NULL
ProcessGraphArgument = R6Class(
"ProcessGraphArgument",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "object"
private$schema$subtype = "process-graph"
},
setValue = function(value) {
if ("function" %in% class(value)) {
# if value is a function -> then make a call with the function and a suitable ProcessGraph
# parameter
# create a new graph
process_collection = private$process$getGraph()
# probably switch temporarily the graph of the parent process
# then all newly created process nodes go into the new graph
private$process$setGraph(process_collection)
process_graph_parameter = private$parameters
# find suitable ProcessGraph parameter (mostly array or binary) -> check for length of formals
# the issue can no longer been resolved automatically
if (length(formals(value)) != length(process_graph_parameter)) stop("Function parameter do not match ProcessGraph parameter(s)")
names(process_graph_parameter) = names(formals(value))
lapply(process_graph_parameter, function(cb){cb$setProcess(private$process)})
# make call
final_node = do.call(value,args = process_graph_parameter)
# then serialize it via the final node
# assign new graph as value
private$value = Graph$new(final_node = final_node)
} else if ("ProcessNode" %in% class(value)) {
private$value = Graph$new(final_node = value)
} else if ("Graph" %in% class(value) || rlang::is_na(value)) {
private$value = value
} else {
stop("Assigned value for process graph needs to be function, graph or a final process node.")
}
},
setProcess = function(p) {
private$process = p
lapply(private$parameters, function(cbv) {
cbv$setProcess(p)
})
return(invisible(self))
},
setProcessGraphParameters = function(parameters) {
private$parameters = parameters
},
getProcessGraphParameters = function() {
return(private$parameters)
}
),
private = list(
parameters = list(),
typeCheck = function() {
# check the value (graph) for the same ProcessGraph parameters (ProcessGraphParameters)
if (!"Graph" %in% class(private$value)) stop("The value of a ProcessGraph argument is usually a graph.")
errors = private$value$validate()
if (any(errors != TRUE)) {
stop(paste("Errors in subgraph:",paste(errors,collapse=";")))
}
return(invisible(NULL))
},
typeSerialization = function() {
if (is.environment(private$value) && "serialize" %in% names(private$value)) {
return(list(
process_graph = private$value$serialize()))
}
}
)
)
# ProcessGraphParameter ====
#' ProcessGraphParameter
#'
#' Inheriting from [Argument()] in order to represent the available data within a ProcessGraph graph.
#' Additional information can be found in the openEO API documentation:
#' \itemize{
#' \item <https://api.openeo.org/#section/Processes/Process-Graphs>
#' }
#'
#' @name ProcessGraphParameter
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a ProcessGraph value.
NULL
# in case the ProcessGraphParameter is an array - which it will be in most cases - we have to store
# process nodes for array subsetting in the object with its index. This should be done to
# reuse the results of previous steps
ProcessGraphParameter = R6Class(
"ProcessGraphParameter",
inherit=Argument,
public = list(
initialize=function(name=character(),
description=character(),
type=character(),
subtype=character(),
default=character(),
required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = type
private$schema$subtype = subtype
private$default = default
},
print = function() {
cat(jsonlite::toJSON(self$serialize(),pretty = TRUE, auto_unbox = TRUE,digits=NA))
invisible(self)
},
adaptType = function(fromParameter) {
if (is.list(fromParameter) && length(fromParameter) == 1) {
fromParameter = fromParameter[[1]]
private$schema = fromParameter$getSchema()
private$default = fromParameter$getDefault()
private$required = fromParameter$isRequired
private$nullable = fromParameter$isNullable
} else {
stop("Not considered yet")
}
invisible(self)
}
),
private = list(
typeSerialization = function() {
if (self$isEmpty()) {
return(list(from_parameter=private$name))
} else {
if ("Argument" %in% class(private$value)) {
value_serialization = self$getValue()$serialize()
} else if ("FileFormat" %in% class(private$value)) {
value_serialization = private$value$name
} else {
value_serialization = self$getValue()
}
return(value_serialization)
}
}
)
)
setOldClass(c("ProcessGraphParameter","Argument","Parameter","R6"))
# Array ====
#' Array
#'
#' Inheriting from [Argument()] in order to represent an array of a single data type.
#'
#' @name Array
#'
#' @section Methods:
#' \describe{
#' \item{`$getMinItems`}{returns the minimum number of items}
#' \item{`$getMaxItems`}{returns the maximum number of items}
#' \item{`$setMinItems(value)`}{sets the minimum number of items}
#' \item{`$setMaxItems(value)`}{sets the maximum number of items}
#' \item{`$getItemSchema`}{returns the item schema of the items in the array}
#' \item{`$setItemSchema(value)`}{sets the schema for the items in the array}
#' }
#'
#' @section Arguments:
#' \describe{
#' \item{`value`}{either a number describing the minimum and maximum number of elements in an array or the
#' parsed JSON schema of a single item in the array}
#' }
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a single valued array.
#'
#' @importFrom rlang is_na
NULL
Array = R6Class(
"array",
inherit=Argument,
public = list(
initialize=function(name=character(),
description=character(),
type=character(),
format=character(),
items=list(),
required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "array"
private$schema$subtype = format
private$schema$items = items
},
getMinItems = function() {
return(private$schema[["minItems"]])
},
getMaxItems = function() {
return(private$schema[["maxItems"]])
},
setMinItems = function(value) {
private$schema[["minItems"]] = value
},
setMaxItems = function(value) {
private$schema[["maxItems"]] = value
},
getItemSchema = function() {
return(private$schema$items)
},
setItemSchema = function(value) {
if (!"type" %in% names(value)) {
value[["type"]]="any"
} else if (any(value$type == "null")) {
value$type[value$type == "null"] = NULL
value$type = unlist(value$type)
value$nullable = TRUE
}
if (is.null(value[["minItems"]])) value[["minItems"]] = integer()
if (is.null(value[["maxItems"]])) value[["maxItems"]] = integer()
private$schema$items = value
},
setValue = function(value) {
if (length(self$getProcess()) > 0) {
process_collection = self$getProcess()$getGraph()
} else {
process_collection = NULL
}
if (!is.environment(value) && length(value) > 0) {
private$value = lapply(value, function(x, pc) {
.checkMathConstants(x,pc)
}, pc = process_collection)
} else {
private$value = value
}
}
),
private = list(
typeCheck = function() {
itemType = private$schema$items$type
if (length(itemType) == 0 || length(itemType) > 1) {
# this can be anything or is to complicated to check in R so we shift the responsibility to the back-end
return(invisible(NULL))
}
if (length(private$schema$minItems) == 1 &&
length(private$value) < private$schema$minItems) {
stop(paste0("Minimum items are not achieved. Found ",length(private$value)," items of minimal ",private$schema$minItems," items."))
}
if (length(private$schema$maxItems) == 1 &&
length(private$value) > private$schema$maxItems) {
stop(paste0("More items than maximum. Found ",length(private$value)," items of maximal ",private$schema$maxItems," items."))
}
if (itemType == "array") {
# just check the first layer, everything else would be nice, but is no more in our responsibility
if ("ProcessGraphParameter" %in% class(private$value)) {
if (length(private$value$getSchema()$type) > 0 &&
private$value$getSchema()$type == "array")
if (length(private$value$getSchema()$items$type) > 0) {
if (private$value$getSchema()$items$type == private$schema$items$type) {
return()
}
} else {
stop("Selected ProcessGraphParameter is an array, but has a different item type.")
}
}
allOK = all(sapply(private$value, function(item) {
# item is an array type -> list or vector
itemsItemType = private$schema$items$type
itemsMinItems = private$schema$items$minItems
itemsMaxItems = private$schema$items$maxItems
# check nested item type
typeOK = switch(itemsItemType,
string = is.character(item),
number = is.numeric(item),
integer = is.integer(item),
boolean = is.logical(item),
array = is.list(item) || is.vector(item))
# check min/max if set
minOK = NULL
if (!is.null(itemsMinItems) && length(itemsMinItems) == 1){
minOK = length(item) >= itemsMinItems
}
maxOK = NULL
if (!is.null(itemsMaxItems) && length(itemsMaxItems) == 1){
maxOK = length(item) >= itemsMaxItems
}
return(all(unlist(list(typeOK,minOK,maxOK))))
}))
if (!allOK) stop("At least one of the nested arrays has an invalid item type or the min/max constraint was triggered.")
} else {
if (!"ProcessGraphParameter" %in% class(private$value[[1]])) {
allOK = switch(itemType,
string = all(sapply(private$value,function(val){
if ("Process" %in% class(val)) {
returnSchema = val$getReturns()$schema
return(String$new()$matchesSchema(returnSchema))
} else {
return(is.character(val))
}
})),
number = all(sapply(private$value,function(val){
if ("Process" %in% class(val)) {
returnSchema = val$getReturns()$schema
return(Number$new()$matchesSchema(returnSchema))
} else {
return(is.numeric(val))
}
})),
integer = all(sapply(private$value,function(val){
if ("Process" %in% class(val)) {
returnSchema = val$getReturns()$schema
return(Integer$new()$matchesSchema(returnSchema))
} else {
return(is.integer(val))
}
})),
boolean = all(sapply(private$value,function(val){
if ("Process" %in% class(val)) {
returnSchema = val$getReturns()$schema
return(Boolean$new()$matchesSchema(returnSchema))
} else {
return(is.logical(val))
}
}))
)
# if allOK == null then it was not checked
if (!is.null(allOK) && !allOK) {
stop(paste0("At least one element in the array is not of type: ",itemType))
}
}
}
if (!is.list(private$value)) {
if (length(private$value) == 1) {
private$value = list(private$value)
return()
}
suppressWarnings({
coerced = as.list(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a boolean."))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
if (!is.environment(self$getValue()) && (length(self$getValue()) == 0 || rlang::is_na(self$getValue()))) {
return(NA)
}
lapply(self$getValue(), function(value) {
if ("ProcessNode" %in% class(value)) return(value$serializeAsReference())
if ("Argument" %in% class(value)) return(value$serialize())
return(value)
})
})
)
# Kernel ====
#' Kernel
#'
#' Inheriting from [Argument()] in order to represent a 2-dimensional array of weights applied
#' to the x and y (spatial) dimensions of the data cube. The inner level of the nested array is aligned to the x-axis and
#' the outer level is aligned to the y-axis. Each level of the kernel must have an uneven number of elements.
#'
#' @name Kernel
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a Kernel.
NULL
Kernel = R6Class(
"kernel",
inherit=Argument,
public = list(
initialize=function(name=character(),
description=character(),
type=character(),
format=character(),
items=list(),
required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "array"
private$schema$subtype = "kernel"
private$schema$items = items
}
),
private = list(
typeSerialization = function() {
# might not be really required
private$value
},
typeCheck = function() {
if (!self$isEmpty()) {
if (!is.matrix(private$value) || !is.data.frame(private$value) || !is.array(private$value)) {
stop("Kernel value is neither matrix nor data.frame")
} else {
dims = dim(kernel)
if (!length(dims) == 2) {
stop("Kernel has more or less than two dimensions")
}
if (!all(dims %% 2 == 1)) {
stop("One or more kernel dimension have an even number of elements")
}
invisible(NULL)
}
}
}
)
)
#TemporalInterval ====
#' TemporalInterval
#'
#' Inheriting from [Argument()] in order to represent a temporal interval. Open interval borders are
#' denoted by NA. Exactly two objects form the temporal interval.
#'
#' @name TemporalInterval
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a temporal interval.
NULL
TemporalInterval = R6Class(
"temporal-interval",
inherit=Array,
public = list(
initialize=function(name=character(),
description=character(),
type=character(),
format=character(),
items=list(),
required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "array"
private$schema$subtype = "temporal-interval"
private$schema$items = items
private$schema$maxItems = 2
private$schema$minItems = 2
},
setValue = function(value) {
private$value = value
}
)
)
#TemporalIntervals ====
#' TemporalIntervals
#'
#' Inheriting from [Argument()] in order to represent a list of [TemporalInterval()].
#'
#' @name TemporalIntervals
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a list of temporal intervals.
NULL
TemporalIntervals = R6Class(
"temporal-intervals",
inherit=Array,
public = list(
initialize=function(name=character(),
description=character(),
type=character(),
format=character(),
items=list(),
required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "array"
private$schema$subtype = "temporal-intervals"
private$schema$items = items
}
)
)
# MetadataFilter ====
#' MetadataFilter
#'
#' Inheriting from [ProcessGraphArgument()] in order to represent a list of functions that is internally
#' interpreted into [Process()] objects.
#'
#' @examples
#' \dontrun{
#' # define filter statement
#' filter = list(
#' "eo:cloud_cover" = function(x) x >= 0 & x < 50,
#' "platform" = function(x) x == "Sentinel-2A"
#' )
#'
#' # setting the arguments is done via the process graph building with of 'processes()'
#' }
#'
#' @name MetadataFilter
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a list of [Process()] in order to filter for collections.
#'
#' @importFrom rlang is_na
NULL
MetadataFilter <- R6Class(
"metadata-filter",
inherit=ProcessGraphArgument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "object"
private$schema$subtype = "metadata-filter"
},
setValue = function(value) {
if (length(value) == 0 || rlang::is_na(value)) {
private$value = value
} else if (is.list(value)) {
node_names = names(value) # TODO add something if missing or stop
# set parameter that is stored in this class...
v = lapply(value,function(FUN, private) {
if (is.function(FUN)) {
process_collection = private$process$getGraph()
# probably switch temporarily the graph of the parent process
# then all newly created process nodes go into the new graph
private$process$setGraph(process_collection)
process_graph_parameter = private$parameters
# find suitable ProcessGraph parameter (mostly array or binary) -> check for length of formals
# the issue can no longer been resolved automatically
if (length(formals(FUN)) != length(process_graph_parameter)) stop("Function parameter do not match ProcessGraph parameter(s)")
names(process_graph_parameter) = names(formals(FUN))
lapply(process_graph_parameter, function(cb){cb$setProcess(private$process)})
# make call
final_node = do.call(FUN,args = process_graph_parameter)
# assign new graph as value
as(final_node,"Process")
} else if ("Graph" %in% class(FUN)) {
as(FUN,"Process")
} else {
stop("Value for the metadata filter needs to be a list of functions.")
}
},private=private)
names(v) = node_names
private$value = v
} else {
stop("Value for the metadata filter needs to be a list of functions.")
}
}
),
private = list(
typeCheck = function() {
if (!self$isEmpty()) {
length_0 = length(private$value) == 0
# named list of functions
is_named = length(names(private$value)) > 0
is_list = is.list(private$value)
all_graphs = all(sapply(private$value,function(o)"Process" %in% class(o)))
if (!length_0 && !is_named && !is_list && !all_graphs) {
stop("value could not be parsed into a named list of Process")
}
}
return(invisible(NULL))
},
typeSerialization = function() {
nn = names(private$value)
ll = lapply(private$value,function(o)o$serialize())
names(ll) = nn
return(ll)
}
)
)
# AnyOf ====
#' AnyOf
#'
#' Inheriting from [Argument()] in order to represent an argument choice object. Multiple
#' types can be stated, but at least one data type has to be picked. In a JSON-schema this is often used to make
#' objects nullable - meaning that they allow NULL as value. The AnyOf parameter is resolved into a simple nullable argument
#' if this applies.
#'
#' @section Methods:
#' \describe{
#' \item{`$getChoice()`}{returns a list of [Argument()] that are allowed}
#' \item{`$isNullable`}{returns TRUE if only one element is in the choice that is not "null"}
#' }
#'
#' @name AnyOf
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing an argument choice object.
#' @importFrom rlang is_na
NULL
AnyOf = R6Class(
"anyOf",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(), parameter_list,required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "anyOf"
private$parameter_choice = parameter_list
},
setProcess = function(p) {
private$process = p
lapply(private$parameter_choice, function(choice) {
choice$setProcess(p)
})
return(invisible(self))
},
setValue = function(value) {
if (is.null(value)) {
private$value =NULL
return(self)
}
if ("function" %in% class(value)) {
signature = formals(value)
# currently we have only 1 parameter (either single value or array) or two (directly binary operation)
number_of_params = sapply(private$parameter_choice,function(cb) {
length(cb$getProcessGraphParameters())
})
choice_index = unname(which(number_of_params == length(signature)))
if (length(choice_index) == 0) {
stop("Cannot match function to any of the ProcessGraph parameter.")
}
choice = private$parameter_choice[[choice_index]]
#resolve anyof parameter
self$getProcess()$setParameter(name = self$getName(),value = choice)
choice$setName(self$getName())
choice$setProcess(private$process)
choice$setValue(value)
return(self)
}
if ("ProcessGraph" %in% class(value)) {
# This is mostly for ProcessGraphs
arg_allowed = any(sapply(private$parameter_choice, function(argument) {
all(length(setdiff(class(argument),class(value))) == 0,
length(setdiff(class(value),class(argument))) == 0
)
}))
if(!arg_allowed) stop("Cannot assign ",class(value)[[1]], " as value. Not allowed.")
private$value = value
return(self)
}
else {
# set to all sub parameters and run validate
choice_copies = self$getChoice()
validated = sapply(choice_copies, function(param) {
tryCatch(
{
param$setValue(value)
validation = param$validate()
return(is.null(validation))
},
error = function(e) {
return(FALSE)
}
)
})
tryCatch({
if (!any(validated)) stop("Cannot match the value to any of the parameter selection (AnyOf)")
private$value = unname(choice_copies[validated])[[1]] # pick the first match
private$value$setValue(value)
}, error = function(e) {
message(e$message)
})
return(self)
}
},
getValue = function() {
# best case only one had survived the selection, if not throw an error?
# or return the first result
if (is.null(private$value)) return(private$value)
if (is.list(private$value)) {
if (length(private$value)==1) {
return(private$value[[1]])
}
return(private$value[[1]])
} else {
return(private$value)
}
},
getChoice = function() {
param_copies = lapply(private$parameter_choice,function(choice){
choice$clone(deep=TRUE)
})
return(param_copies)
}
),
active = list(
isNullable = function(value) {
if (missing(value)) {
return(private$nullable)
} else {
value = as.logical(value)
if (rlang::is_na(value)) {
warning("Cannot cast value to logical. Assume FALSE.")
value = FALSE
}
lapply(private$parameter_choice, function(param) {
param$isNullable = value
})
private$nullable = value
}
}
),
private = list(
parameter_choice = list(),
typeCheck = function() {},
typeSerialization = function() {
if (length(self$getValue()) == 0) {
return(NULL)
} else {
val = self$getValue()
if (!is.list(val)) {
val = list(val)
}
val = lapply(val, function(v) {
if (any(c("Graph","Argument") %in% class(v))) {
return(v$serialize())
} else if ("ProcessNode" %in% class(v)){
return(v$serializeAsReference())
} else {
return(v)
}
})
if (length(val) == 1) return(val[[1]])
else return(val)
}
}
)
)
# parse functions ----
findParameterGenerator = function(schema) {
# adapt this if I add some parameter/argument
# ProcessGraphParameter are not listed since they are created at the graph (as "variables")
parameter_constructor = list(Integer,
EPSGCode,
Number,
Boolean,
BoundingBox,
GeoJson,
RasterCube,
VectorCube,
String,
CollectionId,
JobId,
ProcessGraphId,
ProjDefinition,
OutputFormat,
OutputFormatOptions,
ProcessGraphArgument,
Array,
Kernel,
Date,
DateTime,
TemporalInterval,
TemporalIntervals,
Time,
URI,
UdfRuntimeArgument,
UdfRuntimeVersionArgument,
UdfCodeArgument,
MetadataFilter)
# resolve the any parameter (no specification)
if (length(schema$type) == 0 && length(schema$subtype) == 0) {
return(list(Argument))
}
matches = unlist(lapply(parameter_constructor, function(constructor){
if(constructor$new()$matchesSchema(schema)) constructor
}))
if (is.null(matches) || length(matches) == 0) matches = list(Argument) # if we don't find anything simply use this, since it is not restricted
return(matches)
}
processFromJson=function(json) {
if (is.null(json$summary)) json$summary = character()
tryCatch({
#map parameters!
parameter_names = sapply(json$parameters, function(p)p$name)
if (length(parameter_names) > 0) {
parameters = lapply(
json$parameters, function(pdef) {
# set param if it is contained in the schema
param = parameterFromJson(pdef)
return(param)
}
)
names(parameters) = parameter_names
} else {
parameters = list()
}
if (length(json$process_graph) > 0) {
graph = parse_graph(json=json)
} else {
graph = NULL
}
Process$new(id=json$id,
description = json$description,
summary=json$summary,
parameters = parameters,
returns = json$returns,
process_graph = graph)
}, error = function(e) {
warning(paste0("Invalid process description for '",json$id,"'"))
NULL
})
}
parameterFromJson = function(param_def) {
if (length(param_def$schema) == 0) {
# an empty schema means ANY value is allowed
arg = Argument$new()
if (length(param_def$description) > 0) {
arg$setDescription(param_def$description)
}
return(arg)
}
# if it is no unnamed object list, then box it
if (length(names(param_def$schema)) > 0) {
if (!is.null(param_def$schema$type) && is.list(param_def$schema$type)) {
param_def$schema = lapply(param_def$schema$type, function(type,original_param_schema) {
original_param_schema$type = type
return(original_param_schema)
},original_param_schema = param_def$schema)
} else {
param_def$schema = list(param_def$schema)
}
}
#special case a simple type + null, which mean a type that is a list and schema not
# then dissolve the parameter into multiple instances
# now we have a list over which we can lapply
nullable = sapply(param_def$schema, function(schema) {
nullable_single = !is.null(schema$type) && schema$type == "null"
nullable_array = !is.null(schema$type) && schema$type == "array" &&
length(schema$items$type) == 1 && schema$items$type == "null"
return(nullable_single || nullable_array)
})
param_nullable = any(nullable)
# delete the null parameter
if (param_nullable) {
param_def$schema[[which(nullable)]] = NULL
}
is_choice = length(param_def$schema) > 1
#create a list of parameters / find from schema
params = lapply(param_def$schema, function(schema) {
# this will be the normal case for simple schemas?
gen=findParameterGenerator(schema)[[1]]
param = gen$new()
if (length(schema$pattern) != 0) {
param$setPattern(schema$pattern)
}
if (length(schema$enum) != 0) {
param$setEnum(schema$enum)
}
if ("metadata-filter" %in% class(param)) {
if ("additionalProperties" %in% names(schema)) {
schema = append(schema,schema[["additionalProperties"]])
schema[["additionalProperties"]] = NULL
}
}
if ("ProcessGraphArgument" %in% class(param)) {
# iterate over all ProcessGraph parameters and create ProcessGraphParameters, but name = property name (what the process exports to ProcessGraph)
# value has to be assigned by user, then switch name and value during serialization
pg_params = lapply(schema$parameters, function(param_json) {
if (is.null(param_json$schema[["subtype"]])) param_json$schema[["subtype"]] = character()
cb = ProcessGraphParameter$new(name = param_json$name,
description = param_json$description,
type = param_json$schema[["type"]],
subtype = param_json$schema[["subtype"]],
required = TRUE)
if(!is.null(param_json$schema[["pattern"]])) cb$setPattern(param_json$schema[["pattern"]])
if (is.null(param_json$optional)) param_json$optional = FALSE
cb$isRequired = isFALSE(param_json$optional)
return(cb)
})
pg_param_names = sapply(schema$parameters,function(p)p$name)
names(pg_params) = pg_param_names
param$setProcessGraphParameters(pg_params)
}
if ("array" %in% class(param)) {
if (!"kernel" %in% class(param)) {
param$setItemSchema(schema$items)
} else {
param$setItemSchema(schema$items)
}
}
return(param)
})
# if choice then create an anyOf
if (is_choice) {
#build an anyOf
param = AnyOf$new(parameter_list = params)
} else {
param = params[[1]]
}
# in general also reolve null cases
param$isNullable = param_nullable
param$setDefault(param_def$default)
param$setName(param_def$name)
param$setDescription(param_def$name)
if (is.null(param_def$optional)) param_def$optional = FALSE
param$isRequired = isFALSE(param_def$optional)
pattern = param_def$schema$pattern
if (!is.null(pattern)) {
param$setPattern(pattern)
}
return(param)
}
Try the openeo package in your browser
Any scripts or data that you put into this service are public.
openeo documentation built on Nov. 17, 2022, 5:07 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions parameterFromJson processFromJson findParameterGenerator
# Parameter ====
# should also be abstract
#' Parameter class
#'
#' This class defines parameters of [Process()]. They store information about the type, format and
#' pattern. A parameter class is designed to not carry any value, as opposed to an
#' [Argument()].
#'
#' The parameters are parsed from the specific description and format of the JSON
#' objects returned for the parameters in processes. Find a list of openEO-specific formats here:
#' [RFC7946](https://github.com/Open-EO/openeo-processes/blob/master/meta/subtype-schemas.json)
#'
#' @name Parameter
#'
#' @return Object of [R6Class()] which represents a parameter.
#'
#'
#' @section Methods:
#' \describe{
#' \item{`$new(name, description, required=FALSE)`}{}
#' \item{`$getName`}{returns the name of a parameter as string}
#' \item{`$setName(name)`}{sets the name of a parameter}
#' \item{`$getDescription()`}{returns the description of a parameter}
#' \item{`$setDescription(description)`}{sets the description of a parameter}
#' \item{`$getPattern()`}{returns a string with the pattern of a parameter description}
#' \item{`$setPattern(pattern)`}{sets the pattern (string) for a parameter}
#' \item{`$getDefault()`}{returns the parameter's default value}
#' \item{`$setDefault(default)`}{sets the default value of a parameter}
#' \item{`$matchesSchema(schema)`}{returns TRUE if the given schema - a list of the parsed openEO
#' API schema object - matches the parameter's schema, which is used for finding the corresponding parameter}
#' \item{`$getSchema()`}{returns the schema definition}
#' \item{`$asParameterInfo()`}{returns a list representation of this parameter for being sent in a JSON to the openEO service}
#' \item{`$isNullable()`}{returns TRUE if the parameter is allowed to be nullable, FALSE otherwise}
#' \item{`$isRequired()`}{returns whether a parameter is mandatory or not}
#' \item{`$isAny()`}{returns TRUE if this parameter describes a choice of parameters}
#' }
#' @section Arguments:
#' \describe{
#' \item{`name`}{character - The name of a parameter}
#' \item{`description`}{character - The description of a parameter}
#' \item{`required`}{logical - whether it is required or not }
#' \item{`pattern`}{the regexp as a string indicating how to formulate the value}
#' \item{`default`}{the regexp as a string indicating how to formulate the value}
#' \item{`schema`}{the parsed schema object of a process parameter as a list}
#' }
#'
#' @importFrom rlang is_na
NULL
Parameter = R6Class(
"Parameter",
public = list(
initialize=function(name=character(), description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = FALSE
},
getName = function() {
return(private$name)
},
setName = function(name) {
private$name = name
},
getDescription = function() {
return(private$description)
},
setDescription = function(description) {
private$description = description
invisible(self)
},
getPattern = function() {
return(private$schema$pattern)
},
setPattern = function(pattern) {
private$schema$pattern = pattern
},
getEnum = function() {
return(private$schema$enum)
},
setEnum = function(enum){
private$schema$enum = enum
},
setDefault = function(default) {
private$default = default
invisible(self)
},
getDefault = function() {
return(private$default)
},
matchesSchema = function(schema) {
sel = c("type","subtype")
if (is.null(schema$type)) schema$type = character()
if (is.null(schema$subtype)) schema$subtype = character()
if (length(schema$type) == 0 && length(schema$subtype) == 0) return(TRUE)
return(setequal(private$schema[sel], schema[sel]))
},
getSchema = function() {
return(private$schema)
},
asParameterInfo = function() {
# the function will serialize a parameter as in a process definition, which will be used
# when describing a parameter as some sort of a variable
info = list()
info$name = self$getName()
if (length(self$getDescription()) > 0) {
if (!is.na(self$getDescription()) || nchar(self$getDescription()) > 0) {
info$description = self$getDescription()
}
}
if (self$isNullable) {
info$optional = TRUE
info$default = NA
}
# if the parameter is required "optional" can be left out
if (all(c("Argument","Parameter","R6") %in% class(self)) &&
all(class(self) %in% c("Argument","Parameter","R6"))) {
# this is an object where anything goes in (Any)
info$schema = list(description = "Any data type")
} else if (all(c("anyOf","Argument","Parameter","R6") %in% class(self))) {
info$schema = lapply(self$getChoice(), function(param) {
param$asParameterInfo()
})
if (self$isNullable) {
info$schema = append(private$schema, list(list(type = "null")))
}
} else if (self$isNullable) {
info$schema$type = list(private$schema$type,"null")
} else {
info$schema = private$schema
}
info$schema = .clean_empty_fields(info$schema)
return(info)
}
),
active = list(
isNullable = function(value) {
if (missing(value)) {
return(private$nullable)
} else {
value = as.logical(value)
if (rlang::is_na(value)) {
warning("Cannot cast value to logical. Assume FALSE.")
value = FALSE
}
private$nullable = value
}
},
isRequired = function(value) {
if (missing(value)) {
return(private$required)
} else {
value = as.logical(value)
if (rlang::is_na(value)) {
warning("Cannot cast value to logical. Assume FALSE.")
value = FALSE
}
private$required = value
}
},
isAny = function() {
length(private$schema$type) == 0
}
),
private = list(
name=character(),
nullable = FALSE,
default = character(),
schema = list(
type=character(),
subtype = character(),
pattern = character(),
parameters = list(), # potential ProcessGraphParameter (variables)
# items are relevant for arrays
items = list(
type=NULL # type name, e.g. "string", "array","number","any", etc.
),
minItems = integer(),
maxItems = integer(),
enum = character()
),
required = logical(),
description = character()
)
)
# Argument ====
#' Argument class
#'
#' This class inherits all fields and functions from [Parameter()] adds the functionality to
#' manage a value. This includes getter/setter, validation and serialization. Since this is the parent class
#' for the type specific argument classes, the inheriting classes implement their own version of the private
#' functions `$typeCheck()` and `$typeSerialization()`.
#'
#' @name Argument
#'
#' @return Object of [R6Class()] representing an argument.
#'
#' @section Methods:
#' \describe{
#' \item{`$setValue(value)`}{Assigns a value to this argument}
#' \item{`$getValue()`}{Returns the value of this argument}
#' \item{`$serialize()`}{returns a list representation of a openEO argument}
#' \item{`$validate()`}{return TRUE if the parameter is validated positively by the type check}
#' \item{`$isEmpty()`}{returns TRUE if the value is set}
#' \item{`$getProcess()`}{returns the process this parameter belongs to}
#' \item{`$setProcess(p)`}{sets the owning process for this parameter}
#' }
#' @section Arguments:
#' \describe{
#' \item{`value`}{The value for this argument.}
#' \item{`p`}{An object of class 'Process' or inheriting like 'ProcessNode'}
#' }
#'
#' @importFrom rlang is_na
NULL
Argument = R6Class(
"Argument",
inherit=Parameter,
public = list(
setValue = function(value) {
private$value = value
},
getValue = function() {
private$value
},
serialize = function() {
# nullable / required / value = NULL
if (self$isNullable &&
(length(self$getValue()) == 0 ||
(!is.environment(self$getValue()) &&
rlang::is_na(self$getValue())))
) {
if (self$isRequired) {
return(NA)
} else {
return(NULL)
}
}
if (any(c("ProcessGraphParameter") %in% class(self$getValue()))) {
return(self$getValue()$serialize())
}
if ("ProcessNode" %in% class(self$getValue())) {
return(self$getValue()$serializeAsReference())
}
# for format specific conversion overwrite this by children
tryCatch({
return(private$typeSerialization())
}, error = function(e) {
serialization_error = paste0("Error serializing parameter '",self$getName(),
"' in process node '", self$getProcess()$getNodeId(),
"' :",e$message)
stop(serialization_error)
})
},
validate = function() {
tryCatch(
{
private$checkRequiredNotSet()
if (!self$isRequired &&
!is.environment(private$value) &&
self$isEmpty()) {
} else {
# ProcessGraphParameter -> variable
# schema$type length == 0 -> ANY
if (any(c("ProcessGraphParameter") %in% class(self$getValue()))) return(invisible(NULL))
if ("ProcessNode" %in% class(self$getValue()) && self$getValue()$getReturns()$isAny) return(invisible(NULL))
private$typeCheck()
}
invisible(NULL)
}, error = function(e) {
if (length(self$getProcess()) >0 ) {
node_id = self$getProcess()$getNodeId()
if (!is.null(node_id)) node_id = paste0("[",node_id,"] ")
message = paste0(node_id,"Parameter '",private$name,"': ",e$message)
} else {
message = e$message
}
return(message)
}
)
},
isEmpty = function() {
return(!is.environment(private$value) && !is.function(private$value) && !is.call(private$value) && (
is.null(private$value) ||
rlang::is_na(private$value) ||
length(private$value) == 0))
},
getProcess = function() {
return(private$process)
},
setProcess = function(p) {
private$process = p
return(invisible(self))
}
),
# private =====
private = list(
value=NULL,
process = NULL,
checkRequiredNotSet = function() {
if (private$required &&
!self$isNullable &&
!is.environment(private$value) &&
self$isEmpty()) stop("Argument is required, but has not been set.")
},
typeCheck = function() {
# implemented / overwritten by children
},
typeSerialization = function() {
# implemented / overwritten by children
#if nothing is done, then simply return the object
if (self$isEmpty() && !self$isRequired) return(NULL)
else return(private$value)
},
deep_clone = function(name, value) {
if (name == "process") {
return(value)
}
# this is the anyOf case
if (name == "parameter_choice") {
new_list = list()
if (is.null(names(value))) {
iterable = 1:length(value)
} else {
iterable = names(value)
}
for (list_name in iterable) {
list_elem = value[[list_name]]
if ("R6" %in% class(list_elem)) {
list_elem = list_elem$clone(deep=TRUE)
}
entry = list(list_elem)
names(entry) = list_name
new_list = append(new_list,entry)
}
return(new_list)
}
if (is.environment(value) && !is.null(value$`.__enclos_env__`)) {
return(value$clone(deep = TRUE))
}
return(value)
}
)
)
# Integer ====
#' Integer class
#'
#' Inheriting from [Argument()] in order to represent a single integer value.
#'
#' @name Integer
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing an Integer
NULL
Integer = R6Class(
"integer",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "integer"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("Integer cannot be an array.")
if (!is.na(private$value) && !is.integer(private$value)) {
suppressWarnings({
coerced = as.integer(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into integer."))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
if (self$isEmpty() && !self$isRequired) return(NULL)
else return(as.integer(private$value))
}
)
)
# EPSG-Code ====
#' EPSGCode class
#'
#' Inheriting from [Argument()] in order to represent an EPSG Code. Allowed values are single integer values like `4326` or a text containing 'EPSG:' like `EPSG:4326`.
#'
#' @name EPSGCode
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing an EPSG code as Integer
NULL
EPSGCode = R6Class(
"epsg-code",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "integer"
private$schema$subtype = "epsg-code"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("EPSG code cannot be an array.")
if (!is.na(private$value) && !is.integer(private$value)) {
suppressWarnings({
coerced = as.integer(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) {
if (is.character(private$value) && grepl(tolower(private$value),pattern = "^epsg:")) {
coerced = as.integer(gsub(x = private$value,replacement = "",pattern = "[^0-9]"))
} else {
stop(paste0("Value '", private$value,"' cannot be coerced into integer."))
}
}
# correct value if you can
private$value = coerced
return(invisible(NULL))
}
},
typeSerialization = function() {
if (self$isEmpty() && !self$isRequired) return(NULL)
else return(as.integer(private$value))
}
)
)
# Number ====
#' Number class
#'
#' Inheriting from [Argument()] in order to represent a numeric value.
#'
#' @name Number
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a number
NULL
Number = R6Class(
"number",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "number"
},
setValue = function(value) {
process_collection = self$getProcess()$getGraph()
private$value = .checkMathConstants(value,process_collection)
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("Number cannot be an array.")
if ("ProcessNode" %in% class(private$value)) {
return_value = private$value$getReturns()
if (!any(c("number","integer") %in% class(return_value) &&
length(return_value$getSchema()$type)) != 0) {
stop(paste0("Value 'ProcessNode' returns neither the ANY object nor a number."))
}
# if (!is.null(return_schema$type) && !"number" %in% unlist(return_schema$type))
} else if (!is.na(private$value) && !is.numeric(private$value)) {
suppressWarnings({
coerced = as.numeric(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a number."))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
if ("ProcessNode" %in% class(private$value)) {
return(private$value$serialize())
} else if (self$isEmpty() && !self$isRequired) {
return(NULL)
} else {
return(as.numeric(private$value))
}
}
)
)
# String ====
#' String class
#'
#' Inheriting from [Argument()] in order to represent a character string value.
#'
#' @name String
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a string.
NULL
String = R6Class(
"string",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value) &&
!any(c("CubeDimension") %in% class(private$value))) stop("String cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character string."))
# correct value if you can
private$value = coerced
}
if (length(self$getEnum()) > 0) {
if (!private$value %in% self$getEnum()) {
stop(paste0("Enum was stated, but the value does not match any enum."))
}
}
return(invisible(NULL))
},
typeSerialization = function() {
if (length(private$value) > 1 && !is.environment(private$value) &&
!any(c("CubeDimension") %in% class(private$value))) stop("String cannot be an array.")
if (is.call(private$value)) {
return(paste(deparse(private$value),collapse = "\n"))
} else if (is.character(private$value)) {
if (file.exists(private$value)) {
# if valid file path open file and attach
tryCatch({
suppressWarnings({
content = readChar(private$value, file.info(private$value)$size)
return(content)
})
}, error = function(e) {
return(private$value)
})
} else {
return(private$value)
}
} else if (self$isEmpty() && !self$isRequired) {
return(NULL)
} else if (!is.environment(private$value) && is.na(private$value)) {
return(NA)
} else {
return(as.character(private$value))
}
}
)
)
# URI ====
URI = R6Class(
"uri",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "uri"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("URI cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character string."))
# correct value if you can
private$value = coerced
}
if (!file.exists(private$value) || !grepl(private$value,pattern="\\w+:(\\/?\\/?)[^\\s]+")) stop("Value is not an URI or file.")
return(invisible(NULL))
},
typeSerialization = function() {
if (is.character(private$value)) {
if (file.exists(private$value)) {
# if valid file path open file and attach
return(readChar(private$value, file.info(private$value)$size))
} else {
return(private$value)
}
} else {
return(as.character(private$value))
}
}
)
)
# Output Format ====
#' OutputFormat class
#'
#' Inheriting from [Argument()] in order to represent an output format of a back-end as a
#' character string value.
#'
#' @name OutputFormat
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing an output format of a back-end.
NULL
OutputFormat = R6Class(
"output-format",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "output-format"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value) && !"FileFormat" %in% class(private$value)) stop("Output format cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
if ("FileFormat" %in% class(private$value)) {
# what to do?
} else {
suppressWarnings({
coerced = as.character(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character string."))
# correct value if you can
private$value = coerced
}
}
return(invisible(NULL))
},
typeSerialization = function() {
if ("FileFormat" %in% class(private$value)) {
return(private$value$name)
} else {
return(as.character(private$value))
}
}
)
)
# CollectionId ====
#' CollectionId class
#'
#' Inheriting from [Argument()] in order to represent a CollectionId on an openeo back-end.
#'
#' @name CollectionId
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a CollectionId.
NULL
CollectionId = R6Class(
"collection-id",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "collection-id"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value) && ! "Collection" %in% class(private$value)) stop("Collection ID cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
if (!"Collection" %in% class(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (length(private$schema$pattern) > 0) {
if (!grepl(pattern=private$schema$pattern,x=coerced,perl=TRUE)) stop(paste0("The provided regexpr pattern does not match the value: ",private$value))
}
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character string."))
# correct value if you can
private$value = coerced
} else {
coerced = private$value$id
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("CollectionId obtained from service is not valid, please contact the openEO service support."))
}
} else {
if (!grepl(pattern=private$schema$pattern,x=private$value,perl=TRUE)) stop(paste0("The provided value does not match the required pattern: ",private$value))
}
return(invisible(NULL))
},
typeSerialization = function() {
if (!"Collection" %in% class(private$value)) {
return(as.character(private$value))
} else {
return(private$value$id)
}
}
)
)
# JobId ====
#' JobId class
#'
#' Inheriting from [Argument()] in order to represent a jobId on an openeo back-end.
#'
#' @name JobId
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing the id of a job.
NULL
JobId = R6Class(
"job-id",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "job-id"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 &&
!is.environment(private$value) &&
!"Job" %in% class(private$value)) stop("Job id cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (!grepl(pattern=private$schema$pattern,x=private$value, perl=TRUE)) stop(paste0("The provided regexpr pattern does not match the value: ",private$value))
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character string."))
# correct value if you can
private$value = coerced
} else {
if (!grepl(pattern=private$schema$pattern,x=private$value,perl=TRUE)) stop(paste0("The provided value does not match the required pattern: ",private$value))
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(private$value))
}
)
)
# UdfRuntime argument ====
#' UdfRuntimeArgument class
#'
#' Inheriting from [Argument()] in order to represent the id of an UDF runtime object as obtainable by [list_udf_runtimes()].
#'
#' @name UdfRuntimeArgument
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing the UDF runtime in a process argument.
NULL
UdfRuntimeArgument = R6Class(
"udf-runtime",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "udf-runtime"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 &&
!is.environment(private$value) &&
!"UdfRuntime" %in% class(private$value)) stop("UDF runtime cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a runtime id."))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(private$value))
}
)
)
# UdfRuntimeVersion argument ====
#' UdfRuntimeVersionArgument class
#'
#' Inheriting from [Argument()] in order to represent the id of a UDF runtime object as obtainable by [list_udf_runtimes()].
#'
#' @name UdfRuntimeVersionArgument
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] is an argument that expects a UDF runtime version or character as value.
NULL
UdfRuntimeVersionArgument = R6Class(
"udf-runtime-version",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "udf-runtime-version"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 &&
!is.environment(private$value) &&
!"UdfRuntimeVersion" %in% class(private$value)) stop("UDF runtime version cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into an UDF runtime version string."))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(private$value))
}
)
)
# UdfCode argument ====
#' UdfCodeArgument class
#'
#' Inheriting from [Argument()] in order to represent the UDF code that will be executed in a UDF call. The script has to
#' be passed as a character string or as a local file path from which the script can be loaded.
#'
#' @name UdfCodeArgument
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] is an argument that expects an UDF code or a file path.
NULL
UdfCodeArgument = R6Class(
"udf-code",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "udf-code"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("UDF code cannot be an array cannot be an array.")
# parse
if (!self$isEmpty() && !is.character(private$value)) {
if (is.function(private$value)) {
} else {
suppressWarnings({
coerced = as.character(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character string."))
# correct value if you can
private$value = coerced
}
}
return(invisible(NULL))
},
typeSerialization = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("UDF code cannot be an array.")
if (is.call(private$value) || is.function(private$value)) {
return(deparse1(private$value,collapse = "\n"))
} else if (is.character(private$value)) {
if (file.exists(private$value)) {
# if valid file path open file and attach
tryCatch({
suppressWarnings({
content = readChar(private$value, file.info(private$value)$size)
return(content)
})
}, error = function(e) {
return(private$value)
})
} else {
return(private$value)
}
} else if (self$isEmpty() && !self$isRequired) {
return(NULL)
} else if (!is.environment(private$value) && is.na(private$value)) {
return(NA)
} else {
return(as.character(private$value))
}
}
)
)
# ProcessGraphId ====
#' ProcessGraphId
#'
#' Inheriting from [Argument()] in order to represent a process graph Id on an openeo back-end.
#'
#' @name ProcessGraphId
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing the id of a process graph.
NULL
ProcessGraphId = R6Class(
"process-graph-id",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "process-graph-id"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("Process graph id cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (!grepl(pattern=private$schema$pattern,x=private$value,perl=TRUE)) stop(paste0("The provided regexpr pattern does not match the value: ",private$value))
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character string."))
# correct value if you can
private$value = coerced
} else {
if (!grepl(pattern=private$schema$pattern,x=private$value,perl=TRUE)) stop(paste0("The provided value does not match the required pattern: ",private$value))
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(private$value))
}
)
)
# Proj-Definition ====
#' ProjDefinition
#'
#' Inheriting from [Argument()] in order to represent a projection definition as a PROJ string.
#'
#' @name ProjDefinition
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a projection definition based on PROJ.
NULL
ProjDefinition = R6Class(
"proj-definition",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "proj-definition"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("PROJ definition cannot be an array.")
if (!is.na(private$value) && !is.character(private$value)) {
suppressWarnings({
coerced = as.character(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a character proj definition."))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(private$value))
}
)
)
# Bounding Box ====
#' BoundingBox
#'
#' Inheriting from [Argument()] in order to represent a bounding box / extent of an area of
#' interest. Its value is usually a named list with "west","south","east" and "north". For this argument
#' the 'bbox' object of the sf package is also recognized ([sf::st_bbox()]). This holds also true for
#' classes that support [sf::st_bbox()] and return a valid 'bbox' object.
#'
#' @name BoundingBox
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a bounding box / extent.
#'
#' @examples \dontrun{
#' # most of the time BoundingBox is a choice as parameter value for
#' # spatial_extent in 'load_collection'
#' p = processes()
#'
#' # using a list
#' bbox = list(west=10.711799440170706,
#' east= 11.542794097651838,
#' south=45.92724558214729,
#' north= 46.176044942018734)
#'
#' data = p$load_collection(id = "SENTINEL2_L2A",
#' spatial_extent = bbox,
#' temporal_extent = list("2020-01-01T00:00:00Z", "2020-01-20T00:00:00Z"),
#' bands = list("B04","B08"))
#'
#' # using sf bbox
#' bbox = st_bbox(c(xmin=10.711799440170706,
#' xmax= 11.542794097651838,
#' ymin=45.92724558214729,
#' ymax= 46.176044942018734),
#' crs = 4326)
#'
#' data = p$load_collection(id = "SENTINEL2_L2A",
#' spatial_extent = bbox,
#' temporal_extent = list("2020-01-01T00:00:00Z", "2020-01-20T00:00:00Z"),
#' bands = list("B04","B08"))
#'
#' # objects supporting sf::st_bbox()
#' img = stars::read_stars(system.file("tif/L7_ETMs.tif",package = "stars"))
#' data = p$load_collection(id = "SENTINEL2_L2A",
#' spatial_extent = img,
#' temporal_extent = list("2020-01-01T00:00:00Z", "2020-01-20T00:00:00Z"),
#' bands = list("B04","B08"))
#'
#' }
NULL
BoundingBox = R6Class(
"bounding-box",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "object"
private$schema$subtype = "bounding-box"
},
setValue = function(value) {
bbox=tryCatch(sf::st_bbox(value),error=function(e) NULL)
if (is.null(bbox)) {
if (is.list(value)) {
if ("crs" %in% names(value)) {
crs_value = value[["crs"]]
if (is.character(crs_value) && grepl(tolower(crs_value),pattern = "^epsg:")) {
value[["crs"]] = as.integer(gsub(x = crs_value,replacement = "",pattern = "[^0-9]"))
}
}
}
private$value= value
} else {
private$value = bbox
}
}
),
private = list(
typeCheck = function() {
value = private$value
# should be a list
if ("bbox" %in% class(value)) {
# TODO maybe check completeness?
return(NULL)
} else if (!is.list(value)) {
tryCatch(
{
value = as.list(value)
},
error = function(e) {
stop("Cannot coerce values of bounding box into a list")
}
)
}
obj_names = names(value)
if (length(obj_names) == 0) stop("Bounding box parameter are unnamed. Cannot distinguish between values.")
# check if west, south, east, north are set and all are numeric values or coercable as numeric
required_dir_params = c("west","south","east","north")
if (!all(required_dir_params %in% obj_names)) stop(paste0(
"Bounding box parameters are missing: ", paste(required_dir_params[!required_dir_params %in% obj_names],collapse = ", ")
))
suppressWarnings({
vals = lapply(value[obj_names],as.numeric)
nas = sapply(vals, is.na)
if (any(nas)) {
stop("Not all bbox parameters are numeric or can be coerced into numeric automatically: ",paste0(obj_names[nas],collapse = ", "))
} else {
value[obj_names] = vals
}
})
# check if crs is set (either proj string or epsg code)
if ("crs" %in% obj_names) {
crs_value = value[["crs"]]
if (!is.integer(crs_value) && !is.numeric(crs_value)) {
if (!is.character(crs_value)) stop("CRS is not an EPSG identifier or a PROJ string")
# automatical conversion in this EPSG cases
if (!grepl(pattern="epsg:", tolower(crs_value))) {
stop("CRS String does not contain an EPSG identifier")
# value[["crs"]] = as.integer(sub(pattern = "epsg:",replacement = "",tolower(crs_value)))
}
}
} # else nothing, since it is not required, but its assumed to be WGS84
# check if base and height are set (both or none), also those have to be numeric
height_selector = c("base","height")
if (do.call(xor,as.list(height_selector %in% obj_names))) {
stop("Height was considered, but either 'base' or 'height' is missing.")
}
if (all(height_selector %in% obj_names)) {
height_extent = value[height_selector]
suppressWarnings({
height_extent = sapply(height_extent,as.numeric)
if (any(sapply(height_extent,is.na))) {
stop("'Base' or 'height' cannot be interpreted as numeric value")
} else {
value[height_selector] = height_extent
}
})
}
return(invisible(NULL))
},
typeSerialization = function() {
if (length(self$getValue()) == 0) {
return(NULL)
} else {
#if bbox from sf package serialize it accordingly
if ("bbox" %in% class(private$value)) {
bbox = private$value
crs = sf::st_crs(bbox)
result = list(west=unname(bbox$xmin),
east=unname(bbox$xmax),
south=unname(bbox$ymin),
north=unname(bbox$ymax))
if (crs != sf::st_crs(4326)) {
if (grepl(tolower(crs$input),pattern="^epsg:")) {
result$crs = crs$input
} else {
result$crs = crs$wkt
}
}
} else {
result = self$getValue()
}
if (is.list(result)) {
if ("crs" %in% names(result)) {
crs_value = result[["crs"]]
if (is.character(crs_value) && grepl(tolower(crs_value),pattern = "^epsg:")) {
result[["crs"]] = as.integer(gsub(x = crs_value,replacement = "",pattern = "[^0-9]"))
}
}
}
return(result)
}
}
)
)
# Boolean ====
#' Boolean
#'
#' Inheriting from [Argument()] in order to represent a boolean / logical.
#'
#' @name Boolean
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a boolean / logical.
NULL
Boolean = R6Class(
"boolean",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "boolean"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("Boolean cannot be an array.")
if (length(private$value) > 0 && "ProcessNode" %in% class(private$value)) {
if (! "boolean" %in% class(private$value$getReturns())) {
stop("No logical return from ProcessNode.")
}
return(invisible(NULL))
}
if (!is.na(private$value) && !is.logical(private$value)) {
suppressWarnings({
coerced = as.logical(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a boolean/logical."))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.logical(private$value))
}
)
)
# Date ====
#' Date
#'
#' Inheriting from [Argument()] in order to represent a date.
#'
#' @name Date
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a date.
NULL
Date = R6Class(
"date",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "date"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("Date cannot be an array.")
if (!is.na(private$value) && !is.Date(private$value)) {
suppressWarnings({
coerced = as_date(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a date"))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(format(private$value,format = "%Y-%m-%d")))
}
)
)
# DateTime ====
#' DateTime
#'
#' Inheriting from [Argument()] in order to represent a date with time component.
#'
#' @name DateTime
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a date with time component.
#'
#' @import lubridate
NULL
DateTime = R6Class(
"date-time",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "date-time"
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("Timestamp cannot be an array.")
if (!is.na(private$value) && !is.POSIXct(private$value)) {
suppressWarnings({
coerced = as_datetime(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a date time object"))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(format(private$value,format = "%Y-%m-%dT%H:%M%SZ")))
}
)
)
# Time ====
#' Time
#'
#' Inheriting from [Argument()] in order to represent the time of a day.
#'
#' @name Time
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing the time of a day.
NULL
Time = R6Class(
"time",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "string"
private$schema$subtype = "time"
},
setValue = function(value) {
# the value will be a posixct where we just return the time component
if (is.character(value)) {
private$value = strptime(value, format="%H:%M:%SZ")
} else {
private$value= value
}
},
getValue = function() {
return(self$serialize())
}
),
private = list(
typeCheck = function() {
if (length(private$value) > 1 && !is.environment(private$value)) stop("Time cannot be an array.")
if (!is.na(private$value) && !is.POSIXct(private$value)) {
suppressWarnings({
coerced = strptime(value, format="%H:%M:%SZ")
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a time representation"))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
return(as.character(format(private$value,format = "%H:%M:%SZ")))
}
)
)
# GeoJson ====
#' GeoJson
#'
#' Inheriting from [Argument()] in order to represent a GeoJson object. This class represents geospatial features.
#' Allowed values are either a list directly convertible into a valid GeoJson or polygon features of type 'sf' or 'sfc'
#' from package 'sf'. The current implementation follows the data representation of 'sf' - meaning that coordinate order is
#' XY (e.g. if CRS84 is used then lon/lat is the default order).
#'
#' As GeoJSON is defined in <https://datatracker.ietf.org/doc/html/rfc7946>{RFC7946} the coordinate reference system is
#' `urn:ogc:def:crs:OGC::CRS84`, which uses a longitude, latitude ordering of the coordinates.
#'
#'
#' @name GeoJson
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing an object in GeoJson.
#'
#' @importFrom rlang is_na
NULL
GeoJson = R6Class(
"geojson",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "object"
private$schema$subtype = "geojson"
},
setValue = function(value) {
if (!.is_package_installed("sf")) {
warnings("Package sf is not installed but required for GeoJson support.")
}
# lists are checked for each element for is.na if run under unix
if (!is.environment(value) && (is.null(value) || rlang::is_na(value))) {
private$value = value
return()
}
if (all(c("XY","POLYGON") %in% class(value))) {
private$value = sf::st_sfc(value)
return()
}
if (any(c("sf","sfc") %in% class(value))) {
private$value = value
return()
}
old_class = class(value)
value = unclass(value)
if (is.list(value) && "type" %in% names(value)) {
# this case is a geojson parsed as list
tryCatch({
tmpfile = tempfile()
jsonlite::write_json(value,tmpfile, auto_unbox=TRUE, digits = NA)
suppressWarnings({
private$value = sf::read_sf(tmpfile,crs=4326)
})
}, finally = unlink(tmpfile))
} else {
stop("Cannot set given object for argument 'GeoJSON': class ",paste(sep=",",old_class)," not supported")
}
},
getValue = function() {
return(private$value)
}
),
private = list(
typeCheck = function() {
if ("sf" %in% class(private$value)) {
return(NULL)
} else if ("sfc" %in% class(private$value)) {
return(NULL)
} else if (is.list(private$value)) {
if (!"type" %in% names(private$value)) {
#TODO better probing
stop("Value is not GeoJSON.")
}
#if list we assume that the geojson object was created as list
return(NULL)
} else {
stop("Class ",paste(class(private$value)), " not supported in GeoJson argument")
}
},
typeSerialization = function() {
if (self$isEmpty()) {
return(private$value)
}
if (any(c("sf","sfc") %in% class(private$value))) {
value = sf::st_transform(private$value,4326)
tryCatch({
t = tempfile()
sf::write_sf(value,t,driver="geojson")
obj = jsonlite::read_json(t,simplifyVector = FALSE)
# remove CRS just to be in line with the geojson specification (4326, lat/lon, no crs field)
obj["crs"] = NULL
return(obj)
}, finally = unlink(t))
} else if (is.list(private$value) && "type" %in% names(private$value)) {
return(private$value)
} else {
stop("Unsupported value type.")
}
}
)
)
# OutputFormatOptions ====
#' OutputFormatOptions
#'
#' Inheriting from [Argument()] in order to represent the additional output format options of a back-end.
#'
#' @name OutputFormatOptions
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing output format options.
NULL
OutputFormatOptions = R6Class(
"output-format-options",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "object"
private$schema$subtype = "output-format-options"
}
),
private = list(
typeCheck = function() {
if (!self$isEmpty()) {
if (!is.list(private$value)) {
stop("Output format options are not a list")
}
}
},
typeSerialization = function() {
return(as.list(private$value))
}
)
)
# RasterCube ====
#' RasterCube
#'
#' Inheriting from [Argument()] in order to represent a raster cube. This is usually the in- and
#' output format of a process unless the process operates within a ProcessGraph on reduced data.
#' The [VectorCube()] behaves comparably, but with underlying spatial feature data.
#'
#' @name RasterCube
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a raster cube.
NULL
RasterCube = R6Class(
"raster-cube",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "object"
private$schema$subtype = "raster-cube"
}
),
private = list(
typeCheck = function() {
# a raster data cube can only be derived by process, e.g. get_collection so this
# value should be a ProcessNode
if (! "ProcessNode" %in% class(private$value)) stop("RasterCube is not retreived by process.")
invisible(NULL)
},
typeSerialization = function() {
if ("ProcessNode" %in% class(private$value)) {
return(private$value$serializeAsReference())
}
return(as.character(private$value))
}
)
)
# VectorCube ====
#' VectorCube
#'
#' Inheriting from [Argument()] in order to represent a vector cube. This is analogous to
#' the [RasterCube()].
#'
#' @name VectorCube
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a vector cube.
NULL
VectorCube = R6Class(
"vector-cube",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "object"
private$schema$subtype = "vector-cube"
}
),
private = list(
typeCheck = function() {
# a vector data cube can only be derived by process, e.g. get_collection so this
# value should be a ProcessNode
if (! "ProcessNode" %in% class(private$value)) stop("VectorCube is not retreived by process.")
invisible(NULL)
},
typeSerialization = function() {
if ("ProcessNode" %in% class(private$value)) {
return(private$value$serializeAsReferences())
}
return(as.character(private$value))
}
)
)
# ProcessGraphArgument ====
#' ProcessGraphArgument
#'
#' Inheriting from [Argument()] in order to represent an argument that contains a process or a derivable value (formerly known
#' as callback). The ProcessGraphArgument operates on the reduced data of a data cube. For example reducing or aggregating over
#' the temporal dimension results in a time series that has to be reduced into a single value or aggregated into another time
#' series. The value of a ProcessGraphArgument is usually a function that will be coerced into [`Process()`]. The function
#' is required to use the same amount of parameters as `ProcessGraphParameter` objects are defined, because during the coercion
#' those `ProcessGraphParameter` are passed to function. Additional information can be found in the openEO API documentation:
#' \itemize{
#' \item <https://api.openeo.org/#section/Processes/Process-Graphs>
#' }
#'
#' @section Methods:
#' \describe{
#' \item{`$getProcessGraphParameters()`}{returns the available list [ProcessGraphParameter()]}
#' \item{`$setProcessGraphParameters(parameters)`}{assigns a list of [ProcessGraphParameter()] to the ProcessGraph}
#' }
#'
#' @section Arguments:
#' \describe{
#' \item{`parameters`}{the [ProcessGraphParameter()] list}
#' }
#'
#' @name ProcessGraphArgument
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a ProcessGraph.
NULL
ProcessGraphArgument = R6Class(
"ProcessGraphArgument",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "object"
private$schema$subtype = "process-graph"
},
setValue = function(value) {
if ("function" %in% class(value)) {
# if value is a function -> then make a call with the function and a suitable ProcessGraph
# parameter
# create a new graph
process_collection = private$process$getGraph()
# probably switch temporarily the graph of the parent process
# then all newly created process nodes go into the new graph
private$process$setGraph(process_collection)
process_graph_parameter = private$parameters
# find suitable ProcessGraph parameter (mostly array or binary) -> check for length of formals
# the issue can no longer been resolved automatically
if (length(formals(value)) != length(process_graph_parameter)) stop("Function parameter do not match ProcessGraph parameter(s)")
names(process_graph_parameter) = names(formals(value))
lapply(process_graph_parameter, function(cb){cb$setProcess(private$process)})
# make call
final_node = do.call(value,args = process_graph_parameter)
# then serialize it via the final node
# assign new graph as value
private$value = Graph$new(final_node = final_node)
} else if ("ProcessNode" %in% class(value)) {
private$value = Graph$new(final_node = value)
} else if ("Graph" %in% class(value) || rlang::is_na(value)) {
private$value = value
} else {
stop("Assigned value for process graph needs to be function, graph or a final process node.")
}
},
setProcess = function(p) {
private$process = p
lapply(private$parameters, function(cbv) {
cbv$setProcess(p)
})
return(invisible(self))
},
setProcessGraphParameters = function(parameters) {
private$parameters = parameters
},
getProcessGraphParameters = function() {
return(private$parameters)
}
),
private = list(
parameters = list(),
typeCheck = function() {
# check the value (graph) for the same ProcessGraph parameters (ProcessGraphParameters)
if (!"Graph" %in% class(private$value)) stop("The value of a ProcessGraph argument is usually a graph.")
errors = private$value$validate()
if (any(errors != TRUE)) {
stop(paste("Errors in subgraph:",paste(errors,collapse=";")))
}
return(invisible(NULL))
},
typeSerialization = function() {
if (is.environment(private$value) && "serialize" %in% names(private$value)) {
return(list(
process_graph = private$value$serialize()))
}
}
)
)
# ProcessGraphParameter ====
#' ProcessGraphParameter
#'
#' Inheriting from [Argument()] in order to represent the available data within a ProcessGraph graph.
#' Additional information can be found in the openEO API documentation:
#' \itemize{
#' \item <https://api.openeo.org/#section/Processes/Process-Graphs>
#' }
#'
#' @name ProcessGraphParameter
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a ProcessGraph value.
NULL
# in case the ProcessGraphParameter is an array - which it will be in most cases - we have to store
# process nodes for array subsetting in the object with its index. This should be done to
# reuse the results of previous steps
ProcessGraphParameter = R6Class(
"ProcessGraphParameter",
inherit=Argument,
public = list(
initialize=function(name=character(),
description=character(),
type=character(),
subtype=character(),
default=character(),
required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = type
private$schema$subtype = subtype
private$default = default
},
print = function() {
cat(jsonlite::toJSON(self$serialize(),pretty = TRUE, auto_unbox = TRUE,digits=NA))
invisible(self)
},
adaptType = function(fromParameter) {
if (is.list(fromParameter) && length(fromParameter) == 1) {
fromParameter = fromParameter[[1]]
private$schema = fromParameter$getSchema()
private$default = fromParameter$getDefault()
private$required = fromParameter$isRequired
private$nullable = fromParameter$isNullable
} else {
stop("Not considered yet")
}
invisible(self)
}
),
private = list(
typeSerialization = function() {
if (self$isEmpty()) {
return(list(from_parameter=private$name))
} else {
if ("Argument" %in% class(private$value)) {
value_serialization = self$getValue()$serialize()
} else if ("FileFormat" %in% class(private$value)) {
value_serialization = private$value$name
} else {
value_serialization = self$getValue()
}
return(value_serialization)
}
}
)
)
setOldClass(c("ProcessGraphParameter","Argument","Parameter","R6"))
# Array ====
#' Array
#'
#' Inheriting from [Argument()] in order to represent an array of a single data type.
#'
#' @name Array
#'
#' @section Methods:
#' \describe{
#' \item{`$getMinItems`}{returns the minimum number of items}
#' \item{`$getMaxItems`}{returns the maximum number of items}
#' \item{`$setMinItems(value)`}{sets the minimum number of items}
#' \item{`$setMaxItems(value)`}{sets the maximum number of items}
#' \item{`$getItemSchema`}{returns the item schema of the items in the array}
#' \item{`$setItemSchema(value)`}{sets the schema for the items in the array}
#' }
#'
#' @section Arguments:
#' \describe{
#' \item{`value`}{either a number describing the minimum and maximum number of elements in an array or the
#' parsed JSON schema of a single item in the array}
#' }
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a single valued array.
#'
#' @importFrom rlang is_na
NULL
Array = R6Class(
"array",
inherit=Argument,
public = list(
initialize=function(name=character(),
description=character(),
type=character(),
format=character(),
items=list(),
required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "array"
private$schema$subtype = format
private$schema$items = items
},
getMinItems = function() {
return(private$schema[["minItems"]])
},
getMaxItems = function() {
return(private$schema[["maxItems"]])
},
setMinItems = function(value) {
private$schema[["minItems"]] = value
},
setMaxItems = function(value) {
private$schema[["maxItems"]] = value
},
getItemSchema = function() {
return(private$schema$items)
},
setItemSchema = function(value) {
if (!"type" %in% names(value)) {
value[["type"]]="any"
} else if (any(value$type == "null")) {
value$type[value$type == "null"] = NULL
value$type = unlist(value$type)
value$nullable = TRUE
}
if (is.null(value[["minItems"]])) value[["minItems"]] = integer()
if (is.null(value[["maxItems"]])) value[["maxItems"]] = integer()
private$schema$items = value
},
setValue = function(value) {
if (length(self$getProcess()) > 0) {
process_collection = self$getProcess()$getGraph()
} else {
process_collection = NULL
}
if (!is.environment(value) && length(value) > 0) {
private$value = lapply(value, function(x, pc) {
.checkMathConstants(x,pc)
}, pc = process_collection)
} else {
private$value = value
}
}
),
private = list(
typeCheck = function() {
itemType = private$schema$items$type
if (length(itemType) == 0 || length(itemType) > 1) {
# this can be anything or is to complicated to check in R so we shift the responsibility to the back-end
return(invisible(NULL))
}
if (length(private$schema$minItems) == 1 &&
length(private$value) < private$schema$minItems) {
stop(paste0("Minimum items are not achieved. Found ",length(private$value)," items of minimal ",private$schema$minItems," items."))
}
if (length(private$schema$maxItems) == 1 &&
length(private$value) > private$schema$maxItems) {
stop(paste0("More items than maximum. Found ",length(private$value)," items of maximal ",private$schema$maxItems," items."))
}
if (itemType == "array") {
# just check the first layer, everything else would be nice, but is no more in our responsibility
if ("ProcessGraphParameter" %in% class(private$value)) {
if (length(private$value$getSchema()$type) > 0 &&
private$value$getSchema()$type == "array")
if (length(private$value$getSchema()$items$type) > 0) {
if (private$value$getSchema()$items$type == private$schema$items$type) {
return()
}
} else {
stop("Selected ProcessGraphParameter is an array, but has a different item type.")
}
}
allOK = all(sapply(private$value, function(item) {
# item is an array type -> list or vector
itemsItemType = private$schema$items$type
itemsMinItems = private$schema$items$minItems
itemsMaxItems = private$schema$items$maxItems
# check nested item type
typeOK = switch(itemsItemType,
string = is.character(item),
number = is.numeric(item),
integer = is.integer(item),
boolean = is.logical(item),
array = is.list(item) || is.vector(item))
# check min/max if set
minOK = NULL
if (!is.null(itemsMinItems) && length(itemsMinItems) == 1){
minOK = length(item) >= itemsMinItems
}
maxOK = NULL
if (!is.null(itemsMaxItems) && length(itemsMaxItems) == 1){
maxOK = length(item) >= itemsMaxItems
}
return(all(unlist(list(typeOK,minOK,maxOK))))
}))
if (!allOK) stop("At least one of the nested arrays has an invalid item type or the min/max constraint was triggered.")
} else {
if (!"ProcessGraphParameter" %in% class(private$value[[1]])) {
allOK = switch(itemType,
string = all(sapply(private$value,function(val){
if ("Process" %in% class(val)) {
returnSchema = val$getReturns()$schema
return(String$new()$matchesSchema(returnSchema))
} else {
return(is.character(val))
}
})),
number = all(sapply(private$value,function(val){
if ("Process" %in% class(val)) {
returnSchema = val$getReturns()$schema
return(Number$new()$matchesSchema(returnSchema))
} else {
return(is.numeric(val))
}
})),
integer = all(sapply(private$value,function(val){
if ("Process" %in% class(val)) {
returnSchema = val$getReturns()$schema
return(Integer$new()$matchesSchema(returnSchema))
} else {
return(is.integer(val))
}
})),
boolean = all(sapply(private$value,function(val){
if ("Process" %in% class(val)) {
returnSchema = val$getReturns()$schema
return(Boolean$new()$matchesSchema(returnSchema))
} else {
return(is.logical(val))
}
}))
)
# if allOK == null then it was not checked
if (!is.null(allOK) && !allOK) {
stop(paste0("At least one element in the array is not of type: ",itemType))
}
}
}
if (!is.list(private$value)) {
if (length(private$value) == 1) {
private$value = list(private$value)
return()
}
suppressWarnings({
coerced = as.list(private$value)
})
if (is.null(coerced) ||
rlang::is_na(coerced) ||
length(coerced) == 0) stop(paste0("Value '", private$value,"' cannot be coerced into a boolean."))
# correct value if you can
private$value = coerced
}
return(invisible(NULL))
},
typeSerialization = function() {
if (!is.environment(self$getValue()) && (length(self$getValue()) == 0 || rlang::is_na(self$getValue()))) {
return(NA)
}
lapply(self$getValue(), function(value) {
if ("ProcessNode" %in% class(value)) return(value$serializeAsReference())
if ("Argument" %in% class(value)) return(value$serialize())
return(value)
})
})
)
# Kernel ====
#' Kernel
#'
#' Inheriting from [Argument()] in order to represent a 2-dimensional array of weights applied
#' to the x and y (spatial) dimensions of the data cube. The inner level of the nested array is aligned to the x-axis and
#' the outer level is aligned to the y-axis. Each level of the kernel must have an uneven number of elements.
#'
#' @name Kernel
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a Kernel.
NULL
Kernel = R6Class(
"kernel",
inherit=Argument,
public = list(
initialize=function(name=character(),
description=character(),
type=character(),
format=character(),
items=list(),
required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "array"
private$schema$subtype = "kernel"
private$schema$items = items
}
),
private = list(
typeSerialization = function() {
# might not be really required
private$value
},
typeCheck = function() {
if (!self$isEmpty()) {
if (!is.matrix(private$value) || !is.data.frame(private$value) || !is.array(private$value)) {
stop("Kernel value is neither matrix nor data.frame")
} else {
dims = dim(kernel)
if (!length(dims) == 2) {
stop("Kernel has more or less than two dimensions")
}
if (!all(dims %% 2 == 1)) {
stop("One or more kernel dimension have an even number of elements")
}
invisible(NULL)
}
}
}
)
)
#TemporalInterval ====
#' TemporalInterval
#'
#' Inheriting from [Argument()] in order to represent a temporal interval. Open interval borders are
#' denoted by NA. Exactly two objects form the temporal interval.
#'
#' @name TemporalInterval
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a temporal interval.
NULL
TemporalInterval = R6Class(
"temporal-interval",
inherit=Array,
public = list(
initialize=function(name=character(),
description=character(),
type=character(),
format=character(),
items=list(),
required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "array"
private$schema$subtype = "temporal-interval"
private$schema$items = items
private$schema$maxItems = 2
private$schema$minItems = 2
},
setValue = function(value) {
private$value = value
}
)
)
#TemporalIntervals ====
#' TemporalIntervals
#'
#' Inheriting from [Argument()] in order to represent a list of [TemporalInterval()].
#'
#' @name TemporalIntervals
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a list of temporal intervals.
NULL
TemporalIntervals = R6Class(
"temporal-intervals",
inherit=Array,
public = list(
initialize=function(name=character(),
description=character(),
type=character(),
format=character(),
items=list(),
required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "array"
private$schema$subtype = "temporal-intervals"
private$schema$items = items
}
)
)
# MetadataFilter ====
#' MetadataFilter
#'
#' Inheriting from [ProcessGraphArgument()] in order to represent a list of functions that is internally
#' interpreted into [Process()] objects.
#'
#' @examples
#' \dontrun{
#' # define filter statement
#' filter = list(
#' "eo:cloud_cover" = function(x) x >= 0 & x < 50,
#' "platform" = function(x) x == "Sentinel-2A"
#' )
#'
#' # setting the arguments is done via the process graph building with of 'processes()'
#' }
#'
#' @name MetadataFilter
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing a list of [Process()] in order to filter for collections.
#'
#' @importFrom rlang is_na
NULL
MetadataFilter <- R6Class(
"metadata-filter",
inherit=ProcessGraphArgument,
public = list(
initialize=function(name=character(),description=character(),required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "object"
private$schema$subtype = "metadata-filter"
},
setValue = function(value) {
if (length(value) == 0 || rlang::is_na(value)) {
private$value = value
} else if (is.list(value)) {
node_names = names(value) # TODO add something if missing or stop
# set parameter that is stored in this class...
v = lapply(value,function(FUN, private) {
if (is.function(FUN)) {
process_collection = private$process$getGraph()
# probably switch temporarily the graph of the parent process
# then all newly created process nodes go into the new graph
private$process$setGraph(process_collection)
process_graph_parameter = private$parameters
# find suitable ProcessGraph parameter (mostly array or binary) -> check for length of formals
# the issue can no longer been resolved automatically
if (length(formals(FUN)) != length(process_graph_parameter)) stop("Function parameter do not match ProcessGraph parameter(s)")
names(process_graph_parameter) = names(formals(FUN))
lapply(process_graph_parameter, function(cb){cb$setProcess(private$process)})
# make call
final_node = do.call(FUN,args = process_graph_parameter)
# assign new graph as value
as(final_node,"Process")
} else if ("Graph" %in% class(FUN)) {
as(FUN,"Process")
} else {
stop("Value for the metadata filter needs to be a list of functions.")
}
},private=private)
names(v) = node_names
private$value = v
} else {
stop("Value for the metadata filter needs to be a list of functions.")
}
}
),
private = list(
typeCheck = function() {
if (!self$isEmpty()) {
length_0 = length(private$value) == 0
# named list of functions
is_named = length(names(private$value)) > 0
is_list = is.list(private$value)
all_graphs = all(sapply(private$value,function(o)"Process" %in% class(o)))
if (!length_0 && !is_named && !is_list && !all_graphs) {
stop("value could not be parsed into a named list of Process")
}
}
return(invisible(NULL))
},
typeSerialization = function() {
nn = names(private$value)
ll = lapply(private$value,function(o)o$serialize())
names(ll) = nn
return(ll)
}
)
)
# AnyOf ====
#' AnyOf
#'
#' Inheriting from [Argument()] in order to represent an argument choice object. Multiple
#' types can be stated, but at least one data type has to be picked. In a JSON-schema this is often used to make
#' objects nullable - meaning that they allow NULL as value. The AnyOf parameter is resolved into a simple nullable argument
#' if this applies.
#'
#' @section Methods:
#' \describe{
#' \item{`$getChoice()`}{returns a list of [Argument()] that are allowed}
#' \item{`$isNullable`}{returns TRUE if only one element is in the choice that is not "null"}
#' }
#'
#' @name AnyOf
#'
#' @seealso [Array()], [Integer()], [EPSGCode()], [String()], [Number()],
#' [Date()], [RasterCube()], [VectorCube()], [ProcessGraphArgument()],
#' [ProcessGraphParameter()], [OutputFormatOptions()], [GeoJson()],
#' [Boolean()], [DateTime()], [Time()], [BoundingBox()], [Kernel()],
#' [TemporalInterval()], [TemporalIntervals()], [CollectionId()], [OutputFormat()],
#' [AnyOf()], [ProjDefinition()], [UdfCodeArgument()], [UdfRuntimeArgument()] and
#' [UdfRuntimeVersionArgument()],[TemporalIntervals()], [MetadataFilter()]
#'
#' @return Object of [R6Class()] representing an argument choice object.
#' @importFrom rlang is_na
NULL
AnyOf = R6Class(
"anyOf",
inherit=Argument,
public = list(
initialize=function(name=character(),description=character(), parameter_list,required=FALSE) {
private$name = name
private$description = description
private$required = required
private$schema$type = "anyOf"
private$parameter_choice = parameter_list
},
setProcess = function(p) {
private$process = p
lapply(private$parameter_choice, function(choice) {
choice$setProcess(p)
})
return(invisible(self))
},
setValue = function(value) {
if (is.null(value)) {
private$value =NULL
return(self)
}
if ("function" %in% class(value)) {
signature = formals(value)
# currently we have only 1 parameter (either single value or array) or two (directly binary operation)
number_of_params = sapply(private$parameter_choice,function(cb) {
length(cb$getProcessGraphParameters())
})
choice_index = unname(which(number_of_params == length(signature)))
if (length(choice_index) == 0) {
stop("Cannot match function to any of the ProcessGraph parameter.")
}
choice = private$parameter_choice[[choice_index]]
#resolve anyof parameter
self$getProcess()$setParameter(name = self$getName(),value = choice)
choice$setName(self$getName())
choice$setProcess(private$process)
choice$setValue(value)
return(self)
}
if ("ProcessGraph" %in% class(value)) {
# This is mostly for ProcessGraphs
arg_allowed = any(sapply(private$parameter_choice, function(argument) {
all(length(setdiff(class(argument),class(value))) == 0,
length(setdiff(class(value),class(argument))) == 0
)
}))
if(!arg_allowed) stop("Cannot assign ",class(value)[[1]], " as value. Not allowed.")
private$value = value
return(self)
}
else {
# set to all sub parameters and run validate
choice_copies = self$getChoice()
validated = sapply(choice_copies, function(param) {
tryCatch(
{
param$setValue(value)
validation = param$validate()
return(is.null(validation))
},
error = function(e) {
return(FALSE)
}
)
})
tryCatch({
if (!any(validated)) stop("Cannot match the value to any of the parameter selection (AnyOf)")
private$value = unname(choice_copies[validated])[[1]] # pick the first match
private$value$setValue(value)
}, error = function(e) {
message(e$message)
})
return(self)
}
},
getValue = function() {
# best case only one had survived the selection, if not throw an error?
# or return the first result
if (is.null(private$value)) return(private$value)
if (is.list(private$value)) {
if (length(private$value)==1) {
return(private$value[[1]])
}
return(private$value[[1]])
} else {
return(private$value)
}
},
getChoice = function() {
param_copies = lapply(private$parameter_choice,function(choice){
choice$clone(deep=TRUE)
})
return(param_copies)
}
),
active = list(
isNullable = function(value) {
if (missing(value)) {
return(private$nullable)
} else {
value = as.logical(value)
if (rlang::is_na(value)) {
warning("Cannot cast value to logical. Assume FALSE.")
value = FALSE
}
lapply(private$parameter_choice, function(param) {
param$isNullable = value
})
private$nullable = value
}
}
),
private = list(
parameter_choice = list(),
typeCheck = function() {},
typeSerialization = function() {
if (length(self$getValue()) == 0) {
return(NULL)
} else {
val = self$getValue()
if (!is.list(val)) {
val = list(val)
}
val = lapply(val, function(v) {
if (any(c("Graph","Argument") %in% class(v))) {
return(v$serialize())
} else if ("ProcessNode" %in% class(v)){
return(v$serializeAsReference())
} else {
return(v)
}
})
if (length(val) == 1) return(val[[1]])
else return(val)
}
}
)
)
# parse functions ----
findParameterGenerator = function(schema) {
# adapt this if I add some parameter/argument
# ProcessGraphParameter are not listed since they are created at the graph (as "variables")
parameter_constructor = list(Integer,
EPSGCode,
Number,
Boolean,
BoundingBox,
GeoJson,
RasterCube,
VectorCube,
String,
CollectionId,
JobId,
ProcessGraphId,
ProjDefinition,
OutputFormat,
OutputFormatOptions,
ProcessGraphArgument,
Array,
Kernel,
Date,
DateTime,
TemporalInterval,
TemporalIntervals,
Time,
URI,
UdfRuntimeArgument,
UdfRuntimeVersionArgument,
UdfCodeArgument,
MetadataFilter)
# resolve the any parameter (no specification)
if (length(schema$type) == 0 && length(schema$subtype) == 0) {
return(list(Argument))
}
matches = unlist(lapply(parameter_constructor, function(constructor){
if(constructor$new()$matchesSchema(schema)) constructor
}))
if (is.null(matches) || length(matches) == 0) matches = list(Argument) # if we don't find anything simply use this, since it is not restricted
return(matches)
}
processFromJson=function(json) {
if (is.null(json$summary)) json$summary = character()
tryCatch({
#map parameters!
parameter_names = sapply(json$parameters, function(p)p$name)
if (length(parameter_names) > 0) {
parameters = lapply(
json$parameters, function(pdef) {
# set param if it is contained in the schema
param = parameterFromJson(pdef)
return(param)
}
)
names(parameters) = parameter_names
} else {
parameters = list()
}
if (length(json$process_graph) > 0) {
graph = parse_graph(json=json)
} else {
graph = NULL
}
Process$new(id=json$id,
description = json$description,
summary=json$summary,
parameters = parameters,
returns = json$returns,
process_graph = graph)
}, error = function(e) {
warning(paste0("Invalid process description for '",json$id,"'"))
NULL
})
}
parameterFromJson = function(param_def) {
if (length(param_def$schema) == 0) {
# an empty schema means ANY value is allowed
arg = Argument$new()
if (length(param_def$description) > 0) {
arg$setDescription(param_def$description)
}
return(arg)
}
# if it is no unnamed object list, then box it
if (length(names(param_def$schema)) > 0) {
if (!is.null(param_def$schema$type) && is.list(param_def$schema$type)) {
param_def$schema = lapply(param_def$schema$type, function(type,original_param_schema) {
original_param_schema$type = type
return(original_param_schema)
},original_param_schema = param_def$schema)
} else {
param_def$schema = list(param_def$schema)
}
}
#special case a simple type + null, which mean a type that is a list and schema not
# then dissolve the parameter into multiple instances
# now we have a list over which we can lapply
nullable = sapply(param_def$schema, function(schema) {
nullable_single = !is.null(schema$type) && schema$type == "null"
nullable_array = !is.null(schema$type) && schema$type == "array" &&
length(schema$items$type) == 1 && schema$items$type == "null"
return(nullable_single || nullable_array)
})
param_nullable = any(nullable)
# delete the null parameter
if (param_nullable) {
param_def$schema[[which(nullable)]] = NULL
}
is_choice = length(param_def$schema) > 1
#create a list of parameters / find from schema
params = lapply(param_def$schema, function(schema) {
# this will be the normal case for simple schemas?
gen=findParameterGenerator(schema)[[1]]
param = gen$new()
if (length(schema$pattern) != 0) {
param$setPattern(schema$pattern)
}
if (length(schema$enum) != 0) {
param$setEnum(schema$enum)
}
if ("metadata-filter" %in% class(param)) {
if ("additionalProperties" %in% names(schema)) {
schema = append(schema,schema[["additionalProperties"]])
schema[["additionalProperties"]] = NULL
}
}
if ("ProcessGraphArgument" %in% class(param)) {
# iterate over all ProcessGraph parameters and create ProcessGraphParameters, but name = property name (what the process exports to ProcessGraph)
# value has to be assigned by user, then switch name and value during serialization
pg_params = lapply(schema$parameters, function(param_json) {
if (is.null(param_json$schema[["subtype"]])) param_json$schema[["subtype"]] = character()
cb = ProcessGraphParameter$new(name = param_json$name,
description = param_json$description,
type = param_json$schema[["type"]],
subtype = param_json$schema[["subtype"]],
required = TRUE)
if(!is.null(param_json$schema[["pattern"]])) cb$setPattern(param_json$schema[["pattern"]])
if (is.null(param_json$optional)) param_json$optional = FALSE
cb$isRequired = isFALSE(param_json$optional)
return(cb)
})
pg_param_names = sapply(schema$parameters,function(p)p$name)
names(pg_params) = pg_param_names
param$setProcessGraphParameters(pg_params)
}
if ("array" %in% class(param)) {
if (!"kernel" %in% class(param)) {
param$setItemSchema(schema$items)
} else {
param$setItemSchema(schema$items)
}
}
return(param)
})
# if choice then create an anyOf
if (is_choice) {
#build an anyOf
param = AnyOf$new(parameter_list = params)
} else {
param = params[[1]]
}
# in general also reolve null cases
param$isNullable = param_nullable
param$setDefault(param_def$default)
param$setName(param_def$name)
param$setDescription(param_def$name)
if (is.null(param_def$optional)) param_def$optional = FALSE
param$isRequired = isFALSE(param_def$optional)
pattern = param_def$schema$pattern
if (!is.null(pattern)) {
param$setPattern(pattern)
}
return(param)
}
Try the openeo package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.