Skip to content

Enforce column-major ordering when converting node/varRanges to character strings#33

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
paciorek wants to merge 3 commits into
base:master
Choose a base branch
from
Open

Enforce column-major ordering when converting node/varRanges to character strings #33

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
173d8c1
Enforce column-major ordering when converting
paciorek Jul 3, 2026
1211fdb
Fix bug introduced into toVarChars with single column matrix indexing.
paciorek Sep 2, 2026
5d1e4ab
Fix up testing based on col-major ordering of node strings.
paciorek Sep 3, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion nimbleModel/R/indexRange.R
View file
Open in desktop
Original file line numberDiff line numberDiff line change
Expand Up@@ -260,7 +260,7 @@ indexRangeMatrixClass <- R6Class(
numColumns = numeric(),
initialize = function(values, sort = TRUE) {
if (sort) {
ord <- do.call(order, lapply(seq_len(ncol(values)), function(i) values[, i]))
ord <- do.call(order, lapply(rev(seq_len(ncol(values))), function(i) values[, i]))
values <<- values[ord, , drop = FALSE]
} else {
values <<- values
Expand Down
14 changes: 4 additions & 10 deletions nimbleModel/R/varRange.R
View file
Open in desktop
Original file line numberDiff line numberDiff line change
Expand Up@@ -242,15 +242,13 @@ varRangeClass <- R6Class(
} else {
externalMatrix <- crossIndexRanges(indexRanges)$values
} # not ordered
tmp <- t(apply(externalMatrix, 1, as.character))
if (ncol(externalMatrix) == 1) {
tmp <- t(tmp)
}
indicesList <- list()
indices <- unlist(rangeToIndexSlot)
for (i in seq_along(indices)) {
indicesList[[indices[i]]] <- tmp[, i]
indicesList[[indices[i]]] <- externalMatrix[, i]
}
ord <- do.call(order, indicesList[sort(sapply(rangeToIndexSlot, \(x) x[1]), decreasing = TRUE)]) # Enforce column-major, but using only first index in nonseparable cases).
indicesList <- lapply(indicesList, \(x) x[ord])
return(paste0(varName, "[", do.call(pasteIndices, indicesList), "]"))
}

Expand All@@ -274,12 +272,8 @@ varRangeClass <- R6Class(
} else {
externalMatrix <- crossIndexRanges(indexRanges[boolMatrixIndexRanges])$values
} # not ordered
tmp <- t(apply(externalMatrix, 1, as.character))
if (ncol(externalMatrix) == 1) {
tmp <- t(tmp)
}
for (i in seq_along(matrixIndices)) {
indicesList[[matrixIndices[i]]] <- tmp[, i]
indicesList[[matrixIndices[i]]] <- externalMatrix[, i]
}
}
return(paste0(varName, "[", do.call(pasteIndices, indicesList), "]"))
Expand Down
6 changes: 3 additions & 3 deletions nimbleModel/tests/testthat/test-indexConstraint.R
View file
Open in desktop
Original file line numberDiff line numberDiff line change
Expand Up@@ -192,7 +192,7 @@ test_that("checkIndexConstraints", {
)


expResult <- c(rep(FALSE,4),TRUE,rep(FALSE,6),TRUE)
expResult <- c(FALSE,TRUE,rep(FALSE, 9), TRUE)

## Two input ranges on the matrix constraint; ranges are crossed and result duplicated.
expect_identical(
Expand All@@ -219,7 +219,7 @@ test_that("checkIndexConstraints", {
rangeToIndexSlot <- list(c(1,3),2,4),
varName = 'x'),
constraints),
list(c(TRUE,FALSE), expResult, expResult)
list(c(FALSE,TRUE), expResult, expResult)
)
## Input multi-slot range covers two constraints, but only one of the slots in the matrix constraint.
expect_error(
Expand All@@ -232,7 +232,7 @@ test_that("checkIndexConstraints", {
)

## Input multi-slot range covers only one constraint (and an unconstrained slot).
expResult <- c(FALSE,FALSE,TRUE,rep(FALSE,5))
expResult <- c(FALSE,TRUE,rep(FALSE,6))
expect_identical(
nimbleModel:::checkIndexConstraints(varRangeClass$new(list(newIndexRange(2),
newIndexRange(matrix(c(2,9,4,2,5,5,6,7), ncol = 2, byrow = TRUE)),
Expand Down
143 changes: 129 additions & 14 deletions nimbleModel/tests/testthat/test-nimbleModel.R
View file
Open in desktop
Original file line numberDiff line numberDiff line change
Expand Up@@ -264,8 +264,8 @@ test_that("two index slots", {
## Reverse indices
inds <- matrix(c(1,3, 2,4, 3,2), ncol=2, byrow=TRUE)
vr <- varRangeClass$new(list(newIndexRange(inds)), rangeToIndexSlot = list(c(2,1)), varName = 'y')
tmp <- vr$indexRanges[[1]]$values[,2:1]
inds <- tmp[order(tmp[,1]),] # Rows have been shuffled...
inds <- vr$indexRanges[[1]]$values[,2:1]
inds <- inds[order(inds[,2]), ]
truth <- sum(dnorm(m$y[inds], log=TRUE))
expect_equal(m$calculate(vr), truth)
expect_equal(cm$calculate(vr), truth)
Expand DownExpand Up@@ -376,7 +376,7 @@ test_that("three index slots (plus different index variable ordering)", {
inds <- matrix(c(5,3,1, 1,3,4, 4,1,2), ncol=3, byrow=TRUE)
vr <- varRangeClass$new(list(newIndexRange(inds)), rangeToIndexSlot = list(c(3,1,2)), varName = 'y')
tmp <- vr$indexRanges[[1]]$values[,c(2,3,1)]
inds <- tmp[order(tmp[,1],tmp[,2]),] # Rows have been shuffled...
inds <- tmp[order(tmp[,3],tmp[,2]),] # Rows have been shuffled...
truth <- sum(dnorm(m$y[inds], log=TRUE))
expect_equal(m$calculate(vr), truth)
expect_equal(cm$calculate(vr), truth)
Expand DownExpand Up@@ -413,8 +413,7 @@ test_that("three index slots (plus different index variable ordering)", {
## matp-seq (matp first because of k,j,i in model code)
vr <- varRangeClass$new(list(newIndexRange(quote(2:3)),
newIndexRange(matrix(c(4,1,1,3,4,5),ncol=2,byrow=TRUE))), varName = 'y')
inds <- rbind(c(2,1,3),c(2,4,1),c(2,4,5),c(3,1,3),c(3,4,1),c(3,4,5))
inds <- inds[order(inds[,2],inds[,3],inds[,1]),]
inds <- vr$extractIndexRange(1:3)$values
truth <- sum(dnorm(m$y[inds], log=TRUE))
expect_equal(m$calculate(vr), truth)
expect_equal(cm$calculate(vr), truth)
Expand All@@ -431,8 +430,7 @@ test_that("three index slots (plus different index variable ordering)", {
## seq-matp
vr <- varRangeClass$new(list(newIndexRange(matrix(c(1,4,3,1,2,4),ncol=2,byrow=TRUE)),
newIndexRange(quote(4:5))), varName = 'y')
inds <- rbind(c(1,4,4),c(3,1,4),c(2,4,4),c(1,4,5),c(3,1,5),c(2,4,5))
inds <- inds[order(inds[,3],inds[,1],inds[,2]),]
inds <- vr$extractIndexRange(1:3)$values
truth <- sum(dnorm(m$y[inds], log=TRUE))
expect_equal(m$calculate(vr), truth)
expect_equal(cm$calculate(vr), truth)
Expand All@@ -449,8 +447,7 @@ test_that("three index slots (plus different index variable ordering)", {
## matp-matp (matp first because of k,j,i in model code)
vr <- varRangeClass$new(list(newIndexRange(matrix(c(1,3),ncol=1)),
newIndexRange(matrix(c(1,4,3,1,4,5),ncol=2,byrow=TRUE))), varName = 'y')
inds <- rbind(c(1,1,4),c(1,3,1),c(1,4,5),c(3,1,4),c(3,3,1),c(3,4,5))
inds <- inds[order(inds[,2],inds[,1],inds[,3]),]
inds <- vr$extractIndexRange(1:3)$values
truth <- sum(dnorm(m$y[inds], log=TRUE))
expect_equal(m$calculate(vr), truth)
expect_equal(cm$calculate(vr), truth)
Expand All@@ -467,8 +464,7 @@ test_that("three index slots (plus different index variable ordering)", {
## matp-matp with reordering
vr <- varRangeClass$new(list(newIndexRange(matrix(c(1,4,3,1,3,2),ncol=2,byrow=TRUE)),
newIndexRange(matrix(c(3,5),ncol=1))), varName = 'y')
inds <- rbind(c(1,4,3),c(3,1,3),c(3,2,3),c(1,4,5),c(3,1,5),c(3,2,5))
inds <- inds[order(inds[,3],inds[,1]),]
inds <- vr$extractIndexRange(1:3)$values
truth <- sum(dnorm(m$y[inds], log=TRUE))
expect_equal(m$calculate(vr), truth)
expect_equal(cm$calculate(vr), truth)
Expand DownExpand Up@@ -624,9 +620,8 @@ test_that("five index slots", {
newIndexRange(matrix(c(1,3),ncol=1))),
rangeToIndexSlot = list(1, c(2,4,5), 3),
varName = 'y')
inds <- rbind(c(2,2,1,2,4),c(2,2,3,2,4),c(2,4,1,1,2),c(2,4,3,1,2),
c(3,2,1,2,4),c(3,2,3,2,4),c(3,4,1,1,2),c(3,4,3,1,2),
c(4,2,1,2,4),c(4,2,3,2,4),c(4,4,1,1,2),c(4,4,3,1,2))
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)
Expand DownExpand Up@@ -1184,6 +1179,126 @@ test_that("simulation without data nodes", {
set.seed(1)
cm$simulate('y')
expect_identical(y, cm$y)
})

test_that("column-major node/variable ordering when converted to chars", {
library(nimbleModel); library(testthat)

code <- nimbleCode({
for(i in 1:2)
for(j in 1:3)
y[i,j] ~ dnorm(0,1)
})

m <- nimbleModel(code)
grid <- expand.grid(1:2,1:3)
truth <- paste0('y[', apply(grid, 1, \(x) paste0(x[1], ", ", x[2])), ']')
expect_identical(m$getNodes(nodesAsChars=TRUE), truth)
expect_identical(m$getNodeNames(), truth)
expect_identical(m$expandNodeNames('y'), truth)
expect_identical(m$getDependencies('y', self=TRUE)[[1]]$toVarChars(expandScalars=TRUE), truth)

code <- nimbleCode({
for(i in 1:2)
for(j in 1:3)
y[j,i] ~ dnorm(0,1)
})

m <- nimbleModel(code)
grid <- expand.grid(1:3,1:2)
truth <- paste0('y[', apply(grid, 1, \(x) paste0(x[1], ", ", x[2])), ']')
expect_identical(m$getNodes(nodesAsChars=TRUE), truth)
expect_identical(m$getNodeNames(), truth)
expect_identical(m$expandNodeNames('y'), truth)
expect_identical(m$getDependencies('y', self=TRUE)[[1]]$toVarChars(expandScalars=TRUE), truth)

code <- nimbleCode({
for(i in 1:2)
for(j in 1:3)
y[i,k[j]] ~ dnorm(0,1)
})

m <- nimbleModel(code, constants = list(k=c(3,4,1)))
grid <- expand.grid(1:2,c(1,3,4))
truth <- paste0('y[', apply(grid, 1, \(x) paste0(x[1], ", ", x[2])), ']')

expect_identical(m$getNodes(nodesAsChars=TRUE), truth)
expect_identical(m$getDependencies('y', self=TRUE)[[1]]$toVarChars(expandScalars=TRUE), truth)

code <- nimbleCode({
for(i in 1:2)
for(j in 1:3)
y[k[i],l[j]] ~ dnorm(0,1)
})

m <- nimbleModel(code, constants = list(k=c(3,1), l = c(3,4,1)))
grid <- expand.grid(c(1,3),c(1,3,4))
truth <- paste0('y[', apply(grid, 1, \(x) paste0(x[1], ", ", x[2])), ']')

expect_identical(m$getNodes(nodesAsChars=TRUE), truth)
expect_identical(m$getDependencies('y', self=TRUE)[[1]]$toVarChars(expandScalars=TRUE), truth)

code <- nimbleCode({
for(i in 1:2)
for(j in 1:3)
y[k[j],i,k[j]+1] ~ dnorm(0,1)
})

m <- nimbleModel(code, constants = list(k=c(3,4,1)))
truth <- c("y[1, 1, 2]","y[3, 1, 4]","y[4, 1, 5]","y[1, 2, 2]","y[3, 2, 4]","y[4, 2, 5]")

expect_identical(m$getNodes(nodesAsChars=TRUE), truth)
expect_identical(m$getDependencies('y', self=TRUE)[[1]]$toVarChars(expandScalars=TRUE), truth)

code <- nimbleCode({
for(i in 1:2)
for(j in 1:3)
y[1:4,i,j] ~ dmnorm(z[1:4],pr[1:4,1:4])
})

m <- nimbleModel(code)
grid <- expand.grid(1:2,1:3)
truth <- paste0('y[1:4, ', apply(grid, 1, \(x) paste0(x[1], ", ", x[2])), ']')

expect_identical(m$getNodes('y',nodesAsChars=TRUE), truth)

grid <- expand.grid(1:4,1:2,1:3)
truth <- paste0('y[', apply(grid, 1, \(x) paste0(x[1], ", ", x[2], ", ", x[3])), ']')
expect_identical(m$getNodes('y',nodesAsChars=TRUE, returnScalarComponents=TRUE), truth)
expect_identical(m$getDependencies('y', self=TRUE)[[1]]$toVarChars(expandScalars=TRUE), truth)

code <- nimbleCode({
for(i in 1:2)
for(j in 1:3)
y[i,1:4,j] ~ dmnorm(z[1:4],pr[1:4,1:4])
})

m <- nimbleModel(code)
grid <- expand.grid(1:2,1:3)
truth <- paste0('y[', apply(grid, 1, \(x) paste0(x[1], ", 1:4, ", x[2])), ']')

expect_identical(m$getNodes('y',nodesAsChars=TRUE), truth)

grid <- expand.grid(1:2,1:4,1:3)
truth <- paste0('y[', apply(grid, 1, \(x) paste0(x[1], ", ", x[2], ", ", x[3])), ']')
expect_identical(m$getNodes('y',nodesAsChars=TRUE, returnScalarComponents=TRUE), truth)
expect_identical(m$getDependencies('y', self=TRUE)[[1]]$toVarChars(expandScalars=TRUE), truth)

code <- nimbleCode({
for(i in 1:2)
for(j in 1:3)
y[i,j,1:4] ~ dmnorm(z[1:4],pr[1:4,1:4])
})

m <- nimbleModel(code)
grid <- expand.grid(1:2,1:3)
truth <- paste0('y[', apply(grid, 1, \(x) paste0(x[1], ", ", x[2], ", 1:4")), ']')

expect_identical(m$getNodes('y',nodesAsChars=TRUE), truth)

grid <- expand.grid(1:2,1:3,1:4)
truth <- paste0('y[', apply(grid, 1, \(x) paste0(x[1], ", ", x[2], ", ", x[3])), ']')
expect_identical(m$getNodes('y',nodesAsChars=TRUE, returnScalarComponents=TRUE), truth)
expect_identical(m$getDependencies('y', self=TRUE)[[1]]$toVarChars(expandScalars=TRUE), truth)

})
Loading
Loading