Deduplicate nodes in getNodes using aggregate_nodes

nimbleModel/R/instructions.R

@@ -193,6 +193,7 @@ makeInstrList <- function(model, input, includeData = TRUE, use_vec = FALSE) {
       rule$makeCalcRange(rule$apply(vr))
     })
   }))
+
   sortIDs <- lapply(ranges, \(x) x$sortID)
   sortIDranges <- sapply(sortIDs, \(x) range(x, na.rm = TRUE))
   multiSortID <- which(sortIDranges[1, ] != sortIDranges[2, ])

nimbleModel/R/modelFunctions.R

@@ -8,7 +8,7 @@ getNodes <- function(model, nodes,
                      includePredictive = TRUE, predictiveOnly = FALSE,
                      nodesAsChars = getNimbleModelOption("nodesAsChars"),
                      returnScalarComponents = FALSE,
-                     .sort = FALSE) {
+                     .sort = FALSE, .aggregate = TRUE) {
   if (!missing(nodes) && is.null(nodes)) {
     return(nodes)
   }
@@ -87,6 +87,9 @@ getNodes <- function(model, nodes,
     }
   }
 
+  if(.aggregate)
+    result <- aggregate_nodes(result)
+
   if (.sort) {
     # Ordering is only relevant at calcRange stage and a single nodeRange can contain
     # elements with various sortIDs, so we convert to nodeChars first and then get their
@@ -158,9 +161,8 @@ expandNodeNames <- function(model, nodes, returnScalarComponents = FALSE,
   }
   result <- getNodes(model, nodes,
     includeRHSonly = TRUE, nodesAsChars = TRUE,
-    returnScalarComponents = returnScalarComponents, .sort = sort
-  )
-  if (unique) result <- unique(result)
+    returnScalarComponents = returnScalarComponents,
+    .sort = sort, .aggregate = unique)
   return(result)
 }
 
@@ -224,7 +226,13 @@ aggregate_nodes <- function(nodeSet) {
   if (is.character(nodeSet) || !is.list(nodeSet)) {
     stop("`nodeSet` must be a list of nodeRanges")
   }
-  declIDs <- sapply(nodeSet, \(x) x$decl$declRule$ID)
+  declIDs <- lapply(nodeSet, \(x) x$decl$declRule$ID)
+
+  nullCases <- sapply(declIDs, is.null)
+  RHSonly <- nodeSet[nullCases]
+
+  nodeSet <- nodeSet[!nullCases]
+  declIDs <- unlist(declIDs[!nullCases])
   nodeIDs <- lapply(nodeSet, \(x) x$getIDs())
   IDsByDecl <- lapply(split(nodeIDs, declIDs), \(x) unique(nimbleModel:::flatten(x)))
   nms <- names(IDsByDecl)
@@ -235,7 +243,7 @@ aggregate_nodes <- function(nodeSet) {
       decl$declRule$getOriginalIndexing(IDsByDecl[[i]]), decl
     ))
   })
-  return(newNodeSet)
+  return(c(newNodeSet, RHSonly))
 }
 
 #' @export

nimbleModel/tests/testthat/test-modelClass.R

@@ -230,15 +230,11 @@ test_that("getNodes with data or predictive works", {
 
     result <- getNodes(m, includePredictive = FALSE)
     resultNames <- sapply(result, nimbleModel:::getVarName)
-    expect_length(result, 8)
+    expect_length(result, 6)
     expect_equal(result[[which(resultNames == 'z')[1]]]$indexRanges,
-                 list(newIndexRange(quote(1:5))))
-    expect_equal(result[[which(resultNames == 'z')[2]]]$indexRanges,
-                 list(newIndexRange(quote(9:10))))
+                 list(newIndexRange(c(1:5, 9:10))))
     expect_equal(result[[which(resultNames == 'mu_z')[1]]]$indexRanges,
-                 list(newIndexRange(quote(1:5))))
-    expect_equal(result[[which(resultNames == 'mu_z')[2]]]$indexRanges,
-                 list(newIndexRange(quote(9:10))))
+                 list(newIndexRange(c(1:5, 9:10))))
     expect_equal(result[[which(resultNames == 'y')]]$indexRanges,
                  list(newIndexRange(quote(1:10))))
     expect_equal(result[[which(resultNames == 'mu_y')]]$indexRanges,

nimbleModel/tests/testthat/test-modelGraph.R

@@ -1204,7 +1204,7 @@ test_that("basic check of graph interface", {
                      c('theta'))
     result <- getNodes(model, c('theta','y'))
     expect_identical(sapply(result, function(node) node$varName),
-                     c('theta','y'))
+                     c('y','theta'))
 
     result <- getDependencies(model$modelDef, 'mu0')
     expect_identical(sapply(result, function(node) node$varName),
@@ -1375,7 +1375,7 @@ test_that("basic hierarchical models", {
 
     result <- getNodes(model, c('z[1:5]', 'mu'))
     expect_identical(sapply(result, function(node) node$varName),
-                     c('z','mu'))
+                     c('mu','z'))
 
     result <- getNodes(model, topOnly = TRUE)
     expect_identical(sapply(result, function(node) node$varName),
@@ -1668,9 +1668,8 @@ test_that("state-space model", {
                      list(newIndexRange(1)))
 
     result <- getNodes(model, latentOnly = TRUE)
-    expect_length(result, 3)
-    expect_identical(sapply(result, function(node) node$varName),
-                     rep('z',3))
+    expect_length(result, 1)
+    expect_identical(result[[1]]$varName, 'z')
 
     result <- getDependencies(modelDef, 'z')
     expect_length(result, 3)

nimbleModel/tests/testthat/test-nimbleModel.R

@@ -621,7 +621,6 @@ test_that("five index slots", {
                             rangeToIndexSlot = list(1, c(2,4,5), 3),
                             varName = 'y')
     inds <- vr$extractIndexRange(1:5)$values
-    inds <- inds[order(inds[,1],inds[,5],inds[,3]),]  # ordering is based on index sets
     truth <- sum(dnorm(m$y[inds], log=TRUE))
     expect_equal(m$calculate(vr), truth)
     expect_equal(cm$calculate(vr), truth)
@@ -1050,25 +1049,25 @@ test_that("basic creation of list of instr_nClass objects", {
     expect_identical(instr0$lens, 1)
     expect_identical(length(instr0$values), 0L)
     expect_identical(instr0$index_types, 0)
-    expect_identical(instr0$type, 0)
+    expect_identical(instr0$instr_type, 0)
 
     instr1 <- makeInstrList(m, 'y[3:4]')[[1]]
     expect_identical(instr1$lens, 2)
     expect_identical(instr1$values[[1]], 3) # offset
     expect_identical(instr1$index_types, 1)
-    expect_identical(instr1$type, 1)
+    expect_identical(instr1$instr_type, 1)
 
     instr2 <- makeInstrList(m, c('y[c(2,5)]'))[[1]]
     expect_identical(instr2$lens, 2)
     expect_identical(instr2$values[[1]], c(2,5))
     expect_identical(instr2$index_types, 2)
-    expect_identical(instr2$type, 2)
+    expect_identical(instr2$instr_type, 2)
 
     instr2 <- makeInstrList(m, varRangeClass$new(list(newIndexRange(matrix(c(2,5), ncol=1))), varName='y'))[[1]]
     expect_identical(instr2$lens, 2)
     expect_identical(instr2$values[[1]], c(2,5))
     expect_identical(instr2$index_types, 2)
-    expect_identical(instr2$type, 2)
+    expect_identical(instr2$instr_type, 2)
 
     ## This does some testing of multiple index cases but could be fleshed out further.
     code <- quote({
@@ -1682,8 +1681,20 @@ test_that("non-constant block indexing", {
     expect_identical(model$getLogProb('y'), truth) 
 })
 
+
+test_that("duplication cases", {
+    code <- nimbleCode({
+        for(i in 1:3)
+            y[i] ~ dnorm(0,1)
+        z[1:3] ~ dmnorm(mu[1:3], pr[1:3,1:3])
+    })
+    set.seed(1)
+    m <- nimbleModel(code, data = list(y=rnorm(3), z=rnorm(3)))
 
-
-
-
+    expect_identical(m$getNodes(c('y[1]','y[1]', 'y[2]'), nodesAsChars = TRUE),
+                     c('y[1]','y[2]'))
 
+    expect_identical(m$getNodes(c('z[1]','z[2]'), nodesAsChars = TRUE),
+                     c('z[1:3]'))
+
+})

nimbleModel/tests/testthat/test-nodeChars.R

@@ -72,7 +72,7 @@ test_that("old model API calls", {
   expect_identical(chars, c("x", "mu", "lifted_mu_plus_x", "y[1, 1]","y[2, 1]","y[1, 2]", "y[2, 2]", "y[1, 3]", "y[2, 3]"))
 
   chars <- m$expandNodeNames(c('mu','y','x'))
-  expect_identical(chars, c("mu", "y[1, 1]","y[2, 1]","y[1, 2]", "y[2, 2]", "y[1, 3]", "y[2, 3]", "x"))
+  expect_identical(chars, c("y[1, 1]","y[2, 1]","y[1, 2]", "y[2, 2]", "y[1, 3]", "y[2, 3]", "mu", "x"))
   chars <- m$expandNodeNames(c('mu','y','x'), sort = TRUE)
   expect_identical(chars, c("x", "mu", "y[1, 1]","y[2, 1]","y[1, 2]", "y[2, 2]", "y[1, 3]", "y[2, 3]"))
   chars <- m$topologicallySortNodes(c('mu','y','x'))
@@ -217,9 +217,9 @@ test_that("Use of .sort in cases with multiple and/or overlapping sortID values"
     y[1] ~ dnorm(0,1)
   })
   m <- nimbleModel(code)
-  truth <- c("y[1]", "tau", "lifted_rho_times_y_oBi_minus_1_cB_L2[2]","lifted_d1_over_sqrt_oPtau_cP", "y[2]", "lifted_rho_times_y_oBi_minus_1_cB_L2[3]", "y[3]", "lifted_rho_times_y_oBi_minus_1_cB_L2[4]","y[4]" ,"lifted_rho_times_y_oBi_minus_1_cB_L2[5]","y[5]" , "lifted_rho_times_y_oBi_minus_1_cB_L2[6]","y[6]")
+  truth <- c("tau", "y[1]", "lifted_rho_times_y_oBi_minus_1_cB_L2[2]","lifted_d1_over_sqrt_oPtau_cP", "y[2]", "lifted_rho_times_y_oBi_minus_1_cB_L2[3]", "y[3]", "lifted_rho_times_y_oBi_minus_1_cB_L2[4]","y[4]" ,"lifted_rho_times_y_oBi_minus_1_cB_L2[5]","y[5]" , "lifted_rho_times_y_oBi_minus_1_cB_L2[6]","y[6]")
   expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), truth)
-  expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE, self = TRUE), truth)
+  expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE, self = TRUE), truth[c(2,1,3:length(truth))])  # Not clear why getParents reverses y[1] and tau, but it's not material and will change possibly once getParents calls getNodes.
   expect_identical(m$getParents('y[4]', .sort=TRUE, nodesAsChars = TRUE, self = TRUE), c('tau','lifted_d1_over_sqrt_oPtau_cP','y[3]','lifted_rho_times_y_oBi_minus_1_cB_L2[4]', 'y[4]'))
   nrs <- m$getNodes()
   expect_identical(m$topologicallySortNodes(nrs), truth)

nimbleModel/tests/testthat/test-nodeIDs.R

@@ -173,13 +173,13 @@ test_that("nodeIDs with multiple loops", {
                    'y[c(1, 3), 2:4, c(3, 5)]')
 
   # do with arbitrary subsetting, nonseparable
-  ids <- c(30,35,40,46,51,56)
+  ids <- c(46,51,56, 30,35,40)
   indexingRange <- varRangeClass$new(list(newIndexRange(quote(2:4)),
                                           newIndexRange(matrix(c(5,2,1,3),ncol=2,byrow=TRUE))),
                                      rangeToIndexSlot=list(2,c(3,1)), varName = 'y')
   expect_identical(decl$getIDs(indexingRange), ids)
   expect_identical(decl$getOriginalIndexing(ids)$extractIndexRange(1:3)$getValuesAsMatrix(),
-                   matrix(c(rep(2,3), rep(3,3), 2:4,2:4, rep(5,3), rep(1,3)), ncol = 3)) 
+                   matrix(c(rep(3,3), rep(2,3), 2:4,2:4, rep(1,3), rep(5,3)), ncol = 3)) 
 
 
   code <- nimbleCode({
@@ -208,13 +208,13 @@ test_that("nodeIDs with multiple loops", {
 
 
   # do with arbitrary subsetting, nonseparable
-  ids <- c(30,35,40,46,51,56)
+  ids <- c(46,51,56,30,35,40)
   indexingRange <- varRangeClass$new(list(newIndexRange(quote(3:5)),
                                           newIndexRange(matrix(c(8,4,4,5),ncol=2,byrow=TRUE))),
                                      rangeToIndexSlot=list(2,c(3,1)), varName = 'y')
   expect_identical(decl$getIDs(indexingRange), ids)
   expect_identical(decl$getOriginalIndexing(ids)$extractIndexRange(1:3)$getValuesAsMatrix(),
-                   matrix(c(rep(4,3), rep(5,3), 3:5,3:5, rep(8,3), rep(4,3)), ncol = 3)) 
+                   matrix(c(rep(5,3), rep(4,3), 3:5,3:5, rep(4,3), rep(8,3)), ncol = 3)) 
 
   code <- nimbleCode({
     for(i in c(3,5,7))
@@ -240,13 +240,13 @@ test_that("nodeIDs with multiple loops", {
                    'y[c(3, 7), 3:5, c(14, 18)]')
 
   # do with arbitrary subsetting, nonseparable
-  ids <- c(30,35,40,46,51,56)
+  ids <- c(46,51,56,30,35,40)
   indexingRange <- varRangeClass$new(list(newIndexRange(quote(3:5)),
                                           newIndexRange(matrix(c(18,5,10,7),ncol=2,byrow=TRUE))),
                                      rangeToIndexSlot=list(2,c(3,1)), varName = 'y')
   expect_identical(decl$getIDs(indexingRange), ids)
   expect_identical(decl$getOriginalIndexing(ids)$extractIndexRange(1:3)$getValuesAsMatrix(),
-                   matrix(c(rep(5,3), rep(7,3), 3:5,3:5, rep(18,3), rep(10,3)), ncol = 3))
+                   matrix(c(rep(7,3), rep(5,3), 3:5,3:5, rep(10,3), rep(18,3)), ncol = 3))
 
 })
 
@@ -308,13 +308,13 @@ test_that("nonseparable loop indexing cases", {
   m <- nimbleModel(code)
   decl <- m$modelDef$declRules$y$rules[[1]]
 
-  ids <- c(2L, 4L)
+  ids <- c(4L, 5L)
   indexingRange <- varRangeClass$new(list(newIndexRange(matrix(c(1,101,2,101),ncol=2,byrow=TRUE))),varName='y')
   expect_identical(decl$getIDs(indexingRange), ids)
   expect_identical(decl$getOriginalIndexing(ids)$extractIndexRange(1:2)$getValuesAsMatrix(),
                    matrix(c(1:2,101, 101),ncol=2))
 
-  ids <- 4L
+  ids <- 5L
   indexingRange <- varRangeClass$new(list(newIndexRange(matrix(c(2,101),ncol=2,byrow=TRUE))),varName='y')
   expect_identical(decl$getIDs(indexingRange), ids)
   expect_identical(decl$getOriginalIndexing(ids)$toChar(), "y[c(2, 101)]")
@@ -333,9 +333,9 @@ test_that("nonseparable loop indexing cases", {
   ids <- 1:24
   indexingRange <- decl$originalIndexingRule$apply('y')
   expect_identical(decl$getIDs(indexingRange), ids)
-  expect_identical(decl$getOriginalIndexing(11:12)$extractIndexRange(1:3)$getValuesAsMatrix(), matrix(c(2,2,2,2,1,2),ncol=3))
+  expect_identical(decl$getOriginalIndexing(c(3,15))$extractIndexRange(1:3)$getValuesAsMatrix(), matrix(c(2,2,2,2,1,2),ncol=3))
 
-  ids <- 12L
+  ids <- 15L
   indexingRange <- varRangeClass$new(list(newIndexRange(matrix(c(2,2,2),ncol=3,byrow=TRUE))),varName='y')
   expect_identical(decl$getIDs(indexingRange), ids)
   expect_identical(decl$getOriginalIndexing(ids)$toChar(), "y[c(2, 2, 2)]")

nimbleModel/tests/testthat/test-setupMargNodes.R

@@ -176,7 +176,7 @@ test_that("getConditionallyIndependentSets works in model with one set and deter
 
   SMN <- setupMargNodes(m, paramNodes = "REA1")
   expect_identical(SMN$randomEffectsNodes[[1]]$toNodeChars(), c('REA2'))
-  expect_identical(unlist(lapply(SMN$calcNodes, \(x) x$toNodeChars())), c('REA2','D3','D3C3','Y1'))
+  expect_identical(unlist(lapply(SMN$calcNodes, \(x) x$toNodeChars())), c('D3C3','Y1','REA2','D3'))
 
   SMN <- setupMargNodes(m, calcNodes = m$getDependencies("REB2"))
   expect_identical(unlist(lapply(SMN$paramNodes, \(x) x$toNodeChars())), c("REA2", "REB1"))
@@ -216,7 +216,7 @@ test_that("getConditionallyIndependentSets works in state-space model with a cou
 
   SMN <- setupMargNodes(m)
   expect_identical(SMN$paramNodes[[1]]$toNodeChars(), "x[1]")
-  expect_identical(unlist(lapply(SMN$randomEffectsNodes, \(x) x$toNodeChars())), c("x[4]","x[2]","x[3]"))
+  expect_identical(unlist(lapply(SMN$randomEffectsNodes, \(x) x$toNodeChars())), c("x[2]","x[3]","x[4]"))
 
   SMN <- setupMargNodes(m, randomEffectsNodes = 'x[1:4]')
   expect_identical(SMN$paramNodes, NULL)
@@ -259,7 +259,7 @@ test_that("getConditionallyIndependentSets works in double-state state-space mod
   expect_identical(getConditionallyIndependentSets(m, givenNodes = c("y", "w[3]"), unknownAsGiven=FALSE),
                    list(c("x[1]", "w[1]", "x[2]", "x[3]", "x[4]", "w[2]", "w[4]")))
   expect_identical(getConditionallyIndependentSets(m, givenNodes = c("y", "x[3]", "w[3]"), unknownAsGiven=FALSE),
-                   list(c("x[4]", "w[4]"), c("x[1]", "w[1]", "x[2]", "w[2]")))
+                   list(c("x[1]", "w[1]", "x[2]", "w[2]"), c("x[4]", "w[4]")))
   expect_true(nimble:::testConditionallyIndependentSets(m, getConditionallyIndependentSets(m)))
 
   SMN <- setupMargNodes(m)