Skip to content

Commit 66ee73e

Browse files
perrydvperrydv
authored
Fix find var api calls expt1 (#1617)
* Update from Rf_findVar and Rf_findVarInFrame while maintaining backward compatibility if possible * Use R_do_slot; remove R_BracketSymbol; PROTECT in getSEXPdims; remove R_UnboundValue
1 parent 8babf69 commit 66ee73e

File tree

10 files changed

+192
-259
lines changed

10 files changed

+192
-259
lines changed

‎packages/nimble/R/cppDefs_nimbleFunction.R‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1204,7 +1204,7 @@ makeCopyFromRobjectDef <- function(cppCopyTypes,
12041204
quote = TRUE
12051205
)
12061206
} else {
1207-
unprotectCount <- 2 + length(copyCalls) ## 2 from SETUP_S_xData
1207+
unprotectCount <- length(copyCalls) ## 0 extra from SETUP_S_xData (1 PROTECT, covered by the +1 below)
12081208
allRcode <- do.call('call',
12091209
c(list('{'),
12101210
list(cppLiteral("SETUP_S_xData;")),

‎packages/nimble/R/cppDefs_nimbleList.R‎

Lines changed: 8 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -228,31 +228,24 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass',
228228

229229
conditionalClauseStart <- list(quote(cppLiteral('if (!RCopiedFlag){')))
230230
conditionalClauseEnd <- list(quote(cppLiteral('}')))
231-
environmentCPPName <- Rname2CppName('S_.xData') ## create SEXP for ref class environment
232-
listElementTable$addSymbol(cppSEXP(name = environmentCPPName))
233-
envLine <- substitute({PROTECT(ENVNAME <- Rf_allocVector(STRSXP, 1));
234-
SET_STRING_ELT(ENVNAME, 0, PROTECT(Rf_mkChar(".xData")));},
235-
list(ENVNAME = as.name(environmentCPPName)))
236-
237231
for(i in seq_along(elementNames)){
238232
Snames[i] <- Rname2CppName(paste0('S_', elementNames[i]))
239233
listElementTable$addSymbol(cppSEXP(name = Snames[i]))
240234
elementSymTab <- nimCompProc$symTab$getSymbolObject(elementNames[i])
241235
conditionalLineList <- c(conditionalLineList, generateConditionalLines(nimCompProc$symTab$getSymbolObject(elementNames[i]),
242236
listElementTable$getSymbolObject(Snames[i])))
243237

244-
copyToListLines[[i]] <- substitute(Rf_defineVar(Rf_install(ELEMENTNAME), VALUE, PROTECT(GET_SLOT(ROBJ, XDATA))),
238+
copyToListLines[[i]] <- substitute(Rf_defineVar(Rf_install(ELEMENTNAME), VALUE, PROTECT(R_do_slot(ROBJ, Rf_install(".xData")))),
245239
list(ELEMENTNAME = elementNames[i], VALUE = as.name(Snames[i]),
246-
ROBJ = as.name('RObjectPointer'),
247-
XDATA = as.name(environmentCPPName)))
240+
ROBJ = as.name('RObjectPointer')))
248241
}
249242

250243
setFlagLine <- list(substitute(RCopiedFlag <- true,
251244
list()))
252245
returnLine <- list(substitute(return(ROBJ),
253246
list(ROBJ = as.name('RObjectPointer'))))
254-
unprotectLine <- list(substitute(UNPROTECT(N), list(N = 2 * numElements + 1 + 1)))
255-
allCode <- embedListInRbracket(c(conditionalClauseStart, list(envLine), conditionalLineList,
247+
unprotectLine <- list(substitute(UNPROTECT(N), list(N = 2 * numElements)))
248+
allCode <- embedListInRbracket(c(conditionalClauseStart, conditionalLineList,
256249
copyToListLines, setFlagLine, unprotectLine,
257250
conditionalClauseEnd, returnLine))
258251
functionDefs[[paste0(name, "_copyTo")]] <<- cppFunctionDef(name = "copyToSEXP",
@@ -276,26 +269,19 @@ cppNimbleListClass <- setRefClass('cppNimbleListClass',
276269
listElementTable <- symbolTable()
277270
storeSexpLine <- list(quote(cppLiteral('R_PreserveObject(RObjectPointer = S_nimList_);')))
278271

279-
environmentCPPName <- Rname2CppName('S_.xData') ## create SEXP for ref class environment
280-
listElementTable$addSymbol(cppSEXP(name = environmentCPPName))
281-
envLine <- substitute({PROTECT(ENVNAME <- Rf_allocVector(STRSXP, 1));
282-
SET_STRING_ELT(ENVNAME, 0, PROTECT(Rf_mkChar(".xData")));},
283-
list(ENVNAME = as.name(environmentCPPName)))
284-
285272
for(i in seq_along(argNames)) {
286273
Snames[i] <- Rname2CppName(paste0('S_', argNames[i]))
287274
listElementTable$addSymbol(cppSEXP(name = Snames[i]))
288-
copyFromListLines[[i]] <- substitute(PROTECT(SVAR <- NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, XDATA)), Rf_install(ARGNAME))),
275+
copyFromListLines[[i]] <- substitute(PROTECT(SVAR <- NIM_FINDVARINFRAME(PROTECT(R_do_slot(S_nimList_, Rf_install(".xData"))), Rf_install(ARGNAME))),
289276
list(ARGNAME = argNames[i],
290-
SVAR = as.name(Snames[i]),
291-
XDATA = as.name(environmentCPPName)))
277+
SVAR = as.name(Snames[i])))
292278
copyLine <- buildCopyLineFromSEXP(listElementTable$getSymbolObject(Snames[i]),
293279
nimCompProc$symTab$getSymbolObject(argNames[i]))
294280
copyLines <- c(copyLines, copyLine)
295281
}
296282
numArgs <- length(argNames)
297-
unprotectLine <- substitute(UNPROTECT(N), list(N = 2 * numArgs + 1 + 1))
298-
allCode <- embedListInRbracket(c(storeSexpLine, envLine,
283+
unprotectLine <- substitute(UNPROTECT(N), list(N = 2 * numArgs))
284+
allCode <- embedListInRbracket(c(storeSexpLine,
299285
copyFromListLines, copyLines,
300286
list(unprotectLine)))
301287
functionDefs[[paste0(name, "_copyFrom")]] <<- cppFunctionDef(name = "copyFromSEXP",

‎packages/nimble/inst/CppCode/RcppNimbleUtils.cpp‎

Lines changed: 7 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -54,16 +54,13 @@ SEXP setDoublePtrFromSinglePtr(SEXP SdoublePtr, SEXP SsinglePtr) {
5454
void setNimbleFxnPtr_copyFromRobject(void *nf_to, SEXP S_NF_from) {
5555
void **doublePtr = static_cast<void **>(nf_to);
5656
SEXP Scnf, SsinglePtr;
57-
SEXP S_pxData;
58-
PROTECT(S_pxData = Rf_allocVector(STRSXP, 1));
59-
SET_STRING_ELT(S_pxData, 0, Rf_mkChar(".xData"));
6057
// environment(modelVar)$.CobjectInterface
61-
PROTECT(Scnf = NIM_FINDVARINFRAME(PROTECT(GET_SLOT(
58+
PROTECT(Scnf = NIM_FINDVARINFRAME(PROTECT(R_do_slot(
6259
S_NF_from,
63-
S_pxData)),
60+
Rf_install(".xData"))),
6461
Rf_install(".CobjectInterface"))
6562
);
66-
int unprotectCount = 3;
63+
int unprotectCount = 2;
6764
if(Rf_isNewList(Scnf)) {
6865
// multi-interface
6966
//Cnf[[1]]$basePtrList[[ Cnf[[2]] ]]
@@ -72,10 +69,10 @@ void setNimbleFxnPtr_copyFromRobject(void *nf_to, SEXP S_NF_from) {
7269
int index = (Rf_isInteger(Sindex) ? INTEGER(Sindex)[0] : REAL(Sindex)[0]);
7370
index--; // From 1-based to 0-based indexing
7471
PROTECT(SsinglePtr = VECTOR_ELT(
75-
NIM_FINDVARINFRAME(PROTECT(GET_SLOT(
72+
NIM_FINDVARINFRAME(PROTECT(R_do_slot(
7673
VECTOR_ELT(Scnf,
7774
0),
78-
S_pxData)),
75+
Rf_install(".xData"))),
7976
Rf_install("basePtrList")),
8077
index
8178
)
@@ -85,9 +82,9 @@ void setNimbleFxnPtr_copyFromRobject(void *nf_to, SEXP S_NF_from) {
8582
// printf("in non-list\n");
8683
// full interface
8784
// Cnf$.basePtr
88-
PROTECT(SsinglePtr = NIM_FINDVARINFRAME(PROTECT(GET_SLOT(
85+
PROTECT(SsinglePtr = NIM_FINDVARINFRAME(PROTECT(R_do_slot(
8986
Scnf,
90-
S_pxData)),
87+
Rf_install(".xData"))),
9188
Rf_install(".basePtr")));
9289
unprotectCount += 2;
9390
}

‎packages/nimble/inst/CppCode/RcppUtils.cpp‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -49,7 +49,10 @@ vector<int> getSEXPdims(SEXP Sx) {
4949
vector<int> ans;
5050
ans.resize(1); ans[0] = LENGTH(Sx); return(ans);
5151
}
52-
return(SEXP_2_vectorInt(Rf_getAttrib(Sx, R_DimSymbol), 0));
52+
SEXP dims = PROTECT(Rf_getAttrib(Sx, R_DimSymbol));
53+
vector<int> result = SEXP_2_vectorInt(dims, 0);
54+
UNPROTECT(1);
55+
return result;
5356
}
5457

5558
string STRSEXP_2_string(SEXP Ss, int i) {
@@ -858,7 +861,7 @@ SEXP varAndIndices_2_LANGSXP(const varAndIndicesClass &varAndInds) {
858861
Sans = PROTECT(Rf_install(varAndInds.varName.c_str()));
859862
} else {
860863
t = Sans = PROTECT(Rf_allocVector(LANGSXP, ansLen));
861-
SETCAR(t, R_BracketSymbol); t = CDR(t);
864+
SETCAR(t, Rf_install("[")); t = CDR(t);
862865
SETCAR(t, Rf_install(varAndInds.varName.c_str())); t = CDR(t);
863866
for(size_t i = 0; i < varAndInds.indices.size(); ++i) {
864867
if(varAndInds.indices[i].size() == 0) { // blank

‎packages/nimble/inst/CppCode/accessorClasses.cpp‎

Lines changed: 14 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -920,35 +920,32 @@ void populateNodeFxnVectorNew_internal_forDerivs(NodeVectorClassNew_derivs* nfv,
920920

921921
void populateNodeFxnVectorNew_copyFromRobject_forDerivs(void *nodeFxnVec_to, SEXP S_nodeFxnVec_from ) {
922922
SEXP S_indexingInfo;
923-
SEXP S_pxData;
924-
PROTECT(S_pxData = Rf_allocVector(STRSXP, 1));
925-
SET_STRING_ELT(S_pxData, 0, Rf_mkChar(".xData"));
926923
PROTECT(S_indexingInfo = VECTOR_ELT(S_nodeFxnVec_from, 1));
927924
SEXP S_declIDs;
928925
PROTECT(S_declIDs = VECTOR_ELT(S_indexingInfo, 0));
929926
SEXP S_rowIndices;
930927
PROTECT(S_rowIndices = VECTOR_ELT(S_indexingInfo, 1));
931928
SEXP S_numberedPtrs;
932-
PROTECT(S_numberedPtrs = PROTECT(NIM_FINDVARINFRAME(PROTECT(GET_SLOT(
933-
PROTECT(NIM_FINDVARINFRAME(PROTECT(GET_SLOT(
934-
PROTECT(NIM_FINDVARINFRAME(PROTECT(GET_SLOT(
929+
PROTECT(S_numberedPtrs = PROTECT(NIM_FINDVARINFRAME(PROTECT(R_do_slot(
930+
PROTECT(NIM_FINDVARINFRAME(PROTECT(R_do_slot(
931+
PROTECT(NIM_FINDVARINFRAME(PROTECT(R_do_slot(
935932
VECTOR_ELT(S_nodeFxnVec_from,
936933
2
937934
),
938-
S_pxData)),
935+
Rf_install(".xData"))),
939936
Rf_install("CobjectInterface")
940937
)),
941-
S_pxData)),
938+
Rf_install(".xData"))),
942939
Rf_install(".nodeFxnPointers_byDeclID"))),
943-
S_pxData)),
940+
Rf_install(".xData"))),
944941
Rf_install(".ptr")
945942
))
946943
);
947944
SEXP SderivInfo;
948945
PROTECT(SderivInfo = VECTOR_ELT(S_nodeFxnVec_from, 3));
949946
NodeVectorClassNew_derivs* nfv_derivs = static_cast<NodeVectorClassNew_derivs*>(nodeFxnVec_to);
950947
populateNodeFxnVectorNew_internal_forDerivs(nfv_derivs, S_declIDs, S_numberedPtrs, S_rowIndices, SderivInfo);
951-
UNPROTECT(12);
948+
UNPROTECT(11);
952949
}
953950

954951
SEXP populateNodeFxnVectorNew_byDeclID_forDerivs(SEXP SnodeFxnVec, SEXP S_GIDs, SEXP SnumberedObj, SEXP S_ROWINDS, SEXP SderivInfo){
@@ -979,9 +976,6 @@ void populateNodeFxnVectorNew_internal(NodeVectorClassNew* nfv, SEXP S_GIDs, SEX
979976

980977
void populateNodeFxnVectorNew_copyFromRobject(void *nodeFxnVec_to, SEXP S_nodeFxnVec_from ) {
981978
SEXP S_indexingInfo;
982-
SEXP S_pxData;
983-
S_pxData = PROTECT(Rf_allocVector(STRSXP, 1));
984-
SET_STRING_ELT(S_pxData, 0, Rf_mkChar(".xData"));
985979
S_indexingInfo = PROTECT(VECTOR_ELT(S_nodeFxnVec_from, 1));
986980
SEXP S_declIDs;
987981
S_declIDs = PROTECT(VECTOR_ELT(S_indexingInfo, 0));
@@ -990,24 +984,24 @@ void populateNodeFxnVectorNew_copyFromRobject(void *nodeFxnVec_to, SEXP S_nodeFx
990984
SEXP S_numberedPtrs;
991985
// equivalent to S_nodeFxnVec_from[["model"]]$CobjectInterface$.nodeFxnPointers_byDeclID$.ptr
992986
// implemented by S_nodeFxnVec_from[[2]]@.xData[["CobjectInterface"]]@.xData[[".nodeFxnPointers_byDeclID"]]@.xData[[".ptr"]]
993-
S_numberedPtrs = PROTECT(NIM_FINDVARINFRAME(PROTECT(GET_SLOT(
994-
PROTECT(NIM_FINDVARINFRAME(PROTECT(GET_SLOT(
995-
PROTECT(NIM_FINDVARINFRAME(PROTECT(GET_SLOT(
987+
S_numberedPtrs = PROTECT(NIM_FINDVARINFRAME(PROTECT(R_do_slot(
988+
PROTECT(NIM_FINDVARINFRAME(PROTECT(R_do_slot(
989+
PROTECT(NIM_FINDVARINFRAME(PROTECT(R_do_slot(
996990
VECTOR_ELT(S_nodeFxnVec_from,
997991
2
998992
),
999-
S_pxData)),
993+
Rf_install(".xData"))),
1000994
Rf_install("CobjectInterface")
1001995
)),
1002-
S_pxData)),
996+
Rf_install(".xData"))),
1003997
Rf_install(".nodeFxnPointers_byDeclID"))),
1004-
S_pxData)),
998+
Rf_install(".xData"))),
1005999
Rf_install(".ptr")
10061000
)
10071001
);
10081002
NodeVectorClassNew* nfv = static_cast<NodeVectorClassNew*>(nodeFxnVec_to);
10091003
populateNodeFxnVectorNew_internal(nfv, S_declIDs, S_numberedPtrs, S_rowIndices);
1010-
UNPROTECT(10);
1004+
UNPROTECT(9);
10111005
}
10121006

10131007
SEXP populateNodeFxnVectorNew_byDeclID(SEXP SnodeFxnVec, SEXP S_GIDs, SEXP SnumberedObj, SEXP S_ROWINDS){

‎packages/nimble/inst/CppCode/eigenUsingClasses.cpp‎

Lines changed: 14 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -71,17 +71,14 @@ void SEXP_2_NimArr<1>(SEXP Sn, NimArr<1, int> &ans) {
7171

7272
/*EIGEN_EIGEN class functions below */
7373
SEXP EIGEN_EIGENCLASS_R::copyToSEXP ( ) {
74-
SEXP S_pxData;
7574
SEXP S_values;
7675
SEXP S_vectors;
7776

78-
PROTECT(S_pxData = Rf_allocVector(STRSXP, 1));
79-
SET_STRING_ELT(S_pxData, 0, Rf_mkChar(".xData"));
8077
PROTECT(S_values = NimArr_2_SEXP<1>(values));
8178
PROTECT(S_vectors = NimArr_2_SEXP<2>(vectors));
82-
Rf_defineVar(Rf_install("values"), S_values, PROTECT(GET_SLOT(RObjectPointer, S_pxData)));
83-
Rf_defineVar(Rf_install("vectors"), S_vectors, PROTECT(GET_SLOT(RObjectPointer, S_pxData)));
84-
UNPROTECT(5);
79+
Rf_defineVar(Rf_install("values"), S_values, PROTECT(R_do_slot(RObjectPointer, Rf_install(".xData"))));
80+
Rf_defineVar(Rf_install("vectors"), S_vectors, PROTECT(R_do_slot(RObjectPointer, Rf_install(".xData"))));
81+
UNPROTECT(4);
8582

8683
return(RObjectPointer);
8784
}
@@ -97,36 +94,30 @@ void EIGEN_EIGENCLASS_R::createNewSEXP ( ) {
9794
}
9895

9996
void EIGEN_EIGENCLASS_R::copyFromSEXP ( SEXP S_nimList_ ) {
100-
SEXP S_pxData;
10197
SEXP S_values;
10298
SEXP S_vectors;
10399
RObjectPointer = S_nimList_;
104-
PROTECT(S_pxData = Rf_allocVector(STRSXP, 1));
105-
SET_STRING_ELT(S_pxData, 0, Rf_mkChar(".xData"));
106-
PROTECT(S_values = NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S_pxData)), Rf_install("values")));
107-
PROTECT(S_vectors = NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S_pxData)), Rf_install("vectors")));
100+
PROTECT(S_values = NIM_FINDVARINFRAME(PROTECT(R_do_slot(S_nimList_, Rf_install(".xData"))), Rf_install("values")));
101+
PROTECT(S_vectors = NIM_FINDVARINFRAME(PROTECT(R_do_slot(S_nimList_, Rf_install(".xData"))), Rf_install("vectors")));
108102
SEXP_2_NimArr<1>(S_values, values);
109103
SEXP_2_NimArr<2>(S_vectors, vectors);
110-
UNPROTECT(5);
104+
UNPROTECT(4);
111105
}
112106

113107

114108
/*EIGEN_SVD class functions below */
115109
SEXP EIGEN_SVDCLASS_R::copyToSEXP ( ) {
116-
SEXP S_pxData;
117110
SEXP S_d;
118111
SEXP S_u;
119112
SEXP S_v;
120113

121-
PROTECT(S_pxData = Rf_allocVector(STRSXP, 1));
122-
SET_STRING_ELT(S_pxData, 0, Rf_mkChar(".xData"));
123114
PROTECT(S_d = NimArr_2_SEXP<1>(d));
124115
PROTECT(S_u = NimArr_2_SEXP<2>(u));
125116
PROTECT(S_v = NimArr_2_SEXP<2>(v));
126-
Rf_defineVar(Rf_install("d"), S_d, PROTECT(GET_SLOT(RObjectPointer, S_pxData)));
127-
Rf_defineVar(Rf_install("u"), S_u, PROTECT(GET_SLOT(RObjectPointer, S_pxData)));
128-
Rf_defineVar(Rf_install("v"), S_v, PROTECT(GET_SLOT(RObjectPointer, S_pxData)));
129-
UNPROTECT(7);
117+
Rf_defineVar(Rf_install("d"), S_d, PROTECT(R_do_slot(RObjectPointer, Rf_install(".xData"))));
118+
Rf_defineVar(Rf_install("u"), S_u, PROTECT(R_do_slot(RObjectPointer, Rf_install(".xData"))));
119+
Rf_defineVar(Rf_install("v"), S_v, PROTECT(R_do_slot(RObjectPointer, Rf_install(".xData"))));
120+
UNPROTECT(6);
130121

131122
return(RObjectPointer);
132123
}
@@ -142,20 +133,17 @@ void EIGEN_EIGENCLASS_R::copyFromSEXP ( SEXP S_nimList_ ) {
142133
}
143134

144135
void EIGEN_SVDCLASS_R::copyFromSEXP ( SEXP S_nimList_ ) {
145-
SEXP S_pxData;
146136
SEXP S_d;
147137
SEXP S_v;
148138
SEXP S_u;
149139
RObjectPointer = S_nimList_;
150-
PROTECT(S_pxData = Rf_allocVector(STRSXP, 1));
151-
SET_STRING_ELT(S_pxData, 0, Rf_mkChar(".xData"));
152-
PROTECT(S_d = NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S_pxData)), Rf_install("d")));
153-
PROTECT(S_v = NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S_pxData)), Rf_install("v")));
154-
PROTECT(S_u = NIM_FINDVARINFRAME(PROTECT(GET_SLOT(S_nimList_, S_pxData)), Rf_install("u")));
140+
PROTECT(S_d = NIM_FINDVARINFRAME(PROTECT(R_do_slot(S_nimList_, Rf_install(".xData"))), Rf_install("d")));
141+
PROTECT(S_v = NIM_FINDVARINFRAME(PROTECT(R_do_slot(S_nimList_, Rf_install(".xData"))), Rf_install("v")));
142+
PROTECT(S_u = NIM_FINDVARINFRAME(PROTECT(R_do_slot(S_nimList_, Rf_install(".xData"))), Rf_install("u")));
155143
SEXP_2_NimArr<1>(S_d, d);
156144
SEXP_2_NimArr<2>(S_v, v);
157145
SEXP_2_NimArr<2>(S_u, u);
158-
UNPROTECT(7);
146+
UNPROTECT(6);
159147
}
160148

161149
SEXP C_nimEigen(SEXP S_x, SEXP S_symmetric, SEXP S_valuesOnly, SEXP returnList) {

0 commit comments

Comments
 (0)