Пример #1
0
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);
}
Пример #2
0
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);

}
Пример #3
0
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);
}
Пример #4
0
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);
}
Пример #5
0
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);
}
Пример #6
0
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);

}
Пример #7
0
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);

}
Пример #8
0
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);

}
Пример #9
0
// 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);
}
Пример #10
0
/**
 * 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);

}
Пример #11
0
Файл: bitwise.c Проект: cran/oce
/*#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);
}
Пример #12
0
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);
}
Пример #13
0
// 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);
}
Пример #14
0
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);
}
Пример #15
0
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) );
}
Пример #16
0
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);
}
Пример #17
0
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;
}
Пример #18
0
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);

}
Пример #19
0
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) );
}
Пример #20
0
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);

}
Пример #21
0
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
}
Пример #22
0
//----------------------------------------------------------------------------
	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);
	}
Пример #23
0
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;
}
Пример #24
0
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);
}
Пример #25
0
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);
}
Пример #26
0
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);
}
Пример #27
0
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);

}
Пример #28
0
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);
}
Пример #29
0
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);
}
Пример #30
0
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);

}