static void ProbSampleNoReplace(int n, double *p, int *perm,
int nans, int *ans)
{
double rT, mass, totalmass;
int i, j, k, n1;
/* Record element identities */
for (i = 0; i < n; i++)
perm[i] = i; // + 1;
/* Sort probabilities into descending order */
/* Order element identities in parallel */
revsort(p, perm, n);
/* Compute the sample */
totalmass = 1;
for (i = 0, n1 = n - 1; i < nans; i++, n1--) {
rT = totalmass * unif_rand();
mass = 0;
for (j = 0; j < n1; j++) {
mass += p[j];
if (rT <= mass)
break;
}
ans[i] = perm[j];
totalmass -= p[j];
for (k = j; k < n1; k++) {
p[k] = p[k + 1];
perm[k] = perm[k + 1];
}
}
}
static void ProbSampleReplace(int n, double *p, int *perm, int nans, int *ans)
{
double rU;
int i, j;
int nm1 = n - 1;
/* record element identities */
for (i = 0; i < n; i++)
perm[i] = i; // + 1;
/* sort the probabilities into descending order */
revsort(p, perm, n);
/* compute cumulative probabilities */
for (i = 1 ; i < n; i++)
p[i] += p[i - 1];
/* compute the sample */
for (i = 0; i < nans; i++) {
rU = unif_rand();
for (j = 0; j < nm1; j++) {
if (rU <= p[j])
break;
}
ans[i] = perm[j];
}
}
/* sampling with replacement and unequal probabilties, internal copy of the
* ProbSampleReplace function in src/main/random.c.
* Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
* Copyright (C) 1997--2010 The R Development Core Team
* Copyright (C) 2003--2008 The R Foundation
* licensed under "GPLv2 or later" licence. */
void ProbSampleReplace(int n, double *p, int *perm, int nans, int *ans) {
double rU = 0;
int i = 0, j = 0;
int nm1 = n - 1;
/* record element identities. */
for (i = 0; i < n; i++)
perm[i] = i + 1;
/* sort the probabilities into descending order. */
revsort(p, perm, n);
/* compute cumulative probabilities. */
for (i = 1 ; i < n; i++)
p[i] += p[i - 1];
/* compute the sample. */
for (i = 0; i < nans; i++) {
rU = unif_rand();
for (j = 0; j < nm1; j++)
if (rU <= p[j])
break;
ans[i] = perm[j];
}/*FOR*/
}/*PROBSAMPLEREPLACE*/
void oldmyrevsort_(double *a, int *ib, int *pn)
{
revsort(a, ib, *pn);
// this program can not sort (1,1,1) properly!!!
return;
}
void CondProbSampleReplace(int r, int c, double *p, int *conf, int *perm,
int nans, int *ans, int *warn) {
int i = 0, j = 0;
double rU = 0;
/* record element identities. */
for (i = 0; i < r; i ++)
for (j = 0; j < c; j++)
perm[CMC(i, j, r)] = i + 1;
/* sort the probabilities into descending order. */
for (j = 0; j < c; j++)
revsort(p + j * r, perm + j * r, r);
/* compute cumulative probabilities. */
for (j = 0; j < c; j++)
for (i = 1 ; i < r; i++)
p[CMC(i, j, r)] += p[CMC(i - 1, j, r)];
/* compute the sample. */
for (i = 0; i < nans; i++) {
/* check whether the parents' configuration is missing. */
if (conf[i] == NA_INTEGER) {
ans[i] = NA_INTEGER;
*warn = TRUE;
continue;
}/*THEN*/
/* check whether the conditional distribution is missing. */
if (ISNAN(p[CMC(0, conf[i], r)])) {
ans[i] = NA_INTEGER;
*warn = TRUE;
continue;
}/*THEN*/
rU = unif_rand();
for (j = 0; j < r; j++)
if (rU <= p[CMC(j, conf[i], r)])
break;
ans[i] = perm[CMC(j, conf[i], r)];
}/*FOR*/
}/*CONDPROBSAMPLEREPLACE*/
SEXP SP_PREFIX(SpatialPolygons_plotOrder_c)(SEXP pls) {
SEXP plotOrder;
int pc=0, ng, i;
int *po;
double *areas;
ng = length(pls);
areas = (double *) R_alloc((size_t) ng, sizeof(double));
po = (int *) R_alloc((size_t) ng, sizeof(int));
for (i=0; i<ng; i++) {
areas[i] = NUMERIC_POINTER(GET_SLOT(VECTOR_ELT(pls, i),
install("area")))[0];
po[i] = i + R_OFFSET;
}
revsort(areas, po, ng);
PROTECT(plotOrder = NEW_INTEGER(ng)); pc++;
for (i=0; i<ng; i++) INTEGER_POINTER(plotOrder)[i] = po[i];
UNPROTECT(pc);
return(plotOrder);
}
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 rgeos_geospolygon2Polygons(SEXP env, GEOSGeom geom, SEXP ID) {
GEOSContextHandle_t GEOShandle = getContextHandle(env);
int pc=0;
int type = GEOSGeomTypeId_r(GEOShandle, geom);
int empty = GEOSisEmpty_r(GEOShandle, geom);
int ngeom = GEOSGetNumGeometries_r(GEOShandle, geom);
ngeom = ngeom ? ngeom : 1;
int npoly = 0;
for (int i=0; i<ngeom; i++) {
GEOSGeom GC = (type == GEOS_MULTIPOLYGON && !empty) ?
(GEOSGeometry *) GEOSGetGeometryN_r(GEOShandle, geom, i) :
geom;
int GCempty = GEOSisEmpty_r(GEOShandle, GC);
int GCpolys = (GCempty) ? 1 :
GEOSGetNumInteriorRings_r(GEOShandle, GC) + 1;
npoly += GCpolys;
}
SEXP polys;
PROTECT(polys = NEW_LIST(npoly)); pc++;
int *comm = (int *) R_alloc((size_t) npoly, sizeof(int));
int *po = (int *) R_alloc((size_t) npoly, sizeof(int));
double *areas = (double *) R_alloc((size_t) npoly, sizeof(double));
double totalarea = 0.0;
int k = 0;
for (int i=0; i<ngeom; i++) {
GEOSGeom GC = (type == GEOS_MULTIPOLYGON && !empty) ?
(GEOSGeometry *) GEOSGetGeometryN_r(GEOShandle, geom, i) :
geom;
if (GEOSisEmpty_r(GEOShandle, GC)) {
SEXP ringDir,area,labpt,hole;
PROTECT(ringDir = NEW_INTEGER(1));
INTEGER_POINTER(ringDir)[0] = 1;
PROTECT(labpt = NEW_NUMERIC(2));
NUMERIC_POINTER(labpt)[0] = NA_REAL;
NUMERIC_POINTER(labpt)[1] = NA_REAL;
PROTECT(area = NEW_NUMERIC(1));
NUMERIC_POINTER(area)[0] = 0.0;
PROTECT(hole = NEW_LOGICAL(1));
LOGICAL_POINTER(hole)[0] = TRUE;
SEXP poly;
PROTECT(poly = NEW_OBJECT(MAKE_CLASS("Polygon")));
SET_SLOT(poly, install("ringDir"), ringDir);
SET_SLOT(poly, install("labpt"), labpt);
SET_SLOT(poly, install("area"), area);
SET_SLOT(poly, install("hole"), hole);
SET_SLOT(poly, install("coords"), R_NilValue);
SET_VECTOR_ELT(polys, k, poly);
UNPROTECT(5);
comm[k] = 0;
areas[k] = 0;
po[k] = k + R_OFFSET;
// modified 131004 RSB
// https://stat.ethz.ch/pipermail/r-sig-geo/2013-October/019470.html
// warning("rgeos_geospolygon2Polygons: empty Polygons object");
error("rgeos_geospolygon2Polygons: empty Polygons object");
k++;
} else {
GEOSGeom lr = (GEOSGeometry *) GEOSGetExteriorRing_r(GEOShandle, GC);
if (lr == NULL)
error("rgeos_geospolygon2Polygons: exterior ring failure");
SET_VECTOR_ELT(polys, k, rgeos_geosring2Polygon(env, lr, FALSE));
comm[k] = 0;
areas[k] = NUMERIC_POINTER( GET_SLOT(VECTOR_ELT(polys,k), install("area")) )[0];
totalarea += areas[k];
po[k] = k + R_OFFSET;
int ownerk = k + R_OFFSET;
k++;
int nirs = GEOSGetNumInteriorRings_r(GEOShandle, GC);
for (int j=0; j<nirs; j++) {
lr = (GEOSGeometry *) GEOSGetInteriorRingN_r(GEOShandle, GC, j);
if (lr == NULL)
error("rgeos_geospolygon2Polygons: interior ring failure");
SET_VECTOR_ELT(polys, k, rgeos_geosring2Polygon(env, lr, TRUE));
comm[k] = ownerk;
areas[k] = NUMERIC_POINTER( GET_SLOT(VECTOR_ELT(polys,k), install("area")) )[0];
po[k] = k + R_OFFSET;
k++;
}
}
}
SEXP plotOrder;
PROTECT(plotOrder = NEW_INTEGER(npoly)); pc++;
revsort(areas, po, npoly);
for (int i=0; i<npoly; i++)
INTEGER_POINTER(plotOrder)[i] = po[i];
SEXP labpt = GET_SLOT(VECTOR_ELT(polys,po[0]-1), install("labpt"));
SEXP area;
PROTECT(area = NEW_NUMERIC(1)); pc++;
NUMERIC_POINTER(area)[0] = totalarea;
SEXP comment;
PROTECT(comment = NEW_CHARACTER(1)); pc++;
char *buf;
int nc;
nc = (int) (ceil(log10(npoly)+1.0))+1;
buf = (char *) R_alloc((size_t) (npoly*nc)+1, sizeof(char));
SP_PREFIX(comm2comment)(buf, (npoly*nc)+1, comm, npoly);
SET_STRING_ELT(comment, 0, mkChar((const char*) buf));
SEXP ans;
PROTECT(ans = NEW_OBJECT(MAKE_CLASS("Polygons"))); pc++;
SET_SLOT(ans, install("Polygons"), polys);
SET_SLOT(ans, install("plotOrder"), plotOrder);
SET_SLOT(ans, install("labpt"), labpt);
SET_SLOT(ans, install("ID"), ID);
SET_SLOT(ans, install("area"), area);
setAttrib(ans, install("comment"), comment);
UNPROTECT(pc);
return(ans);
}
SEXP rgeos_geospolygon2SpatialPolygons(SEXP env, GEOSGeom geom, SEXP p4s, SEXP IDs, int ng) {
GEOSContextHandle_t GEOShandle = getContextHandle(env);
int pc=0;
SEXP bbox, comment;
PROTECT(bbox = rgeos_geom2bbox(env, geom)); pc++;
int type = GEOSGeomTypeId_r(GEOShandle, geom);
int empty = GEOSisEmpty_r(GEOShandle, geom);
if (ng < 1)
error("rgeos_geospolygon2SpatialPolygons: invalid number of geometries");
if (ng > length(IDs))
error("rgeos_geospolygon2SpatialPolygons: ng > length(IDs)");
SEXP pls;
PROTECT(pls = NEW_LIST(ng)); pc++;
double *areas = (double *) R_alloc((size_t) ng, sizeof(double));
int *po = (int *) R_alloc((size_t) ng, sizeof(int));
for (int i=0; i<ng; i++) {
GEOSGeom GC = (type == GEOS_GEOMETRYCOLLECTION && !empty) ?
(GEOSGeometry *) GEOSGetGeometryN_r(GEOShandle, geom, i) :
geom;
if (GC == NULL)
error("rgeos_geospolygon2SpatialPolygons: unable to get subgeometry");
SEXP poly, ID;
PROTECT( ID = NEW_CHARACTER(1));
SET_STRING_ELT(ID,0,STRING_ELT(IDs, i));
PROTECT( poly = rgeos_geospolygon2Polygons(env, GC, ID) );
areas[i] = NUMERIC_POINTER(GET_SLOT(poly, install("area")))[0];
SET_VECTOR_ELT(pls, i, poly);
po[i] = i + R_OFFSET;
UNPROTECT(2);
}
revsort(areas, po, ng);
SEXP plotOrder;
PROTECT(plotOrder = NEW_INTEGER(ng)); pc++;
for (int i=0; i<ng; i++)
INTEGER_POINTER(plotOrder)[i] = po[i];
SEXP ans;
PROTECT(ans = NEW_OBJECT(MAKE_CLASS("SpatialPolygons"))); pc++;
SET_SLOT(ans, install("polygons"), pls);
SET_SLOT(ans, install("proj4string"), p4s);
SET_SLOT(ans, install("plotOrder"), plotOrder);
SET_SLOT(ans, install("bbox"), bbox);
// RSB 120417 add top-level comment that all member Polygons
// objects have comment set
PROTECT(comment = NEW_CHARACTER(1)); pc++;
SET_STRING_ELT(comment, 0, mkChar("TRUE"));
setAttrib(ans, install("comment"), comment);
UNPROTECT(pc);
return(ans);
}
