handle some keywords and some other misc stuff

nimbleModel/R/all_utils.R

@@ -184,12 +184,6 @@ is.rcf <- function(x, inputIsName = FALSE, where = -1) {
 nimbleUniqueID <- labelFunctionCreator("UID")
 nimbleModelID <- labelFunctionCreator("MID")
 
-
-# temporary, as we have some tests of use of `c()` in indexing
-nimC <- function(...) {
-  c(...)
-}
-
 evalNumeric <- function(expr) {
   if (length(expr) == 1) {
     return(expr)

nimbleModel/R/context.R

@@ -206,7 +206,7 @@ expandContextAndReplacements <- function(allReplacements, allReplacementNameExpr
   innerLoopCode <- as.call(c(list(quote(`{`)), replacementRecordingCode, indexRecordingCode, quote(iAns <- iAns + 1)))
 
   innerLoopCode <- context$embedCodeInForLoop(innerLoopCode, useContext)
-  # This is a hacky way to deal with `nimC`, which is not in `constantsCopy`.
+  # This is a hacky way to deal with `nC`, which is not in `constantsCopy`.
   if (length(innerLoopCode[[3]]) > 1 && innerLoopCode[[3]][[1]] == "nimC") {
     innerLoopCode[[3]][[1]] <- quote(c)
   }
@@ -265,7 +265,7 @@ determineContextSize <- function(context, useContext = rep(TRUE, length(context$
   innerLoopCode <- quote(iAns <- iAns + 1)
   innerLoopCode <- context$embedCodeInForLoop(innerLoopCode, useContext)
 
-  # This is a hacky way to deal with `nimC`, which is not in `evalEnv`.
+  # This is a hacky way to deal with `nC`, which is not in `evalEnv`.
   if (length(innerLoopCode[[3]]) > 1 && innerLoopCode[[3]][[1]] == "nimC") {
     innerLoopCode[[3]][[1]] <- quote(c)
   }

nimbleModel/R/getSymbolicParentNodes.R

@@ -89,7 +89,7 @@ nimblePreevaluationFunctionNames <- c(
   # distribution functions
   paste0(c("d", "q", "p"), "t"),
   paste0(c("d", "q", "p"), "exp"),
-  "nimC", "nimRep", "nimSeq", "diag",
+  "nC", "nRep", "nSeq", "diag",
   "nimNumeric", "nimMatrix", "nimArray",
   "length"
 )
@@ -99,7 +99,7 @@ nimbleOrRfunctionNames <- c(
   "+", "-", "/", "*",
   "exp", "log",
   "pow", "^",
-  "%%", "%*%",
+  "%%", "%*%", "nMul",
   "t",
   "equals", "nimEquals",
   "inprod",
@@ -143,7 +143,7 @@ nimbleOrRfunctionNames <- c(
   # distribution functions
   paste0(c("d", "r", "q", "p"), "t"),
   paste0(c("d", "r", "q", "p"), "exp"),
-  "nimC", "nimRep", "nimSeq",
+  "nimC", "nC", "nimRep", "nRep", "nimSeq", "nSeq",
   "diag",
   "length"
 )

nimbleModel/R/indexRuleArbitrary.R

@@ -41,7 +41,7 @@ indexRuleArbitraryClass <- R6Class(
       if (any(NAs)) {
         values <- values[!NAs]
       }
-      return(values)
+      return(as.integer(values))
     },
     invertIDs = function(relativeNodeIDs) {
       unlist(setupResults$iRow2toIndices[relativeNodeIDs])

nimbleModel/R/indexRuleBlock.R

@@ -44,11 +44,11 @@ indexRuleBlockClass <- R6Class(
       return(setupResults$fromMax - setupResults$fromMin + 1)
     },
     getIDs = function(indexRange) {
-      init <- setupResults$fromMin + setupResults$offset
+      init <- as.integer(setupResults$fromMin + setupResults$offset)
       switch(class(indexRange)[1],
-             indexRangeScalarClass = indexRange$value - init + 1,
+             indexRangeScalarClass = as.integer(indexRange$value) - init + 1L,
              indexRangeSequenceClass = (indexRange$start - init + 1):(indexRange$end - init + 1),
-             indexRangeMatrixClass = c(indexRange$values) - init + 1,
+             indexRangeMatrixClass = as.integer(c(indexRange$values)) - init + 1L,
              stop("invalid type of indexRange provided for creating IDs")
              )
     },

nimbleModel/R/indexRuleConstant.R

@@ -57,7 +57,7 @@ indexRuleConstant_setup <- function(toIndexExprList,
         eval(toIndexExpr[[3]], envir = constants)
       )
     } else if (length(toIndexExpr) > 1 && toIndexExpr[[1]] == "nimC") {
-      toIndexExpr[[1]] <- quote(c) # `nimC` not readily available in series of environments.
+      toIndexExpr[[1]] <- quote(c) # `nC` not readily available in series of environments.
       toConstant <- indexRangeMatrixClass$new(as.matrix(eval(toIndexExpr, envir = constants)))
     } else {
       stop("input error in `", safeDeparse(toIndexExprList), "`.")

nimbleModel/R/modelDecl.R

@@ -351,8 +351,8 @@ modelDeclClass <- R6Class(
                 logProbExpr[[i]] <- logProbIndexValue
               }
             }
-            if (is.c(origIndex)) { # Handles new cases like `y[c(2,3,5)] ~ dmnorm(...)`.
-              if (origIndex[[1]] == "nimC") {
+            if (is.c(origIndex)) {    # Handles new cases like `y[c(2,3,5)] ~ dmnorm(...)`.
+              if (origIndex[[1]] == "nC") {
                 logProbExpr[[i]] <- origIndex[[2]]
               } else {
                 stop("unexpected input in `", safeDeparse(origIndex), "`.")

nimbleModel/R/model_utils.R

@@ -31,9 +31,9 @@ is.vectorized <- function(node) {
 
 is.c <- function(node) {
   if (is.character(node)) {
-    return(grepl("^nimC", node))
+    return(grepl("^(nC|nimC)", node))
   } else {
-    return("nimC" %in% all.names(node))
+    return("nC" %in% all.names(node) || "nimC" %in% all.names(node))
   }
 }
 

nimbleModel/R/nimbleModel.R

@@ -551,6 +551,7 @@ make_decl_method_nFxn <- function(f, name, returnType = "numericScalar") {
     argTypes = list(idx = "integerVector"),
     returnType = T(returnType),
     compileInfo = list(C_fun = Cfun),
+    control = list(changeKeywords = TRUE)
   )
   nFxn
 }

nimbleModel/R/nodeRules.R

@@ -174,22 +174,22 @@ declRuleClass <- R6Class(
               offset <- offset * lens[loop_idx + 1]
               indices[[loop_idx]] <- (individualLoopIDs[[loop_idx]] - 1) * offset
             }
-            nodeIDs <- rowSums(do.call(expand.grid, rev(indices))) # Use `rev` to avoid need to sort.
+            nodeIDs <- as.integer(rowSums(do.call(expand.grid, rev(indices)))) # Use `rev` to avoid need to sort.
           } else {
             nodeIDs <- getOneLoopIDs(loopIndexingRange$indexRanges[[1]], indexingRules[[1]])
           }
         } else { # indexing range is non-separable: expand and then do arithmetic.
           inputIndices <- loopIndexingRange$extractIndexRange(seq_len(numLoops))$getValuesAsMatrix()
           indicesLast <- getOneLoopIDs(newIndexRange(inputIndices[, numLoops], sort = FALSE), indexingRules[[numLoops]])
-          indices <- matrix(0, nrow = length(indicesLast), ncol = numLoops)
+          indices <- matrix(0L, nrow = length(indicesLast), ncol = numLoops)
           indices[, numLoops] <- indicesLast
-          offset <- 1
-          lens <- sapply(indexingRules, \(x) x$getNumElements())
+          offset <- 1L
+          lens <- sapply(indexingRules, \(x) as.integer(x$getNumElements()))
           for (loop_idx in (numLoops - 1):1) {
             offset <- offset * lens[loop_idx + 1]
-            indices[, loop_idx] <- (getOneLoopIDs(newIndexRange(inputIndices[, loop_idx], sort = FALSE), indexingRules[[loop_idx]]) - 1) * offset
+            indices[, loop_idx] <- (getOneLoopIDs(newIndexRange(inputIndices[, loop_idx], sort = FALSE), indexingRules[[loop_idx]]) - 1L) * offset
           }
-          nodeIDs <- rowSums(indices)
+          nodeIDs <- as.integer(rowSums(indices))
         }
       } else { # Loop indexing is nonseparable. Fall back to expand and match, even if there are multiple (i.e., crossed) rules.
         fullIndices <- loopIndexingRule$apply(loopIndexingRule$varName)$extractIndexRange()$getValuesAsMatrix()

nimbleModel/tests/testthat/test-graphRules.R

@@ -2058,7 +2058,7 @@ test_that("non-sequential indexing in for loop or indexRule", {
         NULL
     )
 
-    rule <- graphRuleClass$new(toExpr = quote(y[nimC(2,3,5)]),
+    rule <- graphRuleClass$new(toExpr = quote(y[nC(2,3,5)]),
                                fromExpr = quote(x[1:3]),
                                context = context_0)
 

nimbleModel/tests/testthat/test-nimbleModel.R

@@ -738,24 +738,23 @@ test_that("non-sequential indexing cases", {
                    returnClass = TRUE)
   m <- mclass$new()
 
-  # No opDef for chol so comment out compiled operations.
-  # cmclass <- nCompile(mclass)
-  # cm <- cmclass$new()
+  cmclass <- nCompile(mclass)
+  cm <- cmclass$new()
   truth <- nCompiler:::dmnorm_chol(m$y[c(2,3,5)], rep(0,3), diag(3), log = TRUE)
   expect_equal(m$calculate(), truth)
   m$simulate('y', includeData = TRUE)
   expect_identical(y[c(1,4)], m$y[c(1,4)])
   expect_false(any(y[c(2,3,5)] == m$y[c(2,3,5)]))
-  # expect_equal(cm$calculate('y'), truth)
-  # cm$simulate(y, includeData = TRUE)
-  # expect_false(any(y[c(2,3,5)] == cm$y[c(2,3,5)]))
+  cm$calculate()  # To set lifted_chol.
+  expect_equal(cm$calculate('y'), truth)
+  cm$simulate('y', includeData = TRUE)
+  expect_false(any(y[c(2,3,5)] == cm$y[c(2,3,5)]))
 
   nr <- m$getNodes()[[2]]
   expect_true(inherits(nr$indexRanges[[1]], "indexRangeMatrixClass"))
   expect_identical(nr$numExternalIndexRanges, 0L)
   expect_identical(nr$toChar(), "`y[c(2, 3, 5)]`")
 
-  # Cannot compile. No operator def for nimC: This was part of the call:  y[i = nimC(2, 3, 5)]
   code <- nimbleCode({
       y[c(2,3,5)] <- x[1:3] + 1
   })
@@ -764,12 +763,12 @@ test_that("non-sequential indexing cases", {
   m <- mclass$new()
   m$calculate()
   expect_identical(m$y, c(NA,2,3,NA,4))
-  expect_error({
-      cmclass <- nCompile(mclass)
-      cm <- cmclass$new()
-      cm$calculate()
-      expect_identical(cm$y, c(NA,2,3,NA,4))
-  })
+  cmclass <- nCompile(mclass)
+  cm <- cmclass$new()
+  # cm$y <- rep(NA, 5)  # Otherwise, y[1],y[4] end up being 5e-310.
+  cm$calculate()
+  # TODO: NAs not being represented correctly.
+  expect_identical(cm$y[c(2,3,5)], c(2,3,4))
 
 })
 
@@ -1825,9 +1824,9 @@ test_that("duplication cases", {
     })
     set.seed(99)
     mclass <- nimbleModel(code, data = list(y=rnorm(3)), inits = list(z=rep(0,3),pr=diag(3)), returnClass = TRUE)
-    # cmclass <- nCompile(mclass)
+    cmclass <- nCompile(mclass)
     m <- mclass$new()
-    # cm <- cmclass$new()
+    cm <- cmclass$new()
 
     ## TODO: add compiled simulate when {d,r}mnorm_chol is resolved.
     m$calculate()
@@ -1841,6 +1840,18 @@ test_that("duplication cases", {
     m$simulate(nodes, includeData = TRUE)
     expect_identical(vals, m$y)
 
+    cm$calculate()
+    nodes <- c('y[1]','y[2]')
+    result <- sum(dnorm(cm$y,log=TRUE))
+    expect_equal(cm$calculate(nodes), result)
+
+    set.seed(1)
+    vals <- rnorm(3)
+    set.seed(1)
+    cm$simulate(nodes, includeData = TRUE)
+    expect_identical(vals, cm$y)
+
+
     # With SSM situation.
     code <- nimbleCode({
         for(i in 3:8) {

nimbleModel/tests/testthat/test-nodeIDs.R

@@ -86,7 +86,7 @@ test_that("basic tests of nodeIDs", {
   m <- nimbleModel(code)
   decl <- m$modelDef$declRules$y$rules[[1]]
 
-  expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[5]')), 5)
+  expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[5]')), 5L)
   expect_identical(decl$getLoopIndexingFromIDs(5)$toChar(),
                    'index 1: 5')
   expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[1:5]')), 1:5)
@@ -100,7 +100,7 @@ test_that("basic tests of nodeIDs", {
   expect_identical(decl$getLoopIndexingFromIDs(9:14)$toChar(),
                    'index 1: 9:14')
 
-  expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[c(2, 4)]')), c(2,4))
+  expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[c(2, 4)]')), c(2L,4L))
   expect_identical(decl$getLoopIndexingFromIDs(c(2,4))$toChar(),
                    'index 1: c(2, 4)')
 
@@ -136,7 +136,7 @@ test_that("basic tests of nodeIDs", {
   expect_identical(decl$getLoopIndexingFromIDs(3:5)$toChar(),
                    'index 1: 5:7')
 
-  expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[c(5,7)]')), c(3,5))
+  expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[c(5,7)]')), c(3L,5L))
   expect_identical(decl$getLoopIndexingFromIDs(c(3,5))$toChar(),
                    'index 1: c(5, 7)')
 
@@ -155,25 +155,25 @@ test_that("nodeIDs with multiple loops", {
   decl <- m$modelDef$declRules$y$rules[[1]]
 
   expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[2,4,3]')),
-                   38)
+                   38L)
   expect_identical(decl$getLoopIndexingFromIDs(38)$toChar(),
                    'index 1: 2, index 2: 4, index 3: 3')
 
-  ids <- as.numeric(c(28:30,33:35,38:40,48:50,53:55,58:60))
+  ids <- as.integer(c(28:30,33:35,38:40,48:50,53:55,58:60))
   expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[2:3,2:4,3:5]')),
                    ids)
   expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(),
                    'index 1: 2:3, index 2: 2:4, index 3: 3:5')
 
   # do with arbitrary subsetting, separable
-  ids <- c(8,10,13,15,18,20,48,50,53,55,58,60)
+  ids <- as.integer(c(8,10,13,15,18,20,48,50,53,55,58,60))
   expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[c(1,3),2:4,c(3,5)]')),
                    ids)
   expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(),
                    'index 1: c(1, 3), index 2: 2:4, index 3: c(3, 5)')
 
   # do with arbitrary subsetting, nonseparable
-  ids <- c(46,51,56, 30,35,40)
+  ids <- as.integer(c(46,51,56, 30,35,40))
   indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(quote(2:4)),
                                           newIndexRange(matrix(c(5,2,1,3),ncol=2,byrow=TRUE))),
                                      rangeToIndexSlot=list(2,c(3,1)))
@@ -192,7 +192,7 @@ test_that("nodeIDs with multiple loops", {
   m <- nimbleModel(code)
   decl <- m$modelDef$declRules$y$rules[[1]]
 
-  ids <- as.numeric(c(28:30,33:35,38:40,48:50,53:55,58:60))
+  ids <- as.integer(c(28:30,33:35,38:40,48:50,53:55,58:60))
   indexingRange <- decl$loopIndexingRule$apply('y[4:5,3:5,6:8]')
   expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids)
   expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(),
@@ -201,14 +201,14 @@ test_that("nodeIDs with multiple loops", {
 
   # do with arbitrary subsetting, separable
   indexingRange <- decl$loopIndexingRule$apply('y[c(3,5),3:5,c(6,8)]')
-  ids <- c(8,10,13,15,18,20,48,50,53,55,58,60)
+  ids <- as.integer(c(8,10,13,15,18,20,48,50,53,55,58,60))
   expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids)
   expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(),
                    'index 1: c(3, 5), index 2: 3:5, index 3: c(6, 8)')
 
 
   # do with arbitrary subsetting, nonseparable
-  ids <- c(46,51,56,30,35,40)
+  ids <- as.integer(c(46,51,56,30,35,40))
   indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(quote(3:5)),
                                           newIndexRange(matrix(c(8,4,4,5),ncol=2,byrow=TRUE))),
                                      rangeToIndexSlot=list(2,c(3,1)))
@@ -226,21 +226,21 @@ test_that("nodeIDs with multiple loops", {
   m <- nimbleModel(code)
   decl <- m$modelDef$declRules$y$rules[[1]]
 
-  ids <- as.numeric(c(28:30,33:35,38:40,48:50,53:55,58:60))
+  ids <- as.integer(c(28:30,33:35,38:40,48:50,53:55,58:60))
   indexingRange <- decl$loopIndexingRule$apply('y[c(5,7),3:5,c(14,16,18)]')
   expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids)
   expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(),
                    'index 1: c(5, 7), index 2: 3:5, index 3: c(14, 16, 18)')
 
   # do with arbitrary subsetting, separable
-  ids <- c(8,10,13,15,18,20,48,50,53,55,58,60)
+  ids <- as.integer(c(8,10,13,15,18,20,48,50,53,55,58,60))
   indexingRange <- decl$loopIndexingRule$apply('y[c(3,7),3:5,c(14,18)]')
   expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids)
   expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(),
                    'index 1: c(3, 7), index 2: 3:5, index 3: c(14, 18)')
 
   # do with arbitrary subsetting, nonseparable
-  ids <- c(46,51,56,30,35,40)
+  ids <- as.integer(c(46,51,56,30,35,40))
   indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(quote(3:5)),
                                           newIndexRange(matrix(c(18,5,10,7),ncol=2,byrow=TRUE))),
                                      rangeToIndexSlot=list(2,c(3,1)))
@@ -385,7 +385,7 @@ test_that("loop indexing with offsets", {
   m <- nimbleModel(code)
   decl <- m$modelDef$declRules$y$rules[[1]]
 
-  ids <- c(8,9,11,12)
+  ids <- as.integer(c(8,9,11,12))
   indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(quote(5:6)), newIndexRange(quote(3:4))))
   expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids)