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

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

Author: gilbertocamara

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(