|
| 1 | +#' @title Dynamic Time Warping for Detect changes. |
| 2 | +#' @name sits_dtw |
| 3 | +#' |
| 4 | +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} |
| 5 | +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} |
| 6 | +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} |
| 7 | +#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} |
| 8 | +#' |
| 9 | +#' @description Create a Dynamic Time Warping (DTW) method for the |
| 10 | +#' \code{\link[sits]{sits_detect_change_method}}. |
| 11 | +#' |
| 12 | +#' @param samples Time series with the training samples. |
| 13 | +#' @param ... Other relevant parameters. |
| 14 | +#' @param threshold Threshold used to define if an event was detected. |
| 15 | +#' Default is `Inf`. |
| 16 | +#' @param window ISO8601-compliant time period used to define the |
| 17 | +#' DTW moving window, with number and unit, |
| 18 | +#' where "D", "M" and "Y" stands for days, month and |
| 19 | +#' year; e.g., "P16D" for 16 days. |
| 20 | +#' @return Change detection method prepared to be passed to |
| 21 | +#' \code{\link[sits]{sits_detect_change_method}} |
| 22 | +#' @export |
| 23 | +#' |
| 24 | +sits_dtw <- |
| 25 | + function(samples = NULL, |
| 26 | + ..., |
| 27 | + threshold = Inf, |
| 28 | + window = NULL) { |
| 29 | + .check_set_caller("sits_dtw") |
| 30 | + train_fun <- |
| 31 | + function(samples) { |
| 32 | + # Check parameters |
| 33 | + .check_period(window) |
| 34 | + .check_null_parameter(threshold) |
| 35 | + # Sample labels |
| 36 | + labels <- .samples_labels(samples) |
| 37 | + # Get samples patterns (temporal median) |
| 38 | + train_samples_patterns <- .pattern_temporal_median(samples) |
| 39 | + # Define detection function |
| 40 | + detect_change_fun <- function(values) { |
| 41 | + # Extract dates |
| 42 | + dates <- values[[1]][["Index"]] |
| 43 | + dates_min <- min(dates) |
| 44 | + dates_max <- max(dates) |
| 45 | + # Assume time-series are regularized, then use the period |
| 46 | + # as the step of the moving window. As a result, we have |
| 47 | + # one step per iteration. |
| 48 | + dates_step <- lubridate::as.period( |
| 49 | + lubridate::int_diff(dates) |
| 50 | + ) |
| 51 | + dates_step <- dates_step[[1]] |
| 52 | + # Create comparison windows |
| 53 | + comparison_windows <- .period_windows( |
| 54 | + period = window, |
| 55 | + step = dates_step, |
| 56 | + start_date = dates_min, |
| 57 | + end_date = dates_max |
| 58 | + ) |
| 59 | + # Do the change detection for each time-series |
| 60 | + purrr::map(values, function(value_row) { |
| 61 | + # Search for the patterns |
| 62 | + patterns_distances <- .pattern_distance_dtw( |
| 63 | + data = value_row, |
| 64 | + patterns = train_samples_patterns, |
| 65 | + windows = comparison_windows |
| 66 | + ) |
| 67 | + # Remove distances out the user-defined threshold |
| 68 | + patterns_distances[patterns_distances > threshold] <- NA |
| 69 | + # Define where each label was detected. For this, first |
| 70 | + # get from each label the minimal distance |
| 71 | + detections_idx <- |
| 72 | + apply(patterns_distances, 2, which.min) |
| 73 | + detections_name <- names(detections_idx) |
| 74 | + # For each label, extract the metadata where they had |
| 75 | + # minimal distance |
| 76 | + purrr::map_df(1:length(detections_idx), function(idx) { |
| 77 | + # Extract detection name and inced |
| 78 | + detection_name <- detections_name[idx] |
| 79 | + detection_idx <- detections_idx[idx] |
| 80 | + # Extract detection distance (min one defined above) |
| 81 | + detection_distance <- |
| 82 | + patterns_distances[detection_idx,] |
| 83 | + detection_distance <- |
| 84 | + detection_distance[detection_name] |
| 85 | + detection_distance <- |
| 86 | + as.numeric(detection_distance) |
| 87 | + # Extract detection dates |
| 88 | + detection_dates <- |
| 89 | + comparison_windows[[detection_idx]] |
| 90 | + # Prepare result and return it! |
| 91 | + data.frame( |
| 92 | + change = detection_name, |
| 93 | + distance = detection_distance, |
| 94 | + from = detection_dates[["start"]], |
| 95 | + to = detection_dates[["end"]] |
| 96 | + ) |
| 97 | + }) |
| 98 | + }) |
| 99 | + } |
| 100 | + # Set model class |
| 101 | + detect_change_fun <- .set_class(detect_change_fun, |
| 102 | + "dtw_model", |
| 103 | + "sits_model", |
| 104 | + class(detect_change_fun)) |
| 105 | + return(detect_change_fun) |
| 106 | + } |
| 107 | + # If samples is informed, train a model and return a predict function |
| 108 | + # Otherwise give back a train function to train model further |
| 109 | + result <- .factory_function(samples, train_fun) |
| 110 | + return(result) |
| 111 | + } |
0 commit comments