SEXP rph_tree_subtree(SEXP treeStr, SEXP nodeStr) {
TreeNode *tr = rph_tree_new(treeStr);
TreeNode *n;
char *newTreeStr;
SEXP result;
n = tr_get_node(tr, CHARACTER_VALUE(nodeStr));
if (n == NULL) {
tr_name_ancestors(tr);
n = tr_get_node(tr, CHARACTER_VALUE(nodeStr));
if (n == NULL)
die("No node named %s", CHARACTER_VALUE(nodeStr));
}
tr_prune_supertree(&tr, n);
newTreeStr = tr_to_string(tr, 1);
PROTECT(result = NEW_CHARACTER(1));
SET_STRING_ELT(result, 0, mkChar(newTreeStr));
UNPROTECT(1);
return result;
}
SEXP
RGDAL_GetDriver(SEXP sxpDriverName) {
const char *pDriverName = asString(sxpDriverName);
installErrorHandler();
GDALDriver *pDriver = (GDALDriver *) GDALGetDriverByName(pDriverName);
uninstallErrorHandlerAndTriggerError();
if (pDriver == NULL)
error("No driver registered with name: %s\n", pDriverName);
SEXP sxpHandle = R_MakeExternalPtr((void *) pDriver,
mkChar("GDAL Driver"),
R_NilValue);
return(sxpHandle);
}
/* NB this is called by R.app even though it is in no public header, so
alter there if you alter this */
void PrintDefaults(void)
{
R_print.na_string = NA_STRING;
R_print.na_string_noquote = mkChar("<NA>");
R_print.na_width = (int) strlen(CHAR(R_print.na_string));
R_print.na_width_noquote = (int) strlen(CHAR(R_print.na_string_noquote));
R_print.quote = 1;
R_print.right = Rprt_adj_left;
R_print.digits = GetOptionDigits();
R_print.scipen = asInteger(GetOption1(install("scipen")));
if (R_print.scipen == NA_INTEGER) R_print.scipen = 0;
R_print.max = asInteger(GetOption1(install("max.print")));
if (R_print.max == NA_INTEGER || R_print.max < 0) R_print.max = 99999;
else if(R_print.max == INT_MAX) R_print.max--; // so we can add
R_print.gap = 1;
R_print.width = GetOptionWidth();
R_print.useSource = USESOURCE;
R_print.cutoff = GetOptionCutoff();
}
SEXP getEIC(SEXP mz, SEXP intensity, SEXP scanindex, SEXP mzrange, SEXP scanrange, SEXP lastscan) {
double *pmz, *pintensity,*p_vint, mzrangeFrom,mzrangeTo;
int i,*pscanindex, *p_scan,scanrangeFrom, scanrangeTo,ilastScan,nmz,ctScan,buflength;
SEXP list_names,reslist,vscan,vint;
pmz = REAL(mz);
nmz = GET_LENGTH(mz);
pintensity = REAL(intensity);
pscanindex = INTEGER(scanindex);
int firstScan = 1; // is always 1
ilastScan = INTEGER(lastscan)[0];
mzrangeFrom = REAL(mzrange)[0];
mzrangeTo = REAL(mzrange)[1];
scanrangeFrom = INTEGER(scanrange)[0];
scanrangeTo = INTEGER(scanrange)[1];
if ((scanrangeFrom < firstScan) || (scanrangeFrom > ilastScan) || (scanrangeTo < firstScan) || (scanrangeTo > ilastScan))
error("Error in scanrange \n");
char *names[2] = {"scan", "intensity"};
PROTECT(list_names = allocVector(STRSXP, 2));
for(i = 0; i < 2; i++)
SET_STRING_ELT(list_names, i, mkChar(names[i]));
buflength = scanrangeTo - scanrangeFrom +1;
PROTECT(reslist = allocVector(VECSXP, 2));
PROTECT(vscan = NEW_INTEGER(buflength));
p_scan = INTEGER_POINTER(vscan);
PROTECT(vint = NEW_NUMERIC(buflength));
p_vint = NUMERIC_POINTER(vint);
i=0;
for (ctScan=scanrangeFrom;ctScan<=scanrangeTo;ctScan++)
{
p_scan[i] = ctScan;
p_vint[i] = getScanEIC(ctScan,mzrangeFrom,mzrangeTo,pmz, pintensity, pscanindex,nmz,ilastScan);
i++;
}
SET_VECTOR_ELT(reslist, 0, vscan);// attaching integer vector scan to list
SET_VECTOR_ELT(reslist, 1, vint); // attaching double vector m/z to list
setAttrib(reslist, R_NamesSymbol, list_names); //and attaching the vector names
UNPROTECT(4);
return(reslist);
}
SEXP rph_tree_label_subtree(SEXP treeP, SEXP nodeP,
SEXP includeLeadingBranchP,
SEXP labelP) {
int i, numtree = LENGTH(treeP), include_leading_branch=0;
TreeNode *tr;
SEXP result;
char *node, *label;
label = copy_charstr(CHARACTER_VALUE(labelP));
node = copy_charstr(CHARACTER_VALUE(nodeP));
include_leading_branch = LOGICAL_VALUE(includeLeadingBranchP);
PROTECT(result = NEW_CHARACTER(numtree));
for (i=0; i < numtree; i++) {
tr = rph_tree_new(STRING_ELT(treeP, i));
tr_label_subtree(tr, node, include_leading_branch, label);
SET_STRING_ELT(result, i, mkChar(tr_to_string(tr, 1)));
}
UNPROTECT(1);
return result;
}
/*
* Adapter function to PQescapeStringConn()
* This function should properly escape the string argument
* appropriately depending on the encoding etc. that is specific to
* connection.
* Note the single quote is not attached in the return val.
*/
SEXP
RS_PostgreSQL_escape(SEXP conHandle, SEXP preescapestring)
{
S_EVALUATOR PGconn * my_connection;
RS_DBI_connection *con;
SEXP output;
size_t length;
const char *statement_cstr;
char *escapedstring;
con = RS_DBI_getConnection(conHandle);
my_connection = (PGconn *) con->drvConnection;
statement_cstr = CHR_EL(preescapestring, 0);
length = strlen(statement_cstr);
escapedstring = R_alloc(length * 2 + 1, 1);
PQescapeStringConn(my_connection, escapedstring, statement_cstr, length, NULL);
output = allocVector(STRSXP, 1);
SET_STRING_ELT(output, 0, mkChar(escapedstring));
return output;
}
static
SEXP MTB2SEXP(MTB mtb[], int len) /* Create a list from a vector of
MTB's and Free the MTB storage */
{
SEXP ans = PROTECT(allocVector(VECSXP,len)),
names = PROTECT(allocVector(STRSXP, len));
int i,j;
for (i = 0; i < len; i++) {
MTB thisRec = mtb[i];
SET_STRING_ELT(names, i, mkChar(thisRec->name));
switch(mtb[i]->dtype) {
case 0: /* numeric data */
SET_VECTOR_ELT(ans, i, allocVector(REALSXP, mtb[i]->len));
Memcpy(REAL(VECTOR_ELT(ans, i)), mtb[i]->dat.ndat, mtb[i]->len);
Free(mtb[i]->dat.ndat);
break;
default:
if (mtb[i]->type == 4) {
int nrow = mtb[i]->len / mtb[i]->dtype;
int ncol = mtb[i]->dtype;
SEXP aMatrix = PROTECT(allocMatrix(REALSXP,nrow,ncol));
for (j = 0; j < nrow*ncol; j++) {
REAL(aMatrix)[j] = mtb[i]->dat.ndat[j];
}
SET_VECTOR_ELT(ans, i, aMatrix);
Free(mtb[i]->dat.ndat);
UNPROTECT(1);
} else {
error(_("non-numeric data types are not yet implemented"));
}
}
Free(mtb[i]);
}
Free(mtb);
setAttrib(ans, R_NamesSymbol, names);
UNPROTECT(2);
return(ans);
}
static SEXP
cross(SEXP s, SEXP t)
{
SEXP a, la, ls, lt;
int i, j, k, n, nls, nlt, vs, vt;
n = length(s);
nls = nlevels(s);
nlt = nlevels(t);
PROTECT(a = allocVector(INTSXP, n));
for (i = 0; i < n; i++) {
vs = INTEGER(s)[i];
vt = INTEGER(t)[i];
if ((vs == NA_INTEGER) || (vt == NA_INTEGER))
INTEGER(a)[i] = NA_INTEGER;
else
INTEGER(a)[i] = vt + (vs - 1) * nlt;
}
ls = getAttrib(s, R_LevelsSymbol);
lt = getAttrib(t, R_LevelsSymbol);
if (!isNull(ls) && !isNull(lt)) {
PROTECT(la = allocVector(STRSXP, nls * nlt));
k = 0;
for (i = 0; i < nls; i++) {
vs = strlen(CHAR(STRING_ELT(ls, i)));
for (j = 0; j < nlt; j++) {
vt = strlen(CHAR(STRING_ELT(lt, j)));
SET_STRING_ELT(la, k, allocString(vs + vt + 1));
sprintf(CHAR(STRING_ELT(la, k)), "%s:%s",
CHAR(STRING_ELT(ls, i)), CHAR(STRING_ELT(lt, j)));
k++;
}
}
setAttrib(a, R_LevelsSymbol, la);
UNPROTECT(1);
}
PROTECT(la = allocVector(STRSXP, 1));
SET_STRING_ELT(la, 0, mkChar("factor"));
setAttrib(a, R_ClassSymbol, la);
UNPROTECT(2);
return(a);
}
SEXP chooseDir(SEXP def, SEXP caption)
{
const char *p;
char path[MAX_PATH];
if(!isString(def) || length(def) != 1 )
error(_("'default' must be a character string"));
p = translateChar(STRING_ELT(def, 0));
if(strlen(p) >= MAX_PATH) error(_("'default' is overlong"));
strcpy(path, R_ExpandFileName(p));
R_fixbackslash(path);
if(!isString(caption) || length(caption) != 1 )
error(_("'caption' must be a character string"));
p = askcdstring(translateChar(STRING_ELT(caption, 0)), path);
SEXP ans = PROTECT(allocVector(STRSXP, 1));
SET_STRING_ELT(ans, 0, p ? mkChar(p): NA_STRING);
UNPROTECT(1);
return ans;
}
SEXP aRTdb::ShowViews()
{
SEXP vectorViews;
TeViewMap& view_map = Database -> viewMap();
TeView* view;
TeViewMap::iterator it;
vectorViews = view_map.size() > 0 ? allocVector(STRSXP, view_map.size()) : R_NilValue;
int i = 0;
for (it = view_map.begin(); it != view_map.end(); ++it)
{
view = it -> second;
SET_STRING_ELT(vectorViews, i, mkChar(view -> name().c_str()));
i++;
}
return vectorViews;
}
/**
* Get workdir of repository.
*
* @param repo S4 class git_repository
* @return R_NilValue if bare repository, else character vector
* of length one with path.
*/
SEXP git2r_repository_workdir(SEXP repo)
{
SEXP result = R_NilValue;
git_repository *repository;
repository = git2r_repository_open(repo);
if (!repository)
git2r_error(git2r_err_invalid_repository, __func__, NULL);
if (!git_repository_is_bare(repository)) {
const char *wd = git_repository_workdir(repository);
PROTECT(result = allocVector(STRSXP, 1));
SET_STRING_ELT(result, 0, mkChar(wd));
UNPROTECT(1);
}
git_repository_free(repository);
return result;
}
SEXP aRTdb::List()
{
SEXP vectorLayers;
TeLayerMap& layer_map = Database -> layerMap();
TeLayer* layer;
TeLayerMap::iterator it;
vectorLayers = layer_map.size() > 0 ? allocVector(STRSXP, layer_map.size()) : R_NilValue;
int i = 0;
for (it = layer_map.begin(); it != layer_map.end(); ++it)
{
layer = it -> second;
SET_STRING_ELT(vectorLayers, i, mkChar(layer -> name().c_str()));
i++;
}
return vectorLayers;
}
SEXP rph_tree_summary_label(SEXP treeP) {
TreeNode *tr = rph_tree_new(treeP), *node;
List *nodes = tr_preorder(tr);
int i, nnodes = lst_size(nodes);
SEXP result;
for (i=0; i < nnodes; i++) {
node = (TreeNode*)lst_get_ptr(nodes, i);
if (node->label != NULL) break;
}
if (i == nnodes) return R_NilValue;
PROTECT(result = NEW_CHARACTER(nnodes));
for (i=0; i < nnodes; i++) {
node = (TreeNode*)lst_get_ptr(nodes, i);
if (node->label == NULL) SET_STRING_ELT(result, i, NA_STRING);
else SET_STRING_ELT(result, i, mkChar(node->label));
}
UNPROTECT(1);
return result;
}
/*
* Adapter function to PQescapeByteaConn()
* This function should properly escape the raw argument
* appropriately depending on connection.
* Note the single quote is not attached in the return val.
* The returned string could differ depending on the environment.
* Especially standard_conforming_strings parameter
* is possibly influencial.
* http://www.postgresql.org/docs/9.3/static/sql-syntax-lexical.html#SQL-SYNTAX-STRINGS
*/
SEXP
RS_PostgreSQL_escape_bytea(SEXP conHandle, SEXP raw_data)
{
S_EVALUATOR PGconn * my_connection;
RS_DBI_connection *con;
SEXP output;
size_t length;
char *escapedstring;
size_t escaped_length;
con = RS_DBI_getConnection(conHandle);
my_connection = (PGconn *) con->drvConnection;
length = LENGTH(raw_data);
escapedstring = (char *)PQescapeByteaConn(my_connection, RAW(raw_data), length, &escaped_length);
/* explicit cast to make clang silent for difference in signedness*/
PROTECT(output = allocVector(STRSXP, 1));
SET_STRING_ELT(output, 0, mkChar(escapedstring));
free(escapedstring);
UNPROTECT(1);
return output;
}
SEXP winMenuNames(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP menuNames;
int i, nmenus;
args = CDR(args);
if (CharacterMode != RGui)
errorcall(call, _("menu functions can only be used in the GUI"));
nmenus = numwinmenus();
PROTECT(menuNames = allocVector(STRSXP, nmenus));
for (i = 0; i < nmenus; i++) {
SET_STRING_ELT(menuNames, i, mkChar(getusermenuname(i)));
}
UNPROTECT(1);
return(menuNames);
}
SEXP RegGetStrValue(SEXP par) {
SEXP res=R_NilValue;
DWORD t,s=32767;
HKEY k;
char *key=CHAR(STRING_ELT(par, 0));
char *val=CHAR(STRING_ELT(par, 1));
RegStrBuf[32767]=*RegStrBuf=0;
/* printf("RegGetStrValue(\"%s\",\"%s\")\n",key,val); */
if (RegOpenKeyEx(HKEY_LOCAL_MACHINE,key,0,KEY_QUERY_VALUE,&k)!=ERROR_SUCCESS ||
RegQueryValueEx(k,val,0,&t,RegStrBuf,&s)!=ERROR_SUCCESS)
return res;
PROTECT(res = allocVector(STRSXP, 1));
SET_STRING_ELT(res, 0, mkChar(RegStrBuf));
UNPROTECT(1);
return res;
};
SEXP slist_to_vec(struct curl_slist *slist){
/* linked list of strings */
struct curl_slist *cursor = slist;
/* count slist */
int n = 0;
while (cursor) {
n++;
cursor = cursor->next;
}
SEXP out = PROTECT(allocVector(STRSXP, n));
cursor = slist;
for(int i = 0; i < n; i++){
SET_STRING_ELT(out, i, mkChar(cursor->data));
cursor = cursor->next;
}
UNPROTECT(1);
return out;
}
//----------------------------------------------------------------------------
SEXP pnlGetLag(SEXP net)
{
SEXP res;
int flag = 0;
int result;
PROTECT(net = AS_INTEGER(net));
int NetNum = INTEGER_VALUE(net);
try
{
result = pDBNs[NetNum]->GetLag();
}
catch(pnl::CException &E)
{
ErrorString = E.GetMessage();
flag = 1;
}
catch(...)
{
ErrorString = "Unrecognized exception during execution of GetLag function";
flag = 1;
}
if (flag == 0)
{
//there were no exceptions
PROTECT(res = NEW_INTEGER(1));
int * pres = INTEGER_POINTER(res);
pres[0] = result;
}
if (flag == 1)
{
//there were exceptions
PROTECT(res = allocVector(STRSXP, 1));
SET_STRING_ELT(res, 0, mkChar(ErrorString.c_str()));
}
UNPROTECT(2);
return (res);
}
SEXP menu_ttest3()
{
char cmd[256];
SEXP cmdSexp, cmdexpr, ans = R_NilValue;
int i;
ParseStatus status;
done = 0;
create_dialog();
setaction(bCancel, cancel2);
show(win);
for(;;) {
R_WaitEvent();
R_ProcessEvents();
if(done > 0) break;
}
if(done == 1) {
sprintf(cmd, "t.test(x=%s, y=%s, alternative=\"%s\",\n paired=%s, var.equal=%s, conf.level=%s)\n", v[0], v[1],
alts[getlistitem(alt)],
ischecked(paired) ? "TRUE" : "FALSE",
ischecked(varequal) ? "TRUE" : "FALSE",
GA_gettext(lvl));
}
hide(win);
delobj(bApply);
delobj(win);
if(done == 1) {
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar(cmd));
cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if (status != PARSE_OK) {
UNPROTECT(2);
error("invalid call %s", cmd);
}
/* Loop is needed here as EXPSEXP will be of length > 1 */
for(i = 0; i < length(cmdexpr); i++)
ans = eval(VECTOR_ELT(cmdexpr, i), R_GlobalEnv);
UNPROTECT(2);
}
return ans;
}
SEXP exprToFunction(int nVariables, const char **vaList, SEXP rExpr) {
PROTECT(rExpr);
SEXP charList, rChar, pl;
SEXP rFunc;
PROTECT(rFunc= allocSExp(CLOSXP));
SET_CLOENV(rFunc, R_GlobalEnv);
int i = 0, warn= 0, n= 0;
if(nVariables > 0) {
PROTECT(charList = allocVector(STRSXP, nVariables));
for(int i=0; i < nVariables; i++){ //TODO STRSXP fill
PROTECT(rChar= mkChar(vaList[i]));
SET_STRING_ELT(charList, i, rChar);
UNPROTECT(1);
}
PROTECT(charList= VectorToPairList(charList));
n= length(charList);
if(n > 0) {
PROTECT(pl = allocList(n));
if(n == 1) {
SET_TAG(pl, CreateTag(CAR(charList)));
SETCAR(pl, R_MissingArg);
}
else
{ SET_TAG(pl, CreateTag(CAR(charList)));
SETCAR(pl, R_MissingArg);
SEXP nextpl= CDR(pl);
SEXP nextChar= CDR(charList);
for (i= 1; i < n; i++, nextpl = CDR(nextpl), nextChar = CDR(nextChar)) {
SET_TAG(nextpl, CreateTag(CAR(nextChar)));
SETCAR(nextpl, R_MissingArg);
}
}
} }
SET_FORMALS(rFunc, pl);
SET_BODY(rFunc, rExpr);
//setAttrib(rFunc, R_SourceSymbol, eval(lang2(install("deparse"), rFunc), R_BaseEnv)); // TODO: Deparse not necessary
if(n > 0) {UNPROTECT(1);}
UNPROTECT(4);
return rFunc;
}
SEXP simplify_names(const SEXP x) {
if (TYPEOF(x)!=STRSXP)
error("simplify: argument type error");
int len = length(x);
int lenf=0, lenb=0;
if (len>1) {
char front[MAX_FLD], back[MAX_FLD];
strncpy(front, CHAR(STRING_ELT(x, 0)), MAX_FLD-1);
strncpy(back, front, MAX_FLD-1);
lenf = lenb = strlen(front);
char *end_back = back + lenb; /* pointer to terminating 0 */
char *start_back = back;
for (int i=1; i<len; i++) {
const char *xi = CHAR(STRING_ELT(x, i));
if (lenf) {
lenf = str_match(front, xi, 1);
front[lenf] = (char) 0;
}
if (lenb) {
lenb = str_match(start_back, xi, 0);
start_back = end_back - lenb ;
}
}
}
SEXP Result;
PROTECT(Result = allocVector(STRSXP, len));
char id[MAX_FLD];
for (int i=0; i<len; i++) {
const char *xi = CHAR(STRING_ELT(x, i));
int lenx = strlen(xi);
int ncp = lenx - lenf - lenb;
if (ncp>=MAX_FLD)
error("simplify: id length overflow");
strncpy(id, xi+lenf, ncp);
*(id+ncp) = (char) 0;
SET_STRING_ELT(Result, i, mkChar(id));
}
UNPROTECT(1);
return Result;
}
SEXP
RGDAL_GetDriverNames(void) {
SEXP sxpDriverList;
PROTECT(sxpDriverList = allocVector(STRSXP, GDALGetDriverCount()));
int i;
for (i = 0; i < GDALGetDriverCount(); ++i) {
GDALDriver *pDriver = GetGDALDriverManager()->GetDriver(i);
SET_STRING_ELT(sxpDriverList, i, mkChar(GDALGetDriverShortName( pDriver )));
}
UNPROTECT(1);
return(sxpDriverList);
}
SEXP aRTdb::ShowTables()
{
SEXP vectorTables;
TeAttrTableVector atts;
TeAttributeList attrList;
Database -> getAttrTables(atts, TeAttrExternal);
// TODO: it returns false when the database does not have any table
//if ( !Database -> getAttrTables(atts, TeAttrExternal) )
// error("Error loading tables from database!");
if( !atts.size() ) return R_NilValue;
vectorTables = allocVector(STRSXP, atts.size());
for (unsigned i = 0; i < atts.size(); i++)
SET_STRING_ELT(vectorTables, i, mkChar(atts[i].name().c_str()));
return vectorTables;
}
/*
Return a character vector describing each of the converter elements.
*/
SEXP attribute_hidden
do_getRtoCConverterDescriptions(SEXP call, SEXP op, SEXP args, SEXP env)
{
int n = 0, i;
R_toCConverter *tmp = StoCConverters;
SEXP ans;
checkArity(op, args);
n = Rf_getNumRtoCConverters();
PROTECT(ans = allocVector(STRSXP, n));
tmp = StoCConverters;
for(i = 0; i < n ; i++) {
if(tmp->description)
SET_STRING_ELT(ans, i, mkChar(tmp->description));
tmp = tmp->next;
}
UNPROTECT(1);
return(ans);
}
void muste_set_R_string(char *dest,char *sour) // RS 25.11.2012
{
SEXP tmp;
char *hakuapu,*teksti;
char tyhja[]="";
if (dest==NULL) return;
if (sour==NULL) teksti=tyhja;
else teksti=sour;
hakuapu=strchr(dest,'$')+1;
if (hakuapu==NULL) hakuapu=dest;
PROTECT(tmp = allocVector(STRSXP, 1));
SET_STRING_ELT(tmp, 0, mkChar(teksti));
defineVar(install(hakuapu),tmp,muste_environment);
UNPROTECT(1); // tmp
// snprintf(cmd,LLENGTH,"%s<-\"%s\"",dest,sour);
// muste_evalr(cmd);
}
SEXP PogsWrapper(SEXP A, SEXP f, SEXP g, SEXP params) {
// Setup output.
SEXP x, y, u, v, opt, status, ans, retnames;
SEXP Adim = GET_DIM(A);
size_t m = INTEGER(Adim)[0];
size_t n = INTEGER(Adim)[1];
unsigned int num_obj = length(f);
// Create output list.
PROTECT(ans = NEW_LIST(6));
PROTECT(retnames = NEW_CHARACTER(6));
SET_NAMES(ans, retnames);
// Allocate x.
PROTECT(x = allocMatrix(REALSXP, n, num_obj));
SET_STRING_ELT(retnames, 0, mkChar("x"));
SET_VECTOR_ELT(ans, 0, x);
// Allocate y.
PROTECT(y = allocMatrix(REALSXP, m, num_obj));
SET_STRING_ELT(retnames, 1, mkChar("y"));
SET_VECTOR_ELT(ans, 1, y);
// Allocate nu.
PROTECT(v = allocMatrix(REALSXP, m, num_obj));
SET_STRING_ELT(retnames, 2, mkChar("v"));
SET_VECTOR_ELT(ans, 2, v);
// Allocate mu.
PROTECT(u = allocMatrix(REALSXP, n, num_obj));
SET_STRING_ELT(retnames, 3, mkChar("u"));
SET_VECTOR_ELT(ans, 3, u);
// Allocate opt.
PROTECT(opt = NEW_NUMERIC(num_obj));
SET_STRING_ELT(retnames, 4, mkChar("optval"));
SET_VECTOR_ELT(ans, 4, opt);
// Allocate status.
PROTECT(status = NEW_INTEGER(num_obj));
SET_STRING_ELT(retnames, 5, mkChar("status"));
SET_VECTOR_ELT(ans, 5, status);
SolverWrap<double>(A, f, g, params, x, y, u, v, opt, status);
UNPROTECT(8);
return ans;
}
/* Parse a string as R code.
Return NULL on error */
SEXP
EmbeddedR_parse(char *string) {
if (! RINTERF_ISREADY()) {
return NULL;
}
RStatus ^= RINTERF_IDLE;
ParseStatus status;
SEXP cmdSexp, cmdExpr;
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar(string));
PROTECT(cmdExpr = R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if (status != PARSE_OK) {
UNPROTECT(2);
RStatus ^= RINTERF_IDLE;
return NULL;
}
R_PreserveObject(cmdExpr);
UNPROTECT(2);
RStatus ^= RINTERF_IDLE;
return cmdExpr;
}
SEXP do_gray(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP lev, ans;
double level;
int i, ilevel, nlev;
checkArity(op, args);
PROTECT(lev = coerceVector(CAR(args),REALSXP));
nlev = LENGTH(lev);
PROTECT(ans = allocVector(STRSXP, nlev));
for (i = 0; i < nlev; i++) {
level = REAL(lev)[i];
if (ISNAN(level) || level < 0 || level > 1)
errorcall(call, _("invalid gray level, must be in [0,1]."));
ilevel = 255 * level + 0.5;
SET_STRING_ELT(ans, i, mkChar(RGB2rgb(ilevel, ilevel, ilevel)));
}
UNPROTECT(2);
return ans;
}
SEXP data_frame_from_apop_data(apop_data *in){
if (!in) return R_NilValue;
int numeric_rows = !!(in->vector)
+ (in->matrix ? in->matrix->size2 : 0)
+ !!(in->weights);
int text_rows = in->textsize[1];
SEXP out, onerow;
PROTECT(out = allocVector(VECSXP, numeric_rows + text_rows));
int col_ct = 0;
int firstcol = in->vector ? -1 : 0;
int lastcol = in->matrix ? in->matrix->size2 : 0;
for (int i= firstcol; i < lastcol; i++){
int len = (i == -1) ? in->vector->size : in->matrix->size1;
apop_data *factorpage = find_factor(onerow, in, i);
if (factorpage){
SET_VECTOR_ELT(out, col_ct++, (onerow = allocVector(INTSXP, len)));
for (int j=0; j< len; j++) INTEGER(onerow)[j] = apop_data_get(in, j, i);
set_factor(onerow, factorpage);
} else {
SET_VECTOR_ELT(out, col_ct++, (onerow = allocVector(REALSXP, len)));
for (int j=0; j< len; j++) REAL(onerow)[j] = apop_data_get(in, j, i);
}
}
for (int i= 0; i < text_rows; i++){
int len = in->textsize[0];
SEXP onerow;
SET_VECTOR_ELT(out, col_ct++, (onerow = allocVector(STRSXP, len)));
for (int j=0; j< len; j++)
SET_STRING_ELT(onerow, j, mkChar(in->text[j][i])); //Do I need strdup?
}
if (in->weights){
int len = in->weights->size;
SET_VECTOR_ELT(out, col_ct++, (onerow = allocVector(REALSXP, len)));
for (int j=0; j< len; j++)
REAL(onerow)[j] = gsl_vector_get(in->weights, j);
}
handle_names(in, out);
UNPROTECT(1);
return out;
}
SEXP Muste_EvalRExpr(char *cmd)
{
ParseStatus status;
SEXP cmdsexp, cmdexpr, ans = R_NilValue;
int i;
char *apu,*apu2,*apu3;
muste_removedoublequotes(cmd);
// sprintf(komento,"if (inherits(try(.muste$ans<-%s,silent=TRUE), \"try-error\")) FALSE else TRUE",cmd);
apu=apu2=apu3=NULL;
apu=strchr(cmd,'('); apu2=strchr(cmd,' '); apu3=strchr(cmd,'<');
if ((apu2!=NULL && apu3!=NULL && (apu3-cmd)<(apu2-cmd)) || (apu2==NULL)) apu2=apu3;
if (strncmp(cmd,".muste.",7)==0 &&
(apu!=NULL &&
(apu2==NULL ||
(apu2!=NULL && (apu-cmd)<(apu2-cmd))))
)
{
sprintf(komento,"if (inherits(try(.muste$ans<-muste:::%s,silent=FALSE), \"try-error\")) FALSE else TRUE",cmd);
}
else
{
sprintf(komento,"if (inherits(try(.muste$ans<-%s,silent=FALSE), \"try-error\")) FALSE else TRUE",cmd);
}
//Rprintf("EvalR: %s\n",komento); // RS DEBUG
PROTECT(cmdsexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdsexp, 0, mkChar(komento));
cmdexpr = PROTECT(R_ParseVector(cmdsexp, -1, &status, R_NilValue));
if (status != PARSE_OK) {
UNPROTECT(2);
// RS REM error("Invalid call %s",cmd);
Rprintf("\nSyntax error!\n%s",cmd);
return (R_NilValue);
}
for(i=0; i<length(cmdexpr); i++) ans = eval(VECTOR_ELT(cmdexpr,i),R_GlobalEnv);
UNPROTECT(2);
if (INTEGER(ans)[0]==FALSE) return (R_NilValue);
ans = findVar(install(".muste$ans"),R_GlobalEnv);
return ans;
}