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