From a3bf11522abf9c3f9ac524e53aa80bb16b93defd Mon Sep 17 00:00:00 2001 From: perrydv Date: Wed, 17 Dec 2025 09:18:54 +0100 Subject: [PATCH 1/2] Provide copying into compiled nClass by generic list or env --- nCompiler/R/NC_SimpleInterface.R | 2 +- nCompiler/R/cppDefs_R_interface_calls.R | 8 +- .../nC_inter/generic_class_interface.h | 222 +--------- .../nC_inter/nCompiler_class_interface_old.h | 288 ------------- .../generic_class_interface_Rcpp_steps.h | 378 +++++------------- .../post_Rcpp/nCompiler_model_base_devel.h | 1 - .../nC_inter/shared_ptr_as_wrap.h_defunct | 85 ---- .../nC_inter/shared_ptr_holder.h_defunct | 59 --- .../nClass_tests/test-nClass_set_all_values.R | 240 +++++++++++ 9 files changed, 352 insertions(+), 931 deletions(-) delete mode 100644 nCompiler/inst/include/nCompiler/nC_inter/nCompiler_class_interface_old.h delete mode 100644 nCompiler/inst/include/nCompiler/nC_inter/shared_ptr_as_wrap.h_defunct delete mode 100644 nCompiler/inst/include/nCompiler/nC_inter/shared_ptr_holder.h_defunct create mode 100644 nCompiler/tests/testthat/nClass_tests/test-nClass_set_all_values.R 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..df055283 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,55 @@ class genericInterfaceC : virtual public genericInterfaceBaseC { return (access->second->get(this)); } + template + void set_all_values_impl(const Rtype Robj); + + // For a list input, checking names in the list is costly + // so we iterate through the list and check names against name2access. + template<> + void set_all_values_impl(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. + template<> + void set_all_values_impl(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(Robj); + } else if(Rcpp::is(Robj)) { + set_all_values_impl(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..c302f75c --- /dev/null +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_set_all_values.R @@ -0,0 +1,240 @@ +# 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 + value(obj1a, "x") + value(obj1a) <- list(x = 1:3, y = TRUE) + value(obj1a, "x") + value(obj1a, "y") + value(obj1a) <- list(x = 4:6) + value(obj1a, "x") + value(obj1a, "y") + value(obj1a) <- list(y = c(1, 0, 1)) + value(obj1a, "x") + value(obj1a, "y") + value(obj1a) <- list(not_there = 100) + value(obj1a, "x") + value(obj1a, "y") + + + value(obj1a) <- as.environment(list(x = 7:9, y = c(0, 1))) + value(obj1a, "x") + value(obj1a, "y") + value(obj1a) <- as.environment(list(y = FALSE)) + value(obj1a, "x") + value(obj1a, "y") + value(obj1a) <- as.environment(list(not_there = 100)) + value(obj1a, "x") + value(obj1a, "y") + + obj2a <- comp$nc2() + value(obj2a, "my_nc1") |> value("x") + value(obj2a) <- list(z = 42, my_nc1 = obj1a) + value(obj2a, "z") + value(obj2a, "my_nc1") |> value("x") + value(obj2a, "my_nc1") |> value("y") + + value( value(obj2a, "my_nc1"), "x") <- 101:103 + value(obj1a, "x") + + value( value(obj2a, "my_nc1") ) <- list(x = 104:106, y = c(1,1,1)) + value(obj1a, "x") + value(obj1a, "y") + + value(obj2a, "my_nc1") <- list(x = 201:203, y = c(0,0,0)) # makes new object + expect_equal(value(obj1a, "x"), 104:106) # old values, because obj2a$my_nc1 is new + expect_equal(value(obj1a, "y"), c(T, T, T)) + obj1b <- value(obj2a, "my_nc1") # new object + expect_equal(value(obj1b, "x"), 201:203) # new values + expect_equal(value(obj1b, "y"), c(F, F, F)) + + value(obj2a, "my_nc1") <- as.environment(list(x = 301:303)) # makes new object + expect_equal(value(obj1b, "x"), 201:203) + 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"), logical()) + + value(obj2a, "my_null_nc1") <- list(x = 1:3, y = TRUE) + value(obj2a, "my_null_nc1") |> value("x") + value(obj2a, "my_null_nc1") <- as.environment(list(x = 4:6, y = TRUE)) + value(obj2a, "my_null_nc1") |> value("x") + + expect_error(value(obj2a, "my_nc0") <- list(w = 1:3)) +}) + + +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") + + obj1a <- comp$nc1$new() + value(obj1a, "x") <- 1:3 + value(obj1a, "x") + value(obj1a) <- list(x = 1:3, y = TRUE) + value(obj1a, "x") + value(obj1a, "y") + value(obj1a) <- list(x = 4:6) + value(obj1a, "x") + value(obj1a, "y") + value(obj1a) <- list(y = c(1, 0, 1)) + value(obj1a, "x") + value(obj1a, "y") + value(obj1a) <- list(not_there = 100) + value(obj1a, "x") + value(obj1a, "y") + + + value(obj1a) <- as.environment(list(x = 7:9, y = c(0, 1))) + value(obj1a, "x") + value(obj1a, "y") + value(obj1a) <- as.environment(list(y = FALSE)) + value(obj1a, "x") + value(obj1a, "y") + value(obj1a) <- as.environment(list(not_there = 100)) + value(obj1a, "x") + value(obj1a, "y") + + obj2a <- comp$nc2$new() + value(obj2a, "my_nc1") |> value("x") + value(obj2a) <- list(z = 42, my_nc1 = obj1a) + value(obj2a, "z") + value(obj2a, "my_nc1") |> value("x") + value(obj2a, "my_nc1") |> value("y") + + value( value(obj2a, "my_nc1"), "x") <- 101:103 + value(obj1a, "x") + + value( value(obj2a, "my_nc1") ) <- list(x = 104:106, y = c(1,1,1)) + value(obj1a, "x") + value(obj1a, "y") + + value(obj2a, "my_nc1") <- list(x = 201:203, y = c(0,0,0)) # makes new object + expect_equal(value(obj1a, "x"), 104:106) # old values, because obj2a$my_nc1 is new + expect_equal(value(obj1a, "y"), c(T, T, T)) + obj1b <- value(obj2a, "my_nc1") # new object + expect_equal(value(obj1b, "x"), 201:203) # new values + expect_equal(value(obj1b, "y"), c(F, F, F)) + + value(obj2a, "my_nc1") <- as.environment(list(x = 301:303)) # makes new object + expect_equal(value(obj1b, "x"), 201:203) + 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"), logical()) + + value(obj2a, "my_null_nc1") <- list(x = 1:3, y = TRUE) + value(obj2a, "my_null_nc1") |> value("x") + value(obj2a, "my_null_nc1") <- as.environment(list(x = 4:6, y = TRUE)) + value(obj2a, "my_null_nc1") |> value("x") + + expect_error(value(obj2a, "my_nc0") <- list(w = 1:3)) + + ##### + + obj2a <- comp$nc2$new() + obj2a$my_nc1$x + obj2a$my_nc1$x <- 101:103 + obj2a$my_nc1$x + obj2a$my_nc1 <- list(x = 104:106, y = c(1,1,1)) + obj2a$my_nc1$x + obj1a <- obj2a$my_nc1 + obj1a$x + obj1a$y + + obj2a$my_nc1 <- as.environment(list(x = 201:203, y = c(0,0,0))) + obj1a$x + obj1a$y + + obj2a$my_null_nc1 <- list(x = 1:3, y = TRUE) + obj2a$my_null_nc1$x + obj2a$my_null_nc1$y + obj2a$my_null_nc1 <- as.environment(list(x = 4:6, y = FALSE)) + obj2a$my_null_nc1$x + obj2a$my_null_nc1$y + + obj2a$my_nc0 <- list(w = 1:3) +}) From 58ba258f3852a5e3ae3fe8a69f34b12d153788bb Mon Sep 17 00:00:00 2001 From: perrydv Date: Wed, 17 Dec 2025 10:32:07 +0100 Subject: [PATCH 2/2] avoid use of template specializations within class definition. fix set_all_values tests. --- .../generic_class_interface_Rcpp_steps.h | 13 +- .../nClass_tests/test-nClass_set_all_values.R | 188 ++++++++++-------- 2 files changed, 104 insertions(+), 97 deletions(-) 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 df055283..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 @@ -160,13 +160,9 @@ class genericInterfaceC : virtual public genericInterfaceBaseC { return (access->second->get(this)); } - template - void set_all_values_impl(const Rtype Robj); - // For a list input, checking names in the list is costly // so we iterate through the list and check names against name2access. - template<> - void set_all_values_impl(const Rcpp::List Robj) { + 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()) { @@ -186,8 +182,7 @@ class genericInterfaceC : virtual public genericInterfaceBaseC { // 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. - template<> - void set_all_values_impl(const Rcpp::Environment Robj) { + 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(); @@ -201,9 +196,9 @@ class genericInterfaceC : virtual public genericInterfaceBaseC { void set_all_values(SEXP Robj) { if(Rcpp::is(Robj)) { - set_all_values_impl(Robj); + set_all_values_impl_environment(Robj); } else if(Rcpp::is(Robj)) { - set_all_values_impl(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"); } 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 index c302f75c..0dbd3dff 100644 --- a/nCompiler/tests/testthat/nClass_tests/test-nClass_set_all_values.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_set_all_values.R @@ -1,7 +1,7 @@ # Tests of assigning multiple fields of an nClass from a list or environment -library(nCompiler) -library(testthat) +# library(nCompiler) +# library(testthat) test_that("assigning multiple fields of an nClass from a list works", { @@ -48,65 +48,67 @@ test_that("assigning multiple fields of an nClass from a list works", { obj1a <- comp$nc1() value(obj1a, "x") <- 1:3 - value(obj1a, "x") - value(obj1a) <- list(x = 1:3, y = TRUE) - value(obj1a, "x") - value(obj1a, "y") + 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) - value(obj1a, "x") - value(obj1a, "y") + expect_equal(value(obj1a, "x"), 4:6) + expect_equal(value(obj1a, "y"), TRUE) value(obj1a) <- list(y = c(1, 0, 1)) - value(obj1a, "x") - value(obj1a, "y") + expect_equal(value(obj1a, "x"), 4:6) + expect_equal(value(obj1a, "y"), as.logical(c(1,0,1))) value(obj1a) <- list(not_there = 100) - value(obj1a, "x") - value(obj1a, "y") - + 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))) - value(obj1a, "x") - value(obj1a, "y") + expect_equal(value(obj1a, "x"), 7:9) + expect_equal(value(obj1a, "y"), as.logical(c(0,1))) value(obj1a) <- as.environment(list(y = FALSE)) - value(obj1a, "x") - value(obj1a, "y") + expect_equal(value(obj1a, "x"), 7:9) + expect_equal(value(obj1a, "y"), FALSE) value(obj1a) <- as.environment(list(not_there = 100)) - value(obj1a, "x") - value(obj1a, "y") + expect_equal(value(obj1a, "x"), 7:9) + expect_equal(value(obj1a, "y"), FALSE) obj2a <- comp$nc2() - value(obj2a, "my_nc1") |> value("x") + expect_identical(value(obj2a, "my_nc1") |> value("x"), numeric()) value(obj2a) <- list(z = 42, my_nc1 = obj1a) - value(obj2a, "z") - value(obj2a, "my_nc1") |> value("x") - value(obj2a, "my_nc1") |> value("y") + 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 - value(obj1a, "x") + expect_equal(value(obj1a, "x"), 101:103) value( value(obj2a, "my_nc1") ) <- list(x = 104:106, y = c(1,1,1)) - value(obj1a, "x") - value(obj1a, "y") - - value(obj2a, "my_nc1") <- list(x = 201:203, y = c(0,0,0)) # makes new object - expect_equal(value(obj1a, "x"), 104:106) # old values, because obj2a$my_nc1 is new - expect_equal(value(obj1a, "y"), c(T, T, T)) - obj1b <- value(obj2a, "my_nc1") # new object - expect_equal(value(obj1b, "x"), 201:203) # new values - expect_equal(value(obj1b, "y"), c(F, F, F)) + expect_equal(value(obj1a, "x"), 104:106) + expect_equal(value(obj1a, "y"), as.logical(c(1,1,1))) - value(obj2a, "my_nc1") <- as.environment(list(x = 301:303)) # makes new object + 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"), logical()) + expect_equal(value(obj1c, "y"), c(F,F,F)) - value(obj2a, "my_null_nc1") <- list(x = 1:3, y = TRUE) - value(obj2a, "my_null_nc1") |> value("x") + 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)) - value(obj2a, "my_null_nc1") |> value("x") + 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() }) @@ -151,90 +153,100 @@ test_that("assigning multiple fields of an nClass from a list works", { 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 - value(obj1a, "x") - value(obj1a) <- list(x = 1:3, y = TRUE) - value(obj1a, "x") - value(obj1a, "y") + 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) - value(obj1a, "x") - value(obj1a, "y") + expect_equal(value(obj1a, "x"), 4:6) + expect_equal(value(obj1a, "y"), TRUE) value(obj1a) <- list(y = c(1, 0, 1)) - value(obj1a, "x") - value(obj1a, "y") + expect_equal(value(obj1a, "x"), 4:6) + expect_equal(value(obj1a, "y"), as.logical(c(1,0,1))) value(obj1a) <- list(not_there = 100) - value(obj1a, "x") - value(obj1a, "y") - + 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))) - value(obj1a, "x") - value(obj1a, "y") + expect_equal(value(obj1a, "x"), 7:9) + expect_equal(value(obj1a, "y"), as.logical(c(0,1))) value(obj1a) <- as.environment(list(y = FALSE)) - value(obj1a, "x") - value(obj1a, "y") + expect_equal(value(obj1a, "x"), 7:9) + expect_equal(value(obj1a, "y"), FALSE) value(obj1a) <- as.environment(list(not_there = 100)) - value(obj1a, "x") - value(obj1a, "y") + expect_equal(value(obj1a, "x"), 7:9) + expect_equal(value(obj1a, "y"), FALSE) obj2a <- comp$nc2$new() - value(obj2a, "my_nc1") |> value("x") + expect_identical(value(obj2a, "my_nc1") |> value("x"), numeric()) value(obj2a) <- list(z = 42, my_nc1 = obj1a) - value(obj2a, "z") - value(obj2a, "my_nc1") |> value("x") - value(obj2a, "my_nc1") |> value("y") + 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 - value(obj1a, "x") + expect_equal(value(obj1a, "x"), 101:103) value( value(obj2a, "my_nc1") ) <- list(x = 104:106, y = c(1,1,1)) - value(obj1a, "x") - value(obj1a, "y") - - value(obj2a, "my_nc1") <- list(x = 201:203, y = c(0,0,0)) # makes new object - expect_equal(value(obj1a, "x"), 104:106) # old values, because obj2a$my_nc1 is new - expect_equal(value(obj1a, "y"), c(T, T, T)) - obj1b <- value(obj2a, "my_nc1") # new object - expect_equal(value(obj1b, "x"), 201:203) # new values - expect_equal(value(obj1b, "y"), c(F, F, F)) + expect_equal(value(obj1a, "x"), 104:106) + expect_equal(value(obj1a, "y"), as.logical(c(1,1,1))) - value(obj2a, "my_nc1") <- as.environment(list(x = 301:303)) # makes new object + 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"), logical()) + expect_equal(value(obj1c, "y"), c(F,F,F)) - value(obj2a, "my_null_nc1") <- list(x = 1:3, y = TRUE) - value(obj2a, "my_null_nc1") |> value("x") + 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)) - value(obj2a, "my_null_nc1") |> value("x") + 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() - obj2a$my_nc1$x + expect_equal(obj2a$my_nc1$x, numeric()) obj2a$my_nc1$x <- 101:103 - obj2a$my_nc1$x + expect_equal(obj2a$my_nc1$x, 101:103) obj2a$my_nc1 <- list(x = 104:106, y = c(1,1,1)) - obj2a$my_nc1$x + expect_equal(obj2a$my_nc1$x, 104:106) obj1a <- obj2a$my_nc1 - obj1a$x - obj1a$y + 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))) - obj1a$x - obj1a$y + 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) - obj2a$my_null_nc1$x - obj2a$my_null_nc1$y + 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)) - obj2a$my_null_nc1$x - obj2a$my_null_nc1$y - - obj2a$my_nc0 <- list(w = 1:3) + 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() })