SEXP
R_xslGetGlobalVariableNames(SEXP r_ctxt)
{
xmlXPathParserContextPtr ctxt = NULL;
xsltTransformContextPtr xslCtxt;
int n;
SEXP ans;
RXMLHashScannerInfo data;
ctxt = (xmlXPathParserContextPtr) R_ExternalPtrAddr(r_ctxt);
xslCtxt = xsltXPathGetTransformContext(ctxt);
if(!xslCtxt || !xslCtxt->globalVars)
return(NEW_CHARACTER(0));
n = xmlHashSize(xslCtxt->globalVars);
PROTECT(ans = NEW_CHARACTER(n));
data.els = ans;
data.i = 0;
xmlHashScan(xslCtxt->globalVars, R_getKeyNames, &data);
UNPROTECT(1);
return(ans);
}
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);
}
/* Autoload default packages and names from autoloads.h
*
* This function behaves in almost every way like
* R's autoload:
* function (name, package, reset = FALSE, ...)
* {
* if (!reset && exists(name, envir = .GlobalEnv, inherits = FALSE))
* stop("an object with that name already exists")
* m <- match.call()
* m[[1]] <- as.name("list")
* newcall <- eval(m, parent.frame())
* newcall <- as.call(c(as.name("autoloader"), newcall))
* newcall$reset <- NULL
* if (is.na(match(package, .Autoloaded)))
* assign(".Autoloaded", c(package, .Autoloaded), env = .AutoloadEnv)
* do.call("delayedAssign", list(name, newcall, .GlobalEnv,
* .AutoloadEnv))
* invisible()
* }
*
* What's missing is the updating of the string vector .Autoloaded with the list
* of packages, which by my code analysis is useless and only for informational
* purposes.
*
*/
void autoloads(void){
SEXP da, dacall, al, alcall, AutoloadEnv, name, package;
int i,j, idx=0, errorOccurred, ptct;
/* delayedAssign call*/
PROTECT(da = Rf_findFun(Rf_install("delayedAssign"), R_GlobalEnv));
PROTECT(AutoloadEnv = Rf_findVar(Rf_install(".AutoloadEnv"), R_GlobalEnv));
if (AutoloadEnv == R_NilValue){
fprintf(stderr,"%s: Cannot find .AutoloadEnv!\n", programName);
exit(1);
}
PROTECT(dacall = allocVector(LANGSXP,5));
SETCAR(dacall,da);
/* SETCAR(CDR(dacall),name); */ /* arg1: assigned in loop */
/* SETCAR(CDR(CDR(dacall)),alcall); */ /* arg2: assigned in loop */
SETCAR(CDR(CDR(CDR(dacall))),R_GlobalEnv); /* arg3 */
SETCAR(CDR(CDR(CDR(CDR(dacall)))),AutoloadEnv); /* arg3 */
/* autoloader call */
PROTECT(al = Rf_findFun(Rf_install("autoloader"), R_GlobalEnv));
PROTECT(alcall = allocVector(LANGSXP,3));
SET_TAG(alcall, R_NilValue); /* just like do_ascall() does */
SETCAR(alcall,al);
/* SETCAR(CDR(alcall),name); */ /* arg1: assigned in loop */
/* SETCAR(CDR(CDR(alcall)),package); */ /* arg2: assigned in loop */
ptct = 5;
for(i = 0; i < packc; i++){
idx += (i != 0)? packobjc[i-1] : 0;
for (j = 0; j < packobjc[i]; j++){
/*printf("autload(%s,%s)\n",packobj[idx+j],pack[i]);*/
PROTECT(name = NEW_CHARACTER(1));
PROTECT(package = NEW_CHARACTER(1));
SET_STRING_ELT(name, 0, COPY_TO_USER_STRING(packobj[idx+j]));
SET_STRING_ELT(package, 0, COPY_TO_USER_STRING(pack[i]));
/* Set up autoloader call */
PROTECT(alcall = allocVector(LANGSXP,3));
SET_TAG(alcall, R_NilValue); /* just like do_ascall() does */
SETCAR(alcall,al);
SETCAR(CDR(alcall),name);
SETCAR(CDR(CDR(alcall)),package);
/* Setup delayedAssign call */
SETCAR(CDR(dacall),name);
SETCAR(CDR(CDR(dacall)),alcall);
R_tryEval(dacall,R_GlobalEnv,&errorOccurred);
if (errorOccurred){
fprintf(stderr,"%s: Error calling delayedAssign!\n", programName);
exit(1);
}
ptct += 3;
}
}
UNPROTECT(ptct);
}
SEXP SP_PREFIX(SpatialPolygons_validate_c)(SEXP obj) {
int pc=0;
int i, n;
SEXP pls, ans;
char *cls="Polygons";
PROTECT(pls = GET_SLOT(obj, install("polygons"))); pc++;
n = length(pls);
for (i=0; i<n; i++) {
if (strcmp(CHAR(STRING_ELT(getAttrib(VECTOR_ELT(pls, i),
R_ClassSymbol), 0)), cls) != 0) {
PROTECT(ans = NEW_CHARACTER(1)); pc++;
SET_STRING_ELT(ans, 0,
COPY_TO_USER_STRING("polygons slot contains non-Polygons object"));
UNPROTECT(pc);
return(ans);
}
}
if (n != length(GET_SLOT(obj, install("plotOrder")))) {
PROTECT(ans = NEW_CHARACTER(1)); pc++;
SET_STRING_ELT(ans, 0,
COPY_TO_USER_STRING("plotOrder and polygons differ in length"));
UNPROTECT(pc);
return(ans);
}
PROTECT(ans = NEW_LOGICAL(1)); pc++;
LOGICAL_POINTER(ans)[0] = TRUE;
UNPROTECT(pc);
return(ans);
}
SEXP RS_DBI_createNamedList(char **names, SEXPTYPE *types, int *lengths, int n) {
SEXP output, output_names, obj = R_NilValue;
int num_elem;
int j;
PROTECT(output = NEW_LIST(n));
PROTECT(output_names = NEW_CHARACTER(n));
for(j = 0; j < n; j++){
num_elem = lengths[j];
switch((int)types[j]){
case LGLSXP:
PROTECT(obj = NEW_LOGICAL(num_elem));
break;
case INTSXP:
PROTECT(obj = NEW_INTEGER(num_elem));
break;
case REALSXP:
PROTECT(obj = NEW_NUMERIC(num_elem));
break;
case STRSXP:
PROTECT(obj = NEW_CHARACTER(num_elem));
break;
case VECSXP:
PROTECT(obj = NEW_LIST(num_elem));
break;
default:
error("unsupported data type");
}
SET_ELEMENT(output, (int)j, obj);
SET_CHR_EL(output_names, j, mkChar(names[j]));
}
SET_NAMES(output, output_names);
UNPROTECT(n+2);
return(output);
}
SEXP scan_bam_template(SEXP rname, SEXP tag)
{
if (R_NilValue != tag)
if (!IS_CHARACTER(tag))
Rf_error("'tag' must be NULL or 'character()'");
SEXP tmpl = PROTECT(NEW_LIST(N_TMPL_ELTS));
SET_VECTOR_ELT(tmpl, QNAME_IDX, NEW_CHARACTER(0));
SET_VECTOR_ELT(tmpl, FLAG_IDX, NEW_INTEGER(0));
SET_VECTOR_ELT(tmpl, RNAME_IDX, rname);
SET_VECTOR_ELT(tmpl, STRAND_IDX, _tmpl_strand());
SET_VECTOR_ELT(tmpl, POS_IDX, NEW_INTEGER(0));
SET_VECTOR_ELT(tmpl, QWIDTH_IDX, NEW_INTEGER(0));
SET_VECTOR_ELT(tmpl, MAPQ_IDX, NEW_INTEGER(0));
SET_VECTOR_ELT(tmpl, CIGAR_IDX, NEW_CHARACTER(0));
SET_VECTOR_ELT(tmpl, MRNM_IDX, rname);
SET_VECTOR_ELT(tmpl, MPOS_IDX, NEW_INTEGER(0));
SET_VECTOR_ELT(tmpl, ISIZE_IDX, NEW_INTEGER(0));
SET_VECTOR_ELT(tmpl, SEQ_IDX, _tmpl_DNAStringSet());
SET_VECTOR_ELT(tmpl, QUAL_IDX, _tmpl_PhredQuality());
SET_VECTOR_ELT(tmpl, PARTITION_IDX, NEW_INTEGER(0));
SET_VECTOR_ELT(tmpl, MATES_IDX, NEW_INTEGER(0));
if (R_NilValue == tag) {
SET_VECTOR_ELT(tmpl, TAG_IDX, R_NilValue);
} else {
SET_VECTOR_ELT(tmpl, TAG_IDX, NEW_LIST(LENGTH(tag)));
SET_ATTR(VECTOR_ELT(tmpl, TAG_IDX), R_NamesSymbol, tag);
}
SEXP names = PROTECT(NEW_CHARACTER(N_TMPL_ELTS));
for (int i = 0; i < N_TMPL_ELTS; ++i)
SET_STRING_ELT(names, i, mkChar(TMPL_ELT_NMS[i]));
SET_ATTR(tmpl, R_NamesSymbol, names);
UNPROTECT(2);
return tmpl;
}
SEXP SP_PREFIX(Polygon_validate_c)(SEXP obj) {
int pc=0;
int n;
SEXP coords, labpt, ans;
coords = GET_SLOT(obj, install("coords"));
n = INTEGER_POINTER(getAttrib(coords, R_DimSymbol))[0];
if (NUMERIC_POINTER(coords)[0] != NUMERIC_POINTER(coords)[n-1]
|| NUMERIC_POINTER(coords)[n] != NUMERIC_POINTER(coords)[(2*n)-1]) {
PROTECT(ans = NEW_CHARACTER(1)); pc++;
SET_STRING_ELT(ans, 0,
COPY_TO_USER_STRING("ring not closed"));
UNPROTECT(pc);
return(ans);
}
labpt = GET_SLOT(obj, install("labpt"));
if (!R_FINITE(NUMERIC_POINTER(labpt)[0]) ||
!R_FINITE(NUMERIC_POINTER(labpt)[1])) {
PROTECT(ans = NEW_CHARACTER(1)); pc++;
SET_STRING_ELT(ans, 0,
COPY_TO_USER_STRING("infinite label point"));
UNPROTECT(pc);
return(ans);
}
PROTECT(ans = NEW_LOGICAL(1)); pc++;
LOGICAL_POINTER(ans)[0] = TRUE;
UNPROTECT(pc);
return(ans);
}
USER_OBJECT_
toRPointerWithFinalizer(gconstpointer val, const gchar *typeName, RPointerFinalizer finalizer)
{
USER_OBJECT_ ans;
USER_OBJECT_ r_finalizer = NULL_USER_OBJECT;
USER_OBJECT_ klass = NULL, rgtk_class;
int i = 0;
GType type = 0;
if(!val)
return(NULL_USER_OBJECT);
if (finalizer) {
PROTECT(r_finalizer = R_MakeExternalPtr(finalizer, NULL_USER_OBJECT, NULL_USER_OBJECT));
}
PROTECT(ans = R_MakeExternalPtr((gpointer)val, r_finalizer, NULL_USER_OBJECT));
if (finalizer) {
R_RegisterCFinalizer(ans, RGtk_finalizer);
}
if (typeName)
type = g_type_from_name(typeName);
if(type) {
if (G_TYPE_IS_INSTANTIATABLE(type) || G_TYPE_IS_INTERFACE(type))
type = G_TYPE_FROM_INSTANCE(val);
if (G_TYPE_IS_DERIVED(type)) {
setAttrib(ans, install("interfaces"), R_internal_getInterfaces(type));
PROTECT(klass = R_internal_getGTypeAncestors(type));
}
}
if (!klass && typeName) {
PROTECT(klass = asRString(typeName));
}
if (klass) { /* so much trouble just to add "RGtkObject" onto the end */
PROTECT(rgtk_class = NEW_CHARACTER(GET_LENGTH(klass)+1));
for (i = 0; i < GET_LENGTH(klass); i++)
SET_STRING_ELT(rgtk_class, i, STRING_ELT(klass, i));
} else {
PROTECT(rgtk_class = NEW_CHARACTER(1));
}
SET_STRING_ELT(rgtk_class, i, COPY_TO_USER_STRING("RGtkObject"));
SET_CLASS(ans, rgtk_class);
if (g_type_is_a(type, S_TYPE_G_OBJECT)) {
USER_OBJECT_ public_sym = install(".public");
setAttrib(ans, public_sym, findVar(public_sym, S_GOBJECT_GET_ENV(val)));
}
if (klass)
UNPROTECT(1);
if (finalizer)
UNPROTECT(1);
UNPROTECT(2);
return(ans);
}
void RS_DBI_allocOutput(SEXP output, RMySQLFields* flds, int num_rec, int expand) {
SEXP names, s_tmp;
int j;
int num_fields;
SEXPTYPE *fld_Sclass;
PROTECT(output);
num_fields = flds->num_fields;
if(expand){
for(j = 0; j < (int) num_fields; j++){
/* Note that in R-1.2.3 (at least) we need to protect SET_LENGTH */
s_tmp = LST_EL(output,j);
PROTECT(SET_LENGTH(s_tmp, num_rec));
SET_ELEMENT(output, j, s_tmp);
UNPROTECT(1);
}
UNPROTECT(1);
return;
}
fld_Sclass = flds->Sclass;
for(j = 0; j < (int) num_fields; j++){
switch((int)fld_Sclass[j]){
case LGLSXP:
SET_ELEMENT(output, j, NEW_LOGICAL(num_rec));
break;
case STRSXP:
SET_ELEMENT(output, j, NEW_CHARACTER(num_rec));
break;
case INTSXP:
SET_ELEMENT(output, j, NEW_INTEGER(num_rec));
break;
case REALSXP:
SET_ELEMENT(output, j, NEW_NUMERIC(num_rec));
break;
case VECSXP:
SET_ELEMENT(output, j, NEW_LIST(num_rec));
break;
default:
error("unsupported data type");
}
}
PROTECT(names = NEW_CHARACTER((int) num_fields));
for(j = 0; j< (int) num_fields; j++){
SET_CHR_EL(names,j, mkChar(flds->name[j]));
}
SET_NAMES(output, names);
UNPROTECT(2);
return;
}
void
RXSLT_callNamedFunction(const char *name, xmlXPathParserContextPtr ctxt, int nargs, int leaveAsRObject)
{
USER_OBJECT_ e, ans;
// xmlXPathObjectPtr obj;
int errorOccurred;
int i, j;
#if 0
PROTECT(e = allocVector(LANGSXP, 2));
SETCAR(e, Rf_install((char *) name));
SETCAR(CDR(e), tmp = NEW_CHARACTER(1));
obj = valuePop(ctxt);
SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING(xmlXPathCastToString(obj)));
#else
PROTECT(e = allocVector(LANGSXP, nargs+1));
SETCAR(e, Rf_install((char *) name));
#if 0
for(i = 0; i < nargs; i++) {
ans = CDR(e);
for(j = nargs-1; j > i ; j--) {
ans = CDR(ans);
}
SETCAR(ans, tmp = NEW_CHARACTER(1));
obj = valuePop(ctxt);
SET_STRING_ELT(tmp, 0, COPY_TO_USER_STRING(xmlXPathCastToString(obj)));
}
#else
for(i = 0; i < nargs; i++) {
ans = CDR(e);
for(j = nargs-1; j > i ; j--) {
ans = CDR(ans);
}
SETCAR(ans, convertFromXPath(ctxt, valuePop(ctxt)));
}
#endif
#endif
ans = R_tryEval(e, R_GlobalEnv, &errorOccurred);
if(errorOccurred) {
RXSLT_Error(ctxt, "error in call to R function");
} else {
PROTECT(ans);
valuePush(ctxt, convertToXPath(ctxt, ans));
UNPROTECT(1);
}
UNPROTECT(1);
return;
}
USER_OBJECT_
createSAX2AttributesList(const xmlChar **attributes, int nb_attributes, int nb_defaulted, const xmlChar *encoding)
{
int i;
const char **ptr;
USER_OBJECT_ attr_names;
USER_OBJECT_ attr_values;
USER_OBJECT_ nsURI, nsNames;
if(nb_attributes < 1)
return(NULL_USER_OBJECT);
PROTECT(attr_values = NEW_CHARACTER(nb_attributes));
PROTECT(attr_names = NEW_CHARACTER(nb_attributes));
PROTECT(nsURI = NEW_CHARACTER(nb_attributes));
PROTECT(nsNames = NEW_CHARACTER(nb_attributes));
ptr = (const char **) attributes; /*XXX */
for(i=0; i < nb_attributes; i++, ptr+=5) {
char *tmp;
int len;
len = (ptr[4] - ptr[3] + 1);
tmp = malloc(sizeof(char) * len);
if(!tmp) {
PROBLEM "Cannot allocate space for attribute of length %d", (int) (ptr[4] - ptr[3] + 2)
ERROR;
}
memcpy(tmp, ptr[3], ptr[4] - ptr[3]);
tmp[len-1] = '\0'; /*XXX*/
SET_STRING_ELT(attr_values, i, ENC_COPY_TO_USER_STRING(tmp));
free(tmp);
SET_STRING_ELT(attr_names, i, ENC_COPY_TO_USER_STRING(ptr[0]));
if(ptr[2]) {
SET_STRING_ELT(nsURI, i, ENC_COPY_TO_USER_STRING(ptr[2]));
if(ptr[1])
SET_STRING_ELT(nsNames, i, ENC_COPY_TO_USER_STRING(ptr[1]));
}
}
SET_NAMES(nsURI, nsNames);
SET_NAMES(attr_values, attr_names);
Rf_setAttrib(attr_values, Rf_install("namespaces"), nsURI);
UNPROTECT(4);
return(attr_values);
}
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);
}
SEXP
RClosureTable_callWithName(R_ObjectTableAction handlerType, const char * const name, R_ObjectTable *tb)
{
SEXP obj, fun, val, e;
int errorOccurred = FALSE;
obj = (SEXP) tb->privateData;
fun = RClosureTable_getFunction(obj, handlerType);
if(!fun || fun == R_NilValue) {
return(NEW_LOGICAL(1));
}
PROTECT(e = allocVector(LANGSXP,2));
SETCAR(e, fun);
SETCAR(CDR(e), val = NEW_CHARACTER(1));
SET_STRING_ELT(val, 0, COPY_TO_USER_STRING(name));
#ifndef TRY_EVAL
val = eval(e, R_GlobalEnv);
#else
val = R_tryEval(e, NULL, &errorOccurred);
#endif
if(errorOccurred) {
UNPROTECT(1);
return(R_UnboundValue);
}
UNPROTECT(1);
return(val);
}
SEXP checkCRSArgs(SEXP args) {
SEXP res;
projPJ pj;
PROTECT(res = NEW_LIST(2));
SET_VECTOR_ELT(res, 0, NEW_LOGICAL(1));
SET_VECTOR_ELT(res, 1, NEW_CHARACTER(1));
LOGICAL_POINTER(VECTOR_ELT(res, 0))[0] = FALSE;
if (!(pj = pj_init_plus(CHAR(STRING_ELT(args, 0))))) {
SET_STRING_ELT(VECTOR_ELT(res, 1), 0,
COPY_TO_USER_STRING(pj_strerrno(*pj_get_errno_ref())));
UNPROTECT(1);
return(res);
}
SET_STRING_ELT(VECTOR_ELT(res, 1), 0,
COPY_TO_USER_STRING(pj_get_def(pj, 0)));
LOGICAL_POINTER(VECTOR_ELT(res, 0))[0] = TRUE;
UNPROTECT(1);
return(res);
}
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 rgeos_GEOSversion(void) {
SEXP ans = NEW_CHARACTER(1);
SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING(GEOSversion()));
return(ans);
}
SEXP
R_Module_getNamedMDList(SEXP r_mod)
{
llvm::Module *mod = GET_REF(r_mod, Module);
const llvm::Module::NamedMDListType &node = mod->getNamedMDList();
int n = node.size();
R_xlen_t i = 0;
if(n == 0)
return(R_NilValue);
SEXP rans, names;
PROTECT(rans = NEW_LIST(n));
PROTECT(names = NEW_CHARACTER(n));
for(llvm::iplist<const llvm::NamedMDNode>::iterator it = node.begin(); it != node.end(); it++, i++) {
const llvm::NamedMDNode *cur = &(*it);
SET_STRING_ELT(names, i, mkChar(cur->getName().data()));
SET_VECTOR_ELT(rans, i, R_createRef(cur, "NamedMDNode"));
}
SET_NAMES(rans, names);
UNPROTECT(2);
return(rans);
}
SEXP wkt_to_p4s(SEXP wkt, SEXP esri) {
OGRSpatialReference hSRS = NULL;
char *pszSRS_P4 = NULL;
char **ppszInput = NULL;
SEXP ans;
ppszInput = CSLAddString(ppszInput, CHAR(STRING_ELT(wkt, 0)));
installErrorHandler();
if (hSRS.importFromWkt(ppszInput) != OGRERR_NONE) {
uninstallErrorHandlerAndTriggerError();
error("Can't parse WKT-style parameter string");
}
uninstallErrorHandlerAndTriggerError();
installErrorHandler();
if (INTEGER_POINTER(esri)[0] == 1) hSRS.morphFromESRI();
hSRS.exportToProj4(&pszSRS_P4);
uninstallErrorHandlerAndTriggerError();
PROTECT(ans=NEW_CHARACTER(1));
SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING(pszSRS_P4));
UNPROTECT(1);
return(ans);
}
SEXP
R_Module_getTargetTriple(SEXP r_module)
{
llvm::Module *mod = GET_REF(r_module, Module);
const char *str = mod->getTargetTriple().c_str();
return(str ? ScalarString(mkChar(str)) : NEW_CHARACTER(0));
}
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);
}
SEXP rph_tree_rename(SEXP treeVec, SEXP oldNamesP, SEXP newNamesP) {
int i, numtree = LENGTH(treeVec), treeIdx;
TreeNode *tr, *n;
SEXP result;
Hashtable *hash = hsh_new(20);
char *str;
for (i=0; i<LENGTH(oldNamesP); i++) {
str = smalloc((strlen(CHAR(STRING_ELT(newNamesP, i)))+1)*sizeof(char));
strcpy(str, CHAR(STRING_ELT(newNamesP, i)));
hsh_put(hash, CHAR(STRING_ELT(oldNamesP, i)), str);
}
PROTECT(result = NEW_CHARACTER(numtree));
for (treeIdx=0; treeIdx < numtree; treeIdx++) {
tr = rph_tree_new(STRING_ELT(treeVec, treeIdx));
// tr = tr_new_from_string(CHAR(STRING_ELT(treeVec, treeIdx)));
for (i=0; i<tr->nnodes; i++) {
n = lst_get_ptr(tr->nodes, i);
if (n->name[0] != '\0' &&
(str = hsh_get(hash, n->name)) != (char*)-1)
strcpy(n->name, str);
}
str = tr_to_string(tr, 1);
SET_STRING_ELT(result, treeIdx, mkChar(str));
}
UNPROTECT(1);
return result;
}
USER_OBJECT_
RS_GGOBI(getDisplayOptions)(USER_OBJECT_ which)
{
USER_OBJECT_ ans, names;
gint NumOptions = 8;
DisplayOptions *options;
if (GET_LENGTH(which) == 0)
options = GGOBI(getDefaultDisplayOptions)();
else {
displayd *display = toDisplay(which);
g_return_val_if_fail(GGOBI_IS_DISPLAY(display), NULL_USER_OBJECT);
options = &(display->options);
}
g_return_val_if_fail(options != NULL, NULL_USER_OBJECT);
PROTECT(ans = NEW_LOGICAL(NumOptions));
PROTECT(names = NEW_CHARACTER(NumOptions));
LOGICAL_DATA(ans)[DOPT_POINTS] = options->points_show_p;
SET_STRING_ELT(names, DOPT_POINTS, COPY_TO_USER_STRING("Show points"));
LOGICAL_DATA(ans)[DOPT_AXES] = options->axes_show_p;
SET_STRING_ELT(names, DOPT_AXES, COPY_TO_USER_STRING("Show axes"));
LOGICAL_DATA(ans)[DOPT_AXESLAB] = options->axes_label_p;
SET_STRING_ELT(names, DOPT_AXESLAB,
COPY_TO_USER_STRING("Show tour axes"));
LOGICAL_DATA(ans)[DOPT_AXESVALS] = options->axes_values_p;
SET_STRING_ELT(names, DOPT_AXESVALS,
COPY_TO_USER_STRING("Show axes labels"));
LOGICAL_DATA(ans)[DOPT_EDGES_U] = options->edges_undirected_show_p;
SET_STRING_ELT(names, DOPT_EDGES_U, COPY_TO_USER_STRING("Undirected edges"));
LOGICAL_DATA(ans)[DOPT_EDGES_A] = options->edges_arrowheads_show_p;
SET_STRING_ELT(names, DOPT_EDGES_A, COPY_TO_USER_STRING("Arrowheads"));
LOGICAL_DATA(ans)[DOPT_EDGES_D] = options->edges_directed_show_p;
SET_STRING_ELT(names, DOPT_EDGES_D, COPY_TO_USER_STRING("Directed edges"));
LOGICAL_DATA(ans)[DOPT_WHISKERS] = options->whiskers_show_p;
SET_STRING_ELT(names, DOPT_WHISKERS,
COPY_TO_USER_STRING("Show whiskers"));
/* unused
LOGICAL_DATA(ans)[5] = options->missings_show_p;
SET_STRING_ELT(names, 5, COPY_TO_USER_STRING("Missing Values"));
LOGICAL_DATA(ans)[8] = options->axes_center_p;
SET_STRING_ELT(names, 8, COPY_TO_USER_STRING("Center axes"));
LOGICAL_DATA(ans)[9] = options->double_buffer_p;
SET_STRING_ELT(names, 9, COPY_TO_USER_STRING("Double buffer"));
LOGICAL_DATA(ans)[10] = options->link_p;
SET_STRING_ELT(names, 10, COPY_TO_USER_STRING("Link"));
*/
SET_NAMES(ans, names);
UNPROTECT(2);
return(ans);
}
static SEXP make_LIST_from_ovenc_parts(SEXP Loffset, SEXP Roffset,
SEXP encoding)
{
SEXP ans, ans_names, ans_names_elt;
PROTECT(ans = NEW_LIST(3));
PROTECT(ans_names = NEW_CHARACTER(3));
PROTECT(ans_names_elt = mkChar("Loffset"));
SET_STRING_ELT(ans_names, 0, ans_names_elt);
UNPROTECT(1);
PROTECT(ans_names_elt = mkChar("Roffset"));
SET_STRING_ELT(ans_names, 1, ans_names_elt);
UNPROTECT(1);
PROTECT(ans_names_elt = mkChar("encoding"));
SET_STRING_ELT(ans_names, 2, ans_names_elt);
UNPROTECT(1);
SET_NAMES(ans, ans_names);
UNPROTECT(1);
SET_VECTOR_ELT(ans, 0, Loffset);
SET_VECTOR_ELT(ans, 1, Roffset);
SET_VECTOR_ELT(ans, 2, encoding);
UNPROTECT(1);
return ans;
}
USER_OBJECT_
R_internal_getGTypeHierarchy(GType type)
{
USER_OBJECT_ ans;
int n = 0;
GType orig = type;
while(type != 0 && type != G_TYPE_INVALID) {
type = g_type_parent(type);
n++;
}
PROTECT(ans = NEW_CHARACTER(n));
n = 0;
type = orig;
while(type != G_TYPE_INVALID) {
const char *val;
val = g_type_name(type);
SET_STRING_ELT(ans, n, COPY_TO_USER_STRING(val));
n++;
type = g_type_parent(type);
}
UNPROTECT(1);
return(ans);
}
SEXP
getAlternatives(tesseract::ResultIterator* ri, const char *word, float conf)
{
tesseract::ChoiceIterator ci_r(*ri);
int nels = 2;
while(ci_r.Next())
nels++;
SEXP ans, names;
PROTECT(ans = NEW_NUMERIC(nels));
PROTECT(names = NEW_CHARACTER(nels));
int i = 0;
SET_STRING_ELT(names, 0, Rf_mkChar(word));
REAL(ans)[0] = conf;
tesseract::ChoiceIterator ci(*ri);
for(i = 1; i < nels ; i++, ci.Next()) {
const char* choice = ci.GetUTF8Text();
conf = ci.Confidence();
if(choice)
SET_STRING_ELT(names, i, Rf_mkChar(choice));
REAL(ans)[i] = conf;
// delete [] choice;
}
SET_NAMES(ans, names);
UNPROTECT(2);
return(ans);
}
USER_OBJECT_
R_libxmlTypeTable_names(USER_OBJECT_ table, USER_OBJECT_ s_elType)
{
xmlHashTablePtr t;
int n = 0, ctr = 0;
int getElements = GET_LENGTH(s_elType) > 0;
HashGatherer d = {0, NULL_USER_OBJECT, NULL_USER_OBJECT, NULL};
t = R_getExternalRef(table, NULL); /* R_libxmlTypeTableGetRef(table); */
n = xmlHashSize(t);
PROTECT(d.names = NEW_CHARACTER(n)); ctr++;
if(getElements) {
PROTECT(d.els = NEW_LIST(n)); ctr++;
d.elType = (char *) CHAR_DEREF(STRING_ELT(s_elType, 0));
}
xmlHashScan(t, getKeys, &d);
if(getElements)
SET_NAMES(d.els, d.names);
else
d.els = d.names;
UNPROTECT(ctr);
return(d.els);
}
SEXP
R_Module_getGlobalList(SEXP r_module)
{
llvm::Module *mod = GET_REF(r_module, Module);
int n, i = 0;
SEXP rans, names;
llvm::iplist<llvm::GlobalVariable> &funclist = mod->getGlobalList();
n = funclist.size();
PROTECT(rans = NEW_LIST(n));
PROTECT(names = NEW_CHARACTER(n));
for(llvm::iplist<const llvm::GlobalVariable>::iterator it = funclist.begin(); it != funclist.end(); it++, i++)
{
const llvm::GlobalVariable *curfunc = &(*it);
SET_STRING_ELT(names, i, mkChar(curfunc->getName().data()));
SET_VECTOR_ELT(rans, i, R_createRef(curfunc, "GlobalVariable"));
}
SET_NAMES(rans, names);
UNPROTECT(2);
return(rans);
}
SEXP ogrAutoIdentifyEPSG(SEXP p4s) {
OGRSpatialReference hSRS = NULL;
OGRErr thisOGRErr;
SEXP ans;
installErrorHandler();
if (hSRS.importFromProj4(CHAR(STRING_ELT(p4s, 0))) != OGRERR_NONE) {
uninstallErrorHandlerAndTriggerError();
error("Can't parse PROJ.4-style parameter string");
}
uninstallErrorHandlerAndTriggerError();
PROTECT(ans=NEW_CHARACTER(1));
installErrorHandler();
thisOGRErr = hSRS.AutoIdentifyEPSG();
uninstallErrorHandlerAndTriggerError();
if (thisOGRErr == OGRERR_NONE) {
installErrorHandler();
SET_STRING_ELT(ans, 0,
COPY_TO_USER_STRING(hSRS.GetAuthorityCode(NULL)));
uninstallErrorHandlerAndTriggerError();
} else if (thisOGRErr == OGRERR_UNSUPPORTED_SRS) {
SET_STRING_ELT(ans, 0,
COPY_TO_USER_STRING("OGRERR_UNSUPPORTED_SRS"));
}
UNPROTECT(1);
return(ans);
}
/* open a connection with the same parameters used for in
* conHandle
*/
Con_Handle *
RS_PostgreSQL_cloneConnection(Con_Handle * conHandle)
{
S_EVALUATOR Mgr_Handle * mgrHandle;
RS_DBI_connection *con;
RS_PostgreSQL_conParams *conParams;
s_object *con_params;
/* get connection params used to open existing connection */
con = RS_DBI_getConnection(conHandle);
conParams = con->conParams;
mgrHandle = RS_DBI_asMgrHandle(MGR_ID(conHandle));
/* Connection parameters need to be put into a 8-element character
* vector to be passed to the RS_PostgreSQL_newConnection() function.
*/
MEM_PROTECT(con_params = NEW_CHARACTER((Sint) 7));
SET_CHR_EL(con_params, 0, C_S_CPY(conParams->user));
SET_CHR_EL(con_params, 1, C_S_CPY(conParams->password));
SET_CHR_EL(con_params, 2, C_S_CPY(conParams->host));
SET_CHR_EL(con_params, 3, C_S_CPY(conParams->dbname));
SET_CHR_EL(con_params, 4, C_S_CPY(conParams->port));
SET_CHR_EL(con_params, 5, C_S_CPY(conParams->tty));
SET_CHR_EL(con_params, 6, C_S_CPY(conParams->options));
MEM_UNPROTECT(1);
return RS_PostgreSQL_newConnection(mgrHandle, con_params);
}
SEXP rph_tree_scale(SEXP treeStr, SEXP scaleP, SEXP nodeStr,
SEXP includeLeadingP) {
TreeNode *tr = rph_tree_new(treeStr);
double scale = NUMERIC_VALUE(scaleP);
char *newTreeStr;
SEXP result;
if (nodeStr != R_NilValue) {
TreeNode *n;
int includeLeading=LOGICAL_VALUE(includeLeadingP);
n = tr_get_node(tr, CHARACTER_VALUE(nodeStr));
if (n == NULL) {
tr_name_ancestors(tr);
n = tr_get_node(tr, CHARACTER_VALUE(nodeStr));
if (n == NULL)
die("No node named %s in %s\n", CHARACTER_VALUE(nodeStr),
CHARACTER_VALUE(treeStr));
}
tr_scale_subtree(tr, n, scale, includeLeading);
}
else tr_scale(tr, scale);
newTreeStr = tr_to_string(tr, 1);
PROTECT(result = NEW_CHARACTER(1));
SET_STRING_ELT(result, 0, mkChar(newTreeStr));
UNPROTECT(1);
return result;
}
