From cebb550e6c06d4822f57b44255336c02aca30b9e Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Mon, 7 Sep 2026 11:10:51 -0700 Subject: [PATCH 1/2] Deduplicate nodes in `getNodes`, using `aggregate_nodes`. Fix bug in `aggregate_nodes` in handling `includeRHSonly=TRUE`. Fix up some remnant test failures from `names-by-cols` work (not sure why these were not already fixed). --- nimbleModel/R/instructions.R | 1 + nimbleModel/R/modelFunctions.R | 12 +++++++++-- nimbleModel/tests/testthat/test-modelClass.R | 10 +++------- nimbleModel/tests/testthat/test-modelGraph.R | 9 ++++----- nimbleModel/tests/testthat/test-nimbleModel.R | 19 ++++++++++++++---- nimbleModel/tests/testthat/test-nodeChars.R | 4 ++-- nimbleModel/tests/testthat/test-nodeIDs.R | 20 +++++++++---------- .../tests/testthat/test-setupMargNodes.R | 6 +++--- 8 files changed, 48 insertions(+), 33 deletions(-) diff --git a/nimbleModel/R/instructions.R b/nimbleModel/R/instructions.R index 35b7ccd..0f8b402 100644 --- a/nimbleModel/R/instructions.R +++ b/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, ]) diff --git a/nimbleModel/R/modelFunctions.R b/nimbleModel/R/modelFunctions.R index e469ab7..4de6a70 100644 --- a/nimbleModel/R/modelFunctions.R +++ b/nimbleModel/R/modelFunctions.R @@ -87,6 +87,8 @@ getNodes <- function(model, nodes, } } + 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 @@ -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 diff --git a/nimbleModel/tests/testthat/test-modelClass.R b/nimbleModel/tests/testthat/test-modelClass.R index ea85a2b..63fabc8 100644 --- a/nimbleModel/tests/testthat/test-modelClass.R +++ b/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, diff --git a/nimbleModel/tests/testthat/test-modelGraph.R b/nimbleModel/tests/testthat/test-modelGraph.R index 63aeba2..036dd09 100644 --- a/nimbleModel/tests/testthat/test-modelGraph.R +++ b/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) diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 2017c77..02ba833 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/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) @@ -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]')) + +}) diff --git a/nimbleModel/tests/testthat/test-nodeChars.R b/nimbleModel/tests/testthat/test-nodeChars.R index 2481fc8..e5a8a2d 100644 --- a/nimbleModel/tests/testthat/test-nodeChars.R +++ b/nimbleModel/tests/testthat/test-nodeChars.R @@ -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) diff --git a/nimbleModel/tests/testthat/test-nodeIDs.R b/nimbleModel/tests/testthat/test-nodeIDs.R index 8a61e04..7634ced 100644 --- a/nimbleModel/tests/testthat/test-nodeIDs.R +++ b/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)]") diff --git a/nimbleModel/tests/testthat/test-setupMargNodes.R b/nimbleModel/tests/testthat/test-setupMargNodes.R index b387b93..917455e 100644 --- a/nimbleModel/tests/testthat/test-setupMargNodes.R +++ b/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) From ae7cf1474d45881a39644cd3d8a5d7201874f489 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Mon, 7 Sep 2026 14:01:35 -0700 Subject: [PATCH 2/2] Fix some tests and resolve inconsistency with `unique=FALSE` for `expandNodeNames`. --- nimbleModel/R/modelFunctions.R | 10 +++++----- nimbleModel/tests/testthat/test-nimbleModel.R | 8 ++++---- nimbleModel/tests/testthat/test-nodeChars.R | 2 +- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/nimbleModel/R/modelFunctions.R b/nimbleModel/R/modelFunctions.R index 4de6a70..dd33a36 100644 --- a/nimbleModel/R/modelFunctions.R +++ b/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,7 +87,8 @@ getNodes <- function(model, nodes, } } - result <- aggregate_nodes(result) + if(.aggregate) + result <- aggregate_nodes(result) if (.sort) { # Ordering is only relevant at calcRange stage and a single nodeRange can contain @@ -160,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) } diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 02ba833..afeb506 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -1049,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({ diff --git a/nimbleModel/tests/testthat/test-nodeChars.R b/nimbleModel/tests/testthat/test-nodeChars.R index e5a8a2d..377f434 100644 --- a/nimbleModel/tests/testthat/test-nodeChars.R +++ b/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'))