max/iphreeqc
1
0
Fork 0
mirror of https://git.gfz-potsdam.de/naaice/iphreeqc.git synced 2025-12-16 16:44:49 +01:00
Code Issues Packages Projects Releases Wiki Activity

before changing PROTECT/UNPROTECT in getSelOut

Browse Source 
git-svn-id: svn://136.177.114.72/svn_GW/IPhreeqc/trunk@8548 1feff8c3-07ed-0310-ac33-dd36852eb9cd
This commit is contained in:
Scott R Charlton 2014-03-07 01:07:49 +00:00
parent 7c831fc893
commit ff17087266
1 changed files with 157 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

232
R/R.cpp
View File

@ -15,8 +15,10 @@ public:
} }
}; };
extern "C" { extern "C" {
SEXP SEXP
accumLine(SEXP line) accumLine(SEXP line)
{ {
@ -120,7 +122,6 @@ setSelectedOutputFileOn(SEXP value)
return(ans); return(ans);
} }
//{{
SEXP SEXP
setDumpStringOn(SEXP value) setDumpStringOn(SEXP value)
{ {
@ -181,7 +182,6 @@ setSelectedOutputStringOn(SEXP value)
return(ans); return(ans);
} }
//{{
SEXP SEXP
setDumpFileName(SEXP filename) setDumpFileName(SEXP filename)
{ {
@ -256,9 +256,7 @@ setSelectedOutputFileName(SEXP filename)
R::singleton().SetSelectedOutputFileName(name); R::singleton().SetSelectedOutputFileName(name);
return(ans); return(ans);
} }
//}}
////{{
SEXP SEXP
getDumpString(void) getDumpString(void)
{ {
@ -308,9 +306,7 @@ getWarningString(void)
UNPROTECT(1); UNPROTECT(1);
return ans; return ans;
} }
////}}
//{{
SEXP SEXP
getDumpFileName(void) getDumpFileName(void)
{ {
@ -360,7 +356,6 @@ getSelectedOutputFileName(void)
UNPROTECT(1); UNPROTECT(1);
return ans; return ans;
} }
//}}
SEXP SEXP
listComps(void) listComps(void)
@ -495,97 +490,143 @@ runString(SEXP input)
return(R_NilValue); return(R_NilValue);
} }
/* SEXP */
/* getColumnCount() */
/* { */
/* SEXP cols = R_NilValue; */
/* PROTECT(cols = allocVector(INTSXP, 1)); */
/* INTEGER(cols)[0] = GetSelectedOutputColumnCount(); */
/* UNPROTECT(1); */
/* return cols; */
/* } */
/* SEXP */
/* getRowCount() */
/* { */
/* SEXP rows = R_NilValue; */
/* PROTECT(rows = allocVector(INTSXP, 1)); */
/* INTEGER(rows)[0] = GetSelectedOutputRowCount(); */
/* UNPROTECT(1); */
/* return rows; */
/* } */
SEXP SEXP
getCol(int ncol) getCol(int ncol)
{ {
int r;
int cols;
int rows;
VAR vn;
VAR vv; VAR vv;
char buffer[80];
SEXP ans = R_NilValue; SEXP ans = R_NilValue;
cols = R::singleton().GetSelectedOutputColumnCount(); int cols = R::singleton().GetSelectedOutputColumnCount();
rows = R::singleton().GetSelectedOutputRowCount(); int rows = R::singleton().GetSelectedOutputRowCount();
if (cols == 0 || rows == 0) { if (cols == 0 || rows == 0) {
//error("getColumn: no data\n");
return ans; return ans;
} }
VarInit(&vn); // count each type
R::singleton().GetSelectedOutputValue(0, ncol, &vn); int nd, nl, ns;
nd = nl = ns = 0;
for (int r = 1; r < rows && ns == 0; ++r) {
VarInit(&vv); VarInit(&vv);
R::singleton().GetSelectedOutputValue(1, ncol, &vv); // may want to implement (int) GetSelectedOutputType(r,c)
R::singleton().GetSelectedOutputValue(r, ncol, &vv);
switch (vv.type) { switch (vv.type) {
case TT_LONG: case TT_DOUBLE: ++nd; break;
PROTECT(ans = allocVector(INTSXP, rows-1)); case TT_LONG: ++nl; break;
for (r = 1; r < rows; ++r) { case TT_STRING: ++ns; break;
VarInit(&vv);
R::singleton().GetSelectedOutputValue(r, ncol, &vv);
if (vv.lVal == -99) {
INTEGER(ans)[r-1] = NA_INTEGER;
}
else {
INTEGER(ans)[r-1] = vv.lVal;
} }
VarClear(&vv); VarClear(&vv);
} }
UNPROTECT(1);
break;
case TT_DOUBLE: if (ns) {
PROTECT(ans = allocVector(REALSXP, rows-1)); // all strings
for (r = 1; r < rows; ++r) {
VarInit(&vv);
R::singleton().GetSelectedOutputValue(r, ncol, &vv);
if (vv.dVal == -999.999 || vv.dVal == -99.) {
REAL(ans)[r-1] = NA_REAL;
}
else {
REAL(ans)[r-1] = vv.dVal;
}
VarClear(&vv);
}
UNPROTECT(1);
break;
case TT_STRING:
PROTECT(ans = allocVector(STRSXP, rows-1)); PROTECT(ans = allocVector(STRSXP, rows-1));
for (r = 1; r < rows; ++r) { for (int r = 1; r < rows; ++r) {
VarInit(&vv); VarInit(&vv);
R::singleton().GetSelectedOutputValue(r, ncol, &vv); R::singleton().GetSelectedOutputValue(r, ncol, &vv);
SET_STRING_ELT(ans, r-1, mkChar(vv.sVal)); switch (vv.type) {
VarClear(&vv);
}
UNPROTECT(1);
break;
case TT_EMPTY: case TT_EMPTY:
SET_STRING_ELT(ans, r-1, mkChar(""));
break; break;
case TT_ERROR: case TT_ERROR:
switch (vv.vresult) {
case VR_OK: SET_STRING_ELT(ans, r-1, mkChar("VR_OK")); break;
case VR_OUTOFMEMORY: SET_STRING_ELT(ans, r-1, mkChar("VR_OUTOFMEMORY")); break;
case VR_BADVARTYPE: SET_STRING_ELT(ans, r-1, mkChar("VR_BADVARTYPE")); break;
case VR_INVALIDARG: SET_STRING_ELT(ans, r-1, mkChar("VR_INVALIDARG")); break;
case VR_INVALIDROW: SET_STRING_ELT(ans, r-1, mkChar("VR_INVALIDROW")); break;
case VR_INVALIDCOL: SET_STRING_ELT(ans, r-1, mkChar("VR_INVALIDCOL")); break;
}
break; break;
case TT_LONG:
if (vv.lVal == -99) {
sprintf(buffer, "NA");
} else {
sprintf(buffer, "%ld", vv.lVal);
}
SET_STRING_ELT(ans, r-1, mkChar(buffer));
break;
case TT_DOUBLE:
if (vv.dVal == -999.999 || vv.dVal == -99.) {
sprintf(buffer, "NA");
} else {
sprintf(buffer, "%lg", vv.dVal);
}
SET_STRING_ELT(ans, r-1, mkChar(buffer));
break;
case TT_STRING:
SET_STRING_ELT(ans, r-1, mkChar(vv.sVal));
break;
}
VarClear(&vv);
}
UNPROTECT(1);
} // if (ns)
else if (nd) {
// all reals
PROTECT(ans = allocVector(REALSXP, rows-1));
for (int r = 1; r < rows; ++r) {
VarInit(&vv);
R::singleton().GetSelectedOutputValue(r, ncol, &vv);
switch (vv.type) {
case TT_EMPTY:
REAL(ans)[r-1] = NA_REAL;
break;
case TT_ERROR:
REAL(ans)[r-1] = NA_REAL;
break;
case TT_LONG:
if (vv.lVal == -99) {
REAL(ans)[r-1] = NA_REAL;
} else {
REAL(ans)[r-1] = (double)vv.lVal;
}
break;
case TT_DOUBLE:
if (vv.dVal == -999.999 || vv.dVal == -99.) {
REAL(ans)[r-1] = NA_REAL;
} else {
REAL(ans)[r-1] = (double)vv.dVal;
}
break;
}
VarClear(&vv);
}
UNPROTECT(1);
} // if (nd)
else if (nl) {
// all ints
PROTECT(ans = allocVector(INTSXP, rows-1));
for (int r = 1; r < rows; ++r) {
VarInit(&vv);
R::singleton().GetSelectedOutputValue(r, ncol, &vv);
switch (vv.type) {
case TT_EMPTY:
INTEGER(ans)[r-1] = NA_INTEGER;
break;
case TT_ERROR:
INTEGER(ans)[r-1] = NA_INTEGER;
break;
case TT_LONG:
if (vv.lVal == -99) {
INTEGER(ans)[r-1] = NA_INTEGER;
} else {
INTEGER(ans)[r-1] = vv.lVal;
}
break;
}
VarClear(&vv);
}
UNPROTECT(1);
} // if (nl)
else {
// all NA
PROTECT(ans = allocVector(INTSXP, rows-1));
for (int r = 1; r < rows; ++r) {
INTEGER(ans)[r-1] = NA_INTEGER;
} // for
UNPROTECT(1);
} }
return ans; return ans;
} }
@ -616,10 +657,8 @@ getSelOut(void)
SEXP attr; SEXP attr;
SEXP col; SEXP col;
#if defined(CONVERT_TO_DATA_FRAME)
SEXP klass; SEXP klass;
SEXP row_names; SEXP row_names;
#endif
list = R_NilValue; list = R_NilValue;
@ -629,7 +668,6 @@ getSelOut(void)
return list; return list;
} }
PROTECT(list = allocVector(VECSXP, cols)); PROTECT(list = allocVector(VECSXP, cols));
PROTECT(attr = allocVector(STRSXP, cols)); PROTECT(attr = allocVector(STRSXP, cols));
for (c = 0; c < cols; ++c) { for (c = 0; c < cols; ++c) {
@ -647,8 +685,6 @@ getSelOut(void)
setAttrib(list, R_NamesSymbol, attr); setAttrib(list, R_NamesSymbol, attr);
#if defined(CONVERT_TO_DATA_FRAME)
/* Turn the data "list" into a "data.frame" */ /* Turn the data "list" into a "data.frame" */
/* see model.c */ /* see model.c */
@ -660,12 +696,44 @@ getSelOut(void)
for (r = 0; r < rows-1; ++r) INTEGER(row_names)[r] = r+1; for (r = 0; r < rows-1; ++r) INTEGER(row_names)[r] = r+1;
setAttrib(list, R_RowNamesSymbol, row_names); setAttrib(list, R_RowNamesSymbol, row_names);
UNPROTECT(1); UNPROTECT(1);
#endif
UNPROTECT(2+cols); UNPROTECT(2+cols);
return list; return list;
} }
SEXP
getSelOuts(void)
{
SEXP list;
SEXP attr;
list = R_NilValue;
if (int n = R::singleton().GetSelectedOutputCount()) {
SEXP so;
char buffer[80];
PROTECT(list = allocVector(VECSXP, n));
PROTECT(attr = allocVector(STRSXP, n));
int save = R::singleton().GetCurrentSelectedOutputUserNumber();
for (int i = 0; i < n; ++i) {
int d = R::singleton().GetNthSelectedOutputUserNumber(i);
::sprintf(buffer, "n%d", d);
SET_STRING_ELT(attr, i, mkChar(buffer));
R::singleton().SetCurrentSelectedOutputUserNumber(d);
PROTECT(so = getSelOut());
SET_VECTOR_ELT(list, i, so);
UNPROTECT(1);
}
R::singleton().SetCurrentSelectedOutputUserNumber(save);
setAttrib(list, R_NamesSymbol, attr);
UNPROTECT(2);
}
return list;
}
SEXP SEXP
getErrStr() getErrStr()
{ {