/
ext_query.R
174 lines (169 loc) · 5.42 KB
/
ext_query.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
#' @title Query extension
#'
#' @description
#' The `ext_query()` is the *exported function* of the STAC API
#' query extension. It can be used after a call to `stac_search()`
#' function. It allows that additional fields and operators other than those
#' defined in `stac_search()` function be used to make a complex filter.
#'
#' The function accepts multiple filter criteria. Each filter entry is an
#' expression formed by `<field> <operator> <value>`, where
#' `<field>` refers to a valid item property. Supported `<fields>`
#' depends on STAC API service implementation. The users must rely on the
#' service providers' documentation to know which properties can be used
#' by this extension.
#'
#' The `ext_query()` function allows the following `<operators>`
#' \itemize{
#' \item `==` corresponds to '`eq`'
#' \item `!=` corresponds to '`neq`'
#' \item `<` corresponds to '`lt`'
#' \item `<=` corresponds to '`lte`'
#' \item `>` corresponds to '`gt`'
#' \item `>=` corresponds to '`gte`'
#' \item `\%startsWith\%` corresponds to '`startsWith`' and implements
#' a string prefix search operator.
#' \item `\%endsWith\%` corresponds to '`endsWith`' and implements a
#' string suffix search operator.
#' \item `\%contains\%`: corresponds to '`contains`' and implements a
#' string infix search operator.
#' \item `\%in\%`: corresponds to '`in`' and implements a vector
#' search operator.
#' }
#'
#' Besides this function, the following S3 generic methods were implemented
#' to get things done for this extension:
#' \itemize{
#' \item The `before_request()` for subclass `ext_query`
#' \item The `after_response()` for subclass `ext_query`
#' }
#' See source file `ext_query.R` for an example of how to implement new
#' extensions.
#'
#' @param q a `rstac_query` object expressing a STAC query
#' criteria.
#'
#' @param ... entries with format `<field> <operator> <value>`.
#'
#' @seealso [ext_filter()], [stac_search()], [post_request()],
#' [before_request()], [after_response()], [content_response()]
#'
#' @return
#' A `rstac_query` object with the subclass `ext_query` containing
#' all request parameters to be passed to `post_request()` function.
#'
#' @examples
#' \dontrun{
#' stac("https://brazildatacube.dpi.inpe.br/stac/") %>%
#' stac_search(collections = "CB4-16D-2") %>%
#' ext_query("bdc:tile" %in% "007004") %>%
#' post_request()
#' }
#'
#' @export
ext_query <- function(q, ...) {
check_query(q, "search")
# get the env parent
env_parent <- parent.frame()
params <- list()
if (!is.null(substitute(list(...), env = environment())[-1])) {
dots <- substitute(list(...), env = environment())[-1]
tryCatch({
ops <- lapply(dots, function(x) as.character(x[[1]]))
keys <- lapply(dots, function(x) as.character(x[[2]]))
values <- lapply(dots, function(x) eval(x[[3]], env_parent))
}, error = function(e) {
.error("Invalid query expression.")
})
}
ops <- lapply(ops, function(op) {
if (op == "==") return("eq")
if (op == "!=") return("neq")
if (op == "<") return("lt")
if (op == "<=") return("lte")
if (op == ">") return("gt")
if (op == ">=") return("gte")
if (op == "%startsWith%") return("startsWith")
if (op == "%endsWith%") return("endsWith")
if (op == "%contains%") return("contains")
if (op == "%in%") return("in")
.error("Invalid operator '%s'.", op)
})
uniq_keys <- unique(keys)
entries <- lapply(uniq_keys, function(k) {
res <- lapply(values[keys == k], c)
names(res) <- ops[keys == k]
res <- lapply(names(res), .parse_values_op, res)
names(res) <- ops[keys == k]
return(res)
})
if (length(entries) == 0)
return(q)
names(entries) <- uniq_keys
params$query <- entries
rstac_query(
version = q$version,
base_url = q$base_url,
params = utils::modifyList(q$params, params),
subclass = unique(c("ext_query", subclass(q)))
)
}
#' @export
before_request.ext_query <- function(q) {
error_msg <- paste0("Query extension is not supported by HTTP GET",
"method. Please, use `post_request()` method instead.")
check_query_verb(q, verbs = "POST", msg = error_msg)
before_request.search(q)
}
#' @export
after_response.ext_query <- function(q, res) {
after_response.items(q, res)
}
#' @export
parse_params.ext_query <- function(q, params) {
# call super class
params <- NextMethod("parse_params")
params$query <- .parse_values_keys(params$query)
params
}
#' @title Utility function
#'
#' @param op a `character` with operation to be searched.
#' @param values a named `list` with all values.
#'
#' @return a `vector` with one operation value.
#'
#' @noRd
.parse_values_op <- function(op, values) {
if (op == "in") {
if (length(values[[op]]) == 1)
return(list(values[[op]]))
return(values[[op]])
}
if (length(values[[op]]) > 1)
.warning(paste("Only the first value of '%s' operation was considered",
"in 'ext_query()' function."), op)
values[[op]][[1]]
}
#' @title Utility function
#'
#' @param query a `list` with parameters to be provided in requests.
#'
#' @return a `list` with parsed parameters.
#'
#' @noRd
.parse_values_keys <- function(query) {
uniq_keys <- names(query)
entries <- lapply(uniq_keys, function(k) {
ops <- names(query[[k]])
values <- lapply(ops, function(op){
query[[k]][[op]]
})
names(values) <- ops
res <- lapply(ops, .parse_values_op, values)
names(res) <- ops
return(res)
})
names(entries) <- uniq_keys
entries
}