infrastructure for nimble models

.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

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

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]],

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()
 

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({

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()
+})

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