From 5a0a241c80c72d07f22a312bea31e0921e4bf0cc Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Fri, 20 Jun 2025 09:17:37 -0700 Subject: [PATCH 01/11] Fix misspelling in an error msg. --- packages/nimble/R/nimbleProject.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/packages/nimble/R/nimbleProject.R b/packages/nimble/R/nimbleProject.R index 690470696..01e0b6c9b 100644 --- a/packages/nimble/R/nimbleProject.R +++ b/packages/nimble/R/nimbleProject.R @@ -899,7 +899,7 @@ nimbleProjectClass <- setRefClass('nimbleProjectClass', ans <- nfCppDef$buildCallable(nf, dll = dll, asTopLevel = asTopLevel) ok <- !is.null(ans) } - if(!ok) stop("Oops, there is something in this compilation job that doesn\'t fit together. This can happen in some cases if you are trying to compile new pieces into an exising project. If that is the situation, please try including \"resetFunctions = TRUE\" as an argument to compileNimble. Alternatively please try rebuilding the project from the beginning with more pieces in the same call to compileNimble. For example, if you are compiling multiple algorithms for the same model in multiple calls to compileNimble, try compiling them all with one call.", call. = FALSE) + if(!ok) stop("There is something in this compilation job that doesn\'t fit together. This can happen in some cases if you are trying to compile new pieces into an existing project. If that is the situation, please try including \"resetFunctions = TRUE\" as an argument to compileNimble. Alternatively please try rebuilding the project from the beginning with more pieces in the same call to compileNimble. For example, if you are compiling multiple algorithms for the same model in multiple calls to compileNimble, try compiling them all with one call.", call. = FALSE) ans }, From 999f0a3c5a1ba963630e6bf2d0e6be698fa44c48 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Sat, 28 Jun 2025 11:41:59 -0700 Subject: [PATCH 02/11] Add a bit more on alternatives to default samplers in documentation. --- UserManual/src/chapter_MCMC.Rmd | 2 +- packages/nimble/R/MCMC_samplers.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/UserManual/src/chapter_MCMC.Rmd b/UserManual/src/chapter_MCMC.Rmd index e21d9acce..7d378738e 100644 --- a/UserManual/src/chapter_MCMC.Rmd +++ b/UserManual/src/chapter_MCMC.Rmd @@ -881,7 +881,7 @@ If `fixedValue` is given when using `indicatorNodes` the values provided in `fix -NIMBLE provides a variety of other commonly-used samplers, some for general-purpose use and some for specialized use with particular distributions or situations. Some that are worth particular consideration are: +NIMBLE provides a variety of other commonly-used samplers, some for general-purpose use and some for specialized use with particular distributions or situations. Some that are worth particular consideration as they may perform better than the samplers that NIMBLE assigns by default are: 1. the Hamiltonian Monte Carlo (HMC) sampler in the `nimbleHMC` package, 2. the slice sampler for sampling scalar parameters in place of the default `RW` (Metropolis) sampler, diff --git a/packages/nimble/R/MCMC_samplers.R b/packages/nimble/R/MCMC_samplers.R index 3914f25ce..bb9608824 100644 --- a/packages/nimble/R/MCMC_samplers.R +++ b/packages/nimble/R/MCMC_samplers.R @@ -3513,7 +3513,7 @@ sampler_barker <- nimbleFunction( #' MCMC Sampling Algorithms #' -#' Details of the MCMC sampling algorithms provided with the NIMBLE MCMC engine; HMC samplers are in the \code{nimbleHMC} package and particle filter samplers are in the \code{nimbleSMC} package. +#' Details of the MCMC sampling algorithms provided with the NIMBLE MCMC engine; HMC samplers are in the \code{nimbleHMC} package and particle filter samplers are in the \code{nimbleSMC} package. Additional details, including some recommendations for samplers that may perform better than the samplers that NIMBLE assigns by default are provided in Section 7.11 of the User Manual. #' #' #' @param model (uncompiled) model on which the MCMC is to be run From d783263c0cd1169819f3d107450972cff1adcc16 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Sat, 28 Jun 2025 11:50:45 -0700 Subject: [PATCH 03/11] Provide a test of compilation in Chapter 4 of manual. --- UserManual/src/chapter_InstallingNimble.Rmd | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/UserManual/src/chapter_InstallingNimble.Rmd b/UserManual/src/chapter_InstallingNimble.Rmd index 6588b9424..a208c8e63 100644 --- a/UserManual/src/chapter_InstallingNimble.Rmd +++ b/UserManual/src/chapter_InstallingNimble.Rmd @@ -88,6 +88,15 @@ method if you download the package source directly. NIMBLE can also be obtained from the [NIMBLE website](https://r-nimble.org). To install from our website, please see our [Download page](https://r-nimble.org/download) for the specific invocation of `install.packages`. +To test that the installation worked and can use NIMBLE's compilation system, you can run this small test code, which should run without error and produce a value for `y` in the model. + +```{r, eval=FALSE} +code <- nimbleCode({ y ~ dnorm(0,1) }) +model <- nimbleModel(code) +comp_model <- compileNimble(model) +comp_model$simulate('y') +comp_model$y +``` ## Troubleshooting installation problems @@ -125,6 +134,7 @@ For MacOS: All operating systems: + - To determine if the problem is with the availability of the C++ compiler or with NIMBLE itself, you can try to install the `Rcpp` package. If you can install `Rcpp` and successfully run this command in R: `Rcpp::evalCpp("2 + 2")` and get 4, that suggests the problem is with NIMBLE. If not, then the problem is probably with the C++ compiler or its use from R and not with NIMBLE itself. - If problems arise from generating and compiling C++ files from the default location in R's `tempdir()`, one can use the `dirName` argument to `compileNimble` to put such files elsewhere, such as in a local working directory. If those suggestions don't help, please post about installation problems to the [nimble-users Google group](https://groups.google.com/forum/#!forum/nimble-users) or From 18894961fac8c0e131d7f38df8cb993d4c5b865e Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Sat, 28 Jun 2025 12:29:44 -0700 Subject: [PATCH 04/11] Make BNP docn more user-friendly for less theoretical users. --- UserManual/src/chapter_BNP.Rmd | 14 ++++++++------ packages/nimble/R/BNP_samplers.R | 14 +++++++------- 2 files changed, 15 insertions(+), 13 deletions(-) diff --git a/UserManual/src/chapter_BNP.Rmd b/UserManual/src/chapter_BNP.Rmd index 4463a2885..ecf5941fe 100644 --- a/UserManual/src/chapter_BNP.Rmd +++ b/UserManual/src/chapter_BNP.Rmd @@ -13,25 +13,27 @@ require(nimble) ## Bayesian nonparametric mixture models {#sec:bnpmixtures} -NIMBLE provides support for Bayesian nonparametric (BNP) mixture modeling. The current implementation provides support for hierarchical specifications involving Dirichlet process (DP) mixtures [@ferguson_73;@ferguson_74;@lo_84;@escobar_94;@escobar_west_95]. More specifically, a DP mixture model takes the form +NIMBLE provides support for Bayesian nonparametric (BNP) mixture modeling. The current implementation provides support for hierarchical specifications involving Dirichlet process (DP) mixtures [@ferguson_73;@ferguson_74;@lo_84;@escobar_94;@escobar_west_95]. These allow one to avoid specifying a particular parametric distribution for a given node (parameter) in a model. Instead one can use a DP mixture as a much more general, nonparametric distribution. For example, a normal distribution for a random effect could be replaced by a DP mixture of normal distributions, with the number of components of the mixture being determined from the data and not fixed in advance. + +We'll first introduce the general, technical definition of a DP mixture model before describing the Chinese Restaurant Process representation, which may be more interpretable for many readers. More specifically, a DP mixture model for a random variable $y_i$ takes the form $$y_i \mid G \overset{iid}{\sim} \int h(y_i \mid \theta) G(d\theta),$$ $$G \mid \alpha, G_0 \sim DP(\alpha, G_0),$$ -where $h(\cdot \mid \theta)$ is a suitable kernel with parameter $\theta$, and $\alpha$ and $G_0$ are the concentration and baseline distribution parameters of the DP, respectively. DP mixture models can be written with different levels of hierarchy, all being equivalent to the model above. +where $h(\cdot \mid \theta)$ is a suitable kernel (i.e., probability density/mass function) with parameter $\theta$, and $\alpha$ and $G_0$ are the concentration and baseline distribution parameters of the DP, respectively. DP mixture models can be written with different levels of hierarchy, all being equivalent to the model above. While "y" would often be used as notation for a data value, it is used generically here, noting that often DP mixtures are used for random effects rather than directly for observations. -When the random measure $G$ is integrated out from the model, the DP mixture model can be written using latent or membership variables, $z_i$, following a Chinese Restaurant Process (CRP) distribution [@blackwell_mcqueen_73], discussed in Section \@ref(sec:crp). The model takes the form +When the random distribution (also referred to as a random 'measure') $G$ is integrated out from the model, the DP mixture model can be written using latent or membership variables, $z_i$, following a Chinese Restaurant Process (CRP) distribution [@blackwell_mcqueen_73], discussed in Section \@ref(sec:crp). The model takes the form $$y_i \mid \tilde{\boldsymbol{\theta}}, z_i \overset{ind}{\sim} h(\cdot \mid \tilde{\theta}_{z_i}),$$ $$\boldsymbol{z}\mid \alpha \sim \mbox{CRP}(\alpha),\hspace{0.5cm} \tilde{\theta}_j \overset{iid}{\sim}G_0,$$ -where $\mbox{CRP}(\alpha)$ denotes the CRP distribution with concentration parameter $\alpha$. +where $\mbox{CRP}(\alpha)$ denotes the CRP distribution with concentration parameter $\alpha$. Put in perhaps more intuitive terms, $z_i$ says which cluster/group the $i$th unit is in, and the parameter $\tilde{\theta}_j$ for group $j$ is distributed according to the $G_0$ baseline distribution. The parameter $\alpha$ controls how dispersed the clustering is, described more in the next section. -If a stick-breaking representation [@sethuraman_94], discussed in section \@ref(sec:sb), is assumed for the random measure $G$, then the model takes the form +If a stick-breaking representation [@sethuraman_94], discussed in section \@ref(sec:sb), is assumed for the random distribution (measure) $G$, then the model takes the form $$y_i \mid {\boldsymbol{\theta}}^{\star}, \boldsymbol{v} \overset{ind}{\sim} \sum_{l=1}^{\infty}\left\{ v_l\prod_{m Date: Sat, 28 Jun 2025 12:38:08 -0700 Subject: [PATCH 05/11] Make minor edit to nimDerivs roxygen. --- packages/nimble/R/nimbleFunction_Rderivs.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/packages/nimble/R/nimbleFunction_Rderivs.R b/packages/nimble/R/nimbleFunction_Rderivs.R index b8864bde7..872188090 100644 --- a/packages/nimble/R/nimbleFunction_Rderivs.R +++ b/packages/nimble/R/nimbleFunction_Rderivs.R @@ -25,8 +25,8 @@ nimDerivs_dummy <- nimbleFunction( #' @param order an integer vector with values within the set \eqn{{0, 1, 2}}, #' corresponding to whether the function value, Jacobian, and Hessian should be #' returned respectively. Defaults to \code{c(0, 1, 2)}. -#' @param model (optional) for derivatives of a nimbleFunction that involves model. -#' calculations, the uncompiled model that is used. This is needed in order +#' @param model (optional) the uncompiled model that is used, if taking derivatives +#' of a nimbleFunction that involves model calculations. This is needed in order #' to be able to correctly restore values into the model when \code{order} does not #' include 0 (or in all cases when double-taping). #' @param ... additional arguments intended for internal use only. From 29aab455a18489925bf75ac92ac6ec782490fbec Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Sat, 28 Jun 2025 12:47:05 -0700 Subject: [PATCH 06/11] Fix up nimDerivs roxygen to be more clear about derivs of nfs. --- packages/nimble/R/nimbleFunction_Rderivs.R | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/packages/nimble/R/nimbleFunction_Rderivs.R b/packages/nimble/R/nimbleFunction_Rderivs.R index 872188090..f419c9243 100644 --- a/packages/nimble/R/nimbleFunction_Rderivs.R +++ b/packages/nimble/R/nimbleFunction_Rderivs.R @@ -28,13 +28,22 @@ nimDerivs_dummy <- nimbleFunction( #' @param model (optional) the uncompiled model that is used, if taking derivatives #' of a nimbleFunction that involves model calculations. This is needed in order #' to be able to correctly restore values into the model when \code{order} does not -#' include 0 (or in all cases when double-taping). +#' include 0 (or in all cases when double-taping). IMPORTANT: if \code{model} +#' is included, one should also include the arguments \code{updateNodes} and +#' \code{constantNodes} using the output obtained from running +#' \code{makeModelDerivsInfo}. #' @param ... additional arguments intended for internal use only. #' #'@details Derivatives for uncompiled nimbleFunctions are calculated using the #' \code{numDeriv} package. If this package is not installed, an error will #' be issued. Derivatives for matrix valued arguments will be returned in #' column-major order. +#' +#' As discussed above with the \code{model} argument, if taking derivatives +#' of a nimbleFunction that involves model calculations (rather than directly +#' taking derivatives of `calculate`), care needs to be taken to provide +#' \code{model}, \code{updateNodes}, and \code{calcNodes} arguments. See +#' Section 16.7.2 of the User Manual for more details. #' #' @return an \code{ADNimbleList} with elements \code{value}, \code{jacobian}, #' and \code{hessian}. From f417bd0711946e42c722079f0d3d547649442124 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Mon, 30 Jun 2025 16:04:17 -0700 Subject: [PATCH 07/11] Add check that correct args passed to nimDerivs when taking deriv of method containing calculate call (NCT issue 557). --- packages/nimble/R/RCfunction_core.R | 32 +++++- packages/nimble/R/nimbleFunction_Rderivs.R | 10 +- packages/nimble/R/nimbleFunction_core.R | 13 +++ .../tests/testthat/test-ADerrorTrapping.R | 102 ++++++++++++++++++ 4 files changed, 147 insertions(+), 10 deletions(-) diff --git a/packages/nimble/R/RCfunction_core.R b/packages/nimble/R/RCfunction_core.R index 7f49de6e8..7642435b7 100644 --- a/packages/nimble/R/RCfunction_core.R +++ b/packages/nimble/R/RCfunction_core.R @@ -263,7 +263,7 @@ nf_checkDSLcode_buildDerivs <- function(code, buildDerivs) { if(isFALSE(buildDerivs) || !length(buildDerivs) || is.null(buildDerivs) || (is.character(buildDerivs) && !methodName %in% buildDerivs) || (is.list(buildDerivs) && !methodName %in% names(buildDerivs))) - message(" [Note] Detected use of `nimDerivs` with a function or method, `", methodName, "`, for which `buildDerivs` has not been set. This nimbleFunction cannot be compiled.") + messageIfVerbose(" [Note] Detected use of `nimDerivs` with a function or method, `", methodName, "`, for which `buildDerivs` has not been set. This nimbleFunction cannot be compiled.") } } @@ -271,6 +271,36 @@ nf_checkDSLcode_buildDerivs <- function(code, buildDerivs) { invisible(NULL) } +nf_checkDSLcode_checkForCalc <- function(code) { + code <- body(code) + return(sum(all.names(code) == "calculate") != sum(all.vars(code)=="calculate")) +} + + +nf_checkDSLcode_calcDerivsArgs <- function(code, methodsWithCalc) { + code <- body(code) + ## This assumes `derivs()` call is from assignment like `var <- derivs()`. + derivsFound <- which(sapply(code, function(expr) + length(expr) >= 3 && length(expr[[1]]) == 1 && + as.character(expr[[1]]) %in% c("=", "<-", "<<-") && + length(expr[[3]]) > 1 && length(expr[[3]][[1]]) == 1 && + as.character(expr[[3]][[1]]) %in% c('derivs', 'nimDerivs'))) + for(idx in derivsFound) { + argNames <- names(code[[idx]][[3]]) + call <- code[[idx]][[3]][[2]][[1]] + if(length(call) == 1 && as.character(call) %in% methodsWithCalc && + length(setdiff(c('model', 'constantNodes', 'updateNodes'), argNames))) + messageIfVerbose(" [Warning] Detected use of `nimDerivs` on a function or method, `", code[[idx]][[3]][[2]][[1]], "`,\n", + " that appears to contain the use of `calculate` on a model.\n", + " If model calculations are done in the method being differentiated, the 'model'\n", + " argument to 'nimDerivs' should be included to ensure correct restoration of\n", + " values in the model, and the 'updateNodes' and 'constantNodes' arguments\n", + " should also be provided (see Section 16.7.2 of the User Manual).") + } + invisible(NULL) +} + + nf_checkDSLcode <- function(code, methodNames, setupVarNames, args, where = NULL) { validCalls <- c(names(sizeCalls), otherDSLcalls, diff --git a/packages/nimble/R/nimbleFunction_Rderivs.R b/packages/nimble/R/nimbleFunction_Rderivs.R index f419c9243..d99ec5284 100644 --- a/packages/nimble/R/nimbleFunction_Rderivs.R +++ b/packages/nimble/R/nimbleFunction_Rderivs.R @@ -703,15 +703,7 @@ nimDerivs_nf <- function(call = NA, if(e$restoreInfo$deepestDepth < e$restoreInfo$currentDepth) e$restoreInfo$deepestDepth <- e$restoreInfo$currentDepth } - } else { # partial check for whether there is a model in the nimbleFunction - if(is(derivFxn, 'refMethodDef') && is.nf(e$.self)) { - isModel <- sapply(names(e), function(x) is.model(e[[x]])) - if(any(isModel)) { - modelElement <- names(e)[which(isModel)] - warning("nimDerivs_nf: detected a model, ", paste(modelElement, collapse = ','), ", associated with the nimbleFunction whose method is being differentiated. If model calculations are done in the method being differentiated, the 'model' argument to 'nimDerivs' should be included to ensure correct restoration of values in the model.") - } - } - } + } ## standardize the derivFxnCall arguments derivFxnCall <- match.call(derivFxn, derivFxnCall) diff --git a/packages/nimble/R/nimbleFunction_core.R b/packages/nimble/R/nimbleFunction_core.R index db68b14ac..cf4dd2005 100644 --- a/packages/nimble/R/nimbleFunction_core.R +++ b/packages/nimble/R/nimbleFunction_core.R @@ -85,10 +85,23 @@ nimbleFunction <- function(setup = NULL, force(where) # so that we can get to namespace where a nf is defined by using topenv(parent.frame(2)) in getNimbleFunctionEnvironment() if(is.logical(setup)) if(setup) setup <- function() {} else setup <- NULL + ## Check for correct entries in `buildDerivs` separately from `nfMethodRC$new()` because ## that only has access to `thisBuildDerivs`, and we need to check if `buildDerivs` is set ## for the method on which `nimDerivs` is called. tmp <- sapply(c(list(run = run), methods), nf_checkDSLcode_buildDerivs, buildDerivs) + + ## Check that if a model calculate is in the code of `run` or another method on + ## which `derivs` is called, that the `model`, `updateNodes`,and `constantNodes` + ## arguments are provided. + if(length(buildDerivs)) { + allMethods <- c(list(run = run), methods) + if(is.character(buildDerivs)) nms <- buildDerivs else nms <- names(buildDerivs) + methodsWithCalc <- sapply(allMethods[nms], nf_checkDSLcode_checkForCalc) + methodsWithCalc <- nms[methodsWithCalc] + if(length(methodsWithCalc)) + tmp <- sapply(c(list(run = run), methods), nf_checkDSLcode_calcDerivsArgs, methodsWithCalc) + } if(is.null(setup)) { if(length(methods) > 0) stop('Cannot provide multiple methods if there is no setup function. Use "setup = function(){}" or "setup = TRUE" if you need a setup function that does not do anything', call. = FALSE) diff --git a/packages/nimble/tests/testthat/test-ADerrorTrapping.R b/packages/nimble/tests/testthat/test-ADerrorTrapping.R index 1e9e52bb1..790a65eb2 100644 --- a/packages/nimble/tests/testthat/test-ADerrorTrapping.R +++ b/packages/nimble/tests/testthat/test-ADerrorTrapping.R @@ -327,3 +327,105 @@ test_that("Incorrect use of buildDerivs=TRUE in nimbleFunction with setup.", { ) }) +test_that("Warning message works for use of nimDerivs with model calculate and incorrect args", { + expect_silent( + mynf <- nimbleFunction( + setup = function(model){ + paramNodes = 'psi[1:4]' + }, + run = function(x = double(1), alpha=double(1)) { + returnType(double(0)) + inds <- 1:length(x) + + tmp <- derivs(dens_calc(x), inds, order = c(0,1), model = model, constantNodes = "", updateNodes = "") + + ## Do AD on ddirch directly. This works. + tmp <- derivs(dens_direct(x, alpha), inds, order = c(0,1)) + + ## Do AD on model$calculate. This works. + tmp <- derivs(model$calculate(paramNodes), wrt = paramNodes, order = c(0,1)) + + return(dens_calc(x)) + }, + methods = list( + ## This mimics calcPrior_p in nimbleQuad + dens_calc = function(x = double(1)) { + values(model, paramNodes) <<- x + result <- model$calculate(paramNodes) + returnType(double(0)) + return(result) + }, + dens_direct = function(x = double(1), alpha=double(1)) { + result <- ddirch(x, alpha, log = TRUE) + calculate <- 7 + returnType(double(0)) + return(result) + } + ), + buildDerivs = c('dens_calc','dens_direct') + )) + + expect_error( + mynf <- nimbleFunction( + setup = function(model){ + paramNodes = 'psi[1:4]' + }, + run = function(x = double(1), alpha=double(1)) { + returnType(double(0)) + inds <- 1:length(x) + + tmp = derivs(dens_calc(x), inds, order = c(0,1), constantNodes = "", updateNodes = "") + + return(dens_calc(x)) + }, + methods = list( + ## This mimics calcPrior_p in nimbleQuad + dens_calc = function(x = double(1)) { + values(model, paramNodes) <<- x + result <- model$calculate(paramNodes) + returnType(double(0)) + return(result) + }, + dens_direct = function(x = double(1), alpha=double(1)) { + result <- ddirch(x, alpha, log = TRUE) + calculate <- 7 + returnType(double(0)) + return(result) + } + ), + buildDerivs = c('dens_calc','dens_direct') + ), "appears to contain the use of `calculate` on a model") + + expect_error( + mynf <- nimbleFunction( + setup = function(model){ + paramNodes = 'psi[1:4]' + }, + run = function(x = double(1), alpha=double(1)) { + returnType(double(0)) + inds <- 1:length(x) + + tmp <- derivs(dens_calc(x), inds, order = c(0,1), model = model) + + return(dens_calc(x)) + }, + methods = list( + ## This mimics calcPrior_p in nimbleQuad + dens_calc = function(x = double(1)) { + values(model, paramNodes) <<- x + result <- model$calculate(paramNodes) + returnType(double(0)) + return(result) + }, + dens_direct = function(x = double(1), alpha=double(1)) { + result <- ddirch(x, alpha, log = TRUE) + calculate <- 7 + returnType(double(0)) + return(result) + } + ), + buildDerivs = c('dens_calc','dens_direct') + ), "appears to contain the use of `calculate` on a model") +}) + + From 13359b8e18a3a53b12b9ba46b92003cff49b9892 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Tue, 1 Jul 2025 13:26:44 -0700 Subject: [PATCH 08/11] Fix test for new AD warning. --- packages/nimble/tests/testthat/test-ADerrorTrapping.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/packages/nimble/tests/testthat/test-ADerrorTrapping.R b/packages/nimble/tests/testthat/test-ADerrorTrapping.R index 790a65eb2..ad835e681 100644 --- a/packages/nimble/tests/testthat/test-ADerrorTrapping.R +++ b/packages/nimble/tests/testthat/test-ADerrorTrapping.R @@ -365,7 +365,7 @@ test_that("Warning message works for use of nimDerivs with model calculate and i buildDerivs = c('dens_calc','dens_direct') )) - expect_error( + expect_message( mynf <- nimbleFunction( setup = function(model){ paramNodes = 'psi[1:4]' @@ -396,7 +396,7 @@ test_that("Warning message works for use of nimDerivs with model calculate and i buildDerivs = c('dens_calc','dens_direct') ), "appears to contain the use of `calculate` on a model") - expect_error( + expect_message( mynf <- nimbleFunction( setup = function(model){ paramNodes = 'psi[1:4]' From da0d8b74cee80aa739be0a2738887fd68c721156 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 9 Jul 2025 12:45:23 -0700 Subject: [PATCH 09/11] Extend checking of nimDerivs args to nested case, and hide checking behind an option. --- packages/nimble/R/RCfunction_core.R | 33 ++++- packages/nimble/R/nimbleFunction_core.R | 6 +- packages/nimble/R/options.R | 3 +- .../tests/testthat/test-ADerrorTrapping.R | 115 ++++++++++++++++++ 4 files changed, 149 insertions(+), 8 deletions(-) diff --git a/packages/nimble/R/RCfunction_core.R b/packages/nimble/R/RCfunction_core.R index 7642435b7..fd650f93b 100644 --- a/packages/nimble/R/RCfunction_core.R +++ b/packages/nimble/R/RCfunction_core.R @@ -276,19 +276,42 @@ nf_checkDSLcode_checkForCalc <- function(code) { return(sum(all.names(code) == "calculate") != sum(all.vars(code)=="calculate")) } - -nf_checkDSLcode_calcDerivsArgs <- function(code, methodsWithCalc) { +nf_checkDSLcode_checkDerivsOf <- function(code) { code <- body(code) ## This assumes `derivs()` call is from assignment like `var <- derivs()`. - derivsFound <- which(sapply(code, function(expr) + derivsFound <- which(findDerivsCalls(code)) + if(length(derivsFound)) { + derivsOf <- sapply(derivsFound, function(i) + return(code[[i]][[3]][[2]][[1]])) + return(as.character(derivsOf[sapply(derivsOf, is.name)])) + } + return(NULL) +} + +findDerivsCalls <- function(code) { + sapply(code, function(expr) length(expr) >= 3 && length(expr[[1]]) == 1 && as.character(expr[[1]]) %in% c("=", "<-", "<<-") && length(expr[[3]]) > 1 && length(expr[[3]][[1]]) == 1 && - as.character(expr[[3]][[1]]) %in% c('derivs', 'nimDerivs'))) + as.character(expr[[3]][[1]]) %in% c('derivs', 'nimDerivs')) +} + +checkNestedCalcCall <- function(functionName, methodsWithCalc, methodsDerivsOf) { + if(functionName %in% methodsWithCalc) return(TRUE) + if(functionName %in% names(methodsDerivsOf)) + return(any(sapply(methodsDerivsOf[[functionName]], checkNestedCalcCall, + methodsWithCalc, methodsDerivsOf))) + return(FALSE) +} + +nf_checkDSLcode_calcDerivsArgs <- function(code, methodsWithCalc, methodsDerivsOf) { + code <- body(code) + ## This assumes `derivs()` call is from assignment like `var <- derivs()`. + derivsFound <- which(findDerivsCalls(code)) for(idx in derivsFound) { argNames <- names(code[[idx]][[3]]) call <- code[[idx]][[3]][[2]][[1]] - if(length(call) == 1 && as.character(call) %in% methodsWithCalc && + if(length(call) == 1 && checkNestedCalcCall(as.character(call), methodsWithCalc, methodsDerivsOf) && length(setdiff(c('model', 'constantNodes', 'updateNodes'), argNames))) messageIfVerbose(" [Warning] Detected use of `nimDerivs` on a function or method, `", code[[idx]][[3]][[2]][[1]], "`,\n", " that appears to contain the use of `calculate` on a model.\n", diff --git a/packages/nimble/R/nimbleFunction_core.R b/packages/nimble/R/nimbleFunction_core.R index cf4dd2005..3ec584178 100644 --- a/packages/nimble/R/nimbleFunction_core.R +++ b/packages/nimble/R/nimbleFunction_core.R @@ -94,13 +94,15 @@ nimbleFunction <- function(setup = NULL, ## Check that if a model calculate is in the code of `run` or another method on ## which `derivs` is called, that the `model`, `updateNodes`,and `constantNodes` ## arguments are provided. - if(length(buildDerivs)) { + if(getNimbleOptions('checkDerivsArgs') && length(buildDerivs)) { allMethods <- c(list(run = run), methods) if(is.character(buildDerivs)) nms <- buildDerivs else nms <- names(buildDerivs) methodsWithCalc <- sapply(allMethods[nms], nf_checkDSLcode_checkForCalc) methodsWithCalc <- nms[methodsWithCalc] + methodsDerivsOf <- sapply(allMethods, nf_checkDSLcode_checkDerivsOf) + methodsDerivsOf <- methodsDerivsOf[!sapply(methodsDerivsOf, is.null)] if(length(methodsWithCalc)) - tmp <- sapply(c(list(run = run), methods), nf_checkDSLcode_calcDerivsArgs, methodsWithCalc) + tmp <- sapply(c(list(run = run), methods), nf_checkDSLcode_calcDerivsArgs, methodsWithCalc, methodsDerivsOf) } if(is.null(setup)) { diff --git a/packages/nimble/R/options.R b/packages/nimble/R/options.R index c017a653b..e6388c584 100644 --- a/packages/nimble/R/options.R +++ b/packages/nimble/R/options.R @@ -226,7 +226,8 @@ nimOptimMethod("bobyqa", useOldcWiseRule = FALSE, # This is a safety toggle for one change in sizeBinaryCwise, 1/24/23. After a while we can remove this. stripUnusedTypeDefs = TRUE, digits = NULL, - enableVirtualNodeFunctionDefs = FALSE + enableVirtualNodeFunctionDefs = FALSE, + checkDerivsArgs = TRUE ) ) diff --git a/packages/nimble/tests/testthat/test-ADerrorTrapping.R b/packages/nimble/tests/testthat/test-ADerrorTrapping.R index ad835e681..74ac7bf29 100644 --- a/packages/nimble/tests/testthat/test-ADerrorTrapping.R +++ b/packages/nimble/tests/testthat/test-ADerrorTrapping.R @@ -429,3 +429,118 @@ test_that("Warning message works for use of nimDerivs with model calculate and i }) + + + +test_that("Warning message works for use of nimDerivs with nested model calculate and incorrect args", { + expect_silent( + mynf <- nimbleFunction( + setup = function(model){ + paramNodes = 'psi[1:4]' + }, + run = function(x = double(1), alpha=double(1)) { + }, + methods = list( + inner_logLik = function(reTransform = double(1)) { + values(model, randomEffectsNodes) <<- reTransform + ans <- model$calculate(innerCalcNodes) + return(ans) + returnType(double()) + }, + gr_inner_logLik_internal = function(reTransform = double(1)) { + ans <- derivs(inner_logLik(reTransform), wrt = re_indices_inner, order = 1, model = model, + updateNodes = inner_updateNodes, constantNodes = inner_constantNodes) + return(ans$jacobian[1,]) + returnType(double(1)) + }, + ## Double taping for efficiency + he_inner_logLik_internal = function(reTransform = double(1)) { + ans <- derivs(gr_inner_logLik_internal(reTransform), wrt = re_indices_inner, order = 1, model = model, + updateNodes = inner_updateNodes, constantNodes = inner_constantNodes) + return(ans$jacobian) + returnType(double(2)) + }, + he_inner_logLik_internal = function(reTransform = double(1)) { + ans <- derivs(gr_inner_logLik_internal(reTransform), wrt = re_indices_inner, order = 0, model = model, + updateNodes = inner_updateNodes, constantNodes = inner_constantNodes) + return(ans$value) + returnType(double(2)) + } + ), buildDerivs = c('inner_logLik','gr_inner_logLik_internal','he_inner_logLik_internal') + ) + ) + + expect_message( + mynf <- nimbleFunction( + setup = function(model){ + paramNodes = 'psi[1:4]' + }, + run = function(x = double(1), alpha=double(1)) { + }, + methods = list( + inner_logLik = function(reTransform = double(1)) { + values(model, randomEffectsNodes) <<- reTransform + ans <- model$calculate(innerCalcNodes) + return(ans) + returnType(double()) + }, + gr_inner_logLik_internal = function(reTransform = double(1)) { + ans <- derivs(inner_logLik(reTransform), wrt = re_indices_inner, order = 1, model = model, + updateNodes = inner_updateNodes, constantNodes = inner_constantNodes) + return(ans$jacobian[1,]) + returnType(double(1)) + }, + he_inner_logLik_internal = function(reTransform = double(1)) { + ans <- derivs(gr_inner_logLik_internal(reTransform), wrt = re_indices_inner, order = 1, model = model, + updateNodes = inner_updateNodes, constantNodes = inner_constantNodes) + return(ans$jacobian) + returnType(double(2)) + }, + he_inner_logLik = function(reTransform = double(1)) { + ans <- derivs(gr_inner_logLik_internal(reTransform), wrt = re_indices_inner, order = 0, model = model, + constantNodes = inner_constantNodes) # Missing `updateNodes`. + return(ans$value) + returnType(double(2)) + } + ), + buildDerivs = c('inner_logLik','gr_inner_logLik_internal','he_inner_logLik_internal') + ), "appears to contain the use of `calculate` on a model") + + expect_message( + mynf <- nimbleFunction( + setup = function(model){ + paramNodes = 'psi[1:4]' + }, + run = function(x = double(1), alpha=double(1)) { + }, + methods = list( + inner_logLik = function(reTransform = double(1)) { + values(model, randomEffectsNodes) <<- reTransform + ans <- model$calculate(innerCalcNodes) + return(ans) + returnType(double()) + }, + gr_inner_logLik_internal = function(reTransform = double(1)) { + ans <- derivs(inner_logLik(reTransform), wrt = re_indices_inner, order = 1, model = model, + updateNodes = inner_updateNodes, constantNodes = inner_constantNodes) + return(ans$jacobian[1,]) + returnType(double(1)) + }, + he_inner_logLik_internal = function(reTransform = double(1)) { + ans <- derivs(gr_inner_logLik_internal(reTransform), wrt = re_indices_inner, order = 1, + updateNodes = inner_updateNodes, constantNodes = inner_constantNodes) # Missing `model`. + return(ans$jacobian) + returnType(double(2)) + }, + he_inner_logLik = function(reTransform = double(1)) { + ans <- derivs(gr_inner_logLik_internal(reTransform), wrt = re_indices_inner, order = 0, model = model, + updateNodes = inner_updateNodes, constantNodes = inner_constantNodes) + return(ans$value) + returnType(double(2)) + } + ), + buildDerivs = c('inner_logLik','gr_inner_logLik_internal','he_inner_logLik_internal') + ), "appears to contain the use of `calculate` on a model") +}) + + From ad69068baae82dacb76c29198586289dd2d403d8 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Wed, 9 Jul 2025 17:04:05 -0700 Subject: [PATCH 10/11] Fix typo in function name. --- packages/nimble/R/nimbleFunction_core.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/packages/nimble/R/nimbleFunction_core.R b/packages/nimble/R/nimbleFunction_core.R index 3ec584178..381053857 100644 --- a/packages/nimble/R/nimbleFunction_core.R +++ b/packages/nimble/R/nimbleFunction_core.R @@ -94,7 +94,7 @@ nimbleFunction <- function(setup = NULL, ## Check that if a model calculate is in the code of `run` or another method on ## which `derivs` is called, that the `model`, `updateNodes`,and `constantNodes` ## arguments are provided. - if(getNimbleOptions('checkDerivsArgs') && length(buildDerivs)) { + if(getNimbleOption('checkDerivsArgs') && length(buildDerivs)) { allMethods <- c(list(run = run), methods) if(is.character(buildDerivs)) nms <- buildDerivs else nms <- names(buildDerivs) methodsWithCalc <- sapply(allMethods[nms], nf_checkDSLcode_checkForCalc) From 0c73932f3e78f0fd8bab7a6d5db866ef28c105f6 Mon Sep 17 00:00:00 2001 From: Christopher Paciorek Date: Thu, 10 Jul 2025 11:13:15 -0700 Subject: [PATCH 11/11] Make slight change to comment. --- packages/nimble/R/RCfunction_core.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/packages/nimble/R/RCfunction_core.R b/packages/nimble/R/RCfunction_core.R index fd650f93b..56cbecd5d 100644 --- a/packages/nimble/R/RCfunction_core.R +++ b/packages/nimble/R/RCfunction_core.R @@ -278,7 +278,6 @@ nf_checkDSLcode_checkForCalc <- function(code) { nf_checkDSLcode_checkDerivsOf <- function(code) { code <- body(code) - ## This assumes `derivs()` call is from assignment like `var <- derivs()`. derivsFound <- which(findDerivsCalls(code)) if(length(derivsFound)) { derivsOf <- sapply(derivsFound, function(i) @@ -289,6 +288,7 @@ nf_checkDSLcode_checkDerivsOf <- function(code) { } findDerivsCalls <- function(code) { + ## This assumes `derivs()` call is from assignment like `var <- derivs()`. sapply(code, function(expr) length(expr) >= 3 && length(expr[[1]]) == 1 && as.character(expr[[1]]) %in% c("=", "<-", "<<-") && @@ -306,7 +306,6 @@ checkNestedCalcCall <- function(functionName, methodsWithCalc, methodsDerivsOf) nf_checkDSLcode_calcDerivsArgs <- function(code, methodsWithCalc, methodsDerivsOf) { code <- body(code) - ## This assumes `derivs()` call is from assignment like `var <- derivs()`. derivsFound <- which(findDerivsCalls(code)) for(idx in derivsFound) { argNames <- names(code[[idx]][[3]])