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); }