Merge pull request #1421 from M3nin0/feat/impute-methods

inclusion of new impute methods

Author: gilbertocamara

NAMESPACE

@@ -515,6 +515,9 @@ S3method(summary,variance_cube)
 export("sits_bands<-")
 export("sits_labels<-")
 export(impute_linear)
+export(impute_mean)
+export(impute_mean_window)
+export(impute_median)
 export(sits_accuracy)
 export(sits_accuracy_summary)
 export(sits_add_base_cube)

R/RcppExports.R

@@ -65,6 +65,46 @@ C_glcm_correlation <- function(x, angles, nrows, ncols, n_grey, window_size) {
     .Call(`_sits_C_glcm_correlation`, x, angles, nrows, ncols, n_grey, window_size)
 }
 
+C_interp_mean_window_vec <- function(data, k, weighting) {
+    .Call(`_sits_C_interp_mean_window_vec`, data, k, weighting)
+}
+
+C_interp_mean_window_mat <- function(data, k, weighting) {
+    .Call(`_sits_C_interp_mean_window_mat`, data, k, weighting)
+}
+
+linear_interp <- function(mtx) {
+    .Call(`_sits_linear_interp`, mtx)
+}
+
+linear_interp_vec <- function(vec) {
+    .Call(`_sits_linear_interp_vec`, vec)
+}
+
+C_mask_na <- function(x) {
+    .Call(`_sits_C_mask_na`, x)
+}
+
+C_fill_na <- function(x, fill) {
+    .Call(`_sits_C_fill_na`, x, fill)
+}
+
+C_interp_mean_vec <- function(data) {
+    .Call(`_sits_C_interp_mean_vec`, data)
+}
+
+C_interp_mean_mat <- function(data) {
+    .Call(`_sits_C_interp_mean_mat`, data)
+}
+
+C_interp_median_vec <- function(data) {
+    .Call(`_sits_C_interp_median_vec`, data)
+}
+
+C_interp_median_mat <- function(data) {
+    .Call(`_sits_C_interp_median_mat`, data)
+}
+
 C_kernel_median <- function(x, ncols, nrows, band, window_size) {
     .Call(`_sits_C_kernel_median`, x, ncols, nrows, band, window_size)
 }
@@ -125,22 +165,6 @@ C_label_max_prob <- function(x) {
     .Call(`_sits_C_label_max_prob`, x)
 }
 
-linear_interp <- function(mtx) {
-    .Call(`_sits_linear_interp`, mtx)
-}
-
-linear_interp_vec <- function(vec) {
-    .Call(`_sits_linear_interp_vec`, vec)
-}
-
-C_mask_na <- function(x) {
-    .Call(`_sits_C_mask_na`, x)
-}
-
-C_fill_na <- function(x, fill) {
-    .Call(`_sits_C_fill_na`, x, fill)
-}
-
 batch_calc <- function(n_pixels, max_lines_per_batch) {
     .Call(`_sits_batch_calc`, n_pixels, max_lines_per_batch)
 }

R/api_classify.R

@@ -541,18 +541,18 @@
             bands = bands
         )
     }
-    # Apply time series filter
-    if (.has(filter_fn)) {
+    # Apply imputation filter
+    if (.has(impute_fn)) {
         samples <- .apply_across(
             data = samples,
-            fn = filter_fn
+            fn = impute_fn
         )
     }
-    # Apply imputation filter
-    if (.has(impute_fn)) {
+    # Apply time series filter
+    if (.has(filter_fn)) {
         samples <- .apply_across(
             data = samples,
-            fn = impute_fn
+            fn = filter_fn
         )
     }
     # Compute the breaks in time for multiyear classification

R/sits_imputation.R

@@ -19,6 +19,126 @@ impute_linear <- function(data = NULL) {
     .factory_function(data, impute_fun)
 }
 
+#' @title Remove NA using median
+#' @name impute_median
+#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com}
+#' @description Remove NA using median
+#'
+#' @param  data          A time series vector or matrix
+#' @return               A set of filtered time series using
+#'                       the imputation function.
+#'
+#' @export
+impute_median <- function(data = NULL) {
+    # Define impute function
+    impute_fun <- function(data) {
+        # Matrix
+        if (inherits(data, "matrix")) {
+            C_interp_median_mat(data)
+        }
+
+        # Vector implementation
+        else {
+            as.vector(
+                C_interp_median_vec(data)
+            )
+        }
+    }
+
+    .factory_function(data, impute_fun)
+}
+
+#' @title Remove NA using mean
+#' @name impute_mean
+#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com}
+#' @description Remove NA using mean
+#'
+#' @param  data          A time series vector or matrix
+#' @return               A set of filtered time series using
+#'                       the imputation function.
+#'
+#' @export
+impute_mean <- function(data = NULL) {
+    # Define impute function
+    impute_fun <- function(data) {
+        # Matrix
+        if (inherits(data, "matrix")) {
+            C_interp_mean_mat(data)
+        }
+
+        # Vector implementation
+        else {
+            as.vector(
+                C_interp_mean_vec(data)
+            )
+        }
+    }
+
+    .factory_function(data, impute_fun)
+}
+
+#' @title Remove NA using weighted moving average
+#' @name impute_mean_window
+#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com}
+#' @description Remove NA using weighted moving average
+#'
+#' @param  data          A time series vector or matrix
+#' @param  k             A integer width of the moving average window. Expands
+#'                       to both sides of the center element e.g. k = 2 means 4
+#'                       observations (2 left, 2 right) are taken into account.
+#'                       If all observations in the current window are NA, the
+#'                       window size is automatically increased until there are
+#'                       at least 2 non-NA values present
+#' @param weighting      A string with the weighting strategy to be used. More
+#'                       details below (default is "simple").
+#' @return               A set of filtered time series using
+#'                       the imputation function.
+#'
+#' @note
+#' The \code{weighting} parameter defines the weighting strategy used
+#' in the moving window. The strategies available are:
+#'
+#' \itemize{
+#' \item{\code{simple} - Simple Moving Average (SMA) (default option)}
+#' \item{\code{linear} - Linear Weighted Moving Average (LWMA)}
+#' \item{\code{exponential} - Exponential Weighted Moving Average (EWMA)}
+#' }
+#'
+#' @references
+#' The implementation of this function was adapted from the \code{imputeTS} R
+#' Package. The code is open-source, under the GPL license, and is available on
+#' GitHub \url{https://github.com/SteffenMoritz/imputeTS}.
+#'
+#' @export
+impute_mean_window <- function(data = NULL, k = 2, weighting = "simple") {
+    # Check parameters
+    .check_int_parameter(k, min = 2)
+    .check_chr_within(
+        x = weighting,
+        within = c("simple", "linear", "exponential")
+    )
+
+    # Define impute function
+    impute_fun <- function(data) {
+        # By default, use the vector implementation
+        fnc <- C_interp_mean_window_vec
+
+        # If data is a matrix, use matrix implementation
+        if (inherits(data, "matrix")) {
+            fnc = C_interp_mean_window_mat
+        }
+
+        # Impute!
+        fnc(
+            data = data,
+            k = k,
+            weighting = weighting
+        )
+    }
+
+    .factory_function(data, impute_fun)
+}
+
 #' @title Replace NA values in time series with imputation function
 #' @name sits_impute
 #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
@@ -37,7 +157,7 @@ sits_impute <- function(samples, impute_fn = impute_linear()) {
     .check_samples_ts(samples)
     .samples_foreach_ts(samples, function(row) {
         .ts_values(row) <- tibble::as_tibble(
-            purrr::map_df(.ts_bands(row), function(band) {
+            purrr::map_dfc(.ts_bands(row), function(band) {
                 # get band values
                 band_value <- as.vector(as.matrix(row[[band]]))
                 # impute data