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