diff --git a/nimbleModel/R/all_utils.R b/nimbleModel/R/all_utils.R index fd3e369..cb80a4a 100644 --- a/nimbleModel/R/all_utils.R +++ b/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) diff --git a/nimbleModel/R/context.R b/nimbleModel/R/context.R index b4d50bd..067753e 100644 --- a/nimbleModel/R/context.R +++ b/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) } diff --git a/nimbleModel/R/getSymbolicParentNodes.R b/nimbleModel/R/getSymbolicParentNodes.R index b3ed2f7..2bc51b7 100644 --- a/nimbleModel/R/getSymbolicParentNodes.R +++ b/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" ) diff --git a/nimbleModel/R/indexRuleArbitrary.R b/nimbleModel/R/indexRuleArbitrary.R index c8b5d53..3aad78b 100644 --- a/nimbleModel/R/indexRuleArbitrary.R +++ b/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]) diff --git a/nimbleModel/R/indexRuleBlock.R b/nimbleModel/R/indexRuleBlock.R index 4c0679e..c4bd34f 100644 --- a/nimbleModel/R/indexRuleBlock.R +++ b/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") ) }, diff --git a/nimbleModel/R/indexRuleConstant.R b/nimbleModel/R/indexRuleConstant.R index 440e4d4..77d8acd 100644 --- a/nimbleModel/R/indexRuleConstant.R +++ b/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), "`.") diff --git a/nimbleModel/R/modelDecl.R b/nimbleModel/R/modelDecl.R index eff0854..50f89ab 100644 --- a/nimbleModel/R/modelDecl.R +++ b/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), "`.") diff --git a/nimbleModel/R/model_utils.R b/nimbleModel/R/model_utils.R index fe39f1c..b36f9f0 100644 --- a/nimbleModel/R/model_utils.R +++ b/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)) } } diff --git a/nimbleModel/R/nimbleModel.R b/nimbleModel/R/nimbleModel.R index 4f03920..cb1d8dc 100644 --- a/nimbleModel/R/nimbleModel.R +++ b/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 } diff --git a/nimbleModel/R/nodeRules.R b/nimbleModel/R/nodeRules.R index e42c338..dfb349c 100644 --- a/nimbleModel/R/nodeRules.R +++ b/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() diff --git a/nimbleModel/tests/testthat/test-graphRules.R b/nimbleModel/tests/testthat/test-graphRules.R index aea01e6..e996582 100644 --- a/nimbleModel/tests/testthat/test-graphRules.R +++ b/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) diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 8845aeb..a581563 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/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) { diff --git a/nimbleModel/tests/testthat/test-nodeIDs.R b/nimbleModel/tests/testthat/test-nodeIDs.R index 5543d2e..9856601 100644 --- a/nimbleModel/tests/testthat/test-nodeIDs.R +++ b/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)