use Rf_lang* functions

qddyy · Dec 17, 2024 · 55a1444 · 55a1444
1 parent e0b62c4
commit 55a1444
Showing 1 changed file with 33 additions and 21 deletions.
diff --git a/src/pmt_interface.cpp b/src/pmt_interface.cpp
@@ -7,31 +7,43 @@ using namespace Rcpp;
 
 #include <type_traits>
 
-template <bool sharing_args>
+template <unsigned n>
+constexpr auto Rf_lang = nullptr;
+
+template <>
+constexpr auto Rf_lang<2> = Rf_lang2;
+
+template <>
+constexpr auto Rf_lang<3> = Rf_lang3;
+
+template <unsigned n_shared>
 class StatFunc : public Function {
+    template <unsigned i>
+    using tag_t = std::integral_constant<unsigned, i>;
+
 public:
     using Function::Function;
 
     template <typename... Args>
     auto operator()(Args&&... args) const
     {
-        return _invoke(std::integral_constant<bool, sharing_args>(), std::forward<Args>(args)...);
+        return _invoke(tag_t<n_shared>(), std::forward<Args>(args)...);
     }
 
 private:
     template <typename... Args>
-    auto _invoke(std::false_type, Args&&... args) const
+    auto _invoke(tag_t<0>, Args&&... args) const
     {
         return [r_closure = Function(Function::operator()(std::forward<Args>(args)...))](auto&&... args) {
             return as<double>(r_closure(std::forward<decltype(args)>(args)...));
         };
     }
 
-    template <typename... Args>
-    auto _invoke(std::true_type, Args&&... args) const
+    template <unsigned n = n_shared, typename... Args>
+    auto _invoke(tag_t<n>, Args&&... args) const
     {
-        return [r_call = Language(Function(Function::operator()(std::forward<Args>(args)...)), std::forward<Args>(args)...)](auto&&...) {
-            return as<double>(r_call.eval());
+        return [r_call = RObject(Rf_lang<n + 1>(Function::operator()(std::forward<Args>(args)...), std::forward<Args>(args)...))](auto&&...) {
+            return as<double>(Rcpp_fast_eval(r_call, R_GlobalEnv));
         };
     }
 };
@@ -47,8 +59,8 @@ SEXP twosample_pmt(
     const bool progress)
 {
     return progress ?
-        impl_twosample_pmt<true, StatFunc<true>>(clone(x), clone(y), statistic_func, n_permu) :
-        impl_twosample_pmt<false, StatFunc<true>>(clone(x), clone(y), statistic_func, n_permu);
+        impl_twosample_pmt<true, StatFunc<2>>(clone(x), clone(y), statistic_func, n_permu) :
+        impl_twosample_pmt<false, StatFunc<2>>(clone(x), clone(y), statistic_func, n_permu);
 }
 
 #include "pmt/impl_ksample_pmt.hpp"
@@ -62,8 +74,8 @@ SEXP ksample_pmt(
     const bool progress)
 {
     return progress ?
-        impl_ksample_pmt<true, StatFunc<true>>(data, clone(group), statistic_func, n_permu) :
-        impl_ksample_pmt<false, StatFunc<true>>(data, clone(group), statistic_func, n_permu);
+        impl_ksample_pmt<true, StatFunc<2>>(data, clone(group), statistic_func, n_permu) :
+        impl_ksample_pmt<false, StatFunc<2>>(data, clone(group), statistic_func, n_permu);
 }
 
 #include "pmt/impl_multcomp_pmt.hpp"
@@ -79,8 +91,8 @@ SEXP multcomp_pmt(
     const bool progress)
 {
     return progress ?
-        impl_multcomp_pmt<true, StatFunc<false>>(group_i, group_j, data, clone(group), statistic_func, n_permu) :
-        impl_multcomp_pmt<false, StatFunc<false>>(group_i, group_j, data, clone(group), statistic_func, n_permu);
+        impl_multcomp_pmt<true, StatFunc<0>>(group_i, group_j, data, clone(group), statistic_func, n_permu) :
+        impl_multcomp_pmt<false, StatFunc<0>>(group_i, group_j, data, clone(group), statistic_func, n_permu);
 }
 
 #include "pmt/impl_paired_pmt.hpp"
@@ -94,8 +106,8 @@ SEXP paired_pmt(
     const bool progress)
 {
     return progress ?
-        impl_paired_pmt<true, StatFunc<true>>(clone(x), clone(y), statistic_func, n_permu) :
-        impl_paired_pmt<false, StatFunc<true>>(clone(x), clone(y), statistic_func, n_permu);
+        impl_paired_pmt<true, StatFunc<2>>(clone(x), clone(y), statistic_func, n_permu) :
+        impl_paired_pmt<false, StatFunc<2>>(clone(x), clone(y), statistic_func, n_permu);
 }
 
 #include "pmt/impl_rcbd_pmt.hpp"
@@ -108,8 +120,8 @@ SEXP rcbd_pmt(
     const bool progress)
 {
     return progress ?
-        impl_rcbd_pmt<true, StatFunc<true>>(clone(data), statistic_func, n_permu) :
-        impl_rcbd_pmt<false, StatFunc<true>>(clone(data), statistic_func, n_permu);
+        impl_rcbd_pmt<true, StatFunc<1>>(clone(data), statistic_func, n_permu) :
+        impl_rcbd_pmt<false, StatFunc<1>>(clone(data), statistic_func, n_permu);
 }
 
 #include "pmt/impl_association_pmt.hpp"
@@ -123,8 +135,8 @@ SEXP association_pmt(
     const bool progress)
 {
     return progress ?
-        impl_association_pmt<true, StatFunc<true>>(clone(x), clone(y), statistic_func, n_permu) :
-        impl_association_pmt<false, StatFunc<true>>(clone(x), clone(y), statistic_func, n_permu);
+        impl_association_pmt<true, StatFunc<2>>(clone(x), clone(y), statistic_func, n_permu) :
+        impl_association_pmt<false, StatFunc<2>>(clone(x), clone(y), statistic_func, n_permu);
 }
 
 #include "pmt/impl_table_pmt.hpp"
@@ -138,6 +150,6 @@ SEXP table_pmt(
     const bool progress)
 {
     return progress ?
-        impl_table_pmt<true, StatFunc<true>>(clone(row), clone(col), statistic_func, n_permu) :
-        impl_table_pmt<false, StatFunc<true>>(clone(row), clone(col), statistic_func, n_permu);
+        impl_table_pmt<true, StatFunc<1>>(clone(row), clone(col), statistic_func, n_permu) :
+        impl_table_pmt<false, StatFunc<1>>(clone(row), clone(col), statistic_func, n_permu);
 }