SEXP rsqlite_query_send(SEXP handle, SEXP statement, SEXP bind_data) {
SQLiteConnection* con = rsqlite_connection_from_handle(handle);
sqlite3* db_connection = con->drvConnection;
sqlite3_stmt* db_statement = NULL;
int state, bind_count;
int rows = 0, cols = 0;
if (con->resultSet) {
if (con->resultSet->completed != 1)
warning("Closing result set with pending rows");
rsqlite_result_free(con);
}
rsqlite_result_alloc(con);
SQLiteResult* res = con->resultSet;
/* allocate and init a new result set */
res->completed = 0;
char* dyn_statement = RS_DBI_copyString(CHAR(asChar(statement)));
res->statement = dyn_statement;
res->drvResultSet = db_statement;
state = sqlite3_prepare_v2(db_connection, dyn_statement, -1,
&db_statement, NULL);
if (state != SQLITE_OK) {
exec_error(con, "error in statement");
}
if (db_statement == NULL) {
exec_error(con, "nothing to execute");
}
res->drvResultSet = (void*) db_statement;
bind_count = sqlite3_bind_parameter_count(db_statement);
if (bind_count > 0 && bind_data != R_NilValue) {
rows = GET_LENGTH(GET_ROWNAMES(bind_data));
cols = GET_LENGTH(bind_data);
}
res->isSelect = sqlite3_column_count(db_statement) > 0;
res->rowCount = 0; /* fake's cursor's row count */
res->rowsAffected = -1; /* no rows affected */
rsqlite_exception_set(con, state, "OK");
if (res->isSelect) {
if (bind_count > 0) {
select_prepared_query(db_statement, bind_data, bind_count, rows, con);
}
} else {
if (bind_count > 0) {
non_select_prepared_query(db_statement, bind_data, bind_count, rows, con);
} else {
state = sqlite3_step(db_statement);
if (state != SQLITE_DONE) {
exec_error(con, "rsqlite_query_send: could not execute1");
}
}
res->completed = 1;
res->rowsAffected = sqlite3_changes(db_connection);
}
return handle;
}
SEXP
R_wxSlider_new(SEXP r_parent, SEXP r_id, SEXP r_value, SEXP r_min, SEXP r_max, SEXP r_pos, SEXP r_size, SEXP r_style)
{
wxWindow *parent;
wxWindowID id;
wxSlider *ans;
SEXP r_ans;
int value, min, max;
long style;
wxPoint pos = wxDefaultPosition;
wxSize size = wxDefaultSize;
parent = (wxWindow *) R_get_wxWidget_Ref(r_parent, NULL);
id = INTEGER(r_id)[0];
value = INTEGER(r_value)[0];
min = INTEGER(r_min)[0];
max = INTEGER(r_max)[0];
style = (long) REAL(r_style)[0];
if(GET_LENGTH(r_pos)) pos = R_to_wxPoint(r_pos);
if(GET_LENGTH(r_size)) size = R_to_wxSize(r_size);
ans = new wxSlider(parent, id, value, min, max, pos, size, style);
r_ans = R_make_wxWidget_Ref(ans, "wxSlider");
return(r_ans);
}
void BigSum(BigMatrix *mat, SEXP colIndices, SEXP rowIndices, double *value) {
BMAccessorType m( *mat );
double *cols = NUMERIC_DATA(colIndices);
double *rows = NUMERIC_DATA(rowIndices);
index_type i=0;
index_type j=0;
index_type xj=0;
index_type numCols = GET_LENGTH(colIndices);
index_type numRows = GET_LENGTH(rowIndices);
CType *pColumn;
double s = 0;
for (i = 0; i < numCols; ++i) {
pColumn = m[static_cast<index_type>(cols[i])-1];
for (j = 0; j < numRows; ++j) {
xj = static_cast<index_type>(rows[j])-1;
s += (double)pColumn[xj];
}
}
value[0] = s;
return;
}
SEXP geoddist_alongpath(SEXP lat, SEXP lon, SEXP a, SEXP f)
{
if (!isReal(lat))
error("latitude must be a numeric (floating-point) vector");
if (!isReal(lon))
error("longitude must be a numeric (floating-point) vector");
SEXP res;
//int n = INTEGER(GET_LENGTH(lat));
//int nlon = INTEGER(GET_LENGTH(lon));
int n = GET_LENGTH(lat);
int nlon = GET_LENGTH(lon);
if (n != nlon)
error("lengths of latitude and longitude vectors must match, but they are %d and %d, respectively", n, nlon);
double *latp = REAL(lat);
double *lonp = REAL(lon);
double *ap = REAL(a);
double *fp = REAL(f);
PROTECT(res = allocVector(REALSXP, n));
double *resp = REAL(res);
double last = 0.0;
resp[0] = ISNA(lonp[0]) ? NA_REAL : 0.0;
for (int i = 0; i < n-1; i++) {
double faz, baz, s;
if (ISNA(latp[i]) || ISNA(lonp[i]) || ISNA(latp[i+1]) || ISNA(lonp[i+1])) {
resp[i+1] = NA_REAL;
last = 0.0; // reset
} else {
geoddist_core(latp+i, lonp+i, latp+i+1, lonp+i+1, ap, fp, &faz, &baz, &s);
resp[i+1] = last + s;
last = resp[i+1];
}
}
UNPROTECT(1);
return(res);
}
SEXP geoddist(SEXP lat1, SEXP lon1, SEXP lat2, SEXP lon2, SEXP a, SEXP f)
{
if (!isReal(lat1)) error("lat1 must be a numeric (floating-point) vector");
if (!isReal(lon1)) error("lon1 must be a numeric (floating-point) vector");
if (!isReal(lat2)) error("lat2 must be a numeric (floating-point) vector");
if (!isReal(lon2)) error("lon2 must be a numeric (floating-point) vector");
int n = GET_LENGTH(lat1);
if (n != GET_LENGTH(lon1))
error("lengths of lat1 and lon1 must match, but they are %d and %d respectively.", n, GET_LENGTH(lon1));
if (n != GET_LENGTH(lat2))
error("lengths of lat1 and lat2 must match, but they are %d and %d respectively.", n, GET_LENGTH(lat2));
if (n != GET_LENGTH(lon2))
error("lengths of lon1 and lon2 must match, but they are %d and %d respectively.", n, GET_LENGTH(lon2));
double *lat1p = REAL(lat1);
double *lon1p = REAL(lon1);
double *lat2p = REAL(lat2);
double *lon2p = REAL(lon2);
double *ap = REAL(a);
double *fp = REAL(f);
SEXP res;
PROTECT(res = allocVector(REALSXP, n));
double *resp = REAL(res);
for (int i = 0; i < n; i++) {
double faz, baz, s;
geoddist_core(lat1p+i, lon1p+i, lat2p+i, lon2p+i, ap, fp, &faz, &baz, &s);
resp[i] = s;
}
UNPROTECT(1);
return(res);
}
////////////////////////////////////////////////////////////
// C'tor
RootChainManager::RootChainManager(SEXP treeName, SEXP fileList, bool verbose, bool trace) :
m_chain(0),
m_verbose(verbose),
m_trace(trace)
{
// Check arguments
if ( ! IS_CHARACTER(treeName) ) error("treeName must be a string");
if ( GET_LENGTH(treeName) != 1) error("treeName must have length 1");
if ( ! IS_CHARACTER(fileList) ) error("fileList must be a list of strings");
// Get the tree name
std::string treeNameC = CHAR(STRING_ELT(treeName, 0));
if (m_verbose) REprintf("Will read tree %s\n", treeNameC.c_str());
// Get the list of files to chain
if (m_verbose)
REprintf("There are %d files to add to the chain\n", GET_LENGTH(fileList) );
// Form the chain from the file lists
m_chain = new TChain(treeNameC.c_str());
// Add files
for ( unsigned int i = 0; i < GET_LENGTH(fileList); ++i ) {
std::string fileNameC = CHAR(STRING_ELT(fileList, i) );
if (m_verbose) REprintf("Adding file %s to chain\n", fileNameC.c_str());
m_chain->Add( fileNameC.c_str(), 0 );
}
}
void DeepCopy(BigMatrix *pInMat, BigMatrix *pOutMat, SEXP rowInds, SEXP colInds)
{
in_BMAccessorType inMat( *pInMat );
out_BMAccessorType outMat( *pOutMat );
double *pRows = NUMERIC_DATA(rowInds);
double *pCols = NUMERIC_DATA(colInds);
index_type nRows = GET_LENGTH(rowInds);
index_type nCols = GET_LENGTH(colInds);
if (nRows != pOutMat->nrow())
Rf_error("length of row indices does not equal # of rows in new matrix");
if (nCols != pOutMat->ncol())
Rf_error("length of col indices does not equal # of cols in new matrix");
index_type i = 0;
index_type j = 0;
in_CType *pInColumn;
out_CType *pOutColumn;
for (i = 0; i < nCols; ++i) {
pInColumn = inMat[static_cast<index_type>(pCols[i])-1];
pOutColumn = outMat[i];
for (j = 0; j < nRows; ++j) {
pOutColumn[j] = static_cast<out_CType>(
pInColumn[static_cast<index_type>(pRows[j])-1]);
}
}
return;
}
USER_OBJECT_
RGnumeric_setCellComment(USER_OBJECT_ scell, USER_OBJECT_ stext, USER_OBJECT_ sauthor)
{
char *text = NULL, *author = NULL;
CellComment *comment;
Cell *cell;
USER_OBJECT_ ans = NULL_USER_OBJECT;
cell = RGnumeric_resolveCellReference(scell);
if(!cell)
PROBLEM "invalid cell reference object"
ERROR;
if(GET_LENGTH(stext))
text = CHAR_DEREF(STRING_ELT(stext, 0));
if(GET_LENGTH(sauthor))
author = CHAR_DEREF(STRING_ELT(sauthor, 0));
comment = cell_has_comment(cell);
if(!comment) {
Sheet *sheet;
sheet = RGnumeric_resolveSheetReference(VECTOR_ELT(scell, 1));
cell_set_comment(sheet, &(cell->pos), (const char*) author, (const char *)text);
} else {
if(text)
cell_comment_text_set(comment, text);
if(author)
cell_comment_author_set(comment, author);
}
return(ans);
}
static int php_is_r_primitive(SEXP val, SEXPTYPE *type) /* {{{ */
{
int is = 0;
if (GET_LENGTH(GET_DIM(val))) {
return 0;
}
if (GET_LENGTH(GET_CLASS(val))) {
return 0;
}
*type = TYPEOF(val);
switch (*type) {
case REALSXP:
case LGLSXP:
case STRSXP:
case INTSXP:
is = 1;
default:
break;
}
return is;
}
USER_OBJECT_
toRPointerWithFinalizer(gconstpointer val, const gchar *typeName, RPointerFinalizer finalizer)
{
USER_OBJECT_ ans;
USER_OBJECT_ r_finalizer = NULL_USER_OBJECT;
USER_OBJECT_ klass = NULL, rgtk_class;
int i = 0;
GType type = 0;
if(!val)
return(NULL_USER_OBJECT);
if (finalizer) {
PROTECT(r_finalizer = R_MakeExternalPtr(finalizer, NULL_USER_OBJECT, NULL_USER_OBJECT));
}
PROTECT(ans = R_MakeExternalPtr((gpointer)val, r_finalizer, NULL_USER_OBJECT));
if (finalizer) {
R_RegisterCFinalizer(ans, RGtk_finalizer);
}
if (typeName)
type = g_type_from_name(typeName);
if(type) {
if (G_TYPE_IS_INSTANTIATABLE(type) || G_TYPE_IS_INTERFACE(type))
type = G_TYPE_FROM_INSTANCE(val);
if (G_TYPE_IS_DERIVED(type)) {
setAttrib(ans, install("interfaces"), R_internal_getInterfaces(type));
PROTECT(klass = R_internal_getGTypeAncestors(type));
}
}
if (!klass && typeName) {
PROTECT(klass = asRString(typeName));
}
if (klass) { /* so much trouble just to add "RGtkObject" onto the end */
PROTECT(rgtk_class = NEW_CHARACTER(GET_LENGTH(klass)+1));
for (i = 0; i < GET_LENGTH(klass); i++)
SET_STRING_ELT(rgtk_class, i, STRING_ELT(klass, i));
} else {
PROTECT(rgtk_class = NEW_CHARACTER(1));
}
SET_STRING_ELT(rgtk_class, i, COPY_TO_USER_STRING("RGtkObject"));
SET_CLASS(ans, rgtk_class);
if (g_type_is_a(type, S_TYPE_G_OBJECT)) {
USER_OBJECT_ public_sym = install(".public");
setAttrib(ans, public_sym, findVar(public_sym, S_GOBJECT_GET_ENV(val)));
}
if (klass)
UNPROTECT(1);
if (finalizer)
UNPROTECT(1);
UNPROTECT(2);
return(ans);
}
SEXP Expect_matrix(SEXP S1, SEXP S, SEXP lambda, SEXP time, SEXP theta0, SEXP theta1, SEXP matdiag){
int nvar, npoints, nprotect=0;
nvar = GET_LENGTH(lambda);
npoints = GET_LENGTH(time);
PROTECT(time = coerceVector(time,REALSXP)); nprotect++;
PROTECT(theta0 = coerceVector(theta0,REALSXP)); nprotect++;
PROTECT(theta1 = coerceVector(theta1,REALSXP)); nprotect++;
// results
SEXP expectation = PROTECT(allocVector(REALSXP,nvar*npoints)); nprotect++;
if(!isComplex(lambda)){
// eigenvectors
PROTECT(S1 = coerceVector(S1,REALSXP)); nprotect++;
PROTECT(S = coerceVector(S,REALSXP)); nprotect++;
// matrix exponential
SEXP matexp = PROTECT(allocVector(REALSXP,nvar*nvar*npoints)); nprotect++;
// Compute the exponential matrix
multi_exp_matrix (&nvar, &npoints, REAL(time), REAL(lambda), REAL(S), REAL(S1), REAL(matexp));
// Compute the expectations
optimum (&nvar, &npoints, REAL(time), REAL(theta0), REAL(theta1), REAL(expectation), REAL(matexp), REAL(matdiag));
// Done.
}else{
double complex *matexp;
// complex eigenvalues & eigenvectors
PROTECT(S1 = coerceVector(S1,CPLXSXP)); nprotect++;
PROTECT(S = coerceVector(S,CPLXSXP)); nprotect++;
// alloc a complex vector in C rather than R structure...
matexp = Calloc(nvar*nvar*npoints,double complex);
// Compute the exponential matrix
multi_exp_matrix_complex (&nvar, &npoints, REAL(time), COMPLEX(lambda), COMPLEX(S), COMPLEX(S1), matexp);
// Compute the expectations
optimum_complex(&nvar, &npoints, REAL(time), REAL(theta0), REAL(theta1), REAL(expectation), matexp, REAL(matdiag));
// Done.
// Free the memory
Free(matexp);
}
UNPROTECT(nprotect);
return expectation;
}
// Weight matrix
SEXP Weight_matrix(SEXP S1, SEXP S, SEXP lambda, SEXP time, SEXP matdiag){
int nvar, npoints, vdim[2], nprotect = 0;
nvar = GET_LENGTH(lambda);
npoints = GET_LENGTH(time);
SEXP expectation;
vdim[0] = npoints*nvar; vdim[1] = nvar*2;
PROTECT(expectation = makearray(2,vdim)); nprotect++;
if(!isComplex(lambda)){
// eigenvectors
PROTECT(S1 = coerceVector(S1,REALSXP)); nprotect++;
PROTECT(S = coerceVector(S,REALSXP)); nprotect++;
// matrix exponential
SEXP matexp = PROTECT(allocVector(REALSXP,nvar*nvar*npoints)); nprotect++;
// Compute the exponential matrix
multi_exp_matrix (&nvar, &npoints, REAL(time), REAL(lambda), REAL(S), REAL(S1), REAL(matexp));
// Compute the expectations
build_w (&nvar, &npoints, REAL(time), REAL(expectation), REAL(matexp), REAL(matdiag));
// Done.
}else{
double complex *matexp;
// complex eigenvalues & eigenvectors
PROTECT(S1 = coerceVector(S1,CPLXSXP)); nprotect++;
PROTECT(S = coerceVector(S,CPLXSXP)); nprotect++;
// alloc a complex vector in C rather than R structure...
matexp = Calloc(nvar*nvar*npoints,double complex);
// Compute the exponential matrix
multi_exp_matrix_complex (&nvar, &npoints, REAL(time), COMPLEX(lambda), COMPLEX(S), COMPLEX(S1), matexp);
// Compute the expectations
build_w_complex (&nvar, &npoints, REAL(time), REAL(expectation), matexp, REAL(matdiag));
// Done.
// Free the memory
Free(matexp);
}
UNPROTECT(nprotect);
return expectation;
}
USER_OBJECT_
RS_PerlUndef(USER_OBJECT_ ids, USER_OBJECT_ types, USER_OBJECT_ interpreter)
{
int n, nt;
int i,j;
const char *id;
int count;
USER_OBJECT_ ans;
n = GET_LENGTH(ids);
nt = GET_LENGTH(types);
PROTECT(ans = NEW_LIST(n));
for(i = 0; i < n; i++) {
id = CHAR_DEREF(STRING_ELT(ids, i));
count = 0;
for(j = 0; i < nt; i++) {
if(LOGICAL_DATA(types)[i] == TRUE) {
count++;
switch(i) {
case PERL_SCALAR:
break;
case PERL_ARRAY:
break;
case PERL_HASH:
break;
case PERL_SUB:
break;
default:
break;
} /* switch() */
} /* end of if LOGICAL_DATA() */
} /* type loop */
if(count == 0) {
/* Was a composite identifier such as $x{'y'} so have to handle it specially. */
}
} /* ids loop */
UNPROTECT(1);
return(ans);
}
static xmlEntityPtr
do_getEntityHandler(void *userData, const xmlChar *name, const char * r_funName)
{
SEXP opArgs, r_ans;
xmlEntityPtr ans = NULL;
RS_XMLParserData *parserData = (RS_XMLParserData*) userData;
DECL_ENCODING_FROM_EVENT_PARSER(parserData)
PROTECT(opArgs = NEW_LIST(1)) ;
SET_VECTOR_ELT(opArgs, 0, ScalarString(ENC_COPY_TO_USER_STRING(name))); /*XXX should we encode this? Done now! */
r_ans = RS_XML(callUserFunction)(r_funName, NULL, (RS_XMLParserData *) userData, opArgs);
PROTECT(r_ans) ;
if(r_ans != NULL_USER_OBJECT && GET_LENGTH(r_ans) > 0) {
if(TYPEOF(r_ans) == STRSXP) {
const char *value;
value = CHAR_DEREF(STRING_ELT(r_ans, 0));
ans = (xmlEntityPtr) malloc(sizeof(xmlEntity));
memset(ans, 0, sizeof(xmlEntity));
ans->type = XML_ENTITY_DECL;
ans->etype = XML_INTERNAL_GENERAL_ENTITY;
ans->name = xmlStrdup(name);
ans->orig = NULL; // xmlStrdup(CHAR_TO_XMLCHAR(value));
ans->content = xmlStrdup(CHAR_TO_XMLCHAR(value));
ans->length = strlen(value);
#ifndef NO_CHECKED_ENTITY_FIELD
ans->checked = 1;
#endif
}
}
UNPROTECT(2);
return(ans);
}
/////////////////////////
// Return a logical vector if entries are in the event list
SEXP isInEventList(SEXP eventList, SEXP entryNums)
{
TEventList* el = checkForEventListWrapper(eventList);
SEXP l;
PROTECT(l = NEW_LOGICAL( GET_LENGTH(entryNums) ) );
for ( unsigned int i = 0; i < GET_LENGTH(entryNums); ++i ) {
LOGICAL(l)[i] = el->Contains( INTEGER(entryNums)[i] ) == 1;
}
UNPROTECT(1);
return l;
}
Rboolean
R_isInstanceOf(USER_OBJECT_ obj, const char *klass)
{
USER_OBJECT_ klasses;
int n, i;
SEXP e, r_ans;
Rboolean ans;
klasses = GET_CLASS(obj);
n = GET_LENGTH(klasses);
for(i = 0; i < n ; i++) {
if(strcmp(CHAR_DEREF(STRING_ELT(klasses, i)), klass) == 0)
return(TRUE);
}
PROTECT(e = allocVector(LANGSXP, 3));
SETCAR(e, Rf_install("is"));
SETCAR(CDR(e), obj);
SETCAR(CDR(CDR(e)), mkString(klass));
r_ans = Rf_eval(e, R_GlobalEnv);
ans = LOGICAL(r_ans)[0];
UNPROTECT(1);
return(ans);
}
guint
asCFlag(USER_OBJECT_ s_flag, GType ftype)
{
GFlagsClass* fclass = g_type_class_ref(ftype);
guint flags = 0;
if (IS_INTEGER(s_flag) || IS_NUMERIC(s_flag)) {
if (asCNumeric(s_flag) > fclass->mask) {
PROBLEM "The flags value %f is too high", asCNumeric(s_flag)
ERROR;
}
flags = asCNumeric(s_flag);
} else {
int i;
for (i = 0; i < GET_LENGTH(s_flag); i++) {
const gchar *fname = CHAR_DEREF(STRING_ELT(s_flag, i));
/*Rprintf("Searching for flag value %s\n", fname);*/
GFlagsValue *fvalue = g_flags_get_value_by_name(fclass, fname);
if (!fvalue)
fvalue = g_flags_get_value_by_nick(fclass, fname);
if (!fvalue && atoi(fname) <= fclass->mask) {
flags |= atoi(fname);
continue;
}
if (!fvalue) {
PROBLEM "Could not find flag by name %s", fname
ERROR;
}
/*Rprintf("Found: %d\n", fvalue->value);*/
flags |= fvalue->value;
}
}
return(flags);
}
// KErrBadDescriptor, if message length too small
// KErrUnderFlow, if message length too big.
// KErrCouldNotConnect, if receiver object is out of scope.
TInt DISICLTransceiver::ValidateISIMessage(
TDes8& aMessage
)
{
C_TRACE( ( _T( "DISICLTransceiver::ValidateISIMessage 0x%x>" ), &aMessage ) );
const TUint16 descLength( aMessage.Length() );
TInt msgOk( KErrNone );
msgOk = ( ISI_HEADER_OFFSET_MESSAGEID >= descLength ) ? KErrBadDescriptor : msgOk;
TRACE_ASSERT_INFO( msgOk == KErrNone, msgOk );
// Get ISI message length after known that the descriptor is big enough.
const TUint8* msgPtr( aMessage.Ptr() );
const TUint16 isiMsgLength( GET_LENGTH( msgPtr ) + PN_HEADER_SIZE );
// If the descriptor length is less than ISI message length.
msgOk = ( ( msgOk == KErrNone && isiMsgLength > descLength ) ? KErrUnderflow : msgOk );
TRACE_ASSERT_INFO( msgOk == KErrNone, msgOk );
// If the ISI message length is bigger that the largest supported.
msgOk = ( ( msgOk == KErrNone && isiMsgLength > KMaxISIMsgSize ) ? KErrUnderflow : msgOk );
TRACE_ASSERT_INFO( msgOk == KErrNone, msgOk );
// If the ISI message length with PN_HEADER_SIZE is less or equal than ISI_HEADER_OFFSET_MESSAGEID.
msgOk = ( ( msgOk == KErrNone && isiMsgLength <= ISI_HEADER_OFFSET_MESSAGEID ) ? KErrUnderflow : msgOk );
TRACE_ASSERT_INFO( msgOk == KErrNone, msgOk );
TRACE_ASSERT_INFO( msgOk == KErrNone, isiMsgLength );
TRACE_ASSERT_INFO( msgOk == KErrNone, descLength );
C_TRACE( ( _T( "DISICLTransceiver::ValidateISIMessage %d<" ), msgOk ) );
return msgOk;
}
#include "RS_XML.h"
#include <libxml/xpath.h>
#include "Utils.h"
static SEXP
convertNodeSetToR(xmlNodeSetPtr obj, SEXP fun, int encoding, SEXP manageMemory)
{
SEXP ans, expr = NULL, arg = NULL, ref;
int i;
if(!obj)
return(NULL_USER_OBJECT);
PROTECT(ans = NEW_LIST(obj->nodeNr));
if(GET_LENGTH(fun) && (TYPEOF(fun) == CLOSXP || TYPEOF(fun) == BUILTINSXP)) {
PROTECT(expr = allocVector(LANGSXP, 2));
SETCAR(expr, fun);
arg = CDR(expr);
} else if(TYPEOF(fun) == LANGSXP) {
expr = fun;
arg = CDR(expr);
}
for(i = 0; i < obj->nodeNr; i++) {
xmlNodePtr el;
el = obj->nodeTab[i];
if(el->type == XML_ATTRIBUTE_NODE) {
#if 0
PROTECT(ref = mkString((el->children && el->children->content) ? XMLCHAR_TO_CHAR(el->children->content) : ""));
SET_NAMES(ref, mkString(el->name));
#else
PROTECT(ref = ScalarString(mkCharCE((el->children && el->children->content) ? XMLCHAR_TO_CHAR(el->children->content) : "", encoding)));
SET_NAMES(ref, ScalarString(mkCharCE(el->name, encoding)));
#endif
SET_CLASS(ref, mkString("XMLAttributeValue"));
UNPROTECT(1);
} else if(el->type == XML_NAMESPACE_DECL)
ref = R_createXMLNsRef((xmlNsPtr) el);
else
ref = R_createXMLNodeRef(el, manageMemory);
if(expr) {
PROTECT(ref);
SETCAR(arg, ref);
PROTECT(ref = Rf_eval(expr, R_GlobalEnv)); /*XXX do we want to catch errors here? Maybe to release the namespaces. */
SET_VECTOR_ELT(ans, i, ref);
UNPROTECT(2);
} else
SET_VECTOR_ELT(ans, i, ref);
}
if(expr) {
if(TYPEOF(fun) == CLOSXP || TYPEOF(fun) == BUILTINSXP)
UNPROTECT(1);
} else
SET_CLASS(ans, mkString("XMLNodeSet"));
UNPROTECT(1);
return(ans);
}
SEXP
convertXPathObjectToR(xmlXPathObjectPtr obj, SEXP fun, int encoding, SEXP manageMemory)
{
SEXP ans = NULL_USER_OBJECT;
switch(obj->type) {
case XPATH_NODESET:
ans = convertNodeSetToR(obj->nodesetval, fun, encoding, manageMemory);
break;
case XPATH_BOOLEAN:
ans = ScalarLogical(obj->boolval);
break;
case XPATH_NUMBER:
ans = ScalarReal(obj->floatval);
if(xmlXPathIsInf(obj->floatval))
REAL(ans)[0] = xmlXPathIsInf(obj->floatval) < 0 ? R_NegInf : R_PosInf;
else if(xmlXPathIsNaN(obj->floatval))
REAL(ans)[0] = NA_REAL;
break;
case XPATH_STRING:
ans = mkString(XMLCHAR_TO_CHAR(obj->stringval)); //XXX encoding
break;
case XPATH_POINT:
case XPATH_RANGE:
case XPATH_LOCATIONSET:
case XPATH_USERS:
PROBLEM "currently unsupported xmlXPathObject type %d in convertXPathObjectToR. Please send mail to maintainer.", obj->type
WARN
default:
ans = R_NilValue;
}
return(ans);
}
#include <libxml/xpathInternals.h> /* For xmlXPathRegisterNs() */
xmlNsPtr *
R_namespaceArray(SEXP namespaces, xmlXPathContextPtr ctxt)
{
int i, n;
SEXP names = GET_NAMES(namespaces);
xmlNsPtr *els;
n = GET_LENGTH(namespaces);
els = xmlMallocAtomic(sizeof(xmlNsPtr) * n);
if(!els) {
PROBLEM "Failed to allocated space for namespaces"
ERROR;
}
for(i = 0; i < n; i++) {
/*XXX who owns these strings. */
const xmlChar *prefix, *href;
href = CHAR_TO_XMLCHAR(strdup(CHAR_DEREF(STRING_ELT(namespaces, i))));
prefix = names == NULL_USER_OBJECT ? CHAR_TO_XMLCHAR("") /* NULL */
: CHAR_TO_XMLCHAR(strdup(CHAR_DEREF(STRING_ELT(names, i))));
els[i] = xmlNewNs(NULL, href, prefix);
if(ctxt)
xmlXPathRegisterNs(ctxt, prefix, href);
}
return(els);
}
double
asCNumeric(USER_OBJECT_ s_num)
{
if (GET_LENGTH(s_num) == 0)
return(0);
return(NUMERIC_DATA(s_num)[0]);
}
guchar
asCRaw(USER_OBJECT_ s_raw)
{
if (GET_LENGTH(s_raw) == 0)
return(0);
return(RAW(s_raw)[0]);
}
int
asCInteger(USER_OBJECT_ s_int)
{
if (GET_LENGTH(s_int) == 0)
return(0);
return(INTEGER_DATA(s_int)[0]);
}
gboolean
asCLogical(USER_OBJECT_ s_log)
{
if (GET_LENGTH(s_log) == 0)
return(FALSE);
return(LOGICAL_DATA(s_log)[0]);
}
USER_OBJECT_
RS_GetPerlReferenceObjects(USER_OBJECT_ which)
{
USER_OBJECT_ ans, tmp;
int n, i = 0;
ForeignReferenceTable *table= &exportReferenceTable;
SV *el;
char *key;
I32 len;
dTHX;
if(table->entries == NULL) {
return(NULL_USER_OBJECT);
}
n = GET_LENGTH(which);
if(n == 0) {
n = hv_iterinit(table->entries);
PROTECT(ans = NEW_LIST(n));
while(i < n) {
el = hv_iternextsv(table->entries, &key, &len);
if(el == NULL)
break;
tmp = makeRSReferenceObject(key, computeRSPerlClassVector(el, NULL, TRUE), table);
SET_VECTOR_ELT(ans, i, tmp);
i++;
}
} else {
}
return(ans);
}
SEXP
R_setInitialModuleFunction(SEXP v)
{
SEXP prev;
if(R_initializeModuleFunction && GET_LENGTH(R_initializeModuleFunction))
R_ReleaseObject(R_initializeModuleFunction);
prev = R_initializeModuleFunction ? R_initializeModuleFunction : R_NilValue;
if(GET_LENGTH(v))
R_PreserveObject(v);
R_initializeModuleFunction = v;
return(prev);
}
/*
* Open a connection to an existing kdb+ process.
*
* If we just have a host and port we call khp from the kdb+ interface.
* If we have a host, port, "username:password" we call instead khpu.
*/
SEXP kx_r_open_connection(SEXP whence)
{
SEXP result;
int connection, port;
char *host;
int length = GET_LENGTH(whence);
if (length < 2)
error("Can't connect with so few parameters..");
port = INTEGER_POINTER (VECTOR_ELT(whence, 1))[0];
host = (char*) CHARACTER_VALUE(VECTOR_ELT(whence, 0));
if (2 == length)
connection = khp(host, port);
else {
char *user = (char*) CHARACTER_VALUE(VECTOR_ELT (whence, 2));
connection = khpu(host, port, user);
}
if (!connection)
error("Could not authenticate");
else if (connection < 0) {
#ifdef WIN32
char buf[256];
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL, GetLastError(),
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), buf, 256, NULL);
error(buf);
#else
error(strerror(errno));
#endif
}
PROTECT(result = NEW_INTEGER(1));
INTEGER_POINTER(result)[0] = connection;
UNPROTECT(1);
return result;
}
static void php_r_to_zval(SEXP value, zval *result) /* {{{ */
{
int value_len, i;
zval_dtor(result);
array_init(result);
value_len = GET_LENGTH(value);
if (value_len == 0) {
return;
}
for (i = 0; i < value_len; i++) {
switch (TYPEOF(value)) {
case INTSXP:
add_next_index_long(result, INTEGER_DATA(value)[i]);
break;
case REALSXP:
add_next_index_double(result, NUMERIC_DATA(value)[i]);
break;
case LGLSXP:
add_next_index_bool(result, LOGICAL_DATA(value)[i]);
break;
case STRSXP:
add_next_index_string(result, CHAR(STRING_ELT(value, 0)), 1);
break;
}
}
return;
}
USER_OBJECT_
RS_GGOBI(getDisplayOptions)(USER_OBJECT_ which)
{
USER_OBJECT_ ans, names;
gint NumOptions = 8;
DisplayOptions *options;
if (GET_LENGTH(which) == 0)
options = GGOBI(getDefaultDisplayOptions)();
else {
displayd *display = toDisplay(which);
g_return_val_if_fail(GGOBI_IS_DISPLAY(display), NULL_USER_OBJECT);
options = &(display->options);
}
g_return_val_if_fail(options != NULL, NULL_USER_OBJECT);
PROTECT(ans = NEW_LOGICAL(NumOptions));
PROTECT(names = NEW_CHARACTER(NumOptions));
LOGICAL_DATA(ans)[DOPT_POINTS] = options->points_show_p;
SET_STRING_ELT(names, DOPT_POINTS, COPY_TO_USER_STRING("Show points"));
LOGICAL_DATA(ans)[DOPT_AXES] = options->axes_show_p;
SET_STRING_ELT(names, DOPT_AXES, COPY_TO_USER_STRING("Show axes"));
LOGICAL_DATA(ans)[DOPT_AXESLAB] = options->axes_label_p;
SET_STRING_ELT(names, DOPT_AXESLAB,
COPY_TO_USER_STRING("Show tour axes"));
LOGICAL_DATA(ans)[DOPT_AXESVALS] = options->axes_values_p;
SET_STRING_ELT(names, DOPT_AXESVALS,
COPY_TO_USER_STRING("Show axes labels"));
LOGICAL_DATA(ans)[DOPT_EDGES_U] = options->edges_undirected_show_p;
SET_STRING_ELT(names, DOPT_EDGES_U, COPY_TO_USER_STRING("Undirected edges"));
LOGICAL_DATA(ans)[DOPT_EDGES_A] = options->edges_arrowheads_show_p;
SET_STRING_ELT(names, DOPT_EDGES_A, COPY_TO_USER_STRING("Arrowheads"));
LOGICAL_DATA(ans)[DOPT_EDGES_D] = options->edges_directed_show_p;
SET_STRING_ELT(names, DOPT_EDGES_D, COPY_TO_USER_STRING("Directed edges"));
LOGICAL_DATA(ans)[DOPT_WHISKERS] = options->whiskers_show_p;
SET_STRING_ELT(names, DOPT_WHISKERS,
COPY_TO_USER_STRING("Show whiskers"));
/* unused
LOGICAL_DATA(ans)[5] = options->missings_show_p;
SET_STRING_ELT(names, 5, COPY_TO_USER_STRING("Missing Values"));
LOGICAL_DATA(ans)[8] = options->axes_center_p;
SET_STRING_ELT(names, 8, COPY_TO_USER_STRING("Center axes"));
LOGICAL_DATA(ans)[9] = options->double_buffer_p;
SET_STRING_ELT(names, 9, COPY_TO_USER_STRING("Double buffer"));
LOGICAL_DATA(ans)[10] = options->link_p;
SET_STRING_ELT(names, 10, COPY_TO_USER_STRING("Link"));
*/
SET_NAMES(ans, names);
UNPROTECT(2);
return(ans);
}
USER_OBJECT_
R_libxmlTypeTable_names(USER_OBJECT_ table, USER_OBJECT_ s_elType)
{
xmlHashTablePtr t;
int n = 0, ctr = 0;
int getElements = GET_LENGTH(s_elType) > 0;
HashGatherer d = {0, NULL_USER_OBJECT, NULL_USER_OBJECT, NULL};
t = R_getExternalRef(table, NULL); /* R_libxmlTypeTableGetRef(table); */
n = xmlHashSize(t);
PROTECT(d.names = NEW_CHARACTER(n)); ctr++;
if(getElements) {
PROTECT(d.els = NEW_LIST(n)); ctr++;
d.elType = (char *) CHAR_DEREF(STRING_ELT(s_elType, 0));
}
xmlHashScan(t, getKeys, &d);
if(getElements)
SET_NAMES(d.els, d.names);
else
d.els = d.names;
UNPROTECT(ctr);
return(d.els);
}
SEXP
simplifyRList(SEXP l)
{
int i, n;
int type = TYPEOF(VECTOR_ELT(l, 0));
SEXP el;
n = GET_LENGTH(l);
for(i = 1; i < n ; i++) {
el = VECTOR_ELT(l, i);
if(type != TYPEOF(el))
return(l);
}
if(type != INTSXP && type != LGLSXP && type != STRSXP && type != REALSXP && type != CPLXSXP)
return(l);
{
SEXP e;
PROTECT(e = allocVector(LANGSXP, 2));
SETCAR(e, Rf_install("unlist"));
SETCAR(CDR(e), l);
l = Rf_eval(e, R_GlobalEnv);
UNPROTECT(1);
}
return(l);
}
