From de0e47ce611cf72adccfba0ab76963fc48b7bb77 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Tue, 7 Jul 2026 08:39:48 -0700 Subject: [PATCH 01/10] Make initial updates to get{Deps,Parents} to handle sorting. --- nimbleModel/R/modelBaseClass.R | 8 +-- nimbleModel/R/modelDef.R | 14 ++-- nimbleModel/R/processModelGraph.R | 57 +++++++++++++-- nimbleModel/tests/testthat/test-nodeChars.R | 77 ++++++++++++++++++++- 4 files changed, 137 insertions(+), 19 deletions(-) diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index 5733e51..d58bfe5 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -360,17 +360,17 @@ modelBase_nClass <- nClass( }, getDependencies = function(nodes, self = TRUE, downstream = FALSE, immediateOnly = FALSE, nodesAsChars = getNimbleModelOption('nodesAsChars'), - returnScalarComponents = FALSE + returnScalarComponents = FALSE, .sort = FALSE ) { nimbleModel::getDependencies(modelDef, nodes, self, downstream, immediateOnly, - nodesAsChars, returnScalarComponents) + nodesAsChars, returnScalarComponents, .sort) }, getParents = function(nodes, self = TRUE, upstream = FALSE, immediateOnly = FALSE, nodesAsChars = getNimbleModelOption('nodesAsChars'), - returnScalarComponents = FALSE + returnScalarComponents = FALSE, .sort = FALSE ) { nimbleModel::getParents(modelDef, nodes, self, upstream, immediateOnly, - nodesAsChars, returnScalarComponents) + nodesAsChars, returnScalarComponents, .sort) }, # TODO: not working because `nimbleModel::getNodes` needs the model not just modelDef. # Once we integrate modelClass with modelBase_nClass, we should be able to pass `self`. diff --git a/nimbleModel/R/modelDef.R b/nimbleModel/R/modelDef.R index 43f63cf..068caa0 100644 --- a/nimbleModel/R/modelDef.R +++ b/nimbleModel/R/modelDef.R @@ -1039,28 +1039,30 @@ getDependencies <- function(modelDef, nodes, self = TRUE, downstream = FALSE, immediateOnly = FALSE, nodesAsChars = getNimbleModelOption('nodesAsChars'), - returnScalarComponents = FALSE + returnScalarComponents = FALSE, .sort = FALSE ) { traverseGraph(modelDef$downstreamRules, modelDef$declRules, nodes = nodes, down = TRUE, self = self, follow = downstream, immediateOnly = immediateOnly, - nodesAsChars = nodesAsChars, returnScalarComponents = returnScalarComponents - ) + nodesAsChars = nodesAsChars, returnScalarComponents = returnScalarComponents, + .sort = .sort, modelDef = modelDef + ) } getParents <- function(modelDef, nodes, self = FALSE, upstream = FALSE, immediateOnly = FALSE, nodesAsChars = getNimbleModelOption('nodesAsChars'), - returnScalarComponents = FALSE + returnScalarComponents = FALSE, .sort = FALSE ) { traverseGraph(modelDef$upstreamRules, modelDef$declRules, nodes = nodes, down = FALSE, self = self, follow = upstream, immediateOnly = immediateOnly, - nodesAsChars = nodesAsChars, returnScalarComponents = returnScalarComponents - ) + nodesAsChars = nodesAsChars, returnScalarComponents = returnScalarComponents, + .sort = .sort, modelDef = modelDef + ) } diff --git a/nimbleModel/R/processModelGraph.R b/nimbleModel/R/processModelGraph.R index 900c663..81781c7 100644 --- a/nimbleModel/R/processModelGraph.R +++ b/nimbleModel/R/processModelGraph.R @@ -242,8 +242,15 @@ traverseGraph <- function(streamRules, declRules, nodes, down, self = TRUE, follow = FALSE, immediateOnly = FALSE, nodesAsChars = getNimbleModelOption('nodesAsChars'), - returnScalarComponents = FALSE + returnScalarComponents = FALSE, .sort = FALSE, + modelDef = NULL ) { + + # A single varRange can have elements that don't share a sortID when converted to calcRange representation, + # so we can't sort varRanges. + if (.sort && !nodesAsChars) + warning("`.sort=TRUE` is provided only for back compatibility and requires the use of character representations of nodes") + if (inherits(nodes, "varRangeClass")) nodes <- list(nodes) # We use `lapply` on 'nodes' later. results <- traverseGraphRecurse(streamRules, nodes, down, follow, immediateOnly) @@ -323,12 +330,50 @@ traverseGraph <- function(streamRules, declRules, return(NULL) } results <- removeDuplicateVarRanges(results) - if (nodesAsChars) { - return(unlist(sapply(results, \(x) x$toVarChars(expandScalars = returnScalarComponents)))) + + 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 + # sortID by creating a temporary calcRange for each. + varChars <- unlist(sapply(results, \(x) x$toVarChars())) + + rangeInfo <- flatten(lapply(varChars, function(varChar) { + lapply(modelDef$calcRules[[getVarName(varChar)]]$rules, function(rule) { + nodeRange <- rule$apply(varChar) + if(is.null(nodeRange)) return(NULL) + calcRange <- rule$makeCalcRange(nodeRange) + return(list(varChar = nodeRange$toVarChars(), calcRange = calcRange)) + }) + })) + + varChars <- sapply(rangeInfo, \(x) x$varChar) + calcRanges <- lapply(rangeInfo, \(x) x$calcRange) + + # TODO: this omits RHSonly cases. Should not be necessary when we fix traverseGraph to always omit those. + # varChars <- varChars[sapply(calcRanges, \(x) length(x) > 0)] + + # We can have overlapping sortIDs in cases with sequential dependence amongst variables. + # Here we avoid the unrolling that we do in `makeInstructionList`, as that is slow, but warn user. + sortIDs <- lapply(calcRanges, \(x) x$sortID) + sortIDranges <- sapply(sortIDs, \(x) range(x, na.rm = TRUE)) + ord <- order(sortIDranges[1,]) + sortIDranges <- sortIDranges[,ord] + multiSortID <- which(sortIDranges[1,] != sortIDranges[2,]) + for(i in multiSortID) + if(any(sortIDranges[2,-i] > sortIDranges[1,i] & sortIDranges[1,-i] < sortIDranges[2,i])) + messageIfVerbose("elements of the ", i, "th varRange overlap with other varRanges in terms of their sort order, so the resulting varRanges cannot be fully sorted") + + results <- varChars[ord] + if (returnScalarComponents) + results <- unlist(lapply(results, \(x) varRangeClass$new(x)$toVarChars(expandScalars = TRUE))) } else { - if (returnScalarComponents) # TODO: put into new messaging system - warning("one must request result as characters via `nodesAsChars` in order to use `returnScalarComponents`") - } + if (nodesAsChars) { + return(unlist(lapply(results, \(x) x$toVarChars(expandScalars = returnScalarComponents)))) + } else { + if (returnScalarComponents) # TODO: put into new messaging system + warning("one must request result as characters via `nodesAsChars` in order to use `returnScalarComponents`") + } + } return(results) } diff --git a/nimbleModel/tests/testthat/test-nodeChars.R b/nimbleModel/tests/testthat/test-nodeChars.R index 6203eac..d85eb70 100644 --- a/nimbleModel/tests/testthat/test-nodeChars.R +++ b/nimbleModel/tests/testthat/test-nodeChars.R @@ -49,9 +49,6 @@ test_that("use of nodes as characters", { }) test_that("old model API calls", { - library(nimbleModel) - library(testthat) - code <- nimbleCode({ for(i in 1:2) for(j in 1:3) @@ -181,4 +178,78 @@ test_that("old model API calls", { expect_identical(chars, c("y[1, 1]","y[1, 2]","y[2, 1]","y[2, 2]","y[3, 1]","y[3, 2]", "y[4, 1]", "y[4, 2]")) chars <- m$expandNodeNames('y',returnScalarComponents=TRUE,sort=TRUE) expect_identical(chars, c("y[4, 1]","y[4, 2]","y[3, 1]","y[3, 2]", "y[2, 1]","y[2, 2]","y[1, 1]","y[1, 2]")) + + # Check on getDependencies/getParents. + code <- nimbleCode({ + for(i in 1:5) + y[i] ~ dnorm(mu, tau) + tau ~ dunif(0,1) + }) + m <- nimbleModel(code) + expect_identical(m$getDependencies(c('y','tau'), .sort = TRUE, nodesAsChars = TRUE), + c("tau", "lifted_d1_over_sqrt_oPtau_cP", "y[1:5]")) + expect_identical(m$getParents('y', .sort = TRUE, nodesAsChars = TRUE), + c("tau", "lifted_d1_over_sqrt_oPtau_cP", "y[1:5]")) + expect_identical(m$getParents('y', .sort = TRUE, nodesAsChars = TRUE, returnScalarComponents = TRUE), + c("tau", "lifted_d1_over_sqrt_oPtau_cP", paste0("y[", 1:5, "]"))) +}) + +test_that("Use of .sort in cases with multiple and/or overlapping sortID values" { + library(nimbleModel); library(testthat) + + code <- nimbleCode({ + for(i in 2:6) + y[i]~dnorm(y[i-1], tau) + tau ~ dunif(0,1) + y[1] ~ dnorm(0,1) + }) + m <- nimbleModel(code) + # BUG: this is giving incorrect warning based on multiple sortID + expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), + c("tau","lifted_d1_over_sqrt_oPtau_cP",paste0("y[", 1:6, "]"))) + expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), + c('tau','y[1]','lifted_d1_over_sqrt_oPtau_cP','y[2]','y[6]')) + + code <- nimbleCode({ + for(i in 2:6) + y[i]~dnorm(rho*y[i-1], tau) # lifted node introduced + tau ~ dunif(0,1) + y[1] ~ dnorm(0,1) + }) + m <- nimbleModel(code) + # BUG: this is giving incorrect warning based on multiple sortID + # also incorrect results + # m$getNodes(.sort=TRUE,nodesAsChars=TRUE) + expect_warning(parents <- m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), + "overlap with other varRanges") + # check on parents + + code <- nimbleCode({ + for(i in 1:5) + y[i]~dnorm(rho*y[i+1], tau) + tau ~ dunif(0,1) + rho ~ dunif(0,1) + y[6] ~ dnorm(0,1) + }) + m <- nimbleModel(code) + # BUG: this is giving incorrect warning based on multiple sortID + # also incorrect results + # m$getNodes(.sort=TRUE,nodesAsChars=TRUE) + m$getParents('y', .sort=TRUE, nodesAsChars = TRUE) + + code <- nimbleCode({ + for(i in 1:5) + y[i]~dnorm(mu[i], tau) + for(i in 2:5) + mu[i] ~ dnorm(mu[i-1],tau) + tau ~ dunif(0,1) + }) + m <- nimbleModel(code) + + m$getNodes(.sort=TRUE,nodesAsChars=TRUE) + m$getDependencies('tau', .sort=TRUE,nodesAsChars=TRUE) + m$getParents('y', .sort=TRUE, nodesAsChars = TRUE) + }) + + From 1b5b481c308203d1ac3d8c156d16a730f5aa8b36 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Tue, 7 Jul 2026 09:09:24 -0700 Subject: [PATCH 02/10] Fix makeCalcRange to correctly subset sortID when not working with full range. --- nimbleModel/tests/testthat/test-nodeRules.R | 29 ++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/nimbleModel/tests/testthat/test-nodeRules.R b/nimbleModel/tests/testthat/test-nodeRules.R index ab5d22c..dcc3c86 100644 --- a/nimbleModel/tests/testthat/test-nodeRules.R +++ b/nimbleModel/tests/testthat/test-nodeRules.R @@ -496,7 +496,34 @@ test_that("calcRanges are generated correctly", { ))) expect_equal(calcRange$indexingRange, varRangeClass$new(list(newIndexRange(matrix(c(1,2,2,2,1,1,2,3), ncol = 2))), - varName = 'y')) + varName = 'y')) + + # multi sortID case + code <- nimbleCode({ + for(i in 3:7) + y[i+1] ~ dnorm(y[i],1) + }) + m <- nimbleModel(code) + nr <- m$modelDef$calcRules$y$rules[['4']]$apply('y[6]') + expect_identical(m$modelDef$calcRules$y$rules[['4']]$makeCalcRange(nr)$sortID, 3) + nr <- m$modelDef$calcRules$y$rules[['4']]$apply('y[6:7]') + expect_identical(m$modelDef$calcRules$y$rules[['4']]$makeCalcRange(nr)$sortID, c(3,4)) + nr <- m$modelDef$calcRules$y$rules[['4']]$apply('y[c(5,7)]') + expect_identical(m$modelDef$calcRules$y$rules[['4']]$makeCalcRange(nr)$sortID, c(2,4)) + + code <- nimbleCode({ + for(i in 3:7) + for(j in 1:1) + y[j,i+1] ~ dnorm(y[j,i],1) + }) + m <- nimbleModel(code) + nr <- m$modelDef$calcRules$y$rules[['4']]$apply('y[1,6]') + expect_identical(m$modelDef$calcRules$y$rules[['4']]$makeCalcRange(nr)$sortID, 3) + nr <- m$modelDef$calcRules$y$rules[['4']]$apply('y[1,6:7]') + expect_identical(m$modelDef$calcRules$y$rules[['4']]$makeCalcRange(nr)$sortID, c(3,4)) + nr <- m$modelDef$calcRules$y$rules[['4']]$apply('y[1,c(5,7)]') + expect_identical(m$modelDef$calcRules$y$rules[['4']]$makeCalcRange(nr)$sortID, c(2,4)) + }) From 27afc8ea644c515ad396915dea578d8dab8cac4f Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Tue, 7 Jul 2026 10:01:01 -0700 Subject: [PATCH 03/10] Update get{Deps,Parents} when sorting to convert to nodes to be able to handle sorting with multiple sortID values. --- nimbleModel/R/processModelGraph.R | 42 ++++++---------- nimbleModel/tests/testthat/test-nodeChars.R | 56 ++++++++++++--------- 2 files changed, 47 insertions(+), 51 deletions(-) diff --git a/nimbleModel/R/processModelGraph.R b/nimbleModel/R/processModelGraph.R index 81781c7..85e3e1a 100644 --- a/nimbleModel/R/processModelGraph.R +++ b/nimbleModel/R/processModelGraph.R @@ -335,35 +335,23 @@ traverseGraph <- function(streamRules, declRules, # 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 # sortID by creating a temporary calcRange for each. - varChars <- unlist(sapply(results, \(x) x$toVarChars())) - - rangeInfo <- flatten(lapply(varChars, function(varChar) { - lapply(modelDef$calcRules[[getVarName(varChar)]]$rules, function(rule) { - nodeRange <- rule$apply(varChar) - if(is.null(nodeRange)) return(NULL) - calcRange <- rule$makeCalcRange(nodeRange) - return(list(varChar = nodeRange$toVarChars(), calcRange = calcRange)) + nodeChars <- unlist(lapply(results, \(vr) + lapply(modelDef$calcRules[[getVarName(vr)]]$rules, + \(rule) { + tmp <- rule$apply(vr) + if(!is.null(tmp)) return(tmp$toNodeChars()) else return(NULL) + } + ))) + calcRanges <- flatten(lapply(nodeChars, function(node) { + lapply(modelDef$calcRules[[getVarName(node)]]$rules, function(rule) { + rule$makeCalcRange(rule$apply(node)) }) })) - - varChars <- sapply(rangeInfo, \(x) x$varChar) - calcRanges <- lapply(rangeInfo, \(x) x$calcRange) - - # TODO: this omits RHSonly cases. Should not be necessary when we fix traverseGraph to always omit those. - # varChars <- varChars[sapply(calcRanges, \(x) length(x) > 0)] - - # We can have overlapping sortIDs in cases with sequential dependence amongst variables. - # Here we avoid the unrolling that we do in `makeInstructionList`, as that is slow, but warn user. - sortIDs <- lapply(calcRanges, \(x) x$sortID) - sortIDranges <- sapply(sortIDs, \(x) range(x, na.rm = TRUE)) - ord <- order(sortIDranges[1,]) - sortIDranges <- sortIDranges[,ord] - multiSortID <- which(sortIDranges[1,] != sortIDranges[2,]) - for(i in multiSortID) - if(any(sortIDranges[2,-i] > sortIDranges[1,i] & sortIDranges[1,-i] < sortIDranges[2,i])) - messageIfVerbose("elements of the ", i, "th varRange overlap with other varRanges in terms of their sort order, so the resulting varRanges cannot be fully sorted") - - results <- varChars[ord] + if (length(nodeChars) != length(calcRanges)) + stop("unexpected mismatch between node character representation and calcRanges in `getNodes` sorting") + ord <- order(sapply(calcRanges, \(x) x$sortID)) + results <- nodeChars[ord] + names(results) <- NULL if (returnScalarComponents) results <- unlist(lapply(results, \(x) varRangeClass$new(x)$toVarChars(expandScalars = TRUE))) } else { diff --git a/nimbleModel/tests/testthat/test-nodeChars.R b/nimbleModel/tests/testthat/test-nodeChars.R index d85eb70..e665821 100644 --- a/nimbleModel/tests/testthat/test-nodeChars.R +++ b/nimbleModel/tests/testthat/test-nodeChars.R @@ -199,16 +199,18 @@ test_that("Use of .sort in cases with multiple and/or overlapping sortID values" code <- nimbleCode({ for(i in 2:6) - y[i]~dnorm(y[i-1], tau) + y[i] ~ dnorm(y[i-1], tau) tau ~ dunif(0,1) y[1] ~ dnorm(0,1) }) m <- nimbleModel(code) - # BUG: this is giving incorrect warning based on multiple sortID expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), c("tau","lifted_d1_over_sqrt_oPtau_cP",paste0("y[", 1:6, "]"))) expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), - c('tau','y[1]','lifted_d1_over_sqrt_oPtau_cP','y[2]','y[6]')) + c('tau','y[1]','lifted_d1_over_sqrt_oPtau_cP',paste0('y[', 2:6, ']'))) + expect_identical(m$getParents('y[4]', .sort=TRUE, nodesAsChars = TRUE), + c('tau','lifted_d1_over_sqrt_oPtau_cP',paste0('y[', 3:4, ']'))) + code <- nimbleCode({ for(i in 2:6) @@ -217,38 +219,44 @@ test_that("Use of .sort in cases with multiple and/or overlapping sortID values" y[1] ~ dnorm(0,1) }) m <- nimbleModel(code) - # BUG: this is giving incorrect warning based on multiple sortID - # also incorrect results - # m$getNodes(.sort=TRUE,nodesAsChars=TRUE) - expect_warning(parents <- m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), - "overlap with other varRanges") - # check on parents + 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]") + expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), truth) + expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), truth) + expect_identical(m$getParents('y[4]', .sort=TRUE, nodesAsChars = TRUE), c('tau','lifted_d1_over_sqrt_oPtau_cP','y[3]','lifted_rho_times_y_oBi_minus_1_cB_L2[4]', 'y[4]')) + code <- nimbleCode({ for(i in 1:5) - y[i]~dnorm(rho*y[i+1], tau) + y[i]~dnorm(y[i+1], tau) tau ~ dunif(0,1) - rho ~ dunif(0,1) y[6] ~ dnorm(0,1) }) m <- nimbleModel(code) - # BUG: this is giving incorrect warning based on multiple sortID - # also incorrect results - # m$getNodes(.sort=TRUE,nodesAsChars=TRUE) - m$getParents('y', .sort=TRUE, nodesAsChars = TRUE) + expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), c('tau','lifted_d1_over_sqrt_oPtau_cP',paste0('y[',6:1,']')) + expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), c('tau','y[6]','lifted_d1_over_sqrt_oPtau_cP',paste0('y[',5:1,']'))truth) + expect_identical(m$getParents('y[4]', .sort=TRUE, nodesAsChars = TRUE), + c('tau','lifted_d1_over_sqrt_oPtau_cP','y[5]','y[4]')) + code <- nimbleCode({ - for(i in 1:5) - y[i]~dnorm(mu[i], tau) - for(i in 2:5) - mu[i] ~ dnorm(mu[i-1],tau) - tau ~ dunif(0,1) + for(i in 1:6) + y[i] <- z[i] + 1 + for(i in 2:6) + z[i] <- y[i-1] + .5 + z[1] <- 0 }) - m <- nimbleModel(code) + # m <- nimbleModel(code) # BUG that is fixed in sortID-vec + # TODO: work on this when BUG fix is incorporated into this branch. - m$getNodes(.sort=TRUE,nodesAsChars=TRUE) - m$getDependencies('tau', .sort=TRUE,nodesAsChars=TRUE) - m$getParents('y', .sort=TRUE, nodesAsChars = TRUE) + # check with mv case to see how written out + code <- nimbleCode({ + for(i in 2:6) + y[1:2,i]~dmnorm(y[1:2,i-1], pr[1:2,1:2]) + }) + m <- nimbleModel(code) + truth <- c("lifted_chol_oPpr_oB1to2_comma_1to2_cB_cP[1:2, 1:2]", paste0("y[1:2, ", 2:6, "]")) + expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), truth) + expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), truth) }) From fce7b487966f4319cad75cc6b4caa8e7634ba5ea Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Tue, 7 Jul 2026 11:22:07 -0700 Subject: [PATCH 04/10] Fix typo in test. --- nimbleModel/tests/testthat/test-nodeChars.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/nimbleModel/tests/testthat/test-nodeChars.R b/nimbleModel/tests/testthat/test-nodeChars.R index e665821..ac3f32e 100644 --- a/nimbleModel/tests/testthat/test-nodeChars.R +++ b/nimbleModel/tests/testthat/test-nodeChars.R @@ -194,9 +194,7 @@ test_that("old model API calls", { c("tau", "lifted_d1_over_sqrt_oPtau_cP", paste0("y[", 1:5, "]"))) }) -test_that("Use of .sort in cases with multiple and/or overlapping sortID values" { - library(nimbleModel); library(testthat) - +test_that("Use of .sort in cases with multiple and/or overlapping sortID values", { code <- nimbleCode({ for(i in 2:6) y[i] ~ dnorm(y[i-1], tau) From 8f22a10251d7480e2bbcff979808b48e3610c657 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 8 Jul 2026 09:52:23 -0700 Subject: [PATCH 05/10] Fix and add tests for sorting. --- nimbleModel/tests/testthat/test-nodeChars.R | 35 +++++++++++++-------- 1 file changed, 22 insertions(+), 13 deletions(-) diff --git a/nimbleModel/tests/testthat/test-nodeChars.R b/nimbleModel/tests/testthat/test-nodeChars.R index ac3f32e..4ca04a3 100644 --- a/nimbleModel/tests/testthat/test-nodeChars.R +++ b/nimbleModel/tests/testthat/test-nodeChars.R @@ -186,12 +186,11 @@ test_that("old model API calls", { tau ~ dunif(0,1) }) m <- nimbleModel(code) - expect_identical(m$getDependencies(c('y','tau'), .sort = TRUE, nodesAsChars = TRUE), - c("tau", "lifted_d1_over_sqrt_oPtau_cP", "y[1:5]")) - expect_identical(m$getParents('y', .sort = TRUE, nodesAsChars = TRUE), - c("tau", "lifted_d1_over_sqrt_oPtau_cP", "y[1:5]")) + truth <- c("tau", "lifted_d1_over_sqrt_oPtau_cP", paste0("y[", 1:5, "]")) + expect_identical(m$getDependencies(c('y','tau'), .sort = TRUE, nodesAsChars = TRUE), truth) + expect_identical(m$getParents('y', .sort = TRUE, nodesAsChars = TRUE), truth) expect_identical(m$getParents('y', .sort = TRUE, nodesAsChars = TRUE, returnScalarComponents = TRUE), - c("tau", "lifted_d1_over_sqrt_oPtau_cP", paste0("y[", 1:5, "]"))) + truth) }) test_that("Use of .sort in cases with multiple and/or overlapping sortID values", { @@ -230,21 +229,21 @@ test_that("Use of .sort in cases with multiple and/or overlapping sortID values" y[6] ~ dnorm(0,1) }) m <- nimbleModel(code) - expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), c('tau','lifted_d1_over_sqrt_oPtau_cP',paste0('y[',6:1,']')) - expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), c('tau','y[6]','lifted_d1_over_sqrt_oPtau_cP',paste0('y[',5:1,']'))truth) + expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), c('tau','lifted_d1_over_sqrt_oPtau_cP',paste0('y[',6:1,']'))) + expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), c('tau','y[6]','lifted_d1_over_sqrt_oPtau_cP',paste0('y[',5:1,']'))) expect_identical(m$getParents('y[4]', .sort=TRUE, nodesAsChars = TRUE), c('tau','lifted_d1_over_sqrt_oPtau_cP','y[5]','y[4]')) code <- nimbleCode({ - for(i in 1:6) - y[i] <- z[i] + 1 for(i in 2:6) - z[i] <- y[i-1] + .5 - z[1] <- 0 + y[i] ~ dnorm(rho * y[i-1], 1) + y[1] ~ dnorm(0,1) }) - # m <- nimbleModel(code) # BUG that is fixed in sortID-vec - # TODO: work on this when BUG fix is incorporated into this branch. +# truth <- c() +# expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), truth) +# expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), truth) + # check with mv case to see how written out code <- nimbleCode({ @@ -255,6 +254,16 @@ test_that("Use of .sort in cases with multiple and/or overlapping sortID values" truth <- c("lifted_chol_oPpr_oB1to2_comma_1to2_cB_cP[1:2, 1:2]", paste0("y[1:2, ", 2:6, "]")) expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), truth) expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), truth) + truth <- c( + paste0("lifted_chol_oPpr_oB1to2_comma_1to2_cB_cP[1, ", 1:2, "]"), + paste0("lifted_chol_oPpr_oB1to2_comma_1to2_cB_cP[2, ", 1:2, "]"), + paste0("y[", 1:2, ", 2]"), + paste0("y[", 1:2, ", 3]"), + paste0("y[", 1:2, ", 4]"), + paste0("y[", 1:2, ", 5]"), + paste0("y[", 1:2, ", 6]")) + expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE, returnScalarComponents = TRUE), truth) + expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE, returnScalarComponents = TRUE), truth) }) From 47be4a2bddbfea6c47861c7f139cac8e2c290f79 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 8 Jul 2026 10:05:16 -0700 Subject: [PATCH 06/10] Fix up some tests. --- nimbleModel/tests/testthat/test-nodeChars.R | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/nimbleModel/tests/testthat/test-nodeChars.R b/nimbleModel/tests/testthat/test-nodeChars.R index 4ca04a3..8c5e956 100644 --- a/nimbleModel/tests/testthat/test-nodeChars.R +++ b/nimbleModel/tests/testthat/test-nodeChars.R @@ -240,12 +240,13 @@ test_that("Use of .sort in cases with multiple and/or overlapping sortID values" y[i] ~ dnorm(rho * y[i-1], 1) y[1] ~ dnorm(0,1) }) -# truth <- c() -# expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), truth) -# expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), truth) - + m <- nimbleModel(code) + tmp1 <- paste0("y[", 1:6, "]") + tmp2 <- paste0("lifted_rho_times_y_oBi_minus_1_cB_L2[", 2:6, "]") + truth <- c(tmp1,tmp2)[c(1,7,2,8,3,9,4,10,5,11,6)] + expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), truth) + expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), truth) - # check with mv case to see how written out code <- nimbleCode({ for(i in 2:6) y[1:2,i]~dmnorm(y[1:2,i-1], pr[1:2,1:2]) From 16c56c43bcb78ae8a47b222b540bbaf10eb2f2b7 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 8 Jul 2026 10:17:33 -0700 Subject: [PATCH 07/10] Change default for getParents to `self=fALSE`. --- nimbleModel/R/modelBaseClass.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index d58bfe5..dddaf47 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -365,7 +365,7 @@ modelBase_nClass <- nClass( nimbleModel::getDependencies(modelDef, nodes, self, downstream, immediateOnly, nodesAsChars, returnScalarComponents, .sort) }, - getParents = function(nodes, self = TRUE, upstream = FALSE, immediateOnly = FALSE, + getParents = function(nodes, self = FALSE, upstream = FALSE, immediateOnly = FALSE, nodesAsChars = getNimbleModelOption('nodesAsChars'), returnScalarComponents = FALSE, .sort = FALSE ) { From 18c17dc63fefa656c6bd68b316ece258b36cbf41 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 8 Jul 2026 10:19:47 -0700 Subject: [PATCH 08/10] Update some tests. --- nimbleModel/tests/testthat/test-nodeChars.R | 22 ++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/nimbleModel/tests/testthat/test-nodeChars.R b/nimbleModel/tests/testthat/test-nodeChars.R index 8c5e956..e766c3a 100644 --- a/nimbleModel/tests/testthat/test-nodeChars.R +++ b/nimbleModel/tests/testthat/test-nodeChars.R @@ -188,8 +188,8 @@ test_that("old model API calls", { m <- nimbleModel(code) truth <- c("tau", "lifted_d1_over_sqrt_oPtau_cP", paste0("y[", 1:5, "]")) expect_identical(m$getDependencies(c('y','tau'), .sort = TRUE, nodesAsChars = TRUE), truth) - expect_identical(m$getParents('y', .sort = TRUE, nodesAsChars = TRUE), truth) - expect_identical(m$getParents('y', .sort = TRUE, nodesAsChars = TRUE, returnScalarComponents = TRUE), + expect_identical(m$getParents('y', .sort = TRUE, nodesAsChars = TRUE, self = TRUE), truth) + expect_identical(m$getParents('y', .sort = TRUE, nodesAsChars = TRUE, self = TRUE, returnScalarComponents = TRUE), truth) }) @@ -203,9 +203,9 @@ test_that("Use of .sort in cases with multiple and/or overlapping sortID values" m <- nimbleModel(code) expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), c("tau","lifted_d1_over_sqrt_oPtau_cP",paste0("y[", 1:6, "]"))) - expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), + expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE, self = TRUE), c('tau','y[1]','lifted_d1_over_sqrt_oPtau_cP',paste0('y[', 2:6, ']'))) - expect_identical(m$getParents('y[4]', .sort=TRUE, nodesAsChars = TRUE), + expect_identical(m$getParents('y[4]', .sort=TRUE, nodesAsChars = TRUE, self = TRUE), c('tau','lifted_d1_over_sqrt_oPtau_cP',paste0('y[', 3:4, ']'))) @@ -218,8 +218,8 @@ test_that("Use of .sort in cases with multiple and/or overlapping sortID values" 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]") expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), truth) - expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), truth) - expect_identical(m$getParents('y[4]', .sort=TRUE, nodesAsChars = TRUE), c('tau','lifted_d1_over_sqrt_oPtau_cP','y[3]','lifted_rho_times_y_oBi_minus_1_cB_L2[4]', 'y[4]')) + expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE, self = TRUE), truth) + 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]')) code <- nimbleCode({ @@ -230,8 +230,8 @@ test_that("Use of .sort in cases with multiple and/or overlapping sortID values" }) m <- nimbleModel(code) expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), c('tau','lifted_d1_over_sqrt_oPtau_cP',paste0('y[',6:1,']'))) - expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), c('tau','y[6]','lifted_d1_over_sqrt_oPtau_cP',paste0('y[',5:1,']'))) - expect_identical(m$getParents('y[4]', .sort=TRUE, nodesAsChars = TRUE), + expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE, self = TRUE), c('tau','y[6]','lifted_d1_over_sqrt_oPtau_cP',paste0('y[',5:1,']'))) + expect_identical(m$getParents('y[4]', .sort=TRUE, nodesAsChars = TRUE, self = TRUE), c('tau','lifted_d1_over_sqrt_oPtau_cP','y[5]','y[4]')) @@ -245,7 +245,7 @@ test_that("Use of .sort in cases with multiple and/or overlapping sortID values" tmp2 <- paste0("lifted_rho_times_y_oBi_minus_1_cB_L2[", 2:6, "]") truth <- c(tmp1,tmp2)[c(1,7,2,8,3,9,4,10,5,11,6)] expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), truth) - expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), truth) + expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE, self = TRUE), truth) code <- nimbleCode({ for(i in 2:6) @@ -254,7 +254,7 @@ test_that("Use of .sort in cases with multiple and/or overlapping sortID values" m <- nimbleModel(code) truth <- c("lifted_chol_oPpr_oB1to2_comma_1to2_cB_cP[1:2, 1:2]", paste0("y[1:2, ", 2:6, "]")) expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE), truth) - expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE), truth) + expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE, self = TRUE), truth) truth <- c( paste0("lifted_chol_oPpr_oB1to2_comma_1to2_cB_cP[1, ", 1:2, "]"), paste0("lifted_chol_oPpr_oB1to2_comma_1to2_cB_cP[2, ", 1:2, "]"), @@ -264,7 +264,7 @@ test_that("Use of .sort in cases with multiple and/or overlapping sortID values" paste0("y[", 1:2, ", 5]"), paste0("y[", 1:2, ", 6]")) expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE, returnScalarComponents = TRUE), truth) - expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE, returnScalarComponents = TRUE), truth) + expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE, self = TRUE, returnScalarComponents = TRUE), truth) }) From 5e6eb20205905ff9ae6a9c080f148534952fcec1 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 8 Jul 2026 10:28:16 -0700 Subject: [PATCH 09/10] Update some tests. --- nimbleModel/tests/testthat/test-nodeChars.R | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/nimbleModel/tests/testthat/test-nodeChars.R b/nimbleModel/tests/testthat/test-nodeChars.R index e766c3a..1306197 100644 --- a/nimbleModel/tests/testthat/test-nodeChars.R +++ b/nimbleModel/tests/testthat/test-nodeChars.R @@ -265,6 +265,26 @@ test_that("Use of .sort in cases with multiple and/or overlapping sortID values" paste0("y[", 1:2, ", 6]")) expect_identical(m$getNodes(.sort=TRUE,nodesAsChars=TRUE, returnScalarComponents = TRUE), truth) expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE, self = TRUE, returnScalarComponents = TRUE), truth) + + + code <- nimbleCode({ + for(i in 2:6) + y[i] ~ dnorm(rho * y[i-1], 1) + y[1] ~ dnorm(0,1) + rho ~ dunif(0, bnd) + bnd ~ dunif(0,1) + }) + m <- nimbleModel(code) + tmp1 <- paste0("y[", 1:6, "]") + tmp2 <- paste0("lifted_rho_times_y_oBi_minus_1_cB_L2[", 2:6, "]") + truth <- c(tmp1,tmp2)[c(1,7,2,8,3,9,4,10,5,11,6)] + expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE, self = TRUE, + immediateOnly = TRUE), truth) + truth <- c(truth[1], 'rho', truth[2:11]) + expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE, self = TRUE), truth) + truth <- c('bnd', truth) + #expect_identical(m$getParents('y', .sort=TRUE, nodesAsChars = TRUE, self = TRUE, + # upstream = TRUE), truth) }) From 0bc1b8d24b248425ab5d56b6c8d482e905815403 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 8 Jul 2026 13:02:27 -0700 Subject: [PATCH 10/10] Omit RHSonly from getParents and fix tests. --- nimbleModel/R/nodeRules.R | 4 +- nimbleModel/R/processModelGraph.R | 10 ++++ nimbleModel/tests/testthat/test-modelGraph.R | 48 +++++++++++--------- 3 files changed, 39 insertions(+), 23 deletions(-) diff --git a/nimbleModel/R/nodeRules.R b/nimbleModel/R/nodeRules.R index 1f25677..230acba 100644 --- a/nimbleModel/R/nodeRules.R +++ b/nimbleModel/R/nodeRules.R @@ -478,8 +478,8 @@ nodeRangeClass <- R6Class( varName = varName ) }, - toVarRange = function() { - varRangeClass$new(indexRanges, rangeToIndexSlot = rangeToIndexSlot, varName = varName, fromStochRule = decl$stoch) + toVarRange = function(fromStochRule = decl$stoch) { + varRangeClass$new(indexRanges, rangeToIndexSlot = rangeToIndexSlot, varName = varName, fromStochRule = fromStochRule) }, toChar = function() { diff --git a/nimbleModel/R/processModelGraph.R b/nimbleModel/R/processModelGraph.R index 85e3e1a..325c050 100644 --- a/nimbleModel/R/processModelGraph.R +++ b/nimbleModel/R/processModelGraph.R @@ -331,6 +331,16 @@ traverseGraph <- function(streamRules, declRules, } results <- removeDuplicateVarRanges(results) + # Remove RHSonly by passing through declRules. + results <- flatten(lapply(results, \(vr) + lapply(modelDef$declRules[[getVarName(vr)]]$rules, \(rule) { + nodeRange <- rule$apply(vr) + if(is.null(nodeRange)) return(NULL) else return(nodeRange$toVarRange(fromStochRule = vr$fromStochRule)) + }))) + if (!length(results)) { + return(NULL) + } + 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 diff --git a/nimbleModel/tests/testthat/test-modelGraph.R b/nimbleModel/tests/testthat/test-modelGraph.R index 42183de..e94ce40 100644 --- a/nimbleModel/tests/testthat/test-modelGraph.R +++ b/nimbleModel/tests/testthat/test-modelGraph.R @@ -1257,7 +1257,7 @@ test_that("basic check of graph interface", { result <- getParents(modelDef, 'y', upstream = TRUE) expect_identical(sapply(result, function(node) node$varName), - c('theta','mu0','sigma')) + c('theta','mu0')) }) @@ -1290,6 +1290,8 @@ test_that("getDependencies deals with repeated parents", { y ~ dnorm(mu, sd = tau) z ~ dnorm(mu, 1) w <- z + 3 + tau ~ dunif(0,1) + mu ~ dunif(0,1) }) modelDef <- modelDefClass$new(code) @@ -1338,6 +1340,7 @@ test_that("getParents traversal with mix of stoch/determ edges", { test_that("same dependent on RHS", { code <- quote({ y ~ dnorm(mu, sd = mu) + mu ~ dunif(0,1) }) modelDef <- modelDefClass$new(code) @@ -1357,7 +1360,6 @@ test_that("basic hierarchical models", { sigma ~ dunif(0, 1) for(i in 1:3) z[k[i]] ~ dnorm(y[k[i]], 1) - }) k <- c(2,4,7) model <- nimbleModel(code, constants = list(k = k)) @@ -1432,18 +1434,18 @@ test_that("basic hierarchical models", { result <- getParents(model$modelDef, 'y', upstream = TRUE) expect_identical(sapply(result, function(node) node$varName), - c('mu','tau','mu0','sigma','bnd')) + c('mu','tau','sigma')) result <- getParents(model$modelDef, 'y[1:5]', upstream = TRUE) expect_identical(sapply(result, function(node) node$varName), - c('mu','tau','mu0','sigma','bnd')) + c('mu','tau','sigma')) expect_equal(result[[1]]$indexRanges, list(newIndexRange(quote(1:5)))) result <- getParents(model$modelDef, varRangeClass$new(list(newIndexRange(quote(1:5))), varName = 'y'), upstream = TRUE) expect_identical(sapply(result, function(node) node$varName), - c('mu','tau','mu0','sigma','bnd')) + c('mu','tau','sigma')) expect_equal(result[[1]]$indexRanges, list(newIndexRange(quote(1:5)))) @@ -1488,14 +1490,11 @@ test_that("basic hierarchical models", { c('w','mu','y')) result <- getParents(model$modelDef, 'pr[2,2]') - expect_identical(sapply(result, function(node) node$varName), - 'S') - expect_equal(result[[1]]$indexRanges, - list(newIndexRange(quote(1:10)), newIndexRange(quote(1:10)))) + expect_identical(result, NULL) result <- getParents(model$modelDef, 'mu[3]') expect_identical(sapply(result, function(node) node$varName), - c('mu0','pr','mu00','z')) + c('mu0','pr','mu00')) expect_equal(result[[2]]$indexRanges, list(newIndexRange(quote(1:10)), newIndexRange(quote(1:10)))) @@ -1536,15 +1535,15 @@ test_that("basic hierarchical models", { result <- getParents(model$modelDef, 'y[1,1:3]') expect_identical(sapply(result, function(node) node$varName), - c('mn','pr','X','beta')) + c('mn','pr','beta')) result <- getParents(model$modelDef, 'y[1,2]') expect_identical(sapply(result, function(node) node$varName), - c('mn','pr','X','beta')) + c('mn','pr','beta')) result <- getParents(model$modelDef, c('y[1,2]','y[2,3]')) expect_identical(sapply(result, function(node) node$varName), - c('mn','pr','X','beta')) + c('mn','pr','beta')) }) @@ -1638,12 +1637,19 @@ test_that("state-space model", { expect_equal(result[[1]], varRangeClass$new(list(newIndexRange(2)), varName = 'y')) + code <- quote({ + for(i in 2:4) + y[i]~dnorm(y[i-1],1) + y[1] ~ dnorm(0,1) + }) + model <- nimbleModel(code) + modelDef <- model$modelDef + result <- getParents(modelDef, 'y[3]', upstream = TRUE) expect_length(result, 2) expect_equal(result[[2]], varRangeClass$new(list(newIndexRange(1)), varName = 'y')) - code <- quote({ for(i in 1:5) y[i] ~ dnorm(z[i], sd = tau) @@ -1776,10 +1782,10 @@ test_that("complicated input varRange", { vr$indexRanges[c(2,1)]) result <- getDependencies(modelDef, vr) - expect_length(result, 2) + expect_length(result, 1) expect_identical(sapply(result, function(node) node$varName), - c('theta','y')) - expect_equal(result[[2]], + c('y')) + expect_equal(result[[1]], varRangeClass$new(list(newIndexRange(matrix(c(3,5,5,1), nrow = 2)), newIndexRange(quote(2:3))), rangeToIndexSlot = list(c(1,3), 2), @@ -2558,12 +2564,12 @@ test_that("missing indexing", { modelCode <- quote({ y <- sum(mu[]) }) + m <- nimbleModel(modelCode, dimensions = list(mu = 5)) + modelDef <- m$modelDef - modelDef <- modelDefClass$new(modelCode, dimensions = list(mu = 5)) - - expect_equal(getParents(modelDef, 'y')[[1]], + expect_equal(getNodes(m, includeRHSonly = TRUE)[[2]]$toVarRange(), varRangeClass$new(list(newIndexRange(quote(1:5))), - varName = 'mu', fromStochRule = FALSE)) + varName = 'mu')) expect_equal(getDependencies(modelDef, 'mu[2]')[[1]], varRangeClass$new(list(), varName = 'y', fromStochRule = FALSE))