forked from e-sensing/sits
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathapi_source_deafrica.R
209 lines (202 loc) · 8.13 KB
/
api_source_deafrica.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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
# ---- source api ----
#' @title Create an items object in an DEAfrica cube
#' @keywords internal
#' @noRd
#' @description \code{.source_items_new()} this function is called to create
#' an items object. In case of Web services, this function is responsible for
#' making the Web requests to the server.
#' @param source Name of the STAC provider.
#' @param ... Other parameters to be passed for specific types.
#' @param collection Collection to be searched in the data source.
#' @param stac_query Query that follows the STAC protocol
#' @param tiles Selected tiles (optional)
#' @param platform Satellite platform (optional).
#' @return An object referring the images of a sits cube.
#' @export
.source_items_new.deafrica_cube <- function(source, ...,
collection,
stac_query,
tiles = NULL,
platform = NULL) {
# Convert roi to bbox
roi <- .stac_intersects_as_bbox(stac_query)
stac_query[["params"]][["intersects"]] <- NULL
stac_query[["params"]][["bbox"]] <- roi$bbox
# making the request
items_info <- rstac::post_request(q = stac_query, ...)
.check_stac_items(items_info)
# if more than 2 times items pagination are found the progress bar
# is displayed
progress <- rstac::items_matched(items_info) >
2 * .conf("rstac_pagination_limit")
# check documentation mode
progress <- .check_documentation(progress)
# fetching all the metadata and updating to upper case instruments
items_info <- rstac::items_fetch(items = items_info, progress = progress)
# checks if the items returned any items
.check_stac_items(items_info)
return(items_info)
}
#' @title Create an items object in an DEAfrica cube
#' @keywords internal
#' @noRd
#' @description \code{.source_items_new()} this function is called to create
#' an items object. In case of Web services, this function is responsible for
#' making the Web requests to the server.
#' @param source Name of the STAC provider.
#' @param ... Other parameters to be passed for specific types.
#' @param collection Collection to be searched in the data source.
#' @param stac_query Query that follows the STAC protocol
#' @param tiles Selected tiles (optional)
#' @param platform Satellite platform (optional).
#' @return An object referring the images of a sits cube.
#' @export
`.source_items_new.deafrica_cube_sentinel-2-l2a` <- function(source, ...,
collection,
stac_query,
tiles = NULL,
platform = NULL) {
# set caller to show in errors
.check_set_caller(".source_items_new")
# check platform
if (!is.null(platform)) {
platform <- .stac_format_platform(
source = source,
collection = collection,
platform = platform
)
}
# check spatial extensions
if (!is.null(tiles)) {
roi <- .s2_mgrs_to_roi(tiles)
stac_query[["params"]][["intersects"]] <- NULL
stac_query[["params"]][["bbox"]] <- c(roi[["lon_min"]],
roi[["lat_min"]],
roi[["lon_max"]],
roi[["lat_max"]])
} else {
roi <- .stac_intersects_as_bbox(stac_query)
stac_query[["params"]][["intersects"]] <- NULL
stac_query[["params"]][["bbox"]] <- roi$bbox
}
# make request
items_info <- rstac::post_request(q = stac_query, ...)
items_info <- rstac::items_fetch(items = items_info, progress = FALSE)
# filter items
items_info <- rstac::items_filter(items_info,
filter_fn = function(feature) {
lgl_res <- TRUE
if (!is.null(platform)) {
lgl_res <- feature[["properties"]][["platform"]] == platform
}
lgl_res
})
# check results
.check_stac_items(items_info)
# done
items_info
}
#' @keywords internal
#' @noRd
#' @export
`.source_items_new.deafrica_cube_sentinel-1-rtc` <- function(
source, ...,
collection,
stac_query,
tiles = NULL,
platform = NULL,
orbit = NULL) {
# set caller to show in errors
.check_set_caller(".source_items_new")
# check orbits
orbits <- .conf("sources", source, "collections", collection, "orbits")
.check_chr_within(orbit, orbits)
# check platform
if (!is.null(platform)) {
platform <- .stac_format_platform(
source = source,
collection = collection,
platform = platform
)
}
# check spatial extensions
if (!is.null(tiles)) {
roi <- .s2_mgrs_to_roi(tiles)
stac_query[["params"]][["intersects"]] <- NULL
stac_query[["params"]][["bbox"]] <- c(roi[["lon_min"]],
roi[["lat_min"]],
roi[["lon_max"]],
roi[["lat_max"]])
} else {
roi <- .stac_intersects_as_bbox(stac_query)
stac_query[["params"]][["intersects"]] <- NULL
stac_query[["params"]][["bbox"]] <- roi$bbox
}
# make request
items_info <- rstac::post_request(q = stac_query, ...)
items_info <- rstac::items_fetch(items = items_info, progress = FALSE)
# filter items
items_info <- rstac::items_filter(items_info,
filter_fn = function(feature) {
lgl_res <- feature[["properties"]][["sat:orbit_state"]] == orbit &&
feature[["properties"]][["sar:instrument_mode"]] == "IW" &&
feature[["properties"]][["sar:frequency_band"]] == "C"
if (!is.null(platform)) {
lgl_res <- lgl_res &&
feature[["properties"]][["platform"]] == platform
}
lgl_res
})
# check results
.check_stac_items(items_info)
# done
items_info
}
#' @keywords internal
#' @noRd
#' @export
`.source_filter_tiles.deafrica_cube_sentinel-1-rtc` <- function(source,
collection,
cube,
tiles) {
return(cube)
}
#' @keywords internal
#' @noRd
#' @export
.source_items_tile.deafrica_cube <- function(source, ...,
items,
collection = NULL) {
rstac::items_reap(items, field = c("properties", "odc:region_code"))
}
#' @keywords internal
#' @noRd
#' @export
.source_item_get_date.deafrica_cube <- function(source,
item,
...,
collection = NULL) {
item_date <- item[[c("properties", "datetime")]]
# Digital Earth Africa provides some products with the `properties.datetime`
# property `null`. In those cases, it is required to use other date
# parameter available
if (is.null(item_date))
item_date <- item[[c("properties", "start_datetime")]]
suppressWarnings(
lubridate::as_date(item_date)
)
}
#' @keywords internal
#' @noRd
#' @export
`.source_items_tile.deafrica_cube_rainfall-chirps-daily` <-
function(source, items, ..., collection = NULL) {
rep("NoTilingSystem", rstac::items_length(items))
}
#' @keywords internal
#' @noRd
#' @export
`.source_items_tile.deafrica_cube_rainfall-chirps-monthly` <-
function(source, items, ..., collection = NULL) {
rep("NoTilingSystem", rstac::items_length(items))
}