fix dtw export

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

@@ -94,6 +94,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

src/RcppExports.cpp

@@ -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},

src/rlang.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);
+}