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 RGDAL_GetGeoTransform(SEXP sxpDataset) { GDALDataset *pDataset = getGDALDatasetPtr(sxpDataset); SEXP sxpGeoTrans = allocVector(REALSXP, 6); SEXP ceFail = NEW_LOGICAL(1); LOGICAL_POINTER(ceFail)[0] = FALSE; installErrorHandler(); CPLErr err = pDataset->GetGeoTransform(REAL(sxpGeoTrans)); if (err == CE_Failure) { REAL(sxpGeoTrans)[0] = 0; // x-origin ul REAL(sxpGeoTrans)[1] = 1; // x-resolution (pixel width) REAL(sxpGeoTrans)[2] = 0; // x-oblique REAL(sxpGeoTrans)[3] = (double) pDataset->GetRasterYSize(); // y-origin ul; 091028 REAL(sxpGeoTrans)[4] = 0; // y-oblique REAL(sxpGeoTrans)[5] = -1; // y-resolution (pixel height); 091028 added sign LOGICAL_POINTER(ceFail)[0] = TRUE; } setAttrib(sxpGeoTrans, install("CE_Failure"), ceFail); uninstallErrorHandlerAndTriggerError(); return(sxpGeoTrans); }
SEXP do_mchoice_equals(SEXP x, SEXP y) { int x_len = LENGTH(x); /* length of x vector */ int y_len = LENGTH(y); /* length of y vector */ SEXP ans; /* Logical return vector */ int nfound = 0; /* number of matches found */ int i,j, comp; /* iterators */ size_t slen; char *str_ptr; /* copy of the x string element */ const char *str; S_EVALUATOR if(!IS_INTEGER(y) || y_len == 0) PROBLEM "y must be an integer vector of at least length one." ERROR; PROTECT(ans = NEW_LOGICAL(x_len)); for(i=0; i < x_len; ++i) { nfound = 0; str = translateCharUTF8(STRING_ELT(x, i)); slen = strlen(str) + 1; /* if length of x element is zero or NA no posible match */ if(STRING_ELT(x, i) == NA_STRING) { SET_NA_LGL(LOGICAL_POINTER(ans)[i]); continue; } if(slen == 0) { LOGICAL_POINTER(ans)[i] = 0; continue; } str_ptr = Hmisc_AllocStringBuffer((slen) * sizeof(char), &cbuff); strncpy(str_ptr, str, slen); str_ptr[slen] = '\0'; while(str_ptr != NULL && nfound < y_len) { comp = get_next_mchoice(&str_ptr); for(j=0; j < y_len; j++) { if(comp == INTEGER_POINTER(y)[j]) { nfound++; break; } } } if(nfound < y_len) LOGICAL_POINTER(ans)[i] = 0; else LOGICAL_POINTER(ans)[i] = 1; } Hmisc_FreeStringBuffer(&cbuff); UNPROTECT(1); return(ans); }
SEXP RGDAL_CPL_RECODE_ICONV(void) { SEXP ans; PROTECT(ans=NEW_LOGICAL(1)); #ifdef CPL_RECODE_ICONV LOGICAL_POINTER(ans)[0] = TRUE; #else /* CPL_RECODE_ICONV */ LOGICAL_POINTER(ans)[0] = FALSE; #endif /* CPL_RECODE_ICONV */ UNPROTECT(1); return(ans); }
SEXP rgeos_miscfunc(SEXP env, SEXP obj, SEXP byid, p_miscfunc miscfunc) { SEXP ans; GEOSContextHandle_t GEOShandle = getContextHandle(env); GEOSGeom geom = rgeos_convert_R2geos(env, obj); int type = GEOSGeomTypeId_r(GEOShandle, geom); int n = (LOGICAL_POINTER(byid)[0] && type == GEOS_GEOMETRYCOLLECTION) ? GEOSGetNumGeometries_r(GEOShandle, geom) : 1; int pc=0; PROTECT(ans = NEW_NUMERIC(n)); pc++; GEOSGeom curgeom = geom; for(int i=0; i<n; i++) { if ( n > 1) { curgeom = (GEOSGeom) GEOSGetGeometryN_r(GEOShandle, geom, i); if (curgeom == NULL) error("rgeos_miscfunc: unable to get subgeometries"); } double val; if (!miscfunc(GEOShandle, curgeom, &val)) error("rgeos_miscfunc: unable to calculate"); NUMERIC_POINTER(ans)[i] = val; } GEOSGeom_destroy_r(GEOShandle, geom); UNPROTECT(pc); return(ans); }
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); }
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 isGDALObjPtrNULL(SEXP sxpObj) { SEXP sxpHandle = getObjHandle(sxpObj); SEXP res; PROTECT(res = NEW_LOGICAL(1)); LOGICAL_POINTER(res)[0] = FALSE; void *extPtr = R_ExternalPtrAddr(sxpHandle); if (extPtr == NULL) LOGICAL_POINTER(res)[0] = TRUE; UNPROTECT(1); return(res); }
// Return closest point to given distance within geometry. // 'spgeom' must be a LineString SEXP rgeos_interpolate(SEXP env, SEXP spgeom, SEXP d, SEXP normalized) { GEOSContextHandle_t GEOShandle = getContextHandle(env); GEOSGeom geom = rgeos_convert_R2geos(env, spgeom); GEOSGeom res_geos; double dist; int nlines = length(GET_SLOT(spgeom, install("lines"))); if (nlines < 1) { error("rgeos_project: invalid number of lines"); } int n = LENGTH(d); if (n < 1) { error("rgeos_interpolate: invalid number of requested points"); } int pc = 0; SEXP crd; PROTECT(crd = NEW_NUMERIC(n*2)); pc++; double x; double y; SEXP ans; // select interpolation function (normalized/unnormalized) GEOSGeometry GEOS_DLL *(*interp_fun)(GEOSContextHandle_t, const GEOSGeometry*, double); if (LOGICAL_POINTER(normalized)[0]) { interp_fun = &GEOSInterpolateNormalized_r; } else { interp_fun = &GEOSInterpolate_r; } // interpolate points and store result in coord matrix for (int i = 0; i < n; i++) { dist = NUMERIC_POINTER(d)[i]; res_geos = (*interp_fun)(GEOShandle, geom, dist); rgeos_Pt2xy(env, res_geos, &x, &y); NUMERIC_POINTER(crd)[i] = x; NUMERIC_POINTER(crd)[n+i] = y; } GEOSGeom_destroy_r(GEOShandle, geom); GEOSGeom_destroy_r(GEOShandle, res_geos); // return coordinates as matrix PROTECT(ans = rgeos_formatcrdMat(crd, n)); pc++; UNPROTECT(pc); return(ans); }
/** * Calculate the sum of squared errors term for spatial regression * using an environment to hold data * * @param env pointer to an SEXP environment * @param coef current value of coefficient being optimzed * * @return double, value of SSE for current coef * */ SEXP R_ml_sse_env(SEXP env, SEXP coef) { SEXP res; // SEXP y, x, wy, WX; int i, k, n, p, np; double tol=1e-7, cyl, cxlqyl, sse; char *trans = "T"; double one = 1.0, zero = 0.0; double m_lambda = - NUMERIC_POINTER(coef)[0]; int pc=0, first_time; OPT_ERROR_SSE *pt; first_time = LOGICAL_POINTER(findVarInFrame(env, install("first_time")))[0]; if (first_time) { opt_error_set(env); } n = INTEGER_POINTER(findVarInFrame(env, install("n")))[0]; p = INTEGER_POINTER(findVarInFrame(env, install("p")))[0]; np = n*p; pt = (OPT_ERROR_SSE *) R_ExternalPtrAddr(findVarInFrame(env, install("ptr"))); for (i=0; i<n; i++) pt->yl[i] = pt->y[i]; for (i=0; i<np; i++) pt->xlq[i] = pt->x[i]; F77_CALL(daxpy)(&n, &m_lambda, pt->wy1, &c__1, pt->yl, &c__1); F77_CALL(daxpy)(&np, &m_lambda, pt->wx1, &c__1, pt->xlq, &c__1); F77_CALL(dqrdc2)(pt->xlq, &n, &n, &p, &tol, &k, pt->qraux, pt->jpvt, pt->work); if (p != k) warning("Q looses full rank"); /* k = 0; F77_CALL(dqrdc)(pt->xlq, &n, &n, &p, pt->qraux, pt->jpvt, pt->work, &k);*/ for (i=0; i<n*k; i++) pt->qy[i] = 0.0; for (i=0; i<k; i++) pt->qy[(i +(n*i))] = 1.0; F77_CALL(dqrqy)(pt->xlq, &n, &k, pt->qraux, pt->qy, &k, pt->qy); F77_CALL(dgemv)(trans, &n, &k, &one, pt->qy, &n, pt->yl, &c__1, &zero, pt->xlqyl, &c__1); cyl = F77_CALL(ddot)(&n, pt->yl, &c__1, pt->yl, &c__1); cxlqyl = F77_CALL(ddot)(&k, pt->xlqyl, &c__1, pt->xlqyl, &c__1); sse = cyl - cxlqyl; PROTECT(res=NEW_NUMERIC(1)); pc++; NUMERIC_POINTER(res)[0] = sse; UNPROTECT(pc); return(res); }
/*#define DEBUG*/ SEXP nortek_checksum(SEXP buf, SEXP key) { /* http://www.nortek-as.com/en/knowledge-center/forum/current-profilers-and-current-meters/367698326 */ /* R CMD SHLIB bitwise.c library(oce) f <- "/Users/kelley/data/archive/sleiwex/2008/moorings/m06/vector1943/194301.vec" ## dir will change; times are odd buf <- readBin(f, what="raw", n=1e4) vvd.start <- matchBytes(buf, 0xa5, 0x10) ok <- NULL;dyn.load("~/src/R-kelley/oce/src/bitwise.so");for(i in 1:200) {ok <- c(ok, .Call("nortek_checksum",buf[vvd.start[i]+0:23], c(0xb5, 0x8c)))} */ int i, n; short check_value; int *resp; unsigned char *bufp, *keyp; SEXP res; PROTECT(key = AS_RAW(key)); PROTECT(buf = AS_RAW(buf)); bufp = (unsigned char*)RAW_POINTER(buf); keyp = (unsigned char*)RAW_POINTER(key); #ifdef DEBUG Rprintf("buf[0]=0x%02x\n",bufp[0]); Rprintf("buf[1]=0x%02x\n",bufp[1]); Rprintf("buf[2]=0x%02x\n",bufp[2]); Rprintf("key[0]=0x%02x\n", keyp[0]); Rprintf("key[1]=0x%02x\n", keyp[1]); #endif n = LENGTH(buf); check_value = (((short)keyp[0]) << 8) | (short)keyp[1]; #ifdef DEBUG Rprintf("check_value= %d\n", check_value); Rprintf("n=%d\n", n); #endif short *sbufp = (short*) bufp; for (i = 0; i < (n - 2)/2; i++) { #ifdef DEBUG Rprintf("i=%d buf=0x%02x\n", i, sbufp[i]); #endif check_value += sbufp[i]; #ifdef DEBUG Rprintf("after, check_value=%d\n", check_value); #endif } short checksum; checksum = (((short)bufp[n-1]) << 8) | (short)bufp[n-2]; #ifdef DEBUG Rprintf("CHECK AGAINST 0x%02x 0x%02x\n", bufp[n-2], bufp[n-1]); Rprintf("CHECK AGAINST %d\n", checksum); #endif PROTECT(res = NEW_LOGICAL(1)); resp = LOGICAL_POINTER(res); *resp = check_value == checksum; UNPROTECT(3); return(res); }
SEXP PROJ4NADsInstalled(void) { SEXP ans; #ifdef OSGEO4W PROTECT(ans=NEW_LOGICAL(1)); LOGICAL_POINTER(ans)[0] = TRUE; #else FILE *fp; PROTECT(ans=NEW_LOGICAL(1)); fp = pj_open_lib("conus", "rb"); if (fp == NULL) LOGICAL_POINTER(ans)[0] = FALSE; else { LOGICAL_POINTER(ans)[0] = TRUE; fclose(fp); } #endif /* OSGEO4W */ UNPROTECT(1); return(ans); }
// Return distance of points 'spppoints' projected on 'spgeom' from origin // of 'spgeom'. Geometry 'spgeom' must be a lineal geometry SEXP rgeos_project(SEXP env, SEXP spgeom, SEXP sppoint, SEXP normalized) { GEOSContextHandle_t GEOShandle = getContextHandle(env); GEOSGeom geom = rgeos_convert_R2geos(env, spgeom); SEXP crds = GET_SLOT(sppoint, install("coords")); SEXP dim = getAttrib(crds, install("dim")); int nlines = length(GET_SLOT(spgeom, install("lines"))); if (nlines < 1) { error("rgeos_project: invalid number of lines"); } int n = INTEGER_POINTER(dim)[0]; if (n < 1) { error("rgeos_project: invalid number of points"); } int pc = 0; SEXP ans; PROTECT(ans = NEW_NUMERIC(n)); pc++; GEOSGeom p; // select projection function (normalized/unnormalized) double GEOS_DLL (*proj_fun)(GEOSContextHandle_t, const GEOSGeometry*, const GEOSGeometry*); if (LOGICAL_POINTER(normalized)[0]) { proj_fun = &GEOSProjectNormalized_r; } else { proj_fun = &GEOSProject_r; } // project points to line geometry for (int i = 0; i < n; i++) { p = rgeos_xy2Pt(env, NUMERIC_POINTER(crds)[i], NUMERIC_POINTER(crds)[i+n]); NUMERIC_POINTER(ans)[i] = (*proj_fun)(GEOShandle, geom, p); } GEOSGeom_destroy_r(GEOShandle, geom); GEOSGeom_destroy_r(GEOShandle, p); UNPROTECT(pc); return(ans); }
SEXP RGDAL_GetBandStatistics(SEXP sxpRasterBand, SEXP silent) { CPLErr err; SEXP ans; double min, max, mean, sd; GDALRasterBand *pRasterBand = getGDALRasterPtr(sxpRasterBand); installErrorHandler(); err = pRasterBand->GetStatistics(FALSE, FALSE, &min, &max, &mean, &sd); if (err == CE_Failure) { if (!LOGICAL_POINTER(silent)[0]) warning("statistics not supported by this driver"); uninstallErrorHandlerAndTriggerError(); return(R_NilValue); } if (err == CE_Warning) { if (!LOGICAL_POINTER(silent)[0]) warning("statistics not supported by this driver"); uninstallErrorHandlerAndTriggerError(); return(R_NilValue); } uninstallErrorHandlerAndTriggerError(); PROTECT(ans = NEW_NUMERIC(4)); NUMERIC_POINTER(ans)[0] = min; NUMERIC_POINTER(ans)[1] = max; NUMERIC_POINTER(ans)[2] = mean; NUMERIC_POINTER(ans)[3] = sd; UNPROTECT(1); return(ans); }
SEXP rgeos_simplify(SEXP env, SEXP obj, SEXP tol, SEXP id, SEXP byid, SEXP topPres) { 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); int preserve = LOGICAL_POINTER(topPres)[0]; double tolerance = NUMERIC_POINTER(tol)[0]; int n = 1; if (LOGICAL_POINTER(byid)[0] && type == GEOS_GEOMETRYCOLLECTION) n = GEOSGetNumGeometries_r(GEOShandle, geom); if (n < 1) error("rgeos_simplify: invalid number of geometries"); GEOSGeom *resgeoms = (GEOSGeom *) R_alloc((size_t) n, sizeof(GEOSGeom)); for(int i=0; i<n; i++) { const GEOSGeometry *curgeom = (n > 1) ? (GEOSGeom) GEOSGetGeometryN_r(GEOShandle, geom, i) : geom; if (curgeom == NULL) error("rgeos_topologyfunc: unable to get subgeometries"); resgeoms[i] = (preserve) ? GEOSTopologyPreserveSimplify_r(GEOShandle, curgeom, tolerance) : GEOSSimplify_r(GEOShandle, curgeom, tolerance); } GEOSGeom_destroy_r(GEOShandle, geom); GEOSGeom res = (n == 1) ? resgeoms[0] : GEOSGeom_createCollection_r(GEOShandle, GEOS_GEOMETRYCOLLECTION, resgeoms, (unsigned int) n); return( rgeos_convert_geos2R(env, res, p4s, id) ); }
SEXP RGDAL_GDALCheckVersion(void) { SEXP ans; PROTECT(ans=NEW_LOGICAL(1)); installErrorHandler(); LOGICAL_POINTER(ans)[0] = GDALCheckVersion(GDAL_VERSION_MAJOR, GDAL_VERSION_MINOR, NULL); uninstallErrorHandlerAndTriggerError(); UNPROTECT(1); return(ans); }
SEXP rph_tree_isNode(SEXP treeP, SEXP nodeName) { TreeNode *tr, *n; SEXP result; int *resultP, i; tr = rph_tree_new(treeP); for (i=0; i<tr->nnodes; i++) { n = (TreeNode*)lst_get_ptr(tr->nodes, i); if (strcmp(n->name, CHARACTER_VALUE(nodeName))==0) break; } PROTECT(result = NEW_LOGICAL(1)); resultP = LOGICAL_POINTER(result); resultP[0] = (i < tr->nnodes); UNPROTECT(1); return result; }
SEXP R_ml1_sse_env(SEXP env, SEXP lambda, SEXP beta) { SEXP res; int i, n, p, np; double sse; char *trans = "N"; double one = 1.0, zero = 0.0, m_one = -1.0; double m_lambda = - NUMERIC_POINTER(lambda)[0]; int pc=0, first_time; HESS_ERROR_SSE *pt; first_time = LOGICAL_POINTER(findVarInFrame(env, install("first_time")))[0]; if (first_time) { hess_error_set(env); } n = INTEGER_POINTER(findVarInFrame(env, install("n")))[0]; p = INTEGER_POINTER(findVarInFrame(env, install("p")))[0]; np = n*p; pt = (HESS_ERROR_SSE *) R_ExternalPtrAddr(findVarInFrame(env, install("ptr"))); for (i=0; i<n; i++) pt->yl[i] = pt->y[i]; for (i=0; i<np; i++) pt->xl[i] = pt->x[i]; for (i=0; i<p; i++) pt->beta1[i] = NUMERIC_POINTER(beta)[i]; F77_CALL(daxpy)(&n, &m_lambda, pt->wy1, &c__1, pt->yl, &c__1); F77_CALL(daxpy)(&np, &m_lambda, pt->wx1, &c__1, pt->xl, &c__1); F77_CALL(dgemv)(trans, &n, &p, &one, pt->xl, &n, pt->beta1, &c__1, &zero, pt->xlb, &c__1); F77_CALL(daxpy)(&n, &m_one, pt->xlb, &c__1, pt->yl, &c__1); sse = F77_CALL(ddot)(&n, pt->yl, &c__1, pt->yl, &c__1); PROTECT(res=NEW_NUMERIC(1)); pc++; NUMERIC_POINTER(res)[0] = sse; UNPROTECT(pc); return(res); }
SEXP rgeos_polygonize(SEXP env, SEXP obj, SEXP id, SEXP p4s, SEXP cutEdges) { GEOSContextHandle_t GEOShandle = getContextHandle(env); int getCutEdges = LOGICAL_POINTER(cutEdges)[0]; int n = length(obj); GEOSGeom *geoms = (GEOSGeom *) R_alloc((size_t) n, sizeof(GEOSGeom)); for(int i=0; i<n; i++) { geoms[i] = rgeos_convert_R2geos(env, VECTOR_ELT(obj,i)); } GEOSGeom res = (getCutEdges) ? GEOSPolygonizer_getCutEdges_r(GEOShandle, (const GEOSGeometry *const *) geoms, (unsigned int) n) : GEOSPolygonize_r(GEOShandle, (const GEOSGeometry *const *) geoms, (unsigned int) n); return( rgeos_convert_geos2R(env, res, p4s, id) ); }
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); }
SEXP rgeos_topologyfunc(SEXP env, SEXP obj, SEXP id, SEXP byid, p_topofunc topofunc) { 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); int n = 1; if (LOGICAL_POINTER(byid)[0] && type == GEOS_GEOMETRYCOLLECTION) n = GEOSGetNumGeometries_r(GEOShandle, geom); if (n < 1) error("rgeos_topologyfunc: invalid number of geometries"); GEOSGeom *resgeoms = (GEOSGeom *) R_alloc((size_t) n, sizeof(GEOSGeom)); for(int i=0; i<n; i++) { const GEOSGeometry *curgeom = (n > 1) ? (GEOSGeom) GEOSGetGeometryN_r(GEOShandle, geom, i) : geom; if (curgeom == NULL) error("rgeos_topologyfunc: unable to get subgeometries"); if ( topofunc == GEOSUnionCascaded_r && GEOSGeomTypeId_r(GEOShandle, curgeom) == GEOS_POLYGON) { resgeoms[i] = GEOSGeom_clone_r(GEOShandle, curgeom); } else { resgeoms[i] = topofunc(GEOShandle, curgeom); if (resgeoms[i] == NULL) error("rgeos_topologyfunc: unable to calculate"); } } GEOSGeom_destroy_r(GEOShandle, geom); GEOSGeom res = (n == 1) ? resgeoms[0] : GEOSGeom_createCollection_r(GEOShandle, GEOS_GEOMETRYCOLLECTION, resgeoms, (unsigned int) n); return( rgeos_convert_geos2R(env, res, p4s, id) ); // releases res }
//---------------------------------------------------------------------------- SEXP pnlIsFullDBN(SEXP net) { SEXP res; int flag = 0; bool result; PROTECT(net = AS_INTEGER(net)); int NetNum = INTEGER_VALUE(net); try { result = pDBNs[NetNum]->IsFullDBN(); } catch(pnl::CException &E) { ErrorString = E.GetMessage(); flag = 1; } catch(...) { ErrorString = "Unrecognized exception during execution of IsFullDBN function"; flag = 1; } if (flag == 0) { PROTECT(res = NEW_LOGICAL(1)); int * pRes = LOGICAL_POINTER(res); pRes[0] = result; } if (flag == 1) { PROTECT(res = allocVector(STRSXP, 1)); SET_STRING_ELT(res, 0, mkChar(ErrorString.c_str())); } UNPROTECT(2); return (res); }
SEXP onGet_SW_VPD() { int i; SW_VEGPROD *v = &SW_VegProd; SEXP swProd; SEXP VegProd; SEXP VegComp, VegComp_names, vegtype_names, col_names; SEXP Albedo; SEXP Canopy, Canopy_names, Canopy_names_x; char *cCanopy_names_x[] = { "xinflec", "yinflec", "range", "slope", "height_cm" }; RealD *p_Canopy; SEXP VegInterception, VegInterception_names, VegInterception_names_x; char *cVegInterception_x[] = { "kSmax", "kdead" }; RealD *p_VegInterception; SEXP LitterInterception, LitterInterception_names, LitterInterception_names_x; char *cLitterInterception_x[] = { "kSmax" }; RealD *p_LitterInterception; SEXP EsTpartitioning_param; SEXP Es_param_limit; SEXP Shade, Shade_names, Shade_names_x; char *cShade_names_x[] = { "ShadeScale", "ShadeMaximalDeadBiomass", "tanfuncXinflec", "yinflec", "range", "slope" }; RealD *p_Shade; SEXP Hydraulic_flag;//"Flag" SEXP Hydraulic, Hydraulic_names, Hydraulic_names_x; RealD *p_Hydraulic; char *cHydraulic_names[] = { "MaxCondRoot", "SoilWaterPotential50", "ShapeCond" }; SEXP CSWP; SEXP MonthlyVeg; SEXP Grasslands, Grasslands_names; SEXP Shrublands, Shrublands_names; SEXP Forest, Forest_names; SEXP Forb, Forb_names; char *cvegtype_names[] = { "Grasses", "Shrubs", "Trees", "Forbs" }; PROTECT(vegtype_names = allocVector(STRSXP, NVEGTYPES)); for (i = 0; i < NVEGTYPES; i++) SET_STRING_ELT(vegtype_names, i, mkChar(cvegtype_names[i])); /* CO2 */ // Initialize variables SEXP CO2Coefficients, CO2_names, CO2_col_names; RealD *p_CO2Coefficients; // Create row and column names char *cCO2_col_names[] = { "Biomass Coeff1", "Biomass Coeff2", "WUE Coeff1", "WUE Coeff2" }; PROTECT(CO2_col_names = allocVector(STRSXP, 4)); for (i = 0; i < 4; i++) SET_STRING_ELT(CO2_col_names, i, mkChar(cCO2_col_names[i])); // Create matrix containing the multipliers PROTECT(CO2Coefficients = allocMatrix(REALSXP, NVEGTYPES, 4)); p_CO2Coefficients = REAL(CO2Coefficients); p_CO2Coefficients[0] = v->veg[SW_GRASS].co2_bio_coeff1; p_CO2Coefficients[1] = v->veg[SW_SHRUB].co2_bio_coeff1; p_CO2Coefficients[2] = v->veg[SW_TREES].co2_bio_coeff1; p_CO2Coefficients[3] = v->veg[SW_FORBS].co2_bio_coeff1; p_CO2Coefficients[4] = v->veg[SW_GRASS].co2_bio_coeff2; p_CO2Coefficients[5] = v->veg[SW_SHRUB].co2_bio_coeff2; p_CO2Coefficients[6] = v->veg[SW_TREES].co2_bio_coeff2; p_CO2Coefficients[7] = v->veg[SW_FORBS].co2_bio_coeff2; p_CO2Coefficients[8] = v->veg[SW_GRASS].co2_wue_coeff1; p_CO2Coefficients[9] = v->veg[SW_SHRUB].co2_wue_coeff1; p_CO2Coefficients[10] = v->veg[SW_TREES].co2_wue_coeff1; p_CO2Coefficients[11] = v->veg[SW_FORBS].co2_wue_coeff1; p_CO2Coefficients[12] = v->veg[SW_GRASS].co2_wue_coeff2; p_CO2Coefficients[13] = v->veg[SW_SHRUB].co2_wue_coeff2; p_CO2Coefficients[14] = v->veg[SW_TREES].co2_wue_coeff2; p_CO2Coefficients[15] = v->veg[SW_FORBS].co2_wue_coeff2; // Integrate values with names PROTECT(CO2_names = allocVector(VECSXP, 2)); SET_VECTOR_ELT(CO2_names, 1, CO2_col_names); SET_VECTOR_ELT(CO2_names, 0, vegtype_names); setAttrib(CO2Coefficients, R_DimNamesSymbol, CO2_names); RealD *p_Grasslands, *p_Shrublands, *p_Forest, *p_Forb; SEXP MonthlyVeg_Column_names, MonthlyVeg_Row_names; char *cMonthlyVeg_Column_names[] = { "Litter", "Biomass", "Live_pct", "LAI_conv" }; PROTECT(swProd = MAKE_CLASS("swProd")); PROTECT(VegProd = NEW_OBJECT(swProd)); PROTECT(VegComp = allocVector(REALSXP, NVEGTYPES + 1)); REAL(VegComp)[0] = v->veg[SW_GRASS].cov.fCover; //Grass REAL(VegComp)[1] = v->veg[SW_SHRUB].cov.fCover; //Shrub REAL(VegComp)[2] = v->veg[SW_TREES].cov.fCover; //Tree REAL(VegComp)[3] = v->veg[SW_FORBS].cov.fCover; //forb REAL(VegComp)[4] = v->bare_cov.fCover; //Bare Ground PROTECT(VegComp_names = allocVector(STRSXP, NVEGTYPES + 1)); SET_STRING_ELT(VegComp_names, 0, mkChar("Grasses")); SET_STRING_ELT(VegComp_names, 1, mkChar("Shrubs")); SET_STRING_ELT(VegComp_names, 2, mkChar("Trees")); SET_STRING_ELT(VegComp_names, 3, mkChar("Forbs")); SET_STRING_ELT(VegComp_names, 4, mkChar("Bare Ground")); setAttrib(VegComp, R_NamesSymbol, VegComp_names); PROTECT(Albedo = allocVector(REALSXP, NVEGTYPES + 1)); REAL(Albedo)[0] = v->veg[SW_GRASS].cov.albedo; //Grass REAL(Albedo)[1] = v->veg[SW_SHRUB].cov.albedo; //Shrub REAL(Albedo)[2] = v->veg[SW_TREES].cov.albedo; //Tree REAL(Albedo)[3] = v->veg[SW_FORBS].cov.albedo; //forb REAL(Albedo)[4] = v->bare_cov.albedo; //bare ground setAttrib(Albedo, R_NamesSymbol, VegComp_names); PROTECT(Canopy = allocMatrix(REALSXP, 5, NVEGTYPES)); p_Canopy = REAL(Canopy); p_Canopy[0] = v->veg[SW_GRASS].cnpy.xinflec; p_Canopy[1] = v->veg[SW_GRASS].cnpy.yinflec; p_Canopy[2] = v->veg[SW_GRASS].cnpy.range; p_Canopy[3] = v->veg[SW_GRASS].cnpy.slope; p_Canopy[4] = v->veg[SW_GRASS].canopy_height_constant; p_Canopy[5] = v->veg[SW_SHRUB].cnpy.xinflec; p_Canopy[6] = v->veg[SW_SHRUB].cnpy.yinflec; p_Canopy[7] = v->veg[SW_SHRUB].cnpy.range; p_Canopy[8] = v->veg[SW_SHRUB].cnpy.slope; p_Canopy[9] = v->veg[SW_SHRUB].canopy_height_constant; p_Canopy[10] = v->veg[SW_TREES].cnpy.xinflec; p_Canopy[11] = v->veg[SW_TREES].cnpy.yinflec; p_Canopy[12] = v->veg[SW_TREES].cnpy.range; p_Canopy[13] = v->veg[SW_TREES].cnpy.slope; p_Canopy[14] = v->veg[SW_TREES].canopy_height_constant; p_Canopy[15] = v->veg[SW_FORBS].cnpy.xinflec; p_Canopy[16] = v->veg[SW_FORBS].cnpy.yinflec; p_Canopy[17] = v->veg[SW_FORBS].cnpy.range; p_Canopy[18] = v->veg[SW_FORBS].cnpy.slope; p_Canopy[19] = v->veg[SW_FORBS].canopy_height_constant; PROTECT(Canopy_names = allocVector(VECSXP, 2)); PROTECT(Canopy_names_x = allocVector(STRSXP, 5)); for (i = 0; i < 5; i++) SET_STRING_ELT(Canopy_names_x, i, mkChar(cCanopy_names_x[i])); SET_VECTOR_ELT(Canopy_names, 0, Canopy_names_x); SET_VECTOR_ELT(Canopy_names, 1, vegtype_names); setAttrib(Canopy, R_DimNamesSymbol, Canopy_names); PROTECT(VegInterception = allocMatrix(REALSXP, 2, NVEGTYPES)); p_VegInterception = REAL(VegInterception); p_VegInterception[0] = v->veg[SW_GRASS].veg_kSmax; p_VegInterception[1] = v->veg[SW_GRASS].veg_kdead; p_VegInterception[2] = v->veg[SW_SHRUB].veg_kSmax; p_VegInterception[3] = v->veg[SW_SHRUB].veg_kdead; p_VegInterception[4] = v->veg[SW_TREES].veg_kSmax; p_VegInterception[5] = v->veg[SW_TREES].veg_kdead; p_VegInterception[6] = v->veg[SW_FORBS].veg_kSmax; p_VegInterception[7] = v->veg[SW_FORBS].veg_kdead; PROTECT(VegInterception_names = allocVector(VECSXP, 2)); PROTECT(VegInterception_names_x = allocVector(STRSXP, 2)); for (i = 0; i < 2; i++) SET_STRING_ELT(VegInterception_names_x, i, mkChar(cVegInterception_x[i])); SET_VECTOR_ELT(VegInterception_names, 0, VegInterception_names_x); SET_VECTOR_ELT(VegInterception_names, 1, vegtype_names); setAttrib(VegInterception, R_DimNamesSymbol, VegInterception_names); PROTECT(LitterInterception = allocMatrix(REALSXP, 1, NVEGTYPES)); p_LitterInterception = REAL(LitterInterception); p_LitterInterception[0] = v->veg[SW_GRASS].lit_kSmax; p_LitterInterception[1] = v->veg[SW_SHRUB].lit_kSmax; p_LitterInterception[2] = v->veg[SW_TREES].lit_kSmax; p_LitterInterception[3] = v->veg[SW_FORBS].lit_kSmax; PROTECT(LitterInterception_names = allocVector(VECSXP, 2)); PROTECT(LitterInterception_names_x = allocVector(STRSXP, 1)); for (i = 0; i < 1; i++) SET_STRING_ELT(LitterInterception_names_x, i, mkChar(cLitterInterception_x[i])); SET_VECTOR_ELT(LitterInterception_names, 0, LitterInterception_names_x); SET_VECTOR_ELT(LitterInterception_names, 1, vegtype_names); setAttrib(LitterInterception, R_DimNamesSymbol, LitterInterception_names); PROTECT(EsTpartitioning_param = allocVector(REALSXP, NVEGTYPES)); REAL(EsTpartitioning_param)[0] = v->veg[SW_GRASS].EsTpartitioning_param; //Grass REAL(EsTpartitioning_param)[1] = v->veg[SW_SHRUB].EsTpartitioning_param; //Shrub REAL(EsTpartitioning_param)[2] = v->veg[SW_TREES].EsTpartitioning_param; //Tree REAL(EsTpartitioning_param)[3] = v->veg[SW_FORBS].EsTpartitioning_param; //forb setAttrib(EsTpartitioning_param, R_NamesSymbol, vegtype_names); PROTECT(Es_param_limit = allocVector(REALSXP, NVEGTYPES)); REAL(Es_param_limit)[0] = v->veg[SW_GRASS].Es_param_limit; //Grass REAL(Es_param_limit)[1] = v->veg[SW_SHRUB].Es_param_limit; //Shrub REAL(Es_param_limit)[2] = v->veg[SW_TREES].Es_param_limit; //Tree REAL(Es_param_limit)[3] = v->veg[SW_FORBS].Es_param_limit; //forb setAttrib(Es_param_limit, R_NamesSymbol, vegtype_names); PROTECT(Shade = allocMatrix(REALSXP, 6, NVEGTYPES)); p_Shade = REAL(Shade); p_Shade[0] = v->veg[SW_GRASS].shade_scale; p_Shade[1] = v->veg[SW_GRASS].shade_deadmax; p_Shade[2] = v->veg[SW_GRASS].tr_shade_effects.xinflec; p_Shade[3] = v->veg[SW_GRASS].tr_shade_effects.yinflec; p_Shade[4] = v->veg[SW_GRASS].tr_shade_effects.range; p_Shade[5] = v->veg[SW_GRASS].tr_shade_effects.slope; p_Shade[6] = v->veg[SW_SHRUB].shade_scale; p_Shade[7] = v->veg[SW_SHRUB].shade_deadmax; p_Shade[8] = v->veg[SW_SHRUB].tr_shade_effects.xinflec; p_Shade[9] = v->veg[SW_SHRUB].tr_shade_effects.yinflec; p_Shade[10] = v->veg[SW_SHRUB].tr_shade_effects.range; p_Shade[11] = v->veg[SW_SHRUB].tr_shade_effects.slope; p_Shade[12] = v->veg[SW_TREES].shade_scale; p_Shade[13] = v->veg[SW_TREES].shade_deadmax; p_Shade[14] = v->veg[SW_TREES].tr_shade_effects.xinflec; p_Shade[15] = v->veg[SW_TREES].tr_shade_effects.yinflec; p_Shade[16] = v->veg[SW_TREES].tr_shade_effects.range; p_Shade[17] = v->veg[SW_TREES].tr_shade_effects.slope; p_Shade[18] = v->veg[SW_FORBS].shade_scale; p_Shade[19] = v->veg[SW_FORBS].shade_deadmax; p_Shade[20] = v->veg[SW_FORBS].tr_shade_effects.xinflec; p_Shade[21] = v->veg[SW_FORBS].tr_shade_effects.yinflec; p_Shade[22] = v->veg[SW_FORBS].tr_shade_effects.range; p_Shade[23] = v->veg[SW_FORBS].tr_shade_effects.slope; PROTECT(Shade_names = allocVector(VECSXP, 2)); PROTECT(Shade_names_x = allocVector(STRSXP, 6)); for (i = 0; i < 6; i++) SET_STRING_ELT(Shade_names_x, i, mkChar(cShade_names_x[i])); SET_VECTOR_ELT(Shade_names, 0, Shade_names_x); SET_VECTOR_ELT(Shade_names, 1, vegtype_names); setAttrib(Shade, R_DimNamesSymbol, Shade_names); PROTECT(Hydraulic_flag = allocVector(LGLSXP, NVEGTYPES)); LOGICAL_POINTER(Hydraulic_flag)[0] = v->veg[SW_GRASS].flagHydraulicRedistribution; //Grass LOGICAL_POINTER(Hydraulic_flag)[1] = v->veg[SW_SHRUB].flagHydraulicRedistribution; //Shrub LOGICAL_POINTER(Hydraulic_flag)[2] = v->veg[SW_TREES].flagHydraulicRedistribution; //Tree LOGICAL_POINTER(Hydraulic_flag)[3] = v->veg[SW_FORBS].flagHydraulicRedistribution; //forb setAttrib(Hydraulic_flag, R_NamesSymbol, vegtype_names); PROTECT(Hydraulic = allocMatrix(REALSXP, 3, NVEGTYPES)); p_Hydraulic = REAL(Hydraulic); p_Hydraulic[0] = v->veg[SW_GRASS].maxCondroot; p_Hydraulic[1] = v->veg[SW_GRASS].swpMatric50; p_Hydraulic[2] = v->veg[SW_GRASS].shapeCond; p_Hydraulic[3] = v->veg[SW_SHRUB].maxCondroot; p_Hydraulic[4] = v->veg[SW_SHRUB].swpMatric50; p_Hydraulic[5] = v->veg[SW_SHRUB].shapeCond; p_Hydraulic[6] = v->veg[SW_TREES].maxCondroot; p_Hydraulic[7] = v->veg[SW_TREES].swpMatric50; p_Hydraulic[8] = v->veg[SW_TREES].shapeCond; p_Hydraulic[9] = v->veg[SW_FORBS].maxCondroot; p_Hydraulic[10] = v->veg[SW_FORBS].swpMatric50; p_Hydraulic[11] = v->veg[SW_FORBS].shapeCond; PROTECT(Hydraulic_names = allocVector(VECSXP, 2)); PROTECT(Hydraulic_names_x = allocVector(STRSXP, 3)); for (i = 0; i < 3; i++) { SET_STRING_ELT(Hydraulic_names_x, i, mkChar(cHydraulic_names[i])); } SET_VECTOR_ELT(Hydraulic_names, 0, Hydraulic_names_x); SET_VECTOR_ELT(Hydraulic_names, 1, vegtype_names); setAttrib(Hydraulic, R_DimNamesSymbol, Hydraulic_names); PROTECT(CSWP = allocVector(REALSXP, NVEGTYPES)); REAL(CSWP)[0] = v->veg[SW_GRASS].SWPcrit / -10; //Grass REAL(CSWP)[1] = v->veg[SW_SHRUB].SWPcrit / -10; //Shrub REAL(CSWP)[2] = v->veg[SW_TREES].SWPcrit / -10; //Tree REAL(CSWP)[3] = v->veg[SW_FORBS].SWPcrit / -10; //Forb setAttrib(CSWP, R_NamesSymbol, vegtype_names); PROTECT(MonthlyVeg_Column_names = allocVector(STRSXP, 4)); for (i = 0; i < 4; i++) SET_STRING_ELT(MonthlyVeg_Column_names, i, mkChar(cMonthlyVeg_Column_names[i])); PROTECT(MonthlyVeg_Row_names = allocVector(STRSXP, 12)); for (i = 0; i < 12; i++) SET_STRING_ELT(MonthlyVeg_Row_names, i, mkChar(cMonths[i])); PROTECT(Grasslands = allocMatrix(REALSXP, 12, 4)); p_Grasslands = REAL(Grasslands); for (i = 0; i < 12; i++) { p_Grasslands[i + 12 * 0] = v->veg[SW_GRASS].litter[i]; p_Grasslands[i + 12 * 1] = v->veg[SW_GRASS].biomass[i]; p_Grasslands[i + 12 * 2] = v->veg[SW_GRASS].pct_live[i]; p_Grasslands[i + 12 * 3] = v->veg[SW_GRASS].lai_conv[i]; } PROTECT(Grasslands_names = allocVector(VECSXP, 2)); SET_VECTOR_ELT(Grasslands_names, 0, MonthlyVeg_Row_names); SET_VECTOR_ELT(Grasslands_names, 1, MonthlyVeg_Column_names); setAttrib(Grasslands, R_DimNamesSymbol, Grasslands_names); PROTECT(Shrublands = allocMatrix(REALSXP, 12, 4)); p_Shrublands = REAL(Shrublands); for (i = 0; i < 12; i++) { p_Shrublands[i + 12 * 0] = v->veg[SW_SHRUB].litter[i]; p_Shrublands[i + 12 * 1] = v->veg[SW_SHRUB].biomass[i]; p_Shrublands[i + 12 * 2] = v->veg[SW_SHRUB].pct_live[i]; p_Shrublands[i + 12 * 3] = v->veg[SW_SHRUB].lai_conv[i]; } PROTECT(Shrublands_names = allocVector(VECSXP, 2)); SET_VECTOR_ELT(Shrublands_names, 0, MonthlyVeg_Row_names); SET_VECTOR_ELT(Shrublands_names, 1, MonthlyVeg_Column_names); setAttrib(Shrublands, R_DimNamesSymbol, Shrublands_names); PROTECT(Forest = allocMatrix(REALSXP, 12, 4)); p_Forest = REAL(Forest); for (i = 0; i < 12; i++) { p_Forest[i + 12 * 0] = v->veg[SW_TREES].litter[i]; p_Forest[i + 12 * 1] = v->veg[SW_TREES].biomass[i]; p_Forest[i + 12 * 2] = v->veg[SW_TREES].pct_live[i]; p_Forest[i + 12 * 3] = v->veg[SW_TREES].lai_conv[i]; } PROTECT(Forest_names = allocVector(VECSXP, 2)); SET_VECTOR_ELT(Forest_names, 0, MonthlyVeg_Row_names); SET_VECTOR_ELT(Forest_names, 1, MonthlyVeg_Column_names); setAttrib(Forest, R_DimNamesSymbol, Forest_names); PROTECT(Forb = allocMatrix(REALSXP, 12, 4)); p_Forb = REAL(Forb); for (i = 0; i < 12; i++) { p_Forb[i + 12 * 0] = v->veg[SW_FORBS].litter[i]; p_Forb[i + 12 * 1] = v->veg[SW_FORBS].biomass[i]; p_Forb[i + 12 * 2] = v->veg[SW_FORBS].pct_live[i]; p_Forb[i + 12 * 3] = v->veg[SW_FORBS].lai_conv[i]; } PROTECT(Forb_names = allocVector(VECSXP, 2)); SET_VECTOR_ELT(Forb_names, 0, MonthlyVeg_Row_names); SET_VECTOR_ELT(Forb_names, 1, MonthlyVeg_Column_names); setAttrib(Forb, R_DimNamesSymbol, Forb_names); PROTECT(MonthlyVeg = allocVector(VECSXP, NVEGTYPES)); SET_VECTOR_ELT(MonthlyVeg, SW_TREES, Forest); SET_VECTOR_ELT(MonthlyVeg, SW_SHRUB, Shrublands); SET_VECTOR_ELT(MonthlyVeg, SW_FORBS, Forb); SET_VECTOR_ELT(MonthlyVeg, SW_GRASS, Grasslands); PROTECT(col_names = allocVector(STRSXP, NVEGTYPES)); SET_STRING_ELT(col_names, 0, mkChar("Trees")); SET_STRING_ELT(col_names, 1, mkChar("Shrubs")); SET_STRING_ELT(col_names, 2, mkChar("Forbs")); SET_STRING_ELT(col_names, 3, mkChar("Grasses")); setAttrib(MonthlyVeg, R_NamesSymbol, col_names); SET_SLOT(VegProd, install(cVegProd_names[0]), VegComp); SET_SLOT(VegProd, install(cVegProd_names[1]), Albedo); SET_SLOT(VegProd, install(cVegProd_names[2]), Canopy); SET_SLOT(VegProd, install(cVegProd_names[3]), VegInterception); SET_SLOT(VegProd, install(cVegProd_names[4]), LitterInterception); SET_SLOT(VegProd, install(cVegProd_names[5]), EsTpartitioning_param); SET_SLOT(VegProd, install(cVegProd_names[6]), Es_param_limit); SET_SLOT(VegProd, install(cVegProd_names[7]), Shade); SET_SLOT(VegProd, install(cVegProd_names[8]), Hydraulic_flag); SET_SLOT(VegProd, install(cVegProd_names[9]), Hydraulic); SET_SLOT(VegProd, install(cVegProd_names[10]), CSWP); SET_SLOT(VegProd, install(cVegProd_names[11]), MonthlyVeg); SET_SLOT(VegProd, install(cVegProd_names[12]), CO2Coefficients); UNPROTECT(40); return VegProd; }
SEXP rgeos_poly_findInBox(SEXP env, SEXP pls, SEXP as_points) { GEOSGeom *bbs; int npls, i, j, jj, pc=0; GEOSGeom GC, bb; SEXP pl, bblist; GEOSSTRtree *str; int *icard, *ids, *oids; int asPTS = LOGICAL_POINTER(as_points)[0]; GEOSContextHandle_t GEOShandle = getContextHandle(env); str = (GEOSSTRtree *) GEOSSTRtree_create_r(GEOShandle, (size_t) 10); npls = length(pls); bbs = (GEOSGeom *) R_alloc((size_t) npls, sizeof(GEOSGeom)); ids = (int *) R_alloc((size_t) npls, sizeof(int)); UD.ids = (int *) R_alloc((size_t) npls, sizeof(int)); oids = (int *) R_alloc((size_t) npls, sizeof(int)); for (i=0; i<npls; i++) { ids[i] = i; pl = VECTOR_ELT(pls, i); if (asPTS) { if ((GC = rgeos_Polygons2MP(env, pl)) == NULL) { error("rgeos_poly2nb: MP GC[%d] not created", i); } } else { if ((GC = rgeos_Polygons2geospolygon(env, pl)) == NULL) { error("rgeos_poly2nb: GC[%d] not created", i); } } if ((bb = GEOSEnvelope_r(GEOShandle, GC)) == NULL) { error("rgeos_poly2nb: envelope [%d] not created", i); } bbs[i] = bb; GEOSSTRtree_insert_r(GEOShandle, str, bb, &(ids[i])); // 110904 EJP GEOSGeom_destroy_r(GEOShandle, GC); } icard = (int *) R_alloc((size_t) npls, sizeof(int)); PROTECT(bblist = NEW_LIST(npls-1)); pc++; for (i=0; i<(npls-1); i++) { UD.count = 0; GEOSSTRtree_query_r(GEOShandle, str, bbs[i], (GEOSQueryCallback) cb, &UD); for (j=0, jj=0; j<UD.count; j++) if (UD.ids[j] > i) jj++; icard[i] = jj; if (icard[i] > 0) SET_VECTOR_ELT(bblist, i, NEW_INTEGER(icard[i])); for (j=0, jj=0; j<UD.count; j++) { if (icard[i] > 0 && UD.ids[j] > i) { oids[jj] = UD.ids[j] + R_OFFSET; jj++; } } R_isort(oids, jj); for (j=0; j<jj; j++) { INTEGER_POINTER(VECTOR_ELT(bblist, i))[j] = oids[j]; } } for (i=0; i<npls; i++) { GEOSSTRtree_remove_r(GEOShandle, str, bbs[i], &(ids[i])); // 110904 EJP GEOSGeom_destroy_r(GEOShandle, bbs[i]); } GEOSSTRtree_destroy_r(GEOShandle, str); UNPROTECT(pc); return(bblist); }
void onSet_SW_VPD(SEXP SW_VPD) { int i; SW_VEGPROD *v = &SW_VegProd; SEXP VegComp; SEXP Albedo; SEXP Canopy; RealD *p_Canopy; SEXP VegInterception; RealD *p_VegInterception; SEXP LitterInterception; RealD *p_LitterInterception; SEXP EsTpartitioning_param; SEXP Es_param_limit; SEXP Shade; RealD *p_Shade; SEXP Hydraulic; SEXP Hydraulic_flag; SEXP CSWP; SEXP MonthlyVeg, Grasslands, Shrublands, Forest, Forb; SEXP CO2Coefficients; RealD *p_Grasslands, *p_Shrublands, *p_Forest, *p_Forb; MyFileName = SW_F_name(eVegProd); PROTECT(VegComp = GET_SLOT(SW_VPD, install(cVegProd_names[0]))); v->veg[SW_GRASS].cov.fCover = REAL(VegComp)[0]; //Grass v->veg[SW_SHRUB].cov.fCover = REAL(VegComp)[1]; //Shrub v->veg[SW_TREES].cov.fCover = REAL(VegComp)[2]; //Tree v->veg[SW_FORBS].cov.fCover = REAL(VegComp)[3]; //Forb v->bare_cov.fCover = REAL(VegComp)[4]; //Bare Ground PROTECT(Albedo = GET_SLOT(SW_VPD, install(cVegProd_names[1]))); v->veg[SW_GRASS].cov.albedo = REAL(Albedo)[0]; //Grass v->veg[SW_SHRUB].cov.albedo = REAL(Albedo)[1]; //Shrub v->veg[SW_TREES].cov.albedo = REAL(Albedo)[2]; //Tree v->veg[SW_FORBS].cov.albedo = REAL(Albedo)[3]; //Forb v->bare_cov.albedo = REAL(Albedo)[4]; //Bare Ground PROTECT(Canopy = GET_SLOT(SW_VPD, install(cVegProd_names[2]))); p_Canopy = REAL(Canopy); v->veg[SW_GRASS].cnpy.xinflec = p_Canopy[0]; v->veg[SW_GRASS].cnpy.yinflec = p_Canopy[1]; v->veg[SW_GRASS].cnpy.range = p_Canopy[2]; v->veg[SW_GRASS].cnpy.slope = p_Canopy[3]; v->veg[SW_GRASS].canopy_height_constant = p_Canopy[4]; v->veg[SW_SHRUB].cnpy.xinflec = p_Canopy[5]; v->veg[SW_SHRUB].cnpy.yinflec = p_Canopy[6]; v->veg[SW_SHRUB].cnpy.range = p_Canopy[7]; v->veg[SW_SHRUB].cnpy.slope = p_Canopy[8]; v->veg[SW_SHRUB].canopy_height_constant = p_Canopy[9]; v->veg[SW_TREES].cnpy.xinflec = p_Canopy[10]; v->veg[SW_TREES].cnpy.yinflec = p_Canopy[11]; v->veg[SW_TREES].cnpy.range = p_Canopy[12]; v->veg[SW_TREES].cnpy.slope = p_Canopy[13]; v->veg[SW_TREES].canopy_height_constant = p_Canopy[14]; v->veg[SW_FORBS].cnpy.xinflec = p_Canopy[15]; v->veg[SW_FORBS].cnpy.yinflec = p_Canopy[16]; v->veg[SW_FORBS].cnpy.range = p_Canopy[17]; v->veg[SW_FORBS].cnpy.slope = p_Canopy[18]; v->veg[SW_FORBS].canopy_height_constant = p_Canopy[19]; PROTECT(VegInterception = GET_SLOT(SW_VPD, install(cVegProd_names[3]))); p_VegInterception = REAL(VegInterception); v->veg[SW_GRASS].veg_kSmax = p_VegInterception[0]; v->veg[SW_GRASS].veg_kdead = p_VegInterception[1]; v->veg[SW_SHRUB].veg_kSmax = p_VegInterception[2]; v->veg[SW_SHRUB].veg_kdead = p_VegInterception[3]; v->veg[SW_TREES].veg_kSmax = p_VegInterception[4]; v->veg[SW_TREES].veg_kdead = p_VegInterception[5]; v->veg[SW_FORBS].veg_kSmax = p_VegInterception[6]; v->veg[SW_FORBS].veg_kdead = p_VegInterception[7]; PROTECT(LitterInterception = GET_SLOT(SW_VPD, install(cVegProd_names[4]))); p_LitterInterception = REAL(LitterInterception); v->veg[SW_GRASS].lit_kSmax = p_LitterInterception[0]; v->veg[SW_SHRUB].lit_kSmax = p_LitterInterception[1]; v->veg[SW_TREES].lit_kSmax = p_LitterInterception[2]; v->veg[SW_FORBS].lit_kSmax = p_LitterInterception[3]; PROTECT(EsTpartitioning_param = GET_SLOT(SW_VPD, install(cVegProd_names[5]))); v->veg[SW_GRASS].EsTpartitioning_param = REAL(EsTpartitioning_param)[0]; //Grass v->veg[SW_SHRUB].EsTpartitioning_param = REAL(EsTpartitioning_param)[1]; //Shrub v->veg[SW_TREES].EsTpartitioning_param = REAL(EsTpartitioning_param)[2]; //Tree v->veg[SW_FORBS].EsTpartitioning_param = REAL(EsTpartitioning_param)[3]; //Forb PROTECT(Es_param_limit = GET_SLOT(SW_VPD, install(cVegProd_names[6]))); v->veg[SW_GRASS].Es_param_limit = REAL(Es_param_limit)[0]; //Grass v->veg[SW_SHRUB].Es_param_limit = REAL(Es_param_limit)[1]; //Shrub v->veg[SW_TREES].Es_param_limit = REAL(Es_param_limit)[2]; //Tree v->veg[SW_FORBS].Es_param_limit = REAL(Es_param_limit)[3]; //Forb PROTECT(Shade = GET_SLOT(SW_VPD, install(cVegProd_names[7]))); p_Shade = REAL(Shade); v->veg[SW_GRASS].shade_scale = p_Shade[0]; v->veg[SW_GRASS].shade_deadmax = p_Shade[1]; v->veg[SW_GRASS].tr_shade_effects.xinflec = p_Shade[2]; v->veg[SW_GRASS].tr_shade_effects.yinflec = p_Shade[3]; v->veg[SW_GRASS].tr_shade_effects.range = p_Shade[4]; v->veg[SW_GRASS].tr_shade_effects.slope = p_Shade[5]; v->veg[SW_SHRUB].shade_scale = p_Shade[6]; v->veg[SW_SHRUB].shade_deadmax = p_Shade[7]; v->veg[SW_SHRUB].tr_shade_effects.xinflec = p_Shade[8]; v->veg[SW_SHRUB].tr_shade_effects.yinflec = p_Shade[9]; v->veg[SW_SHRUB].tr_shade_effects.range = p_Shade[10]; v->veg[SW_SHRUB].tr_shade_effects.slope = p_Shade[11]; v->veg[SW_TREES].shade_scale = p_Shade[12]; v->veg[SW_TREES].shade_deadmax = p_Shade[13]; v->veg[SW_TREES].tr_shade_effects.xinflec = p_Shade[14]; v->veg[SW_TREES].tr_shade_effects.yinflec = p_Shade[15]; v->veg[SW_TREES].tr_shade_effects.range = p_Shade[16]; v->veg[SW_TREES].tr_shade_effects.slope = p_Shade[17]; v->veg[SW_FORBS].shade_scale = p_Shade[18]; v->veg[SW_FORBS].shade_deadmax = p_Shade[19]; v->veg[SW_FORBS].tr_shade_effects.xinflec = p_Shade[20]; v->veg[SW_FORBS].tr_shade_effects.yinflec = p_Shade[21]; v->veg[SW_FORBS].tr_shade_effects.range = p_Shade[22]; v->veg[SW_FORBS].tr_shade_effects.slope = p_Shade[23]; PROTECT(Hydraulic_flag = GET_SLOT(SW_VPD, install(cVegProd_names[8]))); PROTECT(Hydraulic = GET_SLOT(SW_VPD, install(cVegProd_names[9]))); v->veg[SW_GRASS].flagHydraulicRedistribution = LOGICAL_POINTER(Hydraulic_flag)[0]; //Grass v->veg[SW_SHRUB].flagHydraulicRedistribution = LOGICAL_POINTER(Hydraulic_flag)[1]; //Shrub v->veg[SW_TREES].flagHydraulicRedistribution = LOGICAL_POINTER(Hydraulic_flag)[2]; //Tree v->veg[SW_FORBS].flagHydraulicRedistribution = LOGICAL_POINTER(Hydraulic_flag)[3]; //Forb v->veg[SW_GRASS].maxCondroot = REAL(Hydraulic)[0]; //Grass v->veg[SW_GRASS].swpMatric50 = REAL(Hydraulic)[1]; //Grass v->veg[SW_GRASS].shapeCond = REAL(Hydraulic)[2]; //Grass v->veg[SW_SHRUB].maxCondroot = REAL(Hydraulic)[3]; //Shrub v->veg[SW_SHRUB].swpMatric50 = REAL(Hydraulic)[4]; //Shrub v->veg[SW_SHRUB].shapeCond = REAL(Hydraulic)[5]; //Shrub v->veg[SW_TREES].maxCondroot = REAL(Hydraulic)[6]; //Tree v->veg[SW_TREES].swpMatric50 = REAL(Hydraulic)[7]; //Tree v->veg[SW_TREES].shapeCond = REAL(Hydraulic)[8]; //Tree v->veg[SW_FORBS].maxCondroot = REAL(Hydraulic)[9]; //Forb v->veg[SW_FORBS].swpMatric50 = REAL(Hydraulic)[10]; //Forb v->veg[SW_FORBS].shapeCond = REAL(Hydraulic)[11]; //Forb PROTECT(CSWP = GET_SLOT(SW_VPD, install(cVegProd_names[10]))); v->veg[SW_GRASS].SWPcrit = -10 * REAL(CSWP)[0]; //Grass v->veg[SW_SHRUB].SWPcrit = -10 * REAL(CSWP)[1]; //Shrub v->veg[SW_TREES].SWPcrit = -10 * REAL(CSWP)[2]; //Tree v->veg[SW_FORBS].SWPcrit = -10 * REAL(CSWP)[3]; //Forb // getting critSoilWater for use with SWA and get_critical_rank() // critSoilWater goes tree, shrub, forb, grass SW_VegProd.critSoilWater[0] = REAL(CSWP)[2]; SW_VegProd.critSoilWater[1] = REAL(CSWP)[1]; SW_VegProd.critSoilWater[2] = REAL(CSWP)[3]; SW_VegProd.critSoilWater[3] = REAL(CSWP)[0]; get_critical_rank(); PROTECT(MonthlyVeg = GET_SLOT(SW_VPD, install(cVegProd_names[11]))); PROTECT(Grasslands = VECTOR_ELT(MonthlyVeg, SW_GRASS)); p_Grasslands = REAL(Grasslands); for (i = 0; i < 12; i++) { v->veg[SW_GRASS].litter[i] = p_Grasslands[i + 12 * 0]; v->veg[SW_GRASS].biomass[i] = p_Grasslands[i + 12 * 1]; v->veg[SW_GRASS].pct_live[i] = p_Grasslands[i + 12 * 2]; v->veg[SW_GRASS].lai_conv[i] = p_Grasslands[i + 12 * 3]; } PROTECT(Shrublands = VECTOR_ELT(MonthlyVeg, SW_SHRUB)); p_Shrublands = REAL(Shrublands); for (i = 0; i < 12; i++) { v->veg[SW_SHRUB].litter[i] = p_Shrublands[i + 12 * 0]; v->veg[SW_SHRUB].biomass[i] = p_Shrublands[i + 12 * 1]; v->veg[SW_SHRUB].pct_live[i] = p_Shrublands[i + 12 * 2]; v->veg[SW_SHRUB].lai_conv[i] = p_Shrublands[i + 12 * 3]; } PROTECT(Forest = VECTOR_ELT(MonthlyVeg, SW_TREES)); p_Forest = REAL(Forest); for (i = 0; i < 12; i++) { v->veg[SW_TREES].litter[i] = p_Forest[i + 12 * 0]; v->veg[SW_TREES].biomass[i] = p_Forest[i + 12 * 1]; v->veg[SW_TREES].pct_live[i] = p_Forest[i + 12 * 2]; v->veg[SW_TREES].lai_conv[i] = p_Forest[i + 12 * 3]; } PROTECT(Forb = VECTOR_ELT(MonthlyVeg, SW_FORBS)); p_Forb = REAL(Forb); for (i = 0; i < 12; i++) { v->veg[SW_FORBS].litter[i] = p_Forb[i + 12 * 0]; v->veg[SW_FORBS].biomass[i] = p_Forb[i + 12 * 1]; v->veg[SW_FORBS].pct_live[i] = p_Forb[i + 12 * 2]; v->veg[SW_FORBS].lai_conv[i] = p_Forb[i + 12 * 3]; } PROTECT(CO2Coefficients = GET_SLOT(SW_VPD, install(cVegProd_names[12]))); v->veg[SW_GRASS].co2_bio_coeff1 = REAL(CO2Coefficients)[0]; v->veg[SW_SHRUB].co2_bio_coeff1 = REAL(CO2Coefficients)[1]; v->veg[SW_TREES].co2_bio_coeff1 = REAL(CO2Coefficients)[2]; v->veg[SW_FORBS].co2_bio_coeff1 = REAL(CO2Coefficients)[3]; v->veg[SW_GRASS].co2_bio_coeff2 = REAL(CO2Coefficients)[4]; v->veg[SW_SHRUB].co2_bio_coeff2 = REAL(CO2Coefficients)[5]; v->veg[SW_TREES].co2_bio_coeff2 = REAL(CO2Coefficients)[6]; v->veg[SW_FORBS].co2_bio_coeff2 = REAL(CO2Coefficients)[7]; v->veg[SW_GRASS].co2_wue_coeff1 = REAL(CO2Coefficients)[8]; v->veg[SW_SHRUB].co2_wue_coeff1 = REAL(CO2Coefficients)[9]; v->veg[SW_TREES].co2_wue_coeff1 = REAL(CO2Coefficients)[10]; v->veg[SW_FORBS].co2_wue_coeff1 = REAL(CO2Coefficients)[11]; v->veg[SW_GRASS].co2_wue_coeff2 = REAL(CO2Coefficients)[12]; v->veg[SW_SHRUB].co2_wue_coeff2 = REAL(CO2Coefficients)[13]; v->veg[SW_TREES].co2_wue_coeff2 = REAL(CO2Coefficients)[14]; v->veg[SW_FORBS].co2_wue_coeff2 = REAL(CO2Coefficients)[15]; SW_VPD_fix_cover(); SW_VPD_init(); if (EchoInits) _echo_VegProd(); UNPROTECT(17); }
SEXP ogrCheckExists (SEXP ogrSource, SEXP Layer) { OGRLayer *poLayer; #ifdef GDALV2 GDALDataset *poDS; GDALDriver *poDriver; #else OGRDataSource *poDS; OGRSFDriver *poDriver; #endif SEXP ans, drv; int pc=0; PROTECT(ans=NEW_LOGICAL(1)); pc++; installErrorHandler(); #ifdef GDALV2 poDS=(GDALDataset*) GDALOpenEx(CHAR(STRING_ELT(ogrSource, 0)), GDAL_OF_VECTOR, NULL, NULL, NULL); if (poDS != NULL) poDriver = poDS->GetDriver(); #else poDS=OGRSFDriverRegistrar::Open(CHAR(STRING_ELT(ogrSource, 0)), FALSE, &poDriver); #endif uninstallErrorHandlerAndTriggerError(); if (poDS==NULL) { // installErrorHandler(); // OGRDataSource::DestroyDataSource( poDS ); // uninstallErrorHandlerAndTriggerError(); // delete poDS; LOGICAL_POINTER(ans)[0] = FALSE; UNPROTECT(pc); return(ans); } installErrorHandler(); poLayer = poDS->GetLayerByName(CHAR(STRING_ELT(Layer, 0))); uninstallErrorHandlerAndTriggerError(); if (poLayer == NULL) { installErrorHandler(); #ifdef GDALV2 GDALClose( poDS ); #else OGRDataSource::DestroyDataSource( poDS ); #endif uninstallErrorHandlerAndTriggerError(); // delete poDS; LOGICAL_POINTER(ans)[0] = FALSE; UNPROTECT(pc); return(ans); } LOGICAL_POINTER(ans)[0] = TRUE; PROTECT(drv=allocVector(STRSXP,1)); pc++; installErrorHandler(); #ifdef GDALV2 SET_STRING_ELT(drv, 0, mkChar(poDriver->GetDescription())); #else SET_STRING_ELT(drv, 0, mkChar(poDriver->GetName())); #endif uninstallErrorHandlerAndTriggerError(); setAttrib(ans, install("driver"), drv); installErrorHandler(); #ifdef GDALV2 GDALClose( poDS ); #else OGRDataSource::DestroyDataSource( poDS ); #endif uninstallErrorHandlerAndTriggerError(); // delete poDS; UNPROTECT(pc); return(ans); }
SEXP RGDAL_GetDriverNames(void) { #ifdef GDALV2 SEXP ans, ansnames, vattr, rattr; #else SEXP ans, ansnames; #endif int pc=0; installErrorHandler(); int nDr=GDALGetDriverCount(); uninstallErrorHandlerAndTriggerError(); PROTECT(ans = NEW_LIST(4)); pc++; PROTECT(ansnames = NEW_CHARACTER(4)); pc++; SET_STRING_ELT(ansnames, 0, COPY_TO_USER_STRING("name")); SET_STRING_ELT(ansnames, 1, COPY_TO_USER_STRING("long_name")); SET_STRING_ELT(ansnames, 2, COPY_TO_USER_STRING("create")); SET_STRING_ELT(ansnames, 3, COPY_TO_USER_STRING("copy")); setAttrib(ans, R_NamesSymbol, ansnames); // PROTECT(sxpDriverList = allocVector(STRSXP, GDALGetDriverCount())); SET_VECTOR_ELT(ans, 0, NEW_CHARACTER(nDr)); SET_VECTOR_ELT(ans, 1, NEW_CHARACTER(nDr)); SET_VECTOR_ELT(ans, 2, NEW_LOGICAL(nDr)); SET_VECTOR_ELT(ans, 3, NEW_LOGICAL(nDr)); #ifdef GDALV2 PROTECT(vattr = NEW_LOGICAL(nDr)); pc++; PROTECT(rattr = NEW_LOGICAL(nDr)); pc++; #endif int i, flag; installErrorHandler(); for (i = 0; i < nDr; ++i) { #ifdef GDALV2 LOGICAL_POINTER(vattr)[i] = FALSE; LOGICAL_POINTER(rattr)[i] = FALSE; #endif GDALDriver *pDriver = GetGDALDriverManager()->GetDriver(i); #ifdef GDALV2 if(pDriver->GetMetadataItem(GDAL_DCAP_VECTOR) != NULL) LOGICAL_POINTER(vattr)[i] = TRUE; if(pDriver->GetMetadataItem(GDAL_DCAP_RASTER) != NULL) LOGICAL_POINTER(rattr)[i] = TRUE; #endif SET_STRING_ELT(VECTOR_ELT(ans, 0), i, mkChar(GDALGetDriverShortName( pDriver ))); SET_STRING_ELT(VECTOR_ELT(ans, 1), i, mkChar(GDALGetDriverLongName( pDriver ))); flag=0; if (GDALGetMetadataItem( pDriver, GDAL_DCAP_CREATE, NULL )) flag=1; LOGICAL_POINTER(VECTOR_ELT(ans, 2))[i] = flag; flag=0; if (GDALGetMetadataItem( pDriver, GDAL_DCAP_CREATECOPY, NULL )) flag=1; LOGICAL_POINTER(VECTOR_ELT(ans, 3))[i] = flag; } uninstallErrorHandlerAndTriggerError(); #ifdef GDALV2 setAttrib(ans, install("isVector"), vattr); setAttrib(ans, install("isRaster"), rattr); #endif UNPROTECT(pc); return(ans); }
SEXP rgeos_distancefunc(SEXP env, SEXP spgeom1, SEXP spgeom2, SEXP byid, p_distfunc distfunc) { GEOSContextHandle_t GEOShandle = getContextHandle(env); GEOSGeom geom1 = rgeos_convert_R2geos(env, spgeom1); int type1 = GEOSGeomTypeId_r(GEOShandle, geom1); GEOSGeom geom2; int type2; int sym_ans = FALSE; if (spgeom2 == R_NilValue) { sym_ans = TRUE; geom2 = geom1; type2 = GEOSGeomTypeId_r(GEOShandle, geom2); } else { geom2 = rgeos_convert_R2geos(env, spgeom2); type2 = GEOSGeomTypeId_r(GEOShandle, geom2); } int m = (LOGICAL_POINTER(byid)[0] && type1 == GEOS_GEOMETRYCOLLECTION) ? GEOSGetNumGeometries_r(GEOShandle, geom1) : 1; int n = (LOGICAL_POINTER(byid)[1] && type2 == GEOS_GEOMETRYCOLLECTION) ? GEOSGetNumGeometries_r(GEOShandle, geom2) : 1; if (m == -1) error("rgeos_distancefunc: invalid number of subgeometries in geometry 1"); if (n == -1) error("rgeos_distancefunc: invalid number of subgeometries in geometry 2"); int pc=0; SEXP ans; PROTECT(ans = NEW_NUMERIC(m*n)); pc++; GEOSGeom curgeom1 = geom1; GEOSGeom curgeom2 = geom2; for(int i=0; i<m; i++) { if ( m > 1) { curgeom1 = (GEOSGeom) GEOSGetGeometryN_r(GEOShandle, geom1, i); if (curgeom1 == NULL) error("rgeos_binpredfunc: unable to get subgeometries from geometry 1"); } for(int j=0; j<n; j++) { if(sym_ans && j > i) break; if ( n > 1) { curgeom2 = (GEOSGeom) GEOSGetGeometryN_r(GEOShandle, geom2, j); if (curgeom2 == NULL) error("rgeos_binpredfunc: unable to get subgeometries from geometry 2"); } double dist; if (!distfunc(GEOShandle, curgeom1, curgeom2, &dist)) error("rgeos_distancefunc: unable to calculate distance"); NUMERIC_POINTER(ans)[n*i+j] = dist; if (sym_ans) NUMERIC_POINTER(ans)[n*j+i] = dist; } } if (LOGICAL_POINTER(byid)[0] || LOGICAL_POINTER(byid)[1]) { SEXP dims; PROTECT(dims = NEW_INTEGER(2)); pc++; INTEGER_POINTER(dims)[0] = n; INTEGER_POINTER(dims)[1] = m; setAttrib(ans, R_DimSymbol, dims); } GEOSGeom_destroy_r(GEOShandle, geom1); if (!sym_ans) GEOSGeom_destroy_r(GEOShandle, geom2); UNPROTECT(pc); return(ans); }
SEXP SP_PREFIX(Polygons_c)(SEXP pls, SEXP ID) { SEXP ans, labpt, Area, plotOrder, crds, pl, n, hole; int nps, i, pc=0, sumholes; double *areas, *areaseps, fuzz; int *po, *holes; SEXP valid; nps = length(pls); fuzz = R_pow(DOUBLE_EPS, (2.0/3.0)); areas = (double *) R_alloc((size_t) nps, sizeof(double)); areaseps = (double *) R_alloc((size_t) nps, sizeof(double)); holes = (int *) R_alloc((size_t) nps, sizeof(int)); for (i=0, sumholes=0; i<nps; i++) { areas[i] = NUMERIC_POINTER(GET_SLOT(VECTOR_ELT(pls, i), install("area")))[0]; holes[i] = LOGICAL_POINTER(GET_SLOT(VECTOR_ELT(pls, i), install("hole")))[0]; areaseps[i] = holes[i] ? areas[i] + fuzz : areas[i]; sumholes += holes[i]; } po = (int *) R_alloc((size_t) nps, sizeof(int)); if (nps > 1) { for (i=0; i<nps; i++) po[i] = i + R_OFFSET; revsort(areaseps, po, nps); } else { po[0] = 1; } if (sumholes == nps) { crds = GET_SLOT(VECTOR_ELT(pls, (po[0] - R_OFFSET)), install("coords")); PROTECT(n = NEW_INTEGER(1)); pc++; INTEGER_POINTER(n)[0] = INTEGER_POINTER(getAttrib(crds, R_DimSymbol))[0]; PROTECT(hole = NEW_LOGICAL(1)); pc++; LOGICAL_POINTER(hole)[0] = FALSE; pl = SP_PREFIX(Polygon_c)(crds, n, hole); /* bug 100417 Patrick Giraudoux */ holes[po[0] - R_OFFSET] = LOGICAL_POINTER(hole)[0]; SET_VECTOR_ELT(pls, (po[0] - R_OFFSET), pl); } PROTECT(ans = NEW_OBJECT(MAKE_CLASS("Polygons"))); pc++; SET_SLOT(ans, install("Polygons"), pls); SET_SLOT(ans, install("ID"), ID); PROTECT(Area = NEW_NUMERIC(1)); pc++; NUMERIC_POINTER(Area)[0] = 0.0; for (i=0; i<nps; i++) { NUMERIC_POINTER(Area)[0] += holes[i] ? 0.0 : fabs(areas[i]); } SET_SLOT(ans, install("area"), Area); PROTECT(plotOrder = NEW_INTEGER(nps)); pc++; for (i=0; i<nps; i++) INTEGER_POINTER(plotOrder)[i] = po[i]; SET_SLOT(ans, install("plotOrder"), plotOrder); PROTECT(labpt = NEW_NUMERIC(2)); pc++; NUMERIC_POINTER(labpt)[0] = NUMERIC_POINTER(GET_SLOT(VECTOR_ELT(pls, (po[0]-1)), install("labpt")))[0]; NUMERIC_POINTER(labpt)[1] = NUMERIC_POINTER(GET_SLOT(VECTOR_ELT(pls, (po[0]-1)), install("labpt")))[1]; SET_SLOT(ans, install("labpt"), labpt); PROTECT(valid = SP_PREFIX(Polygons_validate_c)(ans)); pc++; if (!isLogical(valid)) { UNPROTECT(pc); if (isString(valid)) error(CHAR(STRING_ELT(valid, 0))); else error("invalid Polygons object"); } UNPROTECT(pc); return(ans); }
SEXP SP_PREFIX(Polygon_c)(SEXP coords, SEXP n, SEXP ihole) { SEXP SPans, labpt, Area, ringDir, hole; double area, xc, yc; double *x, *y; int pc=0, rev=FALSE; int i, ii, nn=INTEGER_POINTER(n)[0]; SEXP valid; for (i=0; i<nn; i++) { if(!R_FINITE(NUMERIC_POINTER(coords)[i])) error("non-finite x coordinate"); if(!R_FINITE(NUMERIC_POINTER(coords)[i+nn])) error("non-finite y coordinate"); } SP_PREFIX(spRFindCG_c)(n, coords, &xc, &yc, &area); if (fabs(area) < DOUBLE_EPS) { if (!R_FINITE(xc) || !R_FINITE(xc)) { if (nn == 1) { xc = NUMERIC_POINTER(coords)[0]; yc = NUMERIC_POINTER(coords)[1]; } else if (nn == 2) { xc = (NUMERIC_POINTER(coords)[0]+NUMERIC_POINTER(coords)[1])/2.0; yc = (NUMERIC_POINTER(coords)[2]+NUMERIC_POINTER(coords)[3])/2.0; } else if (nn > 2) { xc = (NUMERIC_POINTER(coords)[0] + NUMERIC_POINTER(coords)[(nn-1)])/2.0; yc = (NUMERIC_POINTER(coords)[nn] + NUMERIC_POINTER(coords)[nn+(nn-1)])/2.0; } } } PROTECT(SPans = NEW_OBJECT(MAKE_CLASS("Polygon"))); pc++; PROTECT(ringDir = NEW_INTEGER(1)); pc++; INTEGER_POINTER(ringDir)[0] = (area > 0.0) ? -1 : 1; // -1 cw hole, 1 ccw not-hole /* RSB 100126 fixing hole assumption thanks to Javier Munoz for report */ if (INTEGER_POINTER(ihole)[0] == NA_INTEGER) { // trust ring direction if (INTEGER_POINTER(ringDir)[0] == 1) { INTEGER_POINTER(ihole)[0] = 0; } else if (INTEGER_POINTER(ringDir)[0] == -1) { INTEGER_POINTER(ihole)[0] = 1; } } else { // trust hole if (INTEGER_POINTER(ihole)[0] == 1 && INTEGER_POINTER(ringDir)[0] == 1) { rev = TRUE; INTEGER_POINTER(ringDir)[0] = -1; } if (INTEGER_POINTER(ihole)[0] == 0 && INTEGER_POINTER(ringDir)[0] == -1) { rev = TRUE; INTEGER_POINTER(ringDir)[0] = 1; } } PROTECT(hole = NEW_LOGICAL(1)); pc++; if (INTEGER_POINTER(ihole)[0] == 1) LOGICAL_POINTER(hole)[0] = TRUE; else LOGICAL_POINTER(hole)[0] = FALSE; if (rev) { x = (double *) R_alloc((size_t) nn, sizeof(double)); y = (double *) R_alloc((size_t) nn, sizeof(double)); for (i=0; i<nn; i++) { x[i] = NUMERIC_POINTER(coords)[i]; y[i] = NUMERIC_POINTER(coords)[i+nn]; } for (i=0; i<nn; i++) { ii = (nn-1)-i; NUMERIC_POINTER(coords)[ii] = x[i]; NUMERIC_POINTER(coords)[ii+nn] = y[i]; } } SET_SLOT(SPans, install("coords"), coords); PROTECT(labpt = NEW_NUMERIC(2)); pc++; NUMERIC_POINTER(labpt)[0] = xc; NUMERIC_POINTER(labpt)[1] = yc; SET_SLOT(SPans, install("labpt"), labpt); PROTECT(Area = NEW_NUMERIC(1)); pc++; NUMERIC_POINTER(Area)[0] = fabs(area); SET_SLOT(SPans, install("area"), Area); SET_SLOT(SPans, install("hole"), hole); SET_SLOT(SPans, install("ringDir"), ringDir); PROTECT(valid = SP_PREFIX(Polygon_validate_c)(SPans)); pc++; if (!isLogical(valid)) { UNPROTECT(pc); if (isString(valid)) error(CHAR(STRING_ELT(valid, 0))); else error("invalid Polygon object"); } UNPROTECT(pc); return(SPans); }