Skip to content

Commit ffeac18

Browse files
M3nin0M3nin0
committed
add dtw as detect change method
1 parent ce544aa commit ffeac18

8 files changed

+297
-0
lines changed

‎DESCRIPTION

+5
Original file line numberDiff line numberDiff line change
@@ -130,7 +130,9 @@ Collate:
130130
'api_cube.R'
131131
'api_data.R'
132132
'api_debug.R'
133+
'api_detect_changes.R'
133134
'api_download.R'
135+
'api_dtw.R'
134136
'api_environment.R'
135137
'api_factory.R'
136138
'api_file_info.R'
@@ -215,6 +217,9 @@ Collate:
215217
'sits_cube_copy.R'
216218
'sits_clean.R'
217219
'sits_cluster.R'
220+
'sits_detect_change.R'
221+
'sits_detect_change_method.R'
222+
'sits_dtw.R'
218223
'sits_factory.R'
219224
'sits_filters.R'
220225
'sits_geo_dist.R'

‎NAMESPACE

+5
Original file line numberDiff line numberDiff line change
@@ -338,6 +338,8 @@ S3method(sits_cube,default)
338338
S3method(sits_cube,local_cube)
339339
S3method(sits_cube,sar_cube)
340340
S3method(sits_cube,stac_cube)
341+
S3method(sits_detect_change,default)
342+
S3method(sits_detect_change,sits)
341343
S3method(sits_get_data,csv)
342344
S3method(sits_get_data,data.frame)
343345
S3method(sits_get_data,default)
@@ -441,6 +443,9 @@ export(sits_config)
441443
export(sits_config_show)
442444
export(sits_cube)
443445
export(sits_cube_copy)
446+
export(sits_detect_change)
447+
export(sits_detect_change_method)
448+
export(sits_dtw)
444449
export(sits_factory_function)
445450
export(sits_filter)
446451
export(sits_formula_linear)

‎R/api_detect_changes.R

+44
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,44 @@
1+
#' @title Detect changes in time-series using various methods.
2+
#' @name .detect_change_ts
3+
#' @keywords internal
4+
#' @noRd
5+
.detect_change_ts <- function(samples,
6+
cd_method,
7+
filter_fn,
8+
multicores,
9+
progress) {
10+
# Start parallel workers
11+
.parallel_start(workers = multicores)
12+
on.exit(.parallel_stop(), add = TRUE)
13+
# Get bands from model
14+
bands <- .ml_bands(cd_method)
15+
# Update samples bands order
16+
if (any(bands != .samples_bands(samples))) {
17+
samples <- .samples_select_bands(samples = samples,
18+
bands = bands)
19+
}
20+
# Apply time series filter
21+
if (.has(filter_fn)) {
22+
samples <- .apply_across(data = samples,
23+
fn = filter_fn)
24+
}
25+
# Divide samples in chunks to parallel processing
26+
parts <- .pred_create_partition(pred = samples, partitions = multicores)
27+
# Detect changes!
28+
detections <- .jobs_map_parallel_dfr(parts, function(part) {
29+
# Get samples
30+
values <- .pred_part(part)
31+
# Detect changes! For detection, models can be time-aware. So, the
32+
# complete data, including dates, must be passed as argument.
33+
detections <- cd_method(values[["time_series"]])
34+
detections <- tibble::tibble(detections)
35+
# Prepare result
36+
result <- tibble::tibble(data.frame(values, detections = detections))
37+
class(result) <- class(values)
38+
# return
39+
result
40+
41+
}, progress = progress)
42+
43+
return(detections)
44+
}

‎R/api_dtw.R

+56
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,56 @@
1+
2+
#' @title Extract temporal pattern of samples using temporal median.
3+
#' @name .pattern_temporal_median
4+
#' @keywords internal
5+
#' @noRd
6+
.pattern_temporal_median <- function(samples) {
7+
samples |>
8+
dplyr::group_by(.data[["label"]]) |>
9+
dplyr::group_map(function(data, name) {
10+
ts_median <- dplyr::bind_rows(data[["time_series"]]) |>
11+
dplyr::group_by(.data[["Index"]]) |>
12+
dplyr::summarize(dplyr::across(dplyr::everything(),
13+
stats::median, na.rm = TRUE)) |>
14+
dplyr::select(-.data[["Index"]])
15+
16+
ts_median["label"] <- name
17+
ts_median
18+
})
19+
}
20+
21+
#' @title Calculate the DTW distance between label patterns and sample data.
22+
#' @name .pattern_distance_dtw
23+
#' @description This function calculates the DTW distance between label patterns
24+
#' and sample data in a given temporal window.
25+
#' @keywords internal
26+
#' @noRd
27+
.pattern_distance_dtw <- function(data, patterns, windows) {
28+
# Calculate the DTW distance between `data` and `patterns`
29+
purrr::map_dfc(1:length(patterns), function(pattern_index) {
30+
# Get pattern metadata
31+
pattern <- patterns[pattern_index][[1]]
32+
pattern_label <- unique(pattern[["label"]])
33+
# Get pattern data
34+
pattern_ts <- dplyr::select(pattern, -.data[["label"]])
35+
pattern_ts <- as.matrix(pattern_ts)
36+
# Windowed search
37+
distances <- purrr::map_df(windows, function(window) {
38+
# Get time-series in the window
39+
data_in_window <-
40+
dplyr::filter(data,
41+
.data[["Index"]] >= window[["start"]],
42+
.data[["Index"]] <= window[["end"]])
43+
# Remove the time reference column
44+
data_in_window <- dplyr::select(data_in_window, -.data[["Index"]])
45+
# Transform values in matrix (as expected in the cpp code)
46+
data_in_window <- as.matrix(data_in_window)
47+
data_in_window <- data_in_window
48+
# Calculate distance
49+
distance_from_pattern <- dtw_distance(data_in_window, pattern_ts)
50+
# Prepare result and return it
51+
data.frame(distance = distance_from_pattern)
52+
})
53+
# Associate the pattern name with the distances
54+
stats::setNames(distances, pattern_label)
55+
})
56+
}

‎R/api_period.R

+34
Original file line numberDiff line numberDiff line change
@@ -47,3 +47,37 @@ NULL
4747
unit <- c(D = "day", M = "month", Y = "year")
4848
unit[[gsub("^P[0-9]+([DMY])$", "\\1", period)]]
4949
}
50+
51+
#' @describeIn period_api Create period windows.
52+
#' @returns \code{.period_windows()}: Period windows.
53+
#' @noRd
54+
.period_windows <- function(period, step, start_date, end_date) {
55+
# Transform `period` and `step` strings in duration
56+
period_duration <- lubridate::as.duration(period)
57+
step_duration <- lubridate::as.duration(step)
58+
# Transform `start_date` and `end_date` to date
59+
start_date <- as.Date(start_date)
60+
end_date <- as.Date(end_date)
61+
# Final period windows
62+
period_windows <- list()
63+
# Define first time period (used as part of the step)
64+
current_start <- start_date
65+
# Create period windows
66+
while(current_start < end_date) {
67+
# Create the window: current start date + step
68+
current_end <- current_start + period_duration
69+
# Avoid window definition beyond the end date
70+
if (current_end > end_date) {
71+
current_end <- end_date
72+
}
73+
# Save period window
74+
period_windows <-
75+
c(period_windows, list(c(
76+
start = as.Date(current_start),
77+
end = as.Date(current_end)
78+
)))
79+
# Move to the next window date: current start date + step
80+
current_start <- current_start + step_duration
81+
}
82+
period_windows
83+
}

‎R/sits_dtw.R

+111
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,111 @@
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+
}

‎inst/extdata/config_messages.yml

+4
Original file line numberDiff line numberDiff line change
@@ -352,6 +352,10 @@ sits_cube_default: "requested source has not been registered in sits\n - if poss
352352
sits_cube_copy: "wrong input parameters - see example in documentation"
353353
sits_cube_local_cube: "wrong input parameters - see example in documentation"
354354
sits_cube_local_cube_vector_band: "one vector_band must be provided (either segments, class, or probs)"
355+
sits_detect_change_method_model: "cd_method is not a valid function"
356+
sits_detect_change_method_timeline: "samples have different timeline lengths"
357+
sits_detect_change_sits: "wrong input parameters - see example in documentation"
358+
sits_dtw: "wrong input parameters - see example in documentation"
355359
sits_filter: "input should be a valid set of training samples or a non-classified data cube"
356360
sits_formula_linear: "invalid input data"
357361
sits_formula_logref: "invalid input data"

‎man/sits_dtw.Rd

+38
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

0 commit comments

Comments
 (0)