diff --git a/DESCRIPTION b/DESCRIPTION index bd481c8..774a31a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: nimbleMacros -Version: 0.1.1.9003 -Date: 2026-06-09 +Version: 0.1.1.9004 +Date: 2026-06-10 Title: Macros Generating 'nimble' Code Authors@R: c(person("Ken", "Kellner", email="contact@kenkellner.com", role=c("cre","aut")), @@ -23,4 +23,4 @@ URL: https://r-nimble.org BugReports: https://github.com/nimble-dev/nimbleMacros/issues Encoding: UTF-8 VignetteBuilder: knitr -RoxygenNote: 7.3.3 +Config/roxygen2/version: 8.0.0 diff --git a/R/FORLOOP.R b/R/FORLOOP.R index 0f3f728..6045bcb 100644 --- a/R/FORLOOP.R +++ b/R/FORLOOP.R @@ -11,6 +11,7 @@ #' #' @param code The right-hand side of a parameter declaration #' @param modelInfo Used internally by nimbleMacros; a list of model information such as constants and dimensions +#' @param ignoreIndexRanges Index ranges to ignore when creating for loops; must be provided as a list of quoted code #' @param .env Used internally by nimbleMacros; the environment where the model was created #' #' @return NIMBLE code for a for loop or series of nested for loops. @@ -27,7 +28,21 @@ NULL #' @export FORLOOP <- nimble::buildMacro( -function(code, modelInfo, .env){ +function(code, modelInfo, ignoreIndexRanges = list(), .env){ + # Super clunky way of extracting the ignore argument + # seems to be necessary to do it this way given buildMacro options + ignore <- eval(code[[length(code)]]$ignoreIndexRanges, envir = .env) + # necessary for when ignore is not explicitly included in arguments + if(is.null(ignore)) ignore <- list() + # get rid of any ignore stuff in code + code[[length(code)]]$ignoreIndexRanges <- NULL + # Check ignore structure + if(!is.list(ignore)) stop("ignoreIndexRanges argument must be a list", call.=FALSE) + if(length(ignore) > 0){ + is_call <- sapply(ignore, is.call) + if(!all(is_call)) stop("Some elements of ignoreIndexRanges are not quoted code/calls", call.=FALSE) + } + # Remove FORLOOP from the code line code <- removeMacroCall(code) LHS <- getLHS(code) @@ -45,11 +60,13 @@ function(code, modelInfo, .env){ # Subset only indexes with ranges idx_sub <- idx[has_range] + # Remove indices in ignore + idx_sub <- idx_sub[! idx_sub %in% ignore] # Create new index letters to represent those ranges in the for loops idx_letters <- lapply(1:length(idx_sub), function(i) modelInfo$indexCreator()) idx_letters <- lapply(idx_letters, as.name) # Replace the ranges with the new corresponding letters - code <- replaceDeclarationIndexRanges(code, idx_letters) + code <- replaceDeclarationIndexRanges(code, idx_letters, ignore) # Then insert the ranges into the for loop structure idx_sub <- replaceRanges(idx_sub, idx_letters) # So e.g. @@ -168,13 +185,16 @@ removeIndexAdjustments <- function(idx){ # Check if index range on both sides of declaration are the same # Specifically, all indices on RHS have to be present in LHS -hasMatchingIndexRanges <- function (LHS, RHS){ +# ignoreIndexRanges must be a list of quoted code e.g. list(quote(1:n)) +hasMatchingIndexRanges <- function (LHS, RHS, ignoreIndexRanges = list()){ idx_LHS <- extractIndices(LHS) idx_LHS <- idx_LHS[isIndexRange(idx_LHS)] idx_LHS <- lapply(idx_LHS, removeIndexAdjustments) idx_RHS <- extractAllIndices(RHS) idx_RHS <- idx_RHS[isIndexRange(idx_RHS)] idx_RHS <- lapply(idx_RHS, removeIndexAdjustments) + idx_RHS <- idx_RHS[!idx_RHS %in% ignoreIndexRanges] + if(length(idx_RHS) == 0) return(TRUE) all(idx_RHS %in% idx_LHS) } @@ -223,13 +243,16 @@ recursiveReplaceIndex <- function(code, old_idx, new_idx){ } # Replace all indices on both sides LHS/RHS -replaceDeclarationIndexRanges <- function(code, new_idx_list){ +# ignoreIndexRanges, if provided, must be a list of quoted code +# e.g. list(quote(1:n), quote(1:3)) +replaceDeclarationIndexRanges <- function(code, new_idx_list, ignoreIndexRanges = list()){ LHS <- getLHS(code) RHS <- getRHS(code) op <- code[[1]] - if(!hasMatchingIndexRanges(LHS, RHS)) stop("Index ranges must match") + if(!hasMatchingIndexRanges(LHS, RHS, ignoreIndexRanges)) stop("Index ranges must match") idx <- extractAllIndices(LHS) idx <- idx[isIndexRange(idx)] + idx <- idx[! idx %in% ignoreIndexRanges] if(length(idx) == 0) return(code) nidx <- length(idx) for (i in 1:nidx){ diff --git a/R/utilities.R b/R/utilities.R index 3135484..d27bdbd 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -195,6 +195,8 @@ simplifyIndices <- function(code, new_indices){ if(is.name(x) | is.symbol(x)) return(x) if(x[[1]] == "for"){ unique_idx <- unique(extractAllIndices(x)) + # Ignore any remaining index *ranges* + unique_idx <- unique_idx[sapply(unique_idx, is.name)] # Ignore blank indices as in x[i,] unique_idx <- unique_idx[sapply(unique_idx, function(x) x!="")] if(length(unique_idx) > length(new_indices)){ diff --git a/man/FORLOOP.Rd b/man/FORLOOP.Rd index 52b49fe..465ac64 100644 --- a/man/FORLOOP.Rd +++ b/man/FORLOOP.Rd @@ -8,6 +8,8 @@ \item{modelInfo}{Used internally by nimbleMacros; a list of model information such as constants and dimensions} +\item{ignoreIndexRanges}{Index ranges to ignore when creating for loops; must be provided as a list of quoted code} + \item{.env}{Used internally by nimbleMacros; the environment where the model was created} } \value{ diff --git a/tests/testthat/test_FORLOOP.R b/tests/testthat/test_FORLOOP.R index 376461a..d7bcba6 100644 --- a/tests/testthat/test_FORLOOP.R +++ b/tests/testthat/test_FORLOOP.R @@ -322,3 +322,87 @@ test_that("FORLOOP", { nimbleOptions(enableMacroComments=comments_on) }) + +test_that("ignoreIndexRanges argument works", { + comments_on <- nimbleOptions()$enableMacroComments + nimbleOptions(enableMacroComments=FALSE) + + # Check error when index on RHS not on LHS, and not ignored + const <- list(y=rnorm(2), x=matrix(rnorm(6), 2, 3), n=2) + modInfo <- list(constants = const, indexCreator = nimble:::labelFunctionCreator("i")) + code <- quote(y[1:n] <- FORLOOP(sum(x[1:n, 1:3]))) + expect_error(FORLOOP$process(code, modelInfo=modInfo, .env=environment()), + "Index ranges must match") + + # Check malformed ignore arguments + code <- quote(y[1:n] <- FORLOOP(sum(x[1:n, 1:3]), ignoreIndexRanges=1:3)) + expect_error(FORLOOP$process(code, modelInfo=modInfo, .env=environment())$code, + "ignoreIndexRanges argument must be a list") + + code <- quote(y[1:n] <- FORLOOP(sum(x[1:n, 1:3]), ignoreIndexRanges=list(1:3, 2))) + expect_error(FORLOOP$process(code, modelInfo=modInfo, .env=environment())$code, + "Some elements of ignoreIndexRanges are not quoted code/calls") + + # Simple loop with one ignored range + code <- nimbleCode({ + y[1:n] <- FORLOOP(sum(x[1:n, 1:3]), ignoreIndexRanges = list(quote(1:3))) + }) + mod <- nimbleModel(code, constants=const) + expect_equal( + mod$getCode(), + quote({ + for (i_1 in 1:n) { + y[i_1] <- sum(x[i_1, 1:3]) + } + }) + ) + + # Nested loops + const <- list(y=matrix(rnorm(4), 2, 2), x=array(rnorm(12), c(2,2,3)), n=2) + code <- nimbleCode({ + y[1:n, 1:2] <- FORLOOP(sum(x[1:n, 1:2, 1:3]), ignoreIndexRanges = list(quote(1:3))) + }) + mod <- nimbleModel(code, constants=const) + expect_equal( + mod$getCode(), + quote({ + for (i_1 in 1:n) { + for (i_2 in 1:2) { + y[i_1, i_2] <- sum(x[i_1, i_2, 1:3]) + } + } + }) + ) + + # Multiple ignores + const <- list(y=rnorm(2), x=array(rnorm(12), c(2,2,3)), n=2) + code <- nimbleCode({ + y[1:2] <- FORLOOP(sum(x[1:n, 1:2, 1:3]), ignoreIndexRanges = list(quote(1:3), quote(1:n))) + }) + mod <- nimbleModel(code, constants=const) + expect_equal( + mod$getCode(), + quote({ + for (i_1 in 1:2) { + y[i_1] <- sum(x[1:n, i_1, 1:3]) + } + }) + ) + + # Ignore on LHS + const <- list(y=matrix(rnorm(4), 2, 2), x=matrix(rnorm(4), 2, 2), n=2) + code <- nimbleCode({ + y[1:n, 1:2] <- FORLOOP(x[1:n, 1:2], ignoreIndexRanges = list(quote(1:n))) + }) + mod <- nimbleModel(code, constants=const) + expect_equal( + mod$getCode(), + quote({ + for (i_1 in 1:2){ + y[1:n, i_1] <- x[1:n, i_1] + } + }) + ) + + nimbleOptions(enableMacroComments=comments_on) +}) diff --git a/tests/testthat/test_simplifyForLoops.R b/tests/testthat/test_simplifyForLoops.R index e721875..25bf75e 100644 --- a/tests/testthat/test_simplifyForLoops.R +++ b/tests/testthat/test_simplifyForLoops.R @@ -152,3 +152,31 @@ test_that("Blank index slot is ignored", { ) }) +test_that("Remaining index ranges are ignored", { + # Index ranges could remain in loop code based on use of ignore argument + # make sure simplifyForLoops doesn't replace these with a new index + test <- nimbleCode({ + for (i_1 in 1:n){ + for (i_2 in 1:2){ + y[i_1,i_2] <- sum(x[i_1,i_2,1:m]) + } + } + + for(i_1 in 1:n){ + z[i_1] <- sum(a[1:3]) + } + }) + + out <- simplifyForLoops(test) + + expect_equal(out, + quote({ + for (i in 1:n) { + for (j in 1:2) { + y[i, j] <- sum(x[i, j, 1:m]) + } + z[i] <- sum(a[1:3]) + } + }) + ) +})