uncompiled functionality of nimble models (#95)

* add model dollar sign to uncompiled version of calculate methods

* update predefined nClasses used for models

* clean up predefined Hincludes and some testing

* generate full set of calc_one, sim_one, calcDiff_one, getLogProb_one for both stochastic and deterministic

* clean up test-nimbleModel for current status

Author: perrydv

nCompiler/NAMESPACE

@@ -9,7 +9,7 @@ export(argType2Cpp)
 export(build_compiled_nClass)
 export(calcInputList_to_calcInstrList)
 export(calcInstr_nClass)
-export(calcInstrList_nC)
+export(calcInstrList_nClass)
 export(cloglog)
 export(check_Rcpp_for_nCompiler)
 export(compileNimble)
@@ -59,7 +59,8 @@ export(logfact)
 export(loggam)
 export(logit)
 export(makeModel_nClass)
-export(make_node_fun)
+export(make_model_from_nimbleModel)
+export(make_node_nClass)
 export(method)
 export(modelBase_nClass)
 export(new.loadedObjectEnv) ## needed for Rcpp::Function access in loadedObjectEnv.h

nCompiler/R/NC_LoadedObjectEnv.R

@@ -266,7 +266,7 @@ setup_DLLenv <- function(compiledFuns,
 move_funs_from_list_to_env <- function(funNames, funList, env) {
   keep <- rep(TRUE, length(funList))
   for(funName in funNames) {
-    found <- grepl(funName, names(funList))
+    found <- funName == names(funList) #grepl(funName, names(funList))
     if(any(found)) {
       i <- which(found)
       if(length(i) != 1)

nCompiler/R/all_utils.R

@@ -3,7 +3,7 @@
 ## labelFunctionMetaCreator is only called once, immediately below, to create labelFunctionCreator
 ## The outer layer allows allLabelFunctionCreators to be in the closure of every function returned
 ## by labelFunctionCreator.  Each of those functions is registered as an element of allLableFunctionCreators.
-## 
+##
 ## This scheme allows the function resetLabelFunctionCreators below to work simply,
 ## resetting the count to 1 for all of the label generators.
 ##
@@ -48,9 +48,9 @@ modelLabelCreator <- labelFunctionCreator("model")
 
 # no longer documented in Rd
 # Generates a valid C++ name from an R Name
-# 
+#
 # replaces [ ( $ and a few other symbols with underscores, and removes ] ) and spaces in a string
-# 
+#
 # @param rName A String
 # @return returns a string representing the modified rName
 # @author Jagadish Babu
@@ -74,9 +74,9 @@ Rname2CppName <- function(rName, colonsOK = TRUE) {
                 paste(rName[grepl(':', rName)], collapse=', ')))
   }
   rName <- gsub(' ', '', rName)
-  rName <- gsub('\\.', '_dot_', rName) 
+  rName <- gsub('\\.', '_dot_', rName)
   rName <- gsub("\"", "_quote_", rName)
-  rName <- gsub(',', '_comma_', rName)   
+  rName <- gsub(',', '_comma_', rName)
   rName <- gsub("`", "_backtick_" , rName)
   rName <- gsub('\\[', '_oB', rName)
   rName <- gsub('\\]', '_cB', rName)
@@ -105,7 +105,7 @@ Rname2CppName <- function(rName, colonsOK = TRUE) {
   rName <- gsub('\\^', '_tothe_', rName)
   rName <- gsub('^_+', '', rName) # remove leading underscores.  can arise from (a+b), for example
   rName <- gsub('^([[:digit:]])', 'd\\1', rName)    # if begins with a digit, add 'd' in front
-  rName    
+  rName
 }
 
 ## This takes a character vector as the first argument and length-1
@@ -138,7 +138,7 @@ pasteSemicolon <- function(x, indent = '') {
   stop(paste0('Error, pasteSemicolon called for object of class ',
               class(x),
               '. Must be character or list.'),
-       call. = FALSE) 
+       call. = FALSE)
 }
 
 #' Write unlisted code generated from.nCompiler cpp definitions.
@@ -183,3 +183,36 @@ is.blank <- function(arg) {
   if(is.null(arg)) return(FALSE)
   return(identical(arg, quote(x[])[[3]]))
 }
+
+
+# Modified from nimble, including comments
+# simply adds width.cutoff = 500 as the default to deal with creation of long variable names from expressions
+# The control list is the default plus "digits17", which is the only one done in nimble.
+# We need to deparse lists (e.g. in build_compiled_nClass) and have the names in the deparsed result.
+# I think "niceNames" does that, possibly  "showAttributes" too.
+deparse <- function(...) {
+  control <- c("keepNA", "keepInteger", "niceNames", "showAttributes", "digits17")
+  if("width.cutoff" %in% names(list(...))) {
+    base::deparse(..., control = control)
+  } else {
+    base::deparse(..., width.cutoff = 500L, control = control)
+  }
+}
+
+## This version of deparse avoids splitting into multiple lines, which generally would lead to
+## problems. We keep the original nimble:::deparse above as deparse is widely used and there
+## are cases where not modifying the nlines behavior may be best.
+safeDeparse <- function(..., warn = FALSE) {
+  out <- deparse(...)
+  if(isTRUE(get_nOption('useSafeDeparse'))) {
+    dotArgs <- list(...)
+    if("nlines" %in% names(dotArgs))
+      nlines <- dotArgs$nlines else nlines <- 1L
+    if(nlines != -1L && length(out) > nlines) {
+      if(warn)
+        message("  [Note] safeDeparse: truncating deparse output to ", nlines, " line", if(nlines>1) "s" else "")
+      out <- out[1:nlines]
+    }
+  }
+  return(out)
+}

nCompiler/R/compile_aaa_operatorLists.R

@@ -507,6 +507,15 @@ assignOperatorDef(
 updateOperatorDef('max', 'cppOutput', 'cppString', 'maximum')
 updateOperatorDef('min', 'cppOutput', 'cppString', 'minimum')
 
+assignOperatorDef(
+  'invisible',
+  list(
+    simpleTransformations = list(
+      handler = 'RemoveLayer'
+    )
+  )
+)
+
 assignOperatorDef(
   c('pairmin', 'pairmax'),
   list(

nCompiler/R/compile_simpleTransformations.R

@@ -55,6 +55,13 @@ simpleTransformationsEnv$minMax <-
     if(length(code$args) == 2) code$name <- paste0('pair',code$name)
   }
 
+## Used e.g. for invisible(foo(x)) --> foo(x)
+simpleTransformationsEnv$RemoveLayer <-
+  function(code, symTab, auxEnv, info) {
+    removeExprClassLayer(code)
+  }
+
+
 simpleTransformationsEnv$replace <-
   function(code, symTab, auxEnv, info) {
     repl <- info$replacement