Merge branch 'devel' into fix_1356

packages/nimble/LICENSE

@@ -1,3 +1,3 @@
-YEAR: 2023
+YEAR: 2024
 COPYRIGHT HOLDER: Perry de Valpine, Christopher Paciorek, Daniel Turek, Clifford Anderson-Bergman, Nick Michaud, Fritz Obermeyer, Claudia Wehrhahn Cortes, Abel Rodriguez, Sally Paganin, Wei Zhang, Duncan Temple Lang
 ORGANIZATION: University of California

packages/nimble/R/BUGS_modelDef.R

@@ -327,7 +327,7 @@ modelDefClass$methods(assignBUGScode = function(code) {
 })
 modelDefClass$methods(assignConstants = function(constants) {
     ## uses 'constants' argument, sets fields: constantsEnv, constantsList, constantsNamesList
-    constantsEnv <<- new.env()
+    constantsEnv <<- new.env() 
     if(length(constants) > 0) {
         if(!is.list(constants) || is.null(names(constants)))   stop('constants argument must be a named list')
         list2env(constants, constantsEnv)
@@ -1465,6 +1465,10 @@ determineContextSize <- function(context, useContext = rep(TRUE, length(context$
     test <- try(eval(innerLoopCode, evalEnv))
     if(is(test, 'try-error'))
         stop("Could not evaluate loop syntax: is indexing information provided via 'constants'?")
+    wh <- which(!all.vars(innerLoopCode) %in% c(ls(evalEnv), context$indexVarNames))
+    if(length(wh))
+        messageIfVerbose("  [Warning] Indexing information for ", paste(all.vars(innerLoopCode)[wh], collapse = ", "),
+                " not provided in `constants`.\n            Information has been found in the user's environment,\n            but we recommend all indexing information be provided via `constants`.")
     ans <- evalEnv$iAns
     rm(list = c('iAns', context$indexVarNames[useContext]), envir = evalEnv)
     return(ans)

packages/nimble/R/MCMC_samplers.R

@@ -707,7 +707,7 @@ sampler_slice <- nimbleFunction(
                 print("Please set 'nimbleOptions(MCMCsaveHistory = TRUE)' before building the MCMC.")
                 return(numeric(1, 0))
             }
-       },
+        },
         reset = function() {
             width        <<- widthOriginal
             timesRan     <<- 0

packages/nimble/R/all_utils.R

@@ -24,6 +24,7 @@ labelFunctionMetaCreator <- function() {
                 nextIndex <<- 1
                 return(invisible(NULL))
             }
+            envName <- gsub("\\.", "_dot_", envName)
             lead <- paste(lead, envName , sep = '_')
             ans <- paste0(lead, nextIndex - 1 + (1:count))
             nextIndex <<- nextIndex + count

packages/nimble/R/distributions_processInputList.R

@@ -594,7 +594,7 @@ registerDistributions <- function(distributionsInput, userEnv = parent.frame(),
 #' @param distributionsNames a character vector giving the names of the distributions to be dergistered
 #' @author Christopher Paciorek
 #' @export
-deregisterDistributions <- function(distributionsNames) {
+deregisterDistributions <- function(distributionsNames, userEnv = parent.frame()) {
     if(!exists('distributions', nimbleUserNamespace, inherits = FALSE)) 
         warning("No user-supplied distributions are registered.")
     matched <- distributionsNames %in% getAllDistributionsInfo('namesVector', userOnly = TRUE)
@@ -614,7 +614,17 @@ deregisterDistributions <- function(distributionsNames) {
         } else {  # all distributions to be removed
               rm(distributions, envir = nimbleUserNamespace)
         }
+        ## Remove placeholder `r` function if it exists so that user could modify
+        ## their `d` function (NCT issue 485).
+        sapply(distributionsNames, function(densityName) {
+            rName <- sub("^d", "r", densityName)
+            if(exists(rName, userEnv)) {
+                rFun <- get(rName, userEnv)
+                if(length(body(rFun)) >= 2 && length(grep("provided without random", deparse(body(rFun)[[2]]))))
+                    eval(substitute(rm(list = rName, pos = userEnv), list(rName = rName))) 
+            }})
     }
+
     invisible(NULL)
 }
 

packages/nimble/R/genCpp_sizeProcessing.R

@@ -1437,7 +1437,7 @@ sizeOptim <- function(code, symTab, typeEnv) {
 
     fnCode <- code$args$fn
     if(!inherits(fnCode, 'exprClass')) {
-        stop(exprClassProcessingErrorMsg(code, 'In sizeOptim.  fn is not valid.'), call. = FALSE)
+        stop(exprClassProcessingErrorMsg(code, '`fn` argument to `optim` is not valid.'), call. = FALSE)
     }
     if (fnCode$name == 'nfMethod') {
         # This is handled in cppOutputNFmethod.
@@ -1450,7 +1450,7 @@ sizeOptim <- function(code, symTab, typeEnv) {
     } else if(exists(fnCode$name) && is.rcf(get(fnCode$name))) {
         fnCode$name <- environment(get(fnCode$name))$nfMethodRCobject$uniqueName
     } else {
-        stop(paste0('unsupported fn argument in optim(par, fn = ', fnCode$name, '); try an RCfunction or nfMethod instead'))
+        stop('in `optim`, the `fn` argument, `', fnCode$name, '`, is not available or is not a nimbleFunction or nimbleFunction method.')
     }
 
     grCode <- code$args$gr
@@ -3148,24 +3148,29 @@ sizeReturn <- function(code, symTab, typeEnv) {
     asserts <- recurseSetSizes(code, symTab, typeEnv)
     typeEnv$.AllowUnknowns <- TRUE
     if(inherits(code$args[[1]], 'exprClass')) {
-        if(typeEnv$return$type == 'nimbleList' || code$args[[1]]$type == 'nimbleList') {
+        if(typeEnv$return$type == 'nimbleList' || isTRUE(code$args[[1]]$type == 'nimbleList')) {
             if(typeEnv$return$type != 'nimbleList') stop(exprClassProcessingErrorMsg(code, paste0('return() argument is a nimbleList but returnType() statement gives a different type')), call. = FALSE)
             if(code$args[[1]]$type != 'nimbleList') stop(exprClassProcessingErrorMsg(code, paste0('returnType statement gives a nimbleList type but return() argument is not the right type')), call. = FALSE)
             ## equivalent to symTab$getSymbolObject(code$args[[1]]$name)$nlProc, if it is a name
             if(!identical(code$args[[1]]$sizeExprs$nlProc, typeEnv$return$sizeExprs$nlProc)) stop(exprClassProcessingErrorMsg(code, paste0('nimbleList given in return() argument does not match nimbleList type declared in returnType()')), call. = FALSE)
         } else { ## check numeric types and nDim
             fail <- FALSE
-            if(!identical(code$args[[1]]$type, typeEnv$return$type)) {
-                if(typeEnv$return$nDim > 0) { ## allow scalar casting of returns without error
-                    failMsg <- paste0('Type ', code$args[[1]]$type, ' of the return() argument does not match type ',  typeEnv$return$type, ' given in the returnType() statement (void is default).')
+            if(is.null(code$args[[1]]$type)) {  # Issue 1364
+                failMsg <- paste0(code$args[[1]]$name, " is not available or its output type is unknown.")
+                fail <- TRUE
+            } else {
+                if(!identical(code$args[[1]]$type, typeEnv$return$type)) {
+                    if(typeEnv$return$nDim > 0) { ## allow scalar casting of returns without error
+                        failMsg <- paste0('Type ', code$args[[1]]$type, ' of the return() argument does not match type ',  typeEnv$return$type, ' given in the returnType() statement (void is default).')
+                        fail <- TRUE
+                    }
+                }
+                if(!isTRUE(all.equal(code$args[[1]]$nDim, typeEnv$return$nDim))) {
+                    failMsg <- paste0( if(exists("failMsg", inherits = FALSE)) paste0(failMsg,' ') else character(),
+                                      paste0('Number of dimensions ', code$args[[1]]$nDim, ' of the return() argument does not match number ',  typeEnv$return$nDim, ' given in the returnType() statement.'))
                     fail <- TRUE
                 }
             }
-            if(!isTRUE(all.equal(code$args[[1]]$nDim, typeEnv$return$nDim))) {
-                failMsg <- paste0( if(exists("failMsg", inherits = FALSE)) paste0(failMsg,' ') else character(),
-                                  paste0('Number of dimensions ', code$args[[1]]$nDim, ' of the return() argument does not match number ',  typeEnv$return$nDim, ' given in the returnType() statement.'))
-                fail <- TRUE
-            }
             if(fail)
                 stop(exprClassProcessingErrorMsg(code, failMsg), call. = FALSE)
         }

packages/nimble/R/nimbleList_core.R

@@ -105,7 +105,7 @@ is.nlGenerator <- function(x, inputIsName = FALSE, where = -1) {
 #'  ## this nimbleList definition is identical to the one created above
 #'  exampleNimListDef <- nimbleList(nimbleListTypes)
 nimbleList <- function(...,
-                       name = NA,
+                       name = as.character(NA),
                        predefined = FALSE,
                        where =  getNimbleFunctionEnvironment()) {
     ## This has a role like nimbleFunction but a much simpler implementation
@@ -119,12 +119,27 @@ nimbleList <- function(...,
     GENERATE_STATIC_CODE <- FALSE  ## Enable this before using generateStaticCode.R.
     if(GENERATE_STATIC_CODE) predefined <- FALSE
 
-  ## 3 possibilities: arguments as expressions, arguments as list created within call,
-  ## arguments as list created outside of call
-
+    ## 3 possibilities: arguments as expressions, arguments as list created within call,
+    ## arguments as list created outside of call
+    
     Call <-  match.call(expand.dots = TRUE)
-    if(any(names(Call) == 'name')){
-      Call <- Call[-which(names(Call) == 'name')]
+    nms <- names(Call)
+    if(any(nms == 'name')) {
+        if(!is.character(Call[[which(nms == "name")]]))
+            stop("Elements of a nimbleList cannot be named `name`.")
+        Call <- Call[-which(names(Call) == 'name')]
+    }
+    nms <- names(Call)
+    if(any(nms == 'predefined')) {
+        if(!is.logical(Call[[which(nms == "predefined")]]))
+            stop("Elements of a nimbleList cannot be named `predefined`.")
+        Call <- Call[-which(nms == 'predefined')]
+    }
+    nms <- names(Call)
+    if(any(nms == 'where')) {
+        if(!is.environment(Call[[which(nms == "where")]]))
+            stop("Elements of a nimbleList cannot be named `where`.")
+        Call <- Call[-which(nms == 'where')]
     }
     if(length(Call) < 2)
       stop("No arguments specified for nimbleList")
@@ -153,23 +168,27 @@ nimbleList <- function(...,
     types <- list(vars = sapply(argList, function(x){return(x$name)}),
                   types =  sapply(argList, function(x){return(x$type)}),
                   dims =  sapply(argList, function(x){return(x$dim)}))
+
+    if(any(c('name','predefined','where') %in% types$vars))
+        stop("Elements of a nimbleList cannot be named `name`, `predefined` or `where`.")
+
     if(is.na(name)) name <- nf_refClassLabelMaker()
     nlDefClassObject <- nimbleListDefClass(types = types, className = name, predefined = predefined) 
     basicTypes <- c("double", "integer", "character", "logical")
-  nestedListGens <- list()
-  for(i in seq_along(types$types)){
-    if(!(types$types[i] %in% basicTypes)){
-      for(searchEnvironment in c(parent.frame(), globalenv())){
-        ## It could become necessary to add "asNamespace("nimble")" to the searchEnvironment list
-        found_nlGen <- try(get(types$types[i], envir = searchEnvironment), silent = TRUE)
-        if(!inherits(found_nlGen, 'try-error')){
-          if(is.nlGenerator(found_nlGen))
-            nestedListGens[[types$vars[i]]] <- found_nlGen
-          break
+    nestedListGens <- list()
+    for(i in seq_along(types$types)){
+        if(!(types$types[i] %in% basicTypes)){
+            for(searchEnvironment in c(parent.frame(), globalenv())){
+                ## It could become necessary to add "asNamespace("nimble")" to the searchEnvironment list
+                found_nlGen <- try(get(types$types[i], envir = searchEnvironment), silent = TRUE)
+                if(!inherits(found_nlGen, 'try-error')){
+                    if(is.nlGenerator(found_nlGen))
+                        nestedListGens[[types$vars[i]]] <- found_nlGen
+                    break
+                }
+            }
         }
-      }
     }
-  }
 
     classFields <- as.list(rep('ANY', length(types$vars)))
     names(classFields) <- types$vars

packages/nimble/inst/CppCode/RcppUtils.cpp

@@ -234,7 +234,7 @@ vector<int> SEXP_2_vectorInt( SEXP Sn, int offset ) {
 
 int SEXP_2_int(SEXP Sn, int i ) {
   if(!(Rf_isNumeric(Sn) || Rf_isLogical(Sn))) PRINTF("Error: SEXP_2_int called for SEXP that is not numeric or logical\n");
-  if(LENGTH(Sn) <= i) PRINTF("Error: SEXP_2_int called for element %i% >= length of %i.\n", i, LENGTH(Sn));
+  if(LENGTH(Sn) <= i) PRINTF("Error: SEXP_2_int called for element %i% which is beyond the length of %i.\n", i, LENGTH(Sn));
   if(Rf_isInteger(Sn) || Rf_isLogical(Sn)) {
     if(Rf_isInteger(Sn))
       return(INTEGER(Sn)[i]);
@@ -270,7 +270,7 @@ SEXP bool_2_SEXP(bool ind){
 
 bool SEXP_2_bool(SEXP Sn, int i) {
   if(!(Rf_isNumeric(Sn) || Rf_isLogical(Sn))) PRINTF("Error: SEXP_2_bool called for SEXP that is not numeric or logical\n");
-  if(LENGTH(Sn) <= i) PRINTF("Error: SEXP_2_bool called for element %i% >= length of %i.\n", i, LENGTH(Sn));
+  if(LENGTH(Sn) <= i) PRINTF("Error: SEXP_2_bool called for element %i% which is beyond the length of %i.\n", i, LENGTH(Sn));
   if(Rf_isLogical(Sn)) {
     return(static_cast<bool>(LOGICAL(Sn)[i]));
   } else {

packages/nimble/inst/CppCode/Utils.cpp

@@ -62,8 +62,8 @@ bool decide(double lMHr) { // simple function accept or reject based on log Metr
   return(false);
 }
 
-void nimStop(string msg) {NIMERROR(msg.c_str());}
-void nimStop() {NIMERROR("");}
+void nimStop(string msg) {NIMERROR("%s", msg.c_str());}
+void nimStop() {NIMERROR("Error. Exiting from compiled execution.");}
 
 bool nimNot(bool x) {return(!x);}
 

packages/nimble/inst/CppCode/eigenUsingClasses.cpp

@@ -30,7 +30,7 @@ template<>
 void SEXP_2_NimArr<1>(SEXP Sn, NimArr<1, double> &ans) {
   NIM_ASSERT2(Rf_isNumeric(Sn) || Rf_isLogical(Sn),
     "SEXP_2_NimArr<1, double> called for SEXP that is not a numeric or logical: actual type %s\n",
-    Rf_type2str(TYPEOF(Sn)));
+    Rf_type2char(TYPEOF(Sn)));
   int nn = LENGTH(Sn);
   NIM_ASSERT1(ans.size() == 0, "trying to reset a NimArr that was already sized\n");
   ans.setSize(nn);
@@ -39,7 +39,7 @@ void SEXP_2_NimArr<1>(SEXP Sn, NimArr<1, double> &ans) {
   } else {
     NIM_ASSERT2(Rf_isInteger(Sn) || Rf_isLogical(Sn),
       "could not handle input of type %s to SEXP_2_NimArr<1, double>\n",
-      Rf_type2str(TYPEOF(Sn)));
+      Rf_type2char(TYPEOF(Sn)));
     int *iSn = Rf_isInteger(Sn) ? INTEGER(Sn) : LOGICAL(Sn);
     for(int i = 0; i < nn; ++i) {
       ans(i) = static_cast<double>(iSn[i]);
@@ -52,7 +52,7 @@ template<>
 void SEXP_2_NimArr<1>(SEXP Sn, NimArr<1, int> &ans) {
   NIM_ASSERT2(Rf_isNumeric(Sn) || Rf_isLogical(Sn),
     "SEXP_2_NimArr<1, int> called for SEXP that is not a numeric or logical: actual type %s\n",
-    Rf_type2str(TYPEOF(Sn)));
+    Rf_type2char(TYPEOF(Sn)));
   int nn = LENGTH(Sn);
   NIM_ASSERT1(ans.size() == 0, "trying to reset a NimArr that was already sized\n");
   ans.setSize(nn);
@@ -61,7 +61,7 @@ void SEXP_2_NimArr<1>(SEXP Sn, NimArr<1, int> &ans) {
   } else {
     NIM_ASSERT2(Rf_isInteger(Sn) || Rf_isLogical(Sn),
       "could not handle input of type %s to SEXP_2_NimArr<1, int>\n",
-      Rf_type2str(TYPEOF(Sn)));
+      Rf_type2char(TYPEOF(Sn)));
     int *iSn = Rf_isInteger(Sn) ? INTEGER(Sn) : LOGICAL(Sn);
     for(int i = 0; i < nn; ++i) {
       ans(i) = static_cast<double>(iSn[i]);

packages/nimble/inst/NEWS.md

@@ -7,11 +7,17 @@
 
 - Change argument of `besselK` in manual table to be `x` not `k`.
 
+- Do not allow elements of a `nimbleList` to be named `name`, `predefined`,
+or `where` (issue #1306).
+
 - Add new control list option, `maxDimCovHistory` to `RW_block` sampler 
   specify maximum dimension for saving proposal covariance history.
 
 ## DEVELOPER LEVEL CHANGES
 
+- Fix error with name mangling affecting packages that use nimble
+  and have dot(s) in the package name (issue #1332)
+
 - Make change to `nimble-package` documentation to use `"_PACKAGE"`
   instead of `@docType` per CRAN request (issue #1359).
 

packages/nimble/inst/include/nimble/RcppNimbleUtils.h

@@ -239,11 +239,11 @@ template<int ndim>
 void SEXP_2_NimArr(SEXP Sn, NimArr<ndim, double> &ans) {
   NIM_ASSERT3(Rf_isNumeric(Sn) || Rf_isLogical(Sn),
     "SEXP_2_NimArr<%d, double> called for SEXP that is not a numeric or logical: actual type %s\n",
-    ndim, Rf_type2str(TYPEOF(Sn)));
+    ndim, Rf_type2char(TYPEOF(Sn)));
   vector<int> inputDims(getSEXPdims(Sn));
   NIM_ASSERT4(inputDims.size() == ndim,
     "Wrong number of input dimensions in SEXP_2_NimArr<%d, double> called for SEXP that is not a numeric: expected %d, actual %d\n",
-    ndim, ndim, inputDims.size());
+    ndim, ndim, static_cast<int>(inputDims.size()));
   // NIM_ASSERT(ans.size() == 0, "trying to reset a NimArr that was already sized\n");
   ans.setSize(inputDims);
   int nn = LENGTH(Sn);
@@ -252,7 +252,7 @@ void SEXP_2_NimArr(SEXP Sn, NimArr<ndim, double> &ans) {
   } else {
     NIM_ASSERT3(Rf_isInteger(Sn) || Rf_isLogical(Sn),
       "could not handle input of type %s to SEXP_2_NimArr<%d, double>\n",
-      Rf_type2str(TYPEOF(Sn)), ndim);
+      Rf_type2char(TYPEOF(Sn)), ndim);
     int *iSn = Rf_isInteger(Sn) ? INTEGER(Sn) : LOGICAL(Sn);
     std::copy(iSn, iSn + nn, ans.getPtr()); //v);
   }
@@ -263,7 +263,7 @@ template<int ndim>
 void SEXP_2_NimArr(SEXP Sn, NimArr<ndim, int> &ans) {
   NIM_ASSERT3(Rf_isNumeric(Sn) || Rf_isLogical(Sn),
     "SEXP_2_NimArr<%d, int> called for SEXP that is not a numeric or logical: actual type %s\n",
-    ndim, Rf_type2str(TYPEOF(Sn)));
+    ndim, Rf_type2char(TYPEOF(Sn)));
   vector<int> inputDims(getSEXPdims(Sn));
   NIM_ASSERT4(inputDims.size() == ndim,
     "Wrong number of input dimensions in SEXP_2_NimArr<%d, int> called for SEXP that is not a numeric: expected %d, actual %d\n",
@@ -276,7 +276,7 @@ void SEXP_2_NimArr(SEXP Sn, NimArr<ndim, int> &ans) {
   } else {
     NIM_ASSERT3(Rf_isInteger(Sn) || Rf_isLogical(Sn),
       "could not handle input type %s to SEXP_2_NimArr<%d, int>\n",
-      Rf_type2str(TYPEOF(Sn)), ndim);
+      Rf_type2char(TYPEOF(Sn)), ndim);
     int *iSn = Rf_isInteger(Sn) ? INTEGER(Sn) : LOGICAL(Sn);
     std::copy(iSn, iSn + nn, ans.getPtr()); //v);
   }
@@ -286,7 +286,7 @@ template<int ndim>
 void SEXP_2_NimArr(SEXP Sn, NimArr<ndim, bool> &ans) {
   NIM_ASSERT3(Rf_isNumeric(Sn) || Rf_isLogical(Sn),
     "SEXP_2_NimArr<%d, bool> called for SEXP that is not a numeric or logical: actual type %s\n",
-    ndim, Rf_type2str(TYPEOF(Sn)));
+    ndim, Rf_type2char(TYPEOF(Sn)));
   vector<int> inputDims(getSEXPdims(Sn));
   NIM_ASSERT4(inputDims.size() == ndim,
     "Wrong number of input dimensions in SEXP_2_NimArr<%d, bool> called for SEXP that is not a numeric: expected %d, actual %d\n",
@@ -299,7 +299,7 @@ void SEXP_2_NimArr(SEXP Sn, NimArr<ndim, bool> &ans) {
   } else {
     NIM_ASSERT3(Rf_isInteger(Sn) || Rf_isLogical(Sn),
       "could not handle input type %s to SEXP_2_NimArr<%d, bool>\n",
-      Rf_type2str(TYPEOF(Sn)), ndim);
+      Rf_type2char(TYPEOF(Sn)), ndim);
     int *iSn = Rf_isInteger(Sn) ? INTEGER(Sn) : LOGICAL(Sn);
     std::copy(iSn, iSn + nn, ans.getPtr()); //v);
   }

packages/nimble/tests/testthat/test-models.R

@@ -1010,5 +1010,17 @@ test_that("Example of splitVertices bug from Issue 1268 works.", {
   expect_no_error(Rmodel <- nimbleModel(code, constants = list(index=c(1,1))))
 })
 
+test_that("Warning printed when indexing info in user environment.", {
+    code <- nimbleCode({
+        for(i in 1:N)
+            y[i] ~ dnorm(0,1)
+    })
+    N <- 3
+    temporarilyAssignInGlobalEnv(N)
+    expect_message(m <- nimbleModel(code, constants = list(foo=3)),
+                   "Information has been found in the user's environment")
+})
+
+
 options(warn = RwarnLevel)
 nimbleOptions(verbose = nimbleVerboseSetting)

packages/nimble/tests/testthat/test-nimbleList.R

@@ -1389,6 +1389,15 @@ test_that("Assignment of list object to list object works (Issue 1246) b", {
   expect_equal(cfoo$run(), 1:3)
 })
 
+test_that("Invalids names of nimbleList elements", {
+    expect_silent(nL <- nimbleList(x = integer(0), Y = double(2), name = 'foo'))
+    expect_error(nimbleList(x = integer(0), Y = double(2), name = logical(0)),
+                 "cannot be named")
+    nimbleListTypes <- list(nimbleType(name = 'predefined', type = 'integer', dim = 0),
+                            nimbleType(name = 'Y', type = 'double', dim = 2))
+    expect_error(nimbleList(nimbleListTypes), "cannot be named")
+})
+
 options(warn = RwarnLevel)
 nimbleOptions(verbose = nimbleVerboseSetting)