remove all bottlenecks in creating instrList with multiple sortIDs

.github/workflows/tests.yaml

@@ -47,7 +47,7 @@ jobs:
              install.packages('R6')
              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", ref="nimble-dists")
+             remotes::install_github("https://github.com/nimble-dev/nCompiler", subdir="nCompiler")
         shell: Rscript {0}
 
       - name: Install nimbleModel (Windows)

nimbleModel/R/instructions.R

@@ -129,7 +129,10 @@ makeInstrList <- function(model, input, includeData = TRUE, use_vec = FALSE) {
   # (2) a list of (or single) varRanges
   # (3) an nList of (or single) instr_nClass objects (assumed to be in sort order)
   # (4) an R list of instr_nClass objects (not assumed to be in sort order)
-
+  # (5) an R list of instr_nClass-like R lists (produced by makeScalarInstrInfoLists when splitting a calcRange with multiple sortID values.
+
+  # TODO: do we really need to handle case #4? 
+
   # A single instruction.
   if (inherits(input, "instr_nClass")) {
     return(list(input))
@@ -166,6 +169,10 @@ makeInstrList <- function(model, input, includeData = TRUE, use_vec = FALSE) {
     return(instrList)
   }
 
+  # An R list of instr_nClass-like R lists
+  if(inherits(input, "Rlist_Rinstr"))
+    return(input)
+
   # Finally handle character vectors or varRanges.
   if (inherits(input, "varRangeClass")) input <- list(input)
 
@@ -190,39 +197,24 @@ makeInstrList <- function(model, input, includeData = TRUE, use_vec = FALSE) {
   rangesToRemove <- numeric(0)
   for(i in multiSortID) 
     if(!all(diff(sortIDs[[i]]) == 1, na.rm = TRUE)) {
-      newRanges <- ranges[[i]]$makeScalars()  # Somewhat slow; 5s per 10k items.
-      # Attempt to avoid repeated identical processing in `range2instr`.
-      # However, that is not the bottleneck; simply passing the `newRanges` elements into `instr_nClass$new()`
-      # would not be much slower. For now, leave the approach of using the template.
-      templateInstr <- range2instr(newRanges[[1]])
-      newInstrs <- c(newInstrs, lapply(seq_along(newRanges), 
-                                     function(idx) {
-                                       templateInstr$sortID <- newRanges[[idx]]$sortID
-                                       templateInstr$values[[1]] <- newRanges[[idx]]$indexingRange$indexRanges[[1]]$values[1]
-                                       return(templateInstr)
-                                     }))
+      # This quickly creates a list of R lists, where the elements mimic instr_nClass objects,
+      # from a calcRange with multiple sortID values. Creating many calcRanges or instr_nClass objects is slow.
+      newInstrs <- c(newInstrs, ranges[[i]]$makeScalarInstrInfoLists())
       rangesToRemove <- c(rangesToRemove, i)
     } else {  # Check for any overlapping sortID values for the sequential backward dependence calcRange.
       if(any(sortIDranges[2,-i] > sortIDranges[1,i] & sortIDranges[1,-i] < sortIDranges[2,i]))
         stop("the multiple sortID values in the ", i, "th calcRange overlap with sortID values in other calcRanges")                
     }
   if(length(rangesToRemove))
     ranges <- ranges[-rangesToRemove]
-  # This is slow - 40 ms per new instr_nClass, regardless of whether pass in a calcRange
-  # or an R list containing instruction info.
-  Rlist <- c(lapply(ranges, \(x) instr_nClass$new(x)),
-             lapply(newInstrs, \(x) instr_nClass$new(instr = x)))
 
-  numRanges <- length(Rlist)
-  sortIDranges <- sapply(Rlist, \(x) min(x$sortID, na.rm = TRUE))
-  ord <- order(sortIDranges)
-  instrList <- nList(instr_nClass)$new()
-  instrList$setLength(numRanges)
-  # We need a loop to populate an nList; can't use `input[ord]`.
-  for (i in seq_len(numRanges)) {
-    instrList[[i]] <- Rlist[[ord[i]]]
-  }
-  return(instrList)
+  # Again, returning a list of R lists that mimic instr_nClass objects is much faster
+  # than instantiating instr_nClass objects.
+  Rlist <- c(newInstrs, lapply(ranges, \(x) range2instr(x)))
+  sortIDs <- sapply(Rlist, \(x) min(x$sortID, na.rm = TRUE))  # `min` still needed for case of ascending sortIDs (e.g., dependence on the past), which are not split.
+  Rlist <- Rlist[order(sortIDs)]
+  class(Rlist) <- "Rlist_Rinstr"  # For checking idempotency.
+  return(Rlist)
 }
 
 
@@ -231,9 +223,9 @@ instr_nClass <- nClass(
   Rpublic = list(
     initialize = function(calcRange, instr, ...) {
       super$initialize(...)
-      if (!missing(calcRange) || !missing(instr)) {
+      if(!missing(calcRange) || !missing(instr)) {
         if(!missing(calcRange))
-          instr <- range2instr(calcRange) # This processing could simply be included here in `initialize`.
+          instr <- range2instr(calcRange) 
         self$lens <- instr$lens %||% integer()
         self$index_types <- instr$index_types %||% integer()
         self$nDim <- instr$nDim %||% 0L

nimbleModel/R/modelBaseClass.R

@@ -415,7 +415,8 @@ modelBase_nClass <- nClass(
       }
       instrList <- makeInstrList(self, instr)
       if (isCompiled()) {
-        if (!instrList$isCompiled()) instrList <- makeCompiledInstrList(instrList)
+        if (inherits(instrList, "Rlist_Rinstr") || !instrList$isCompiled())
+          instrList <- makeCompiledInstrList(instrList)
         return(self[[fn_cpp]](instrList))
       }
       logProb <- 0
@@ -443,7 +444,8 @@ modelBase_nClass <- nClass(
       instrList <- makeInstrList(self, instr, includeData = includeData)
       if(is.null(instrList)) return(invisible(NULL))
       if (isCompiled()) {
-        if (!instrList$isCompiled()) instrList <- makeCompiledInstrList(instrList)
+        if (inherits(instrList, "Rlist_Rinstr") || !instrList$isCompiled())
+          instrList <- makeCompiledInstrList(instrList)
         self$simulate_impl(instrList)
       } else {
         for (i in 1:length(instrList)) {

nimbleModel/R/nodeRules.R

@@ -376,17 +376,24 @@ calcRangeClass <- R6Class(
       declID <<- declID
       multiSortIDindex <<- multiSortIDindex
     },
-    makeScalars = function() {
+    makeScalarInstrInfoLists = function() {
+      # This is used to split the calcRange when there are multiple sortID values.
+      # To avoid overhead (0.5 ms per call) in making many calcRangeClass objects,
+      # we simply produce a list of lists where each list item is in the form also
+      # produced by `range2instr()` (i.e., basically an instr_nClass object in R list form).
+
       # Need original indexing because nodeFunctions will use that indexing
       # (e.g. `y[i+1]` needs value of `i`).
       if(length(multiSortIDindex) != 1)
         stop("attempting to split calcRange that has multiple indexing")
       indices <- c(indexingRange$indexRanges[[indexingRange$indexSlotToRange[multiSortIDindex]]]$getValuesAsMatrix())
       if(length(indices) != length(sortID))
         stop("mismatch between indexing values and node-based sortIDs")
+
       results <- lapply(seq_along(indices), \(i)
-                        calcRangeClass$new(varName, varRangeClass$new(list(indexRangeMatrixClass$new(matrix(indices[i]), sort=FALSE))),
-                                declID, sortID[i], NULL))
+                        list(dims = 1, index_types = 2, lens = 1, nDim = 1, slots = 1, sortID = sortID[i],
+                             declID = declID, type = 2, values = list(indices[i])))
+      class(results) <- "Rlist_Rinstr"  # For ease of determining the type of the object in `makeInstrList`.
       return(results)
     }
   )

nimbleModel/tests/testthat/test-nimbleModel.R

@@ -791,7 +791,7 @@ test_that("calculate works correctly for time series/SSM recursion", {
               "something other than sequential dependence on the past")
 
   # Check proper handling when providing list of instructions.
-  instrList <- makeInstrList(m, lapply(c(5,3,1,2,4), \(i) instrList[[i]])) 
+  instrList <- makeInstrList(m, lapply(c(5,3,1,2,4), \(i) nimbleModel:::instr_nClass$new(instrList[[i]])))
   sortIDs <- lapply(instrList, \(x) x$sortID)
   expect_true(all(diff(sapply(sortIDs, \(x) min(x,na.rm=TRUE))) >= 0))
   expect_true(all(sapply(sortIDs, \(x) length(x) == 1 || all(diff(x) >= 1, na.rm=TRUE))))