Skip to content

Commit d34a67c

Browse files
gilbertocamaragilbertocamara
committed
support for tiles in DEAfrica and HLS
1 parent c50361d commit d34a67c

22 files changed

+607
-185
lines changed

‎NAMESPACE

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -111,6 +111,7 @@ S3method(.raster_polygonize,terra)
111111
S3method(.raster_rast,terra)
112112
S3method(.raster_read_rast,terra)
113113
S3method(.raster_row,terra)
114+
S3method(.raster_scale,terra)
114115
S3method(.raster_set_na,terra)
115116
S3method(.raster_set_values,terra)
116117
S3method(.raster_summary,terra)
@@ -127,6 +128,8 @@ S3method(.source_collection_access_test,mpc_cube)
127128
S3method(.source_collection_access_test,stac_cube)
128129
S3method(.source_collection_access_test,usgs_cube)
129130
S3method(.source_cube,stac_cube)
131+
S3method(.source_filter_tiles,"mpc_cube_sentinel-1-grd")
132+
S3method(.source_filter_tiles,stac_cube)
130133
S3method(.source_item_get_bands,stac_cube)
131134
S3method(.source_item_get_cloud_cover,sdc_cube)
132135
S3method(.source_item_get_cloud_cover,stac_cube)
@@ -141,16 +144,19 @@ S3method(.source_items_fid,stac_cube)
141144
S3method(.source_items_new,"aws_cube_landsat-c2-l2")
142145
S3method(.source_items_new,"mpc_cube_landsat-c2-l2")
143146
S3method(.source_items_new,"mpc_cube_sentinel-1-grd")
147+
S3method(.source_items_new,"mpc_cube_sentinel-1-rtc")
144148
S3method(.source_items_new,"mpc_cube_sentinel-2-l2a")
145149
S3method(.source_items_new,aws_cube)
146150
S3method(.source_items_new,bdc_cube)
147151
S3method(.source_items_new,deafrica_cube)
152+
S3method(.source_items_new,deafrica_cube_s2_l2a)
148153
S3method(.source_items_new,hls_cube)
149154
S3method(.source_items_new,sdc_cube)
150155
S3method(.source_items_new,usgs_cube)
151156
S3method(.source_items_tile,"aws_cube_landsat-c2-l2")
152157
S3method(.source_items_tile,"mpc_cube_landsat-c2-l2")
153158
S3method(.source_items_tile,"mpc_cube_sentinel-1-grd")
159+
S3method(.source_items_tile,"mpc_cube_sentinel-1-rtc")
154160
S3method(.source_items_tile,"mpc_cube_sentinel-2-l2a")
155161
S3method(.source_items_tile,aws_cube)
156162
S3method(.source_items_tile,bdc_cube)
@@ -159,6 +165,7 @@ S3method(.source_items_tile,hls_cube)
159165
S3method(.source_items_tile,sdc_cube)
160166
S3method(.source_items_tile,usgs_cube)
161167
S3method(.source_tile_get_bbox,"mpc_cube_sentinel-1-grd")
168+
S3method(.source_tile_get_bbox,"mpc_cube_sentinel-1-rtc")
162169
S3method(.source_tile_get_bbox,stac_cube)
163170
S3method(.tile,default)
164171
S3method(.tile,raster_cube)
@@ -283,6 +290,7 @@ S3method(sits_bands,patterns)
283290
S3method(sits_bands,raster_cube)
284291
S3method(sits_bands,sits)
285292
S3method(sits_bands,sits_model)
293+
S3method(sits_bbox,"mpc_cube_sentinel-1-grd")
286294
S3method(sits_bbox,default)
287295
S3method(sits_bbox,raster_cube)
288296
S3method(sits_bbox,sits)
@@ -340,6 +348,7 @@ S3method(sits_reclassify,default)
340348
S3method(sits_reduce,raster_cube)
341349
S3method(sits_reduce,sits)
342350
S3method(sits_regularize,"mpc_cube_sentinel-1-grd")
351+
S3method(sits_regularize,"mpc_cube_sentinel-1-rtc")
343352
S3method(sits_regularize,default)
344353
S3method(sits_regularize,derived_cube)
345354
S3method(sits_regularize,raster_cube)
@@ -421,6 +430,7 @@ export(sits_labels_summary)
421430
export(sits_lighttae)
422431
export(sits_list_collections)
423432
export(sits_merge)
433+
export(sits_mgrs_to_roi)
424434
export(sits_mixture_model)
425435
export(sits_mlp)
426436
export(sits_model_export)

‎R/api_cube.R

Lines changed: 15 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -1252,18 +1252,18 @@ NULL
12521252
return(unlist(cube_chunks, recursive = FALSE))
12531253
}
12541254

1255-
.cube_split_segments <- function(cube, block) {
1256-
segments_sf <- .segments_read_vec(segments)
1257-
chunks <- .tile_chunks_create(
1258-
tile = segments,
1259-
overlap = 0,
1260-
block = block
1261-
)
1262-
chunks_sf <- .bbox_as_sf(
1263-
.bbox(chunks, by_feature = TRUE), as_crs = sf::st_crs(segments_sf)
1264-
)
1265-
chunks_jobs <- slider::slide(chunks_sf[1,], function(chunk_sf) {
1266-
segments_sf[ .intersects(segments_sf, chunk_sf),]
1267-
})
1268-
return(chunks_sf)
1269-
}
1255+
# .cube_split_segments <- function(cube, block) {
1256+
# segments_sf <- .segments_read_vec(segments)
1257+
# chunks <- .tile_chunks_create(
1258+
# tile = segments,
1259+
# overlap = 0,
1260+
# block = block
1261+
# )
1262+
# chunks_sf <- .bbox_as_sf(
1263+
# .bbox(chunks, by_feature = TRUE), as_crs = sf::st_crs(segments_sf)
1264+
# )
1265+
# chunks_jobs <- slider::slide(chunks_sf[1,], function(chunk_sf) {
1266+
# segments_sf[ .intersects(segments_sf, chunk_sf),]
1267+
# })
1268+
# return(chunks_sf)
1269+
# }

‎R/api_raster.R

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -574,7 +574,15 @@
574574

575575
UseMethod(".raster_yres", pkg_class)
576576
}
577+
#' @name .raster_scale
578+
#' @keywords internal
579+
#' @noRd
580+
.raster_scale <- function(r_obj, ...) {
581+
# check package
582+
pkg_class <- .raster_check_package()
577583

584+
UseMethod(".raster_scale", pkg_class)
585+
}
578586
#' @name .raster_crs
579587
#' @keywords internal
580588
#' @noRd

‎R/api_raster_terra.R

Lines changed: 21 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -84,6 +84,7 @@
8484
suppressWarnings(
8585
terra::rast(x = r_obj, nlyrs = nlayers, ...)
8686
)
87+
8788
}
8889
#' @title Open a raster object based on a file
8990
#' @keywords internal
@@ -93,9 +94,12 @@
9394
#' @return Terra raster object
9495
#' @export
9596
.raster_open_rast.terra <- function(file, ...) {
96-
suppressWarnings(
97+
r_obj <- suppressWarnings(
9798
terra::rast(x = .file_normalize(file), ...)
9899
)
100+
# remove gain and offset applied by terra
101+
terra::scoff(r_obj) <- NULL
102+
r_obj
99103
}
100104
#' @title Write values to a terra raster object based on a file
101105
#' @keywords internal
@@ -430,7 +434,22 @@
430434
.raster_yres.terra <- function(r_obj, ...) {
431435
terra::yres(x = r_obj)
432436
}
433-
437+
#' @keywords internal
438+
#' @noRd
439+
#' @export
440+
.raster_scale.terra <- function(r_obj, ...) {
441+
# check value
442+
i <- 1
443+
while (is.na(r_obj[i])) {
444+
i <- i + 1
445+
}
446+
value <- r_obj[i]
447+
if (value > 1.0 && value <= 10000)
448+
scale_factor <- 0.0001
449+
else
450+
scale_factor <- 1.0
451+
return(scale_factor)
452+
}
434453
#' @keywords internal
435454
#' @noRd
436455
#' @export

‎R/api_s2tile.R

Lines changed: 50 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -70,3 +70,53 @@
7070
sf::st_transform(crs = 4326)
7171
})
7272
}
73+
#' @title Convert MGRS tile information to ROI in WGS84
74+
#' @name .s2_mgrs_to_roi
75+
#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
76+
#' @author Rolf Simoes, \email{rolf.simoes@@gmail.com}
77+
#' @keywords internal
78+
#' @noRd
79+
#' @description
80+
#' Takes a list of MGRS tiles and produces a ROI covering them
81+
#'
82+
#' @param tiles Character vector with names of MGRS tiles
83+
#' @return roi Valid ROI to use in other SITS functions
84+
#'
85+
.s2_mgrs_to_roi <- function(tiles){
86+
87+
# read the MGRS data set
88+
mgrs_tiles <- readRDS(system.file("extdata/s2-tiles/tiles.rds",
89+
package = "sits"))
90+
# check tiles names are valid
91+
.check_chr_within(
92+
x = tiles,
93+
within = mgrs_tiles$tile_id,
94+
msg = "invalid MGRS tiles"
95+
)
96+
# select MGRS tiles
97+
tiles_selected <- dplyr::filter(mgrs_tiles, .data[["tile_id"]] %in% !!tiles)
98+
99+
# obtain a list of sf objects
100+
bbox_dfr <- slider::slide_dfr(tiles_selected, function(tile){
101+
xmin <- as.double(tile$xmin)
102+
xmax <- xmin + 109800
103+
ymin <- as.double(tile$ymin)
104+
ymax <- ymin + 109800
105+
bbox <- sf::st_bbox(c("xmin" = xmin, "ymin" = ymin,
106+
"xmax" = xmax, "ymax" = ymax), crs = sf::st_crs(tile$epsg))
107+
bbox_ll <- bbox |>
108+
sf::st_as_sfc() |>
109+
sf::st_transform(crs = 4326) |>
110+
sf::st_bbox()
111+
112+
ll <- c("lon_min" = bbox_ll[["xmin"]], "lat_min" = bbox_ll[["ymin"]],
113+
"lon_max" = bbox_ll[["xmax"]], "lat_max" = bbox_ll[["ymax"]])
114+
return(ll)
115+
})
116+
roi <- c("lon_min" = min(bbox_dfr[["lon_min"]]),
117+
"lat_min" = min(bbox_dfr[["lat_min"]]),
118+
"lon_max" = max(bbox_dfr[["lon_max"]]),
119+
"lat_max" = max(bbox_dfr[["lat_max"]])
120+
)
121+
return(roi)
122+
}

‎R/api_source.R

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1027,3 +1027,13 @@ NULL
10271027
source <- .source_new(source = source)
10281028
UseMethod(".source_adjust_date", source)
10291029
}
1030+
#' @title Filter tiles if required by source
1031+
#' @noRd
1032+
#' @param source Data source
1033+
#' @param cube Cube to be filtered
1034+
#' @param tiles Tiles to be selected
1035+
#' @return Filtered cube
1036+
.source_filter_tiles <- function(source, collection, cube, tiles) {
1037+
source <- .source_new(source = source, collection = collection)
1038+
UseMethod(".source_filter_tiles", source)
1039+
}

‎R/api_source_deafrica.R

Lines changed: 60 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -20,17 +20,71 @@
2020
# set caller to show in errors
2121
.check_set_caller(".source_items_new.deafrica_cube")
2222

23-
if (!is.null(tiles)) {
24-
stop(paste("DEAFRICA cubes do not support searching for tiles, use",
25-
"'roi' parameter instead.",
26-
call. = FALSE
27-
))
28-
}
2923
# Convert roi to bbox
3024
lon <- stac_query$params$intersects$coordinates[, , 1]
3125
lat <- stac_query$params$intersects$coordinates[, , 2]
3226
stac_query$params$intersects <- NULL
3327
stac_query$params$bbox <- c(min(lon), min(lat), max(lon), max(lat))
28+
29+
# making the request
30+
items_info <- rstac::post_request(q = stac_query, ...)
31+
.check_stac_items(items_info)
32+
# if more than 2 times items pagination are found the progress bar
33+
# is displayed
34+
progress <- rstac::items_matched(items_info) >
35+
2 * .conf("rstac_pagination_limit")
36+
# check documentation mode
37+
progress <- .check_documentation(progress)
38+
39+
# fetching all the metadata and updating to upper case instruments
40+
items_info <- rstac::items_fetch(items = items_info, progress = progress)
41+
# checks if the items returned any items
42+
.check_that(
43+
x = rstac::items_length(items_info) != 0,
44+
msg = paste(
45+
"the provided search returned 0 items. Please, verify",
46+
"the provided parameters."
47+
)
48+
)
49+
return(items_info)
50+
}
51+
#' @title Create an items object in an DEAfrica cube
52+
#' @keywords internal
53+
#' @noRd
54+
#' @description \code{.source_items_new()} this function is called to create
55+
#' an items object. In case of Web services, this function is responsible for
56+
#' making the Web requests to the server.
57+
#' @param source Name of the STAC provider.
58+
#' @param ... Other parameters to be passed for specific types.
59+
#' @param collection Collection to be searched in the data source.
60+
#' @param stac_query Query that follows the STAC protocol
61+
#' @param tiles Selected tiles (optional)
62+
#' @param platform Satellite platform (optional).
63+
#' @return An object referring the images of a sits cube.
64+
#' @export
65+
.source_items_new.deafrica_cube_s2_l2a <- function(source, ...,
66+
collection,
67+
stac_query,
68+
tiles = NULL,
69+
platform = NULL) {
70+
# set caller to show in errors
71+
.check_set_caller(".source_items_new.deafrica_cube")
72+
73+
if (!is.null(tiles)) {
74+
roi <- .s2_mgrs_to_roi(tiles)
75+
stac_query$params$intersects <- NULL
76+
stac_query$params$bbox <- c(roi[["lon_min"]],
77+
roi[["lat_min"]],
78+
roi[["lon_max"]],
79+
roi[["lat_max"]]
80+
)
81+
} else {
82+
# Convert roi to bbox
83+
lon <- stac_query$params$intersects$coordinates[, , 1]
84+
lat <- stac_query$params$intersects$coordinates[, , 2]
85+
stac_query$params$intersects <- NULL
86+
stac_query$params$bbox <- c(min(lon), min(lat), max(lon), max(lat))
87+
}
3488
# making the request
3589
items_info <- rstac::post_request(q = stac_query, ...)
3690
.check_stac_items(items_info)

‎R/api_source_hls.R

Lines changed: 16 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -15,12 +15,6 @@
1515
collection,
1616
stac_query,
1717
tiles = NULL) {
18-
if (!is.null(tiles)) {
19-
stop(paste("HLS cubes do not support searching for tiles, use",
20-
"'roi' parameter instead.",
21-
call. = FALSE
22-
))
23-
}
2418
# NASA EarthData requires a login/password combination
2519
netrc_path <- "~/.netrc"
2620
if (.Platform$OS.type == "windows") {
@@ -32,12 +26,22 @@
3226
"Have you configured your access to NASA EarthData?"
3327
))
3428
}
35-
36-
# Convert roi to bbox
37-
lon <- stac_query$params$intersects$coordinates[, , 1]
38-
lat <- stac_query$params$intersects$coordinates[, , 2]
39-
stac_query$params$intersects <- NULL
40-
stac_query$params$bbox <- c(min(lon), min(lat), max(lon), max(lat))
29+
# convert tiles to a valid STAC query
30+
if (!is.null(tiles)) {
31+
roi <- .s2_mgrs_to_roi(tiles)
32+
stac_query$params$intersects <- NULL
33+
stac_query$params$bbox <- c(roi[["lon_min"]],
34+
roi[["lat_min"]],
35+
roi[["lon_max"]],
36+
roi[["lat_max"]]
37+
)
38+
} else {
39+
# Convert roi to bbox
40+
lon <- stac_query$params$intersects$coordinates[, , 1]
41+
lat <- stac_query$params$intersects$coordinates[, , 2]
42+
stac_query$params$intersects <- NULL
43+
stac_query$params$bbox <- c(min(lon), min(lat), max(lon), max(lat))
44+
}
4145
# making the request
4246
items_info <- rstac::post_request(q = stac_query, ...)
4347
.check_stac_items(items_info)

0 commit comments

Comments
 (0)