/** Get the row and column indices for the specified GnumericCellRef object. */ USER_OBJECT_ RGnumeric_getCellPosition(USER_OBJECT_ scell) { USER_OBJECT_ ans; Cell *cell; cell = RGnumeric_resolveCellReference(scell); ans = NEW_INTEGER(2); INTEGER_DATA(ans)[0] = cell->pos.row; INTEGER_DATA(ans)[1] = cell->pos.col; return(ans); }
USER_OBJECT_ RS_PerlReferenceCount() { USER_OBJECT_ ans; ForeignReferenceTable *table= &exportReferenceTable; dTHX; PROTECT(ans = NEW_INTEGER(2)); if(table->entries != NULL) { INTEGER_DATA(ans)[0] = hv_iterinit(table->entries); INTEGER_DATA(ans)[1] = table->numReferences; } UNPROTECT(1); return(ans); }
SEXP binit1RIntMatrix(SEXP x, SEXP col, SEXP breaks) { index_type numRows = static_cast<index_type>(nrows(x)); MatrixAccessor<int> mat(INTEGER_DATA(x), numRows); return CBinIt1<int, MatrixAccessor<int> >(mat, numRows, col, breaks); }
static USER_OBJECT_ convertRegistryValueToS(BYTE *val, DWORD size, DWORD valType) { USER_OBJECT_ ans = R_NilValue;; switch(valType) { case REG_DWORD: ans = NEW_INTEGER(1); INTEGER_DATA(ans)[0] = *((int *) val); break; case REG_SZ: case REG_EXPAND_SZ: PROTECT(ans = NEW_CHARACTER(1)); SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING((char *) val)); UNPROTECT(1); break; case REG_MULTI_SZ: fprintf(stderr, "Muti_sz entry\n"); break; case REG_BINARY: fprintf(stderr, "Binary entry\n"); break; default: PROBLEM "No such type %d", (int) valType ERROR; } return(ans); }
int asCInteger(USER_OBJECT_ s_int) { if (GET_LENGTH(s_int) == 0) return(0); return(INTEGER_DATA(s_int)[0]); }
USER_OBJECT_ RS_GGOBI(getDisplayVariables)(USER_OBJECT_ dpy) { USER_OBJECT_ buttons, vars, ans; static gchar *button_names[] = { "X", "Y", "Z" }; gint i; displayd *display = toDisplay(dpy); /* get the currently plotted variables */ gint *plotted_vars = g_new (gint, display->d->ncols); gint nplotted_vars = GGOBI_EXTENDED_DISPLAY_GET_CLASS (display)->plotted_vars_get( display, plotted_vars, display->d, display->ggobi); PROTECT(ans = NEW_LIST(2)); buttons = NEW_CHARACTER(nplotted_vars); SET_VECTOR_ELT(ans, 1, buttons); vars = NEW_INTEGER(nplotted_vars); SET_VECTOR_ELT(ans, 0, vars); for (i = 0; i < nplotted_vars; i++) { gint var = plotted_vars[i], j; for (j = 0; j < G_N_ELEMENTS(button_names); j++) { GtkWidget *wid = varpanel_widget_get_nth(j, var, display->d); if (gtk_toggle_button_get_active(GTK_TOGGLE_BUTTON(wid))) SET_STRING_ELT(buttons, i, mkChar(button_names[j])); } INTEGER_DATA(vars)[i] = var; } UNPROTECT(1); g_free(plotted_vars); return(ans); }
SEXP R_createVariant(SEXP type) { VARIANT var; VariantInit(&var); return(createRVariantObject(&var, INTEGER_DATA(type)[0])); }
USER_OBJECT_ asREnum(int value, GType etype) { USER_OBJECT_ ans, names; GEnumValue *evalue; PROTECT(ans = NEW_INTEGER(1)); INTEGER_DATA(ans)[0] = value; if (!(evalue = g_enum_get_value(g_type_class_ref(etype), value))) { PROBLEM "Unknown enum value %d", value ERROR; } PROTECT(names = NEW_CHARACTER(1)); SET_STRING_ELT(names, 0, COPY_TO_USER_STRING(evalue->value_name)); SET_NAMES(ans, names); PROTECT(names = NEW_CHARACTER(2)); SET_STRING_ELT(names, 0, COPY_TO_USER_STRING(g_type_name(etype))); SET_STRING_ELT(names, 1, COPY_TO_USER_STRING("enum")); SET_CLASS(ans, names); UNPROTECT(3); return(ans); }
USER_OBJECT_ createFactor(USER_OBJECT_ vals, vartabled *vt, GGobiData *d, int which) { USER_OBJECT_ labels, levels, ans, e; int i; PROTECT(levels = NEW_INTEGER(vt->nlevels)); PROTECT(labels = NEW_CHARACTER(vt->nlevels)); for(i = 0; i < vt->nlevels; i++) { INTEGER_DATA(levels)[i] = vt->level_values[i]; if (vt->level_names[i]) SET_STRING_ELT(labels, i, COPY_TO_USER_STRING(vt->level_names[i])); } PROTECT(e = allocVector(LANGSXP, 4)); SETCAR(e, Rf_install("factor")); SETCAR(CDR(e), vals); SETCAR(CDR(CDR(e)), levels); SETCAR(CDR(CDR(CDR(e))), labels); ans = eval(e, R_GlobalEnv); UNPROTECT(3); return(ans); }
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; }
SEXP GetRScalar(SV *val) { dTHX; SEXP ans = NULL_USER_OBJECT; if(SvIOKp(val)) { PROTECT(ans = NEW_INTEGER(1)); INTEGER_DATA(ans)[0] = SvIV(val); UNPROTECT(1); } else if(SvNOKp(val)) { PROTECT(ans = NEW_NUMERIC(1)); NUMERIC_DATA(ans)[0] = SvNV(val); UNPROTECT(1); } else if(SvPOK(val)) { PROTECT(ans = NEW_CHARACTER(1)); SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING(SvPV(val, PL_na))); UNPROTECT(1); } else if(SvROK(val)) { fprintf(stderr, "Not handling nested references in conversion from Perl to R at present. Suggestions for semantics welcome!\n");fflush(stderr); } else if(SvTYPE(val) == SVt_PVMG) { /*XXX get more info about the type of the magic object. struct magic *mg = SvMAGIC(val); */ PROTECT(ans = createPerlReference(val)); UNPROTECT(1); } else { fprintf(stderr, "Cannot deal currently with Perl types %d\n", SvTYPE(val));fflush(stderr); } return(ans); }
USER_OBJECT_ asRCairoPath(cairo_path_t *path) { static gchar *pathNames[] = { "status", "data", NULL }; cairo_path_data_t *data; gint i, j; USER_OBJECT_ s_path, s_data; PROTECT(s_path = NEW_LIST(2)); SET_VECTOR_ELT(s_path, 0, asREnum(path->status, CAIRO_TYPE_STATUS)); for (i = 0, j = 0; i < path->num_data; i++, j++) { i += path->data[i].header.length; } s_data = NEW_LIST(j); SET_VECTOR_ELT(s_path, 1, s_data); for (i = 0, j = 0; i < path->num_data; i+= data->header.length, j++) { USER_OBJECT_ s_data_el = NULL_USER_OBJECT; data = &path->data[i]; switch(data->header.type) { case CAIRO_PATH_MOVE_TO: case CAIRO_PATH_LINE_TO: PROTECT(s_data_el = NEW_INTEGER(2)); INTEGER_DATA(s_data_el)[0] = data[1].point.x; INTEGER_DATA(s_data_el)[1] = data[1].point.y; break; case CAIRO_PATH_CURVE_TO: PROTECT(s_data_el = NEW_INTEGER(6)); INTEGER_DATA(s_data_el)[0] = data[1].point.x; INTEGER_DATA(s_data_el)[1] = data[1].point.y; INTEGER_DATA(s_data_el)[2] = data[2].point.x; INTEGER_DATA(s_data_el)[3] = data[2].point.y; INTEGER_DATA(s_data_el)[4] = data[3].point.x; INTEGER_DATA(s_data_el)[5] = data[3].point.y; break; case CAIRO_PATH_CLOSE_PATH: PROTECT(s_data_el = NEW_INTEGER(0)); break; default: PROBLEM "Converting Cairo path: did not understand type %d", data->header.type ERROR; } setAttrib(s_data_el, install("type"), asRInteger(data->header.type)); UNPROTECT(1); SET_VECTOR_ELT(s_data, j, s_data_el); } SET_NAMES(s_path, asRStringArray(pathNames)); UNPROTECT(1); return(s_path); }
/** Get a reference to a Cell in the specified sheet and return it as an S object. This contains the pointer to the internal C value. It can be used in subsequent calls to identify the cell. Under no circumstances should this be saved and reused across R sessions. */ USER_OBJECT_ RGnumeric_getCellReference(USER_OBJECT_ sheetRef, USER_OBJECT_ row, USER_OBJECT_ col) { Sheet *sheet; Cell *cell; USER_OBJECT_ ans; sheet = RGnumeric_resolveSheetReference(sheetRef); cell = sheet_cell_get(sheet, INTEGER_DATA(col)[0] -1, INTEGER_DATA(row)[0] - 1); if(cell) { ans = RGnumeric_createCellReference(cell, sheet); } else { PROBLEM "No such cell @ %d, %d", INTEGER_DATA(col)[0] -1, INTEGER_DATA(row)[0] - 1 ERROR; } return(ans); }
USER_OBJECT_ asRInteger(int val) { USER_OBJECT_ ans; ans = NEW_INTEGER(1); INTEGER_DATA(ans)[0] = val; return(ans); }
USER_OBJECT_ RGnumeric_setCellAlign(USER_OBJECT_ scell, USER_OBJECT_ value, USER_OBJECT_ horizontal) { MStyle *style; Cell *cell; cell = RGnumeric_resolveCellReference(scell); style = cell_get_mstyle(cell); if(LOGICAL_DATA(horizontal)[0]) mstyle_set_align_h(style, INTEGER_DATA(value)[0]) ; else mstyle_set_align_v(style, INTEGER_DATA(value)[0]); updateSCell(cell, scell, style); return(value); }
/* Converts and inserts the Perl primitive value `val' into the R/S object `ans' in position `i'. It knows the type of the Perl object and hence the S object type. See PerlAllocHomogeneousVector() above. */ void PerlAddHomogeneousElement(SV *val, int i, USER_OBJECT_ ans, svtype elementType) { dTHX; switch(elementType) { case SVt_IV: INTEGER_DATA(ans)[i] = SvIV(val); break; case SVt_PVIV: INTEGER_DATA(ans)[i] = SvIV(val); break; case SVt_NV: NUMERIC_DATA(ans)[i] = SvNV(val); break; case SVt_PVNV: NUMERIC_DATA(ans)[i] = SvNV(val); break; case SVt_PV: SET_STRING_ELT(ans, i, COPY_TO_USER_STRING(SvPV(val, PL_na))); break; #if 0 case SVt_RV: SET_VECTOR_ELT(ans, i, fromPerl(sv_isobject(val) ? val : val/*XXX SvRV(val)*/, 1)); break; #endif case SVt_PVMG: /* magic variable */ /*XXX */ SET_VECTOR_ELT(ans, i, fromPerl(val, 0)); break; case SVt_PVGV: /* glob value*/ SET_VECTOR_ELT(ans, i, fromPerl(val, 1)); break; case SVt_NULL: if(TYPEOF(ans) == VECSXP) SET_VECTOR_ELT(ans, i, R_NilValue); else fprintf(stderr, "Unhandled NULL object at position %d in array conversion into R object of type %d\n", i, TYPEOF(ans)); break; default: fprintf(stderr, "Unhandled type %d at position %d in array conversion\n", elementType, i); break; } }
/* * plr_SPI_lastoid - return the last oid. To be used after insert queries. */ SEXP plr_SPI_lastoid(void) { SEXP result; PROTECT(result = NEW_INTEGER(1)); INTEGER_DATA(result)[0] = SPI_lastoid; UNPROTECT(1); return result; }
/** Get the number of worksheets in the specified workbook. */ USER_OBJECT_ RGnumeric_getNumSheetsInWorkbook(USER_OBJECT_ workbookRef) { USER_OBJECT_ ans; Workbook *workbook; workbook = RGnumeric_resolveWorkbookReference(workbookRef); ans = NEW_INTEGER(1); INTEGER_DATA(ans)[0] = workbook_sheet_count(workbook); return(ans); }
SEXP isSameRef(USER_OBJECT_ x, USER_OBJECT_ y) { SEXP ans; void *a, *b; ans = NEW_LOGICAL(1); a = R_ExternalPtrAddr(x); b = R_ExternalPtrAddr(y); INTEGER_DATA(ans)[0] = (a == b); return(ans); }
SEXP plr_SPI_cursor_fetch(SEXP cursor_in,SEXP forward_in, SEXP rows_in) { Portal portal=NULL; int ntuples; SEXP result = NULL; MemoryContext oldcontext; int forward; int rows; PREPARE_PG_TRY; PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.cursor_fetch"); portal = R_ExternalPtrAddr(cursor_in); if(!IS_LOGICAL(forward_in)) { error("pg.spi.cursor_fetch arg2 must be boolean"); return result; } if(!IS_INTEGER(rows_in)) { error("pg.spi.cursor_fetch arg3 must be an integer"); return result; } forward = LOGICAL_DATA(forward_in)[0]; rows = INTEGER_DATA(rows_in)[0]; /* switch to SPI memory context */ oldcontext = MemoryContextSwitchTo(plr_SPI_context); PG_TRY(); { /* Open the cursor */ SPI_cursor_fetch(portal,forward,rows); } PLR_PG_CATCH(); PLR_PG_END_TRY(); /* back to caller's memory context */ MemoryContextSwitchTo(oldcontext); /* check the result */ ntuples = SPI_processed; if (ntuples > 0) { result = rpgsql_get_results(ntuples, SPI_tuptable); SPI_freetuptable(SPI_tuptable); } else result = R_NilValue; POP_PLERRCONTEXT; return result; }
USER_OBJECT_ RS_PerlLength(USER_OBJECT_ obj) { SV *sv; int n; USER_OBJECT_ ans; dTHX; sv = RS_PerlGetSV(obj); if(!sv) { PROBLEM "Can't get Perl object from S object" ERROR; } /* Check for a) objects, b) references here. */ #if 0 if(sv_isobject(sv)) { /*XXX What are we warning here. Is it debugging? */ PROBLEM "Calling length on a Perl object" WARN; } #endif if(SvROK(sv)) { sv = SvRV(sv); } switch(SvTYPE(sv)) { case SVt_PVHV: n = hv_iterinit((HV*) sv); break; case SVt_PVAV: n = av_len((AV*) sv) + 1; break; default: n = 0; break; } ans = NEW_INTEGER(1); INTEGER_DATA(ans)[0] = n; return(ans); }
USER_OBJECT_ RS_GGOBI(getNumPlotsInDisplay)(USER_OBJECT_ dpy) { displayd *display; gint len; USER_OBJECT_ ans = NEW_INTEGER(1); display = toDisplay(dpy); g_return_val_if_fail(GGOBI_IS_DISPLAY(display), NULL_USER_OBJECT); len = g_list_length(display->splots); INTEGER_DATA(ans)[0] = len; return(ans); }
/** Get either the cell horizontal or vertical alignment setting for the specified cell. This just returns the value of the alignment setting. We put a symbolic name on it in S. */ USER_OBJECT_ RGnumeric_getCellAlign(USER_OBJECT_ scell, USER_OBJECT_ horizontal) { USER_OBJECT_ ans; MStyle *style; Cell *cell; cell = RGnumeric_resolveCellReference(scell); style = cell_get_mstyle(cell); ans = NEW_INTEGER(1); INTEGER_DATA(ans)[0] = LOGICAL_DATA(horizontal)[0] ? mstyle_get_align_h(style) : mstyle_get_align_v(style); return(ans); }
USER_OBJECT_ asRFlag(guint value, GType ftype) { USER_OBJECT_ ans, names; PROTECT(ans = NEW_INTEGER(1)); INTEGER_DATA(ans)[0] = value; PROTECT(names = NEW_CHARACTER(2)); SET_STRING_ELT(names, 0, COPY_TO_USER_STRING(g_type_name(ftype))); SET_STRING_ELT(names, 1, COPY_TO_USER_STRING("flag")); SET_CLASS(ans, names); UNPROTECT(2); return(ans); }
/** Get a reference to a particular sheet in a Gnumeric workbook, identifying it either by index or by name. If an integer is specified, this should be 1-based (rather than 0-based). */ USER_OBJECT_ RGnumeric_sheetInWorkbook(USER_OBJECT_ workbookRef, USER_OBJECT_ index) { Workbook *workbook; USER_OBJECT_ ans = NULL_USER_OBJECT; Sheet *sheet; workbook = RGnumeric_resolveWorkbookReference(workbookRef); if(IS_INTEGER(index)) sheet = workbook_sheet_by_index(workbook, INTEGER_DATA(index)[0] - 1); else { sheet = workbook_sheet_by_name(workbook, CHAR_DEREF(STRING_ELT(index, 0))); } if(sheet) ans = RGnumeric_sheetReference(sheet); return(ans); }
static void toggle_display_variables(displayd *display, USER_OBJECT_ vars, gboolean active) { gint i, j; for (j = 0; j < 3; j++) { USER_OBJECT_ varIds = VECTOR_ELT(vars, j); for (i = 0; i < GET_LENGTH(varIds); i++) { gint var = INTEGER_DATA(varIds)[i]; GtkWidget *wid = varpanel_widget_get_nth(j, var, display->d); if (!GTK_IS_WIDGET(wid)) error("Unknown variable"); if (gtk_toggle_button_get_active(GTK_TOGGLE_BUTTON(wid)) == active) { varsel(wid, &display->cpanel, display->current_splot, var, j, -1, 0, 0, 0, display->d, display->ggobi); } } } }
USER_OBJECT_ RS_GGOBI(createDisplay)(USER_OBJECT_ stype, USER_OBJECT_ svars, USER_OBJECT_ datasetId, USER_OBJECT_ useWindow) { GGobiData *d; ggobid *gg; displayd *display = NULL; GType type; GGobiExtendedDisplayClass *klass; gboolean use_window = asCLogical(useWindow); d = toData(datasetId); g_return_val_if_fail(GGOBI_IS_DATA(d), NULL_USER_OBJECT); gg = d->gg; type = g_type_from_name(asCString(stype)); klass = GGOBI_EXTENDED_DISPLAY_CLASS(g_type_class_peek(type)); if(!klass) { PROBLEM "Unrecognized display type" ERROR; } if(klass->createWithVars && GET_LENGTH(svars)) { gint nvars, *vars, i; nvars = GET_LENGTH(svars); vars = g_malloc(sizeof(gint)*nvars); for(i = 0; i < nvars; i++) vars[i] = INTEGER_DATA(svars)[i]; display = klass->createWithVars(use_window, false, nvars, vars, d, gg); } else if(klass->create) display = klass->create(use_window, false, NULL, d, gg); if(!display) { PROBLEM "Couldn't create the display" ERROR; } display_add(display, gg); gdk_flush(); return(RS_displayInstance(display)); }
USER_OBJECT_ RS_PerlArrayElement(USER_OBJECT_ rs_arr, USER_OBJECT_ elements, USER_OBJECT_ convert) { int i, n; AV *arr; SV *obj; USER_OBJECT_ ans = NULL_USER_OBJECT; unsigned int depth; dTHX; obj = getForeignPerlReference(rs_arr); if(obj == NULL) { PROBLEM "No such array reference %s", "?" ERROR; } if(SvROK(obj)) obj = SvRV(obj); if(SvTYPE(obj) != SVt_PVAV) { PROBLEM "Perl object is not an array %s, but of type %d", "?", (int) SvTYPE(obj) ERROR; } arr = (AV*) obj; if(TYPEOF(convert) == LGLSXP || TYPEOF(convert) == INTSXP) depth = (TYPEOF(convert) == LGLSXP ? LOGICAL(convert)[0] : INTEGER(convert)[0]); n = GET_LENGTH(elements); if(n > 0) { SV **el; PROTECT(ans = NEW_LIST(n)); for(i = 0; i < n; i++) { el = av_fetch(arr, INTEGER_DATA(elements)[i], 0); if(el && *el) SET_VECTOR_ELT(ans, i, fromPerl(*el, depth/*XXX handle other cases, like CallModified. Accept a native symbol */)); } UNPROTECT(1); } return(ans); }
USER_OBJECT_ RGnumeric_setCellForeground(USER_OBJECT_ cellRef, USER_OBJECT_ val, USER_OBJECT_ isFg) { MStyle *style; Cell *cell; enum _MStyleElementType attr; int *v = INTEGER_DATA(val); attr = LOGICAL_DATA(isFg)[0] ? MSTYLE_COLOR_FORE : MSTYLE_COLOR_BACK; cell = RGnumeric_resolveCellReference(cellRef); style = cell_get_mstyle(cell); style = mstyle_copy(style); mstyle_set_color(style, attr, style_color_new(v[0], v[1], v[2])); updateSCell(cell, cellRef, style); return(NULL_USER_OBJECT); }
/* Sets a plot as the active plot given a display and a plot index */ USER_OBJECT_ RS_GGOBI(setActivePlot)(USER_OBJECT_ s_display, USER_OBJECT_ s_plot) { USER_OBJECT_ ans = NEW_LOGICAL(1); displayd *display; splotd *sp; display = toDisplay(s_display); g_return_val_if_fail(GGOBI_IS_DISPLAY(display), NULL_USER_OBJECT); display_set_current(display, display->ggobi); sp = GGOBI(getPlot)(display, INTEGER_DATA(s_plot)[0]); g_return_val_if_fail(sp != NULL, NULL_USER_OBJECT); GGOBI(splot_set_current_full)(display, sp, display->ggobi); LOGICAL_DATA(ans)[0] = 1; gdk_flush(); return (ans); }