update api_segments to handle empty segments

DESCRIPTION

@@ -105,6 +105,7 @@ Suggests:
  tmap (>= 3.3),
  torchopt (>= 0.1.2),
  tools,
+ vctrs,
  xgboost
 Config/testthat/edition: 3
 Config/testthat/parallel: false

R/api_segments.R

@@ -361,8 +361,9 @@
  ts_bands[["polygon_id"]] <- pol_id
  # we do the unnest again because we do not know the polygon id index
  ts_bands <- tidyr::unnest(ts_bands, "time_series")
- # remove pixels where all timeline was NA
- ts_bands <- tidyr::drop_na(ts_bands)
+ # detect pixels where all timeline was NA
+ na_polygons <- vctrs::vec_detect_complete(ts_bands)
+ na_polygons <- unique(ts_bands[!na_polygons,][["polygon_id"]])
  # nest the values by bands
  ts_bands <- tidyr::nest(
  ts_bands,
@@ -401,6 +402,10 @@
  )
  }
  samples <- .discard(samples, "sample_id")
+ # fill NA samples
+ if (length(na_polygons) > 0) {
+ samples <- .segments_poilypoints_fill(samples, segments, na_polygons)
+ }
  # set sits class
  class(samples) <- c("sits", class(samples))
  return(samples)
@@ -477,3 +482,61 @@
  })
  return(seg_tile_band_lst)
 }
+#' @title Fill ts data from polygon points.
+#' @name .segments_poilypoints_fill
+#' @keywords internal
+#' @noRd
+#' @param samples samples extracted from polygons
+#' @param segments large set of segments
+#' @param polygon_idx Index of NA polygons
+#' @return ts tibble
+#'
+.segments_poilypoints_fill <- function(samples, segments, polygon_idx) {
+ # get polygons with NA values
+ na_polygons <- dplyr::filter(segments, .data[["pol_id"]] %in% polygon_idx)
+ # get neighbors geometries that touch polygons with NA values
+ na_touches <- sf::st_touches(na_polygons, segments)
+ # extract bands
+ bands <- .ts_bands(.ts(samples))
+ # fill NA values
+ na_touches <- purrr::map_dfr(seq_along(na_touches), function(touches_idx) {
+ # get polygons and touches reference for the current polygon
+ na_polygons_row <- na_polygons[touches_idx,]
+ na_touched_row <- segments[na_touches[touches_idx][[1]],]
+ # get samples associated with the NA polygon as reference
+ samples_ref <- dplyr::filter(
+ samples, .data[["polygon_id"]] == na_polygons_row[["pol_id"]]
+ )
+ # define reference samples from where values will be extracted
+ samples_row <- samples_ref
+ # if neighbors are available, use their reference samples
+ if (nrow(na_touched_row) > 0) {
+ samples_row <- dplyr::filter(
+ samples, .data[["polygon_id"]] %in% na_touched_row[["pol_id"]]
+ )
+ }
+ # expand time-series values to calculate median value
+ samples_row_ts <- tidyr::unnest(samples_row, "time_series")
+ # calculate temporal median and fill NA values with `0`
+ samples_row_ts <- samples_row_ts |>
+ dplyr::group_by(.data[["Index"]]) |>
+ dplyr::summarize(dplyr::across(
+ bands, stats::median, na.rm = TRUE)
+ ) |>
+ dplyr::mutate(
+ dplyr::across(dplyr::everything(), ~tidyr::replace_na(., 0))
+ )
+ # spread the result across all points from the NA polygon
+ samples_ref[["time_series"]] <- list(samples_row_ts)
+ samples_ref
+ })
+ # get samples from non-NA polygons
+ samples <- dplyr::filter(
+ samples, !.data[["polygon_id"]] %in% na_polygons[["pol_id"]]
+ )
+ # bind result and return them
+ dplyr::bind_rows(
+ samples, na_touches
+ )
+}
+

R/sits_segmentation.R

@@ -88,6 +88,8 @@ sits_segment <- function(cube,
  output_dir,
  version = "v1",
  progress = TRUE) {
+ # check required package
+ .check_require_packages("vctrs")
  # set caller for error msg
  .check_set_caller("sits_segment")
  # Preconditions
@@ -296,7 +298,9 @@ sits_slic <- function(data = NULL,
  # Get valid centers
  valid_centers <- slic[[2]][, 1] != 0 | slic[[2]][, 2] != 0
  # Bind valid centers with segments table
- v_obj <- cbind(v_obj, stats::na.omit(slic[[2]][valid_centers, ]))
+ v_obj <- cbind(
+ v_obj, matrix(stats::na.omit(slic[[2]][valid_centers, ]), ncol = 2)
+ )
  # Rename columns
  names(v_obj) <- c("supercells", "x", "y", "geometry")
  # Get the extent of template raster