SEXP audio_wait(SEXP instance, SEXP timeout) {
if (instance == R_NilValue) { /* unlike other functions we allow NULL for a system-wide sleep without any event */
if (current_driver && current_driver->wait) return Rf_ScalarInteger(current_driver->wait(NULL, Rf_asReal(timeout)));
return Rf_ScalarInteger(fallback_wait(Rf_asReal(timeout)));
}
if (TYPEOF(instance) != EXTPTRSXP)
Rf_error("invalid audio instance");
audio_instance_t *p = (audio_instance_t *) EXTPTR_PTR(instance);
if (!p) Rf_error("invalid audio instance");
return Rf_ScalarInteger(p->driver->wait ? p->driver->wait(p, Rf_asReal(timeout)) : WAIT_ERROR);
}
static au_instance_t *audiounits_create_recorder(SEXP source, float rate, int chs, int flags) {
UInt32 propsize=0;
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 = (chs == 2) ? YES : NO;
propsize = sizeof(ap->inDev);
err = AudioHardwareGetProperty(kAudioHardwarePropertyDefaultInputDevice, &propsize, &ap->inDev);
if (err) {
free(ap);
Rf_error("unable to find default audio input (%08x)", err);
}
propsize = sizeof(ap->fmtIn);
err = AudioDeviceGetProperty(ap->inDev, 0, YES, kAudioDevicePropertyStreamFormat, &propsize, &ap->fmtIn);
if (err) {
free(ap);
Rf_error("unable to retrieve audio input format (%08x)", err);
}
/* Rprintf(" recording format: %f, chs: %d, fpp: %d, bpp: %d, bpf: %d, flags: %x\n", ap->fmtIn.mSampleRate, ap->fmtIn.mChannelsPerFrame, ap->fmtIn.mFramesPerPacket, ap->fmtIn.mBytesPerPacket, ap->fmtIn.mBytesPerFrame, ap->fmtIn.mFormatFlags); */
ap->srFrac = 1.0;
if (ap->fmtIn.mSampleRate != ap->sample_rate) ap->srFrac = ap->sample_rate / ap->fmtIn.mSampleRate;
ap->srRun = 0.0;
#if defined(MAC_OS_X_VERSION_10_5) && (MAC_OS_X_VERSION_MIN_REQUIRED>=MAC_OS_X_VERSION_10_5)
err = AudioDeviceCreateIOProcID(ap->inDev, inputRenderProc, ap, &ap->inIOProcID );
#else
err = AudioDeviceAddIOProc(ap->inDev, inputRenderProc, ap);
#endif
if (err) {
free(ap);
Rf_error("unable to register recording callback (%08x)", err);
}
R_PreserveObject(ap->source);
Rf_setAttrib(ap->source, Rf_install("rate"), Rf_ScalarInteger(rate)); /* we adjust the rate */
Rf_setAttrib(ap->source, Rf_install("bits"), Rf_ScalarInteger(16)); /* we say it's 16 because we don't know - float is always 32-bit */
Rf_setAttrib(ap->source, Rf_install("class"), Rf_mkString("audioSample"));
if (ap->stereo) {
SEXP dim = Rf_allocVector(INTSXP, 2);
INTEGER(dim)[0] = 2;
INTEGER(dim)[1] = LENGTH(ap->source) / 2;
Rf_setAttrib(ap->source, R_DimSymbol, dim);
}
return ap;
}
/**
* Return the version of the libgit2 library being currently used.
*
* @return A VECSXP with major, minor and rev.
*/
SEXP git2r_libgit2_version(void)
{
const char *names[] = {"major", "minor", "rev", ""};
SEXP version;
int major, minor, rev;
git_libgit2_version(&major, &minor, &rev);
PROTECT(version = Rf_mkNamed(VECSXP, names));
SET_VECTOR_ELT(version, 0, Rf_ScalarInteger(major));
SET_VECTOR_ELT(version, 1, Rf_ScalarInteger(minor));
SET_VECTOR_ELT(version, 2, Rf_ScalarInteger(rev));
UNPROTECT(1);
return version;
}
SEXP audio_instance_type(SEXP instance) {
if (TYPEOF(instance) != EXTPTRSXP)
Rf_error("invalid audio instance");
audio_instance_t *p = (audio_instance_t *) EXTPTR_PTR(instance);
if (!p) Rf_error("invalid audio instance");
return Rf_ScalarInteger(p->kind);
}
/* R_mpc_cmp - Comparison function for MPC objects.
*
* Ops.mpc.R includes code to coerce complex numbers or numerics from
* e2 into MPC objects for this comparison since the MPC library only
* supports comparison against other MPC objects or integers.
*
* Arguments:
* e1: SEXP for an mpc type.
* e2: SEXP for an mpc type, or integer.
* Return value:
* True if e1 == e2.
*/
SEXP R_mpc_cmp(SEXP e1, SEXP e2) {
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
return(Rf_ScalarInteger(mpc_cmp(*z1, *z2)));
} else if (Rf_isInteger(e2)) {
return(Rf_ScalarInteger(mpc_cmp_si(*z1,
INTEGER(e2)[0])));
} else {
Rf_error("Invalid operand for mpc cmp.");
}
} else {
Rf_error("Invalid operand for mpc cmp.");
}
}
SEXP audio_instance_address(SEXP instance) {
if (TYPEOF(instance) != EXTPTRSXP)
Rf_error("invalid audio instance");
audio_instance_t *p = (audio_instance_t *) EXTPTR_PTR(instance);
if (!p) Rf_error("invalid audio instance");
return Rf_ScalarInteger((int) p);
}
static SEXP rc_reply2R(redisReply *reply) {
SEXP res;
int i, n;
/* Rprintf("rc_reply2R, type=%d\n", reply->type); */
switch (reply->type) {
case REDIS_REPLY_STATUS:
case REDIS_REPLY_ERROR:
res = PROTECT(Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(res, 0, Rf_mkCharLenCE(reply->str, reply->len, CE_UTF8));
UNPROTECT(1);
return res;
case REDIS_REPLY_STRING:
res = Rf_allocVector(RAWSXP, reply->len);
memcpy(RAW(res), reply->str, reply->len);
return res;
case REDIS_REPLY_NIL:
return R_NilValue;
case REDIS_REPLY_INTEGER:
if (reply->integer > INT_MAX || reply->integer < INT_MIN)
return Rf_ScalarReal((double) reply->integer);
return Rf_ScalarInteger((int) reply->integer);
case REDIS_REPLY_ARRAY:
res = PROTECT(Rf_allocVector(VECSXP, reply->elements));
n = reply->elements;
for (i = 0; i < n; i++)
SET_VECTOR_ELT(res, i, rc_reply2R(reply->element[i]));
UNPROTECT(1);
return res;
default:
Rf_error("unknown redis reply type %d", reply->type);
}
return R_NilValue;
}
void omxGlobal::reportProgressStr(const char *msg)
{
ProtectedSEXP theCall(Rf_allocVector(LANGSXP, 3));
SETCAR(theCall, Rf_install("imxReportProgress"));
ProtectedSEXP Rmsg(Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(Rmsg, 0, Rf_mkChar(msg));
SETCADR(theCall, Rmsg);
SETCADDR(theCall, Rf_ScalarInteger(previousReportLength));
Rf_eval(theCall, R_GlobalEnv);
}
SEXP getBoundBox(Agraph_t *g) {
/* Determine the graphviz determiend bounding box and */
/* assign it to the appropriate Ragraph structure */
SEXP bbClass, xyClass, curBB, LLXY, URXY;
xyClass = MAKE_CLASS("xyPoint");
bbClass = MAKE_CLASS("boundingBox");
PROTECT(curBB = NEW_OBJECT(bbClass));
PROTECT(LLXY = NEW_OBJECT(xyClass));
PROTECT(URXY = NEW_OBJECT(xyClass));
SET_SLOT(LLXY,Rf_install("x"),Rf_ScalarInteger(g->u.bb.LL.x));
SET_SLOT(LLXY,Rf_install("y"),Rf_ScalarInteger(g->u.bb.LL.y));
SET_SLOT(URXY,Rf_install("x"),Rf_ScalarInteger(g->u.bb.UR.x));
SET_SLOT(URXY,Rf_install("y"),Rf_ScalarInteger(g->u.bb.UR.y));
SET_SLOT(curBB,Rf_install("botLeft"), LLXY);
SET_SLOT(curBB,Rf_install("upRight"), URXY);
UNPROTECT(3);
return(curBB);
}
SEXP R_mongo_restore(SEXP con, SEXP ptr_col, SEXP verb) {
bool verbose = Rf_asLogical(verb);
mongoc_collection_t *col = r2col(ptr_col);
bson_reader_t *reader = bson_reader_new_from_handle(con, bson_reader_feed, bson_reader_finalize);
mongoc_bulk_operation_t *bulk = NULL;
const bson_t *b;
bson_error_t err;
int count = 0;
int i = 0;
bool done = false;
bson_t reply;
while(!done) {
//note: default opts uses {ordered:true}
bulk = mongoc_collection_create_bulk_operation_with_opts(col, NULL);
for(i = 0; i < 1000; i++){
if(!(b = bson_reader_read (reader, &done)))
break;
mongoc_bulk_operation_insert (bulk, b);
count++;
}
if(i == 0)
break;
if(!mongoc_bulk_operation_execute (bulk, &reply, &err)){
bson_reader_destroy(reader);
mongoc_bulk_operation_destroy (bulk);
Rf_error(err.message);
}
if(verbose)
Rprintf("\rRestored %d records...", count);
}
if(verbose)
Rprintf("\rDone! Inserted total of %d records.\n", count);
if (!done)
Rf_warning("Failed to read all documents.\n");
bson_reader_destroy(reader);
mongoc_bulk_operation_destroy (bulk);
return Rf_ScalarInteger(count);
}
void omxComputeNumericDeriv::reportResults(FitContext *fc, MxRList *slots, MxRList *result)
{
if (!numParams || !(fc->wanted & (FF_COMPUTE_HESSIAN | FF_COMPUTE_IHESSIAN | FF_COMPUTE_GRADIENT))) return;
if (wantHessian) {
SEXP calculatedHessian;
Rf_protect(calculatedHessian = Rf_allocMatrix(REALSXP, numParams, numParams));
fc->copyDenseHess(REAL(calculatedHessian));
result->add("calculatedHessian", calculatedHessian);
}
MxRList out;
out.add("probeCount", Rf_ScalarInteger(totalProbeCount));
if (detail && recordDetail) {
Eigen::Map< Eigen::ArrayXi > Gsymmetric(LOGICAL(VECTOR_ELT(detail, 0)), numParams);
out.add("gradient", detail);
}
slots->add("output", out.asR());
}
ssize_t bson_reader_feed(void *handle, void *buf, size_t count){
int err;
SEXP con = (SEXP) handle;
SEXP x = PROTECT(Rf_lcons(Rf_ScalarInteger(count), R_NilValue));
SEXP y = PROTECT(Rf_lcons(Rf_mkString("raw"), x));
SEXP z = PROTECT(Rf_lcons(con, y));
SEXP readbin = PROTECT(Rf_install("readBin"));
SEXP call = PROTECT(Rf_lcons(readbin, z));
SEXP res = PROTECT(R_tryEval(call, R_GlobalEnv, &err));
// check if readBin succeeded
if(err || TYPEOF(res) != RAWSXP)
Rf_error("Mongo reader failed to read data from connection. (%d)", err);
// Copy data into buf
memcpy(buf, RAW(res), Rf_length(res));
UNPROTECT(6);
return Rf_length(res);
}
SEXP extract_impl(SEXP x, SEXP index, SEXP missing) {
if (!Rf_isVector(x)) {
Rf_errorcall(R_NilValue, "`x` must be a vector (not a %s)",
Rf_type2char(TYPEOF(x)));
}
if (TYPEOF(index) != VECSXP) {
Rf_errorcall(R_NilValue, "`index` must be a vector (not a %s)",
Rf_type2char(TYPEOF(index)));
}
int n = Rf_length(index);
for (int i = 0; i < n; ++i) {
SEXP index_i = VECTOR_ELT(index, i);
int offset = find_offset(x, index_i, i);
if (offset < 0)
return missing;
switch(TYPEOF(x)) {
case NILSXP: return missing;
case LGLSXP: x = Rf_ScalarLogical(LOGICAL(x)[offset]); break;
case INTSXP: x = Rf_ScalarInteger(INTEGER(x)[offset]); break;
case REALSXP: x = Rf_ScalarReal(REAL(x)[offset]); break;
case STRSXP: x = Rf_ScalarString(STRING_ELT(x, offset)); break;
case VECSXP: x = VECTOR_ELT(x, offset); break;
default:
Rf_errorcall(R_NilValue,
"Don't know how to index object of type %s at level %i",
Rf_type2char(TYPEOF(x)), i + 1
);
}
}
return x;
}
SEXP Rgraphviz_buildEdgeList(SEXP nodes, SEXP edgeL, SEXP edgeMode,
SEXP subGList, SEXP edgeNames,
SEXP removedEdges, SEXP edgeAttrs,
SEXP defAttrs) {
int x, y, curEle = 0;
SEXP from;
SEXP peList;
SEXP peClass, curPE;
SEXP curAttrs, curFrom, curTo, curWeights = R_NilValue;
SEXP attrNames;
SEXP tmpToSTR, tmpWtSTR, tmpW;
SEXP curSubG, subGEdgeL, subGEdges, subGNodes, elt;
SEXP recipAttrs, newRecipAttrs, recipAttrNames, newRecipAttrNames;
SEXP goodEdgeNames;
SEXP toName;
SEXP recipPE;
char *edgeName, *recipName;
int i, j, k, nSubG;
int nEdges = length(edgeNames);
if (length(edgeL) == 0)
return(allocVector(VECSXP, 0));
PROTECT(peClass = MAKE_CLASS("pEdge"));
PROTECT(peList = allocVector(VECSXP, nEdges -
length(removedEdges)));
PROTECT(goodEdgeNames = allocVector(STRSXP, nEdges -
length(removedEdges)));
PROTECT(curAttrs = allocVector(VECSXP, 3));
PROTECT(attrNames = allocVector(STRSXP, 3));
/* TODO: get rid of attrs "arrowhead"/"arrowtail", "dir" is sufficient */
SET_STRING_ELT(attrNames, 0, mkChar("arrowhead"));
SET_STRING_ELT(attrNames, 1, mkChar("weight"));
SET_STRING_ELT(attrNames, 2, mkChar("dir"));
setAttrib(curAttrs, R_NamesSymbol, attrNames);
PROTECT(from = getAttrib(edgeL, R_NamesSymbol));
nSubG = length(subGList);
/* For each edge, create a new object of class pEdge */
/* and then assign the 'from' and 'to' strings as */
/* as well as the default attrs (arrowhead & weight) */
for (x = 0; x < length(from); x++) {
PROTECT(curFrom = allocVector(STRSXP, 1));
SET_STRING_ELT(curFrom, 0, STRING_ELT(from, x));
if (length(VECTOR_ELT(edgeL, x)) == 0)
error("Invalid edgeList element given to buildEdgeList in Rgraphviz, is NULL");
PROTECT(curTo = coerceVector(VECTOR_ELT(VECTOR_ELT(edgeL, x), 0),
INTSXP));
if (length(VECTOR_ELT(edgeL, x)) > 1) {
curWeights = VECTOR_ELT(VECTOR_ELT(edgeL, x), 1);
}
if (curWeights == R_NilValue || (length(curWeights) != length(curTo))) {
curWeights = allocVector(REALSXP, length(curTo));
for (i = 0; i < length(curWeights); i++)
REAL(curWeights)[i] = 1;
}
PROTECT(curWeights);
for (y = 0; y < length(curTo); y++) {
PROTECT(toName = STRING_ELT(from, INTEGER(curTo)[y]-1));
edgeName = (char *)malloc((strlen(STR(curFrom))+
strlen(CHAR(toName)) + 2) *
sizeof(char));
sprintf(edgeName, "%s~%s", STR(curFrom), CHAR(toName));
/* See if this edge is a removed edge */
for (i = 0; i < length(removedEdges); i++) {
if (strcmp(CHAR(STRING_ELT(edgeNames,
INTEGER(removedEdges)[i]-1)),
edgeName) == 0)
break;
}
if (i < length(removedEdges)) {
/* This edge is to be removed */
if (strcmp(STR(edgeMode), "directed") == 0) {
/* Find the recip and add 'open' to tail */
recipName = (char *)malloc((strlen(STR(curFrom))+
strlen(CHAR(toName)) + 2) *
sizeof(char));
sprintf(recipName, "%s~%s", CHAR(toName), STR(curFrom));
for (k = 0; k < curEle; k++) {
if (strcmp(CHAR(STRING_ELT(goodEdgeNames, k)),
recipName) == 0)
break;
}
free(recipName);
PROTECT(recipPE = VECTOR_ELT(peList, k));
recipAttrs = GET_SLOT(recipPE, Rf_install("attrs"));
recipAttrNames = getAttrib(recipAttrs,
R_NamesSymbol);
/* We need to add this to the current set of
recipAttrs, so create a new list which is one
element longer and copy everything over, adding
the new element */
PROTECT(newRecipAttrs = allocVector(VECSXP,
length(recipAttrs)+1));
PROTECT(newRecipAttrNames = allocVector(STRSXP,
length(recipAttrNames)+1));
for (j = 0; j < length(recipAttrs); j++) {
if ( !strcmp(CHAR(STRING_ELT(recipAttrNames, j)), "dir") )
SET_VECTOR_ELT(newRecipAttrs, j, mkString("both"));
else
SET_VECTOR_ELT(newRecipAttrs, j,
VECTOR_ELT(recipAttrs, j));
SET_STRING_ELT(newRecipAttrNames, j,
STRING_ELT(recipAttrNames, j));
}
SET_VECTOR_ELT(newRecipAttrs, j, mkString("open"));
SET_STRING_ELT(newRecipAttrNames, j, mkChar("arrowtail"));
setAttrib(newRecipAttrs, R_NamesSymbol, newRecipAttrNames);
SET_SLOT(recipPE, Rf_install("attrs"), newRecipAttrs);
SET_VECTOR_ELT(peList, k, recipPE);
UNPROTECT(3);
}
UNPROTECT(1);
continue;
}
PROTECT(tmpToSTR = allocVector(STRSXP, 1));
PROTECT(curPE = NEW_OBJECT(peClass));
SET_SLOT(curPE, Rf_install("from"), curFrom);
SET_STRING_ELT(tmpToSTR, 0, toName);
SET_SLOT(curPE, Rf_install("to"), tmpToSTR);
if (strcmp(STR(edgeMode), "directed") == 0)
{
SET_VECTOR_ELT(curAttrs, 0, mkString("open"));
SET_VECTOR_ELT(curAttrs, 2, mkString("forward"));
}
else
{
SET_VECTOR_ELT(curAttrs, 0, mkString("none"));
SET_VECTOR_ELT(curAttrs, 2, mkString("none"));
}
PROTECT(tmpWtSTR = allocVector(STRSXP, 1));
PROTECT(tmpW = Rf_ScalarReal(REAL(curWeights)[y]));
SET_STRING_ELT(tmpWtSTR, 0, asChar(tmpW));
UNPROTECT(1);
SET_VECTOR_ELT(curAttrs, 1, tmpWtSTR);
SET_SLOT(curPE, Rf_install("attrs"), curAttrs);
SET_STRING_ELT(goodEdgeNames, curEle, mkChar(edgeName));
SET_VECTOR_ELT(peList, curEle, curPE);
curEle++;
for (i = 0; i < nSubG; i++) {
curSubG = getListElement(VECTOR_ELT(subGList, i), "graph");
subGEdgeL = GET_SLOT(curSubG, Rf_install("edgeL"));
subGNodes = GET_SLOT(curSubG, Rf_install("nodes"));
elt = getListElement(subGEdgeL, STR(curFrom));
if (elt == R_NilValue)
continue;
/* Extract out the edges */
subGEdges = VECTOR_ELT(elt, 0);
for (j = 0; j < length(subGEdges); j++) {
int subGIdx = INTEGER(subGEdges)[j]-1;
int graphIdx = INTEGER(curTo)[y]-1;
if(strcmp(CHAR(STRING_ELT(subGNodes, subGIdx)),CHAR(STRING_ELT(nodes, graphIdx))) == 0)
break;
}
if (j == length(subGEdges))
continue;
/* If we get here, then this edge is in subG 'i' */
SET_SLOT(curPE, Rf_install("subG"), Rf_ScalarInteger(i+1));
/* Only one subgraph per edge */
break;
}
free(edgeName);
UNPROTECT(4);
}
UNPROTECT(3);
}
setAttrib(peList, R_NamesSymbol, goodEdgeNames);
peList = assignAttrs(edgeAttrs, peList, defAttrs);
UNPROTECT(6);
return(peList);
}
SEXP flatten_impl(SEXP x) {
if (TYPEOF(x) != VECSXP) {
stop_bad_type(x, "a list", NULL, ".x");
}
int m = Rf_length(x);
// Determine output size and check type
int n = 0;
int has_names = 0;
SEXP x_names = PROTECT(Rf_getAttrib(x, R_NamesSymbol));
for (int j = 0; j < m; ++j) {
SEXP x_j = VECTOR_ELT(x, j);
if (!is_vector(x_j) && x_j != R_NilValue) {
stop_bad_element_type(x_j, j + 1, "a vector", NULL, ".x");
}
n += Rf_length(x_j);
if (!has_names) {
if (!Rf_isNull(Rf_getAttrib(x_j, R_NamesSymbol))) {
// Sub-element is named
has_names = 1;
} else if (Rf_length(x_j) == 1 && !Rf_isNull(x_names)) {
// Element is a "scalar" and has name in parent
SEXP name = STRING_ELT(x_names, j);
if (name != NA_STRING && strcmp(CHAR(name), "") != 0)
has_names = 1;
}
}
}
SEXP out = PROTECT(Rf_allocVector(VECSXP, n));
SEXP names = PROTECT(Rf_allocVector(STRSXP, n));
if (has_names)
Rf_setAttrib(out, R_NamesSymbol, names);
int i = 0;
for (int j = 0; j < m; ++j) {
SEXP x_j = VECTOR_ELT(x, j);
int n_j = Rf_length(x_j);
SEXP names_j = PROTECT(Rf_getAttrib(x_j, R_NamesSymbol));
int has_names_j = !Rf_isNull(names_j);
for (int k = 0; k < n_j; ++k, ++i) {
switch(TYPEOF(x_j)) {
case LGLSXP: SET_VECTOR_ELT(out, i, Rf_ScalarLogical(LOGICAL(x_j)[k])); break;
case INTSXP: SET_VECTOR_ELT(out, i, Rf_ScalarInteger(INTEGER(x_j)[k])); break;
case REALSXP: SET_VECTOR_ELT(out, i, Rf_ScalarReal(REAL(x_j)[k])); break;
case CPLXSXP: SET_VECTOR_ELT(out, i, Rf_ScalarComplex(COMPLEX(x_j)[k])); break;
case STRSXP: SET_VECTOR_ELT(out, i, Rf_ScalarString(STRING_ELT(x_j, k))); break;
case RAWSXP: SET_VECTOR_ELT(out, i, Rf_ScalarRaw(RAW(x_j)[k])); break;
case VECSXP: SET_VECTOR_ELT(out, i, VECTOR_ELT(x_j, k)); break;
default:
Rf_error("Internal error: `flatten_impl()` should have failed earlier");
}
if (has_names) {
if (has_names_j) {
SET_STRING_ELT(names, i, has_names_j ? STRING_ELT(names_j, k) : Rf_mkChar(""));
} else if (n_j == 1) {
SET_STRING_ELT(names, i, !Rf_isNull(x_names) ? STRING_ELT(x_names, j) : Rf_mkChar(""));
}
}
if (i % 1024 == 0)
R_CheckUserInterrupt();
}
UNPROTECT(1);
}
UNPROTECT(3);
return out;
}
SEXP getEdgeLocs(Agraph_t *g) {
SEXP outList, curCP, curEP, pntList, pntSet, curXY, curLab;
SEXP epClass, cpClass, xyClass, labClass;
Agnode_t *node, *head;
Agedge_t *edge;
char *tmpString;
bezier bez;
int nodes;
int i,k,l,pntLstEl;
int curEle = 0;
epClass = MAKE_CLASS("AgEdge");
cpClass = MAKE_CLASS("BezierCurve");
xyClass = MAKE_CLASS("xyPoint");
labClass = MAKE_CLASS("AgTextLabel");
/* tmpString is used to convert a char to a char* w/ labels */
tmpString = (char *)R_alloc(2, sizeof(char));
if (tmpString == NULL) error("Allocation error in getEdgeLocs");
PROTECT(outList = allocVector(VECSXP, agnedges(g)));
nodes = agnnodes(g);
node = agfstnode(g);
for (i = 0; i < nodes; i++) {
edge = agfstout(g, node);
while (edge != NULL && edge->u.spl != NULL) {
PROTECT(curEP = NEW_OBJECT(epClass));
bez = edge->u.spl->list[0];
PROTECT(pntList = allocVector(VECSXP, ((bez.size-1)/3)));
pntLstEl = 0;
/* There are really (bez.size-1)/3 sets of control */
/* points, with the first set containing teh first 4 */
/* points, and then every other set starting with the */
/* last point from the previous set and then the next 3 */
for (k = 1; k < bez.size; k += 3) {
PROTECT(curCP = NEW_OBJECT(cpClass));
PROTECT(pntSet = allocVector(VECSXP, 4));
for (l = -1; l < 3; l++) {
PROTECT(curXY = NEW_OBJECT(xyClass));
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(bez.list[k+l].x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(bez.list[k+l].y));
SET_ELEMENT(pntSet, l+1, curXY);
UNPROTECT(1);
}
SET_SLOT(curCP, Rf_install("cPoints"), pntSet);
SET_ELEMENT(pntList, pntLstEl++, curCP);
UNPROTECT(2);
}
SET_SLOT(curEP, Rf_install("splines"), pntList);
/* get the sp and ep */
PROTECT(curXY = NEW_OBJECT(xyClass));
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(bez.sp.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(bez.sp.y));
SET_SLOT(curEP, Rf_install("sp"), curXY);
UNPROTECT(1);
PROTECT(curXY = NEW_OBJECT(xyClass));
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(bez.ep.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(bez.ep.y));
SET_SLOT(curEP, Rf_install("ep"), curXY);
UNPROTECT(1);
SET_SLOT(curEP, Rf_install("tail"), Rgraphviz_ScalarStringOrNull(node->name));
head = edge->head;
SET_SLOT(curEP, Rf_install("head"), Rgraphviz_ScalarStringOrNull(head->name));
/* TODO: clean up the use of attrs: dir, arrowhead, arrowtail.
* the following are for interactive plotting in R-env, not needed
* for output to files. The existing codes set "dir"-attr, but use
* "arrowhead"/"arrowtail" instead. Quite confusing.
*/
SET_SLOT(curEP, Rf_install("dir"), Rgraphviz_ScalarStringOrNull(agget(edge, "dir")));
SET_SLOT(curEP, Rf_install("arrowhead"), Rgraphviz_ScalarStringOrNull(agget(edge, "arrowhead")));
SET_SLOT(curEP, Rf_install("arrowtail"), Rgraphviz_ScalarStringOrNull(agget(edge, "arrowtail")));
SET_SLOT(curEP, Rf_install("arrowsize"), Rgraphviz_ScalarStringOrNull(agget(edge, "arrowsize")));
SET_SLOT(curEP, Rf_install("color"), Rgraphviz_ScalarStringOrNull(agget(edge, "color")));
/* get lty/lwd info */
if ( agget(edge, "lty") )
SET_SLOT(curEP, Rf_install("lty"), Rgraphviz_ScalarStringOrNull(agget(edge, "lty")));
if ( agget(edge, "lwd") )
SET_SLOT(curEP, Rf_install("lwd"), Rgraphviz_ScalarStringOrNull(agget(edge, "lwd")));
/* Get the label information */
if (edge->u.label != NULL) {
PROTECT(curLab = NEW_OBJECT(labClass));
SET_SLOT(curLab, Rf_install("labelText"),
Rgraphviz_ScalarStringOrNull(ED_label(edge)->text));
/* Get the X/Y location of the label */
PROTECT(curXY = NEW_OBJECT(xyClass));
#if GRAPHVIZ_MAJOR == 2 && GRAPHVIZ_MINOR > 20
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(ED_label(edge)->pos.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(ED_label(edge)->pos.y));
#else
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(edge->u.label->p.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(edge->u.label->p.y));
#endif
SET_SLOT(curLab, Rf_install("labelLoc"), curXY);
UNPROTECT(1);
snprintf(tmpString, 2, "%c",ED_label(edge)->u.txt.para->just);
SET_SLOT(curLab, Rf_install("labelJust"),
Rgraphviz_ScalarStringOrNull(tmpString));
SET_SLOT(curLab, Rf_install("labelWidth"),
Rf_ScalarInteger(ED_label(edge)->u.txt.para->width));
SET_SLOT(curLab, Rf_install("labelColor"),
Rgraphviz_ScalarStringOrNull(edge->u.label->fontcolor));
SET_SLOT(curLab, Rf_install("labelFontsize"), Rf_ScalarReal(edge->u.label->fontsize));
SET_SLOT(curEP, Rf_install("txtLabel"), curLab);
UNPROTECT(1);
}
SET_ELEMENT(outList, curEle++, curEP);
UNPROTECT(2);
edge = agnxtout(g, edge);
}
node = agnxtnode(g, node);
}
UNPROTECT(1);
return(outList);
}
SEXP getNodeLayouts(Agraph_t *g) {
Agnode_t *node;
SEXP outLst, nlClass, xyClass, curXY, curNL;
SEXP curLab, labClass;
int i, nodes;
char *tmpString;
if (g == NULL) error("getNodeLayouts passed a NULL graph");
nlClass = MAKE_CLASS("AgNode");
xyClass = MAKE_CLASS("xyPoint");
labClass = MAKE_CLASS("AgTextLabel");
/* tmpString is used to convert a char to a char* w/ labels */
tmpString = (char *)R_alloc(2, sizeof(char));
if (tmpString == NULL) error("Allocation error in getNodeLayouts");
nodes = agnnodes(g);
node = agfstnode(g);
PROTECT(outLst = allocVector(VECSXP, nodes));
for (i = 0; i < nodes; i++) {
PROTECT(curNL = NEW_OBJECT(nlClass));
PROTECT(curXY = NEW_OBJECT(xyClass));
SET_SLOT(curXY,Rf_install("x"),Rf_ScalarInteger(node->u.coord.x));
SET_SLOT(curXY,Rf_install("y"),Rf_ScalarInteger(node->u.coord.y));
SET_SLOT(curNL,Rf_install("center"),curXY);
SET_SLOT(curNL,Rf_install("height"),Rf_ScalarInteger(node->u.ht));
SET_SLOT(curNL,Rf_install("rWidth"),Rf_ScalarInteger(node->u.rw));
SET_SLOT(curNL,Rf_install("lWidth"),Rf_ScalarInteger(node->u.lw));
SET_SLOT(curNL,Rf_install("name"), Rgraphviz_ScalarStringOrNull(node->name));
SET_SLOT(curNL, Rf_install("color"), Rgraphviz_ScalarStringOrNull(agget(node, "color")));
SET_SLOT(curNL, Rf_install("fillcolor"), Rgraphviz_ScalarStringOrNull(agget(node, "fillcolor")));
SET_SLOT(curNL, Rf_install("shape"), Rgraphviz_ScalarStringOrNull(agget(node, "shape")));
SET_SLOT(curNL, Rf_install("style"), Rgraphviz_ScalarStringOrNull(agget(node, "style")));
PROTECT(curLab = NEW_OBJECT(labClass));
if (ND_label(node) == NULL) {
} else if (ND_label(node)->u.txt.para != NULL) {
SET_SLOT(curLab, Rf_install("labelText"),
Rgraphviz_ScalarStringOrNull(ND_label(node)->text));
snprintf(tmpString, 2, "%c",ND_label(node)->u.txt.para->just);
SET_SLOT(curLab, Rf_install("labelJust"), Rgraphviz_ScalarStringOrNull(tmpString));
SET_SLOT(curLab, Rf_install("labelWidth"),
Rf_ScalarInteger(ND_label(node)->u.txt.para->width));
/* Get the X/Y location of the label */
PROTECT(curXY = NEW_OBJECT(xyClass));
#if GRAPHVIZ_MAJOR == 2 && GRAPHVIZ_MINOR > 20
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(ND_label(node)->pos.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(ND_label(node)->pos.y));
#else
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(node->u.label->p.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(node->u.label->p.y));
#endif
SET_SLOT(curLab, Rf_install("labelLoc"), curXY);
UNPROTECT(1);
SET_SLOT(curLab, Rf_install("labelColor"), Rgraphviz_ScalarStringOrNull(node->u.label->fontcolor));
SET_SLOT(curLab, Rf_install("labelFontsize"), Rf_ScalarReal(node->u.label->fontsize));
}
SET_SLOT(curNL, Rf_install("txtLabel"), curLab);
SET_ELEMENT(outLst, i, curNL);
node = agnxtnode(g,node);
UNPROTECT(3);
}
UNPROTECT(1);
return(outLst);
}
SEXP transpose_impl(SEXP x, SEXP names_template) {
if (TYPEOF(x) != VECSXP)
Rf_errorcall(R_NilValue, "`.l` is not a list (%s)", Rf_type2char(TYPEOF(x)));
int n = Rf_length(x);
if (n == 0) {
return Rf_allocVector(VECSXP, 0);
}
int has_template = !Rf_isNull(names_template);
SEXP x1 = VECTOR_ELT(x, 0);
if (!Rf_isVector(x1))
Rf_errorcall(R_NilValue, "Element 1 is not a vector (%s)", Rf_type2char(TYPEOF(x1)));
int m = has_template ? Rf_length(names_template) : Rf_length(x1);
// Create space for output
SEXP out = PROTECT(Rf_allocVector(VECSXP, m));
SEXP names1 = Rf_getAttrib(x, R_NamesSymbol);
for (int j = 0; j < m; ++j) {
SEXP xj = PROTECT(Rf_allocVector(VECSXP, n));
if (!Rf_isNull(names1)) {
Rf_setAttrib(xj, R_NamesSymbol, names1);
}
SET_VECTOR_ELT(out, j, xj);
UNPROTECT(1);
}
SEXP names2 = has_template ? names_template : Rf_getAttrib(x1, R_NamesSymbol);
if (!Rf_isNull(names2)) {
Rf_setAttrib(out, R_NamesSymbol, names2);
}
// Fill output
for (int i = 0; i < n; ++i) {
SEXP xi = VECTOR_ELT(x, i);
if (!Rf_isVector(xi))
Rf_errorcall(R_NilValue, "Element %i is not a vector (%s)", i + 1, Rf_type2char(TYPEOF(x1)));
// find mapping between names and index. Use -1 to indicate not found
SEXP names_i = Rf_getAttrib(xi, R_NamesSymbol);
SEXP index;
if (!Rf_isNull(names2) && !Rf_isNull(names_i)) {
index = PROTECT(Rf_match(names_i, names2, 0));
// Rf_match returns 1-based index; convert to 0-based for C
for (int i = 0; i < m; ++i) {
INTEGER(index)[i] = INTEGER(index)[i] - 1;
}
} else {
index = PROTECT(Rf_allocVector(INTSXP, m));
int mi = Rf_length(xi);
if (m != mi) {
Rf_warningcall(R_NilValue, "Element %i has length %i not %i", i + 1, mi, m);
}
for (int i = 0; i < m; ++i) {
INTEGER(index)[i] = (i < mi) ? i : -1;
}
}
int* pIndex = INTEGER(index);
for (int j = 0; j < m; ++j) {
int pos = pIndex[j];
if (pos == -1)
continue;
switch(TYPEOF(xi)) {
case LGLSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarLogical(LOGICAL(xi)[pos]));
break;
case INTSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarInteger(INTEGER(xi)[pos]));
break;
case REALSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarReal(REAL(xi)[pos]));
break;
case STRSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarString(STRING_ELT(xi, pos)));
break;
case VECSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, VECTOR_ELT(xi, pos));
break;
default:
Rf_errorcall(R_NilValue, "Unsupported type %s", Rf_type2char(TYPEOF(xi)));
}
}
UNPROTECT(1);
}
UNPROTECT(1);
return out;
}
// adapted from https://github.com/armgong/RJulia/blob/master/src/R_Julia.c
SEXP jr_scalar(jl_value_t *tt)
{
SEXP ans = R_NilValue;
double z;
// float64, int64, int32 are most common, so put them in the front
if (jl_is_float64(tt))
{
PROTECT(ans = Rf_ScalarReal(jl_unbox_float64(tt)));
UNPROTECT(1);
}
else if (jl_is_int32(tt))
{
PROTECT(ans = Rf_ScalarInteger(jl_unbox_int32(tt)));
UNPROTECT(1);
}
else if (jl_is_int64(tt))
{
z = (double)jl_unbox_int64(tt);
if (in_int32_range(z))
PROTECT(ans = Rf_ScalarInteger((int32_t)jl_unbox_int64(tt)));
else
PROTECT(ans = Rf_ScalarReal(z));
UNPROTECT(1);
}
else if (jl_is_bool(tt))
{
PROTECT(ans = Rf_ScalarLogical(jl_unbox_bool(tt)));
UNPROTECT(1);
}
else if (jl_is_int8(tt))
{
PROTECT(ans = Rf_ScalarInteger(jl_unbox_int8(tt)));
UNPROTECT(1);
}
else if (jl_is_uint8(tt))
{
PROTECT(ans = Rf_ScalarInteger(jl_unbox_uint8(tt)));
UNPROTECT(1);
}
else if (jl_is_int16(tt))
{
PROTECT(ans = Rf_ScalarInteger(jl_unbox_int16(tt)));
UNPROTECT(1);
}
else if (jl_is_uint16(tt))
{
PROTECT(ans = Rf_ScalarInteger(jl_unbox_uint16(tt)));
UNPROTECT(1);
}
else if (jl_is_uint32(tt))
{
z = (double)jl_unbox_uint32(tt);
if (in_int32_range(z))
PROTECT(ans = Rf_ScalarInteger((int32_t)jl_unbox_uint32(tt)));
else
PROTECT(ans = Rf_ScalarReal(z));
UNPROTECT(1);
}
else if (jl_is_uint64(tt))
{
z = (double)jl_unbox_int64(tt);
if (in_int32_range(z))
PROTECT(ans = Rf_ScalarInteger((int32_t)jl_unbox_uint64(tt)));
else
PROTECT(ans = Rf_ScalarReal(z));
UNPROTECT(1);
}
else if (jl_is_float32(tt))
{
PROTECT(ans = Rf_ScalarReal(jl_unbox_float32(tt)));
UNPROTECT(1);
}
else if (jl_is_utf8_string(tt))
{
PROTECT(ans = Rf_allocVector(STRSXP, 1));
SET_STRING_ELT(ans, 0, Rf_mkCharCE(jl_string_data(tt), CE_UTF8));
UNPROTECT(1);
}
else if (jl_is_ascii_string(tt))
{
PROTECT(ans = Rf_ScalarString(Rf_mkChar(jl_string_data(tt))));
UNPROTECT(1);
}
return ans;
}
/** Fetch information on an encoding
*
* @param enc either NULL or "" for default encoding,
* or one string with encoding name
* @return R list object with many components (see R doc for details)
*
* @version 0.1-?? (Marek Gagolewski)
*
* @version 0.2-1 (Marek Gagolewski)
* use StriUcnv; make StriException-friendly
*
* @version 0.3-1 (Marek Gagolewski, 2014-11-04)
* Issue #112: str_prepare_arg* retvals were not PROTECTed from gc
*/
SEXP stri_enc_info(SEXP enc)
{
const char* selected_enc = stri__prepare_arg_enc(enc, "enc", true/*default ok*/); /* this is R_alloc'ed */
STRI__ERROR_HANDLER_BEGIN(0)
StriUcnv uconv_obj(selected_enc);
//uconv_obj.setCallBackSubstitute(); // restore default callbacks (no warning)
UConverter* uconv = uconv_obj.getConverter(false);
UErrorCode status = U_ZERO_ERROR;
// get the list of available standards
vector<const char*> standards = StriUcnv::getStandards();
R_len_t standards_n = (R_len_t)standards.size();
// alloc output list
SEXP vals;
SEXP names;
const int nval = standards_n+2+5;
STRI__PROTECT(names = Rf_allocVector(STRSXP, nval));
SET_STRING_ELT(names, 0, Rf_mkChar("Name.friendly"));
SET_STRING_ELT(names, 1, Rf_mkChar("Name.ICU"));
for (R_len_t i=0; i<standards_n; ++i) {
if (standards[i])
SET_STRING_ELT(names, i+2, Rf_mkChar((string("Name.")+standards[i]).c_str()));
}
SET_STRING_ELT(names, nval-5, Rf_mkChar("ASCII.subset"));
SET_STRING_ELT(names, nval-4, Rf_mkChar("Unicode.1to1"));
SET_STRING_ELT(names, nval-3, Rf_mkChar("CharSize.8bit"));
SET_STRING_ELT(names, nval-2, Rf_mkChar("CharSize.min"));
SET_STRING_ELT(names, nval-1, Rf_mkChar("CharSize.max"));
STRI__PROTECT(vals = Rf_allocVector(VECSXP, nval));
// get canonical (ICU) name
status = U_ZERO_ERROR;
const char* canname = ucnv_getName(uconv, &status);
if (U_FAILURE(status) || !canname) {
SET_VECTOR_ELT(vals, 1, Rf_ScalarString(NA_STRING));
Rf_warning(MSG__ENC_ERROR_GETNAME);
}
else {
SET_VECTOR_ELT(vals, 1, stri__make_character_vector_char_ptr(1, canname));
// friendly name
const char* frname = StriUcnv::getFriendlyName(canname);
if (frname) SET_VECTOR_ELT(vals, 0, stri__make_character_vector_char_ptr(1, frname));
else SET_VECTOR_ELT(vals, 0, Rf_ScalarString(NA_STRING));
// has ASCII as its subset?
SET_VECTOR_ELT(vals, nval-5, Rf_ScalarLogical((int)uconv_obj.hasASCIIsubset()));
// min,max character size, is 8bit?
int mincharsize = (int)ucnv_getMinCharSize(uconv);
int maxcharsize = (int)ucnv_getMaxCharSize(uconv);
int is8bit = (mincharsize==1 && maxcharsize == 1);
SET_VECTOR_ELT(vals, nval-3, Rf_ScalarLogical(is8bit));
SET_VECTOR_ELT(vals, nval-2, Rf_ScalarInteger(mincharsize));
SET_VECTOR_ELT(vals, nval-1, Rf_ScalarInteger(maxcharsize));
// is there a one-to-one correspondence with Unicode?
if (!is8bit)
SET_VECTOR_ELT(vals, nval-4, Rf_ScalarLogical(NA_LOGICAL));
else
SET_VECTOR_ELT(vals, nval-4, Rf_ScalarLogical((int)uconv_obj.is1to1Unicode()));
// other standard names
for (R_len_t i=0; i<standards_n; ++i) {
if (!standards[i]) continue;
status = U_ZERO_ERROR;
const char* stdname = ucnv_getStandardName(canname, standards[i], &status);
if (U_FAILURE(status) || !stdname)
SET_VECTOR_ELT(vals, i+2, Rf_ScalarString(NA_STRING));
else
SET_VECTOR_ELT(vals, i+2, stri__make_character_vector_char_ptr(1, stdname));
}
}
Rf_setAttrib(vals, R_NamesSymbol, names);
STRI__UNPROTECT_ALL
return vals;
STRI__ERROR_HANDLER_END({/* no special action on error */})
}
/* return the length of the vector as the number of elements.
This is more efficient than length(unclass(x)). */
SEXP clFloat_length(SEXP fObject) {
return Rf_ScalarInteger(LENGTH(fObject) / sizeof(float));
}