diff --git a/.github/workflows/test-all.yaml b/.github/workflows/test-all.yaml index 596b3554..a052a5cd 100644 --- a/.github/workflows/test-all.yaml +++ b/.github/workflows/test-all.yaml @@ -39,6 +39,10 @@ jobs: - uses: actions/checkout@v3 - name: SessionInfo run: R -q -e 'sessionInfo()' + - name: Install nimbleModel + run: R -q -e 'remotes::install_github("https://github.com/perrydv/nimbleModel", subdir="nimbleModel", auth_token=Sys.getenv("GITHUB_TOKEN_NIMBLEMODEL"))' + env: + GITHUB_TOKEN_NIMBLEMODEL: ${{ secrets.GH_NM_PAT }} - name: Package Dependencies run: R -q -e 'remotes::install_deps("nCompiler", dependencies=TRUE)' - name: Install inline diff --git a/nCompiler/R/NC.R b/nCompiler/R/NC.R index bfcf5670..79838630 100644 --- a/nCompiler/R/NC.R +++ b/nCompiler/R/NC.R @@ -169,10 +169,11 @@ nClass <- function(classname, # Uncompiled behavior for Cpublic fields needs to be handled. # Right now a type string like 'numericScalar' just becomes a # default value. + builtIn <- list(isCompiled=function() FALSE) eval(substitute( result <- R6::R6Class( classname = classname, - public = c(Rpublic, Cpublic), + public = c(Rpublic, Cpublic, builtIn), portable = FALSE, inherit = INHERIT, parent_env = new_env diff --git a/nCompiler/R/NC_FullCompiledInterface.R b/nCompiler/R/NC_FullCompiledInterface.R index 7ee78c1a..7fb48302 100644 --- a/nCompiler/R/NC_FullCompiledInterface.R +++ b/nCompiler/R/NC_FullCompiledInterface.R @@ -191,6 +191,52 @@ build_compiled_nClass <- function(NCgenerator, classname <- paste0(NCgenerator$classname, '_compiled') + if("isCompiled" %in% names(RinterfaceMethods)) + RinterfaceMethods[["isCompiled"]] <- function() TRUE + + ## How the initialize scheme works: + ## If a user has not provided an Rpublic method called initialize, + ## then we insert a default initialize, which takes CppObj and calls initializeCpp(CppObj), + ## which builds a new Cpp object in the usual case that CppObj is missing or + ## inserts it as the private$CppObj if provided. + ## If a user has provided an Rpublic method called initialize, + ## then if compileInfo$omit_automatic_Cpp_construction is not TRUE, + ## we modify the body of that initialize to call initializeCpp() at the start. + ##. In that case, there is no option to pass in a CppObj; the C++ object is always constructed. + ## If a user wants to write an initialize AND allow the use of an existing CppObj, + ## they must set compileInfo=list(omit_automatic_Cpp_construction=TRUE) + ##. AND write the call to initializeCpp(CppObj) themselves, which should normally check + ## if the object is compiled: `if(isCompiled()) initializeCpp(CppObj)`. + + if("initializeCpp" %in% names(RinterfaceMethods)) + stop("Rpublic method name 'initializeCpp' is reserved for nCompiler use.") + + RinterfaceMethods[["initializeCpp"]] <- substitute( + function(CppObj) { + if(missing(CppObj)) { + newCobjFun <- NEWCOBJFUN + if(is.null(newCobjFun)) + stop("Cannot create a nClass full interface object without a newCobjFun or a CppObj argument.") + CppObj <- newCobjFun() + } + private$CppObj <- CppObj + private$DLLenv <- `:::`("nCompiler", "get_DLLenv")(CppObj) # workaround static code scanning for nCompiler:::get_DLLenv(CppObj) + }, + list( + NEWCOBJFUN = if(quoted) as.name(newCobjFun) + else quote(parent.env(parent.env(self))$.newCobjFun) + ) + ) + omit_automatic_Cpp_construction <- isTRUE(NCI$compileInfo$omit_automatic_Cpp_construction) + if("initialize" %in% names(RinterfaceMethods)) { + if(!omit_automatic_Cpp_construction) { + body(RinterfaceMethods[["initialize"]]) <- + substitute({initializeCpp(); OLDBODY}, list(OLDBODY = body(RinterfaceMethods[["initialize"]]))) + } + } else { + if(!omit_automatic_Cpp_construction) + RinterfaceMethods[["initialize"]] <- function(CppObj) {initializeCpp(CppObj)} + } ans <- substitute( expr = R6::R6Class( classname = CLASSNAME, @@ -199,16 +245,6 @@ build_compiled_nClass <- function(NCgenerator, DLLenv = NULL ), public = c( - list(initialize = function(CppObj) { - if(missing(CppObj)) { - newCobjFun <- NEWCOBJFUN - if(is.null(newCobjFun)) - stop("Cannot create a nClass full interface object without a newCobjFun or a CppObj argument.") - CppObj <- newCobjFun() - } - private$CppObj <- CppObj - private$DLLenv <- `:::`("nCompiler", "get_DLLenv")(CppObj) # workaround static code scanning for nCompiler:::get_DLLenv(CppObj) - }), RPUBLIC, RFIELDS, CINTERFACE), @@ -219,10 +255,6 @@ build_compiled_nClass <- function(NCgenerator, ), env = list( CLASSNAME = classname, - NEWCOBJFUN = if(quoted) as.name(newCobjFun) - else quote(parent.env(parent.env(self))$.newCobjFun), - #parse(text = paste0('new_', NCgenerator$classname), - # keep.source = FALSE)[[1]], RPUBLIC = parse(text = deparse( RinterfaceMethods #NCgenerator$public_methods[RmethodNames] ), keep.source = FALSE)[[1]], diff --git a/nCompiler/R/nimbleModels.R b/nCompiler/R/nimbleModels.R index 71f0b267..ab7fafaa 100644 --- a/nCompiler/R/nimbleModels.R +++ b/nCompiler/R/nimbleModels.R @@ -128,10 +128,7 @@ make_node_fun <- function(varInfo = list(), classname) { # varInfo will be a list (names not used) of name, nDim, sizes. varInfo_2_cppVar <- \(x) nCompiler:::symbolBasic$new( - type="double", nDim=x$nDim, name="", isRef=TRUE, isConst=FALSE, interface=FALSE) # We could in future make some isConst=TRUE, but it might not matter much - # varInfo_2_cppVar <- \(x) nCompiler:::symbolCppVar$new( - # baseType = nCompiler:::symbolBasic$new(type="double", nDim=x$nDim, name="")$genCppVar()$generate(), - # ref=TRUE, const=TRUE) + type="double", nDim=x$nDim, name="", isRef=TRUE, isConst=FALSE, interface=FALSE) # In future maybe isConst=TRUE, but it might not matter much typeList <- varInfo |> lapply(varInfo_2_cppVar) names(typeList) <- varInfo |> lapply(\(x) x$name) |> unlist() diff --git a/nCompiler/tests/nimble/test-coreR.R b/nCompiler/tests/nimble/test-coreR.R index ebc439b2..36058495 100644 --- a/nCompiler/tests/nimble/test-coreR.R +++ b/nCompiler/tests/nimble/test-coreR.R @@ -1090,6 +1090,7 @@ test_that('seq_along works in nimbleFunctions', { }) ## Some tests of using coreR features in BUGS models +require(nimbleModel) test_that('c(a, 1.1) in BUGS works', { mc <- nimbleCode({ diff --git a/nCompiler/tests/testthat/nClass_tests/test-nClass_constructor.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_constructor.R index 6ad6109b..7fb67d0e 100644 --- a/nCompiler/tests/testthat/nClass_tests/test-nClass_constructor.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_constructor.R @@ -72,3 +72,161 @@ test_that("nClass replacing default constructor works", { # rm(obj) # gc() }) + +test_that("manual initialize works and Cpp ctor call is inserted", { + nc <- nClass( + classname = "methods_test", + Rpublic = list( + Ra = 0, + initialize = function() { + print("calling initialize") + self$Ra <- 1 + }, + get_Ra = function() { + self$Ra + }, + get_Ca = function() { + self$Ca + } + ), + Cpublic = list( + Ca = 'numericScalar', + methods_test = nFunction( + function() { + nCpp('Rprintf("calling c++ constructor\\n")') + Ca <- 2 + }, + compileInfo = list(constructor=TRUE) + ) + ) + ) + + obj <- nc$new() + expect_equal(obj$Ra, 1) + expect_equal(obj$get_Ra(), 1) + #obj$Ca + #obj$get_Ca() + # Need initialization of uncompiled Cpublic variables? + + Cnc <- nCompile(nc) + out <- capture_output(Cobj <- Cnc$new()) + # the C++ initializer output should appear BEFORE the R initializer msg + expect_true(regexpr("initialize", out) > regexpr("constructor", out)) + + expect_equal(Cobj$Ra, 1) + expect_equal(Cobj$get_Ra(), 1) + expect_equal(Cobj$Ca, 2) + expect_equal(Cobj$get_Ca(), 2) + rm(Cobj); gc() +}) + + +test_that("manual initialize with hand-coded C++ initialization works", { + nc <- nClass( + classname = "methods_test", + Rpublic = list( + Ra = 0, + initialize = function() { + print("calling initialize") + if(isCompiled()) initializeCpp() + self$Ra <- 1 + }, + get_Ra = function() { + self$Ra + }, + get_Ca = function() { + self$Ca + } + ), + Cpublic = list( + Ca = 'numericScalar', + methods_test = nFunction( + function() { + nCpp('Rprintf("calling c++ constructor\\n")') + Ca <- 2 + }, + compileInfo = list(constructor=TRUE) + ) + ), + compileInfo=list(omit_automatic_Cpp_construction=TRUE) + ) + + obj <- nc$new() + expect_equal(obj$Ra, 1) + expect_equal(obj$get_Ra(), 1) + expect_true(isFALSE(obj$isCompiled())) + #obj$Ca + #obj$get_Ca() + # Need initialization of uncompiled Cpublic variables? + + Cnc <- nCompile(nc) + out <- capture_output(Cobj <- Cnc$new()) + # the C++ initializer output should now appear AFTER the R initializer msg + expect_true(regexpr("initialize", out) < regexpr("constructor", out)) + expect_true(isTRUE(Cobj$isCompiled())) + expect_equal(Cobj$Ra, 1) + expect_equal(Cobj$get_Ra(), 1) + expect_equal(Cobj$Ca, 2) + expect_equal(Cobj$get_Ca(), 2) + rm(Cobj); gc() +}) + + +test_that("manual initialize OMITTED with hand-coded C++ initialization compiles but is correctly broken", { + nc <- nClass( + classname = "methods_test", + Rpublic = list( + Ra = 0, + initialize = function() { + print("calling initialize") + # if(isCompiled()) initializeCpp() # OMITTED! + self$Ra <- 1 + }, + get_Ra = function() { + self$Ra + }, + get_Ca = function() { + self$Ca + } + ), + Cpublic = list( + Ca = 'numericScalar', + methods_test = nFunction( + function() { + nCpp('Rprintf("calling c++ constructor\\n")') + Ca <- 2 + }, + compileInfo = list(constructor=TRUE) + ) + ), + compileInfo=list(omit_automatic_Cpp_construction=TRUE) + ) + + obj <- nc$new() + expect_equal(obj$Ra, 1) + expect_equal(obj$get_Ra(), 1) + expect_true(isFALSE(obj$isCompiled())) + #obj$Ca + #obj$get_Ca() + # Need initialization of uncompiled Cpublic variables? + + Cnc <- nCompile(nc) + out <- capture_output(Cobj <- Cnc$new()) + # the C++ initializer output should now appear AFTER the R initializer msg + expect_true(regexpr("constructor", out)==-1) + expect_true(isTRUE(Cobj$isCompiled())) + expect_equal(Cobj$Ra, 1) + expect_equal(Cobj$get_Ra(), 1) + expect_error(Cobj$Ca) + expect_error(Cobj$get_Ca()) + + out2 <- capture_output(Cobj$initializeCpp()) + expect_true(regexpr("constructor", out2)>0) + expect_true(isTRUE(Cobj$isCompiled())) + expect_equal(Cobj$Ra, 1) + expect_equal(Cobj$get_Ra(), 1) + expect_equal(Cobj$Ca, 2) + expect_equal(Cobj$get_Ca(), 2) + + rm(Cobj); gc() +}) diff --git a/nCompiler/tests/testthat/nCompile_tests/test-argumentPassing.R b/nCompiler/tests/testthat/nCompile_tests/test-argumentPassing.R index 5374e8bb..ab06c901 100644 --- a/nCompiler/tests/testthat/nCompile_tests/test-argumentPassing.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-argumentPassing.R @@ -14,7 +14,7 @@ message("doing scalar = vector + scalar does not error out if the vector in leng message("blockRef error trapping can be more involved -- using dims.") message("blockRef cannot cross between scalar types") -cat("startig test-argumentPassing\n") +cat("starting test-argumentPassing\n") # This is a workaround to pkg_name::var. # This is necessary because on GitHub Actions for testing, we use diff --git a/nCompiler/tests/testthat/nCompile_tests/test-indexing.R b/nCompiler/tests/testthat/nCompile_tests/test-indexing.R index 102dd2ce..5ece4b1b 100644 --- a/nCompiler/tests/testthat/nCompile_tests/test-indexing.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-indexing.R @@ -19,8 +19,8 @@ test_that("indexing by numeric vector works", { cobj <- nCompile(nC)$new() x <- matrix(1:20, nrow = 4) iv <- c(2,3,2,1,5) - for (i in seq_along(ls(nC$public_methods)[-1])) { - test_i <- paste0('test', i) + method_names <- ls(nC$public_methods) + for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x, iv) outR <- nC$public_methods[[test_i]](x, iv) if (is.array(outC) && length(attributes(outC)$dim) == 1) @@ -91,8 +91,8 @@ test_that("drop arg variations give correct results, 3D input", { # cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() x <- array(1:105, c(3, 5, 7)) - for (i in seq_along(ls(nC$public_methods)[-1])) { - test_i <- paste0('test', i) + method_names <- ls(nC$public_methods) + for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) outR <- nC$public_methods[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) @@ -142,8 +142,8 @@ test_that("indexing arg variations give correct results, 3D input", { #cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() x <- array(1:105, c(3, 5, 7)) - for (i in seq_along(ls(nC$public_methods)[-1])) { - test_i <- paste0('test', i) + method_names <- ls(nC$public_methods) + for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) outR <- nC$public_methods[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) @@ -176,8 +176,8 @@ test_that("assignment involving indexing give correct results, 3D input", { # cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() x <- array(1:105, c(3, 5, 7)) - for (i in seq_along(ls(nC$public_methods)[-1])) { - test_i <- paste0('test', i) + method_names <- ls(nC$public_methods) + for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) outR <- nC$public_methods[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) @@ -209,8 +209,8 @@ test_that("expressions involving indexing give correct results, 3D input", { #cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() x <- array(1:105, c(3, 8, 7)) - for (i in seq_along(ls(nC$public_methods)[-1])) { - test_i <- paste0('test', i) + method_names <- ls(nC$public_methods) + for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) outR <- nC$public_methods[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) @@ -234,8 +234,8 @@ test_that("scalar input gives correct results", { # cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() x <- 3 - for (i in seq_along(ls(nC$public_methods)[-1])) { - test_i <- paste0('test', i) + method_names <- ls(nC$public_methods) + for (test_i in method_names[startsWith(method_names, "test")]) { expect_equal( nC$public_methods[[test_i]](x), ## R cobj[[test_i]](x) ## C++ @@ -265,8 +265,8 @@ test_that("vector input gives correct results", { # cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() x <- 1:11 - for (i in seq_along(ls(nC$public_methods)[-1])) { - test_i <- paste0('test', i) + method_names <- ls(nC$public_methods) + for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) outR <- nC$public_methods[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) @@ -304,8 +304,8 @@ test_that("matrix input gives correct results", { # cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() x <- matrix(1:21, c(7, 3)) - for (i in seq_along(ls(nC$public_methods)[-1])) { - test_i <- paste0('test', i) + method_names <- ls(nC$public_methods) + for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) outR <- nC$public_methods[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) @@ -343,8 +343,8 @@ test_that("3-dimensional input array gives correct results", { # cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() x <- array(1:84, c(3, 4, 7)) - for (i in seq_along(ls(nC$public_methods)[-1])) { - test_i <- paste0('test', i) + method_names <- ls(nC$public_methods) + for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) outR <- nC$public_methods[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) @@ -396,8 +396,8 @@ test_that("4-dimensional input array gives correct results", { #cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() x <- array(1:924, c(3, 7, 4, 11)) - for (i in seq_along(ls(nC$public_methods)[-1])) { - test_i <- paste0('test', i) + method_names <- ls(nC$public_methods) + for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) outR <- nC$public_methods[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) @@ -421,8 +421,8 @@ test_that("5-dimensional input array gives correct results", { # cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() x <- array(1:2310, c(2, 3, 7, 5, 11)) - for (i in seq_along(ls(nC$public_methods)[-1])) { - test_i <- paste0('test', i) + method_names <- ls(nC$public_methods) + for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) outR <- nC$public_methods[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1)