From f89ab96e46f64a121004e54056412de1674a4235 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Sat, 19 Sep 2026 12:32:09 -0700 Subject: [PATCH] Refactor originalIndexingRules: - use `loopIndexing` as naming - clarify naming for nodeRange <-> loopIndexing <-> IDs - simplify/clean structure of related class methods - create loopIndexingRangeClass inheriting from varRangeClass to clarify concepts. --- nimbleModel/DESCRIPTION | 2 +- nimbleModel/NAMESPACE | 3 +- nimbleModel/R/MCMC_configuration.R | 4 +- nimbleModel/R/graphRules.R | 29 +- nimbleModel/R/indexRuleArbitrary.R | 11 + nimbleModel/R/indexRuleBlock.R | 16 ++ ...nalIndexingRules.R => loopIndexingRules.R} | 56 +++- nimbleModel/R/modelBaseClass.R | 8 +- nimbleModel/R/modelDecl.R | 4 +- nimbleModel/R/modelFunctions.R | 23 +- nimbleModel/R/nodeRules.R | 114 +++----- ...dexingRules.R => test-loopIndexingRules.R} | 30 +- nimbleModel/tests/testthat/test-nimbleModel.R | 8 +- nimbleModel/tests/testthat/test-nodeIDs.R | 270 +++++++++--------- nimbleModel/tests/testthat/test-nodeRules.R | 23 +- 15 files changed, 316 insertions(+), 285 deletions(-) rename nimbleModel/R/{originalIndexingRules.R => loopIndexingRules.R} (69%) rename nimbleModel/tests/testthat/{test-originalIndexingRules.R => test-loopIndexingRules.R} (78%) diff --git a/nimbleModel/DESCRIPTION b/nimbleModel/DESCRIPTION index 8c5ac36..b9697e1 100644 --- a/nimbleModel/DESCRIPTION +++ b/nimbleModel/DESCRIPTION @@ -30,6 +30,7 @@ Collate: indexConstraint.R getSymbolicParentNodes.R graphRules.R + loopIndexingRules.R MCMC_configuration.R MCMC_conjugacy.R MCMC_utils.R @@ -41,7 +42,6 @@ Collate: model_utils.R nodeRules.R options.R - originalIndexingRules.R processModelGraph.R rhsRules.R types_util.R diff --git a/nimbleModel/NAMESPACE b/nimbleModel/NAMESPACE index a8405eb..7c7487c 100644 --- a/nimbleModel/NAMESPACE +++ b/nimbleModel/NAMESPACE @@ -35,7 +35,8 @@ export(declRuleClass) export(rhsRuleClass) export(calcRuleClass) export(calcRangeClass) -export(originalIndexingRuleClass) +export(loopIndexingRuleClass) +export(loopIndexingRangeClass) ## functions and other objects export(makeCalcRules) diff --git a/nimbleModel/R/MCMC_configuration.R b/nimbleModel/R/MCMC_configuration.R index ff887fc..4fd8e70 100644 --- a/nimbleModel/R/MCMC_configuration.R +++ b/nimbleModel/R/MCMC_configuration.R @@ -37,7 +37,7 @@ samplerConfClass <- R6Class( }, toStr = function(displayControlDefaults = FALSE, displayNonScalars = FALSE, displayConjugateDependencies = FALSE) { tempList <- list() - tempList[[paste0(name, " sampler")]] <- paste0(target, collapse = ", ") + tempList[[paste0(name, " sampler")]] <- paste0(target$toNodeChars(), collapse = ", ") infoList <- c(tempList, control) mcmc_listContentsToStr(infoList, displayControlDefaults, displayNonScalars, displayConjugateDependencies) }, @@ -219,7 +219,7 @@ mcmcConfClass <- R6Class( dynamicallyIndexed = model$modelDef$varInfo[[target$varName]]$anyDynamicallyIndexed )) } - stop("Cannot assign conjugate sampler to non-conjugate node: `", target, "`") + stop("Cannot assign conjugate sampler to non-conjugate node: `", target$toNodeChars(), "`") } if (targetAsScalars) { diff --git a/nimbleModel/R/graphRules.R b/nimbleModel/R/graphRules.R index 2bfa84b..b0d2813 100644 --- a/nimbleModel/R/graphRules.R +++ b/nimbleModel/R/graphRules.R @@ -525,11 +525,13 @@ applyGraphRule <- function(fromVarRange, rule, varName = NULL, removeDuplicates } if (!length(indexRules)) { - return( - varRangeClass$new(ifelse(is.null(varName), rule$toVarName, varName), - fromStochRule = rule$stoch - ) - ) + if(rule$toVarName == ".loop") { + return(loopIndexingRangeClass$new(ifelse(is.null(varName), rule$toVarName, varName), + fromStochRule = NULL)) + } else { + return(varRangeClass$new(ifelse(is.null(varName), rule$toVarName, varName), + fromStochRule = rule$stoch)) + } } # Step 1: Apply indexRules one by one, getting inputs from multiple indexRanges if necessary. @@ -701,14 +703,21 @@ applyGraphRule <- function(fromVarRange, rule, varName = NULL, removeDuplicates # Remove duplicate columns (from cases where two indexRanges are used in a single rule). repeats <- duplicated(finalRangeToIndexSlot) - return( - varRangeClass$new( + if(rule$toVarName == ".loop") { + return(loopIndexingRangeClass$new( indexInfo = finalIndexRanges[!repeats], rangeToIndexSlot = finalRangeToIndexSlot[!repeats], varName = ifelse(is.null(varName), rule$toVarName, varName), - fromStochRule = rule$stoch - ) - ) + fromStochRule = NULL)) + } else { + return( + varRangeClass$new( + indexInfo = finalIndexRanges[!repeats], + rangeToIndexSlot = finalRangeToIndexSlot[!repeats], + varName = ifelse(is.null(varName), rule$toVarName, varName), + fromStochRule = rule$stoch + )) + } } diff --git a/nimbleModel/R/indexRuleArbitrary.R b/nimbleModel/R/indexRuleArbitrary.R index 52bad4f..c8b5d53 100644 --- a/nimbleModel/R/indexRuleArbitrary.R +++ b/nimbleModel/R/indexRuleArbitrary.R @@ -34,6 +34,17 @@ indexRuleArbitraryClass <- R6Class( }, getNumElements = function() { return(setupResults$unrolledSize) + }, + getIDs = function(indexRange) { + values <- match(indexRange$getValuesAsMatrix(), unlist(setupResults$iRow2toIndices)) + NAs <- is.na(values) + if (any(NAs)) { + values <- values[!NAs] + } + return(values) + }, + invertIDs = function(relativeNodeIDs) { + unlist(setupResults$iRow2toIndices[relativeNodeIDs]) } ) ) diff --git a/nimbleModel/R/indexRuleBlock.R b/nimbleModel/R/indexRuleBlock.R index 9394874..4c0679e 100644 --- a/nimbleModel/R/indexRuleBlock.R +++ b/nimbleModel/R/indexRuleBlock.R @@ -42,6 +42,22 @@ indexRuleBlockClass <- R6Class( }, getNumElements = function() { return(setupResults$fromMax - setupResults$fromMin + 1) + }, + getIDs = function(indexRange) { + init <- setupResults$fromMin + setupResults$offset + switch(class(indexRange)[1], + indexRangeScalarClass = indexRange$value - init + 1, + indexRangeSequenceClass = (indexRange$start - init + 1):(indexRange$end - init + 1), + indexRangeMatrixClass = c(indexRange$values) - init + 1, + stop("invalid type of indexRange provided for creating IDs") + ) + }, + invertIDs = function(relativeNodeIDs) { + if (setupResults$fromMin + setupResults$offset != 1) { + return(relativeNodeIDs + (setupResults$fromMin + setupResults$offset - 1)) + } else { + return(relativeNodeIDs) + } } ) ) diff --git a/nimbleModel/R/originalIndexingRules.R b/nimbleModel/R/loopIndexingRules.R similarity index 69% rename from nimbleModel/R/originalIndexingRules.R rename to nimbleModel/R/loopIndexingRules.R index ef1c4f2..c1605e4 100644 --- a/nimbleModel/R/originalIndexingRules.R +++ b/nimbleModel/R/loopIndexingRules.R @@ -1,22 +1,25 @@ -# An originalIndexingRuleClass object represents the relationship +# An loopIndexingRuleClass object represents the relationship # between the loop indexing and the indexing of a LHS variable, # such as giving the values of `i` when provided a varRange for `y` in # `for(i in 5:n) y[i-2] <- 1`, such that `y[7:9]` would give `i=9:11`. -originalIndexingRuleClass <- R6Class( - classname = "originalIndexingRuleClass", +loopIndexingRuleClass <- R6Class( + classname = "loopIndexingRuleClass", portable = FALSE, public = list( graphRule = NULL, indexSlotToSet = NULL, externalRule = NULL, internalRule = NULL, + decl = NULL, varName = character(), initialize = function(LHS, context, - constants = list()) { + constants = list(), + decl = NULL) { varName <<- getVarName(LHS) + decl <<- decl if (length(context$indexVarNames)) { # Exclude indices not used in lifted expression, e.g., `i` in `y[i,j] ~ dnorm(mu[i], var = sigma2[j])` indexVarNames <- context$indexVarNames @@ -26,10 +29,10 @@ originalIndexingRuleClass <- R6Class( } else { "" } - dummyLHS <- parse(text = paste0(varName, indexing))[[1]] + dummyLHS <- parse(text = paste0(".loop", indexing))[[1]] # Unused singleContexts will be removed in graphRuleClass$new(). } else { - dummyLHS <- as.name(varName) + dummyLHS <- as.name(".loop") } graphRule <<- graphRuleClass$new( @@ -39,7 +42,7 @@ originalIndexingRuleClass <- R6Class( constants ) - # For use in apply_reverse; we want to produce nodeRanges, not varRanges. + # For use in `invert`; we want to produce nodeRanges, not varRanges. fullRule <- graphRuleClass$new( LHS, dummyLHS, @@ -72,9 +75,6 @@ originalIndexingRuleClass <- R6Class( } }, - # Produces a varRange, though it's not really a range for a variable - # but rather a range for the indices. - # (2023-06-10, commit 30ede6) # Do not remove duplicates because in generation of `calcRange`s there # can be cases where we need duplicated values in order to have correct # number of logProbs. @@ -88,7 +88,8 @@ originalIndexingRuleClass <- R6Class( apply = function(fromVarRange) { graphRule$apply(fromVarRange, removeDuplicates = TRUE) }, - apply_reverse = function(indexingRange, decl) { + # TODO: or we could name this loopIndexingToNodes or some such. + invert = function(indexingRange) { if (length(externalRule$indexRules)) { externalRange <- externalRule$apply(indexingRange) if (is.null(externalRange)) { @@ -98,12 +99,41 @@ originalIndexingRuleClass <- R6Class( externalRange <- varRangeClass$new(list()) } if (length(internalRule$indexRules)) { - internalRange <- internalRule$apply(externalRule$getFromRange()) # This needs to be instantiated anew to avoid having multiple references to the internalRange indexRanges. + # This needs to be instantiated anew to avoid having multiple references to the internalRange indexRanges. + internalRange <- internalRule$apply(externalRule$getFromRange()) } else { internalRange <- varRangeClass$new(list()) } - + # Note that the varName is determined from self$varName (indexingRange has .loop as varName). return(nodeRangeClass$new(varName, externalRange, internalRange, indexSlotToSet, decl)) } ) ) + +loopIndexingRangeClass <- R6Class( + "loopIndexingRangeClass", + portable = FALSE, + inherit = varRangeClass, + public = list( + initialize = function(indexInfo, + rangeToIndexSlot = NULL, + varName = ".loop", + fromStochRule = NULL) { + super$initialize(indexInfo, rangeToIndexSlot, varName, fromStochRule) + }, + toChar = function() { + dots <- sapply(indexRangeExprs, identical, quote(...)) + if(all(dots)) + return("nonseparable loop indexing") + text <- paste0("index ", seq_along(indexRangeExprs[!dots]), ": ") + text <- paste0(text, indexRangeExprs[!dots], collapse = ", ") + if(any(dots)) text <- paste0(text, ", plus nonseparable loop indexing") + return(text) + }, + print = function() { + cat("looping with ", toChar(), ".\n", sep = "") + } + ) +) + + diff --git a/nimbleModel/R/modelBaseClass.R b/nimbleModel/R/modelBaseClass.R index 4469acc..d71a4d0 100644 --- a/nimbleModel/R/modelBaseClass.R +++ b/nimbleModel/R/modelBaseClass.R @@ -334,8 +334,8 @@ modelBase_nClass <- nClass( stop("getParamExpr: `", param, "` is not present in the parameterization") } if (length(expr) > 1) { - # Substitute original index values into the expression. - indexVarRange <- decl$declRule$originalIndexingRule$apply(nodeRange) + # Substitute looping index values into the expression. + indexVarRange <- decl$declRule$loopIndexingRule$apply(nodeRange) indexValues <- indexVarRange$indexRangeExprs names(indexValues) <- decl$context$indexVarNames expr <- eval(substitute(substitute(EXPR, indexValues), list(EXPR = expr))) @@ -358,8 +358,8 @@ modelBase_nClass <- nClass( expr <- expr[!names(expr) %in% c("lower_", "upper_") & !grepl("^\\.", names(expr))] } - # Substitute original index values into the expression. - indexVarRange <- decl$declRule$originalIndexingRule$apply(nodeRange) + # Substitute loop index values into the expression. + indexVarRange <- decl$declRule$loopIndexingRule$apply(nodeRange) indexValues <- indexVarRange$indexRangeExprs names(indexValues) <- decl$context$indexVarNames expr <- eval(substitute(substitute(EXPR, indexValues), list(EXPR = expr))) diff --git a/nimbleModel/R/modelDecl.R b/nimbleModel/R/modelDecl.R index c9778a0..eff0854 100644 --- a/nimbleModel/R/modelDecl.R +++ b/nimbleModel/R/modelDecl.R @@ -129,10 +129,10 @@ modelDeclClass <- R6Class( # Create declRule and symbolic RHS pieces. processDecl = function(nimFunNames, constants = list(), envir) { declRule <<- declRuleClass$new(self, 0, context, constants) - if (length(declRule$originalIndexingRule$graphRule$indexRules)) { + if (length(declRule$loopIndexingRule$graphRule$indexRules)) { if (!identical( declRule$externalRule$apply(declRule$varName)$extractIndexRange()$numElements, - declRule$originalIndexingRule$apply(declRule$varName)$extractIndexRange()$numElements + declRule$loopIndexingRule$apply(declRule$varName)$extractIndexRange()$numElements ) && !any(sapply(indexExpr, checkForIndexedIntervals, context))) { # Non-constant indexing invalidates this check. stop("found duplicated node definitions in declaring `", safeDeparse(declRule$expr), "`.") diff --git a/nimbleModel/R/modelFunctions.R b/nimbleModel/R/modelFunctions.R index 6c1441e..2558b78 100644 --- a/nimbleModel/R/modelFunctions.R +++ b/nimbleModel/R/modelFunctions.R @@ -281,10 +281,7 @@ aggregate_nodes <- function(nodeSet) { newNodeSet <- lapply(seq_along(IDsByDecl), \(i) { if(sum(nms[i] == declIDs) > 1) { whichDecl <- match(nms[i], declIDs) - decl <- nodeSet[[whichDecl]]$decl - return(decl$declRule$originalIndexingRule$apply_reverse( - decl$declRule$getOriginalIndexing(IDsByDecl[[i]]), decl - )) + return(nodeSet[[whichDecl]]$decl$declRule$getNodesFromIDs(IDsByDecl[[i]])) } else return(nodeSet[[nms[i]]]) }) return(c(newNodeSet, RHSonly)) @@ -310,9 +307,7 @@ intersect_nodes <- function(nodeSet1, nodeSet2) { if (declIDs1[i] == declIDs2[j]) intersect(nodeIDs1[[i]], nodeIDs2[[j]]) else NULL }))) if (length(keepNodeIDs)) { - newNodeSet1[[i]] <- nodeSet1[[i]]$decl$declRule$originalIndexingRule$apply_reverse( - nodeSet1[[i]]$decl$declRule$getOriginalIndexing(keepNodeIDs), nodeSet1[[i]]$decl - ) + newNodeSet1[[i]] <- nodeSet1[[i]]$decl$declRule$getNodesFromIDs(keepNodeIDs) } } return(newNodeSet1[!sapply(newNodeSet1, is.null)]) @@ -347,9 +342,7 @@ setdiff_nodes <- function(nodeSet1, nodeSet2) { for (i in seq_along(nodeSet1)) { keepNodeIDs <- setdiff(nodeIDs1[[i]], excludeNodeIDs[[declIDs1[i]]]) if (length(keepNodeIDs)) { - newNodeSet1[[i]] <- nodeSet1[[i]]$decl$declRule$originalIndexingRule$apply_reverse( - nodeSet1[[i]]$decl$declRule$getOriginalIndexing(keepNodeIDs), nodeSet1[[i]]$decl - ) + newNodeSet1[[i]] <- nodeSet1[[i]]$decl$declRule$getNodesFromIDs(keepNodeIDs) } } return(c(newNodeSet1[!sapply(newNodeSet1, is.null)], RHSonly)) @@ -455,9 +448,7 @@ getConditionallyIndependentSets <- function(model, nodes, givenNodes, omit = NUL this_touched <- touched[[focalNodeRange$decl$declRule$ID]]$tagged[focalNodeIDs] while (!all(this_touched)) { focalNodeID <- focalNodeIDs[!this_touched][1] - currentNode <- focalNodeRange$decl$declRule$originalIndexingRule$apply_reverse( # indexing range to nodeRange - focalNodeRange$decl$declRule$getOriginalIndexing(focalNodeID), focalNodeRange$decl - ) # ID to indexing range + currentNode <- focalNodeRange$decl$declRule$getNodesFromIDs(focalNodeID) sets[[numSets]] <- getOneConditionallyIndependentSet(model, currentNode, focalNodeID, given, touched, startUp = startUp, startDown = startDown ) @@ -508,7 +499,7 @@ exploreDown <- function(ans, model, currentNodes, given, touched) { newLatentNodes <- child } else { newLatentIDs <- childIDs[chosen] - newLatentNodes <- child$decl$declRule$originalIndexingRule$apply_reverse(child$decl$declRule$getOriginalIndexing(newLatentIDs), child$decl) + newLatentNodes <- child$decl$declRule$getNodesFromIDs(newLatentIDs) } ans[[length(ans) + 1]] <- newLatentNodes } else { @@ -520,7 +511,7 @@ exploreDown <- function(ans, model, currentNodes, given, touched) { } else { upIDsFromGiven <- childIDs[chosen] if (length(upIDsFromGiven)) { - upNodesFromGiven <- child$decl$declRule$originalIndexingRule$apply_reverse(child$decl$declRule$getOriginalIndexing(upIDsFromGiven), child$decl) + upNodesFromGiven <- child$decl$declRule$getNodesFromIDs(upIDsFromGiven) } else { upNodesFromGiven <- NULL } @@ -552,7 +543,7 @@ exploreUp <- function(ans, model, currentNodes, given, touched) { newLatentNodes <- parent } else { newLatentIDs <- parentIDs[chosen] - newLatentNodes <- parent$decl$declRule$originalIndexingRule$apply_reverse(parent$decl$declRule$getOriginalIndexing(newLatentIDs), parent$decl) + newLatentNodes <- parent$decl$declRule$getNodesFromIDs(newLatentIDs) } ans[[length(ans) + 1]] <- newLatentNodes ans <- exploreUp(ans, model, newLatentNodes, given, touched) diff --git a/nimbleModel/R/nodeRules.R b/nimbleModel/R/nodeRules.R index 6b5af93..e42c338 100644 --- a/nimbleModel/R/nodeRules.R +++ b/nimbleModel/R/nodeRules.R @@ -132,38 +132,41 @@ declRuleClass <- R6Class( portable = FALSE, inherit = nodeRuleClass, public = list( - originalIndexingRule = NULL, # Determines original indexing (based on context). + loopIndexingRule = NULL, # Determines loop indexing (based on context). decl = NULL, # Full declInfo; nodeRuleClass$expr is just LHS. initialize = function(decl, ID, context = modelContextClass$new(), constants = list()) { decl <<- decl super$initialize(decl$code[[2]], ID, context = context, constants = constants) # `expr` in is parent class. - originalIndexingRule <<- originalIndexingRuleClass$new(expr, context, constants) + loopIndexingRule <<- loopIndexingRuleClass$new(expr, context, constants, decl) # We rely on assuming canonical ordering of standard non-separable rules when working with nodeIDs. - if (length(originalIndexingRule$graphRule$indexRules) == length(originalIndexingRule$graphRule$indexSets$toIndexSlotToSet) && - !identical(originalIndexingRule$graphRule$indexSets$toIndexSlotToSet, seq_along(originalIndexingRule$graphRule$indexRules))) { - stop("originalIndexingRules are not in canonical order") + if (length(loopIndexingRule$graphRule$indexRules) == length(loopIndexingRule$graphRule$indexSets$toIndexSlotToSet) && + !identical(loopIndexingRule$graphRule$indexSets$toIndexSlotToSet, seq_along(loopIndexingRule$graphRule$indexRules))) { + stop("loopIndexingRules are not in canonical order") } }, - getIDs = function(indexingRange) { # Could be named originalIndexingToIDs or some such. - if (!length(indexingRange$indexRanges)) { # scalar case + getNodesFromIDs = function(IDs) { + loopIndexingRule$invert(getLoopIndexingFromIDs(IDs)) + }, + getIDsFromLoopIndexing = function(loopIndexingRange) { # Could be named loopIndexingToIDs or some such. + if (!length(loopIndexingRange$indexRanges)) { # scalar case return(1) } - indexingRules <- originalIndexingRule$graphRule$indexRules - numLoops <- length(originalIndexingRule$graphRule$indexSets$toIndexSlotToSet) - if (!inherits(indexingRange, "varRangeClass")) { - stop("`indexingRange` must be a varRange") + indexingRules <- loopIndexingRule$graphRule$indexRules + numLoops <- length(loopIndexingRule$graphRule$indexSets$toIndexSlotToSet) + if (!inherits(loopIndexingRange, "loopIndexingRangeClass")) { + stop("`loopIndexingRange` must be a loopIndexingRange") } # Loop indexing is separable so can determine IDs by arithmetic. if (length(indexingRules) == numLoops) { - if (length(indexingRange$indexRanges) == length(indexingRules)) { # indexingRange is separable as well. + if (length(loopIndexingRange$indexRanges) == length(indexingRules)) { # loopIndexingRange is separable as well. if (numLoops > 1) { indices <- list(length = numLoops) # Put in order of loop index slots. - indexingRangeRanges <- indexingRange$indexRanges[indexingRange$indexSlotToRange] - individualLoopIDs <- lapply(seq_len(numLoops), \(i) getOneLoopIDs(indexingRangeRanges[[i]], indexingRules[[i]])) + loopIndexingRangeRanges <- loopIndexingRange$indexRanges[loopIndexingRange$indexSlotToRange] + individualLoopIDs <- lapply(seq_len(numLoops), \(i) getOneLoopIDs(loopIndexingRangeRanges[[i]], indexingRules[[i]])) indices[[numLoops]] <- individualLoopIDs[[numLoops]] offset <- 1 lens <- sapply(indexingRules, \(x) x$getNumElements()) @@ -173,10 +176,10 @@ declRuleClass <- R6Class( } nodeIDs <- rowSums(do.call(expand.grid, rev(indices))) # Use `rev` to avoid need to sort. } else { - nodeIDs <- getOneLoopIDs(indexingRange$indexRanges[[1]], indexingRules[[1]]) + nodeIDs <- getOneLoopIDs(loopIndexingRange$indexRanges[[1]], indexingRules[[1]]) } } else { # indexing range is non-separable: expand and then do arithmetic. - inputIndices <- indexingRange$extractIndexRange(seq_len(numLoops))$getValuesAsMatrix() + inputIndices <- loopIndexingRange$extractIndexRange(seq_len(numLoops))$getValuesAsMatrix() indicesLast <- getOneLoopIDs(newIndexRange(inputIndices[, numLoops], sort = FALSE), indexingRules[[numLoops]]) indices <- matrix(0, nrow = length(indicesLast), ncol = numLoops) indices[, numLoops] <- indicesLast @@ -189,8 +192,8 @@ declRuleClass <- R6Class( nodeIDs <- rowSums(indices) } } else { # Loop indexing is nonseparable. Fall back to expand and match, even if there are multiple (i.e., crossed) rules. - fullIndices <- originalIndexingRule$apply(originalIndexingRule$varName)$extractIndexRange()$getValuesAsMatrix() - inputIndices <- indexingRange$extractIndexRange()$getValuesAsMatrix() + fullIndices <- loopIndexingRule$apply(loopIndexingRule$varName)$extractIndexRange()$getValuesAsMatrix() + inputIndices <- loopIndexingRange$extractIndexRange()$getValuesAsMatrix() nodeIDs <- match( do.call(interaction, as.data.frame(inputIndices)), do.call(interaction, as.data.frame(fullIndices)) @@ -198,16 +201,16 @@ declRuleClass <- R6Class( } return(nodeIDs) }, - getOriginalIndexing = function(nodeIDs) { # Could be named IDsToOriginalIndexing or some such. - indexingRules <- originalIndexingRule$graphRule$indexRules + getLoopIndexingFromIDs = function(nodeIDs) { + indexingRules <- loopIndexingRule$graphRule$indexRules if (!length(indexingRules)) { # scalar case if (nodeIDs == 1) { - return(varRangeClass$new(list(), varName = originalIndexingRule$varName)) + return(loopIndexingRangeClass$new(list())) } else { return(NULL) } } - numLoops <- length(originalIndexingRule$graphRule$indexSets$toIndexSlotToSet) + numLoops <- length(loopIndexingRule$graphRule$indexSets$toIndexSlotToSet) if (length(indexingRules) == numLoops) { # Loop indexing is separable. # Can we shortcircuit if nodeIDs is all possible ones? # Or if only one nodeID @@ -217,7 +220,7 @@ declRuleClass <- R6Class( if (inherits(indexRange, "indexRangeMatrixClass")) { indexRange <- indexRange$toSequence() # TODO: does this handle sorting? Should we see if we can do it more quickly? } - return(varRangeClass$new(list(indexRange), varName = originalIndexingRule$varName)) + return(loopIndexingRangeClass$new(list(indexRange))) } else { lens <- sapply(indexingRules, \(x) x$getNumElements()) cumLens <- rev(cumprod(rev(lens))) @@ -251,7 +254,7 @@ declRuleClass <- R6Class( return(newIndexRange(uniqIndices[[i]])) } }) - return(varRangeClass$new(indexRanges, varName = originalIndexingRule$varName)) + return(loopIndexingRangeClass$new(indexRanges)) } } else { for (i in seq_len(numLoops)) { @@ -260,57 +263,28 @@ declRuleClass <- R6Class( } } } else { # Loop indexing is nonseparable. Fall back to expand and select, even if there are multiple (i.e., crossed) rules. - fullIndices <- originalIndexingRule$apply(originalIndexingRule$varName)$extractIndexRange()$getValuesAsMatrix() + fullIndices <- loopIndexingRule$apply(loopIndexingRule$varName)$extractIndexRange()$getValuesAsMatrix() indices <- fullIndices[nodeIDs, ] } - return(varRangeClass$new(list(newIndexRange(indices)), varName = originalIndexingRule$varName)) + return(loopIndexingRangeClass$new(list(newIndexRange(indices)))) } ) ) -# TODO: we may want to create more methods for the indexingRules so as not to access their internals in these next two functions. -# Note that these functions do not deal with validity of IDs or loop indexing. Invalid values are filtered out when -# going to back to nodeRanges, so we may not need to do that filtering here. -# Convert from loop indexing to ID indexing (locally within a given separable loop set) (accounting for offset or non-sequential indexing). +# Note that these functions do not deal with validity of IDs or loop indexing. +# Invalid values are filtered out when going to back to nodeRanges, so we do +# not need to do that filtering here. + +# Convert from loop indexing to ID indexing (locally within a given separable loop set) +# (accounting for offset or non-sequential indexing). getOneLoopIDs <- function(indexRange, indexingRule) { - if (inherits(indexingRule, "indexRuleBlockClass")) { - init <- indexingRule$setupResults$fromMin + indexingRule$setupResults$offset - # We could use `switch` but then can't use `inherits` and would need to pick off [[1]] element from class(). - if (inherits(indexRange, "indexRangeMatrixClass")) { - return(c(indexRange$values) - init + 1) - } - if (inherits(indexRange, "indexRangeSequenceClass")) { - return((indexRange$start - init + 1):(indexRange$end - init + 1)) - } - if (inherits(indexRange, "indexRangeScalarClass")) { - return(indexRange$value - init + 1) - } - stop("invalid type of indexRange provided for creating nodeIDs") - } - if (inherits(indexingRule, "indexRuleArbitraryClass")) { - values <- match(indexRange$getValuesAsMatrix(), unlist(indexingRule$setupResults$iRow2toIndices)) - NAs <- is.na(values) - if (any(NAs)) { - values <- values[!NAs] - } - return(values) - } - stop("invalid type of indexRule provided for creating nodeIDs") + indexingRule$getIDs(indexRange) } -# Convert from ID indexing (locally within a given separable loop set) to the actual loop indexing (accounting for offset or non-sequential indexing). +# Convert from ID indexing (locally within a given separable loop set) to the +# actual loop indexing (accounting for offset or non-sequential indexing). getOneLoopIndices <- function(relativeNodeIDs, indexingRule) { - if (inherits(indexingRule, "indexRuleBlockClass")) { - if (indexingRule$setupResults$fromMin + indexingRule$setupResults$offset != 1) { - return(relativeNodeIDs + (indexingRule$setupResults$fromMin + indexingRule$setupResults$offset - 1)) - } else { - return(relativeNodeIDs) - } - } - if (inherits(indexingRule, "indexRuleArbitraryClass")) { - return(unlist(indexingRule$setupResults$iRow2toIndices[relativeNodeIDs])) - } - stop("invalid type of indexRule provided for creating indices from nodeIDs") + indexingRule$invertIDs(relativeNodeIDs) } @@ -361,9 +335,9 @@ calcRuleClass <- R6Class( stop("`inputRange` variable name does not match the `calcRule` variable name.") } - # Need original indexing because nodeFunctions will use that indexing + # Need loop indexing because nodeFunctions will use that indexing # (e.g. `y[i+1]` needs value of `i`). - indexingRange <- declRule$originalIndexingRule$apply(inputRange) + indexingRange <- declRule$loopIndexingRule$apply(inputRange) if (is.null(indexingRange)) { return(NULL) } @@ -379,7 +353,7 @@ calcRuleClass <- R6Class( if (is.null(multiSortIDindex)) { newMultiSortIDindex <- NULL } else { - newMultiSortIDindex <- declRule$originalIndexingRule$graphRule$indexSets$fromIndexSlotToSet[multiSortIDindex] + newMultiSortIDindex <- declRule$loopIndexingRule$graphRule$indexSets$fromIndexSlotToSet[multiSortIDindex] } result <- calcRangeClass$new(varName, indexingRange, as.numeric(declRule$ID), newSortID, newMultiSortIDindex) @@ -540,7 +514,7 @@ calcRangeClass <- R6Class( portable = FALSE, public = list( varName = NULL, - indexingRange = NULL, + indexingRange = NULL, # a loopIndexingRangeClass sortID = NULL, multiSortIDindex = NULL, declID = NULL, @@ -671,7 +645,7 @@ nodeRangeClass <- R6Class( }, getIDs = function() { if (is.null(nodeIDs)) { - nodeIDs <<- decl$declRule$getIDs(decl$declRule$originalIndexingRule$apply(self)) + nodeIDs <<- decl$declRule$getIDsFromLoopIndexing(decl$declRule$loopIndexingRule$apply(self)) } return(nodeIDs) }, diff --git a/nimbleModel/tests/testthat/test-originalIndexingRules.R b/nimbleModel/tests/testthat/test-loopIndexingRules.R similarity index 78% rename from nimbleModel/tests/testthat/test-originalIndexingRules.R rename to nimbleModel/tests/testthat/test-loopIndexingRules.R index 304722f..fcf1678 100644 --- a/nimbleModel/tests/testthat/test-originalIndexingRules.R +++ b/nimbleModel/tests/testthat/test-loopIndexingRules.R @@ -1,4 +1,4 @@ -test_that("originalIndexingRules work correctly", { +test_that("loopIndexingRules work correctly", { singleContext1 <- singleContextClass$new(forCode = quote(for(i in 1:10){})) @@ -11,15 +11,15 @@ test_that("originalIndexingRules work correctly", { singleContext2)) - rule <- originalIndexingRuleClass$new(LHS = quote(y[i+1]), + rule <- loopIndexingRuleClass$new(LHS = quote(y[i+1]), context = context_i) expect_equal( rule$apply( varRangeClass$new(list( newIndexRange(quote(3:6))))), - varRangeClass$new(list( - newIndexRange(quote(2:5))), varName = 'y') + loopIndexingRangeClass$new(list( + newIndexRange(quote(2:5)))) ) @@ -28,7 +28,7 @@ test_that("originalIndexingRules work correctly", { context_i <- modelContextClass$new(list(singleContext1)) k <- c(5,1,3) - rule <- originalIndexingRuleClass$new(LHS = quote(y[k[i]]), + rule <- loopIndexingRuleClass$new(LHS = quote(y[k[i]]), context = context_i, constants = list(k = k)) @@ -36,12 +36,12 @@ test_that("originalIndexingRules work correctly", { rule$apply( varRangeClass$new(list( newIndexRange(quote(3:5))))), - varRangeClass$new(list( - newIndexRange(matrix(c(3,1), ncol = 1))), varName = 'y') + loopIndexingRangeClass$new(list( + newIndexRange(matrix(c(3,1), ncol = 1)))) ) - rule <- originalIndexingRuleClass$new(LHS = quote(y[j, i+1]), + rule <- loopIndexingRuleClass$new(LHS = quote(y[j, i+1]), context = context_ij) expect_equal( @@ -49,17 +49,17 @@ test_that("originalIndexingRules work correctly", { varRangeClass$new(list( newIndexRange(quote(3:5)), newIndexRange(quote(1:3))))), - varRangeClass$new(list( + loopIndexingRangeClass$new(list( newIndexRange(quote(1:2)), - newIndexRange(quote(3:5))), varName = 'y') + newIndexRange(quote(3:5)))) ) expect_equal( rule$apply( varRangeClass$new(list( newIndexRange(matrix(c(8,4,3,2), ncol = 2))))), - varRangeClass$new(list( - newIndexRange(matrix(c(1,4),nrow = 1))), varName = 'y') + loopIndexingRangeClass$new(list( + newIndexRange(matrix(c(1,4),nrow = 1)))) ) n <- c(1,3,2) @@ -72,7 +72,7 @@ test_that("originalIndexingRules work correctly", { context_ijni <- modelContextClass$new(list(singleContext1, singleContext2)) - rule <- originalIndexingRuleClass$new(LHS = quote(y[j, i+1]), + rule <- loopIndexingRuleClass$new(LHS = quote(y[j, i+1]), context = context_ijni, constants = list(n = n)) expect_equal( @@ -80,7 +80,7 @@ test_that("originalIndexingRules work correctly", { varRangeClass$new(list( newIndexRange(quote(1:2)), newIndexRange(quote(1:3))))), - varRangeClass$new(list( - newIndexRange(matrix(c(1,2,2,1,1,2), ncol = 2))), varName = 'y') + loopIndexingRangeClass$new(list( + newIndexRange(matrix(c(1,2,2,1,1,2), ncol = 2)))) ) }) diff --git a/nimbleModel/tests/testthat/test-nimbleModel.R b/nimbleModel/tests/testthat/test-nimbleModel.R index 75b451b..23af2ae 100644 --- a/nimbleModel/tests/testthat/test-nimbleModel.R +++ b/nimbleModel/tests/testthat/test-nimbleModel.R @@ -993,7 +993,7 @@ test_that("calculate works correctly for time series/SSM recursion", { ranges <- m$modelDef$calcRules[['y']]$rules[[2]]$makeCalcRange(m$modelDef$calcRules[['y']]$rules[[2]]$apply('y[2,5:7]')) expect_identical(ranges$sortID, c(5,4,3)) expect_identical(ranges$multiSortIDindex, 1L) - expect_identical(ranges$indexingRange$toVarChars(), c("y[4:6, 2]")) + expect_identical(ranges$indexingRange$toChar(), "index 1: 4:6, index 2: 2") scalars <- ranges$makeScalarInstrInfoLists() expect_identical(length(scalars), 3L) expect_identical(sapply(scalars, \(x) x$sortID), c(5,4,3)) @@ -1002,7 +1002,7 @@ test_that("calculate works correctly for time series/SSM recursion", { ranges <- m$modelDef$calcRules[['y']]$rules[[2]]$makeCalcRange(m$modelDef$calcRules[['y']]$rules[[2]]$apply('y[2,c(7,5)]')) expect_identical(ranges$sortID, c(5,3)) expect_identical(ranges$multiSortIDindex, 1L) - expect_identical(ranges$indexingRange$toVarChars(), c("y[4, 2]", "y[6, 2]")) + expect_identical(ranges$indexingRange$toChar(), "index 1: c(4, 6), index 2: 2") scalars <- ranges$makeScalarInstrInfoLists() expect_identical(length(scalars), 2L) expect_identical(sapply(scalars, \(x) x$sortID), c(5,3)) @@ -1019,7 +1019,7 @@ test_that("calculate works correctly for time series/SSM recursion", { ranges <- m$modelDef$calcRules[['y']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['y']]$rules[[1]]$apply('y[3:5]')) expect_identical(ranges$sortID, c(4,6,8)) - expect_identical(ranges$indexingRange$toVarChars(), "y[3:5]") + expect_identical(ranges$indexingRange$toChar(), "index 1: 3:5") scalars <- ranges$makeScalarInstrInfoLists() expect_identical(length(scalars), 3L) expect_identical(sapply(scalars, \(x) x$sortID), c(4,6,8)) @@ -1027,7 +1027,7 @@ test_that("calculate works correctly for time series/SSM recursion", { ranges <- m$modelDef$calcRules[['lifted_rho_times_y_oBi_minus_1_cB_L2']]$rules[[1]]$makeCalcRange(m$modelDef$calcRules[['lifted_rho_times_y_oBi_minus_1_cB_L2']]$rules[[1]]$apply('lifted_rho_times_y_oBi_minus_1_cB_L2[3:5]')) expect_identical(ranges$sortID, c(3,5,7)) - expect_identical(ranges$indexingRange$toVarChars(), "lifted_rho_times_y_oBi_minus_1_cB_L2[3:5]") + expect_identical(ranges$indexingRange$toChar(), "index 1: 3:5") scalars <- ranges$makeScalarInstrInfoLists() expect_identical(length(scalars), 3L) expect_identical(sapply(scalars, \(x) x$sortID), c(3,5,7)) diff --git a/nimbleModel/tests/testthat/test-nodeIDs.R b/nimbleModel/tests/testthat/test-nodeIDs.R index 7634ced..5543d2e 100644 --- a/nimbleModel/tests/testthat/test-nodeIDs.R +++ b/nimbleModel/tests/testthat/test-nodeIDs.R @@ -1,4 +1,4 @@ -test_that("basic tests of mapping indexing to nodes via originalIndexingRule$apply_reverse", { +test_that("basic tests of mapping indexing to nodes via loopIndexingRule$invert", { code <- nimbleCode({ for(i in 1:10) @@ -8,14 +8,14 @@ test_that("basic tests of mapping indexing to nodes via originalIndexingRule$app m <- nimbleModel(code) decl <- m$modelDef$declRules$y$rules[[1]] - indexingRange <- decl$originalIndexingRule$apply('y[1:5]') - expect_identical(decl$originalIndexingRule$apply_reverse(indexingRange, decl)$toVarRange()$toChar(), "y[1:5]") + indexingRange <- decl$loopIndexingRule$apply('y[1:5]') + expect_identical(decl$loopIndexingRule$invert(indexingRange)$toVarRange()$toChar(), "y[1:5]") - indexingRange <- decl$originalIndexingRule$apply('y[3:5]') - expect_identical(decl$originalIndexingRule$apply_reverse(indexingRange, decl)$toVarRange()$toChar(), "y[3:5]") + indexingRange <- decl$loopIndexingRule$apply('y[3:5]') + expect_identical(decl$loopIndexingRule$invert(indexingRange)$toVarRange()$toChar(), "y[3:5]") - indexingRange <- decl$originalIndexingRule$apply('y[c(2,4)]') - expect_identical(decl$originalIndexingRule$apply_reverse(indexingRange, decl)$toVarRange()$toChar(), "y[c(2, 4)]") + indexingRange <- decl$loopIndexingRule$apply('y[c(2,4)]') + expect_identical(decl$loopIndexingRule$invert(indexingRange)$toVarRange()$toChar(), "y[c(2, 4)]") code <- nimbleCode({ for(i in c(2,4,7,9)) @@ -25,10 +25,10 @@ test_that("basic tests of mapping indexing to nodes via originalIndexingRule$app m <- nimbleModel(code) decl <- m$modelDef$declRules$y$rules[[1]] - indexingRange <- decl$originalIndexingRule$apply('y[c(4,9)]') - expect_identical(decl$originalIndexingRule$apply_reverse(indexingRange, decl)$toVarRange()$toChar(), "y[c(4, 9)]") - indexingRange <- decl$originalIndexingRule$apply('y[4:9]') - expect_identical(decl$originalIndexingRule$apply_reverse(indexingRange, decl)$toVarRange()$toChar(), "y[c(4, 7, 9)]") + indexingRange <- decl$loopIndexingRule$apply('y[c(4,9)]') + expect_identical(decl$loopIndexingRule$invert(indexingRange)$toVarRange()$toChar(), "y[c(4, 9)]") + indexingRange <- decl$loopIndexingRule$apply('y[4:9]') + expect_identical(decl$loopIndexingRule$invert(indexingRange)$toVarRange()$toChar(), "y[c(4, 7, 9)]") code <- nimbleCode({ for(i in 1:10) @@ -38,14 +38,14 @@ test_that("basic tests of mapping indexing to nodes via originalIndexingRule$app m <- nimbleModel(code) decl <- m$modelDef$declRules$y$rules[[1]] - indexingRange <- decl$originalIndexingRule$apply('y[3:7]') - expect_identical(decl$originalIndexingRule$apply_reverse(indexingRange, decl)$toVarRange()$toChar(), "y[3:7]") + indexingRange <- decl$loopIndexingRule$apply('y[3:7]') + expect_identical(decl$loopIndexingRule$invert(indexingRange)$toVarRange()$toChar(), "y[3:7]") - indexingRange <- decl$originalIndexingRule$apply('y[5:7]') - expect_identical(decl$originalIndexingRule$apply_reverse(indexingRange, decl)$toVarRange()$toChar(), "y[5:7]") + indexingRange <- decl$loopIndexingRule$apply('y[5:7]') + expect_identical(decl$loopIndexingRule$invert(indexingRange)$toVarRange()$toChar(), "y[5:7]") - indexingRange <- decl$originalIndexingRule$apply('y[c(5,7)]') - expect_identical(decl$originalIndexingRule$apply_reverse(indexingRange, decl)$toVarRange()$toChar(), "y[c(5, 7)]") + indexingRange <- decl$loopIndexingRule$apply('y[c(5,7)]') + expect_identical(decl$loopIndexingRule$invert(indexingRange)$toVarRange()$toChar(), "y[c(5, 7)]") code <- nimbleCode({ for(i in c(2,4,7,9)) @@ -55,11 +55,11 @@ test_that("basic tests of mapping indexing to nodes via originalIndexingRule$app m <- nimbleModel(code) decl <- m$modelDef$declRules$y$rules[[1]] - indexingRange <- decl$originalIndexingRule$apply('y[3:7]') - expect_identical(decl$originalIndexingRule$apply_reverse(indexingRange, decl)$toVarRange()$toChar(), "y[c(4, 6)]") + indexingRange <- decl$loopIndexingRule$apply('y[3:7]') + expect_identical(decl$loopIndexingRule$invert(indexingRange)$toVarRange()$toChar(), "y[c(4, 6)]") - indexingRange <- decl$originalIndexingRule$apply('y[c(6,9)]') - expect_identical(decl$originalIndexingRule$apply_reverse(indexingRange, decl)$toVarRange()$toChar(), "y[c(6, 9)]") + indexingRange <- decl$loopIndexingRule$apply('y[c(6,9)]') + expect_identical(decl$loopIndexingRule$invert(indexingRange)$toVarRange()$toChar(), "y[c(6, 9)]") code <- nimbleCode({ for(i in 1:3) @@ -71,8 +71,8 @@ test_that("basic tests of mapping indexing to nodes via originalIndexingRule$app m <- nimbleModel(code) decl <- m$modelDef$declRules$y$rules[[1]] - indexingRange <- decl$originalIndexingRule$apply('y[2:3,2:4,3:5]') - expect_identical(decl$originalIndexingRule$apply_reverse(indexingRange, decl)$toVarRange()$toChar(), "y[2:3, 2:4, 3:5]") + indexingRange <- decl$loopIndexingRule$apply('y[2:3,2:4,3:5]') + expect_identical(decl$loopIndexingRule$invert(indexingRange)$toVarRange()$toChar(), "y[2:3, 2:4, 3:5]") }) @@ -86,23 +86,23 @@ test_that("basic tests of nodeIDs", { m <- nimbleModel(code) decl <- m$modelDef$declRules$y$rules[[1]] - expect_identical(decl$getIDs(varRangeClass$new('y[5]')), 5) - expect_identical(decl$getOriginalIndexing(5)$toChar(), - 'y[5]') - expect_identical(decl$getIDs(varRangeClass$new('y[1:5]')), 1:5) - expect_identical(decl$getOriginalIndexing(1:5)$toChar(), - 'y[1:5]') - expect_identical(decl$getIDs(varRangeClass$new('y[3:5]')), 3:5) - expect_identical(decl$getOriginalIndexing(3:5)$toChar(), - 'y[3:5]') - - expect_identical(decl$getIDs(varRangeClass$new('y[9:14]')), 9:14) - expect_identical(decl$getOriginalIndexing(9:14)$toChar(), - 'y[9:14]') + expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[5]')), 5) + expect_identical(decl$getLoopIndexingFromIDs(5)$toChar(), + 'index 1: 5') + expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[1:5]')), 1:5) + expect_identical(decl$getLoopIndexingFromIDs(1:5)$toChar(), + 'index 1: 1:5') + expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[3:5]')), 3:5) + expect_identical(decl$getLoopIndexingFromIDs(3:5)$toChar(), + 'index 1: 3:5') + + expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[9:14]')), 9:14) + expect_identical(decl$getLoopIndexingFromIDs(9:14)$toChar(), + 'index 1: 9:14') - expect_identical(decl$getIDs(varRangeClass$new('y[c(2, 4)]')), c(2,4)) - expect_identical(decl$getOriginalIndexing(c(2,4))$toChar(), - 'y[c(2, 4)]') + expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[c(2, 4)]')), c(2,4)) + expect_identical(decl$getLoopIndexingFromIDs(c(2,4))$toChar(), + 'index 1: c(2, 4)') code <- nimbleCode({ for(i in c(2,4,7,9)) @@ -112,13 +112,13 @@ test_that("basic tests of nodeIDs", { m <- nimbleModel(code) decl <- m$modelDef$declRules$y$rules[[1]] - expect_identical(decl$getIDs(varRangeClass$new('y[1:5]')), 1:2) - expect_identical(decl$getOriginalIndexing(1:2)$toChar(), - 'y[c(2, 4)]') + expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[1:5]')), 1:2) + expect_identical(decl$getLoopIndexingFromIDs(1:2)$toChar(), + 'index 1: c(2, 4)') - expect_identical(decl$getIDs(varRangeClass$new('y[c(4, 9)]')), c(2L,4L)) - expect_identical(decl$getOriginalIndexing(c(2,4))$toChar(), - 'y[c(4, 9)]') + expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[c(4, 9)]')), c(2L,4L)) + expect_identical(decl$getLoopIndexingFromIDs(c(2,4))$toChar(), + 'index 1: c(4, 9)') code <- nimbleCode({ for(i in 3:10) @@ -128,17 +128,17 @@ test_that("basic tests of nodeIDs", { m <- nimbleModel(code) decl <- m$modelDef$declRules$y$rules[[1]] - expect_identical(decl$getIDs(varRangeClass$new('y[3:7]')), 1:5) - expect_identical(decl$getOriginalIndexing(1:5)$toChar(), - 'y[3:7]') + expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[3:7]')), 1:5) + expect_identical(decl$getLoopIndexingFromIDs(1:5)$toChar(), + 'index 1: 3:7') - expect_identical(decl$getIDs(varRangeClass$new('y[5:7]')), 3:5) - expect_identical(decl$getOriginalIndexing(3:5)$toChar(), - 'y[5:7]') + expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[5:7]')), 3:5) + expect_identical(decl$getLoopIndexingFromIDs(3:5)$toChar(), + 'index 1: 5:7') - expect_identical(decl$getIDs(varRangeClass$new('y[c(5,7)]')), c(3,5)) - expect_identical(decl$getOriginalIndexing(c(3,5))$toChar(), - 'y[c(5, 7)]') + expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[c(5,7)]')), c(3,5)) + expect_identical(decl$getLoopIndexingFromIDs(c(3,5))$toChar(), + 'index 1: c(5, 7)') }) @@ -154,31 +154,31 @@ test_that("nodeIDs with multiple loops", { m <- nimbleModel(code) decl <- m$modelDef$declRules$y$rules[[1]] - expect_identical(decl$getIDs(varRangeClass$new('y[2,4,3]')), + expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[2,4,3]')), 38) - expect_identical(decl$getOriginalIndexing(38)$toChar(), - 'y[2, 4, 3]') + expect_identical(decl$getLoopIndexingFromIDs(38)$toChar(), + 'index 1: 2, index 2: 4, index 3: 3') ids <- as.numeric(c(28:30,33:35,38:40,48:50,53:55,58:60)) - expect_identical(decl$getIDs(varRangeClass$new('y[2:3,2:4,3:5]')), + expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[2:3,2:4,3:5]')), ids) - expect_identical(decl$getOriginalIndexing(ids)$toChar(), - 'y[2:3, 2:4, 3:5]') + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(), + 'index 1: 2:3, index 2: 2:4, index 3: 3:5') # do with arbitrary subsetting, separable ids <- c(8,10,13,15,18,20,48,50,53,55,58,60) - expect_identical(decl$getIDs(varRangeClass$new('y[c(1,3),2:4,c(3,5)]')), + expect_identical(decl$getIDsFromLoopIndexing(loopIndexingRangeClass$new('.loop[c(1,3),2:4,c(3,5)]')), ids) - expect_identical(decl$getOriginalIndexing(ids)$toChar(), - 'y[c(1, 3), 2:4, c(3, 5)]') + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(), + 'index 1: c(1, 3), index 2: 2:4, index 3: c(3, 5)') # do with arbitrary subsetting, nonseparable ids <- c(46,51,56, 30,35,40) - indexingRange <- varRangeClass$new(list(newIndexRange(quote(2:4)), + indexingRange <- loopIndexingRangeClass$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(), + rangeToIndexSlot=list(2,c(3,1))) + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(ids)$extractIndexRange(1:3)$getValuesAsMatrix(), matrix(c(rep(3,3), rep(2,3), 2:4,2:4, rep(1,3), rep(5,3)), ncol = 3)) @@ -193,27 +193,27 @@ test_that("nodeIDs with multiple loops", { decl <- m$modelDef$declRules$y$rules[[1]] ids <- as.numeric(c(28:30,33:35,38:40,48:50,53:55,58:60)) - indexingRange <- decl$originalIndexingRule$apply('y[4:5,3:5,6:8]') - expect_identical(decl$getIDs(indexingRange), ids) - expect_identical(decl$getOriginalIndexing(ids)$toChar(), - 'y[4:5, 3:5, 6:8]') + indexingRange <- decl$loopIndexingRule$apply('y[4:5,3:5,6:8]') + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(), + 'index 1: 4:5, index 2: 3:5, index 3: 6:8') # do with arbitrary subsetting, separable - indexingRange <- decl$originalIndexingRule$apply('y[c(3,5),3:5,c(6,8)]') + indexingRange <- decl$loopIndexingRule$apply('y[c(3,5),3:5,c(6,8)]') ids <- c(8,10,13,15,18,20,48,50,53,55,58,60) - expect_identical(decl$getIDs(indexingRange), ids) - expect_identical(decl$getOriginalIndexing(ids)$toChar(), - 'y[c(3, 5), 3:5, c(6, 8)]') + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(), + 'index 1: c(3, 5), index 2: 3:5, index 3: c(6, 8)') # do with arbitrary subsetting, nonseparable ids <- c(46,51,56,30,35,40) - indexingRange <- varRangeClass$new(list(newIndexRange(quote(3:5)), + indexingRange <- loopIndexingRangeClass$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(), + rangeToIndexSlot=list(2,c(3,1))) + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(ids)$extractIndexRange(1:3)$getValuesAsMatrix(), matrix(c(rep(5,3), rep(4,3), 3:5,3:5, rep(4,3), rep(8,3)), ncol = 3)) code <- nimbleCode({ @@ -227,25 +227,25 @@ test_that("nodeIDs with multiple loops", { decl <- m$modelDef$declRules$y$rules[[1]] ids <- as.numeric(c(28:30,33:35,38:40,48:50,53:55,58:60)) - indexingRange <- decl$originalIndexingRule$apply('y[c(5,7),3:5,c(14,16,18)]') - expect_identical(decl$getIDs(indexingRange), ids) - expect_identical(decl$getOriginalIndexing(ids)$toChar(), - 'y[c(5, 7), 3:5, c(14, 16, 18)]') + indexingRange <- decl$loopIndexingRule$apply('y[c(5,7),3:5,c(14,16,18)]') + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(), + 'index 1: c(5, 7), index 2: 3:5, index 3: c(14, 16, 18)') # do with arbitrary subsetting, separable ids <- c(8,10,13,15,18,20,48,50,53,55,58,60) - indexingRange <- decl$originalIndexingRule$apply('y[c(3,7),3:5,c(14,18)]') - expect_identical(decl$getIDs(indexingRange), ids) - expect_identical(decl$getOriginalIndexing(ids)$toChar(), - 'y[c(3, 7), 3:5, c(14, 18)]') + indexingRange <- decl$loopIndexingRule$apply('y[c(3,7),3:5,c(14,18)]') + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(), + 'index 1: c(3, 7), index 2: 3:5, index 3: c(14, 18)') # do with arbitrary subsetting, nonseparable ids <- c(46,51,56,30,35,40) - indexingRange <- varRangeClass$new(list(newIndexRange(quote(3:5)), + indexingRange <- loopIndexingRangeClass$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(), + rangeToIndexSlot=list(2,c(3,1))) + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(ids)$extractIndexRange(1:3)$getValuesAsMatrix(), matrix(c(rep(7,3), rep(5,3), 3:5,3:5, rep(10,3), rep(18,3)), ncol = 3)) }) @@ -261,22 +261,22 @@ test_that("nonseparable loop indexing cases", { decl <- m$modelDef$declRules$y$rules[[1]] ids <- 3:6 - indexingRange <- varRangeClass$new(list(newIndexRange(quote(5:8))),varName='y') - expect_identical(decl$getIDs(indexingRange), ids) - expect_identical(decl$getOriginalIndexing(ids)$toChar(), - 'y[5:8]') + indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(quote(5:8)))) + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(), + 'index 1: 5:8') ids <- c(3L,6L) - indexingRange <- varRangeClass$new(list(newIndexRange(matrix(c(5,8),ncol=1))),varName='y') - expect_identical(decl$getIDs(indexingRange), ids) - expect_identical(decl$getOriginalIndexing(ids)$toChar(), - 'y[c(5, 8)]') + indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(matrix(c(5,8),ncol=1)))) + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(), + 'index 1: c(5, 8)') ids <- 3L - indexingRange <- varRangeClass$new(list(newIndexRange(5)),varName='y') - expect_identical(decl$getIDs(indexingRange), ids) - expect_identical(decl$getOriginalIndexing(ids)$toChar(), - 'y[5]') + indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(5))) + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(), + 'index 1: 5') code <- nimbleCode({ @@ -288,16 +288,16 @@ test_that("nonseparable loop indexing cases", { decl <- m$modelDef$declRules$y$rules[[1]] ids <- 3:6 - indexingRange <- varRangeClass$new(list(newIndexRange(quote(5:8))),varName='y') - expect_identical(decl$getIDs(indexingRange), ids) - expect_identical(decl$getOriginalIndexing(ids)$toChar(), - 'y[5:8]') + indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(quote(5:8)))) + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(), + 'index 1: 5:8') ids <- c(3L,6L) - indexingRange <- varRangeClass$new(list(newIndexRange(matrix(c(5,8),ncol=1))),varName='y') - expect_identical(decl$getIDs(indexingRange), ids) - expect_identical(decl$getOriginalIndexing(ids)$toChar(), - 'y[c(5, 8)]') + indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(matrix(c(5,8),ncol=1)))) + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(), + 'index 1: c(5, 8)') code <- nimbleCode({ for(i in 1:3) @@ -309,15 +309,15 @@ test_that("nonseparable loop indexing cases", { decl <- m$modelDef$declRules$y$rules[[1]] 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(), + indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(matrix(c(1,101,2,101),ncol=2,byrow=TRUE))),varName='y') + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(ids)$extractIndexRange(1:2)$getValuesAsMatrix(), matrix(c(1:2,101, 101),ncol=2)) 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)]") + indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(matrix(c(2,101),ncol=2,byrow=TRUE)))) + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(), "index 1: c(2, 101)") # separable and nonseparable code <- nimbleCode({ @@ -331,14 +331,14 @@ test_that("nonseparable loop indexing cases", { decl <- m$modelDef$declRules$y$rules[[1]] ids <- 1:24 - indexingRange <- decl$originalIndexingRule$apply('y') - expect_identical(decl$getIDs(indexingRange), ids) - expect_identical(decl$getOriginalIndexing(c(3,15))$extractIndexRange(1:3)$getValuesAsMatrix(), matrix(c(2,2,2,2,1,2),ncol=3)) + indexingRange <- decl$loopIndexingRule$apply('y') + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(c(3,15))$extractIndexRange(1:3)$getValuesAsMatrix(), matrix(c(2,2,2,2,1,2),ncol=3)) 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)]") + indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(matrix(c(2,2,2),ncol=3,byrow=TRUE)))) + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(), "index 1: c(2, 2, 2)") }) test_that("loop indexing with offsets", { @@ -351,13 +351,13 @@ test_that("loop indexing with offsets", { decl <- m$modelDef$declRules$y$rules[[1]] ids <- 3:4 - indexingRange <- varRangeClass$new(list(newIndexRange(quote(5:6))),varName='y') - expect_identical(decl$getIDs(indexingRange), ids) + indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(quote(5:6)))) + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) nr <- m$getNodes('y[7:8]') expect_identical(nr[[1]]$getIDs(), ids) - expect_identical(decl$getOriginalIndexing(ids)$toChar(),"y[5:6]") + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(), "index 1: 5:6") code <- nimbleCode({ for(i in 3:10) @@ -368,13 +368,13 @@ test_that("loop indexing with offsets", { decl <- m$modelDef$declRules$y$rules[[1]] ids <- 3:4 - indexingRange <- varRangeClass$new(list(newIndexRange(quote(5:6))),varName='y') - expect_identical(decl$getIDs(indexingRange), ids) + indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(quote(5:6)))) + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) nr <- m$getNodes('y[3:4]') expect_identical(nr[[1]]$getIDs(), ids) - expect_identical(decl$getOriginalIndexing(ids)$toChar(),"y[5:6]") + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(),"index 1: 5:6") code <- nimbleCode({ for(i in 3:10) @@ -386,13 +386,13 @@ test_that("loop indexing with offsets", { decl <- m$modelDef$declRules$y$rules[[1]] ids <- c(8,9,11,12) - indexingRange <- varRangeClass$new(list(newIndexRange(quote(5:6)), newIndexRange(quote(3:4))),varName='y') - expect_identical(decl$getIDs(indexingRange), ids) + indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(quote(5:6)), newIndexRange(quote(3:4)))) + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) nr <- m$getNodes('y[5:6,5:6]') expect_identical(nr[[1]]$getIDs(), ids) - expect_identical(decl$getOriginalIndexing(ids)$toChar(),"y[5:6, 3:4]") + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(),"index 1: 5:6, index 2: 3:4") }) @@ -406,8 +406,8 @@ test_that("multivariate nodes", { decl <- m$modelDef$declRules$y$rules[[1]] ids <- 2:3 - indexingRange <- varRangeClass$new(list(newIndexRange(quote(5:6))),varName='y') - expect_identical(decl$getIDs(indexingRange), ids) + indexingRange <- loopIndexingRangeClass$new(list(newIndexRange(quote(5:6)))) + expect_identical(decl$getIDsFromLoopIndexing(indexingRange), ids) nr <- m$getNodes('y[2:4, 3:4]') expect_identical(nr[[1]]$getIDs(), ids) @@ -415,5 +415,5 @@ test_that("multivariate nodes", { nr <- m$getNodes('y[3:4, 3:4]') expect_identical(nr[[1]]$getIDs(), ids) - expect_identical(decl$getOriginalIndexing(ids)$toChar(),"y[5:6]") + expect_identical(decl$getLoopIndexingFromIDs(ids)$toChar(),"index 1: 5:6") }) diff --git a/nimbleModel/tests/testthat/test-nodeRules.R b/nimbleModel/tests/testthat/test-nodeRules.R index 652af03..9317a9a 100644 --- a/nimbleModel/tests/testthat/test-nodeRules.R +++ b/nimbleModel/tests/testthat/test-nodeRules.R @@ -7,11 +7,11 @@ test_that("declRules are generated correctly", { modelDecl$processDecl(NULL, list(), .GlobalEnv) expect_identical(modelDecl$stoch, TRUE) expect_equal( - modelDecl$declRule$originalIndexingRule$apply( + modelDecl$declRule$loopIndexingRule$apply( varRangeClass$new(list( newIndexRange(quote(3:6))))), - varRangeClass$new(list( - newIndexRange(quote(2:4))), varName = 'y') + loopIndexingRangeClass$new(list( + newIndexRange(quote(2:4)))) ) }) @@ -373,7 +373,7 @@ test_that("calcRanges are generated correctly", { calcRange <- calcRule$makeCalcRange(varRangeClass$new(list(newIndexRange(quote(3:5))))) expect_equal(calcRange$indexingRange, - varRangeClass$new(list(newIndexRange(quote(2:4))), varName = 'y')) + loopIndexingRangeClass$new(list(newIndexRange(quote(2:4))))) ## Mismatched varNames expect_error(calcRule$makeCalcRange(varRangeClass$new(list(newIndexRange(quote(3:5))), @@ -444,9 +444,9 @@ test_that("calcRanges are generated correctly", { newIndexRange(quote(1:6)), newIndexRange(2)))) expect_equal(calcRange$indexingRange, - varRangeClass$new(list(newIndexRange(matrix(c(2,7))), + loopIndexingRangeClass$new(list(newIndexRange(matrix(c(2,7))), newIndexRange(quote(3:5)), - newIndexRange(quote(1:4))), varName = 'y')) + newIndexRange(quote(1:4))))) calcRange <- calcRule$makeCalcRange(varRangeClass$new(list( @@ -462,8 +462,8 @@ test_that("calcRanges are generated correctly", { newIndexRange(2)) )) expect_equal(calcRange$indexingRange, - varRangeClass$new(list(newIndexRange(matrix(c(2,8,1,2), ncol = 2)), - newIndexRange(quote(3:5))), rangeToIndexSlot = list(c(1,3), 2), varName = 'y')) + loopIndexingRangeClass$new(list(newIndexRange(matrix(c(2,8,1,2), ncol = 2)), + newIndexRange(quote(3:5))), rangeToIndexSlot = list(c(1,3), 2))) calcRange <- calcRule$makeCalcRange(varRangeClass$new(list( newIndexRange(quote(3:5)), @@ -471,9 +471,9 @@ test_that("calcRanges are generated correctly", { newIndexRange(quote(1:5)) ), rangeToIndexSlot = list(1,c(2,4), 3))) expect_equal(calcRange$indexingRange, - varRangeClass$new(list(newIndexRange(matrix(c(2,6))), + loopIndexingRangeClass$new(list(newIndexRange(matrix(c(2,6))), newIndexRange(quote(3:5)), - newIndexRange(quote(1:4))), varName = 'y')) + newIndexRange(quote(1:4))))) ## j in 1:n[i] type case singleContext1 <- @@ -495,8 +495,7 @@ test_that("calcRanges are generated correctly", { newIndexRange(quote(1:3)) ))) expect_equal(calcRange$indexingRange, - varRangeClass$new(list(newIndexRange(matrix(c(1,2,2,2,1,1,2,3), ncol = 2))), - varName = 'y')) + loopIndexingRangeClass$new(list(newIndexRange(matrix(c(1,2,2,2,1,1,2,3), ncol = 2))))) # multi sortID case code <- nimbleCode({