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 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);
}
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);
}
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);
}
/* 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);
}
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);
}
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_
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);
}
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);
}
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);
}
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);
}
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
RGDAL_GetMetadata(SEXP sDataset, SEXP tag) {
char **papszMetadata;
SEXP ans;
int i, n, pc=0;
GDALDataset *pDataset = getGDALDatasetPtr(sDataset);
installErrorHandler();
if (tag == R_NilValue) {
papszMetadata = pDataset->GetMetadata( NULL );
} else {
papszMetadata = pDataset->GetMetadata(CHAR(STRING_ELT(tag, 0)));
}
uninstallErrorHandlerAndTriggerError();
if (CSLCount(papszMetadata) == 0) return(R_NilValue);
for (n=0; papszMetadata[n] != NULL; n++);
PROTECT(ans = NEW_CHARACTER(n)); pc++;
for (i=0; i<n; i++)
SET_STRING_ELT(ans, i, COPY_TO_USER_STRING(papszMetadata[i]));
UNPROTECT(pc);
return(ans);
}
void
R_getKeyNames(void *el, void *data, xmlChar *name)
{
RXMLHashScannerInfo *info = ( RXMLHashScannerInfo *) data;
SET_STRING_ELT(info->els, info->i, COPY_TO_USER_STRING(name));
info->i++;
}
int
loadXSLPackage(void)
{
USER_OBJECT_ e, fun, tmp;
int isError;
PROTECT(fun = Rf_findFun(Rf_install("library"), R_GlobalEnv));
PROTECT(e = allocVector(LANGSXP, 2));
SETCAR(e, fun);
SETCAR(CDR(e), tmp = NEW_CHARACTER(1));
SET_VECTOR_ELT(tmp, 0, COPY_TO_USER_STRING("Sxslt"));
R_tryEval(e, R_GlobalEnv, &isError);
if(isError) {
Rf_error("Couldn't load Sxslt package. Check the setting of R_LIBS");
/*
fprintf(stderr, "Couldn't load Sxslt package. Check the setting of R_LIBS\n");
fflush(stderr);
*/
}
UNPROTECT(2);
return(TRUE);
}
int source(char *file){
SEXP expr, s, f, p;
int errorOccurred;
/* Find source function */
s = Rf_findFun(Rf_install("source"), R_GlobalEnv);
PROTECT(s);
/* Make file argument */
PROTECT(f = NEW_CHARACTER(1));
SET_STRING_ELT(f, 0, COPY_TO_USER_STRING(file));
/* Make print.eval argument */
PROTECT(p = NEW_LOGICAL(1));
LOGICAL_DATA(p)[0] = (verbose)? TRUE : FALSE;
/* expression source(f,print.eval=p) */
PROTECT(expr = allocVector(LANGSXP,3));
SETCAR(expr,s);
SETCAR(CDR(expr),f);
SETCAR(CDR(CDR(expr)), p);
SET_TAG(CDR(CDR(expr)), Rf_install("print.eval"));
errorOccurred=0;
R_tryEval(expr,NULL,&errorOccurred);
UNPROTECT(4);
return errorOccurred;
}
/* changed to return proj4 string 20060212 RSB */
SEXP
RGDAL_GetProjectionRef(SEXP sDataset) {
OGRSpatialReference oSRS;
char *pszSRS_WKT = NULL;
SEXP ans;
GDALDataset *pDataset = getGDALDatasetPtr(sDataset);
installErrorHandler();
pszSRS_WKT = (char*) pDataset->GetProjectionRef();
uninstallErrorHandlerAndTriggerError();
installErrorHandler();
oSRS.importFromWkt( &pszSRS_WKT );
oSRS.exportToProj4( &pszSRS_WKT );
uninstallErrorHandlerAndTriggerError();
PROTECT(ans = NEW_CHARACTER(1));
SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING(pszSRS_WKT));
installErrorHandler();
CPLFree( pszSRS_WKT );
uninstallErrorHandlerAndTriggerError();
UNPROTECT(1);
return(ans);
}
SEXP rgeos_node(SEXP env, SEXP obj) {
SEXP ans, id;
int pc=0;
GEOSContextHandle_t GEOShandle = getContextHandle(env);
SEXP p4s = GET_SLOT(obj, install("proj4string"));
GEOSGeom geom = rgeos_convert_R2geos(env, obj);
// int type = GEOSGeomTypeId_r(GEOShandle, geom);
//Rprintf("type: %d, %s\n", type, GEOSGeomType_r(GEOShandle, geom));
GEOSGeom res = GEOSNode_r(GEOShandle, geom);
// type = GEOSGeomTypeId_r(GEOShandle, res);
int ng = GEOSGetNumGeometries_r(GEOShandle, res);
//Rprintf("ng: %d, type: %d, %s\n", ng, type, GEOSGeomType_r(GEOShandle, res));
char buf[BUFSIZ];
PROTECT(id = NEW_CHARACTER(ng)); pc++;
for (int i=0; i<ng; i++) {
sprintf(buf, "%d", i);
SET_STRING_ELT(id, i, COPY_TO_USER_STRING(buf));
}
GEOSGeom_destroy_r(GEOShandle, geom);
ans = rgeos_convert_geos2R(env, res, p4s, id);
UNPROTECT(pc);
return(ans);
}
/*
This assumes that `val' is actually a Perl Hash table
and that elementType identifies a _primitive_ Perl
type and that all the elements in the table are of
that type. This then creates an S vector of
the corresponding type and populates it with the
elements of the table and puts the names of the elements
as the names of the S vector.
*/
USER_OBJECT_
fromHomogeneousTable(SV *val, svtype elementType)
{
USER_OBJECT_ ans, names;
SV *av, *el;
I32 len;
char *key;
int n, i;
dTHX;
if(SvROK(val))
av = SvRV(val) ;
else
av = val;
n = hv_iterinit((HV *) av);
PROTECT(ans = PerlAllocHomogeneousVector(n, elementType));
PROTECT(names = NEW_CHARACTER(n));
for(i = 0; i < n; i++) {
el = hv_iternextsv((HV *) av, &key, &len);
if(el) {
PerlAddHomogeneousElement(el, i, ans, elementType);
}
if(key && key[0]) {
SET_STRING_ELT(names, i, COPY_TO_USER_STRING(key));
}
}
SET_NAMES(ans, names);
UNPROTECT(2);
return(ans);
}
/*
Loop over all the key-value pairs and convert
them to string and USER_OBJECT_ and put the latter
into an R/S LIST and use the vector of keys as the names.
*/
USER_OBJECT_
fromPerlHV(HV *table, unsigned int depth)
{
I32 len;
char *key;
SV *el;
I32 n, i;
Rboolean sameType;
svtype elType;
dTHX;
USER_OBJECT_ names, ans;
sameType = isHomogeneous((SV*)table, &elType);
if(sameType && isPerlPrimitiveType(elType, (SV *)table)) {
return(fromHomogeneousTable((SV *) table, elType));
}
n = hv_iterinit(table);
i = 0;
PROTECT(names = NEW_CHARACTER(n));
PROTECT(ans = NEW_LIST(n));
while(i < n) {
el = hv_iternextsv(table, &key, &len);
if(key == NULL)
break;
SET_VECTOR_ELT(ans, i, fromPerl(el, TRUE));
SET_STRING_ELT(names, i, COPY_TO_USER_STRING(key));
i++;
}
SET_NAMES(ans, names);
UNPROTECT(2);
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);
}
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 rgeos_GEOSversion(void) {
SEXP ans = NEW_CHARACTER(1);
SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING(GEOSversion()));
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);
}
SEXP SP_PREFIX(bboxCalcR_c)(SEXP pls) {
SEXP ans, dim, dimnames, Pl, crds;
double UX=-DBL_MAX, LX=DBL_MAX, UY=-DBL_MAX, LY=DBL_MAX;
int i, j, k, n, npls, npl, pc=0;
double x, y;
npls = length(pls);
for (i=0; i<npls; i++) {
Pl = GET_SLOT(VECTOR_ELT(pls, i), install("Polygons"));
npl = length(Pl);
for (j=0; j<npl; j++) {
crds = GET_SLOT(VECTOR_ELT(Pl, j), install("coords"));
n = INTEGER_POINTER(getAttrib(crds, R_DimSymbol))[0];
for (k=0; k<n; k++) {
x = NUMERIC_POINTER(crds)[k];
y = NUMERIC_POINTER(crds)[k+n];
if (x > UX) UX = x;
if (y > UY) UY = y;
if (x < LX) LX = x;
if (y < LY) LY = y;
}
}
}
PROTECT(ans = NEW_NUMERIC(4)); pc++;
NUMERIC_POINTER(ans)[0] = LX;
NUMERIC_POINTER(ans)[1] = LY;
NUMERIC_POINTER(ans)[2] = UX;
NUMERIC_POINTER(ans)[3] = UY;
PROTECT(dim = NEW_INTEGER(2)); pc++;
INTEGER_POINTER(dim)[0] = 2;
INTEGER_POINTER(dim)[1] = 2;
setAttrib(ans, R_DimSymbol, dim);
PROTECT(dimnames = NEW_LIST(2)); pc++;
SET_VECTOR_ELT(dimnames, 0, NEW_CHARACTER(2));
SET_STRING_ELT(VECTOR_ELT(dimnames, 0), 0, COPY_TO_USER_STRING("x"));
SET_STRING_ELT(VECTOR_ELT(dimnames, 0), 1, COPY_TO_USER_STRING("y"));
SET_VECTOR_ELT(dimnames, 1, NEW_CHARACTER(2));
SET_STRING_ELT(VECTOR_ELT(dimnames, 1), 0, COPY_TO_USER_STRING("min"));
SET_STRING_ELT(VECTOR_ELT(dimnames, 1), 1, COPY_TO_USER_STRING("max"));
setAttrib(ans, R_DimNamesSymbol, dimnames);
UNPROTECT(pc);
return(ans);
}
SEXP R_G_get_cygwinstring() {
SEXP ans;
PROTECT(ans=NEW_CHARACTER(1));
SET_STRING_ELT(ans, 0,
COPY_TO_USER_STRING(G_get_cygwinstring()));
UNPROTECT(1);
return(ans);
}
SEXP Rshapeinfo1(SEXP shpname)
{
SEXP res, nms;
SHPHandle hSHP;
int nShapeType, nEntities, i, pc=0;
double adfMinBound[4], adfMaxBound[4];
PROTECT(res = NEW_LIST(5)); pc++;
PROTECT(nms = NEW_CHARACTER(5)); pc++;
SET_STRING_ELT(nms, 0, COPY_TO_USER_STRING("fname"));
SET_STRING_ELT(nms, 1, COPY_TO_USER_STRING("type"));
SET_STRING_ELT(nms, 2, COPY_TO_USER_STRING("entities"));
SET_STRING_ELT(nms, 3, COPY_TO_USER_STRING("minbounds"));
SET_STRING_ELT(nms, 4, COPY_TO_USER_STRING("maxbounds"));
setAttrib(res, R_NamesSymbol, nms);
SET_VECTOR_ELT(res, 0, NEW_CHARACTER(1));
SET_VECTOR_ELT(res, 1, NEW_INTEGER(1));
SET_VECTOR_ELT(res, 2, NEW_INTEGER(1));
SET_VECTOR_ELT(res, 3, NEW_NUMERIC(4));
SET_VECTOR_ELT(res, 4, NEW_NUMERIC(4));
SET_STRING_ELT(VECTOR_ELT(res, 0), 0, STRING_ELT(shpname, 0));
/* const char *pszPlus; */
/* -------------------------------------------------------------------- */
/* Open the passed shapefile. */
/* -------------------------------------------------------------------- */
hSHP = SHPOpen(CHAR(STRING_ELT(shpname, 0)), "rb" );
if( hSHP == NULL ) error("Error opening SHP file");
/* -------------------------------------------------------------------- */
/* Print out the file bounds. */
/* -------------------------------------------------------------------- */
SHPGetInfo( hSHP, &nEntities, &nShapeType, adfMinBound, adfMaxBound );
INTEGER_POINTER(VECTOR_ELT(res, 1))[0] = nShapeType;
INTEGER_POINTER(VECTOR_ELT(res, 2))[0] = nEntities;
for (i=0; i<4; i++) {
NUMERIC_POINTER(VECTOR_ELT(res, 3))[i] = adfMinBound[i];
NUMERIC_POINTER(VECTOR_ELT(res, 4))[i] = adfMaxBound[i];
}
SHPClose( hSHP );
UNPROTECT(pc);
return(res);
}
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);
}
static void
getKeys(void *el, void *data, xmlChar *name)
{
HashGatherer *d = (HashGatherer *)data;
SET_STRING_ELT(d->names, d->pos, COPY_TO_USER_STRING(name));
if(d->elType) {
SET_VECTOR_ELT(d->els, d->pos, R_makeRefObject(el, d->elType));
}
d->pos++;
}
SEXP SP_PREFIX(Polygons_validate_c)(SEXP obj) {
int pc=0;
int i, n;
SEXP Pls, labpt, ans;
char *cls="Polygon";
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-Polygon 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);
}
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);
}
