Support nimble2 (with conflicts resolved)

.github/workflows/tests.yaml

@@ -45,6 +45,7 @@ jobs:
         run: |
              install.packages(c('testthat', 'remotes'))
              install.packages('R6')
+             install.packages('digest')
              install.packages('nimble') # For now, we use `nimble` for stuff in `miscFunctions.R`.
              install.packages('inline') # For now, seemingly need for nCompiler.
              remotes::install_github("https://github.com/nimble-dev/nCompiler", subdir="nCompiler")

.gitignore

@@ -32,3 +32,9 @@ vignettes/*.pdf
 *.utf8.md
 *.knit.md
 .Rproj.user
+
+.DS_Store
+**/.DS_Store
+
+# Symlink to inst/include for devtools::load_all()
+nimbleModel/include

.vscode/settings.json

@@ -0,0 +1,3 @@
+{
+    "makefile.configureOnOpen": false
+}

nimbleModel.Rproj

@@ -0,0 +1,15 @@
+Version: 1.0
+
+RestoreWorkspace: Default
+SaveWorkspace: Default
+AlwaysSaveHistory: Default
+
+EnableCodeIndexing: Yes
+UseSpacesForTab: Yes
+NumSpacesForTab: 2
+Encoding: UTF-8
+
+RnwWeave: Sweave
+LaTeX: pdfLaTeX
+
+BuildType: Makefile

nimbleModel/DESCRIPTION

@@ -10,14 +10,15 @@ Authors@R: c(
 Description: This package provides the ability to create 'nimble' models, generally hierarchical models, not necessarily Bayesian, in R that are compiled to C++. It includes graph processing tools (e.g., finding dependent and parent nodes), abstractions for efficiently storing variable ranges, e.g., `y[1:5, c(2,4)]`  and sets of model nodes (e.g., `y[1,1:5],y[2,1:5],...`), and functions for calculating and simulating variables and nodes in a model. It has been developed to support nimble version 2.0 but can be used more generally for setting up models, doing graph queries and carrying out model calculations.
 Depends: R (>= 4.1.0)
 Imports:
-    methods,R6,nCompiler
+    digest,methods,R6,nCompiler
 License: BSD_3_clause + file LICENSE | GPL (>= 2)
 Encoding: UTF-8
 LazyData: true
 Collate:
     aaa.R
     all_utils.R
     context.R
+    copier.R
     dataRules.R
     distributions_inputList.R
     distributions_processInputList.R
@@ -39,8 +40,10 @@ Collate:
     modelDecl.R
     modelDef.R
     modelFunctions.R
+    modelValues.R
     model_utils.R
     nodeRules.R
+    opDefs.R
     options.R       
     processModelGraph.R
     rhsRules.R
@@ -52,6 +55,7 @@ Collate:
     modelBaseClass.R
     instructions.R
     nimbleModel.R
+    zzz.R
 
 
 

nimbleModel/NAMESPACE

@@ -4,6 +4,8 @@ import(nCompiler)
 ## Some exports are for testing convenience and may not need to be exported.
 
 ## Classes: R6 classes are exported as regular objects
+export(copier_nClass)
+export(multiCopier_nClass)
 export(indexRangeClass)
 export(indexRangeEmptyClass)
 export(indexRangeScalarClass)
@@ -79,6 +81,23 @@ export(calc_dwishAltParams)
 export(nimbleCode)
 export(nimbleModel)
 export(makeInstrList)
+export(makeMultiCopier)
+
+export(values)
+export("values<-")
+
+export(modelValues)
+export(modelValuesConf)
+export(getsize)
+export(resize)
+
+S3method("[", modelValues)
+S3method("[<-", modelValues)
+S3method("length", modelValues)
+S3method("length<-", modelValues)
+S3method("as.list", modelValues)
+S3method("as.matrix", modelValues)
+export(matrix2mv)
 
 export(intersect_nodes)
 export(aggregate_nodes)

nimbleModel/R/copier.R

@@ -0,0 +1,275 @@
+# Classes and tools to support nimble2's values() and nimCopy(), both getting and setting.
+#
+# copier_nClass is just a data structure for one variable name and index information. It doesn't actually copy.
+#
+# multiCopier_nClass holds multiple copier_nClass's and does values() copying (for a model only).
+# It has a C++ layer that uses the flatViewGroup class to do the copying.
+#
+# multiCopierMV_nClass is like multiCopier_nClass but for modelValues objects, 
+# but is used only for nimCopy. 
+#
+# multiCopier_nClass and multiCopierMV_nClass share a C++ base class. 
+# The C++ step of nimCopy_ takes two multiCopier base classes and copies from one to the other.
+# 
+# An important aspect on the C++ side is avoiding repeated name-based lookups of variables
+# within the model or modelValues.
+
+
+#' @export
+copier_nClass <- nCompiler::nClass(
+  classname = "copier_nClass",
+  Cpublic = list(
+    varName = "string",
+    indsList = "nCompiler:::nList(integerVector())"
+  ),
+  predefined = quote(system.file(file.path("include", "nimbleModel", "predef"), package = "nimbleModel") |> file.path("copier_nClass")),
+  compileInfo = list(
+    interface = "full",
+    createFromR = TRUE,
+    exportName = "copier_nClass_new",
+    needed_units = list("nCompiler:::nList(integerVector())"),
+    packageNames = c(uncompiled = "copier_nClass_R", compiled = "copier_nClass"),
+    nClass_inherit = list("copier_nC_base")
+  )
+)
+
+#' @export
+multiCopier_nClass <- nCompiler::nClass(
+  classname = "multiCopier_nClass",
+  Rpublic = list(
+    initialize = function(...) {
+      super$initialize(...)
+      self$copiers <- nList(copier_nClass())$new()
+    }
+  ),
+  Cpublic = list(
+    copiers = "nCompiler:::nList(copier_nClass())",
+    init = nFunction(
+      name = "init",
+      function(model) {
+        cat("need uncompiled multiCopier init() implementation.")
+      },
+      compileInfo = list(
+        C_fun = function(model = "nimbleModel:::modelBase_nClass()") {
+          cppLiteral("multiCopier_model_nC_base::init(this->copiers, model)")
+        }
+      )
+    ),
+    getValues = nFunction(
+      name = "getValues",
+      function() {
+        cat("need uncompiled multiCopier getValues() implementation.")
+      },
+      returnType = "numericVector",
+      compileInfo = list(
+        C_fun = function() {
+          cppLiteral("return flatViewGroup.copyIntoVector()")
+        }
+      )
+    ),
+    # Note that this setValues works but is not actually used by nimble2 keyword processing
+    # which instead uses copiers->flatViewGroup.setValues_() which provides an operator=.
+    # It is possible that this setValues() will be useful in other contexts, or if not that we
+    # can eventually remove it to avoid confusion.
+    setValues = nFunction(
+      name = "setValues",
+      function(v = "numericVector") {
+        cat("need uncompiled multiCopier setValues() implementation.")
+      },
+      compileInfo = list(
+        C_fun = function(v = "numericVector") {
+          cppLiteral("flatViewGroup.copyFromVector(v)")
+        }
+      )
+    )
+  ),
+  predefined = quote(system.file(file.path("include", "nimbleModel", "predef"), package = "nimbleModel") |> file.path("mCopy_nC")),
+  compileInfo = list(
+    cpp_classname = "mCopy_nC",
+    interface = "full",
+    createFromR = TRUE,
+    exportName = "multiCopier_nClass_new",
+    needed_units = list("nCompiler:::nList(copier_nClass())", "modelBase_nClass()"),
+    packageNames = c(uncompiled = "multiCopier_nClass_R", compiled = "multiCopier_nClass"),
+    nClass_inherit = list("multiCopier_model_nC_base"),
+    opDefs = list(
+      getOrSetValues = list(
+        labelAbstractTypes = list(
+          handler = "multiCopier_getOrSetValues_LAT"
+        )
+      )
+    )
+  )
+)
+
+multiCopier_getOrSetValues_LAT <- function(...) {
+  browser()
+}
+
+#' @export
+multiCopierMV_nClass <- nCompiler::nClass(
+  classname = "multiCopierMV_nClass",
+  Rpublic = list(
+    initialize = function(...) {
+      super$initialize(...)
+      self$copiers <- nList(copier_nClass())$new()
+    }
+  ),
+  Cpublic = list(
+    copiers = "nCompiler:::nList(copier_nClass())",
+    init = nFunction(
+      name = "init",
+      function(modelValues) {
+        cat("need uncompiled multiCopierMV init() implementation.")
+      },
+      compileInfo = list(
+        C_fun = function(modelValues = "nimbleModel:::modelValuesBase_nClass()") {
+          cppLiteral("multiCopier_modelValues_nC_base::init(this->copiers, modelValues)")
+        }
+      )
+    ),
+    # Selects which row of each variable's nList the flatViewGroup reads
+    # from/writes to. Must be called at least once, after the modelValues has
+    # been resized to have at least one row, before getValues/setValues/
+    # nimCopy_ are used. See multiCopier_modelValues_nC_base::setActiveRow.
+    setActiveRow = nFunction(
+      name = "setActiveRow",
+      function(row) {
+        cat("need uncompiled multiCopierMV setActiveRow() implementation.")
+      },
+      compileInfo = list(
+        C_fun = function(row) {
+          cppLiteral("multiCopier_modelValues_nC_base::setActiveRow(row)")
+        }
+      ),
+      argTypes = list(row = "integerScalar")
+    ),
+    getValues = nFunction(
+      name = "getValues",
+      function() {
+        cat("need uncompiled multiCopierMV getValues() implementation.")
+      },
+      returnType = "numericVector",
+      compileInfo = list(
+        C_fun = function() {
+          cppLiteral("return flatViewGroup.copyIntoVector()")
+        }
+      )
+    ),
+    # See the note on multiCopier_nClass$setValues above: kept for other
+    # contexts even though nimble2 keyword processing uses
+    # copiers->flatViewGroup.setValues_() directly.
+    setValues = nFunction(
+      name = "setValues",
+      function(v = "numericVector") {
+        cat("need uncompiled multiCopierMV setValues() implementation.")
+      },
+      compileInfo = list(
+        C_fun = function(v = "numericVector") {
+          cppLiteral("flatViewGroup.copyFromVector(v)")
+        }
+      )
+    )
+  ),
+  predefined = quote(system.file(file.path("include", "nimbleModel", "predef"), package = "nimbleModel") |> file.path("mCopyMV_nC")),
+  compileInfo = list(
+    cpp_classaname = "mCopyMV_nC",
+    interface = "full",
+    createFromR = TRUE,
+    exportName = "multiCopierMV_nClass_new",
+    needed_units = list("nCompiler:::nList(copier_nClass())", "modelValuesBase_nClass()"),
+    packageNames = c(uncompiled = "multiCopierMV_nClass_R", compiled = "multiCopierMV_nClass"),
+    nClass_inherit = list("multiCopier_modelValues_nC_base")
+  )
+)
+
+#' @export
+makeMultiCopier <- function(source, nodes,
+                            sourceType = c("model", "modelValues"), ...) {
+  # This will be called from a nimble2 keyword processor
+  # The ... is to absorb further arguments that at the time of this writing are not fleshed out.
+  if (is.character(nodes)) {
+    nodes <- nodes |> lapply(\(x) nimbleModel:::varRangeClass$new(x))
+  }
+  sourceType <- match.arg(sourceType)
+  multiCopier <-
+    switch(sourceType,
+      model = multiCopier_nClass$new(),
+      modelValues = multiCopierMV_nClass$new()
+    )
+  getRange <- function(indexRange) {
+    if (!inherits(indexRange, "indexRangeSequenceClass")) {
+      stop("In a copy operation, only contiguous index blocks are supported")
+    }
+    c(indexRange$start, indexRange$end)
+  }
+  for (i in seq_along(nodes)) {
+    thisNode <- nodes[[i]]
+    multiCopier$copiers[[i]] <- copier_nClass$new()
+    multiCopier$copiers[[i]]$varName <- thisNode$varName
+    multiCopier$copiers[[i]]$indsList <- thisNode$indexRanges |> lapply(getRange)
+  }
+  attr(multiCopier, "NCgenerator") <-
+    switch(sourceType,
+      model = quote(nimbleModel:::multiCopier_nClass),
+      modelValues = quote(nimbleModel:::multiCopierMV_nClass)
+    )
+  multiCopier
+}
+
+# Uncompiled implementations of values(model, nodes) and `values<-`(model, nodes, value).
+
+#' @export
+values <- function(model, nodes) {
+  if (is.character(nodes)) {
+    nodes <- lapply(nodes, \(x) varRangeClass$new(x))
+  }
+  # To-do: other checking and error-trapping on inputs
+  vals <- lapply(
+    nodes,
+    \(x) {
+      eval(x$toExpr(), envir = model) |> as.numeric()
+    }
+  )
+  do.call("c", vals)
+}
+
+#' @export
+`values<-` <- function(model, nodes, value) {
+  if (is.character(nodes)) {
+    nodes <- lapply(nodes, \(x) varRangeClass$new(x))
+  }
+  iV_start <- 1
+  replExprTemplate <- quote(model_stuff <- value[iV_start:iV_end])
+  for (i in seq_along(nodes)) {
+    thisNode <- nodes[[i]]
+    expr <- thisNode$toExpr()
+    if (is.name(expr)) {
+      thisLength <- length(model[[expr]])
+    } else {
+      mm <- thisNode$getMinMax()
+      sizes <- mm[, 2] - mm[, 1] + 1
+      ## This section about NAs in the sizes
+      ## anticipates how we would handle blank index slots
+      ## by putting NAs in the getMinMax() result.
+      ## But that is not in place while this is being drafted
+      NAsizes <- which(is.na(sizes))
+      if (length(NAsizes)) {
+        thisDims <- dimOrLength(model[[thisNode$varName]])
+        sizes[NAsizes] <- thisDims[NAsizes]
+      }
+      #
+      thisLength <- prod(sizes)
+      varExpr <- expr[[2]]
+      model_stuff <- quote(model$VAR)
+      model_stuff[[3]] <- varExpr
+      expr[[2]] <- model_stuff
+    }
+    iV_end <- iV_start + thisLength - 1
+    replExpr <- replExprTemplate
+    replExpr[[2]] <- expr
+    eval(replExpr)
+    iV_start <- iV_end + 1
+  }
+  model
+}