diff --git a/nCompiler/R/NC_SimpleInterface.R b/nCompiler/R/NC_SimpleInterface.R index 63199cc9..39ee93f6 100644 --- a/nCompiler/R/NC_SimpleInterface.R +++ b/nCompiler/R/NC_SimpleInterface.R @@ -43,7 +43,7 @@ value <- function(obj, name) { } #' @export -`value<-` <- function(obj, name, value) { +`value<-` <- function(obj, name = NULL, value) { if(inherits(obj, "CnClass")) obj <- obj$private$CppObj DLLenv <- get_DLLenv(obj) diff --git a/nCompiler/R/cppDefs_R_interface_calls.R b/nCompiler/R/cppDefs_R_interface_calls.R index a8b14c3b..015123ab 100644 --- a/nCompiler/R/cppDefs_R_interface_calls.R +++ b/nCompiler/R/cppDefs_R_interface_calls.R @@ -27,11 +27,15 @@ global_R_interface_cppDef <- "// This is completely generic, good for all derived classes\n", "// [[Rcpp::export]]\n", - "SEXP set_value(SEXP Xptr, const std::string &name, SEXP Svalue) {\n", + "SEXP set_value(SEXP Xptr, Rcpp::Nullable &name, SEXP Svalue) {\n", " genericInterfaceBaseC *obj =\n", " get_genericInterfaceBaseC(Xptr);\n", " //std::cout << name << std::endl;\n", - " obj->set_value( name, Svalue );\n", + " if(name.isNull()) {\n", + " obj->set_all_values( Svalue );\n", + " } else {\n", + " obj->set_value( Rcpp::as(name), Svalue );\n", + " }\n", " return(R_NilValue);\n", "}\n\n", diff --git a/nCompiler/inst/include/nCompiler/nC_inter/generic_class_interface.h b/nCompiler/inst/include/nCompiler/nC_inter/generic_class_interface.h index 533d8885..30d0d4ef 100644 --- a/nCompiler/inst/include/nCompiler/nC_inter/generic_class_interface.h +++ b/nCompiler/inst/include/nCompiler/nC_inter/generic_class_interface.h @@ -71,6 +71,9 @@ class genericInterfaceBaseC { std::cout<<"Error: you should be in a derived genericInterfaceC class for get_value"< : virtual public genericInterfaceBaseC SEXP get_value(const std::string &name) const override { return FirstFound::get_value(name); } + void set_all_values(SEXP Robj) override { + FirstFound::set_all_values(Robj); + } void set_value(const std::string &name, SEXP Svalue) override { FirstFound::set_value(name, Svalue); } @@ -228,217 +237,4 @@ class method_base { template class genericInterfaceC; -// // Interface to class T. -// template -// class genericInterfaceC : public genericInterfaceBaseC { -// public: -// ~genericInterfaceC() { -// #ifdef SHOW_DESTRUCTORS -// std::cout<<"In derived genericInterfaceC destructor"< -// class accessor_class : public accessor_base { -// public: -// typedef P T::*ptrtype; -// ptrtype ptr; -// accessor_class(ptrtype ptr) : ptr(ptr) {}; - -// SEXP get(const genericInterfaceBaseC *intBasePtr) const { -// #ifdef SHOW_FIELDS -// std::cout<<"in derived get"<(intBasePtr)->*ptr); -// } -// void set(genericInterfaceBaseC *intBasePtr, SEXP Svalue) { -// #ifdef SHOW_FIELDS -// std::cout<<"in derived set"<(intBasePtr)->*ptr = Rcpp::as

(Svalue); -// // Originally we defined an Rcpp::Exporter specialization as needed, -// // which is called via as<>. However, we gain more flexibility in -// // argument passing by defining new Rcpp::traits::input_parameter specializations. -// // As a result, it is simpler her to create a new P object via this pathway. -// reinterpret_cast(intBasePtr)->*ptr = P(typename Rcpp::traits::input_parameter

::type(Svalue)); -// } -// }; - -// // static maps from character names -// static int name_count; -// typedef std::map name2index_type; -// static name2index_type name2index; - -// typedef std::map > name2access_type; -// typedef std::pair > name_access_pair; -// static name2access_type name2access; - -// // Enter a new (name, member ptr) pair to static maps. -// template -// static name_access_pair field(std::string name, P T::*ptr) { -// #ifdef SHOW_FIELDS -// std::cout<<"adding "<(new accessor_class

(ptr)) -// ); -// } - -// // hello world to see if static maps were populated. -// void hw() { -// std::cout<<"HW "<second->get(this)); -// } - -// void set_value(const std::string &name, SEXP Svalue ) { -// #ifdef SHOW_FIELDS -// std::cout<<"in derived set_value"<second->set(this, Svalue); -// } - -// /****** METHODS ******/ -// struct method_info { -// // explicit saves the compiler from giving ambiguous -// // constructor error from implicit copy and move constructors. -// // I am not sure if this is the right way to resolve the issue. -// method_info(const std::shared_ptr& method_ptr_, -// const args &args_) : -// my_args(args_), -// method_ptr(method_ptr_){}; -// args my_args; -// std::shared_ptr method_ptr; -// }; -// // method_info needs a template argument, so this idea breaks. -// typedef std::map name2method_type; -// typedef std::pair name_method_pair; - - -// SEXP call_method(const std::string &name, SEXP Sargs) { -// #ifdef SHOW_METHODS -// std::cout<<"in derived call_method"<second.my_args.argVector, Sargs)); -// SEXP Sans = PROTECT(method->second.method_ptr->call(this, SinnerArgs)); -// UNPROTECT(2); -// return Sans; -// } - -// template -// class method_class : public method_base { -// public: -// typedef P (T::*ptrtype)(ARGS...); -// ptrtype ptr; -// method_class(ptrtype ptr) : ptr(ptr) {}; - -// SEXP call(genericInterfaceBaseC *intBasePtr, SEXP Sargs) { -// #ifdef SHOW_METHODS -// std::cout<<"in derived call"<::template call(reinterpret_cast(intBasePtr), ptr, Sargs) -// ); -// } -// }; - -// /* Partial specialization on void return type avoids Rcpp::wrap, which doesn't work. */ -// /* There might be a slightly more compact way to refactor just the Rcpp::wrap step, but */ -// /* this is a quick and simple solution:*/ -// template -// class method_class : public method_base { -// public: -// typedef void (T::*ptrtype)(ARGS...); -// ptrtype ptr; -// method_class(ptrtype ptr) : ptr(ptr) {}; - -// SEXP call(genericInterfaceBaseC *intBasePtr, SEXP Sargs) { -// #ifdef SHOW_METHODS -// std::cout<<"in derived call"<::template call(reinterpret_cast(intBasePtr), ptr, Sargs); -// return R_NilValue; -// } -// }; - -// // typedef std::map > name2method_type; -// // typedef std::pair > name_method_pair; - -// static name2method_type name2method; -// template -// static name_method_pair method(std::string name, -// P (T::*fun)(ARGS... args), -// const args& args_) { -// #ifdef SHOW_METHODS -// std::cout<<"adding method "<(new method_class(fun)), args_) -// ); -// } -// #ifdef NCOMPILER_USES_CEREAL -// template -// void _SERIALIZE_(Archive &archive) { -// archive(cereal::base_class(this)); -// } -// #endif -// }; - - -/* // From here down has been turned into macros above. */ -/* // This example uses the input name fooC */ -/* // followed by "field" and "method" entries. */ -/* template<> */ -/* int genericInterfaceC::name_count = 0; */ - -/* template<> */ -/* genericInterfaceC::name2index_type genericInterfaceC::name2index {}; */ - -/* template<> */ -/* genericInterfaceC::name2access_type genericInterfaceC::name2access { */ -/* field("x", &fooC::x), */ -/* field("y", &fooC::y) */ -/* }; */ - - -/* template<> */ -/* genericInterfaceC::name2method_type genericInterfaceC::name2method { */ -/* method("print_val", &fooC::print_val) */ -/* }; */ - #endif diff --git a/nCompiler/inst/include/nCompiler/nC_inter/nCompiler_class_interface_old.h b/nCompiler/inst/include/nCompiler/nC_inter/nCompiler_class_interface_old.h deleted file mode 100644 index dfd08424..00000000 --- a/nCompiler/inst/include/nCompiler/nC_inter/nCompiler_class_interface_old.h +++ /dev/null @@ -1,288 +0,0 @@ -#ifndef __NCOMPILER_CLASS_INTERFACE -#define __NCOMPILER_CLASS_INTERFACE - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include "shared_ptr_as_wrap.h" - -// #include - -// These avoid the problem that a macro argument like "fields" below -// can't contain comma-separated elements. -#define NCOMPILER_FIELDS(...) { __VA_ARGS__ } -#define NCOMPILER_METHODS(...) { __VA_ARGS__ } - -// Some options for verbose output: -// #define SHOW_DESTRUCTORS -// #define SHOW_FIELDS -// #define SHOW_METHODS - -#define NCOMPILER_INTERFACE(name, fields, methods)\ - template <>\ - int genericInterfaceC::name_count = 0; \ - template<>\ - genericInterfaceC::name2index_type genericInterfaceC::name2index {};\ - template<>\ - genericInterfaceC::name2access_type genericInterfaceC::name2access \ - fields\ - ;\ - template<>\ - genericInterfaceC::name2method_type genericInterfaceC::name2method \ - methods\ - ; - -// Base class for interfaces to nimble classes -class genericInterfaceBaseC { - public: - // return a named member converted to a SEXP. - // Derived classes should provide valid implementations. - virtual SEXP get_value(const std::string &name) const { - std::cout<<"Error: you should be in a derived genericInterfaceC class for get_value"< - void _SERIALIZE_(Archive &archive) {} - virtual ~genericInterfaceBaseC() { -#ifdef SHOW_DESTRUCTORS - std::cout<<"In genericInterfaceBaseC destructor"< -class genericInterfaceC : public genericInterfaceBaseC { - public: - ~genericInterfaceC() { -#ifdef SHOW_DESTRUCTORS - std::cout<<"In derived genericInterfaceC destructor"< - class accessor_class : public accessor_base { - public: - typedef P T::*ptrtype; - ptrtype ptr; - accessor_class(ptrtype ptr) : ptr(ptr) {}; - - SEXP get(const genericInterfaceBaseC *intBasePtr) const { -#ifdef SHOW_FIELDS - std::cout<<"in derived get"<(intBasePtr)->*ptr); - } - void set(genericInterfaceBaseC *intBasePtr, SEXP Svalue) { -#ifdef SHOW_FIELDS - std::cout<<"in derived set"<(intBasePtr)->*ptr = Rcpp::as

(Svalue); - // Originally we defined an Rcpp::Exporter specialization as needed, - // which is called via as<>. However, we gain more flexibility in - // argument passing by defining new Rcpp::traits::input_parameter specializations. - // As a result, it is simpler her to create a new P object via this pathway. - reinterpret_cast(intBasePtr)->*ptr = P(typename Rcpp::traits::input_parameter

::type(Svalue)); - } - }; - - // static maps from character names - static int name_count; - typedef std::map name2index_type; - static name2index_type name2index; - - typedef std::map > name2access_type; - typedef std::pair > name_access_pair; - static name2access_type name2access; - - // Enter a new (name, member ptr) pair to static maps. - template - static name_access_pair field(std::string name, P T::*ptr) { -#ifdef SHOW_FIELDS - std::cout<<"adding "<(new accessor_class

(ptr)) - ); - } - - // hello world to see if static maps were populated. - void hw() { - std::cout<<"HW "<second->get(this)); - } - - void set_value(const std::string &name, SEXP Svalue ) { -#ifdef SHOW_FIELDS - std::cout<<"in derived set_value"<second->set(this, Svalue); - } - - /****** METHODS ******/ - SEXP call_method(const std::string &name, SEXP Sargs) { -#ifdef SHOW_METHODS - std::cout<<"in derived call_method"<second->call(this, Sargs)); - } - - template - class method_class : public method_base { - public: - typedef P (T::*ptrtype)(ARGS...); - ptrtype ptr; - method_class(ptrtype ptr) : ptr(ptr) {}; - - SEXP call(genericInterfaceBaseC *intBasePtr, SEXP Sargs) { -#ifdef SHOW_METHODS - std::cout<<"in derived call"<::template call(reinterpret_cast(intBasePtr), ptr, Sargs) - ); - } - }; - - /* Partial specialization on void return type avoids Rcpp::wrap, which doesn't work. */ - /* There might be a slightly more compact way to refactor just the Rcpp::wrap step, but */ - /* this is a quick and simple solution:*/ - template - class method_class : public method_base { - public: - typedef void (T::*ptrtype)(ARGS...); - ptrtype ptr; - method_class(ptrtype ptr) : ptr(ptr) {}; - - SEXP call(genericInterfaceBaseC *intBasePtr, SEXP Sargs) { -#ifdef SHOW_METHODS - std::cout<<"in derived call"<::template call(reinterpret_cast(intBasePtr), ptr, Sargs); - return R_NilValue; - } - }; - - typedef std::map > name2method_type; - typedef std::pair > name_method_pair; - - static name2method_type name2method; - template - static name_method_pair method(std::string name, - P (T::*fun)(ARGS... args)) { -#ifdef SHOW_METHODS - std::cout<<"adding method "<(new method_class(fun)) - ); - } - template - void _SERIALIZE_(Archive &archive) { - archive(cereal::base_class(this)); - } -}; - - -/* // From here down has been turned into macros above. */ -/* // This example uses the input name fooC */ -/* // followed by "field" and "method" entries. */ -/* template<> */ -/* int genericInterfaceC::name_count = 0; */ - -/* template<> */ -/* genericInterfaceC::name2index_type genericInterfaceC::name2index {}; */ - -/* template<> */ -/* genericInterfaceC::name2access_type genericInterfaceC::name2access { */ -/* field("x", &fooC::x), */ -/* field("y", &fooC::y) */ -/* }; */ - - -/* template<> */ -/* genericInterfaceC::name2method_type genericInterfaceC::name2method { */ -/* method("print_val", &fooC::print_val) */ -/* }; */ - -#endif diff --git a/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/generic_class_interface_Rcpp_steps.h b/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/generic_class_interface_Rcpp_steps.h index 8551c24b..ec0983b2 100644 --- a/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/generic_class_interface_Rcpp_steps.h +++ b/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/generic_class_interface_Rcpp_steps.h @@ -3,286 +3,6 @@ #include -// begin ETaccess scheme -// If this works, I'll move it to its own header file. - -// template -// class ETaccessorTyped; - -// // Virtual nDim-general methods (e.g. resize, conversions to and from SEXP). -// class ETaccessorBase { -// public: -// // virtual void resize(Eigen::Tensor &t)=0; -// // To iron out: set, get, generic ref access. -// virtual void set(SEXP Sinput)=0; -// virtual SEXP get()=0; -// virtual SEXP operator=(SEXP RHS) {set(RHS); return RHS;} - -// virtual std::vector &intDims()=0; - -// template -// using ETM = Eigen::TensorMap >; - -// template -// ETaccessorTyped &S() { -// auto castptr = dynamic_cast* >(this); -// if(castptr == nullptr) Rcpp::stop("Problem with some form of access()\n."); -// return *castptr; -// } - -// template -// ETM map(); - -// template -// Eigen::Tensor &ref(); - -// template -// Scalar &scalar(); - -// virtual ~ETaccessorBase(){}; -// }; - -// template -// class ETaccessorTyped : public ETaccessorBase { -// public: - -// virtual Scalar *data()=0; - -// template -// using ETM = Eigen::TensorMap >; - -// Scalar &scalarTyped() { -// const auto intDims_ = this->intDims(); -// for(size_t i = 0; i < intDims_.size(); ++i) { -// if(intDims_[i]!=1) -// Rcpp::stop("Invalid call to scalar() for ETaccessor with dimensions not all equal to 1."); -// } -// return *data(); -// } - -// template -// ETM mapTyped() { -// //innate_nDim is the nDim of the object. -// //output_nDim is the requested nDim of the output map. -// //If the output_nDim > innate_nDim, then set the output dims to innate dims padded with 1s. -// //If the output_nDim < innate_nDim, then drop singleton dimensions in the innate dims. -// //This is very similar to checkAndSetupDims in tensorFlex.h -// //but there both the LHS and RHS nDims are known at compile time. -// //Here only the output_nDim is known at compile time. -// //Also it looks like in checkAndSetupDims, RHS singletons are always dropped -// typedef typename Eigen::internal::traits >::Index Index; -// typedef typename ETM::Dimensions output_Dimensions; -// output_Dimensions outDim; -// const auto intDims_ = this->intDims(); -// size_t innate_nDim = intDims_.size(); -// if(output_nDim >= innate_nDim) { -// for(size_t i = 0; i < innate_nDim; ++i) -// outDim[i] = intDims_[i]; -// if(output_nDim > innate_nDim) { -// for(size_t i = innate_nDim; i < output_nDim; ++i) -// outDim[i] = 1; -// } -// } else { -// size_t i_out = 0; -// for(size_t i_innate = 0 ; i_innate < innate_nDim; ++i_innate) { -// if(intDims_[i_innate] > 1) { -// if(i_out >= output_nDim) { -// Rcpp::stop("Problem making a TensorMap from some form of access(): Too many non-singleton dimensions for the requested map dimensions.\n"); -// break; -// } else { -// outDim[i_out++] = intDims_[i_innate]; -// } -// } -// } -// for( ; i_out < output_nDim; ++i_out ) outDim[i_out]=1; -// } -// return ETM(data(), outDim); -// } -// ~ETaccessorTyped(){}; -// }; - -// template -// Eigen::TensorMap > ETaccessorBase::map() { -// auto castptr = dynamic_cast* >(this); -// if(castptr == nullptr) Rcpp::stop("Problem creating a map() from some form of access().\n"); -// return castptr->template mapTyped(); -// } - -// template -// Scalar& ETaccessorBase::scalar() { -// auto castptr = dynamic_cast* >(this); -// if(castptr == nullptr) Rcpp::stop("Problem using scalar() from some form of access().\n"); -// return castptr->scalarTyped(); -// } - -// // default to throwing an error -// // then specialize to allow valid types (Eigen::Tensor's or true scalars) -// // These are supported as run-time errors because the genericInterfaceC -// // will access them by a name. -// template -// class ETaccessor : public ETaccessorTyped { -// public: -// using ET = Eigen::Tensor; -// // I think to compile this all needs to be valid in terms of types but throw run-time errors everywhere. -// // It should never get past the constructor because that throws an error, but other errors are written -// // for good measure. -// ETaccessor(ERROR &obj_) { Rcpp::stop("Invalid use of some form of access(). You probably tried to access() a non-numeric object.\n"); } -// ~ETaccessor() {}; -// double *data() override { -// Rcpp::stop("Invalid call to data() for invalid ETaccessor."); -// return nullptr; -// } -// std::vector &intDims() override { -// Rcpp::stop("Invalid call to intDims() for invalid ETaccessor."); -// return intDims_; -// } -// void set(SEXP Sinput) override { -// Rcpp::stop("Invalid call to set() for invalid ETaccessor."); -// } -// SEXP get() override { -// Rcpp::stop("Invalid call to get() for invalid ETaccessor."); -// return R_NilValue; -// } -// ET &innerRef() { -// Rcpp::stop("Invalid call to ref() for invalid ETaccessor."); -// return obj; -// } -// double &scalar() { -// Rcpp::stop("Invalid call to scalar() for invalid ETaccessor."); -// return *new double(0.); // would leak memory but will never be reached and may reduce compiler warnings -// } -// ET obj; -// std::vector intDims_; -// }; - - -// template -// class ETaccessor > : public ETaccessorTyped { -// public: -// using ET = Eigen::Tensor; -// // using Scalar = typename ET::Scalar; -// typedef typename Eigen::internal::traits::Index Index; -// // NumIndices should match nDim, so this is a bit redundant. -// static const Index NumIndices = ET::NumIndices; // StridedTensorMap: This is output number of dimensions (indices). -// typedef typename ET::Dimensions Dimensions; -// ETaccessor(ET &obj_) : obj(obj_), intDims_(NumIndices) {}; -// ~ETaccessor() {}; -// Scalar *data() override {return obj.data();} -// std::vector &intDims() override { -// Dimensions dim = obj.dimensions(); -// std::copy(dim.begin(), dim.end(), intDims_.begin()); -// return intDims_; -// } -// void set(SEXP Sinput) override { -// obj = as(Sinput); -// } -// SEXP get() override { -// return wrap(obj); -// } -// ET &innerRef() {return obj;} -// // Scalar &scalar() { -// // Dimensions dim = obj.dimensions(); -// // for(int i = 0; i < nDim; ++i) { -// // if(dim[i]!=1) -// // Rcpp::stop("Invalid call to scalar() for ETaccessor with dimensions not all equal to 1."); -// // } -// // return *obj.data(); // would leak memory but will never be reached and may reduce compiler warnings -// // } -// ET &obj; -// std::vector intDims_; -// }; - -// template -// class ETaccessorScalar : public ETaccessorTyped { -// public: -// ETaccessorScalar(Scalar &obj_) : obj(obj_) {}; -// ~ETaccessorScalar() {}; -// Scalar *data() override {return &obj;} -// std::vector &intDims() override {return intDims_;} -// void set(SEXP Sinput) override { obj = as(Sinput);} -// SEXP get() override {return wrap(obj);} -// Eigen::Tensor &innerRef() { -// Rcpp::stop("Invalid call to ref() for ETaccessor to scalar."); -// return *new Eigen::Tensor(); // bad memory mgmt (would leak) but will never be called. only to show compiler valid return. -// } -// //Scalar &scalar() {return obj;} -// Scalar &obj; -// std::vector intDims_; -// }; - -// template<> -// class ETaccessor : public ETaccessorScalar { -// public: -// ETaccessor(double &obj_) : ETaccessorScalar(obj_) {}; -// ~ETaccessor() {}; -// }; - -// // // CppAD header is not read by here, so this needs attention. -// // template<> -// // class ETaccessor > : public ETaccessorScalar > { -// // public: -// // ETaccessor(CppAD::AD &obj_) : ETaccessorScalar(obj_) {}; -// // ~ETaccessor() {}; -// // }; - -// template<> -// class ETaccessor : public ETaccessorScalar { -// public: -// ETaccessor(int &obj_) : ETaccessorScalar(obj_) {}; -// ~ETaccessor() {}; -// }; - -// template<> -// class ETaccessor : public ETaccessorScalar { -// public: -// ETaccessor(bool &obj_) : ETaccessorScalar(obj_) {}; -// ~ETaccessor() {}; -// }; - -// // template<> -// // class ETaccessor : public ETaccessorTyped { -// // public: -// // using Scalar = double; - -// // ETaccessor(Scalar &obj_) : obj(obj_) {}; -// // ~ETaccessor() {}; -// // Scalar *data() override {return &obj;} -// // std::vector &intDims() override {return intDims_;} -// // void set(SEXP Sinput) override { obj = as(Sinput);} -// // SEXP get() override {return wrap(obj);} -// // Eigen::Tensor &ref() { -// // Rcpp::stop("Invalid call to ref() for ETaccessor to scalar."); -// // return *new Eigen::Tensor(); // bad memory mgmt (would leak) but will never be called. only to show compiler valid return. -// // } -// // Scalar &scalar() {return obj;} -// // Scalar &obj; -// // std::vector intDims_; -// // }; - -// template -// Eigen::Tensor &ETaccessorBase::ref() { -// auto castptr = dynamic_cast >* >(this); -// if(castptr == nullptr) Rcpp::stop("Problem creating a ref() from some form of access().\n"); -// return castptr->innerRef(); -// } - -// // template -// // Scalar &ETaccessorBase::scalar() { -// // auto castptr = dynamic_cast* >(this); -// // if(castptr == nullptr) Rcpp::stop("Problem creating a scalar() from some form of access().\n"); -// // return castptr->scalar(); -// // } - -// // template -// // auto access(Eigen::Tensor &x) -> ETaccessor >{ -// // return ETaccessor >(x); -// // } - -// template -// auto ETaccess(T &x) -> ETaccessor{ -// return ETaccessor(x); -// } - // maybe put these inside the class or namespace. template struct is_shared_ptr : std::false_type {}; @@ -331,7 +51,52 @@ class genericInterfaceC : virtual public genericInterfaceBaseC { // Originally we defined an Rcpp::Exporter specialization as needed, // which is called via as<>. However, we gain more flexibility in // argument passing by defining new Rcpp::traits::input_parameter specializations. - // As a result, it is simpler her to create a new P object via this pathway. + // As a result, it is simpler here to create a new P object via this pathway. + if constexpr(P_is_shared_ptr) { + bool use_set_all_values(true); + if(Rcpp::is(Svalue)) { + // use_set_all_values is definitively true. + } else { + // Unfortunately the checking for either extptr + // or private$CppObj will be done again if we use the Exporter + // when use_set_all_values=false. + // But at the moment there is not a great way to avoid that. + // This checking could possibly be pulled out to a small utility + // used also by the Exporter< shared_ptr > specialization. + if(Rcpp::is(Svalue)) { + Rcpp::Environment Senv(Svalue); + if(Senv.exists("extptr")) { + use_set_all_values = false; // it is a loadedObjectEnv + } else { + Nullable private_env = Senv["private"]; + if(private_env.isNotNull()) { + if(Rcpp::Environment(private_env).exists("CppObj")) { + use_set_all_values = false; // It is an R6 nClass-interface object. + } + } + } + } + } + if(use_set_all_values) { + // Rprintf("trying to use set all values\n"); + auto casted_T = dynamic_cast(intBasePtr); + auto& ptr2 = casted_T->*ptr; + if(ptr2 != nullptr) { + // Rprintf("its not null\n"); + ptr2->set_all_values(Svalue); + } else { + if constexpr(std::is_default_constructible_v) { + casted_T->*ptr = std::make_shared(); + // auto& ptr3 = casted_T->*ptr; + (casted_T->*ptr)->set_all_values(Svalue); + } else { + Rcpp::stop("Trying to set values of an uninitialized compiled nClass (with no default constructor!) from a list or environment."); + } + } + return; + } + } + // Use the regular Exporter pathway for non-shared_ptr types dynamic_cast(intBasePtr)->*ptr = P(typename Rcpp::traits::input_parameter

::type(Svalue)); } std::unique_ptr ETaccess(genericInterfaceBaseC *intBasePtr) { @@ -352,7 +117,7 @@ class genericInterfaceC : virtual public genericInterfaceBaseC { // static maps from character names static int name_count; -// typedef std::map name2index_type; + // typedef std::map name2index_type; static name2index_type name2index; // typedef std::map > name2access_type; @@ -395,6 +160,50 @@ class genericInterfaceC : virtual public genericInterfaceBaseC { return (access->second->get(this)); } + // For a list input, checking names in the list is costly + // so we iterate through the list and check names against name2access. + void set_all_values_impl_list(const Rcpp::List Robj) { + // Cache names once to avoid repeatedly constructing the names vector + Rcpp::Nullable nmsN = Robj.names(); + if(nmsN.isNull()) { + Rcpp::stop("Setting multiple values of an nClass from a list requires that the list have names.\n"); + } + Rcpp::CharacterVector nms(nmsN.get()); + for(int i = 0; i < Robj.length(); ++i) { + // Safely extract the i-th name from the cached names vector + std::string name = Rcpp::as(nms[i]); + name2access_type::iterator access = name2access.find(name); + if(access == name2access.end()) continue; + SEXP Svalue = Robj[i]; + access->second->set(this, Svalue); + } + } + + // For an environment input, checking names is less costly + // so we iterate through name2access and check for each name + // whether it exists in the environment. + void set_all_values_impl_environment(const Rcpp::Environment Robj) { + size_t n = name2access.size(); + auto i_n2a = name2access.begin(); + auto end_n2a = name2access.end(); + for(; i_n2a != end_n2a; ++i_n2a) { + if(Robj.exists(i_n2a->first)) { + SEXP Svalue = Robj.get(i_n2a->first); + i_n2a->second->set(this, Svalue); + } + } + } + + void set_all_values(SEXP Robj) { + if(Rcpp::is(Robj)) { + set_all_values_impl_environment(Robj); + } else if(Rcpp::is(Robj)) { + set_all_values_impl_list(Robj); + } else { + Rcpp::stop("Setting all values of an nClass only works from environment (including nClass or R6) or list objects.\n"); + } + } + void set_value(const std::string &name, SEXP Svalue ) { #ifdef SHOW_FIELDS std::cout<<"in derived set_value"< ptr = i_n2a->second->getInterfacePtr(dynamic_cast(self)); bool got_one = (ptr != nullptr); if(got_one) diff --git a/nCompiler/inst/include/nCompiler/nC_inter/shared_ptr_as_wrap.h_defunct b/nCompiler/inst/include/nCompiler/nC_inter/shared_ptr_as_wrap.h_defunct deleted file mode 100644 index 227fc215..00000000 --- a/nCompiler/inst/include/nCompiler/nC_inter/shared_ptr_as_wrap.h_defunct +++ /dev/null @@ -1,85 +0,0 @@ -#ifndef _AS_WRAP_SHARED_PTR -#define _AS_WRAP_SHARED_PTR - -#include - -#include "shared_ptr_holder.h" -#include "nCompiler_class_factory.h" -// #include "loadedObjectEnv.h" - -// For an input of type T (e.g. shared_ptr< some_nClass_ >), -// Rcpp creates code like this: -// void test_input_(std::shared_ptr obj); -// RcppExport SEXP sourceCpp_1_test_input_(SEXP objSEXP) { -// BEGIN_RCPP -// Rcpp::RNGScope rcpp_rngScope_gen; -// Rcpp::traits::input_parameter< std::shared_ptr >::type obj(objSEXP); -// test_input_(obj); -// return R_NilValue; -// END_RCPP -// } -// -// The Rcpp::traits::input_parameter< std::shared_ptr >::type -// will be Rcpp::InputParameter< std::shared_ptr >, which simply -// holds the input SEXP (objSEXP) and has an explicit conversion to std::shared_ptr -// which will be used for obj in test_input_(obj). -// That explicit conversion is defined by as(SEXP) -// The generic template case of as<> creates an Rcpp::traits::Exporter(SEXP) -// and calls its get() function. -// Hence giving template specialization for std::shared_ptr< T > below means -// that this object is first created and then the get() function is called -// to provide the argument of the desired type (to test_input_ above). -namespace Rcpp { -namespace traits { -template -class Exporter< std::shared_ptr< T > > { -public: - std::shared_ptr sp_; - Exporter(SEXP Sx) { - Rcpp::Environment Sx_env(Sx); // Sx is an environment, so initialize an Rcpp:Environment from it. - SEXP Xptr = PROTECT(Sx_env["extptr"]); // Get the extptr element of it. - bool ok(false); - if(Xptr != R_NilValue) { - ok = true; - } else { - UNPROTECT(1); - Nullable private_env = Sx_env["private"]; - if(private_env.isNotNull()) { - Nullable CppObj = Rcpp::Environment(private_env)["CppObj"]; - if(CppObj.isNotNull()) { - Xptr = PROTECT(Rcpp::Environment(CppObj)["extptr"]); - if(Xptr != R_NilValue) { - ok=true;}}} - } - if(!ok) {stop("An argument that should be an nClass object is not valid.");} - sp_ = reinterpret_cast* >(R_ExternalPtrAddr(Xptr))->sp(); - UNPROTECT(1); - } - inline std::shared_ptr< T > get(){ - return sp_; - } -}; -} -} - -// This is called by code generated by Rcpp -// to return an object of a type such as std::shared_ptr< some_nClass_type > -// Rcpp's code looks like: -// rcpp_result_gen = Rcpp::wrap(test_output_()); -// based on user-written code: -// std::shared_ptr test_output_ ( ) { -// std::shared_ptr obj ( new nc1_ ); -// return(obj); -// } -namespace Rcpp { -template -SEXP wrap( std::shared_ptr< T > obj ) { - SEXP Sans; - Sans = PROTECT(T::setup_R_return_object_full( PROTECT(return_nCompiler_object< T >(obj) ) ) ); - // Sans = PROTECT(loadedObjectEnv(PROTECT(return_nCompiler_object< T >(obj)))); - UNPROTECT(2); - return Sans; -} -} - -#endif diff --git a/nCompiler/inst/include/nCompiler/nC_inter/shared_ptr_holder.h_defunct b/nCompiler/inst/include/nCompiler/nC_inter/shared_ptr_holder.h_defunct deleted file mode 100644 index 0ff2ea8a..00000000 --- a/nCompiler/inst/include/nCompiler/nC_inter/shared_ptr_holder.h_defunct +++ /dev/null @@ -1,59 +0,0 @@ -#ifndef __SHARED_PTR_HOLDER -#define __SHARED_PTR_HOLDER - -#define SHOW_SHARED_PTR_DESTRUCTORS - -#include - -class shared_ptr_holder_base { - public: - virtual void *get_ptr() const { - std::cout<<"Error: you should be in a derived shared_ptr_holder class get_ptr(). This is the base class."< - void _SERIALIZE_(Archive &archive) {} -}; - -template -class shared_ptr_holder: public shared_ptr_holder_base { - public: - std::shared_ptr sp_; - void *get_ptr() const { - return static_cast(sp_.get()); - } - shared_ptr_holder_base* make_shared_ptr_holder() { - std::cout<<"making new shared_ptr_holder_base"< - (new shared_ptr_holder(sp_)); - } - SEXP return_this_nCompiler_object() { - return return_nCompiler_object(sp_); // This gives a compiler warning because return_nCompiler_object is not yet defined. to-do: check on ordering of #includes etc. - } - std::shared_ptr &sp() {return sp_;} - shared_ptr_holder() {} // needed for cereal - shared_ptr_holder(T *obj) : sp_(obj) {} - shared_ptr_holder(std::shared_ptr &sp_other) {sp_= sp_other;} - ~shared_ptr_holder() { -#ifdef SHOW_SHARED_PTR_DESTRUCTORS -// std::cout<<"Destroying shared_ptr_holder."; - if(sp_.unique()) { - std::cout<<" This should destroy the underlying nCompiler object."< - void _SERIALIZE_(Archive &archive) { - archive(cereal::base_class(this), sp_); - } -}; - -#endif diff --git a/nCompiler/tests/testthat/nClass_tests/test-nClass_set_all_values.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_set_all_values.R new file mode 100644 index 00000000..0dbd3dff --- /dev/null +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_set_all_values.R @@ -0,0 +1,252 @@ +# Tests of assigning multiple fields of an nClass from a list or environment + +# library(nCompiler) +# library(testthat) + +test_that("assigning multiple fields of an nClass from a list works", { + + # A class that LACKS a default constructor and so will + # lead to trapped error below + nc0 <- nClass( + classname = "nc0", + Cpublic = list( + w = 'numericVector', + nc0 = nFunction( + function(x = 'numericVector') { + }, + compileInfo = list(constructor=TRUE) + ) + ), + compileInfo=list(omit_automatic_Cpp_construction=TRUE, + createFromR = FALSE) + ) + + nc1 <- nClass( + Cpublic = list( + x = 'numericVector', + y = 'logicalVector' + ) + ) + + nc2 = nClass( + classname = "nc2", + Cpublic = list( + my_nc1 = 'nc1', + my_null_nc1 = 'nc1', + my_nc0 = 'nc0', # chance to check catching error below + z = 'numericScalar', + nc2 = nFunction( + function() { + my_nc1 = nc1$new() + }, + compileInfo = list(constructor=TRUE) + ) + ) + ) + + comp <- nCompile(nc0, nc1, nc2, interfaces = "generic") #list(nc1 ="generic", nc2 = "generic")) + + obj1a <- comp$nc1() + value(obj1a, "x") <- 1:3 + expect_equal(value(obj1a, "x"), 1:3) + expect_equal(value(obj1a, "y"), logical()) + value(obj1a) <- list(x = 2:4, y = TRUE) + expect_equal(value(obj1a, "x"), 2:4) + expect_equal(value(obj1a, "y"), TRUE) + value(obj1a) <- list(x = 4:6) + expect_equal(value(obj1a, "x"), 4:6) + expect_equal(value(obj1a, "y"), TRUE) + value(obj1a) <- list(y = c(1, 0, 1)) + expect_equal(value(obj1a, "x"), 4:6) + expect_equal(value(obj1a, "y"), as.logical(c(1,0,1))) + value(obj1a) <- list(not_there = 100) + expect_equal(value(obj1a, "x"), 4:6) + expect_equal(value(obj1a, "y"), as.logical(c(1,0,1))) + + value(obj1a) <- as.environment(list(x = 7:9, y = c(0, 1))) + expect_equal(value(obj1a, "x"), 7:9) + expect_equal(value(obj1a, "y"), as.logical(c(0,1))) + value(obj1a) <- as.environment(list(y = FALSE)) + expect_equal(value(obj1a, "x"), 7:9) + expect_equal(value(obj1a, "y"), FALSE) + value(obj1a) <- as.environment(list(not_there = 100)) + expect_equal(value(obj1a, "x"), 7:9) + expect_equal(value(obj1a, "y"), FALSE) + + obj2a <- comp$nc2() + expect_identical(value(obj2a, "my_nc1") |> value("x"), numeric()) + value(obj2a) <- list(z = 42, my_nc1 = obj1a) + expect_equal(value(obj2a, "z"), 42) + expect_equal(value(obj2a, "my_nc1") |> value("x"), 7:9) + expect_equal(value(obj2a, "my_nc1") |> value("y"), FALSE) + + value( value(obj2a, "my_nc1"), "x") <- 101:103 + expect_equal(value(obj1a, "x"), 101:103) + + value( value(obj2a, "my_nc1") ) <- list(x = 104:106, y = c(1,1,1)) + expect_equal(value(obj1a, "x"), 104:106) + expect_equal(value(obj1a, "y"), as.logical(c(1,1,1))) + + value(obj2a, "my_nc1") <- list(x = 201:203, y = c(0,0,0)) + expect_equal(value(obj1a, "x"), 201:203) + expect_equal(value(obj1a, "y"), as.logical(c(0,0,0))) + obj1b <- value(obj2a, "my_nc1") + expect_equal(value(obj1b, "x"), 201:203) + expect_equal(value(obj1b, "y"), c(F, F, F)) + + value(obj2a, "my_nc1") <- as.environment(list(x = 301:303)) + expect_equal(value(obj1b, "x"), 301:303) + expect_equal(value(obj1b, "y"), c(F, F, F)) + obj1c <- value(obj2a, "my_nc1") + expect_equal(value(obj1c, "x"), 301:303) + expect_equal(value(obj1c, "y"), c(F,F,F)) + + value(obj2a, "my_null_nc1") <- list(x = 1:3, y = TRUE) # makes new object + expect_equal(value(obj2a, "my_null_nc1") |> value("x"), 1:3) + value(obj2a, "my_null_nc1") <- as.environment(list(x = 4:6, y = TRUE)) + expect_equal(value(obj2a, "my_null_nc1") |> value("x"), 4:6) + expect_equal(value(obj2a, "my_null_nc1") |> value("y"), TRUE) + + expect_error(value(obj2a, "my_nc0") <- list(w = 1:3)) + rm(obj1a, obj1b, obj2a); gc() +}) + + +test_that("assigning multiple fields of an nClass from a list works", { + + nc0 <- nClass( + classname = "nc0", + Cpublic = list( + w = 'numericVector', + nc0 = nFunction( + function(x = 'numericVector') { + }, + compileInfo = list(constructor=TRUE) + ) + ), + compileInfo=list(omit_automatic_Cpp_construction=TRUE, + createFromR = FALSE) + ) + + nc1 <- nClass( + Cpublic = list( + x = 'numericVector', + y = 'logicalVector' + ) + ) + + nc2 = nClass( + classname = "nc2", + Cpublic = list( + my_nc1 = 'nc1', + my_null_nc1 = 'nc1', + my_nc0 = 'nc0', # chance to check catching error below + z = 'numericScalar', + nc2 = nFunction( + function() { + my_nc1 = nc1$new() + }, + compileInfo = list(constructor=TRUE) + ) + ) + ) + + comp <- nCompile(nc0, nc1, nc2, interfaces = "full") + + # Use the tests above because generic interface + # should also work with full interface objects + obj1a <- comp$nc1$new() + value(obj1a, "x") <- 1:3 + expect_equal(value(obj1a, "x"), 1:3) + expect_equal(value(obj1a, "y"), logical()) + value(obj1a) <- list(x = 2:4, y = TRUE) + expect_equal(value(obj1a, "x"), 2:4) + expect_equal(value(obj1a, "y"), TRUE) + value(obj1a) <- list(x = 4:6) + expect_equal(value(obj1a, "x"), 4:6) + expect_equal(value(obj1a, "y"), TRUE) + value(obj1a) <- list(y = c(1, 0, 1)) + expect_equal(value(obj1a, "x"), 4:6) + expect_equal(value(obj1a, "y"), as.logical(c(1,0,1))) + value(obj1a) <- list(not_there = 100) + expect_equal(value(obj1a, "x"), 4:6) + expect_equal(value(obj1a, "y"), as.logical(c(1,0,1))) + + value(obj1a) <- as.environment(list(x = 7:9, y = c(0, 1))) + expect_equal(value(obj1a, "x"), 7:9) + expect_equal(value(obj1a, "y"), as.logical(c(0,1))) + value(obj1a) <- as.environment(list(y = FALSE)) + expect_equal(value(obj1a, "x"), 7:9) + expect_equal(value(obj1a, "y"), FALSE) + value(obj1a) <- as.environment(list(not_there = 100)) + expect_equal(value(obj1a, "x"), 7:9) + expect_equal(value(obj1a, "y"), FALSE) + + obj2a <- comp$nc2$new() + expect_identical(value(obj2a, "my_nc1") |> value("x"), numeric()) + value(obj2a) <- list(z = 42, my_nc1 = obj1a) + expect_equal(value(obj2a, "z"), 42) + expect_equal(value(obj2a, "my_nc1") |> value("x"), 7:9) + expect_equal(value(obj2a, "my_nc1") |> value("y"), FALSE) + + value( value(obj2a, "my_nc1"), "x") <- 101:103 + expect_equal(value(obj1a, "x"), 101:103) + + value( value(obj2a, "my_nc1") ) <- list(x = 104:106, y = c(1,1,1)) + expect_equal(value(obj1a, "x"), 104:106) + expect_equal(value(obj1a, "y"), as.logical(c(1,1,1))) + + value(obj2a, "my_nc1") <- list(x = 201:203, y = c(0,0,0)) + expect_equal(value(obj1a, "x"), 201:203) + expect_equal(value(obj1a, "y"), as.logical(c(0,0,0))) + obj1b <- value(obj2a, "my_nc1") + expect_equal(value(obj1b, "x"), 201:203) + expect_equal(value(obj1b, "y"), c(F, F, F)) + + value(obj2a, "my_nc1") <- as.environment(list(x = 301:303)) + expect_equal(value(obj1b, "x"), 301:303) + expect_equal(value(obj1b, "y"), c(F, F, F)) + obj1c <- value(obj2a, "my_nc1") + expect_equal(value(obj1c, "x"), 301:303) + expect_equal(value(obj1c, "y"), c(F,F,F)) + + value(obj2a, "my_null_nc1") <- list(x = 1:3, y = TRUE) # makes new object + expect_equal(value(obj2a, "my_null_nc1") |> value("x"), 1:3) + value(obj2a, "my_null_nc1") <- as.environment(list(x = 4:6, y = TRUE)) + expect_equal(value(obj2a, "my_null_nc1") |> value("x"), 4:6) + expect_equal(value(obj2a, "my_null_nc1") |> value("y"), TRUE) + + expect_error(value(obj2a, "my_nc0") <- list(w = 1:3)) + rm(obj1a, obj1b, obj2a); gc() + + ### + ## Add some tests using the actual full interface + + obj2a <- comp$nc2$new() + expect_equal(obj2a$my_nc1$x, numeric()) + obj2a$my_nc1$x <- 101:103 + expect_equal(obj2a$my_nc1$x, 101:103) + obj2a$my_nc1 <- list(x = 104:106, y = c(1,1,1)) + expect_equal(obj2a$my_nc1$x, 104:106) + obj1a <- obj2a$my_nc1 + expect_equal(obj1a$x, 104:106) + expect_equal(obj1a$y, as.logical(c(1,1,1))) + + obj2a$my_nc1 <- as.environment(list(x = 201:203, y = c(0,0,0))) + expect_equal(obj1a$x, 201:203) + expect_equal(obj1a$y, as.logical(c(0,0,0))) + + obj2a$my_null_nc1 <- list(x = 1:3, y = TRUE) + expect_equal(obj2a$my_null_nc1$x, 1:3) + expect_equal(obj2a$my_null_nc1$y, TRUE) + obj2a$my_null_nc1 <- as.environment(list(x = 4:6, y = FALSE)) + expect_equal(obj2a$my_null_nc1$x, 4:6) + expect_equal(obj2a$my_null_nc1$y, FALSE) + + # Could add more but stopping. I'm not sure there's a purpose + # in further exercising the full interface. At this point I have + # ended up testing that the generic interface for a full object + # does the same thing internally and there is no further point + # to pursue here. + rm(obj2a, obj1a); gc() +})