Merge pull request #1141 from M3nin0/feature/detections-api-cube

detect changes api: improve `sits_dtw` operations in data cubes

R/api_dtw.R

@@ -1,26 +1,5 @@
 # ---- Distances ----
 #' @title Calculate the DTW distance between temporal patterns and time-series.
-#' @name .dtw_distance
-#' @description This function calculates the DTW distance between label patterns
-#' and real data (e.g., sample data, data cube data). The distance is calculated
-#' without a window. It's use is recommended for big datasets.
-#' @keywords internal
-#' @noRd
-.dtw_distance <- function(data, patterns) {
- # Prepare input data
- data <- as.matrix(.ts_values(data))
- # Calculate the DTW distance between `data` and `patterns`
- purrr::map_dfc(patterns, function(pattern) {
- # Prepare pattern data
- pattern_ts <- as.matrix(.ts_values(pattern))
- # Calculate distance
- stats::setNames(
- data.frame(distance = dtw_distance(data, pattern_ts)),
- pattern[["label"]][[1]]
- )
- })
-}
-#' @title Calculate the DTW distance between temporal patterns and time-series.
 #' @name .dtw_distance_windowed
 #' @description This function calculates the DTW distance between label patterns
 #' and real data (e.g., sample data, data cube data). The distance is calculated
@@ -35,12 +14,7 @@
  # Windowed search
  distances <- purrr::map_df(windows, function(window) {
  # Get time-series in the window
- data_in_window <-
- dplyr::filter(data,
- .data[["Index"]] >= window[["start"]],
- .data[["Index"]] <= window[["end"]])
- # Remove the time reference column
- data_in_window <- as.matrix(.ts_values(data_in_window))
+ data_in_window <- as.matrix(.ts_values(data[window,]))
  # Calculate distance
  data.frame(distance = dtw_distance(data_in_window, pattern_ts))
  })
@@ -49,31 +23,61 @@
  })
 }
 # ---- Operation mode ----
-#' @title Search for events in time series using complete data (no windowing).
-#' @name .dtw_complete_ts
-#' @description This function searches for events in time series without
-#' windowing.
+#' @title Search for events in data cube.
+#' @name .dtw_cube
+#' @description This function searches for events in data cubes.
 #' @keywords internal
 #' @noRd
-.dtw_complete_ts <- function(values, patterns, threshold, ...) {
+.dtw_cube <- function(values, patterns, window, threshold, ...) {
+ # Extract dates
+ dates <- .ts_index(values[[1]])
+ dates_min <- .ts_min_date(values[[1]])
+ dates_max <- .ts_max_date(values[[1]])
+ # Assume time-series are regularized, then use the period
+ # as the step of the moving window. As a result, we have
+ # one step per iteration.
+ dates_step <- lubridate::as.period(
+ lubridate::int_diff(.ts_index(values[[1]]))
+ )
+ dates_step <- dates_step[[1]]
+ # Create comparison windows
+ comparison_windows <- .period_windows(
+ period = window,
+ step = dates_step,
+ start_date = dates_min,
+ end_date = dates_max
+ )
+ # Transform comparison windows to indices to avoid filters
+ comparison_windows <- purrr::map(comparison_windows, function(window) {
+ which(
+ dates >= window[["start"]] & dates <= window[["end"]]
+ )
+ })
  # Do the change detection for each time-series
  purrr::map_vec(values, function(value_row) {
  # Search for the patterns
- patterns_distances <- .dtw_distance(
+ patterns_distances <- .dtw_distance_windowed(
  data = value_row,
- patterns = patterns
+ patterns = patterns,
+ windows = comparison_windows
  )
  # Remove distances out the user-defined threshold
- as.numeric(any(patterns_distances <= threshold))
+ patterns_distances[patterns_distances <= threshold] <- 1
+ patterns_distances[patterns_distances > threshold] <- 0
+ # Get the position of the valid values
+ patterns_distances <- which(patterns_distances == 1)
+ # Return value
+ ifelse(length(patterns_distances) > 0, min(patterns_distances), 0)
  })
 }
-#' @title Search for events in time series using windowing.
-#' @name .dtw_windowed_ts
-#' @description This function searches for events in time series with windowing.
+#' @title Search for events in time-series.
+#' @name .dtw_ts
+#' @description This function searches for events in time-series
 #' @keywords internal
 #' @noRd
-.dtw_windowed_ts <- function(values, patterns, window, threshold) {
+.dtw_ts <- function(values, patterns, window, threshold, ...) {
  # Extract dates
+ dates <- .ts_index(values[[1]])
  dates_min <- .ts_min_date(values[[1]])
  dates_max <- .ts_max_date(values[[1]])
  # Assume time-series are regularized, then use the period
@@ -90,13 +94,19 @@
  start_date = dates_min,
  end_date = dates_max
  )
+ # Transform comparison windows to indices to avoid filters
+ comparison_windows_idx <- purrr::map(comparison_windows, function(window) {
+ which(
+ dates >= window[["start"]] & dates <= window[["end"]]
+ )
+ })
  # Do the change detection for each time-series
  purrr::map(values, function(value_row) {
  # Search for the patterns
  patterns_distances <- .dtw_distance_windowed(
  data = value_row,
  patterns = patterns,
- windows = comparison_windows
+ windows = comparison_windows_idx
  )
  # Remove distances out the user-defined threshold
  patterns_distances[patterns_distances > threshold] <- NA

R/api_patterns.R

@@ -18,3 +18,14 @@
  ts_median
  })
 }
+
+#' @title Extract labels available in patterns.
+#' @name .pattern_labels
+#' @keywords internal
+#' @noRd
+#' @param patterns Samples patterns.
+.pattern_labels <- function(patterns) {
+ purrr::map_vec(patterns, function(pattern) {
+ unique(pattern[["label"]])
+ })
+}

R/sits_dtw.R

@@ -17,31 +17,62 @@
 #' where "D", "M" and "Y" stands for days, month and
 #' year; e.g., "P16D" for 16 days. This parameter is not
 #' used in operations with data cubes.
+#' @param start_date Initial date of the interval used to extract the
+#' patterns from the samples.
+#' @param end_date Final date of the interval used to extract the
+#' patterns from the samples.
+#' @param patterns Temporal patterns of the each label available in
+#' `samples`.
 #' @return Change detection method prepared to be passed to
 #' \code{\link[sits]{sits_detect_change_method}}
 #' @export
+#'
 sits_dtw <-
  function(samples = NULL,
  ...,
  threshold = NULL,
- window = NULL) {
+ start_date = NULL,
+ end_date = NULL,
+ window = NULL,
+ patterns = NULL) {
  .check_set_caller("sits_dtw")
  train_fun <-
  function(samples) {
  # Check parameters
  .check_period(window)
  .check_null_parameter(threshold)
+ .check_date_parameter(start_date, allow_null = TRUE)
+ .check_date_parameter(end_date, allow_null = TRUE)
  # Sample labels
  labels <- .samples_labels(samples)
- # Get samples patterns (temporal median)
+ # Generate predictors
  train_samples <- .predictors(samples)
- patterns <- .pattern_temporal_median(samples)
+ # Generate patterns (if not defined by the user)
+ if (is.null(patterns)) {
+ # Save samples used to generate temporal patterns
+ patterns_samples <- samples
+ # Filter samples if required
+ if (!is.null(start_date) & !is.null(end_date)) {
+ patterns_samples <- .samples_filter_interval(
+ samples = patterns_samples,
+ start_date = start_date,
+ end_date = end_date
+ )
+ }
+ # Generate samples patterns (temporal median)
+ patterns <- .pattern_temporal_median(patterns_samples)
+ }
+ # Check patterns
+ .check_chr_contains(
+ x = .samples_labels(samples),
+ contains = .pattern_labels(patterns)
+ )
  # Define detection function
  detect_change_fun <- function(values, type) {
  # Define the type of the operation
- dtw_fun <- .dtw_windowed_ts
+ dtw_fun <- .dtw_ts
  if (type == "cube") {
- dtw_fun <- .dtw_complete_ts
+ dtw_fun <- .dtw_cube
  }
  # Detect changes
  dtw_fun(