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