fix dtw export

Author: M3nin0

R/RcppExports.R

@@ -145,6 +145,14 @@ C_temp_iqr <- function(mtx) {
     .Call(`_sits_C_temp_iqr`, mtx)
 }
 
+rlang_env_unlock <- function(env) {
+    invisible(.Call(`_sits_rlang_env_unlock`, env))
+}
+
+rlang_env_lock <- function(env) {
+    invisible(.Call(`_sits_rlang_env_lock`, env))
+}
+
 sample_points_inclusion <- function(polymatrix, n_sam_pol) {
     .Call(`_sits_sample_points_inclusion`, polymatrix, n_sam_pol)
 }

R/api_som.R

@@ -1,3 +1,25 @@
+#' @title Register custom distances in the `kohonen` package environment.
+#' @name .som_register_custom_distances
+#' @keywords internal
+#' @noRd
+#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com}
+#'
+#' @description This function injects custom distance functions in the
+#' environment of the `kohonen` package.
+#'
+.som_register_custom_distances <- function() {
+    kohonen_namespace <- base::asNamespace("kohonen")
+
+    # unlock the environment
+    rlang_env_unlock(kohonen_namespace)
+
+    # include custom distances in the environment
+    base::assign("dtw", dtw, envir = kohonen_namespace)
+
+    # lock the environment
+    rlang_env_lock(kohonen_namespace)
+}
+
 #' @title Label neurons
 #' @name .som_label_neurons
 #' @keywords internal

R/sits_som.R

@@ -54,9 +54,10 @@
 #' @param som_radius     Radius of SOM neighborhood.
 #' @param mode           Type of learning algorithm (default = "online").
 #'
-#' @note The sits package implements the \code{"dtw"} (Dynamic Time Warping)
-#'       similarity measure. All other similarity measurements are from
-#'       the \code{\link[kohonen:supersom]{kohonen::supersom (dist.fcts)}}
+#' @note The \code{sits} package implements the \code{"dtw"} (Dynamic Time
+#'       Warping) similarity measure. All other similarity measurements
+#'       come from the
+#'       \code{\link[kohonen:supersom]{kohonen::supersom (dist.fcts)}}
 #'       function.
 #'
 #' @return
@@ -94,6 +95,8 @@ sits_som_map <- function(data,
                          distance = "euclidean",
                          som_radius = 2,
                          mode = "online") {
+    # register custom distances
+    .som_register_custom_distances()
     # set caller to show in errors
     .check_set_caller("sits_som_map")
     # verifies if kohonen package is installed

man/sits-package.Rd

@@ -447,6 +447,26 @@ BEGIN_RCPP
     return rcpp_result_gen;
 END_RCPP
 }
+// rlang_env_unlock
+void rlang_env_unlock(SEXPREC* env);
+RcppExport SEXP _sits_rlang_env_unlock(SEXP envSEXP) {
+BEGIN_RCPP
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    Rcpp::traits::input_parameter< SEXPREC* >::type env(envSEXP);
+    rlang_env_unlock(env);
+    return R_NilValue;
+END_RCPP
+}
+// rlang_env_lock
+void rlang_env_lock(SEXPREC* env);
+RcppExport SEXP _sits_rlang_env_lock(SEXP envSEXP) {
+BEGIN_RCPP
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    Rcpp::traits::input_parameter< SEXPREC* >::type env(envSEXP);
+    rlang_env_lock(env);
+    return R_NilValue;
+END_RCPP
+}
 // sample_points_inclusion
 NumericMatrix sample_points_inclusion(const NumericMatrix& polymatrix, const int n_sam_pol);
 RcppExport SEXP _sits_sample_points_inclusion(SEXP polymatrixSEXP, SEXP n_sam_polSEXP) {
@@ -669,6 +689,8 @@ static const R_CallMethodDef CallEntries[] = {
     {"_sits_C_temp_sqr", (DL_FUNC) &_sits_C_temp_sqr, 1},
     {"_sits_C_temp_tqr", (DL_FUNC) &_sits_C_temp_tqr, 1},
     {"_sits_C_temp_iqr", (DL_FUNC) &_sits_C_temp_iqr, 1},
+    {"_sits_rlang_env_unlock", (DL_FUNC) &_sits_rlang_env_unlock, 1},
+    {"_sits_rlang_env_lock", (DL_FUNC) &_sits_rlang_env_lock, 1},
     {"_sits_sample_points_inclusion", (DL_FUNC) &_sits_sample_points_inclusion, 2},
     {"_sits_sample_points_crossings", (DL_FUNC) &_sits_sample_points_crossings, 2},
     {"_sits_sample_points_bin", (DL_FUNC) &_sits_sample_points_bin, 2},

man/sits_som.Rd

@@ -1,40 +1,38 @@
 #include <Rcpp.h>
 
-#include <cstdlib>
-#include <vector>
-#include <cmath>
-#include <algorithm>
-#include <stdexcept>
-
 #include "./sits_types.h"
 
 using namespace Rcpp;
 
 /**
- * Compute the p-norm distance between two 1D C++ vectors.
+ * Compute the p-norm between two time-series.
  *
  * @description
- * The p-norm, also known as the Minkowski norm, is a generalized norm
- * calculation that includes several types of distances based on the value of p.
+ * The `p-norm`, also known as the `Minkowski space`, is a generalized norm
+ * calculation that includes several types of distances based on the value
+ * of `p`.
  *
- * Common values of p include:
+ * Common values of `p` include:
  *
- *  - p = 1 for the Manhattan (city block) distance;
- *  - p = 2 for the Euclidean norm (distance).
+ *  - `p = 1` for the Manhattan (city block) distance;
+ *  - `p = 2` for the Euclidean norm (distance).
  *
  * More details about p-norms can be found on Wikipedia:
  * https://en.wikipedia.org/wiki/Norm_(mathematics)#p-norm
  *
- * @param a A 1D vector representing the first point in an m-dimensional space.
- * @param b A 1D vector representing the second point in an m-dimensional space.
- * @param p The value of the norm to use, determining the type of distance
- *          calculated.
+ * @param a A `std::vector<double>` with time-series values.
+ * @param b A `std::vector<double>` with time-series values.
+ * @param p A `double` value of the norm to use, determining the type of
+ *          distance calculated.
+ *
+ * @note
+ * Both vectors `a` and `b` must have the same length.
  *
- * @note Both vectors 'a' and 'b' must have the same number of dimensions.
- * @note This function was adapted from the DTW implementation found at:
- *       https://github.com/cjekel/DTW_cpp
+ * @note
+ * The implementation of this DTW distance calculation was adapted from the
+ * `DTW_cpp` single header library (https://github.com/cjekel/DTW_cpp).
  *
- * @return The p-norm distance between vectors 'a' and 'b'.
+ * @return The `p-norm` value between vectors `a` and `b`.
  */
 double p_norm(std::vector<double> a, std::vector<double> b, double p)
 {
@@ -51,34 +49,25 @@ double p_norm(std::vector<double> a, std::vector<double> b, double p)
 }
 
 /**
- * Compute the Dynamic Time Warping (DTW) distance between two 2D C++ vectors.
+ * Dynamic Time Warping (DTW) distance.
  *
  * @description
  * This function calculates the Dynamic Time Warping (DTW) distance between
- * two sequences that can have a different number of data points but must
- * share the same number of dimensions. An exception is thrown if the dimensions
- * of the input vectors do not match.
+ * two time-series.
  *
- * For more information on DTW, visit:
- * https://en.wikipedia.org/wiki/Dynamic_time_warping
+ * @param x A `std::vector<std::vector<double>>` with time-series values.
+ * @param y A `std::vector<std::vector<double>>` with time-series values.
  *
- * @param a A 2D vector representing the first sequence
- * @param b A 2D vector representing the second sequence.
- * @param p The value of p-norm to use for distance calculation.
- *
- * @throws std::invalid_argument If the dimensions of 'a' and 'b' do not match.
+ * @reference
+ * Giorgino, T. (2009). Computing and Visualizing Dynamic Time Warping
+ * Alignments in R: The dtw Package. Journal of Statistical Software, 31(7),
+ * 1–24. https://doi.org/10.18637/jss.v031.i07
  *
  * @note
- * Both vectors 'a', and 'b' should be structured as follows:
- *
- *  [number_of_data_points][number_of_dimensions]
- *
- * allowing the DTW distance computation to adapt to any p-norm value specified.
+ * The implementation of this DTW distance calculation was adapted from the
+ * `DTW_cpp` single header library (https://github.com/cjekel/DTW_cpp).
  *
- * @note The implementation of this DTW distance calculation was adapted from:
- *       https://github.com/cjekel/DTW_cpp
- *
- * @return The DTW distance between the two input sequences.
+ * @return DTW distance.
  */
 double distance_dtw_op(std::vector<std::vector<double>> a,
                        std::vector<std::vector<double>> b,
@@ -87,15 +76,6 @@ double distance_dtw_op(std::vector<std::vector<double>> a,
     int n = a.size();
     int o = b.size();
 
-    int a_m = a[0].size();
-    int b_m = b[0].size();
-
-    if (a_m != b_m)
-    {
-        throw std::invalid_argument(
-            "a and b must have the same number of dimensions!"
-        );
-    }
     std::vector<std::vector<double>> d(n, std::vector<double>(o, 0.0));
 
     d[0][0] = p_norm(a[0], b[0], p);
@@ -121,22 +101,27 @@ double distance_dtw_op(std::vector<std::vector<double>> a,
 }
 
 /**
- * Dynamic Time Warping (DTW) distance wrapper.
+ * Dynamic Time Warping (DTW) distance.
  *
  * @description
- * This function calculates prepare data from `Kohonen` package and calculate
- * the DTW distance between two array of points.
+ * This function calculates the Dynamic Time Warping (DTW) distance between
+ * two time-series.
  *
- * @param a A 2D vector representing the first sequence.
- * @param b A 2D vector representing the second sequence.
- * @param np Number of points in vectors `a` and `b`.
- * @param nNA Number of NA values in the vectors `a` and `b`.
+ * @param x A `double *` Time-series data.
+ * @param y A `double *` Self-Organizing Maps (SOM) codebook.
+ * @param np `int` Number of points in arrays `p1` and `p2`.
+ * @param nNA `int` Number of `NA` values in the arrays `p1` and `p2`.
  *
- * @note The function signature was created following the `Kohonen` R package
- *        specifications for custom distance functions.
+ * @reference
+ * Giorgino, T. (2009). Computing and Visualizing Dynamic Time Warping
+ * Alignments in R: The dtw Package. Journal of Statistical Software, 31(7),
+ * 1–24. https://doi.org/10.18637/jss.v031.i07
  *
+ * @note
+ * The implementation of this DTW distance calculation was adapted from the
+ * `DTW_cpp` single header library (https://github.com/cjekel/DTW_cpp).
  *
- * @return The DTW distance between the two input sequences.
+ * @return DTW distance.
  */
 double kohonen_dtw(double *p1, double *p2, int np, int nNA)
 {

src/RcppExports.cpp

@@ -0,0 +1,20 @@
+#include <Rcpp.h>
+
+using namespace Rcpp;
+
+/*
+ * These functions were extracted from the `rlang` package to avoid extra
+ * dependencies.
+ */
+#define FRAME_LOCK_MASK (1 << 14)
+#define UNLOCK_FRAME(e) SET_ENVFLAGS(e, ENVFLAGS(e) & (~FRAME_LOCK_MASK))
+
+// [[Rcpp::export]]
+void rlang_env_unlock(SEXPREC* env) {
+    UNLOCK_FRAME(env);
+}
+
+// [[Rcpp::export]]
+void rlang_env_lock(SEXPREC* env) {
+    UNLOCK_FRAME(env);
+}