From c21482a7bbd0e7f93cb3a548f5465e5e24243736 Mon Sep 17 00:00:00 2001 From: perrydv Date: Mon, 23 Mar 2026 18:51:26 -0700 Subject: [PATCH] Update from Rf_findVar and Rf_findVarInFrame while maintaining backward compatibility if possible --- packages/nimble/R/cppDefs_nimbleList.R | 30 +-- .../nimble/inst/CppCode/RcppNimbleUtils.cpp | 151 +++++++------ packages/nimble/inst/CppCode/RcppUtils.cpp | 70 +++--- .../nimble/inst/CppCode/accessorClasses.cpp | 34 +-- .../nimble/inst/CppCode/eigenUsingClasses.cpp | 24 +- packages/nimble/inst/CppCode/nimOptim.cpp | 16 +- .../inst/CppCode/predefinedNimbleLists.cpp | 98 ++++---- .../inst/include/nimble/RcppNimbleUtils.h | 52 ++--- packages/nimble/inst/include/nimble/Utils.h | 52 ++++- .../inst/include/nimble/accessorClasses.h | 211 ++++-------------- 10 files changed, 325 insertions(+), 413 deletions(-) diff --git a/packages/nimble/R/cppDefs_nimbleList.R b/packages/nimble/R/cppDefs_nimbleList.R index 05ceee258..2865633ec 100644 --- a/packages/nimble/R/cppDefs_nimbleList.R +++ b/packages/nimble/R/cppDefs_nimbleList.R @@ -59,7 +59,7 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass', ## ptrToSmartPtrBase = dynamic_cast(ptrToSmartPtr); ## ptrToPtr = ptrToSmartPtr->getVoidPtrToRealPtr(); ## reinterpret_cast(*static_cast(ptrToPtr))->NO_hw(); - + ## PROTECT(SptrToSmartPtrBase = R_MakeExternalPtr(ptrToSmartPtrBase, R_NilValue, R_NilValue)); ## PROTECT(SptrToPtr = R_MakeExternalPtr(ptrToPtr, R_NilValue, R_NilValue)); ## PROTECT(Sans = Rf_allocVector(VECSXP,2)); @@ -83,11 +83,11 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass', 'PROTECT(SptrToSmartPtrBase = R_MakeExternalPtr(ptrToSmartPtrBase, R_NilValue, R_NilValue));', 'PROTECT(SptrToPtr = R_MakeExternalPtr(ptrToPtr, R_NilValue, R_NilValue));')) allocVectorLine <- cppLiteral(paste0('PROTECT(Sans = Rf_allocVector(VECSXP,', 2, '));')) - + packListLines <- cppLiteral(c('SET_VECTOR_ELT(Sans,0,SptrToSmartPtrBase);', 'SET_VECTOR_ELT(Sans,1,SptrToPtr);' )) - + codeLines <- substitute({ ## Finalizer registration now happens through nimble's finalizer mapping system. UNPROTECT(3) @@ -99,7 +99,7 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass', args = args, code = cppCodeBlock(code = allCode, objectDefs = CBobjectDefs, skipBrackets = TRUE), returnType = cppSEXP(), - externC = TRUE) + externC = TRUE) }, buildSEXPgenerator = function(finalizer = NULL) { ## Build a function that will provide a new object and return an external pointer. @@ -197,7 +197,7 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass', listElementTable <- symbolTable() listElementTable$addSymbol(cppSEXP(name = "S_newNimList")) listElementTable$addSymbol(cppSEXP(name = "S_listName")) - + newListLine[[1]] <- substitute({PROTECT(S_listName <- Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(S_listName, 0, PROTECT(Rf_mkChar(LISTNAME)));}, list(LISTNAME = nimCompProc$nimbleListObj$className)) @@ -225,28 +225,28 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass', listElementTable <- symbolTable() numElements <- length(elementNames) conditionalLineList <- list() - + conditionalClauseStart <- list(quote(cppLiteral('if (!RCopiedFlag){'))) conditionalClauseEnd <- list(quote(cppLiteral('}'))) - environmentCPPName <- Rname2CppName('S_.xData') ## create SEXP for ref class environment + environmentCPPName <- Rname2CppName('S_.xData') ## create SEXP for ref class environment listElementTable$addSymbol(cppSEXP(name = environmentCPPName)) envLine <- substitute({PROTECT(ENVNAME <- Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(ENVNAME, 0, PROTECT(Rf_mkChar(".xData")));}, list(ENVNAME = as.name(environmentCPPName))) - + for(i in seq_along(elementNames)){ Snames[i] <- Rname2CppName(paste0('S_', elementNames[i])) listElementTable$addSymbol(cppSEXP(name = Snames[i])) elementSymTab <- nimCompProc$symTab$getSymbolObject(elementNames[i]) conditionalLineList <- c(conditionalLineList, generateConditionalLines(nimCompProc$symTab$getSymbolObject(elementNames[i]), listElementTable$getSymbolObject(Snames[i]))) - + copyToListLines[[i]] <- substitute(Rf_defineVar(Rf_install(ELEMENTNAME), VALUE, PROTECT(GET_SLOT(ROBJ, XDATA))), list(ELEMENTNAME = elementNames[i], VALUE = as.name(Snames[i]), ROBJ = as.name('RObjectPointer'), XDATA = as.name(environmentCPPName))) } - + setFlagLine <- list(substitute(RCopiedFlag <- true, list())) returnLine <- list(substitute(return(ROBJ), @@ -276,7 +276,7 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass', listElementTable <- symbolTable() storeSexpLine <- list(quote(cppLiteral('R_PreserveObject(RObjectPointer = S_nimList_);'))) - environmentCPPName <- Rname2CppName('S_.xData') ## create SEXP for ref class environment + environmentCPPName <- Rname2CppName('S_.xData') ## create SEXP for ref class environment listElementTable$addSymbol(cppSEXP(name = environmentCPPName)) envLine <- substitute({PROTECT(ENVNAME <- Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(ENVNAME, 0, PROTECT(Rf_mkChar(".xData")));}, @@ -285,8 +285,8 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass', for(i in seq_along(argNames)) { Snames[i] <- Rname2CppName(paste0('S_', argNames[i])) listElementTable$addSymbol(cppSEXP(name = Snames[i])) - copyFromListLines[[i]] <- substitute(PROTECT(SVAR <- Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, XDATA)), Rf_install(ARGNAME))), - list(ARGNAME = argNames[i], + copyFromListLines[[i]] <- substitute(PROTECT(SVAR <- NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, XDATA)), Rf_install(ARGNAME))), + list(ARGNAME = argNames[i], SVAR = as.name(Snames[i]), XDATA = as.name(environmentCPPName))) copyLine <- buildCopyLineFromSEXP(listElementTable$getSymbolObject(Snames[i]), @@ -295,7 +295,7 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass', } numArgs <- length(argNames) unprotectLine <- substitute(UNPROTECT(N), list(N = 2 * numArgs + 1 + 1)) - allCode <- embedListInRbracket(c(storeSexpLine, envLine, + allCode <- embedListInRbracket(c(storeSexpLine, envLine, copyFromListLines, copyLines, list(unprotectLine))) functionDefs[[paste0(name, "_copyFrom")]] <<- cppFunctionDef(name = "copyFromSEXP", @@ -311,7 +311,7 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass', elementNames <- nimCompProc$symTab$getSymbolNames() resetNestedFlagLines <- list() listElementTable <- symbolTable() - + resetFlagLine <- list(substitute(RCopiedFlag <- false, list())) diff --git a/packages/nimble/inst/CppCode/RcppNimbleUtils.cpp b/packages/nimble/inst/CppCode/RcppNimbleUtils.cpp index b3bdfcbd8..2da7514d0 100644 --- a/packages/nimble/inst/CppCode/RcppNimbleUtils.cpp +++ b/packages/nimble/inst/CppCode/RcppNimbleUtils.cpp @@ -3,17 +3,17 @@ * Copyright (C) 2014-2017 Perry de Valpine, Christopher Paciorek, * Daniel Turek, Clifford Anderson-Bergman, Nick Michaud, Fritz Obermeyer, * Duncan Temple Lang. - * + * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. - * + * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. - * + * * You should have received a copy of the GNU General Public License * along with this program; if not, a copy is available at * https://www.R-project.org/Licenses/ @@ -46,7 +46,7 @@ SEXP NimArr_2_SEXP(const std::vector &x) {return(vectorString_2_STR // We assume we have an extptr to each SEXP setDoublePtrFromSinglePtr(SEXP SdoublePtr, SEXP SsinglePtr) { void *singlePtr = R_ExternalPtrAddr(SsinglePtr); // this is really a ** - void **doublePtr = static_cast(R_ExternalPtrAddr(SdoublePtr)); // this is really a ***. + void **doublePtr = static_cast(R_ExternalPtrAddr(SdoublePtr)); // this is really a ***. *doublePtr = singlePtr; return(R_NilValue); } @@ -58,7 +58,7 @@ void setNimbleFxnPtr_copyFromRobject(void *nf_to, SEXP S_NF_from) { PROTECT(S_pxData = Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(S_pxData, 0, Rf_mkChar(".xData")); // environment(modelVar)$.CobjectInterface - PROTECT(Scnf = Rf_findVarInFrame(PROTECT(GET_SLOT( + PROTECT(Scnf = NIM_FINDVARINFRAME(PROTECT(GET_SLOT( S_NF_from, S_pxData)), Rf_install(".CobjectInterface")) @@ -69,10 +69,10 @@ void setNimbleFxnPtr_copyFromRobject(void *nf_to, SEXP S_NF_from) { //Cnf[[1]]$basePtrList[[ Cnf[[2]] ]] SEXP Sindex; PROTECT(Sindex = VECTOR_ELT(Scnf, 1)); - int index = (Rf_isInteger(Sindex) ? INTEGER(Sindex)[0] : REAL(Sindex)[0]); - index--; // From 1-based to 0-based indexing + int index = (Rf_isInteger(Sindex) ? INTEGER(Sindex)[0] : REAL(Sindex)[0]); + index--; // From 1-based to 0-based indexing PROTECT(SsinglePtr = VECTOR_ELT( - Rf_findVarInFrame(PROTECT(GET_SLOT( + NIM_FINDVARINFRAME(PROTECT(GET_SLOT( VECTOR_ELT(Scnf, 0), S_pxData)), @@ -85,7 +85,7 @@ void setNimbleFxnPtr_copyFromRobject(void *nf_to, SEXP S_NF_from) { // printf("in non-list\n"); // full interface // Cnf$.basePtr - PROTECT(SsinglePtr = Rf_findVarInFrame(PROTECT(GET_SLOT( + PROTECT(SsinglePtr = NIM_FINDVARINFRAME(PROTECT(GET_SLOT( Scnf, S_pxData)), Rf_install(".basePtr"))); @@ -98,21 +98,21 @@ void setNimbleFxnPtr_copyFromRobject(void *nf_to, SEXP S_NF_from) { // probably deprecated SEXP setSmartPtrFromSinglePtr(SEXP StoPtr, SEXP SfromPtr) { - void *fromPtr = R_ExternalPtrAddr(SfromPtr); - nimSmartPtrBase *toSmartPtr = static_cast(R_ExternalPtrAddr(StoPtr)); + void *fromPtr = R_ExternalPtrAddr(SfromPtr); + nimSmartPtrBase *toSmartPtr = static_cast(R_ExternalPtrAddr(StoPtr)); toSmartPtr->setPtrFromVoidPtr(fromPtr); return(R_NilValue); } SEXP setSmartPtrFromDoublePtr(SEXP StoPtr, SEXP SfromPtr) { - void *fromPtr = *static_cast(R_ExternalPtrAddr(SfromPtr)); - nimSmartPtrBase *toSmartPtr = static_cast(R_ExternalPtrAddr(StoPtr)); + void *fromPtr = *static_cast(R_ExternalPtrAddr(SfromPtr)); + nimSmartPtrBase *toSmartPtr = static_cast(R_ExternalPtrAddr(StoPtr)); toSmartPtr->setPtrFromVoidPtr(fromPtr); return(R_NilValue); } SEXP setPtrVectorOfPtrs(SEXP SaccessorPtr, SEXP ScontentsPtr, SEXP Ssize) { - vectorOfPtrsAccessBase *accessorPtr = static_cast(R_ExternalPtrAddr(SaccessorPtr)); + vectorOfPtrsAccessBase *accessorPtr = static_cast(R_ExternalPtrAddr(SaccessorPtr)); void *contentsPtr = static_cast(R_ExternalPtrAddr(ScontentsPtr)); int size = INTEGER(Ssize)[0]; accessorPtr->setTheVec(contentsPtr, size); @@ -120,7 +120,7 @@ SEXP setPtrVectorOfPtrs(SEXP SaccessorPtr, SEXP ScontentsPtr, SEXP Ssize) { } SEXP setOnePtrVectorOfPtrs(SEXP SaccessorPtr, SEXP Si, SEXP ScontentsPtr) { - vectorOfPtrsAccessBase *accessorPtr = static_cast(R_ExternalPtrAddr(SaccessorPtr)); + vectorOfPtrsAccessBase *accessorPtr = static_cast(R_ExternalPtrAddr(SaccessorPtr)); void *contentsPtr = static_cast(R_ExternalPtrAddr(ScontentsPtr)); int i = INTEGER(Si)[0]; accessorPtr->setVecPtr(i, contentsPtr); @@ -129,11 +129,11 @@ SEXP setOnePtrVectorOfPtrs(SEXP SaccessorPtr, SEXP Si, SEXP ScontentsPtr) { /*This function was created so we can report the status of different operations from C++ to R. I found that Rbreak does not stop the R function from which the C++ -function was called. This can cause an excessive number (e.g. nrow) of printed -error reports if the user makes a common mistake. Instead, this function is used to +function was called. This can cause an excessive number (e.g. nrow) of printed +error reports if the user makes a common mistake. Instead, this function is used to return the status to R. If it is false, we use the R function "stop" which will break for loops, etc. */ - + SEXP returnStatus(bool OK) { SEXP ans; @@ -203,7 +203,7 @@ SEXP setVecNimArrRows(SEXP Sextptr, SEXP nRows, SEXP setSize2row1){ } return(returnStatus(true) ); } - + PRINTF("Data type for VecNimArr not currently supported\n"); return(returnStatus(false) ) ; } @@ -214,7 +214,7 @@ SEXP addBlankModelValueRows(SEXP Sextptr, SEXP numAdded){ PRINTF("Error: numAdded is not an integer!\n"); return(returnStatus(false) ); } - + if(!R_ExternalPtrAddr(Sextptr)) { PRINTF("Error: Sextptr is not a valid external pointer\n"); return(returnStatus(false) ); @@ -233,12 +233,12 @@ SEXP addBlankModelValueRows(SEXP Sextptr, SEXP numAdded){ for(int i = 0; i < numDims; i++) Dims[i] = thisRow->dimSize(i); for(int i = nrowCpp; i < INTEGER(numAdded)[0] + nrowCpp; i++){ - thisRow = matPtr->getBasePtr(i); + thisRow = matPtr->getBasePtr(i); thisRow->setSize(Dims); } return(returnStatus(true) ); } - + else if(vecType == nimType::INT){ VecNimArrBase *matPtr = static_cast< VecNimArrBase* >(R_ExternalPtrAddr(Sextptr)); int nrowCpp = matPtr->size(); @@ -251,12 +251,12 @@ SEXP addBlankModelValueRows(SEXP Sextptr, SEXP numAdded){ for(int i = 0; i < numDims; i++) Dims[i] = thisRow->dimSize(i); for(int i = nrowCpp; i < INTEGER(numAdded)[0] + nrowCpp; i++){ - thisRow = matPtr->getBasePtr(i); + thisRow = matPtr->getBasePtr(i); thisRow->setSize(Dims); } return(returnStatus(true) ); } - + PRINTF("Data type for VecNimArr not currently supported\n"); return(returnStatus(false) ) ; } @@ -284,7 +284,7 @@ SEXP getNRow(SEXP Sextptr){ // cout << "vecType DOUBLE = " << DOUBLE << "\n"; } SEXP rNRow; - PROTECT(rNRow = Rf_allocVector(INTSXP, 1) ); + PROTECT(rNRow = Rf_allocVector(INTSXP, 1) ); INTEGER(rNRow)[0] = nRow; UNPROTECT(1); return(rNRow); @@ -306,7 +306,7 @@ SEXP copyModelValuesElements(SEXP SextptrFrom, SEXP SextptrTo, SEXP rowsFrom, SE if(LENGTH(rowsFrom) == 0){ return(returnStatus(true) ); } - + NimVecType *typePtrFrom = static_cast< NimVecType* >(R_ExternalPtrAddr(SextptrFrom)); nimType vecTypeFrom = (*typePtrFrom).getNimType(); NimVecType *typePtrTo = static_cast< NimVecType* >(R_ExternalPtrAddr(SextptrTo)); @@ -324,7 +324,7 @@ SEXP copyModelValuesElements(SEXP SextptrFrom, SEXP SextptrTo, SEXP rowsFrom, SE NimArrBase *thisRowTo; int ncFrom = 0; int ncTo = 0; - + for(int i = 0; i < k; i++){ if((indexFrom[i] > sizeFrom) || (indexFrom[i] <= 0)) { @@ -342,12 +342,12 @@ SEXP copyModelValuesElements(SEXP SextptrFrom, SEXP SextptrTo, SEXP rowsFrom, SE PRINTF("Warning: partial copy completed before error discovered!\n"); return(returnStatus(false) ); } - thisRowFrom = matPtrFrom->getBasePtr(indexFrom[i] - 1); - thisRowTo = matPtrTo->getBasePtr(indexTo[i] - 1); - + thisRowFrom = matPtrFrom->getBasePtr(indexFrom[i] - 1); + thisRowTo = matPtrTo->getBasePtr(indexTo[i] - 1); + ncFrom = thisRowFrom->size(); ncTo = thisRowTo->size(); - + if(ncFrom != ncTo){ PRINTF("Error: ncFrom != ncTo\n"); if(i > 0) @@ -372,7 +372,7 @@ SEXP copyModelValuesElements(SEXP SextptrFrom, SEXP SextptrTo, SEXP rowsFrom, SE NimArrBase *thisRowTo; int ncFrom = 0; int ncTo = 0; - + for(int i = 0; i < k; i++){ if((indexFrom[i] > sizeFrom) || (indexFrom[i] <= 0)) { @@ -390,12 +390,12 @@ SEXP copyModelValuesElements(SEXP SextptrFrom, SEXP SextptrTo, SEXP rowsFrom, SE PRINTF("Warning: partial copy completed before error discovered!\n"); return(returnStatus(false) ); } - thisRowFrom = matPtrFrom->getBasePtr(indexFrom[i] - 1); - thisRowTo = matPtrTo->getBasePtr(indexTo[i] - 1); - + thisRowFrom = matPtrFrom->getBasePtr(indexFrom[i] - 1); + thisRowTo = matPtrTo->getBasePtr(indexTo[i] - 1); + ncFrom = thisRowFrom->size(); ncTo = thisRowTo->size(); - + if(ncFrom != ncTo){ PRINTF("Error: ncFrom != ncTo\n"); if(i > 0) @@ -411,7 +411,7 @@ SEXP copyModelValuesElements(SEXP SextptrFrom, SEXP SextptrTo, SEXP rowsFrom, SE PRINTF("Data type not currently supported for VecNimArr. Copy MV elements failed\n"); return(returnStatus(false) ); -} +} SEXP getMVElement(SEXP Sextptr, SEXP Sindex){ if(!Rf_isInteger(Sindex)) { @@ -434,11 +434,11 @@ SEXP getMVElement(SEXP Sextptr, SEXP Sindex){ PRINTF("Error: index < 1\n"); return(returnStatus(false) ) ; } - return(cGetMVElementOneRow(typePtr, vecType, index) ) ; -} + return(cGetMVElementOneRow(typePtr, vecType, index) ) ; +} // This is not called directly from R. It is called from getMVElement -SEXP cGetMVElementOneRow(NimVecType* typePtr, nimType vecType, int index) { +SEXP cGetMVElementOneRow(NimVecType* typePtr, nimType vecType, int index) { if(vecType == nimType::DOUBLE){ VecNimArrBase *matPtr = static_cast< VecNimArrBase* >(typePtr); NimArrBase *thisRow; @@ -480,7 +480,7 @@ SEXP cGetMVElementOneRow(NimVecType* typePtr, nimType vecType, int index) { else { UNPROTECT(1); } - return(Sans); + return(Sans); } else PRINTF("VecNimArr datatype not supported\n"); @@ -570,8 +570,8 @@ SEXP setMVElement(SEXP Sextptr, SEXP Sindex, SEXP Svalue){ return(returnStatus(false) ) ; } int index = INTEGER(Sindex)[0]; - if(index < 1){ - PRINTF("Error: index < 1\n"); + if(index < 1){ + PRINTF("Error: index < 1\n"); return(returnStatus(false) ) ; } @@ -585,11 +585,11 @@ SEXP setMVElement(SEXP Sextptr, SEXP Sindex, SEXP Svalue){ cSetMVElementSingle( typePtr, vecType, index, Svalue ); //SEXP SEXP_2_int(SEXP rPtr, SEXP refNum, SEXP rScalar); return(returnStatus(true) ); - } - - + } + + SEXP getMVsize(SEXP Sextptr){ - NimVecType *nimVecPtr = static_cast(R_ExternalPtrAddr(Sextptr) ); + NimVecType *nimVecPtr = static_cast(R_ExternalPtrAddr(Sextptr) ); vector cDims = (*nimVecPtr).getRowDims(0); int nDims = cDims.size(); SEXP Sans; @@ -602,10 +602,10 @@ SEXP setMVElement(SEXP Sextptr, SEXP Sindex, SEXP Svalue){ SEXP NimArrDouble_2_SEXP(NimArrBase &nimArrDbl){ int len = nimArrDbl.size(); - SEXP Sans; + SEXP Sans; PROTECT(Sans = Rf_allocVector(REALSXP, len)); // std::copy(nimArrDbl.v.begin(), nimArrDbl.v.end() , REAL(Sans) ); - std::copy(nimArrDbl.v, nimArrDbl.v + len , REAL(Sans) ); + std::copy(nimArrDbl.v, nimArrDbl.v + len , REAL(Sans) ); int numDims = nimArrDbl.numDims(); if(numDims > 1) { SEXP Sdim; @@ -616,16 +616,16 @@ SEXP NimArrDouble_2_SEXP(NimArrBase &nimArrDbl){ } else { UNPROTECT(1); - } + } return(Sans); } SEXP NimArrInt_2_SEXP(NimArrBase &nimArrInt){ int len = nimArrInt.size(); - SEXP Sans; + SEXP Sans; PROTECT(Sans = Rf_allocVector(INTSXP, len)); // std::copy(nimArrInt.v.begin(), nimArrInt.v.end() , INTEGER(Sans) ); - std::copy(nimArrInt.v, nimArrInt.v + len , INTEGER(Sans) ); + std::copy(nimArrInt.v, nimArrInt.v + len , INTEGER(Sans) ); int numDims = nimArrInt.numDims(); if(numDims > 1) { SEXP Sdim; @@ -636,16 +636,16 @@ SEXP NimArrInt_2_SEXP(NimArrBase &nimArrInt){ } else { UNPROTECT(1); - } + } return(Sans); } SEXP NimArrBool_2_SEXP(NimArrBase &nimArrBl){ int len = nimArrBl.size(); - SEXP Sans; + SEXP Sans; PROTECT(Sans = Rf_allocVector(LGLSXP, len)); // std::copy(nimArrInt.v.begin(), nimArrInt.v.end() , INTEGER(Sans) ); - std::copy(nimArrBl.v, nimArrBl.v + len , LOGICAL(Sans) ); + std::copy(nimArrBl.v, nimArrBl.v + len , LOGICAL(Sans) ); int numDims = nimArrBl.numDims(); if(numDims > 1) { SEXP Sdim; @@ -656,7 +656,7 @@ SEXP NimArrBool_2_SEXP(NimArrBase &nimArrBl){ } else { UNPROTECT(1); - } + } return(Sans); } @@ -667,7 +667,7 @@ NimArrType* getNimTypePtr(SEXP &rPtr, SEXP &refNum) int cRefNum = INTEGER(refNum)[0]; if(cRefNum == 1){ nimTypePtr = static_cast(R_ExternalPtrAddr(rPtr) ); - return(nimTypePtr); + return(nimTypePtr); } if(cRefNum == 2){ nimTypePtr = (*static_cast (R_ExternalPtrAddr(rPtr) ) ); @@ -692,7 +692,7 @@ void SEXP_2_NimArrDouble (SEXP rValues, NimArrBase &NimArrDbl){ for(int i = 0; i < rLength; i++) NimArrDbl[i] = INTEGER(rValues)[i]; } - + else PRINTF("WARNING: class of R object not recognized. Should be numeric or integer\n"); return; @@ -702,9 +702,9 @@ void SEXP_2_NimArrInt (SEXP rValues, NimArrBase &NimArrInt){ int rLength = LENGTH(rValues); if(rLength != NimArrInt.size() ) { PRINTF("Warning: R object of different size than NimArrInt!\n"); - return; + return; } - + if(Rf_isInteger(rValues) || Rf_isLogical(rValues) ) { for(int i = 0; i < rLength; i++) NimArrInt[i] = INTEGER(rValues)[i]; @@ -713,9 +713,9 @@ void SEXP_2_NimArrInt (SEXP rValues, NimArrBase &NimArrInt){ for(int i = 0; i < rLength; i++) NimArrInt[i] = REAL(rValues)[i]; } - + else - PRINTF("WARNING: class of R object not recognized. Should be numeric or integer\n"); + PRINTF("WARNING: class of R object not recognized. Should be numeric or integer\n"); return; } @@ -723,7 +723,7 @@ void SEXP_2_NimArrBool (SEXP rValues, NimArrBase &NimArrBl){ int rLength = LENGTH(rValues); if(rLength != NimArrBl.size() ) { PRINTF("Warning: R object of different size than NimArrBl!\n"); - return; + return; } // In R, Logical is represented as integer @@ -735,9 +735,9 @@ void SEXP_2_NimArrBool (SEXP rValues, NimArrBase &NimArrBl){ for(int i = 0; i < rLength; i++) NimArrBl[i] = REAL(rValues)[i]; } - + else - PRINTF("WARNING: class of R object not recognized. Should be numeric or integer\n"); + PRINTF("WARNING: class of R object not recognized. Should be numeric or integer\n"); return; } @@ -768,15 +768,15 @@ void SEXP_2_Nim_internal(NimArrType* nimTypePtr, bool resize = true) { vector sexpDims = getSEXPdims( rValues ); int sexpNumDims = sexpDims.size(); - + if(!nimTypePtr) return; - + if((*nimTypePtr).getNimType() == nimType::INT){ NimArrBase* nimBase = static_cast *>(nimTypePtr); int nimNumDims = (*nimBase).numDims(); if(nimNumDims != sexpNumDims) { - if((LENGTH(rValues) != (*nimBase).size()) && + if((LENGTH(rValues) != (*nimBase).size()) && (sexpNumDims != 1)){ PRINTF("Incorrect number of dimensions in copying\n"); return; @@ -787,10 +787,10 @@ void SEXP_2_Nim_internal(NimArrType* nimTypePtr, SEXP_2_NimArrInt(rValues, (*nimBase) ) ; } if((*nimTypePtr).getNimType() == nimType::DOUBLE){ - + NimArrBase* nimBase = static_cast *>(nimTypePtr); int nimNumDims = (*nimBase).numDims(); - + if(nimNumDims != sexpNumDims){ if((LENGTH(rValues) != (*nimBase).size()) & (sexpNumDims != 1)){ @@ -849,7 +849,7 @@ double nimMod(double a, double b) { return(fmod(a, b)); } -// bool compareOrderedPair(orderedPair a, orderedPair b) { //function called for sort +// bool compareOrderedPair(orderedPair a, orderedPair b) { //function called for sort // return(a.value < b.value); // } @@ -877,7 +877,7 @@ void row2NimArr(SEXP matrix, NimArrBase* nimPtr, int startPoint, int len void row2NimArr(SEXP matrix, NimArrBase* nimPtr, int startPoint, int len, int nRows){ for(int i = 0; i < len; i++) - (*nimPtr)[i] = INTEGER(matrix)[startPoint + i * nRows]; + (*nimPtr)[i] = INTEGER(matrix)[startPoint + i * nRows]; } SEXP matrix2VecNimArr(SEXP RvecNimPtr, SEXP matrix, SEXP rowStart, SEXP rowEnd){ @@ -905,7 +905,7 @@ SEXP matrix2VecNimArr(SEXP RvecNimPtr, SEXP matrix, SEXP rowStart, SEXP rowEnd){ // if(dnRows != floor(dnRows)) { // NIMERROR("In matrix2VecNimArr: Length of matrix is not congruent with dimensions of modelValues variable.\n"); // } - // nRows = Rf_length(matrix) / len; + // nRows = Rf_length(matrix) / len; } else if(Rf_length(RmatrixDim) == 1) { NIMERROR("In matrix2VecNimArr: matrix argument must be a matrix, but a one-dimensional array was provided\n"); // // If matrix is not a vector, then if it is a 1D array, handle it like a vector @@ -957,7 +957,7 @@ SEXP matrix2VecNimArr(SEXP RvecNimPtr, SEXP matrix, SEXP rowStart, SEXP rowEnd){ SEXP getEnvVar_Sindex(SEXP sString, SEXP sEnv, SEXP sIndex){ SEXP ans; int cIndex = INTEGER(sIndex)[0] - 1; - ans = Rf_findVar(Rf_install(CHAR(STRING_ELT(sString, cIndex ))), sEnv); + ans = NIM_FINDVAR(Rf_install(CHAR(STRING_ELT(sString, cIndex ))), sEnv); PROTECT(ans); UNPROTECT(1); return(ans); @@ -973,7 +973,6 @@ SEXP setEnvVar_Sindex(SEXP sString, SEXP sEnv, SEXP sVal, SEXP sIndex){ return(R_NilValue); } - SEXP setEnvVar(SEXP sString, SEXP sEnv, SEXP sVal){ + SEXP setEnvVar(SEXP sString, SEXP sEnv, SEXP sVal){ return(setEnvVar_Sindex(sString, sEnv, sVal, Rf_ScalarInteger(1))); } - diff --git a/packages/nimble/inst/CppCode/RcppUtils.cpp b/packages/nimble/inst/CppCode/RcppUtils.cpp index 1b65c1384..7a448a731 100644 --- a/packages/nimble/inst/CppCode/RcppUtils.cpp +++ b/packages/nimble/inst/CppCode/RcppUtils.cpp @@ -3,17 +3,17 @@ * Copyright (C) 2014-2017 Perry de Valpine, Christopher Paciorek, * Daniel Turek, Clifford Anderson-Bergman, Nick Michaud, Fritz Obermeyer, * Duncan Temple Lang. - * + * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. - * + * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. - * + * * You should have received a copy of the GNU General Public License * along with this program; if not, a copy is available at * https://www.R-project.org/Licenses/ @@ -46,7 +46,7 @@ vector getSEXPdims(SEXP Sx) { if(!Rf_isNumeric(Sx)) {PRINTF("Error, getSEXPdims called for something not numeric\n"); return(vector());} if(!Rf_isVector(Sx)) {PRINTF("Error, getSEXPdims called for something not vector\n"); return(vector());} if(!Rf_isArray(Sx) && !Rf_isMatrix(Sx)) { - vector ans; + vector ans; ans.resize(1); ans[0] = LENGTH(Sx); return(ans); } return(SEXP_2_vectorInt(Rf_getAttrib(Sx, R_DimSymbol), 0)); @@ -54,7 +54,7 @@ vector getSEXPdims(SEXP Sx) { string STRSEXP_2_string(SEXP Ss, int i) { if(!Rf_isString(Ss)) { - PRINTF("Error: STRSEXP_2_string called for SEXP that is not a string!\n"); + PRINTF("Error: STRSEXP_2_string called for SEXP that is not a string!\n"); return(string("")); } if(LENGTH(Ss) <= i) { @@ -68,7 +68,7 @@ string STRSEXP_2_string(SEXP Ss, int i) { void STRSEXP_2_vectorString(SEXP Ss, vector &ans) { if(!Rf_isString(Ss)) { - PRINTF("Error: STRSEXP_2_vectorString called for SEXP that is not a string!\n"); + PRINTF("Error: STRSEXP_2_vectorString called for SEXP that is not a string!\n"); return; } int nn = LENGTH(Ss); @@ -122,7 +122,7 @@ double SEXP_2_double(SEXP Sn, int i) { if(LENGTH(Sn) <= i) PRINTF("Error: SEXP_2_double called for element %i >= length of %i.\n", i, LENGTH(Sn)); if(Rf_isReal(Sn)) { return(REAL(Sn)[i]); - } + } if(Rf_isInteger(Sn) || Rf_isLogical(Sn)) { if(Rf_isInteger(Sn)) return(static_cast(INTEGER(Sn)[i])); @@ -214,7 +214,7 @@ vector SEXP_2_vectorInt( SEXP Sn, int offset ) { int *iSn = Rf_isInteger(Sn) ? INTEGER(Sn) : LOGICAL(Sn); if(offset == 0) copy(iSn, iSn + nn, ans.begin()); else { - std::transform(iSn, iSn + nn, ans.begin(), opIntegerShift(offset)); + std::transform(iSn, iSn + nn, ans.begin(), opIntegerShift(offset)); } } else { if(Rf_isReal(Sn)) { @@ -288,7 +288,7 @@ bool SEXP_2_bool(SEXP Sn, int i) { // bool checkString(SEXP Ss, int len) { // if(!Rf_isString(Ss)) { -// PRINTF("Error: something that was supposed to be a string is not\n"); +// PRINTF("Error: something that was supposed to be a string is not\n"); // return(false); // } // if(LENGTH(Ss) < len) { @@ -322,10 +322,10 @@ bool SEXP_2_bool(SEXP Sn, int i) { // if(nn > lengthCpp) nn = lengthCpp; // } // double *value = REAL(Svalue); -// std::copy(value, value + nn, &(vecPtr->v[0]) ); +// std::copy(value, value + nn, &(vecPtr->v[0]) ); // return(R_NilValue); // } - + // SEXP getVec(SEXP Sextptr) { // if(!R_ExternalPtrAddr(Sextptr)) { // PRINTF("Error: Sextptr is not a valid external pointer\n"); @@ -335,12 +335,12 @@ bool SEXP_2_bool(SEXP Sn, int i) { // NimArrBase *vecPtr = static_cast< NimArrBase * >(R_ExternalPtrAddr(Sextptr)); // int len = vecPtr->size(); -// SEXP Sans; - +// SEXP Sans; + // PROTECT(Sans = Rf_allocVector(REALSXP, len)); // //std::copy(vecPtr->v.begin(), vecPtr->v.end() , REAL(Sans) ); // std::copy(vecPtr->v, vecPtr->v + len , REAL(Sans) ); - + // int numDims = vecPtr->numDims(); // if(numDims > 1) { // SEXP Sdim; @@ -350,7 +350,7 @@ bool SEXP_2_bool(SEXP Sn, int i) { // UNPROTECT(2); // } else { // UNPROTECT(1); -// } +// } // return(Sans); // } @@ -362,11 +362,11 @@ bool SEXP_2_bool(SEXP Sn, int i) { // NimArrBase *vecPtr = *static_cast< NimArrBase ** >(R_ExternalPtrAddr(Sextptr)); // SEXP Sans; // int len = vecPtr->size(); - + // PROTECT(Sans = Rf_allocVector(REALSXP, len)); // // std::copy(vecPtr->v.begin(), vecPtr->v.end(), INTEGER(Sans) ); -// std::copy(vecPtr->v, vecPtr->v + len, INTEGER(Sans) ); - +// std::copy(vecPtr->v, vecPtr->v + len, INTEGER(Sans) ); + // int numDims = vecPtr->numDims(); // if(numDims > 1) { // SEXP Sdim; @@ -376,7 +376,7 @@ bool SEXP_2_bool(SEXP Sn, int i) { // UNPROTECT(2); // } else { // UNPROTECT(1); -// } +// } // return(Sans); // } @@ -447,7 +447,7 @@ SEXP populate_SEXP_2_int(SEXP rPtr, SEXP refNum, SEXP rScalar){ else if(cRefNum == 2) cPtr = (*static_cast ( vPtr ) ); else return(R_NilValue); - + populate_SEXP_2_int_internal(cPtr, rScalar); return(R_NilValue); } @@ -526,7 +526,7 @@ SEXP extract_double_2_SEXP(SEXP rPtr, SEXP refNum){ } SEXP Sans; PROTECT(Sans = Rf_allocVector(REALSXP, 1)); - REAL(Sans)[0] = (*cPtr); + REAL(Sans)[0] = (*cPtr); UNPROTECT(1); return(Sans); } @@ -597,15 +597,15 @@ SEXP fastMatrixInsert(SEXP matrixInto, SEXP matrix, SEXP rowStart, SEXP colStart PROTECT(RdimInto); int Iinto = INTEGER(RdimInto)[0]; int Jinto = INTEGER(RdimInto)[1]; - + SEXP Rdim = Rf_getAttrib(matrix, R_DimSymbol); PROTECT(Rdim); int I = INTEGER(Rdim)[0]; int J = INTEGER(Rdim)[1]; - + int cRowStart = INTEGER(rowStart)[0] - 1; int cColStart = INTEGER(colStart)[0] - 1; - + if((I + cRowStart > Iinto) || (J + cColStart > Jinto)){ UNPROTECT(2); PRINTF("Matrix copying not allowed for given indices\n"); @@ -628,12 +628,12 @@ SEXP matrix2ListDouble(SEXP matrix, SEXP list, SEXP listStartIndex, SEXP RnRows, for(int i = 0; i < cNRows; i++){ SEXP row = PROTECT(Rf_allocVector(REALSXP, len) ) ; Rf_setAttrib(row, R_DimSymbol, dims); - for(int j = 0; j < len; j++){ + for(int j = 0; j < len; j++){ REAL(row)[j] = REAL(matrix)[i + cNRows * j]; } SET_VECTOR_ELT(list, i, row); UNPROTECT(1); - } + } return(R_NilValue); } @@ -646,12 +646,12 @@ SEXP matrix2ListInt(SEXP matrix, SEXP list, SEXP listStartIndex, SEXP RnRows, S for(int i = 0; i < cNRows; i++){ SEXP row = PROTECT(Rf_allocVector(INTSXP, len) ) ; Rf_setAttrib(row, R_DimSymbol, dims); - for(int j = 0; j < len; j++){ + for(int j = 0; j < len; j++){ INTEGER(row)[j] = INTEGER(matrix)[i + cNRows * j]; } SET_VECTOR_ELT(list, i, row); UNPROTECT(1); - } + } return(R_NilValue); } @@ -685,10 +685,10 @@ void rawSample(double* p, int c_samps, int N, int* ans, bool unsort, bool silent cdf[N] = sum + 1; vector sampP(c_samps + 1); sampP[0] = 1 - exp( log( unif_rand() ) / c_samps ); - + sampP[0] = sampP[0] * sum; sampP[c_samps] = sum + 1; - + for(int i = 1; i < c_samps ; i++) sampP[i] = (1 - exp( log(unif_rand()) / (c_samps - i) ) )* (sum - sampP[i-1]) + sampP[i-1]; int curP = 0; @@ -699,17 +699,17 @@ void rawSample(double* p, int c_samps, int N, int* ans, bool unsort, bool silent curP++; } } - return; + return; } // unsort must be true to get here - vector sortAns(c_samps); + vector sortAns(c_samps); for(int i = 1; i <= N; i++){ while(cdf[i] > (sampP[curP])){ sortAns[curP] = i; curP++; } } - + vector newOrder(c_samps); for(int i = 0; i < c_samps;i++) newOrder[i] = i; @@ -875,7 +875,7 @@ SEXP varAndIndices_2_LANGSXP(const varAndIndicesClass &varAndInds) { } else { _nimble_global_output<<"problem in varAndIndices_2_LANGSXP: there is badly formed input\n"; nimble_print_to_R(_nimble_global_output); - + } } } @@ -903,7 +903,7 @@ SEXP makeNewNimbleList(SEXP S_listName) { SEXP SnimbleInternalFunctionsEnv; SEXP call; SnimbleInternalFunctionsEnv = - PROTECT(Rf_eval(PROTECT(Rf_findVar(Rf_install("nimbleInternalFunctions"), R_GlobalEnv)), R_GlobalEnv)); + PROTECT(Rf_eval(PROTECT(NIM_FINDVAR(Rf_install("nimbleInternalFunctions"), R_GlobalEnv)), R_GlobalEnv)); call = PROTECT(Rf_allocVector(LANGSXP, 2)); SETCAR(call, Rf_install("makeNewNimListSEXPRESSIONFromC")); SETCADR(call, S_listName); diff --git a/packages/nimble/inst/CppCode/accessorClasses.cpp b/packages/nimble/inst/CppCode/accessorClasses.cpp index 8128846b6..467e3a492 100644 --- a/packages/nimble/inst/CppCode/accessorClasses.cpp +++ b/packages/nimble/inst/CppCode/accessorClasses.cpp @@ -3,17 +3,17 @@ * Copyright (C) 2014-2017 Perry de Valpine, Christopher Paciorek, * Daniel Turek, Clifford Anderson-Bergman, Nick Michaud, Fritz Obermeyer, * Duncan Temple Lang. - * + * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. - * + * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. - * + * * You should have received a copy of the GNU General Public License * along with this program; if not, a copy is available at * https://www.R-project.org/Licenses/ @@ -111,13 +111,13 @@ set_CppAD_tape_info_for_model::~set_CppAD_tape_info_for_model() { // nimbleCppADrecordingInfoClass &recordingInfo) { // // std::cout <<"entering calculate_ADproxyModel"<< std::endl; // // std::cout<<"handle address: "<::get_handle_address_nimble()< ans = 0; // const vector &instructions = nodes.getInstructions(); // vector::const_iterator iNode(instructions.begin()); // vector::const_iterator iNodeEnd(instructions.end()); // // std::cout<<"starting node calcs in calculate_ADproxyModel"<nodeFunPtr->calculateBlock_ADproxyModel(iNode->operand); // if(includeExtraOutputStep && recordingInfo.recording()) { @@ -420,7 +420,7 @@ void nimArr_2_ManyModelAccessIndex(ManyVariablesMapAccessor &MMVAPtr, NimArrBase if(nimCurrent != nimEnd) PRINTF("Warning: after completing nimArr_2_ManyModelAccessIndex, nimCurrent != nimEnd. Perhaps the NimArr was longer than the accessor?\n"); } - + /////////////// // [accessors]_2_nimArr // nimArr is "to". SMVAPtr is "from" @@ -538,7 +538,7 @@ void getValues_AD_AD(NimArr<1, CppAD::AD > &nimArr, ManyVariablesMapAcce void getValues(NimArr<1, double> &nimArr, ManyVariablesMapAccessor &MVA, int index){ ManyModelAccessIndex_2_nimArr(MVA, nimArr, index-1); -} +} void getValues(NimArr<1, int> &nimArr, ManyVariablesMapAccessor &MVA, int index){ ManyModelAccessIndex_2_nimArr(MVA, nimArr, index-1); @@ -593,7 +593,7 @@ void copierVectorClass::setup(ManyVariablesMapAccessorBase *from, ManyVariablesM iTo = toAccessors->begin(); int i = 0; for(iFrom = fromAccessors->begin(); iFrom != iFromEnd; iFrom++) { - copyVector[i] = makeOneCopyClass(*iFrom, *iTo, isFromMV, isToMV); + copyVector[i] = makeOneCopyClass(*iFrom, *iTo, isFromMV, isToMV); iTo++; i++; } @@ -609,7 +609,7 @@ copierVectorClass::~copierVectorClass() { } -void nimCopy(ManyVariablesMapAccessorBase &from, ManyVariablesMapAccessorBase &to) { +void nimCopy(ManyVariablesMapAccessorBase &from, ManyVariablesMapAccessorBase &to) { vector *fromAccessors = &(from.getMapAccessVector()); vector *toAccessors = &(to.getMapAccessVector()); @@ -929,9 +929,9 @@ void populateNodeFxnVectorNew_copyFromRobject_forDerivs(void *nodeFxnVec_to, SEX SEXP S_rowIndices; PROTECT(S_rowIndices = VECTOR_ELT(S_indexingInfo, 1)); SEXP S_numberedPtrs; - PROTECT(S_numberedPtrs = PROTECT(Rf_findVarInFrame(PROTECT(GET_SLOT( - PROTECT(Rf_findVarInFrame(PROTECT(GET_SLOT( - PROTECT(Rf_findVarInFrame(PROTECT(GET_SLOT( + PROTECT(S_numberedPtrs = PROTECT(NIM_FINDVARINFRAME(PROTECT(GET_SLOT( + PROTECT(NIM_FINDVARINFRAME(PROTECT(GET_SLOT( + PROTECT(NIM_FINDVARINFRAME(PROTECT(GET_SLOT( VECTOR_ELT(S_nodeFxnVec_from, 2 ), @@ -990,9 +990,9 @@ void populateNodeFxnVectorNew_copyFromRobject(void *nodeFxnVec_to, SEXP S_nodeFx SEXP S_numberedPtrs; // equivalent to S_nodeFxnVec_from[["model"]]$CobjectInterface$.nodeFxnPointers_byDeclID$.ptr // implemented by S_nodeFxnVec_from[[2]]@.xData[["CobjectInterface"]]@.xData[[".nodeFxnPointers_byDeclID"]]@.xData[[".ptr"]] - S_numberedPtrs = PROTECT(Rf_findVarInFrame(PROTECT(GET_SLOT( - PROTECT(Rf_findVarInFrame(PROTECT(GET_SLOT( - PROTECT(Rf_findVarInFrame(PROTECT(GET_SLOT( + S_numberedPtrs = PROTECT(NIM_FINDVARINFRAME(PROTECT(GET_SLOT( + PROTECT(NIM_FINDVARINFRAME(PROTECT(GET_SLOT( + PROTECT(NIM_FINDVARINFRAME(PROTECT(GET_SLOT( VECTOR_ELT(S_nodeFxnVec_from, 2 ), @@ -1211,7 +1211,7 @@ void populateValueMapAccessorsFromNodeNames_internal(ManyVariablesMapAccessorBas SEXP SoneSizesAndNdims; mapInfoClass mapInfo; int totalLength = 0; - + #ifdef _DEBUG_POPULATE_MAP_ACCESSORS _nimble_global_output<<"New: "<(S_values, values); SEXP_2_NimArr<2>(S_vectors, vectors); UNPROTECT(5); @@ -127,7 +127,7 @@ void EIGEN_EIGENCLASS_R::copyFromSEXP ( SEXP S_nimList_ ) { Rf_defineVar(Rf_install("u"), S_u, PROTECT(GET_SLOT(RObjectPointer, S_pxData))); Rf_defineVar(Rf_install("v"), S_v, PROTECT(GET_SLOT(RObjectPointer, S_pxData))); UNPROTECT(7); - + return(RObjectPointer); } @@ -149,9 +149,9 @@ void EIGEN_EIGENCLASS_R::copyFromSEXP ( SEXP S_nimList_ ) { RObjectPointer = S_nimList_; PROTECT(S_pxData = Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(S_pxData, 0, Rf_mkChar(".xData")); - PROTECT(S_d = Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S_pxData)), Rf_install("d"))); - PROTECT(S_v = Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S_pxData)), Rf_install("v"))); - PROTECT(S_u = Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S_pxData)), Rf_install("u"))); + PROTECT(S_d = NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S_pxData)), Rf_install("d"))); + PROTECT(S_v = NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S_pxData)), Rf_install("v"))); + PROTECT(S_u = NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S_pxData)), Rf_install("u"))); SEXP_2_NimArr<1>(S_d, d); SEXP_2_NimArr<2>(S_v, v); SEXP_2_NimArr<2>(S_u, u); @@ -168,7 +168,7 @@ SEXP C_nimEigen(SEXP S_x, SEXP S_symmetric, SEXP S_valuesOnly, SEXP returnList) SEXP_2_NimArr<2>(S_x, x); valuesOnly = SEXP_2_bool(S_valuesOnly); symmetric = SEXP_2_bool(S_symmetric); - Eigen::Map Eig_x(x.getPtr(), x.dim()[0], x.dim()[1]); + Eigen::Map Eig_x(x.getPtr(), x.dim()[0], x.dim()[1]); EIGEN_EIGENCLASS_R C_eigenClass = *EIGEN_EIGEN_R(Eig_x, symmetric, valuesOnly); C_eigenClass.RObjectPointer = returnList; C_eigenClass.copyToSEXP(); @@ -181,7 +181,7 @@ SEXP C_nimSvd(SEXP S_x, SEXP S_vectors, SEXP returnList) { NimArr<2, double> x; int vectors = SEXP_2_int(S_vectors, 0); SEXP_2_NimArr<2>(S_x, x); - Eigen::Map Eig_x(x.getPtr(), x.dim()[0], x.dim()[1]); + Eigen::Map Eig_x(x.getPtr(), x.dim()[0], x.dim()[1]); EIGEN_SVDCLASS_R C_svdClass = *EIGEN_SVD_R(Eig_x, vectors); C_svdClass.RObjectPointer = returnList; C_svdClass.copyToSEXP(); diff --git a/packages/nimble/inst/CppCode/nimOptim.cpp b/packages/nimble/inst/CppCode/nimOptim.cpp index 1fe2fac77..96cbc67aa 100644 --- a/packages/nimble/inst/CppCode/nimOptim.cpp +++ b/packages/nimble/inst/CppCode/nimOptim.cpp @@ -3,17 +3,17 @@ * Copyright (C) 2014-2017 Perry de Valpine, Christopher Paciorek, * Daniel Turek, Clifford Anderson-Bergman, Nick Michaud, Fritz Obermeyer, * Duncan Temple Lang. - * + * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. - * + * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. - * + * * You should have received a copy of the GNU General Public License * along with this program; if not, a copy is available at * https://www.R-project.org/Licenses/ @@ -290,7 +290,7 @@ nimSmartPtr NimOptimProblem::solve( SET_NEXT_LANG_ARG(SLANGpiece, PROTECT(R_MakeExternalPtr(this, R_NilValue, R_NilValue))); SEXP SnimbleInternalFunctionsEnv = - PROTECT(Rf_eval(PROTECT(Rf_findVar(Rf_install("nimbleInternalFunctions"), + PROTECT(Rf_eval(PROTECT(NIM_FINDVAR(Rf_install("nimbleInternalFunctions"), R_GlobalEnv)), R_GlobalEnv)); @@ -396,17 +396,17 @@ The .External2 format passes the R call in a standard four arguments, of which t The actual optimization algorithms such as nmmin and vmmin can be found in src/appl/optim.c. optimhess calculates the Hessian. We see that it uses finite element method for the gradient at points p + eps and p - eps, where eps comes from the - control list argument ndeps, which acccording to help(optim) can be user supplied or defaults to 0.001. + control list argument ndeps, which acccording to help(optim) can be user supplied or defaults to 0.001. The gradient is evaluated via fmingr, which either uses the supplied gradient function or uses finite element differences of +/- eps. For the finite element case, this means in effect that the function (fminfn) is evaluated at p + 2*eps, p [twice, once in each call to fmingr], and p - 2*eps. -The exception is for a case with bounds (L-BFGS-B), in which case, inside fmingr, the p + eps and p-eps are reduced to upper boundary or lower boundary, -respectively, and the corresponding epsilons are adjusted. +The exception is for a case with bounds (L-BFGS-B), in which case, inside fmingr, the p + eps and p-eps are reduced to upper boundary or lower boundary, +respectively, and the corresponding epsilons are adjusted. fminfn and fmingr are defined in the same file as optim and optimhess. (Our gr function above mimics the behavior of fmingr.) -These functions wrap calls to the R evaluator for the provided +These functions wrap calls to the R evaluator for the provided objective and gradient functions, respectively. Within these functions, parscale and fnscale are applied. (Our fn and gr use fnscale but not parscale.) */ diff --git a/packages/nimble/inst/CppCode/predefinedNimbleLists.cpp b/packages/nimble/inst/CppCode/predefinedNimbleLists.cpp index 5668a4fad..014831546 100644 --- a/packages/nimble/inst/CppCode/predefinedNimbleLists.cpp +++ b/packages/nimble/inst/CppCode/predefinedNimbleLists.cpp @@ -111,22 +111,22 @@ void OptimResultNimbleList::copyFromSEXP(SEXP S_nimList_) { R_PreserveObject(RObjectPointer = S_nimList_); PROTECT(S__dot_xData = Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(S__dot_xData, 0, PROTECT(Rf_mkChar(".xData"))); - PROTECT(S_par = Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + PROTECT(S_par = NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("par"))); PROTECT(S_value = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("value"))); PROTECT(S_counts = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("counts"))); PROTECT(S_convergence = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("convergence"))); PROTECT(S_message = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("message"))); PROTECT(S_hessian = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("hessian"))); SEXP_2_NimArr<1>(S_par, par); value = SEXP_2_double(S_value); @@ -273,50 +273,50 @@ void OptimControlNimbleList::copyFromSEXP(SEXP S_nimList_) { PROTECT(S__dot_xData = Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(S__dot_xData, 0, PROTECT(Rf_mkChar(".xData"))); PROTECT(S_trace = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("trace"))); PROTECT(S_fnscale = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("fnscale"))); PROTECT(S_parscale = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("parscale"))); PROTECT(S_ndeps = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("ndeps"))); PROTECT(S_maxit = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("maxit"))); PROTECT(S_abstol = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("abstol"))); PROTECT(S_reltol = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("reltol"))); PROTECT(S_alpha = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("alpha"))); - PROTECT(S_beta = Rf_findVarInFrame( + PROTECT(S_beta = NIM_FINDVARINFRAME( PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("beta"))); PROTECT(S_gamma = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("gamma"))); PROTECT(S_REPORT = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("REPORT"))); - PROTECT(S_type = Rf_findVarInFrame( + PROTECT(S_type = NIM_FINDVARINFRAME( PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("type"))); - PROTECT(S_lmm = Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + PROTECT(S_lmm = NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("lmm"))); PROTECT(S_factr = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("factr"))); PROTECT(S_pgtol = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("pgtol"))); - PROTECT(S_temp = Rf_findVarInFrame( + PROTECT(S_temp = NIM_FINDVARINFRAME( PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("temp"))); - PROTECT(S_tmax = Rf_findVarInFrame( + PROTECT(S_tmax = NIM_FINDVARINFRAME( PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("tmax"))); trace = SEXP_2_int(S_trace); fnscale = SEXP_2_double(S_fnscale); @@ -527,13 +527,13 @@ void NIMBLE_ADCLASS::copyFromSEXP(SEXP S_nimList_) { PROTECT(S__dot_xData = Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(S__dot_xData, 0, PROTECT(Rf_mkChar(".xData"))); PROTECT(S_value = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("value"))); PROTECT(S_jacobian = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("jacobian"))); PROTECT(S_hessian = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("hessian"))); SEXP_2_NimArr<1>(S_value, value); SEXP_2_NimArr<2>(S_jacobian, jacobian); @@ -649,12 +649,12 @@ void waicNimbleList::copyFromSEXP(SEXP S_nimList_) { R_PreserveObject(RObjectPointer = S_nimList_); PROTECT(S__dot_xData = Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(S__dot_xData, 0, PROTECT(Rf_mkChar(".xData"))); - PROTECT(S_WAIC = Rf_findVarInFrame( + PROTECT(S_WAIC = NIM_FINDVARINFRAME( PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("WAIC"))); - PROTECT(S_lppd = Rf_findVarInFrame( + PROTECT(S_lppd = NIM_FINDVARINFRAME( PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("lppd"))); PROTECT(S_pWAIC = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("pWAIC"))); WAIC = SEXP_2_double(S_WAIC); lppd = SEXP_2_double(S_lppd); @@ -775,39 +775,39 @@ void waicDetailsNimbleList::copyFromSEXP(SEXP S_nimList_) { PROTECT(S__dot_xData = Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(S__dot_xData, 0, PROTECT(Rf_mkChar(".xData"))); PROTECT(S_marginal = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("marginal"))); PROTECT(S_niterMarginal = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("niterMarginal"))); - PROTECT(S_thin = Rf_findVarInFrame( + PROTECT(S_thin = NIM_FINDVARINFRAME( PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("thin"))); PROTECT(S_online = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("online"))); PROTECT(S_nburnin_extra = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("nburnin_extra"))); PROTECT(S_WAIC_partialMC = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("WAIC_partialMC"))); PROTECT(S_lppd_partialMC = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("lppd_partialMC"))); PROTECT(S_pWAIC_partialMC = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("pWAIC_partialMC"))); PROTECT(S_niterMarginal_partialMC = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("niterMarginal_partialMC"))); PROTECT(S_WAIC_elements = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("WAIC_elements"))); PROTECT(S_lppd_elements = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("lppd_elements"))); PROTECT(S_pWAIC_elements = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("pWAIC_elements"))); marginal = SEXP_2_bool(S_marginal); niterMarginal = SEXP_2_double(S_niterMarginal); @@ -987,13 +987,13 @@ void AGHQuad_params::copyFromSEXP(SEXP S_nimList_) { PROTECT(S__dot_xData = Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(S__dot_xData, 0, PROTECT(Rf_mkChar(".xData"))); PROTECT(S_names = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("names"))); PROTECT(S_estimate = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("estimate"))); PROTECT(S_stdError = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("stdError"))); STRSEXP_2_vectorString(S_names, names); SEXP_2_NimArr<1>(S_estimate, estimate); @@ -1042,7 +1042,7 @@ void AGHQuad_params::copyFromRobject(SEXP Robject) { SETUP_S_xData; // There is no macro for a string vector, so do it by hand here std::string svarName("names"); - STRSEXP_2_vectorString(PROTECT(Rf_findVarInFrame(S_xData, + STRSEXP_2_vectorString(PROTECT(NIM_FINDVARINFRAME(S_xData, Rf_install("names"))), *static_cast< std::vector* >(getObjectPtr(svarName))); COPY_NUMERIC_VECTOR_FROM_R_OBJECT("estimate"); @@ -1114,16 +1114,16 @@ void AGHQuad_summary::copyFromSEXP(SEXP S_nimList_) { PROTECT(S__dot_xData = Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(S__dot_xData, 0, PROTECT(Rf_mkChar(".xData"))); PROTECT(S_params = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("params"))); PROTECT(S_randomEffects = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("randomEffects"))); PROTECT(S_vcov = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("vcov"))); PROTECT(S_originalScale = - Rf_findVarInFrame(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S__dot_xData)), Rf_install("originalScale"))); params = new AGHQuad_params; params->copyFromSEXP(S_params); diff --git a/packages/nimble/inst/include/nimble/RcppNimbleUtils.h b/packages/nimble/inst/include/nimble/RcppNimbleUtils.h index 9d4f704a9..31096b0c8 100644 --- a/packages/nimble/inst/include/nimble/RcppNimbleUtils.h +++ b/packages/nimble/inst/include/nimble/RcppNimbleUtils.h @@ -3,17 +3,17 @@ * Copyright (C) 2014-2017 Perry de Valpine, Christopher Paciorek, * Daniel Turek, Clifford Anderson-Bergman, Nick Michaud, Fritz Obermeyer, * Duncan Temple Lang. - * + * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. - * + * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. - * + * * You should have received a copy of the GNU General Public License * along with this program; if not, a copy is available at * https://www.R-project.org/Licenses/ @@ -25,7 +25,7 @@ #include "NimArr.h" #include "RcppUtils.h" -/* The following two macros are for use by copyFromRobject methods +/* The following two macros are for use by copyFromRobject methods in compiled nimbleFunctions. */ #define SETUP_S_xData \ SEXP S_string_xData; \ @@ -38,7 +38,7 @@ { \ std::string svarName(varName); \ SEXP_2_Nim_for_copyFromRobject(getObjectPtr(svarName),\ - PROTECT(Rf_findVarInFrame(S_xData, \ + PROTECT(NIM_FINDVARINFRAME(S_xData, \ Rf_install(varName)))); \ } @@ -47,7 +47,7 @@ std::string svarName(varName); \ std::string svarName_AD_(svarName + "_AD_"); \ populateValueMapAccessorsFromNodeNames_copyFromRobject(getObjectPtr(svarName), \ - PROTECT(Rf_findVarInFrame(S_xData, \ + PROTECT(NIM_FINDVARINFRAME(S_xData, \ Rf_install(varName))), \ derivsEnabled, \ getObjectPtr(svarName_AD_, false) \ @@ -58,7 +58,7 @@ { \ std::string svarName(varName); \ populateNodeFxnVectorNew_copyFromRobject(getObjectPtr(svarName),\ - PROTECT(Rf_findVarInFrame(S_xData, \ + PROTECT(NIM_FINDVARINFRAME(S_xData, \ Rf_install(varName)))); \ } @@ -66,7 +66,7 @@ { \ std::string svarName(varName); \ populateNodeFxnVectorNew_copyFromRobject_forDerivs(getObjectPtr(svarName),\ - PROTECT(Rf_findVarInFrame(S_xData, \ + PROTECT(NIM_FINDVARINFRAME(S_xData, \ Rf_install(varName)))); \ } @@ -74,7 +74,7 @@ { \ std::string svarName(varName); \ setNimbleFxnPtr_copyFromRobject(getObjectPtr(svarName),\ - PROTECT(Rf_findVarInFrame(S_xData, \ + PROTECT(NIM_FINDVARINFRAME(S_xData, \ Rf_install(varName)))); \ } @@ -82,7 +82,7 @@ { \ std::string svarName(varName); \ populate_SEXP_2_double_for_copyFromRobject(getObjectPtr(svarName),\ - PROTECT(Rf_findVarInFrame(S_xData, \ + PROTECT(NIM_FINDVARINFRAME(S_xData, \ Rf_install(varName)))); \ } @@ -90,7 +90,7 @@ { \ std::string svarName(varName); \ populate_SEXP_2_int_for_copyFromRobject(getObjectPtr(svarName),\ - PROTECT(Rf_findVarInFrame(S_xData, \ + PROTECT(NIM_FINDVARINFRAME(S_xData, \ Rf_install(varName)))); \ } @@ -98,7 +98,7 @@ { \ std::string svarName(varName); \ populate_SEXP_2_bool_for_copyFromRobject(getObjectPtr(svarName),\ - PROTECT(Rf_findVarInFrame(S_xData, \ + PROTECT(NIM_FINDVARINFRAME(S_xData, \ Rf_install(varName)))); \ } @@ -126,7 +126,7 @@ extern "C" { SEXP setDoublePtrFromSinglePtr(SEXP SdoublePtr, SEXP SsinglePtr); SEXP setSmartPtrFromSinglePtr(SEXP SdoublePtr, SEXP SsinglePtr); SEXP setSmartPtrFromDoublePtr(SEXP SdoublePtr, SEXP SsinglePtr); - + SEXP setVecNimArrRows(SEXP Sextptr, SEXP nRows, SEXP setSize2row1); SEXP addBlankModelValueRows(SEXP Sextptr, SEXP numAdded); SEXP getNRow(SEXP Sextptr); @@ -145,36 +145,36 @@ extern "C" { // Just for use in demos // To get a pointer to an element from sampleClass, use // getModelObjectPtr (from the NamedObjects.cpp file) - + SEXP Nim_2_SEXP(SEXP rPtr, SEXP NumRefers); // Returns SEXP object with correct data type and dimensions. NumRefers // should be an integer with the number of dereferencing required for rPtr // So if rPtr is a pointer to a NimArr, NumRefers = 1 // If rPtr is a pointer to a pointer to a NimArr, NumRefers = 2 // Currently only NumRefers = 1 and 2 are allowed, but easily updated // by extending "getNimTypePtr" function - + SEXP SEXP_2_Nim(SEXP rPtr, SEXP NumRefers, SEXP rValues, SEXP allowResize); // Copies values from rValues to NimArr. Same behavior // with NumRefers as above. Also, type checking is done // by R.internals functions INTEGER and REAL - - // SEXP Nim_2_Nim(SEXP rPtrFrom, SEXP numRefFrom, SEXP rPtrTo, SEXP numRefTo); + + // SEXP Nim_2_Nim(SEXP rPtrFrom, SEXP numRefFrom, SEXP rPtrTo, SEXP numRefTo); // Copies from one NimArr to another. Type checks // For now, both NimArr's must be either double or int. We can add other - // types or allow conversion by extending Nim_2_Nim and the cNim_2_Nim options - + // types or allow conversion by extending Nim_2_Nim and the cNim_2_Nim options + SEXP setPtrVectorOfPtrs(SEXP SaccessorPtr, SEXP ScontentsPtr, SEXP Ssize); SEXP setOnePtrVectorOfPtrs(SEXP SaccessorPtr, SEXP Si, SEXP ScontentsPtr); - + SEXP getEnvVar_Sindex(SEXP sString, SEXP sEnv, SEXP sIndex);// This is a utility for looking up a field of an environment // sString is a character vector with the field name we want // sEnv is the environment // sIndex is the index of the sString that contains the name - // we actually want to use. + // we actually want to use. // Look up by sString[sIndex] is done to allow for easy looping - //Important Note: sIndex = 1 looks up the first name (i.e. use R indexing, not C) + //Important Note: sIndex = 1 looks up the first name (i.e. use R indexing, not C) SEXP getEnvVar(SEXP sString, SEXP sEnv); // Same as above, but uses sIndex = 1 (i.e. sString is a single character string) - - SEXP setEnvVar_Sindex(SEXP sString, SEXP sEnv, SEXP sVal, SEXP sIndex); //Same as getEnvVar_Sindex, but this function sets rather than gets + + SEXP setEnvVar_Sindex(SEXP sString, SEXP sEnv, SEXP sVal, SEXP sIndex); //Same as getEnvVar_Sindex, but this function sets rather than gets SEXP setEnvVar(SEXP sString, SEXP sEnv, SEXP sVal); //Same as above but uses sIndex = 1 SEXP register_VecNimArr_Finalizer(SEXP Sp, SEXP Dll); @@ -204,10 +204,10 @@ NimArr<1, double> vectorDouble_2_NimArr(vector input); /* Apparently partial specialization of function templates is not allowed. - So these are witten for doubles, and when we get to integers and logicals we can + So these are witten for doubles, and when we get to integers and logicals we can use overlaoding or different names. */ -/* Try overloading these for all needed copy operations */ +/* Try overloading these for all needed copy operations */ void SEXP_2_NimArr(SEXP Sn, double &x); void SEXP_2_NimArr(SEXP Sn, int &x); void SEXP_2_NimArr(SEXP Sn, bool &x); diff --git a/packages/nimble/inst/include/nimble/Utils.h b/packages/nimble/inst/include/nimble/Utils.h index b908ef667..1d7bb5567 100644 --- a/packages/nimble/inst/include/nimble/Utils.h +++ b/packages/nimble/inst/include/nimble/Utils.h @@ -3,17 +3,17 @@ * Copyright (C) 2014-2017 Perry de Valpine, Christopher Paciorek, * Daniel Turek, Clifford Anderson-Bergman, Nick Michaud, Fritz Obermeyer, * Duncan Temple Lang. - * + * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. - * + * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. - * + * * You should have received a copy of the GNU General Public License * along with this program; if not, a copy is available at * https://www.R-project.org/Licenses/ @@ -30,6 +30,50 @@ #include #include #include + +#include +// chicken-and-egg: we need to check version, but the R_Version macro won't be there in old versions +#ifndef R_Version +#define R_Version(a,b,c) (((a) << 16) + ((b) << 8) + (c)) +#endif + + +#if R_VERSION < R_Version(4, 5, 0) +// #define NIM_FINDVARINFRAME(env, sym) \ +// Rf_findVarInFrame(env, sym) +static inline SEXP NIM_FINDVARINFRAME(SEXP Senv, SEXP Ssym) { + return Rf_findVarInFrame(Senv, Ssym); +} +static inline SEXP NIM_FINDVAR(SEXP Senv, SEXP Ssym) { + return Rf_findVar(Senv, Ssym); +} +// #define NIM_FINDVAR(env, sym) \ +// Rf_findVar(env, sym) +#else +// #define NIM_FINDVARINFRAME(env, sym) \ +// SEXP sym_ = TYPEOF(sym) == SYMSXP ? (sym) : Rf_install(CHAR(Rf_asChar(sym))); \ +// R_getVarEx(sym_, env, FALSE, R_UnboundValue) +// #define NIM_FINDVAR(env, sym) \ +// SEXP sym_ = TYPEOF(sym) == SYMSXP ? (sym) : Rf_install(CHAR(Rf_asChar(sym))); \ +// R_getVar(sym_, env, TRUE) +static inline SEXP NIM_FINDVARINFRAME(SEXP Senv, SEXP Ssym) { + if (TYPEOF(Senv) != ENVSXP) { + Rf_error("Senv was of type %s (a)", + Rf_type2char(TYPEOF(Senv))); + } + SEXP sym__ = TYPEOF(Ssym) == SYMSXP ? Ssym : Rf_install(CHAR(Rf_asChar(Ssym))); + return R_getVarEx(sym__, Senv, FALSE, R_UnboundValue); +} +static inline SEXP NIM_FINDVAR(SEXP Ssym, SEXP Senv) { + if (TYPEOF(Senv) != ENVSXP) { + Rf_error("Senv was of type %s (b)", + Rf_type2char(TYPEOF(Senv))); + } + SEXP sym__ = TYPEOF(Ssym) == SYMSXP ? Ssym : Rf_install(CHAR(Rf_asChar(Ssym))); + return R_getVar(sym__, Senv, TRUE); +} +#endif + using std::string; //using namespace std; @@ -76,7 +120,7 @@ class nimbleTimerClass_ { #my_array " has wrong size: expected %d, actual %d", n, \ my_array.dimSize(0)); -// code copied from nmath.h - useful utilities +// code copied from nmath.h - useful utilities # define MATHLIB_ERROR(fmt,x) Rf_error(fmt,x); # define MATHLIB_WARNING(fmt,x) Rf_warning(fmt,x) # define MATHLIB_WARNING2(fmt,x,x2) Rf_warning(fmt,x,x2) diff --git a/packages/nimble/inst/include/nimble/accessorClasses.h b/packages/nimble/inst/include/nimble/accessorClasses.h index e2660933f..2113b632c 100644 --- a/packages/nimble/inst/include/nimble/accessorClasses.h +++ b/packages/nimble/inst/include/nimble/accessorClasses.h @@ -3,24 +3,24 @@ * Copyright (C) 2014-2017 Perry de Valpine, Christopher Paciorek, * Daniel Turek, Clifford Anderson-Bergman, Nick Michaud, Fritz Obermeyer, * Duncan Temple Lang. - * + * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License * as published by the Free Software Foundation; either version 2 * of the License, or (at your option) any later version. - * + * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. - * + * * You should have received a copy of the GNU General Public License * along with this program; if not, a copy is available at * https://www.R-project.org/Licenses/ */ // NOTE: THESE FUNCTIONS WILL ASSUME MODELS ARE OF CLASS -// "ModelBase". THIS CLASS CAN BE FOUND IN "ModelClassUtils.h" +// "ModelBase". THIS CLASS CAN BE FOUND IN "ModelClassUtils.h" // This file contains new components for accessing and copying from groups of node Functions or subsets of variables in models or modelValues #ifndef __ACCESSORCLASSES @@ -29,7 +29,7 @@ #include #include "NimArrBase.h" -#include "NimArr.h" +#include "NimArr.h" #include "ModelClassUtils.h" #include "RcppNimbleUtils.h" #include @@ -38,7 +38,7 @@ using std::cout; -#include "nodeFun.h" +#include "nodeFun.h" //#define __NIMBLE_DEBUG_ACCESSORS @@ -62,137 +62,6 @@ class NodeVectorClassNew { }; #define _DERIVS_FULLTAPE -#ifdef _DERIVS_FULLTAPE - - -#else - -// This is a collection of instructions denoting a sort of "program". -/* class NodeVectorClassNew_derivs : public NodeVectorClassNew { */ -/* public: */ -/* vector > > parentIndicesList; */ -/* vector > > > topLevelWrtDeps; */ -/* NimArr<1, int> stochNodeIndicators; */ -/* NimArr<1, int> isAddedScalarNode; */ -/* NimArr<1, int> calcNodeIndicators; */ -/* vector > cppWrtArgIndices; */ -/* NimArr<1, int> wrtLineNums; */ -/* NimArr<1, int> nodeLengths; */ -/* vector > wrtToIndices; */ -/* vector > wrtFromIndices; */ -/* vector > wrtLineIndices; */ -/* vector > lineWrtArgSizeInfo; */ -/* vector > allNeededWRTCopyVars; */ -/* vector > thisAddedNodeJacobianList; */ -/* int totalOutWrtSize; */ -/* int totalWrtSize; */ -/* NimArr<1, int> cumulativeWrtLineNums; */ -/* NimArr<1, int> wrtLineSize; */ -/* const vector &getConstInstructions() const { */ -/* return instructions; } */ - -/* void populateDerivsInfo(SEXP SderivsInfo) { */ -/* SEXP S_pxData; */ -/* SEXP S_parentInds; */ -/* SEXP S_thisList; */ -/* SEXP S_thisListI; */ -/* SEXP S_stochNodeIndicators; */ -/* SEXP S_calcNodeIndicators; */ -/* SEXP S_cppWrtArgIndices; */ -/* SEXP S_wrtLineNums; */ -/* SEXP S_wrtToIndices; */ -/* SEXP S_wrtFromIndices; */ -/* SEXP S_wrtLineIndices; */ -/* SEXP S_lineWrtArgSizeInfo; */ -/* SEXP S_nodeLengths; */ -/* SEXP S_topLevelWrtDeps; */ -/* SEXP S_allNeededWRTCopyVars; */ -/* SEXP S_isAddedScalarNode; */ -/* SEXP S_thisAddedNodeJacobianList; */ -/* int numNodes; */ -/* int numNodesI; */ -/* PROTECT(S_pxData = Rf_allocVector(STRSXP, 1)); */ -/* SET_STRING_ELT(S_pxData, 0, Rf_mkChar(".xData")); */ -/* PROTECT(S_parentInds = Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, S_pxData)), */ -/* Rf_install("parentIndicesList"))); */ -/* numNodes = Rf_length(S_parentInds); */ -/* parentIndicesList.resize(numNodes); */ -/* for(int i = 0; i < numNodes; i++){ */ -/* PROTECT(S_thisList = VECTOR_ELT(S_parentInds, i)); */ -/* SEXP_list_2_NimArr_int_vec(S_thisList, parentIndicesList[i]); */ -/* } */ - -/* PROTECT(S_thisAddedNodeJacobianList = Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, S_pxData)), */ -/* Rf_install("thisAddedNodeJacobianList"))); */ -/* SEXP_list_2_NimArr_double_vec(S_thisAddedNodeJacobianList, thisAddedNodeJacobianList); */ - -/* PROTECT(S_topLevelWrtDeps = Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, S_pxData)), */ -/* Rf_install("topLevelWrtDeps"))); */ -/* topLevelWrtDeps.resize(numNodes); */ -/* int sumNodesI = 0; */ -/* for(int i = 0; i < numNodes; i++){ */ -/* PROTECT(S_thisList = VECTOR_ELT(S_topLevelWrtDeps, i)); */ -/* numNodesI = Rf_length(S_thisList); */ -/* sumNodesI += numNodesI; */ -/* topLevelWrtDeps[i].resize(numNodesI); */ -/* for(int j = 0; j < numNodesI; j++){ */ -/* PROTECT(S_thisListI = VECTOR_ELT(S_thisList, j)); */ -/* SEXP_list_2_NimArr_int_vec(S_thisListI, topLevelWrtDeps[i][j]); */ -/* } */ -/* } */ - -/* PROTECT(S_isAddedScalarNode = Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, S_pxData)), */ -/* Rf_install("isAddedScalarNode"))); */ -/* SEXP_2_NimArr(S_isAddedScalarNode, isAddedScalarNode); */ -/* PROTECT(S_stochNodeIndicators = Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, S_pxData)), */ -/* Rf_install("stochNodeIndicators"))); */ -/* SEXP_2_NimArr(S_stochNodeIndicators, stochNodeIndicators); */ -/* PROTECT(S_calcNodeIndicators = Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, S_pxData)), */ -/* Rf_install("calcNodeIndicators"))); */ -/* SEXP_2_NimArr(S_calcNodeIndicators, calcNodeIndicators); */ -/* PROTECT(S_wrtLineNums = Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, S_pxData)), */ -/* Rf_install("wrtLineNums"))); */ -/* SEXP_2_NimArr(S_wrtLineNums, wrtLineNums); */ -/* PROTECT(S_nodeLengths = Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, S_pxData)), */ -/* Rf_install("nodeLengths"))); */ -/* SEXP_2_NimArr(S_nodeLengths, nodeLengths); */ -/* PROTECT(S_cppWrtArgIndices = Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, S_pxData)), */ -/* Rf_install("cppWrtArgIndices"))); */ -/* SEXP_list_2_NimArr_double_vec(S_cppWrtArgIndices, cppWrtArgIndices); */ -/* PROTECT(S_wrtToIndices = Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, S_pxData)), */ -/* Rf_install("wrtToIndices"))); */ -/* SEXP_list_2_NimArr_int_vec(S_wrtToIndices, wrtToIndices); */ -/* PROTECT(S_wrtFromIndices = Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, S_pxData)), */ -/* Rf_install("wrtFromIndices"))); */ -/* SEXP_list_2_NimArr_int_vec(S_wrtFromIndices, wrtFromIndices); */ -/* PROTECT(S_wrtLineIndices = Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, S_pxData)), */ -/* Rf_install("wrtLineIndices"))); */ -/* SEXP_list_2_NimArr_int_vec(S_wrtLineIndices, wrtLineIndices); */ -/* PROTECT(S_lineWrtArgSizeInfo = Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, S_pxData)), */ -/* Rf_install("lineWrtArgSizeInfo"))); */ -/* SEXP_list_2_NimArr_int_vec(S_lineWrtArgSizeInfo, lineWrtArgSizeInfo); */ -/* PROTECT(S_allNeededWRTCopyVars = Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, S_pxData)), */ -/* Rf_install("allNeededWRTCopyVars"))); */ -/* SEXP_list_2_NimArr_int_vec(S_allNeededWRTCopyVars, allNeededWRTCopyVars); */ - -/* UNPROTECT(29 + 2*numNodes + sumNodesI); */ - -/* totalOutWrtSize = 0; */ -/* for(int i = 0; i < length(wrtToIndices); i++){ */ -/* totalOutWrtSize += wrtToIndices[i].dimSize(0); */ -/* } */ - -/* cumulativeWrtLineNums.initialize(-1, 1, numNodes); */ -/* wrtLineSize.setSize(wrtLineNums.dimSize(0)); */ -/* totalWrtSize = 0; */ -/* for(int i = 0; i < wrtLineNums.dimSize(0); i++){ */ -/* cumulativeWrtLineNums[wrtLineNums[i] - 1] = i; */ -/* wrtLineSize[i] = nodeLengths[wrtLineNums[i] -1]; */ -/* totalWrtSize += wrtLineSize[i]; */ -/* } */ -/* } */ -/* }; */ -#endif // ideas on efficiency @@ -203,14 +72,14 @@ class NodeVectorClassNew { /* ## could do this all on a new branch of newNodeFxn to be able to compare */ /* ## instead of the extra argument with default 0, use overloaded versions - might have helped - didn't compare carefully */ /* ## try making all calculate, simulate etc. const */ - + // for these, if there is use of iNodeFunction, it is generated directly from cppOutputGetParam //getParam_0D inline double getParam_0D_double(int paramID, const NodeInstruction &useInfo) { return(useInfo.nodeFunPtr->getParam_0D_double_block(paramID, useInfo.operand)); } -inline double getParam_0D_double(int paramID, const NodeInstruction &useInfo, int iNodeFunction) { +inline double getParam_0D_double(int paramID, const NodeInstruction &useInfo, int iNodeFunction) { /* iNodeFunction sometimes needs to be generated in a call even if not needed */ /* but we want to avoid compiled warnings about an unused argument */ /* the following line of code tries to make the compiler think iNodeFunction will be used */ @@ -245,7 +114,7 @@ NimArr<2, double> getParam_2D_double(const paramIDtype ¶mID, const NodeInstr inline double getBound_0D_double(int boundID, const NodeInstruction &useInfo) { return(useInfo.nodeFunPtr->getBound_0D_double_block(boundID, useInfo.operand)); } -inline double getBound_0D_double(int boundID, const NodeInstruction &useInfo, int iNodeFunction) { +inline double getBound_0D_double(int boundID, const NodeInstruction &useInfo, int iNodeFunction) { /* iNodeFunction sometimes needs to be generated in a call even if not needed */ /* but we want to avoid compiled warnings about an unused argument */ /* the following line of code tries to make the compiler think iNodeFunction will be used */ @@ -443,8 +312,8 @@ template toOffset = to->getOffset(); fromOffset = from->getOffset(); } - NimArrType **fromNimArr; - NimVecType *toVecNimArr; + NimArrType **fromNimArr; + NimVecType *toVecNimArr; void copy(const rowInfoClass &rowInfo) const { (*static_cast *>(toVecNimArr)->getBasePtr(rowInfo.rowTo)->getVptr())[toOffset] = (*static_cast *>(*fromNimArr)->getVptr())[fromOffset]; } @@ -462,7 +331,7 @@ template toOffset = to->getOffset(); fromOffset = from->getOffset(); } - NimArrType **fromNimArr; + NimArrType **fromNimArr; NimArrType **toNimArr; void copy(const rowInfoClass &rowInfo) const { (*static_cast *>(*toNimArr)->getVptr())[toOffset] = (*static_cast *>(*fromNimArr)->getVptr())[fromOffset]; @@ -481,7 +350,7 @@ template toOffset = to->getOffset(); fromOffset = from->getOffset(); } - NimVecType *fromVecNimArr; + NimVecType *fromVecNimArr; NimArrType **toNimArr; void copy(const rowInfoClass &rowInfo) const { (*static_cast *>(*toNimArr)->getVptr())[toOffset] = (*static_cast *>(fromVecNimArr)->getBasePtr(rowInfo.rowFrom)->getVptr())[fromOffset]; @@ -500,7 +369,7 @@ template toOffset = to->getOffset(); fromOffset = from->getOffset(); } - NimVecType *fromVecNimArr; + NimVecType *fromVecNimArr; NimVecType *toVecNimArr; void copy(const rowInfoClass &rowInfo) const { (*static_cast *>(toVecNimArr)->getBasePtr(rowInfo.rowTo)->getVptr())[toOffset] = (*static_cast *>(fromVecNimArr)->getBasePtr(rowInfo.rowFrom)->getVptr())[fromOffset]; @@ -560,7 +429,7 @@ class copierClassBuilderCase : public copierClassBuilderClass { fromNimArr = from->getNimArrPtr(); toNimArr = to->getNimArrPtr(); fromType = fromNimArr->getNimType(); - toType = toNimArr->getNimType(); + toType = toNimArr->getNimType(); switch(fromType) { case nimType::DOUBLE: switch(toType) { @@ -620,7 +489,7 @@ void nimCopy(const copierVectorClass &copiers); void nimCopy(copierVectorClass &copiers, int rowFrom); void nimCopy(copierVectorClass &copiers, int rowFrom, int rowTo); void nimCopy(copierVectorClass &copiers, int rowFrom, int rowTo, int unused); - + void dynamicMapCopyCheck(NimArrType *NAT, int offset, vector &strides, vector &sizes); void singletonCopyCheck(NimArrType *NAT, int offset); @@ -718,13 +587,13 @@ void populateValueMapAccessorsFromNodeNames_copyFromRobject(void *VvaluesAccesso void *VvaluesAccessor_AD); extern "C" { SEXP resizeManyModelVarAccessor(SEXP manyModelVarPtr, SEXP size); - SEXP resizeManyModelValuesAccessor(SEXP manyModelValuesPtr, SEXP size); + SEXP resizeManyModelValuesAccessor(SEXP manyModelValuesPtr, SEXP size); SEXP manualSetNRows(SEXP Sextptr, SEXP nRows); SEXP getVarAndIndices(SEXP Sstring); SEXP varAndIndices2mapParts(SEXP SvarAndIndicesExtPtr, SEXP Ssizes, SEXP SnDim); SEXP var2mapParts(SEXP Sinput, SEXP Ssizes, SEXP SnDim); - + SEXP populateNodeFxnVectorNew_byDeclID(SEXP SnodeFxnVec, SEXP S_GIDs, SEXP SnumberedObj, SEXP S_ROWINDS); SEXP populateNodeFxnVectorNew_byDeclID_forDerivs(SEXP SnodeFxnVec, SEXP S_GIDs, SEXP SnumberedObj, SEXP S_ROWINDS, SEXP SderivInfo); SEXP populateIndexedNodeInfoTable(SEXP StablePtr, SEXP StableContents); @@ -734,7 +603,7 @@ extern "C" { SEXP populateNumberedObject_withSingleModelValuesAccessors(SEXP mvPtr, SEXP varName, SEXP GIDs, SEXP curRow, SEXP SnumbObj); SEXP populateCopierVector(SEXP ScopierVector, SEXP SfromPtr, SEXP StoPtr, SEXP SintIsFromMV, SEXP SintIsToMV); - + SEXP populateNumberedObject_withSingleModelVariablesAccessors(SEXP modelPtr, SEXP varName, SEXP sGIDS, SEXP SvalidIndices, SEXP SnumbObj); SEXP populateModelVariablesAccessors_byGID(SEXP SmodelVariableAccessorVector, SEXP S_GIDs, SEXP SnumberedObj, SEXP S_LP_GIDs, SEXP S_LP_numberedObj); } @@ -823,7 +692,7 @@ class NodeVectorClassNew_derivs : public NodeVectorClassNew { // 11. Copy logProb to dependentVars[0] // 12. Call setModelOutputs to put AD modelOutputs into model // 13. Finish taping - // 14. Call tape->optimize() + // 14. Call tape->optimize() ManyVariablesMapAccessor model_wrt_accessor; ManyVariablesMapAccessor& get_model_wrt_accessor() {return model_wrt_accessor;} ManyVariablesMapAccessor model_AD_wrt_accessor; @@ -865,7 +734,7 @@ class NodeVectorClassNew_derivs : public NodeVectorClassNew { //std::vector< double > independentVars(length_independent); independentVars.resize(length_independent); - + NimArr<1, double > NimArrVars; NimArrVars.setSize(length_wrt); getValues(NimArrVars, model_wrt_accessor); @@ -930,25 +799,25 @@ class NodeVectorClassNew_derivs : public NodeVectorClassNew { PROTECT(SpxData = Rf_allocVector(STRSXP, 1)); SET_STRING_ELT(SpxData, 0, Rf_mkChar(".xData")); - + //Smodel <- SderivsInfo$model PROTECT(Smodel = - Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, SpxData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(SderivsInfo, SpxData)), Rf_install("model"))); //SCobjInt <- Smodel$CobjectInterface - PROTECT(SCobjInt = - Rf_findVarInFrame(PROTECT(GET_SLOT(Smodel, SpxData)), + PROTECT(SCobjInt = + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(Smodel, SpxData)), Rf_install("CobjectInterface"))); // SbasePtr <- SCobjInt$.basePtr - PROTECT(SbasePtr = - Rf_findVarInFrame(PROTECT(GET_SLOT(SCobjInt, SpxData)), + PROTECT(SbasePtr = + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(SCobjInt, SpxData)), Rf_install(".basePtr"))); // SADptrs <- SCobjInt$.ADptrs - PROTECT(SADptrs = - Rf_findVarInFrame(PROTECT(GET_SLOT(SCobjInt, SpxData)), + PROTECT(SADptrs = + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(SCobjInt, SpxData)), Rf_install(".ADptrs"))); // SbasePtrAD <- SADptrs[[".ADptrs"]] - PROTECT(SbasePtrAD = + PROTECT(SbasePtrAD = VECTOR_ELT(SADptrs, 0)); @@ -956,13 +825,13 @@ class NodeVectorClassNew_derivs : public NodeVectorClassNew { SEXP Swrt; SEXP SwrtNodeNames, SwrtSizesAndNdims; PROTECT(Swrt = - Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, SpxData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(SderivsInfo, SpxData)), Rf_install("wrtMapInfo"))); // SwrtNodeNames = Swrt[[1]] PROTECT(SwrtNodeNames = VECTOR_ELT(Swrt, 0)); // SwrtNizesAndNdims = Swrt[[2]] PROTECT(SwrtSizesAndNdims = VECTOR_ELT(Swrt, 1)); - + populateValueMapAccessorsFromNodeNames_internal(&model_wrt_accessor, SwrtNodeNames, SwrtSizesAndNdims, @@ -977,13 +846,13 @@ class NodeVectorClassNew_derivs : public NodeVectorClassNew { SEXP SextraInput; SEXP SextraInputNodeNames, SextraInputSizesAndNdims; PROTECT(SextraInput = - Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, SpxData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(SderivsInfo, SpxData)), Rf_install("extraInputMapInfo"))); // SextraInputNodeNames = SextraInput[[1]] PROTECT(SextraInputNodeNames = VECTOR_ELT(SextraInput, 0)); // SextraInputNizesAndNdims = SextraInput[[2]] PROTECT(SextraInputSizesAndNdims = VECTOR_ELT(SextraInput, 1)); - + populateValueMapAccessorsFromNodeNames_internal(&model_extraInput_accessor, SextraInputNodeNames, SextraInputSizesAndNdims, @@ -998,13 +867,13 @@ class NodeVectorClassNew_derivs : public NodeVectorClassNew { SEXP SmodelOutput; SEXP SmodelOutputNodeNames, SmodelOutputSizesAndNdims; PROTECT(SmodelOutput = - Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, SpxData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(SderivsInfo, SpxData)), Rf_install("modelOutputMapInfo"))); // SmodelOutputNodeNames = SmodelOutput[[1]] PROTECT(SmodelOutputNodeNames = VECTOR_ELT(SmodelOutput, 0)); // SmodelOutputNizesAndNdims = SmodelOutput[[2]] PROTECT(SmodelOutputSizesAndNdims = VECTOR_ELT(SmodelOutput, 1)); - + populateValueMapAccessorsFromNodeNames_internal(&model_modelOutput_accessor, SmodelOutputNodeNames, SmodelOutputSizesAndNdims, @@ -1019,13 +888,13 @@ class NodeVectorClassNew_derivs : public NodeVectorClassNew { SEXP Sconstant; SEXP SconstantNodeNames, SconstantSizesAndNdims; PROTECT(Sconstant = - Rf_findVarInFrame(PROTECT(GET_SLOT(SderivsInfo, SpxData)), + NIM_FINDVARINFRAME(PROTECT(GET_SLOT(SderivsInfo, SpxData)), Rf_install("constantMapInfo"))); // SconstantNodeNames = Sconstant[[1]] PROTECT(SconstantNodeNames = VECTOR_ELT(Sconstant, 0)); // SconstantNizesAndNdims = Sconstant[[2]] PROTECT(SconstantSizesAndNdims = VECTOR_ELT(Sconstant, 1)); - + populateValueMapAccessorsFromNodeNames_internal(&model_constant_accessor, SconstantNodeNames, SconstantSizesAndNdims, @@ -1036,7 +905,7 @@ class NodeVectorClassNew_derivs : public NodeVectorClassNew { SconstantSizesAndNdims, SbasePtrAD); - + UNPROTECT(26); } }; @@ -1057,5 +926,5 @@ double getLogProb(NodeVectorClassNew &nodes, int iNodeFunction); void simulate(NodeVectorClassNew &nodes); void simulate(NodeVectorClassNew &nodes, int iNodeFunction); - + #endif