static au_instance_t *audiounits_create_player(SEXP source, float rate, int flags) {
ComponentDescription desc = { kAudioUnitType_Output, kAudioUnitSubType_DefaultOutput, kAudioUnitManufacturer_Apple, 0, 0 };
Component comp;
OSStatus err;
au_instance_t *ap = (au_instance_t*) calloc(sizeof(au_instance_t), 1);
ap->source = source;
ap->sample_rate = rate;
ap->done = NO;
ap->position = 0;
ap->length = LENGTH(source);
ap->stereo = NO;
{ /* if the source is a matrix with 2 rows then we'll use stereo */
SEXP dim = Rf_getAttrib(source, R_DimSymbol);
if (TYPEOF(dim) == INTSXP && LENGTH(dim) > 0 && INTEGER(dim)[0] == 2)
ap->stereo = YES;
}
ap->loop = (flags & APFLAG_LOOP) ? YES : NO;
memset(&ap->fmtOut, 0, sizeof(ap->fmtOut));
ap->fmtOut.mSampleRate = ap->sample_rate;
ap->fmtOut.mFormatID = kAudioFormatLinearPCM;
ap->fmtOut.mChannelsPerFrame = ap->stereo ? 2 : 1;
ap->fmtOut.mFormatFlags = kAudioFormatFlagIsSignedInteger | kAudioFormatFlagIsPacked;
#if __ppc__ || __ppc64__ || __BIG_ENDIAN__
ap->fmtOut.mFormatFlags |= kAudioFormatFlagIsBigEndian;
#endif
ap->fmtOut.mFramesPerPacket = 1;
ap->fmtOut.mBytesPerPacket = ap->fmtOut.mBytesPerFrame = ap->fmtOut.mFramesPerPacket * ap->fmtOut.mChannelsPerFrame * 2;
ap->fmtOut.mBitsPerChannel = 16;
if (ap->stereo) ap->length /= 2;
comp = FindNextComponent(NULL, &desc);
if (!comp) Rf_error("unable to find default audio output");
err = OpenAComponent(comp, &ap->outUnit);
if (err) Rf_error("unable to open default audio (%08x)", err);
err = AudioUnitInitialize(ap->outUnit);
if (err) {
CloseComponent(ap->outUnit);
Rf_error("unable to initialize default audio (%08x)", err);
}
R_PreserveObject(ap->source);
return ap;
}
SEXP
newRClosureTable(SEXP handlers)
{
R_ObjectTable *tb;
SEXP val, klass, env;
tb = (R_ObjectTable *) malloc(sizeof(R_ObjectTable));
if(!tb)
error("cannot allocate space for an internal R object table");
tb->type = 15;
tb->cachedNames = NULL;
tb->active = TRUE;
R_PreserveObject(handlers);
tb->privateData = handlers;
tb->exists = RClosureTable_exists;
tb->get = RClosureTable_get;
tb->remove = RClosureTable_remove;
tb->assign = RClosureTable_assign;
tb->objects = RClosureTable_objects;
tb->canCache = RClosureTable_canCache;
tb->onAttach = NULL;
tb->onDetach = NULL;
PROTECT(val = R_MakeExternalPtr(tb, Rf_install("UserDefinedDatabase"), R_NilValue));
PROTECT(klass = NEW_CHARACTER(1));
SET_STRING_ELT(klass, 0, COPY_TO_USER_STRING("UserDefinedDatabase"));
SET_CLASS(val, klass);
env = allocSExp(ENVSXP);
SET_HASHTAB(env, val);
SET_ENCLOS(env, R_GlobalEnv);
setAttrib(env, R_ClassSymbol, getAttrib(HASHTAB(env), R_ClassSymbol));
UNPROTECT(2);
return(env);
}
/* Return NULL on failure */
SEXP
SexpEnvironment_get(const SEXP envir, const char* symbol) {
if (! RINTERF_ISREADY()) {
printf("R is not ready.\n");
return NULL;
}
RStatus ^= RINTERF_IDLE;
SEXP sexp, sexp_ok;
PROTECT(sexp = findVar(Rf_install(symbol), envir));
if (TYPEOF(sexp) == PROMSXP) {
sexp_ok = Sexp_evalPromise(sexp);
} else {
sexp_ok = sexp;
}
//FIXME: protect/unprotect from garbage collection (for now protect only)
R_PreserveObject(sexp_ok);
UNPROTECT(1);
RStatus ^= RINTERF_IDLE;
return sexp_ok;
}
bool DataFrameModel::setData(const QModelIndex &index, const QVariant &value,
int role)
{
int col = index.column();
int row = index.row();
QModelIndex dummy;
if (!index.isValid()) {
qCritical("Model index is invalid");
return false;
}
if (col >= columnCount(dummy)) {
qCritical("Column index %d out of bounds", col);
return false;
}
if (row >= rowCount(dummy)) {
qCritical("Row index %d out of bounds", row);
return false;
}
if (role >= length(_roles)) {
qCritical("Role index %d out of bounds", role);
return false;
}
SEXP roleVector = VECTOR_ELT(_roles, role);
int dfIndex;
if (roleVector == R_NilValue || (dfIndex = INTEGER(roleVector)[col]) == -1)
return(false);
SEXP tmpDataframe = duplicate(_dataframe);
R_ReleaseObject(_dataframe);
_dataframe = tmpDataframe;
R_PreserveObject(_dataframe);
SEXP v = VECTOR_ELT(_dataframe, dfIndex);
bool success = qvariant_into_vector(value, v, row);
if (success)
dataChanged(index, index);
return success;
}
/* 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;
}
// internal use only
jobject create_direct_buffer(SEXP matrix, SEXP buflen)
{
int d = *INTEGER(buflen);
if(d < 0)
return (NULL);
d = sqrt(d);
// We lose the handle to the DirectByteBuffer, but since it doesn't own the data itself,
// this is trivial. Java may even clean it up for us?
jobject dbytebuffer = env->NewDirectByteBuffer(REAL(matrix), d*d*sizeof(double));
if(env->ExceptionOccurred())
{
env->ExceptionDescribe();
env->ExceptionClear();
return NULL;
}
jobject distbuffer = env->NewObject(cl["RDirectBufferData"], fn["RDirectBufferData.<init>"], d, dbytebuffer);
if(env->ExceptionOccurred())
{
env->ExceptionDescribe();
env->ExceptionClear();
return NULL;
}
// If all goes well, preserve the matrix memory for Java
R_PreserveObject(matrix);
return distbuffer;
}
void protect_robj(SEXP robj){
R_PreserveObject(robj);
}
/* to match seq.default */
SEXP attribute_hidden do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans = R_NilValue /* -Wall */, tmp, from, to, by, len, along;
int nargs = length(args), lf;
Rboolean One = nargs == 1;
R_xlen_t i, lout = NA_INTEGER;
static SEXP do_seq_formals = NULL;
if (DispatchOrEval(call, op, R_SeqCharSXP, args, rho, &ans, 0, 1))
return(ans);
/* This is a primitive and we manage argument matching ourselves.
We pretend this is
seq(from, to, by, length.out, along.with, ...)
*/
if (do_seq_formals == NULL) {
do_seq_formals = CONS(R_NilValue, CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue)));
R_PreserveObject(do_seq_formals);
tmp = do_seq_formals;
SET_TAG(tmp, install("from")); tmp = CDR(tmp);
SET_TAG(tmp, install("to")); tmp = CDR(tmp);
SET_TAG(tmp, install("by")); tmp = CDR(tmp);
SET_TAG(tmp, R_LengthOutSymbol); tmp = CDR(tmp);
SET_TAG(tmp, R_AlongWithSymbol); tmp = CDR(tmp);
SET_TAG(tmp, R_DotsSymbol);
}
PROTECT(args = matchArgs(do_seq_formals, args, call));
from = CAR(args); args = CDR(args);
to = CAR(args); args = CDR(args);
by = CAR(args); args = CDR(args);
len = CAR(args); args = CDR(args);
along = CAR(args);
if(One && from != R_MissingArg) {
lf = length(from);
if(lf == 1 && (TYPEOF(from) == INTSXP || TYPEOF(from) == REALSXP)) {
double rfrom = asReal(from);
if (!R_FINITE(rfrom))
errorcall(call, "'from' cannot be NA, NaN or infinite");
ans = seq_colon(1.0, rfrom, call);
}
else if (lf)
ans = seq_colon(1.0, (double)lf, call);
else
ans = allocVector(INTSXP, 0);
goto done;
}
if(along != R_MissingArg) {
lout = XLENGTH(along);
if(One) {
ans = lout ? seq_colon(1.0, (double)lout, call) : allocVector(INTSXP, 0);
goto done;
}
} else if(len != R_MissingArg && len != R_NilValue) {
double rout = asReal(len);
if(ISNAN(rout) || rout <= -0.5)
errorcall(call, _("'length.out' must be a non-negative number"));
if(length(len) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
lout = (R_xlen_t) ceil(rout);
}
if(lout == NA_INTEGER) {
double rfrom = asReal(from), rto = asReal(to), rby = asReal(by), *ra;
if(from == R_MissingArg) rfrom = 1.0;
else if(length(from) != 1) error("'from' must be of length 1");
if(to == R_MissingArg) rto = 1.0;
else if(length(to) != 1) error("'to' must be of length 1");
if (!R_FINITE(rfrom))
errorcall(call, "'from' cannot be NA, NaN or infinite");
if (!R_FINITE(rto))
errorcall(call, "'to' cannot be NA, NaN or infinite");
if(by == R_MissingArg)
ans = seq_colon(rfrom, rto, call);
else {
if(length(by) != 1) error("'by' must be of length 1");
double del = rto - rfrom, n, dd;
R_xlen_t nn;
if(!R_FINITE(rfrom))
errorcall(call, _("'from' must be finite"));
if(!R_FINITE(rto))
errorcall(call, _("'to' must be finite"));
if(del == 0.0 && rto == 0.0) {
ans = to;
goto done;
}
/* printf("from = %f, to = %f, by = %f\n", rfrom, rto, rby); */
n = del/rby;
if(!R_FINITE(n)) {
if(del == 0.0 && rby == 0.0) {
ans = from;
goto done;
} else
errorcall(call, _("invalid '(to - from)/by' in 'seq'"));
}
dd = fabs(del)/fmax2(fabs(rto), fabs(rfrom));
if(dd < 100 * DBL_EPSILON) {
ans = from;
goto done;
}
#ifdef LONG_VECTOR_SUPPORT
if(n > 100 * (double) INT_MAX)
#else
if(n > (double) INT_MAX)
#endif
errorcall(call, _("'by' argument is much too small"));
if(n < - FEPS)
errorcall(call, _("wrong sign in 'by' argument"));
if(TYPEOF(from) == INTSXP &&
TYPEOF(to) == INTSXP &&
TYPEOF(by) == INTSXP) {
int *ia, ifrom = asInteger(from), iby = asInteger(by);
/* With the current limits on integers and FEPS
reduced below 1/INT_MAX this is the same as the
next, so this is future-proofing against longer integers.
*/
/* seq.default gives integer result from
from + (0:n)*by
*/
nn = (R_xlen_t) n;
ans = allocVector(INTSXP, nn+1);
ia = INTEGER(ans);
for(i = 0; i <= nn; i++)
ia[i] = (int)(ifrom + i * iby);
} else {
nn = (int)(n + FEPS);
ans = allocVector(REALSXP, nn+1);
ra = REAL(ans);
for(i = 0; i <= nn; i++)
ra[i] = rfrom + (double)i * rby;
/* Added in 2.9.0 */
if (nn > 0)
if((rby > 0 && ra[nn] > rto) || (rby < 0 && ra[nn] < rto))
ra[nn] = rto;
}
}
} else if (lout == 0) {
ans = allocVector(INTSXP, 0);
} else if (One) {
ans = seq_colon(1.0, (double)lout, call);
} else if (by == R_MissingArg) {
double rfrom = asReal(from), rto = asReal(to), rby;
if(to == R_MissingArg) rto = rfrom + (double)lout - 1;
if(from == R_MissingArg) rfrom = rto - (double)lout + 1;
if(!R_FINITE(rfrom))
errorcall(call, _("'from' must be finite"));
if(!R_FINITE(rto))
errorcall(call, _("'to' must be finite"));
ans = allocVector(REALSXP, lout);
if(lout > 0) REAL(ans)[0] = rfrom;
if(lout > 1) REAL(ans)[lout - 1] = rto;
if(lout > 2) {
rby = (rto - rfrom)/(double)(lout - 1);
for(i = 1; i < lout-1; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(ans)[i] = rfrom + (double)i*rby;
}
}
} else if (to == R_MissingArg) {
double rfrom = asReal(from), rby = asReal(by), rto;
if(from == R_MissingArg) rfrom = 1.0;
if(!R_FINITE(rfrom))
errorcall(call, _("'from' must be finite"));
if(!R_FINITE(rby))
errorcall(call, _("'by' must be finite"));
rto = rfrom + (double)(lout-1)*rby;
if(rby == (int)rby && rfrom <= INT_MAX && rfrom >= INT_MIN
&& rto <= INT_MAX && rto >= INT_MIN) {
ans = allocVector(INTSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
INTEGER(ans)[i] = (int)(rfrom + (double)i*rby);
}
} else {
ans = allocVector(REALSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(ans)[i] = rfrom + (double)i*rby;
}
}
} else if (from == R_MissingArg) {
double rto = asReal(to), rby = asReal(by),
rfrom = rto - (double)(lout-1)*rby;
if(!R_FINITE(rto))
errorcall(call, _("'to' must be finite"));
if(!R_FINITE(rby))
errorcall(call, _("'by' must be finite"));
if(rby == (int)rby && rfrom <= INT_MAX && rfrom >= INT_MIN
&& rto <= INT_MAX && rto >= INT_MIN) {
ans = allocVector(INTSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
INTEGER(ans)[i] = (int)(rto - (double)(lout - 1 - i)*rby);
}
} else {
ans = allocVector(REALSXP, lout);
for(i = 0; i < lout; i++) {
// if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
REAL(ans)[i] = rto - (double)(lout - 1 - i)*rby;
}
}
} else
errorcall(call, _("too many arguments"));
done:
UNPROTECT(1);
return ans;
}
/* This is a primitive SPECIALSXP with internal argument matching */
SEXP attribute_hidden do_rep(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, x, times = R_NilValue /* -Wall */;
int each = 1, nprotect = 3;
R_xlen_t i, lx, len = NA_INTEGER, nt;
static SEXP do_rep_formals = NULL;
/* includes factors, POSIX[cl]t, Date */
if (DispatchOrEval(call, op, R_RepCharSXP, args, rho, &ans, 0, 0))
return(ans);
/* This has evaluated all the non-missing arguments into ans */
PROTECT(args = ans);
/* This is a primitive, and we have not dispatched to a method
so we manage the argument matching ourselves. We pretend this is
rep(x, times, length.out, each, ...)
*/
if (do_rep_formals == NULL) {
do_rep_formals = CONS(R_NilValue, list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue));
R_PreserveObject(do_rep_formals);
SET_TAG(do_rep_formals, R_XSymbol);
SET_TAG(CDR(do_rep_formals), install("times"));
SET_TAG(CDDR(do_rep_formals), R_LengthOutSymbol);
SET_TAG(CDR(CDDR(do_rep_formals)), install("each"));
SET_TAG(CDDR(CDDR(do_rep_formals)), R_DotsSymbol);
}
PROTECT(args = matchArgs(do_rep_formals, args, call));
x = CAR(args);
/* supported in R 2.15.x */
if (TYPEOF(x) == LISTSXP)
errorcall(call, "replication of pairlists is defunct");
lx = xlength(x);
double slen = asReal(CADDR(args));
if (R_FINITE(slen)) {
if(slen < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
len = (R_xlen_t) slen;
} else {
len = asInteger(CADDR(args));
if(len != NA_INTEGER && len < 0)
errorcall(call, _("invalid '%s' argument"), "length.out");
}
if(length(CADDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"),
"length.out");
each = asInteger(CADDDR(args));
if(each != NA_INTEGER && each < 0)
errorcall(call, _("invalid '%s' argument"), "each");
if(length(CADDDR(args)) != 1)
warningcall(call, _("first element used of '%s' argument"), "each");
if(each == NA_INTEGER) each = 1;
if(lx == 0) {
if(len > 0 && x == R_NilValue)
warningcall(call, "'x' is NULL so the result will be NULL");
SEXP a;
PROTECT(a = duplicate(x));
if(len != NA_INTEGER && len > 0) a = xlengthgets(a, len);
UNPROTECT(3);
return a;
}
if (!isVector(x))
errorcall(call, "attempt to replicate an object of type '%s'",
type2char(TYPEOF(x)));
/* So now we know x is a vector of positive length. We need to
replicate it, and its names if it has them. */
/* First find the final length using 'times' and 'each' */
if(len != NA_INTEGER) { /* takes precedence over times */
nt = 1;
} else {
R_xlen_t sum = 0;
if(CADR(args) == R_MissingArg) PROTECT(times = ScalarInteger(1));
else PROTECT(times = coerceVector(CADR(args), INTSXP));
nprotect++;
nt = XLENGTH(times);
if(nt != 1 && nt != lx * each)
errorcall(call, _("invalid '%s' argument"), "times");
if(nt == 1) {
int it = INTEGER(times)[0];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
len = lx * it * each;
} else {
for(i = 0; i < nt; i++) {
int it = INTEGER(times)[i];
if (it == NA_INTEGER || it < 0)
errorcall(call, _("invalid '%s' argument"), "times");
sum += it;
}
len = sum;
}
}
if(len > 0 && each == 0)
errorcall(call, _("invalid '%s' argument"), "each");
SEXP xn = getNamesAttrib(x);
PROTECT(ans = rep4(x, times, len, each, nt));
if (length(xn) > 0)
setAttrib(ans, R_NamesSymbol, rep4(xn, times, len, each, nt));
#ifdef _S4_rep_keepClass
if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
setAttrib(ans, R_ClassSymbol, getClassAttrib(x));
SET_S4_OBJECT(ans);
}
#endif
UNPROTECT(nprotect);
return ans;
}
SEXP R_initMethodDispatch(SEXP envir)
{
if(envir && !isNull(envir))
Methods_Namespace = envir;
if(!Methods_Namespace)
Methods_Namespace = R_GlobalEnv;
if(initialized)
return(envir);
s_dot_Methods = install(".Methods");
s_skeleton = install("skeleton");
s_expression = install("expression");
s_function = install("function");
s_getAllMethods = install("getAllMethods");
s_objectsEnv = install("objectsEnv");
s_MethodsListSelect = install("MethodsListSelect");
s_sys_dot_frame = install("sys.frame");
s_sys_dot_call = install("sys.call");
s_sys_dot_function = install("sys.function");
s_generic = install("generic");
s_generic_dot_skeleton = install("generic.skeleton");
s_subset_gets = install("[<-");
s_element_gets = install("[[<-");
s_argument = install("argument");
s_allMethods = install("allMethods");
R_FALSE = ScalarLogical(FALSE);
R_PreserveObject(R_FALSE);
R_TRUE = ScalarLogical(TRUE);
R_PreserveObject(R_TRUE);
/* some strings (NOT symbols) */
s_missing = mkString("missing");
setAttrib(s_missing, R_PackageSymbol, mkString("methods"));
R_PreserveObject(s_missing);
s_base = mkString("base");
R_PreserveObject(s_base);
/* Initialize method dispatch, using the static */
R_set_standardGeneric_ptr(
(table_dispatch_on ? R_dispatchGeneric : R_standardGeneric)
, Methods_Namespace);
R_set_quick_method_check(
(table_dispatch_on ? R_quick_dispatch : R_quick_method_check));
/* Some special lists of primitive skeleton calls.
These will be promises under lazy-loading.
*/
PROTECT(R_short_skeletons =
findVar(install(".ShortPrimitiveSkeletons"),
Methods_Namespace));
if(TYPEOF(R_short_skeletons) == PROMSXP)
R_short_skeletons = eval(R_short_skeletons, Methods_Namespace);
R_PreserveObject(R_short_skeletons);
UNPROTECT(1);
PROTECT(R_empty_skeletons =
findVar(install(".EmptyPrimitiveSkeletons"),
Methods_Namespace));
if(TYPEOF(R_empty_skeletons) == PROMSXP)
R_empty_skeletons = eval(R_empty_skeletons, Methods_Namespace);
R_PreserveObject(R_empty_skeletons);
UNPROTECT(1);
if(R_short_skeletons == R_UnboundValue ||
R_empty_skeletons == R_UnboundValue)
error(_("could not find the skeleton calls for 'methods' (package detached?): expect very bad things to happen"));
f_x_i_skeleton = VECTOR_ELT(R_short_skeletons, 0);
fgets_x_i_skeleton = VECTOR_ELT(R_short_skeletons, 1);
f_x_skeleton = VECTOR_ELT(R_empty_skeletons, 0);
fgets_x_skeleton = VECTOR_ELT(R_empty_skeletons, 1);
init_loadMethod();
initialized = 1;
return(envir);
}
RVector::RVector(size_t init_size)
: size_(0), capacity_(slack), vector(Rf_allocVector(VECSXP, init_size)) {
SETLENGTH(vector, 0);
R_PreserveObject(vector);
}
RClass::RClass(SEXP klass) : _klass(klass) {
R_PreserveObject(klass);
}
void
_showInGtkWindow (SEXP xx, SEXP caption) {
int nx, ny, nz, width, height;
udata *dat;
SEXP dim;
GdkPixbuf * pxbuf;
GtkWidget *evBox, *winWG, *vboxWG, *tbarWG, *scrollWG,
*btnZoomInWG, *btnZoomOutWG, *btnZoomOneWG,
*btnNextWG, *btnPrevWG;
GtkObject *hAdjustment;
GtkIconSize iSize;
if ( !GTK_OK )
error ( "failed to initialize GTK+, use 'read.image' instead" );
dim = GET_DIM (xx);
nx = INTEGER (dim)[0];
ny = INTEGER (dim)[1];
nz = getNumberOfFrames(xx,1);
dat=g_new(udata,1);
dat->nx=nx;
dat->ny=ny;
dat->nz=nz;
dat->x=0;
dat->y=0;
dat->zoom=1.0;
dat->index=0;
dat->hSlider=NULL;
dat->xx=xx;
// xx is preserved from garbage collection til the windows is closed
R_PreserveObject(xx);
/* create pixbuf from image data */
pxbuf=newPixbufFromSEXP(xx,0);
if ( pxbuf == NULL )
error ( "cannot copy image data to display window" );
/* create imae display */
dat->imgWG = gtk_image_new_from_pixbuf (pxbuf);
g_object_unref (pxbuf);
/* create main window */
winWG = gtk_window_new (GTK_WINDOW_TOPLEVEL);
if ( caption != R_NilValue )
gtk_window_set_title ( GTK_WINDOW(winWG), CHAR( asChar(caption) ) );
else
gtk_window_set_title ( GTK_WINDOW(winWG), "R image display" );
/* set destroy event handler for the window */
g_signal_connect ( G_OBJECT(winWG), "delete-event", G_CALLBACK(onWinDestroy), dat);
/* create controls and set event handlers */
/* create general horizontal lyout with a toolbar and add it to the window */
vboxWG = gtk_vbox_new (FALSE, 0);
gtk_container_add ( GTK_CONTAINER(winWG), vboxWG);
/* create toolbar and push it to layout */
tbarWG = gtk_toolbar_new ();
gtk_box_pack_start ( GTK_BOX(vboxWG), tbarWG, FALSE, FALSE, 0);
// add a horizontal slider
if (nz>1) {
hAdjustment=gtk_adjustment_new(1,1,nz,1,1,0);
dat->hSlider=gtk_hscale_new(GTK_ADJUSTMENT(hAdjustment));
gtk_scale_set_digits(GTK_SCALE(dat->hSlider),0);
gtk_box_pack_start(GTK_BOX(vboxWG), dat->hSlider, FALSE,FALSE, 0);
gtk_signal_connect(GTK_OBJECT(dat->hSlider),"value-changed", GTK_SIGNAL_FUNC(onSlide), dat);
}
/* create scrollbox that occupies and extends and push it to layout */
scrollWG = gtk_scrolled_window_new (NULL, NULL);
gtk_box_pack_start ( GTK_BOX(vboxWG), scrollWG, TRUE, TRUE, 5);
gtk_scrolled_window_set_policy ( GTK_SCROLLED_WINDOW(scrollWG), GTK_POLICY_AUTOMATIC, GTK_POLICY_AUTOMATIC);
/* add image to event box */
evBox = gtk_event_box_new();
gtk_container_add(GTK_CONTAINER(evBox), dat->imgWG);
/* add image to scroll */
gtk_scrolled_window_add_with_viewport ( GTK_SCROLLED_WINDOW(scrollWG), evBox);
gtk_signal_connect(GTK_OBJECT(gtk_scrolled_window_get_hadjustment(GTK_SCROLLED_WINDOW(scrollWG))),"value-changed", GTK_SIGNAL_FUNC(onScroll), dat);
gtk_signal_connect(GTK_OBJECT(gtk_scrolled_window_get_vadjustment(GTK_SCROLLED_WINDOW(scrollWG))),"value-changed", GTK_SIGNAL_FUNC(onScroll), dat);
/* create status bar and push it to layout */
dat->stbarWG = gtk_statusbar_new ();
gtk_box_pack_start ( GTK_BOX(vboxWG), dat->stbarWG, FALSE, FALSE, 0);
/* add zoom buttons */
iSize = gtk_toolbar_get_icon_size ( GTK_TOOLBAR(tbarWG) );
btnZoomInWG = (GtkWidget *) gtk_tool_button_new ( gtk_image_new_from_stock("gtk-zoom-in", iSize), "Zoom in" );
gtk_container_add ( GTK_CONTAINER(tbarWG), btnZoomInWG);
g_signal_connect ( G_OBJECT(btnZoomInWG), "clicked", G_CALLBACK(onZoomInPress), dat);
btnZoomOutWG = (GtkWidget *) gtk_tool_button_new ( gtk_image_new_from_stock("gtk-zoom-out", iSize), "Zoom out" );
gtk_container_add ( GTK_CONTAINER(tbarWG), btnZoomOutWG);
g_signal_connect ( G_OBJECT(btnZoomOutWG), "clicked", G_CALLBACK(onZoomOutPress), dat);
btnZoomOneWG = (GtkWidget *) gtk_tool_button_new ( gtk_image_new_from_stock("gtk-yes", iSize), "1:1");
gtk_container_add ( GTK_CONTAINER(tbarWG), btnZoomOneWG);
g_signal_connect ( G_OBJECT(btnZoomOneWG), "clicked", G_CALLBACK(onZoomOnePress), dat);
/* add browsing buttons */
if ( nz > 1 ) {
btnPrevWG = (GtkWidget *) gtk_tool_button_new ( gtk_image_new_from_stock("gtk-go-back", iSize), "Previous" );
gtk_container_add ( GTK_CONTAINER(tbarWG), btnPrevWG);
g_signal_connect ( G_OBJECT(btnPrevWG), "clicked", G_CALLBACK(onPrevImPress), dat);
btnNextWG = (GtkWidget *) gtk_tool_button_new ( gtk_image_new_from_stock("gtk-go-forward", iSize), "Next" );
gtk_container_add ( GTK_CONTAINER(tbarWG), btnNextWG);
g_signal_connect ( G_OBJECT(btnNextWG), "clicked", G_CALLBACK(onNextImPress), dat);
}
gtk_signal_connect( GTK_OBJECT(evBox), "motion-notify-event", GTK_SIGNAL_FUNC(onMouseMove), dat);
gtk_widget_set_events(evBox, GDK_BUTTON_PRESS_MASK | GDK_POINTER_MOTION_MASK );
/* resize to fit image */
width = gdk_screen_get_width ( gdk_screen_get_default() );
height = gdk_screen_get_height ( gdk_screen_get_default () );
width = ( nx + 20 < width - 20 ) ? ( nx + 20 ) : ( width - 20 );
height = ( ny + 80 < height - 20 ) ? ( ny + 80 ) : ( height - 20 );
if ( width < 150 ) width = 150;
if ( height < 100 ) height = 100;
gtk_window_resize ( GTK_WINDOW(winWG), width, height);
/* show window */
gtk_widget_show_all (winWG);
updateStatusBar(dat);
gdk_flush();
}
/*
The implementation of the r:call() XSL function.
*/
void
RXSLT_callConvert(xmlXPathParserContextPtr ctxt, int nargs, int leaveAsRObject)
{
USER_OBJECT_ e, ans, tmp, fun;
xmlXPathObjectPtr obj, *xpathArgs;
int i, errorOccurred = 0;
int addContext = 0;
const char *funName, *colon;
xpathArgs = (xmlXPathObjectPtr*) malloc(nargs * sizeof(xmlXPathObjectPtr));
for(i = nargs-1; i >= 0; i--)
xpathArgs[i] = valuePop(ctxt);
funName = xmlXPathCastToString(xpathArgs[0]);
colon = strchr(funName, ':');
if(!colon) {
/* regular name of a function. */
fun = Rf_findFun(Rf_install(funName), R_GlobalEnv);
} else {
/* Handle a :: or ::: in the name by calling the corresponding function to get the value */
const char *realFunName = colon;
char tmp[300], *p = tmp;
do {
p[0] = ':';
p++;
realFunName++;
} while(realFunName[0] == ':');
p[0] = '\0';
PROTECT(e = allocVector(LANGSXP, 3));
SETCAR(e, Rf_install(tmp));
memcpy(tmp, funName, colon - funName);
SETCAR(CDR(e), mkString(tmp));
SETCAR(CDR(CDR(e)), mkString(realFunName));
/*??? Do we need to protect ?
XXX If the symbol is not present, this seems to throw the error in R
but using R_tryEval(), we should be gettting back to here.
*/
fun = R_tryEval(e, R_GlobalEnv, &errorOccurred);
if(errorOccurred)
RXSLT_Error(ctxt, "can't find R function %s", (char *) funName);
UNPROTECT(1);
}
if(TYPEOF(fun) != CLOSXP && /*???*/ TYPEOF(fun) != FUNSXP && TYPEOF(fun) != BUILTINSXP)
RXSLT_Error(ctxt, "%s does not correspond to an R function (%d)", funName, TYPEOF(fun));
addContext = OBJECT(fun) && R_isInstanceOf(fun, "XSLTContextFunction");
PROTECT(e = allocVector(LANGSXP, nargs + addContext));
obj = valuePop(ctxt); /* ?? what is here. */
#ifdef XSLT_DEBUG
fprintf(stderr, "RXSLT_call for %s with %d args\n", xmlXPathCastToString(xpathArgs[0]), nargs);fflush(stderr);
#endif
SETCAR(e, fun); /* Rf_install(xmlXPathCastToString(xpathArgs[0])));*/
tmp = CDR(e);
if(addContext) {
SETCAR(tmp, RXSLT_exportPointer(ctxt, "XMLXPathParserContext"));
tmp = CDR(tmp);
}
for(i = 1 ; i < nargs; i++) {
obj = xpathArgs[i];
SETCAR(tmp, convertFromXPath(ctxt, obj));
tmp = CDR(tmp);
}
ans = R_tryEval(e, R_GlobalEnv, &errorOccurred);
if(!errorOccurred) {
xmlXPathObjectPtr val;
PROTECT(ans);
if(leaveAsRObject) {
R_PreserveObject(ans);
val = xmlXPathWrapExternal(ans);
} else
val = convertToXPath(ctxt, ans);
if(val)
valuePush(ctxt, val);
UNPROTECT(1);
} else {
RXSLT_Error(ctxt, "[R:error] error calling R function %s\n", (char *) funName);
}
free(xpathArgs);
UNPROTECT(1);
return;
}
void
setRMethods(RDevDescMethods *dev, SEXP methods)
{
SEXP tmp;
tmp = GET_SLOT(methods, Rf_install("activate"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> activate = tmp);
else
dev-> activate = NULL;
tmp = GET_SLOT(methods, Rf_install("circle"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> circle = tmp); /* createCircleCall(tmp)); */
else
dev-> circle = NULL;
tmp = GET_SLOT(methods, Rf_install("clip"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> clip = tmp);
else
dev-> clip = NULL;
tmp = GET_SLOT(methods, Rf_install("close"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> close = tmp);
else
dev-> close = NULL;
tmp = GET_SLOT(methods, Rf_install("deactivate"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> deactivate = tmp);
else
dev-> deactivate = NULL;
tmp = GET_SLOT(methods, Rf_install("locator"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> locator = tmp);
else
dev-> locator = NULL;
tmp = GET_SLOT(methods, Rf_install("line"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> line = tmp);
else
dev-> line = NULL;
tmp = GET_SLOT(methods, Rf_install("metricInfo"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> metricInfo = tmp);
else
dev-> metricInfo = NULL;
tmp = GET_SLOT(methods, Rf_install("mode"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> mode = tmp);
else
dev-> mode = NULL;
tmp = GET_SLOT(methods, Rf_install("newPage"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> newPage = tmp);
else
dev-> newPage = NULL;
tmp = GET_SLOT(methods, Rf_install("polygon"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> polygon = tmp);
else
dev-> polygon = NULL;
tmp = GET_SLOT(methods, Rf_install("polyline"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> polyline = tmp);
else
dev-> polyline = NULL;
tmp = GET_SLOT(methods, Rf_install("rect"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> rect = tmp);
else
dev-> rect = NULL;
tmp = GET_SLOT(methods, Rf_install("size"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> size = tmp);
else
dev-> size = NULL;
tmp = GET_SLOT(methods, Rf_install("strWidth"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> strWidth = tmp);
else
dev-> strWidth = NULL;
tmp = GET_SLOT(methods, Rf_install("text"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> text = tmp);
else
dev-> text = NULL;
tmp = GET_SLOT(methods, Rf_install("onExit"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> onExit = tmp);
else
dev-> onExit = NULL;
tmp = GET_SLOT(methods, Rf_install("getEvent"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> getEvent = tmp);
else
dev-> getEvent = NULL;
tmp = GET_SLOT(methods, Rf_install("newFrameConfirm"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> newFrameConfirm = tmp);
else
dev-> newFrameConfirm = NULL;
tmp = GET_SLOT(methods, Rf_install("textUTF8"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> textUTF8 = tmp);
else
dev-> textUTF8 = NULL;
tmp = GET_SLOT(methods, Rf_install("strWidthUTF8"));
if(tmp != R_NilValue)
R_PreserveObject(dev-> strWidthUTF8 = tmp);
else
dev-> strWidthUTF8 = NULL;
}
static void
RS_XML(xmlSAX2StartElementNs)(void * userData,
const xmlChar * localname,
const xmlChar * prefix,
const xmlChar * URI,
int nb_namespaces,
const xmlChar ** namespaces,
int nb_attributes,
int nb_defaulted,
const xmlChar ** attributes)
{
int i, n;
USER_OBJECT_ tmp, names;
USER_OBJECT_ opArgs, ans;
RS_XMLParserData *rinfo = (RS_XMLParserData*) userData;
DECL_ENCODING_FROM_EVENT_PARSER(rinfo)
if(!localname)
return;
/* if there is a branch function in the branches argument of xmlEventParse() with this name, call that and return.*/
if((i = R_isBranch(localname, rinfo)) != -1) {
R_processBranch(rinfo, i, localname, prefix, URI, nb_namespaces, namespaces, nb_attributes, nb_defaulted, attributes, FALSE);
return;
}
PROTECT(opArgs = NEW_LIST(4));
SET_VECTOR_ELT(opArgs, 0, NEW_CHARACTER(1));
SET_STRING_ELT(VECTOR_ELT(opArgs, 0), 0, ENC_COPY_TO_USER_STRING(XMLCHAR_TO_CHAR(localname)));
/* Now convert the attributes list. */
SET_VECTOR_ELT(opArgs, 1, createSAX2AttributesList(attributes, nb_attributes, nb_defaulted, encoding));
PROTECT(tmp = NEW_CHARACTER(1));
if(URI) {
SET_STRING_ELT(tmp, 0, ENC_COPY_TO_USER_STRING(XMLCHAR_TO_CHAR(URI)));
SET_NAMES(tmp, ScalarString(CreateCharSexpWithEncoding(encoding, ( (void*)prefix ? XMLCHAR_TO_CHAR(prefix) : ""))));
}
SET_VECTOR_ELT(opArgs, 2, tmp);
UNPROTECT(1);
n = nb_namespaces;
PROTECT(tmp = NEW_CHARACTER(n));
PROTECT(names = NEW_CHARACTER(n));
for(i = 0, n = 0; n < nb_namespaces; n++, i+=2) {
SET_STRING_ELT(tmp, n, ENC_COPY_TO_USER_STRING(XMLCHAR_TO_CHAR(namespaces[i+1])));
if(namespaces[i])
SET_STRING_ELT(names, n, ENC_COPY_TO_USER_STRING(XMLCHAR_TO_CHAR(namespaces[i])));
}
SET_NAMES(tmp, names);
SET_VECTOR_ELT(opArgs, 3, tmp);
UNPROTECT(2);
ans = RS_XML(callUserFunction)(HANDLER_FUN_NAME(rinfo, "startElement"), XMLCHAR_TO_CHAR(localname), rinfo, opArgs);
/* If the handler function returned us a SAXBranchFunction function, then we need to build the node's sub-tree and
then invoke the function with that node as the main argument. (It may also get the context/parser.) */
if(isBranchFunction(ans)) {
/* Hold on to the function to avoid it being garbage collected. */
R_PreserveObject(rinfo->dynamicBranchFunction = ans);
/* Start the creation of the node's sub-tree. */
R_processBranch(rinfo, -1, localname, prefix, URI, nb_namespaces, namespaces, nb_attributes, nb_defaulted, attributes, FALSE);
}
UNPROTECT(1);
}
void
init(int n)
{
ans = NEW_CHARACTER(n);
R_PreserveObject(ans);
}
void setEnv(SEXP e) {
env = e;
R_PreserveObject(env);
}
RVector::RVector(SEXP vector)
: size_(XLENGTH(vector)), capacity_(XLENGTH(vector)), vector(vector) {
assert(TYPEOF(vector) == VECSXP);
R_PreserveObject(vector);
}
static void Rserve_eval_cleanup(void *arg) {
rs_eval_t *e = (rs_eval_t*) arg;
SEXP tb = R_GetTraceback(0);
if (tb && tb != R_NilValue)
R_PreserveObject((e->traceback = tb));
}
