From ef50c83ee782873787137b2e5ae39dea51ddb00e Mon Sep 17 00:00:00 2001 From: perrydv Date: Sun, 31 May 2026 14:12:44 -0700 Subject: [PATCH] minor changes supporting or noticed due to work on nimbleModel --- nCompiler/R/NC.R | 18 +++ nCompiler/R/NC_LoadedObjectEnv.R | 4 +- nCompiler/R/compile_generateCpp.R | 2 +- nCompiler/R/nCppVec.R | 23 +++- .../post_Rcpp/SEXP_2_EigenTensor.h | 7 +- .../generic_class_interface_Rcpp_steps.h | 1 + .../include/nCompiler/predef/nList_/nList_.h | 88 +++++++++++++++ .../nClass_tests/test-nClass_constructor.R | 105 ++++++++++++++++++ .../testthat/specificOp_tests/test-nList.R | 68 +++++++++++- 9 files changed, 305 insertions(+), 11 deletions(-) diff --git a/nCompiler/R/NC.R b/nCompiler/R/NC.R index 04d286e6..0d4425c9 100644 --- a/nCompiler/R/NC.R +++ b/nCompiler/R/NC.R @@ -180,6 +180,24 @@ nClass <- function(classname, stop("In nFunction 'initialize', use 'compileInfo = list(constructor=TRUE)'.") } + if('initialize' %in% names(Rpublic) && is.function(Rpublic[['initialize']])) { + init_body_text <- deparse(body(Rpublic[['initialize']])) + has_super_init <- any(grepl("super\\$initialize", init_body_text)) + has_init_cpublic <- any(grepl("initialize_Cpublic", init_body_text)) + if(!has_super_init && !has_init_cpublic) + warning( + "The Rpublic 'initialize' function does not call 'super$initialize()' or ", + "'initialize_Cpublic()'. Without one of these, the Cpublic component will not ", + "be properly set up, and compiled nClass objects returned from nFunctions will ", + "not be connected to their C++ data. ", + "Add '...' to the 'initialize' signature and call 'super$initialize(...)' ", + "(recommended) so that the `CppObj` argument is forwarded when returning an nClass ", + "from a compiled nFunction. Alternatively use 'initialize_Cpublic()' followed by ", + "'if(isCompiled()) initializeCpp()' for manual control.", + call. = FALSE + ) + } + inheritQ <- substitute(inherit) inherit_provided <- !is.null(inheritQ) diff --git a/nCompiler/R/NC_LoadedObjectEnv.R b/nCompiler/R/NC_LoadedObjectEnv.R index cdad8a07..91eb51cb 100644 --- a/nCompiler/R/NC_LoadedObjectEnv.R +++ b/nCompiler/R/NC_LoadedObjectEnv.R @@ -31,7 +31,7 @@ to_full_interface <- function(LOE) { stop("LOE should be a loadedObjectEnv") CnCenv <- get_CnCenv(LOE) if(exists('.R6interface', CnCenv)) { - fullAns <- CnCenv$.R6interface$new(LOE) + fullAns <- CnCenv$.R6interface$new(CppObj = LOE) return(fullAns) } LOE # default to non-full @@ -51,7 +51,7 @@ new.loadedObjectEnv_full <- function(extptr = NULL, parentEnv = NULL) { if(!is.null(parentEnv)) { # This doesn't really do anything if(exists('.R6interface', parentEnv) && parentEnv$return_mode == "full") { - fullAns <- parentEnv$.R6interface$new(ans) + fullAns <- parentEnv$.R6interface$new(CppObj = ans) return(fullAns) } } diff --git a/nCompiler/R/compile_generateCpp.R b/nCompiler/R/compile_generateCpp.R index e8932ba9..0340b64d 100644 --- a/nCompiler/R/compile_generateCpp.R +++ b/nCompiler/R/compile_generateCpp.R @@ -174,7 +174,7 @@ inGenCppEnv( inGenCppEnv( Assign <- function(code, symTab) { orig_name <- code$name - code$name <- ' = ' + code$name <- '=' res <- MidOperator(code, symTab) code$name <- orig_name res diff --git a/nCompiler/R/nCppVec.R b/nCompiler/R/nCppVec.R index 4cffd8cc..1a1753cd 100644 --- a/nCompiler/R/nCppVec.R +++ b/nCompiler/R/nCppVec.R @@ -259,12 +259,33 @@ nList_nClass <- function(type, env = parent.frame()) { C_fun = function(i = 'SEXP', value = {{RtypeObj}}) { cppLiteral('return doubleBracket_set_(i, value)') } + )), + set_all_values = nFunction( + name = "set_all_values", + # R-level (uncompiled): handle plain list, uncompiled nList, or compiled + # nList (all via duck-typing on as_list). + function(Robj = 'SEXP') { + if(is.list(Robj)) { + Rcontents <<- Robj + } else if(is.environment(Robj) && + exists("as_list", envir = Robj, inherits = FALSE)) { + Rcontents <<- Robj$as_list() + } else { + stop("Uncompiled nList set_all_values requires a list or an nList object.") + } + }, + compileInfo = list( + # Delegates to set_all_values_() in nList_, which handles all + # four input types without needing explicit namespace qualification. + C_fun = function(Robj = 'SEXP') { + cppLiteral('set_all_values_(Robj);') + } )) ) ans <- substitute( nClass( classname = CLASSNAME, - inherit = nListBase_nClass, + inherit = nCompiler::nListBase_nClass, Cpublic = c( list( x = TYPE), diff --git a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/SEXP_2_EigenTensor.h b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/SEXP_2_EigenTensor.h index 144bd417..aa897048 100644 --- a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/SEXP_2_EigenTensor.h +++ b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/SEXP_2_EigenTensor.h @@ -30,6 +30,11 @@ struct SEXP_2_EigenTensor { static EigenTensorType copy(SEXP &Sinput, const IndexArray &indexArray) { EigenTensorType xCopy; + if(Sinput==R_NilValue) { + // Return an empty tensor with the correct shape and scalar type. + std::cout<<" [Warning]: NULL was provided where a numeric, integer or logical object was expected.\n"<::type i_match_type; typedef typename std::is_same::type d_match_type; switch( TYPEOF(Sinput) ) { @@ -59,7 +64,7 @@ struct SEXP_2_EigenTensor { ); break; default: - std::cout<<"Bad type\n"< nmsN = Robj.names(); if(nmsN.isNull()) { Rcpp::stop("Setting multiple values of an nClass from a list requires that the list have names.\n"); diff --git a/nCompiler/inst/include/nCompiler/predef/nList_/nList_.h b/nCompiler/inst/include/nCompiler/predef/nList_/nList_.h index e9600cff..50ca4346 100644 --- a/nCompiler/inst/include/nCompiler/predef/nList_/nList_.h +++ b/nCompiler/inst/include/nCompiler/predef/nList_/nList_.h @@ -331,6 +331,94 @@ class nList_ : public nListBase_nClass { // return res; // } + // CRTP-level implementation called by the generated nList class's + // set_all_values Cpublic method (which is the actual virtual override). + // Handles all ways an R object may represent a positionally-indexed nList: + // 1. plain R list — compiled or uncompiled elements; handled by set_from_list + // 2. compiled nList (LOE/R6 environment with extptr) — copy contents_ directly + // 3. uncompiled nList (R6 environment without extptr) — call as_list() then set_from_list + void set_all_values_(SEXP Robj) { + // Case 1: plain R list — compiled or uncompiled elements positionally + if(Rcpp::is(Robj)) { + set_from_list(Rcpp::as(Robj)); + return; + } + if(Rcpp::is(Robj)) { + // Case 2: compiled nList — LOE environment containing an extptr + Rcpp::RObject Rextptr = get_extptr_from_SEXP(Robj); + SEXP Sextptr = Rextptr; + if(Sextptr != R_NilValue) { + genericInterfaceBaseC* src_base = + static_cast( + static_cast( + R_ExternalPtrAddr(Sextptr))->get_ptr()); + nList_* src = dynamic_cast*>(src_base); + if(src) { + contents_ = src->contents_; + return; + } + Rcpp::stop( + "set_all_values on nList: extptr found but object is not an nList."); + } + // Case 3: uncompiled nList R6 environment — call as_list() to convert + Rcpp::Environment Renv(Robj); + if(Renv.exists("as_list")) { + Rcpp::Function as_list_fn(Renv["as_list"]); + SEXP Slist = as_list_fn(); + if(Rcpp::is(Slist)) { + set_from_list(Rcpp::as(Slist)); + return; + } + } + Rcpp::stop( + "set_all_values on nList: environment is neither a compiled nList " + "(no extptr) nor a recognised uncompiled nList (no as_list method)."); + } + Rcpp::stop( + "set_all_values on nList requires a list, a compiled nList, " + "or an uncompiled nList object."); + } + + // Populate contents_ positionally from an R list. + // Each element is converted to Element: + // - shared_ptr: tries the compiled extptr path first; falls back to + // default-constructing a T and calling set_all_values() on it + // (handles uncompiled objects, plain R lists, and nested nLists). + // - primitive / Eigen tensor: Rcpp::as(). + void set_from_list(const Rcpp::List& Robj) { + int n = Robj.length(); + contents_.resize(n); + for(int i = 0; i < n; ++i) { + SEXP Selem = Robj[i]; + if constexpr(is_shared_ptr::value) { + Rcpp::RObject Rextptr = get_extptr_from_SEXP(Selem); + SEXP Sextptr = Rextptr; + if(Sextptr != R_NilValue) { + // Compiled object: extract via shared_ptr Exporter + contents_[i] = Element( + typename Rcpp::traits::input_parameter::type(Sextptr)); + } else { + // Not compiled (plain R list, uncompiled nClass, nested nList): + // create element if absent, then populate recursively + if(!contents_[i]) { + if constexpr(std::is_default_constructible_v< + typename Element::element_type>) { + contents_[i] = + std::make_shared(); + } else { + Rcpp::stop( + "nList set_from_list: element nClass type has no " + "default constructor."); + } + } + contents_[i]->set_all_values(Selem); + } + } else { + contents_[i] = Rcpp::as(Selem); + } + } + } + Rcpp::List as_list_() { Rcpp::List res(contents_.size()); for(size_t i = 0; i < contents_.size(); ++i) { diff --git a/nCompiler/tests/testthat/nClass_tests/test-nClass_constructor.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_constructor.R index 0dd9fd73..3fce42a4 100644 --- a/nCompiler/tests/testthat/nClass_tests/test-nClass_constructor.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_constructor.R @@ -182,6 +182,70 @@ test_that("manual initialize with hand-coded Cpublic initialization works", { }) +test_that("warning issued when Rpublic initialize lacks super$initialize or initialize_Cpublic", { + # Should warn: no super$initialize or initialize_Cpublic + expect_warning( + nClass( + classname = "warn_test", + Rpublic = list( + initialize = function() { + self$Ra <- 1 + }, + Ra = 0 + ), + Cpublic = list( + Ca = 'numericScalar' + ) + ), + "super\\$initialize" + ) + + # Should NOT warn: has super$initialize + expect_no_warning( + nClass( + classname = "no_warn_super", + Rpublic = list( + initialize = function(...) { + super$initialize(...) + self$Ra <- 1 + }, + Ra = 0 + ), + Cpublic = list( + Ca = 'numericScalar' + ) + ) + ) + + # Should NOT warn: has initialize_Cpublic (manual-control pattern) + expect_no_warning( + nClass( + classname = "no_warn_init_cpublic", + Rpublic = list( + initialize = function() { + initialize_Cpublic() + if(isCompiled()) initializeCpp() + self$Ra <- 1 + }, + Ra = 0 + ), + Cpublic = list( + Ca = 'numericScalar' + ), + compileInfo = list(omit_automatic_Cpp_construction = TRUE) + ) + ) + + # Should NOT warn: no Rpublic initialize at all + expect_no_warning( + nClass( + classname = "no_warn_no_init", + Rpublic = list(Ra = 0), + Cpublic = list(Ca = 'numericScalar') + ) + ) +}) + test_that("manual initialize OMITTED with hand-coded C++ initialization compiles but is correctly broken", { nc <- nClass( classname = "methods_test", @@ -242,3 +306,44 @@ test_that("manual initialize OMITTED with hand-coded C++ initialization compiles rm(Cobj); gc() }) + +test_that("nClass returned from nFunction connects to correct C++ object when initialize has args before ...", { + # This tests the fix where $new(CppObj = LOE) uses a named argument so that + # CppObj ends up in ... rather than binding to a positional parameter. + # Without the named CppObj, the LOE would bind to Ra_init and be dropped. + nc <- nClass( + classname = "return_test", + Rpublic = list( + Ra = 0, + initialize = function(Ra_init = 0, ...) { + super$initialize(...) # CppObj = LOE flows through ... when returning from nFunction + self$Ra <- Ra_init + } + ), + Cpublic = list( + Ca = 'numericScalar' + ) + ) + + nf <- nFunction( + function() { + obj <- nc$new() + obj$Ca <- 42 + return(obj) + }, + returnType = 'nc' + ) + + Cnc <- nCompile(nc, nf) + # Normal user-facing construction: Ra_init is used, Ca should be default (0) + user_obj <- Cnc$nc$new(Ra_init = 7) + expect_equal(user_obj$Ra, 7) + expect_equal(user_obj$Ca, 0) + + # Object returned from compiled nFunction: must be connected to the C++ object + # that had Ca set to 42, NOT a freshly default-initialized one. + returned_obj <- Cnc$nf() + expect_equal(returned_obj$Ca, 42) + + rm(user_obj, returned_obj); gc() +}) diff --git a/nCompiler/tests/testthat/specificOp_tests/test-nList.R b/nCompiler/tests/testthat/specificOp_tests/test-nList.R index f40ba947..6ede3c7f 100644 --- a/nCompiler/tests/testthat/specificOp_tests/test-nList.R +++ b/nCompiler/tests/testthat/specificOp_tests/test-nList.R @@ -838,7 +838,7 @@ test_that("nList various bracket get and set operations compile and work for sca comp <- nCompile(nc, rNL = rNL) obj <- comp$nc$new() - obj$lst <- nc$new() + obj$lst <- rNL$new() length(obj$lst) <- 3 curlst <- as.list(obj$lst) @@ -961,7 +961,7 @@ test_that("nList various bracket get and set operations compile and work for vec comp <- nCompile(nc, rNL = rNL) obj <- comp$nc$new() - obj$lst <- nc$new() + obj$lst <- rNL$new() length(obj$lst) <- 3 curlst <- as.list(obj$lst) @@ -1035,9 +1035,6 @@ test_that("nList of nClass elements works", { expect_equal(nl1[[3]]$x, 1:3) }) -## The following tests might be made to work fine. -## At the time of working on this I ran out of time to pursue further tests, -## so these were left incompletely worked out. ## test_that("nList: nClass member of nList type compiles and works", { elemT <- nType("numericScalar") @@ -1062,7 +1059,6 @@ test_that("nList: nClass member of nList type compiles and works", { ) ) ) -# debug(nCompiler:::simpleTransformationsEnv$CheckOpAssignment) comp <- nCompile(rNL = rNL, nc) obj <- comp$nc$new() obj$init() @@ -1116,3 +1112,63 @@ test_that("nList: nFunction argument of nList type compiles and works", { expect_equal(obj$lenOf(lst), 5L) rm(rNL, nc, comp, obj, lst); gc() }) + +# --------------------------------------------------------------------------- +# set_all_values — populate an nList from various R representations +# --------------------------------------------------------------------------- + +test_that("nList uncompiled: set_all_values from plain list", { + obj <- rNL$new() + obj$set_all_values(list(1.0, 2.0, 3.0)) + expect_equal(length(obj), 3) + expect_equal(obj[[1]], 1.0) + expect_equal(obj[[2]], 2.0) + expect_equal(obj[[3]], 3.0) + rm(obj); gc() +}) + +test_that("nList uncompiled: set_all_values from uncompiled nList", { + src <- make_uncompiled() + obj <- rNL$new() + obj$set_all_values(src) + expect_equal(length(obj), 4) + for(i in 1:4) expect_equal(obj[[i]], src[[i]]) + rm(src, obj); gc() +}) + +test_that("nList uncompiled: set_all_values from compiled nList", { + src <- make_compiled() + obj <- rNL$new() + obj$set_all_values(src) + expect_equal(length(obj), 4) + for(i in 1:4) expect_equal(obj[[i]], i * 10.0) + rm(src, obj); gc() +}) + +test_that("nList compiled: set_all_values from plain list", { + obj <- cNL$new() + obj$set_all_values(list(1.0, 2.0, 3.0)) + expect_equal(obj$getLength(), 3L) + expect_equal(obj[[1]], 1.0) + expect_equal(obj[[2]], 2.0) + expect_equal(obj[[3]], 3.0) + rm(obj); gc() +}) + +test_that("nList compiled: set_all_values from compiled nList", { + src <- make_compiled() + obj <- cNL$new() + obj$set_all_values(src) + expect_equal(obj$getLength(), 4L) + for(i in 1:4) expect_equal(obj[[i]], i * 10.0) + rm(src, obj); gc() +}) + +test_that("nList compiled: set_all_values from uncompiled nList", { + src <- make_uncompiled() + obj <- cNL$new() + obj$set_all_values(src) + expect_equal(obj$getLength(), 4L) + for(i in 1:4) expect_equal(obj[[i]], i * 10.0) + rm(src, obj); gc() +})