SEXP R_rowSums_sgCMatrix(SEXP x) {
if (!inherits(x, "sgCMatrix"))
error("'x' not of class 'sgCMatrix'");
int h, i, j, k, f, l, n;
SEXP r, px, ix;
n = INTEGER(getAttrib(x, install("Dim")))[0];
px = getAttrib(x, install("p"));
PROTECT(ix = duplicate(getAttrib(x, install("i"))));
PROTECT(r = allocVector(INTSXP, n));
memset(INTEGER(r), 0, sizeof(int) * n);
f = 0;
for (i = 1; i < LENGTH(px); i++) {
l = INTEGER(px)[i];
n = l-f;
if (n == 0)
continue;
R_isort(INTEGER(ix)+f, n);
h = INTEGER(ix)[f];
INTEGER(r)[h]++;
for (k = f+1; k < l; k++) {
j = INTEGER(ix)[k];
if (j == h)
continue;
INTEGER(r)[j]++;
h = j;
}
f = l;
}
setAttrib(r, R_NamesSymbol, VECTOR_ELT(getAttrib(x, install("Dimnames")), 0));
UNPROTECT(2);
return r;
}
SEXP rgeos_binary_STRtree_query(SEXP env, SEXP obj1, SEXP obj2) {
GEOSGeom *bbs2;
int nobj1, nobj2, i, j, pc=0, isPts=FALSE;
GEOSGeom GC, GCpts=NULL, bb;
SEXP pl, bblist;
GEOSSTRtree *str;
int *icard, *ids, *oids;
char classbuf1[BUFSIZ], classbuf2[BUFSIZ];
GEOSGeom (*rgeos_xx2MP)(SEXP, SEXP);
strcpy(classbuf1, CHAR(STRING_ELT(GET_CLASS(VECTOR_ELT(obj1, 0)), 0)));
if (!strncmp(classbuf1, "Polygons", 8))
rgeos_xx2MP = rgeos_Polygons2MP;
else if (!strncmp(classbuf1, "Lines", 5))
rgeos_xx2MP = rgeos_Lines2MP;
else
error("rgeos_binary_STRtree_query: object class %s unknown", classbuf1);
GEOSContextHandle_t GEOShandle = getContextHandle(env);
str = (GEOSSTRtree *) GEOSSTRtree_create_r(GEOShandle, (size_t) 10);
nobj1 = length(obj1);
SEXP cl2 = GET_CLASS(obj2);
if (cl2 == R_NilValue) strcpy(classbuf2, "\0");
else strcpy(classbuf2, CHAR(STRING_ELT(cl2, 0)));
if ( !strcmp( classbuf2, "SpatialPoints") ||
!strcmp(classbuf2, "SpatialPointsDataFrame")) {
isPts = TRUE;
SEXP crds = GET_SLOT(obj2, install("coords"));
SEXP dim = getAttrib(crds, install("dim"));
nobj2 = INTEGER_POINTER(dim)[0];
} else {
nobj2 = length(obj2);
}
bbs2 = (GEOSGeom *) R_alloc((size_t) nobj2, sizeof(GEOSGeom));
ids = (int *) R_alloc((size_t) nobj1, sizeof(int));
UD.ids = (int *) R_alloc((size_t) nobj1, sizeof(int));
oids = (int *) R_alloc((size_t) nobj1, sizeof(int));
for (i=0; i<nobj1; i++) {
ids[i] = i;
pl = VECTOR_ELT(obj1, i);
GC = rgeos_xx2MP(env, pl);
if (GC == NULL) {
error("rgeos_binary_STRtree_query: MP GC[%d] not created", i);
}
if ((bb = GEOSEnvelope_r(GEOShandle, GC)) == NULL) {
error("rgeos_binary_STRtree_query: envelope [%d] not created", i);
}
GEOSGeom_destroy_r(GEOShandle, GC);
GEOSSTRtree_insert_r(GEOShandle, str, bb, &(ids[i]));
}
if (isPts) {
GCpts = rgeos_SpatialPoints2geospoint(env, obj2);
} else {
strcpy(classbuf2, CHAR(STRING_ELT(GET_CLASS(VECTOR_ELT(obj2, 0)), 0)));
if (!strncmp(classbuf2, "Polygons", 8))
rgeos_xx2MP = rgeos_Polygons2MP;
else if (!strncmp(classbuf2, "Lines", 5))
rgeos_xx2MP = rgeos_Lines2MP;
else
error("rgeos_binary_STRtree_query: object class %s unknown",
classbuf2);
}
for (i=0; i<nobj2; i++) {
if (isPts) {
GC = (GEOSGeom) GEOSGetGeometryN_r(GEOShandle, GCpts, i);
} else {
pl = VECTOR_ELT(obj2, i);
GC = rgeos_xx2MP(env, pl);
}
if (GC == NULL) {
error("rgeos_binary_STRtree_query: GC[%d] not created", i);
}
if ((bb = GEOSEnvelope_r(GEOShandle, GC)) == NULL) {
error("rgeos_binary_STRtree_query: envelope [%d] not created", i);
}
GEOSGeom_destroy_r(GEOShandle, GC);
// Rprintf("i: %d, bb %s\n", i, GEOSGeomType_r(GEOShandle, bb));
bbs2[i] = bb;
}
// 110904 EJP
icard = (int *) R_alloc((size_t) nobj2, sizeof(int));
PROTECT(bblist = NEW_LIST(nobj2)); pc++;
for (i=0; i<nobj2; i++) {
UD.count = 0;
GEOSSTRtree_query_r(GEOShandle, str, bbs2[i],
(GEOSQueryCallback) cb, &UD);
icard[i] = UD.count;
if (icard[i] > 0) {
SET_VECTOR_ELT(bblist, i, NEW_INTEGER(icard[i]));
for (j=0; j<UD.count; j++) {
oids[j] = UD.ids[j] + R_OFFSET;
}
R_isort(oids, UD.count);
for (j=0; j<UD.count; j++) {
INTEGER_POINTER(VECTOR_ELT(bblist, i))[j] = oids[j];
}
}
}
GEOSSTRtree_destroy_r(GEOShandle, str);
for (i=0; i<nobj2; i++) {
GEOSGeom_destroy_r(GEOShandle, bbs2[i]);
}
UNPROTECT(pc);
return(bblist);
}
SEXP rgeos_unary_STRtree_query(SEXP env, SEXP obj) {
GEOSGeom *bbs;
int nobj, i, j, jj, pc=0;
GEOSGeom GC, bb;
SEXP pl, bblist;
GEOSSTRtree *str;
int *icard, *ids, *oids;
char classbuf[BUFSIZ];
GEOSGeom (*rgeos_xx2MP)(SEXP, SEXP);
strcpy(classbuf, CHAR(STRING_ELT(GET_CLASS(VECTOR_ELT(obj, 0)), 0)));
if (!strncmp(classbuf, "Polygons", 8))
rgeos_xx2MP = rgeos_Polygons2MP;
else if (!strncmp(classbuf, "Lines", 5))
rgeos_xx2MP = rgeos_Lines2MP;
else if (!strncmp(classbuf, "Polygon", 7))
rgeos_xx2MP = rgeos_Polygon2MP;
else
error("rgeos_binary_STRtree_query: object class %s unknown", classbuf);
GEOSContextHandle_t GEOShandle = getContextHandle(env);
str = (GEOSSTRtree *) GEOSSTRtree_create_r(GEOShandle, (size_t) 10);
nobj = length(obj);
bbs = (GEOSGeom *) R_alloc((size_t) nobj, sizeof(GEOSGeom));
ids = (int *) R_alloc((size_t) nobj, sizeof(int));
UD.ids = (int *) R_alloc((size_t) nobj, sizeof(int));
oids = (int *) R_alloc((size_t) nobj, sizeof(int));
for (i=0; i<nobj; i++) {
ids[i] = i;
pl = VECTOR_ELT(obj, i);
GC = rgeos_xx2MP(env, pl);
if (GC == NULL) {
error("rgeos_unary_STRtree_query: MP GC[%d] not created", i);
}
if ((bb = GEOSEnvelope_r(GEOShandle, GC)) == NULL) {
error("rgeos_unary_STRtree_query: envelope [%d] not created", i);
}
bbs[i] = bb;
GEOSSTRtree_insert_r(GEOShandle, str, bb, &(ids[i]));
GEOSGeom_destroy_r(GEOShandle, GC);
// 110904 EJP
}
icard = (int *) R_alloc((size_t) nobj, sizeof(int));
PROTECT(bblist = NEW_LIST(nobj-1)); pc++;
for (i=0; i<(nobj-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 (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<nobj; 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);
}
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);
}
/* backend for the all.equal() function for bn objects. */
SEXP all_equal(SEXP target, SEXP current) {
int nnodes = 0, narcs = 0;
int *t = NULL, *c = NULL;
SEXP tnodes, cnodes, cmatch, tarcs, carcs, thash, chash;
/* get the node set of each network. */
tnodes = getAttrib(getListElement(target, "nodes"), R_NamesSymbol);
cnodes = getAttrib(getListElement(current, "nodes"), R_NamesSymbol);
/* first check: node sets must have the same size. */
if (length(tnodes) != length(cnodes))
return mkString("Different number of nodes");
/* store for future use. */
nnodes = length(tnodes);
/* second check: node sets must contain the same node labels. */
PROTECT(cmatch = match(tnodes, cnodes, 0));
c = INTEGER(cmatch);
/* sorting takes care of different node orderings. */
R_isort(c, nnodes);
/* check that every node in the first network is also present in the
* second one; this is enough because the node sets have the same size
* and the nodes in each set are guaranteed to be unique. */
for (int i = 0; i < nnodes; i++) {
if (c[i] != i + 1) {
UNPROTECT(1);
return mkString("Different node sets");
}/*THEN*/
}/*FOR*/
UNPROTECT(1);
/* get the node set of each network. */
tarcs = getListElement(target, "arcs");
carcs = getListElement(current, "arcs");
/* third check: arc sets must have the same size. */
if (length(tarcs) != length(carcs))
return mkString("Different number of directed/undirected arcs");
/* store for future use. */
narcs = length(tarcs)/2;
/* fourth check: arcs sets must contain the same arcs. */
if (narcs > 0) {
/* compute the numeric hashes of both arc sets (against the same
* node set to make comparisons meaningful) and sort them. */
PROTECT(thash = arc_hash(tarcs, tnodes, FALSE, TRUE));
PROTECT(chash = arc_hash(carcs, tnodes, FALSE, TRUE));
/* dereference the resulting integer vectors. */
t = INTEGER(thash);
c = INTEGER(chash);
/* sorting takes care of different arc orderings. */
R_isort(t, narcs);
R_isort(c, narcs);
/* compare the integer vectors as generic memory areas. */
if (memcmp(t, c, narcs * sizeof(int))) {
UNPROTECT(2);
return mkString("Different arc sets");
}/*THEN*/
UNPROTECT(2);
}/*THEN*/
/* all checks completed successfully, returning TRUE. */
return ScalarLogical(TRUE);
}/*ALL_EQUAL*/
SEXP R_pncount(SEXP R_x, SEXP R_t, SEXP R_s, SEXP R_o, SEXP R_v) {
int i, j, c, f, l, k, n, nr, np, ni, e;
int *x, *o = NULL;
double s, t = 0;
SEXP px, ix, pt, it;
SEXP r, pr, ir, pl, il, rs, rc, rl, pi;
#ifdef _TIME_H
clock_t t5, t4, t3, t2, t1, t0;
t1 = t0 = clock();
if (LOGICAL(R_v)[0] == TRUE) {
if (LOGICAL(R_o)[0] == TRUE)
Rprintf("reducing ... ");
else
Rprintf("preparing ... ");
}
#endif
if (!inherits(R_x, "ngCMatrix"))
error("'x' not of class ngCMatrix");
if (!inherits(R_t, "ngCMatrix"))
error("'t' not of class ngCMatrix");
if (INTEGER(GET_SLOT(R_x, install("Dim")))[0] !=
INTEGER(GET_SLOT(R_t, install("Dim")))[0])
error("the number of rows of 'x' and 't' do not conform");
if (TYPEOF(R_s) != LGLSXP)
error("'s' not of type logical");
if (TYPEOF(R_o) != LGLSXP)
error("'o' not of type logical");
if (TYPEOF(R_v) != LGLSXP)
error("'v' not of type logical");
nr = INTEGER(GET_SLOT(R_x, install("Dim")))[0];
px = GET_SLOT(R_x, install("p"));
ix = GET_SLOT(R_x, install("i"));
pt = GET_SLOT(R_t, install("p"));
it = GET_SLOT(R_t, install("i"));
pb = INTEGER(PROTECT(allocVector(INTSXP, nr+1)));
if (LOGICAL(R_o)[0] == TRUE) {
SEXP pz, iz;
o = INTEGER(PROTECT(allocVector(INTSXP, nr)));
memset(o, 0, sizeof(int) * nr);
for (k = 0; k < LENGTH(it); k++)
o[INTEGER(it)[k]]++;
memset(pb, 0, sizeof(int) * nr);
for (k = 0; k < LENGTH(ix); k++)
pb[INTEGER(ix)[k]] = 1;
n = c = 0;
for (k = 0; k < nr; k++) {
if (pb[k])
n += o[k];
else {
o[k] = -1;
c++;
}
pb[k] = k;
}
R_qsort_int_I(o, pb, 1, nr);
for (k = 0; k < nr; k++)
o[pb[k]] = (k < c) ? -1 : k;
PROTECT(iz = allocVector(INTSXP, LENGTH(ix)));
f = 0;
for (i = 1; i < LENGTH(px); i++) {
l = INTEGER(px)[i];
if (f == l)
continue;
for (k = f; k < l; k++)
INTEGER(iz)[k] = o[INTEGER(ix)[k]];
R_isort(INTEGER(iz)+f, l-f);
f = l;
}
ix = iz;
PROTECT(pz = allocVector(INTSXP, LENGTH(pt)));
PROTECT(iz = allocVector(INTSXP, n));
f = n = INTEGER(pz)[0] = 0;
for (i = 1; i < LENGTH(pt); i++) {
l = INTEGER(pt)[i];
if (f < l) {
for (k = f, f = n; k < l; k++)
if ((j = o[INTEGER(it)[k]]) > -1)
INTEGER(iz)[n++] = j;
R_isort(INTEGER(iz)+f, n-f);
f = l;
}
INTEGER(pz)[i] = n;
}
pt = pz;
ni = LENGTH(it);
it = iz;
if (LOGICAL(R_s)[0] == FALSE)
memcpy(o, pb, sizeof(int) * nr);
#ifdef _TIME_H
t1 = clock();
if (LOGICAL(R_v)[0] == TRUE) {
Rprintf("%i indexes, dropped %i (%.2f) items [%.2fs]\n",
LENGTH(ix) + ni, c, 1 - (double) n / ni,
((double) t1 - t0) / CLOCKS_PER_SEC);
Rprintf("preparing ... ");
}
#endif
}
cpn = apn = npn = 0;
if (nb != NULL)
nbfree();
nb = (PN **) malloc(sizeof(PN *) * (nr+1));
if (nb == NULL)
error("pointer array allocation failed");
k = nr;
nb[k] = NULL;
while (k-- > 0)
nb[k] = pnadd(nb[k+1], &k, 1);
if (npn) {
nbfree();
error("node allocation failed");
}
np = ni = 0;
f = 0;
for (i = 1; i < LENGTH(px); i++) {
l = INTEGER(px)[i];
n = l-f;
if (n == 0)
continue;
x = INTEGER(ix)+f;
pnadd(nb[*x], x, n);
if (LOGICAL(R_s)[0] == FALSE && n > 1) {
if (n > 2) {
memcpy(pb, x, sizeof(int) * n);
for (k = 0; k < n-1; k++) {
if (k > 0) {
j = pb[0];
pb[0] = pb[k];
pb[k] = j;
}
pnadd(nb[pb[1]], pb+1, n-1);
}
}
np += n;
ni += n * (n-1);
}
if (npn) {
nbfree();
error("node allocation failed");
}
f = l;
R_CheckUserInterrupt();
}
#ifdef _TIME_H
t2 = clock();
if (LOGICAL(R_v)[0] == TRUE) {
Rprintf("%i itemsets, created %i (%.2f) nodes [%.2fs]\n",
2 * np + LENGTH(px) - 1, apn, (double) apn / cpn,
((double) t2 - t1) / CLOCKS_PER_SEC);
Rprintf("counting ... ");
}
#endif
cpn = npn = 0;
f = 0;
for (i = 1; i < LENGTH(pt); i++) {
l = INTEGER(pt)[i];
n = l-f;
if (n == 0)
continue;
x = INTEGER(it)+f;
pncount(nb[*x], x, n);
f = l;
R_CheckUserInterrupt();
}
#ifdef _TIME_H
t3 = clock();
if (LOGICAL(R_v)[0] == TRUE) {
Rprintf("%i transactions, processed %i (%.2f) nodes [%.2fs]\n",
LENGTH(pt) - 1, cpn, (double) npn / cpn,
((double) t3 - t2) / CLOCKS_PER_SEC);
Rprintf("writing ... ");
}
#endif
if (LOGICAL(R_s)[0] == TRUE) {
PROTECT(r = allocVector(INTSXP, LENGTH(px)-1));
/* warnings */
pl = il = pr = ir = rs = rc = rl = pi = (SEXP)0;
} else {
SEXP o, p;
PROTECT(r = allocVector(VECSXP, 6));
SET_VECTOR_ELT(r, 0, (o = NEW_OBJECT(MAKE_CLASS("ngCMatrix"))));
SET_SLOT(o, install("p"), (pl = allocVector(INTSXP, np+1)));
SET_SLOT(o, install("i"), (il = allocVector(INTSXP, ni)));
SET_SLOT(o, install("Dim"), (p = allocVector(INTSXP, 2)));
INTEGER(p)[0] = nr;
INTEGER(p)[1] = np;
SET_VECTOR_ELT(r, 1, (o = NEW_OBJECT(MAKE_CLASS("ngCMatrix"))));
SET_SLOT(o, install("p"), (pr = allocVector(INTSXP, np+1)));
SET_SLOT(o, install("i"), (ir = allocVector(INTSXP, np)));
SET_SLOT(o, install("Dim"), (p = allocVector(INTSXP, 2)));
INTEGER(p)[0] = nr;
INTEGER(p)[1] = np;
SET_VECTOR_ELT(r, 2, (rs = allocVector(REALSXP, np)));
SET_VECTOR_ELT(r, 3, (rc = allocVector(REALSXP, np)));
SET_VECTOR_ELT(r, 4, (rl = allocVector(REALSXP, np)));
SET_VECTOR_ELT(r, 5, (pi = allocVector(INTSXP, np)));
INTEGER(pl)[0] = INTEGER(pr)[0] = np = ni = 0;
t = (double) LENGTH(pt)-1;
}
cpn = npn = 0;
e = LENGTH(pt) - 1;
f = 0;
for (i = 1; i < LENGTH(px); i++) {
l = INTEGER(px)[i];
n = l-f;
if (n == 0) {
if (LOGICAL(R_s)[0] == TRUE)
INTEGER(r)[i-1] = e;
continue;
}
x = INTEGER(ix)+f;
c = pnget(nb[*x], x, n);
if (LOGICAL(R_s)[0] == TRUE)
INTEGER(r)[i-1] = c;
else if (n > 1) {
s = c / t;
memcpy(pb, x, sizeof(int) * n);
for (k = 0; k < n; k++) {
if (k > 0) {
j = pb[0];
pb[0] = pb[k];
pb[k] = j;
}
INTEGER(pi)[np] = i; /* itemset index */
REAL(rs)[np] = s;
REAL(rc)[np] = c / (double) pnget(nb[pb[1]], pb+1, n-1);
REAL(rl)[np] = REAL(rc)[np] / pnget(nb[pb[0]], pb, 1) * t;
INTEGER(ir)[np++] = pb[0];
INTEGER(pr)[np] = np;
for (j = 1; j < n; j++)
INTEGER(il)[ni++] = pb[j];
INTEGER(pl)[np] = ni;
}
}
f = l;
R_CheckUserInterrupt();
}
nbfree();
if (apn)
error("node deallocation imbalance %i", apn);
#ifdef _TIME_H
t4 = clock();
if (LOGICAL(R_v)[0] == TRUE) {
if (LOGICAL(R_s)[0] == FALSE)
Rprintf("%i rules, ", np);
else
Rprintf("%i counts, ", LENGTH(px)-1);
Rprintf("processed %i (%.2f) nodes [%.2fs]\n", cpn, (double) npn / cpn,
((double) t4 - t3) / CLOCKS_PER_SEC);
}
#endif
if (LOGICAL(R_o)[0] == TRUE) {
if (LOGICAL(R_s)[0] == FALSE) {
#ifdef _TIME_H
if (LOGICAL(R_v)[0] == TRUE)
Rprintf("recoding ... ");
#endif
f = 0;
for (i = 1; i < LENGTH(pl); i++) {
l = INTEGER(pl)[i];
if (f == l)
continue;
for (k = f; k < l; k++)
INTEGER(il)[k] = o[INTEGER(il)[k]];
R_isort(INTEGER(il)+f, l-f);
f = l;
}
for (k = 0; k < LENGTH(ir); k++)
INTEGER(ir)[k] = o[INTEGER(ir)[k]];
#ifdef _TIME_H
t5 = clock();
if (LOGICAL(R_v)[0] == TRUE)
Rprintf(" %i indexes [%.2fs]\n", LENGTH(il) + LENGTH(ir),
((double) t5 - t4) / CLOCKS_PER_SEC);
#endif
}
UNPROTECT(6);
}
else
UNPROTECT(2);
return r;
}
/* backend for the all.equal() function for bn objects. */
SEXP all_equal(SEXP target, SEXP current) {
int nnodes = 0, narcs = 0;
int *t = NULL, *c = NULL;
SEXP tnodes, cnodes, cmatch, tarcs, carcs, thash, chash, result;
/* get the node set of each network. */
tnodes = getAttrib(getListElement(target, "nodes"), R_NamesSymbol);
cnodes = getAttrib(getListElement(current, "nodes"), R_NamesSymbol);
/* first check: node sets must have the same size. */
if (LENGTH(tnodes) != LENGTH(cnodes)) {
PROTECT(result = allocVector(STRSXP, 1));
SET_STRING_ELT(result, 0, mkChar("Different number of nodes"));
UNPROTECT(1);
return result;
}/*THEN*/
/* store for future use. */
nnodes = LENGTH(tnodes);
/* second check: node sets must contain the same node labels. */
PROTECT(cmatch = match(tnodes, cnodes, 0));
c = INTEGER(cmatch);
R_isort(c, narcs);
/* check that every node in the first network is also present in the
* second one; this is enough because the node sets have the same size
* and the nodes in each set are guaranteed to be unique. */
for (int i = 0; i < nnodes; i++) {
if (c[i] != i + 1) {
PROTECT(result = allocVector(STRSXP, 1));
SET_STRING_ELT(result, 0, mkChar("Different node sets"));
UNPROTECT(2);
return result;
}/*THEN*/
}/*FOR*/
UNPROTECT(1);
/* get the node set of each network. */
tarcs = getListElement(target, "arcs");
carcs = getListElement(current, "arcs");
/* third check: arc sets must have the same size. */
if (LENGTH(tarcs) != LENGTH(carcs)) {
PROTECT(result = allocVector(STRSXP, 1));
SET_STRING_ELT(result, 0, mkChar("Different number of directed/undirected arcs"));
UNPROTECT(1);
return result;
}/*THEN*/
/* store for future use. */
narcs = LENGTH(tarcs)/2;
/* fourth check: arcs sets must contain the same arcs. */
if (narcs > 0) {
/* compute the numeric hash of the arcs and sort them. */
PROTECT(thash = arc_hash(tarcs, tnodes, FALSE, TRUE));
PROTECT(chash = arc_hash(carcs, cnodes, FALSE, TRUE));
/* dereference the resulting integer vectors. */
t = INTEGER(thash);
c = INTEGER(chash);
/* compare the integer vectors as generic memory areas. */
if (memcmp(t, c, narcs * sizeof(int))) {
PROTECT(result = allocVector(STRSXP, 1));
SET_STRING_ELT(result, 0, mkChar("Different arc sets"));
UNPROTECT(3);
return result;
}/*THEN*/
UNPROTECT(2);
}/*THEN*/
/* all checks completed successfully, returning TRUE. */
PROTECT(result = allocVector(LGLSXP, 1));
LOGICAL(result)[0] = TRUE;
UNPROTECT(1);
return result;
}/*ALL_EQUAL*/
void isevect(double *t, int *delta, int *n, int *nboot, double *gridise, int *legridise, double *gridbw1, int *legridbw1, double *gridbw2, int *legridbw2, int *nkernel, int * dup, int *nestimand, double *phat, double *estim, int* presmoothing, double *isev){
int i, j, k, boot, *indices, *deltaboot, *pnull;
double *pnull2, *ptemp, *estimboot, *tboot, *integrand, *isecomp, *deltabootdbl;
indices = malloc(*n * sizeof(int));
ptemp = malloc(*n * sizeof(double));
estimboot = malloc(*legridise * sizeof(double));
tboot = malloc(*n * sizeof(double));
integrand = malloc(*legridise * sizeof(double));
isecomp = malloc(sizeof(double));
GetRNGstate();
if(*presmoothing == 1){ // with presmoothing
deltaboot = malloc(*n * sizeof(int));
switch(*nestimand){
// S
case 1:
pnull = calloc(1, sizeof(int));
pnull2 = calloc(1, sizeof(double));
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmestim(gridise, legridise, tboot, n, pnull2, pnull, pnull, ptemp, pnull, nestimand, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
free(pnull);
free(pnull2);
break;
// H
case 2:
pnull = calloc(1, sizeof(int));
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmestim(gridise, legridise, tboot, n, gridbw2, nkernel, pnull, ptemp, dup, nestimand, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
free(pnull);
break;
// f
case 3:
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (j = 0; j < *legridbw2; j++)
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmdensfast(gridise, legridise, tboot, n, &(gridbw2[j]), nkernel, ptemp, estimboot);
for (k = 0; k < *legridise; k++)
integrand[k] = (estimboot[k] - estim[k])*(estimboot[k] - estim[k]);
simpson(integrand, legridise, isecomp);
isev[j * (*legridbw1) + i] += *isecomp;
}
}
break;
// h
case 4:
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltaboot[i] = (int)rbinom(1, phat[indices[i]]);
}
for (j = 0; j < *legridbw2; j++)
for (i = 0; i < *legridbw1; i++){
nadarayawatson(tboot, n, tboot, deltaboot, n, &(gridbw1[i]), nkernel, ptemp);
presmtwfast(gridise, legridise, tboot, n, &(gridbw2[j]), nkernel, dup, ptemp, estimboot);
for (k = 0; k < *legridise; k++)
integrand[k] = (estimboot[k] - estim[k])*(estimboot[k] - estim[k]);
simpson(integrand, legridise, isecomp);
isev[j * (*legridbw1) + i] += *isecomp;
}
}
break;
default:
break;
}
free(deltaboot);
}
else{ // without presmoothing
deltabootdbl = malloc(*n * sizeof(double));
if(*nestimand == 3){
// f
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltabootdbl[i] = (double)delta[indices[i]];
}
for (i = 0; i < *legridbw2; i++){
presmdensfast(gridise, legridise, tboot, n, &(gridbw2[i]), nkernel, deltabootdbl, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
}
else{
// h
for (boot = 0; boot < *nboot; boot++){
R_FlushConsole();
R_ProcessEvents();
for (i = 0; i < *n; i++)
indices[i] = (int)ftrunc(runif(0, 1) * (*n));
R_isort(indices, *n);
for (i = 0; i < *n; i++){
tboot[i] = t[indices[i]];
deltabootdbl[i] = (double)delta[indices[i]];
}
for (i = 0; i < *legridbw2; i++){
presmtwfast(gridise, legridise, tboot, n, &(gridbw2[i]), nkernel, dup, deltabootdbl, estimboot);
for (j = 0; j < *legridise; j++)
integrand[j] = (estimboot[j] - estim[j])*(estimboot[j] - estim[j]);
simpson(integrand, legridise, isecomp);
isev[i] += *isecomp;
}
}
}
free(deltabootdbl);
}
PutRNGstate();
free(indices);
free(ptemp);
free(estimboot);
free(tboot);
free(integrand);
free(isecomp);
}
SEXP poly_loop2(SEXP n, SEXP i_findInBox, SEXP bb, SEXP pl, SEXP nrs,
SEXP dsnap, SEXP criterion, SEXP nfIBB) {
int nn = INTEGER_POINTER(n)[0];
int crit = INTEGER_POINTER(criterion)[0];
/* int Scale = INTEGER_POINTER(scale)[0];*/
int uBound = (int) INTEGER_POINTER(nfIBB)[0]*2;
int i, j, jj, li, pc = 0;
int ii = 0;
int *card, *icard, *is, *jjs, *NRS, *cNRS;
double *bb1, *bb2, *bb3, *bb4, *plx, *ply;
double Dsnap = NUMERIC_POINTER(dsnap)[0];
// struct bbcontainer *bbs;
SEXP ans;
int jhit, khit, nrsi, nrsj;
int xx, yy, zz, ww;
card = (int *) R_alloc((size_t) nn, sizeof(int));
icard = (int *) R_alloc((size_t) nn, sizeof(int));
is = (int *) R_alloc((size_t) uBound, sizeof(int));
jjs = (int *) R_alloc((size_t) uBound, sizeof(int));
bb1 = (double *) R_alloc((size_t) nn, sizeof(double));
bb2 = (double *) R_alloc((size_t) nn, sizeof(double));
bb3 = (double *) R_alloc((size_t) nn, sizeof(double));
bb4 = (double *) R_alloc((size_t) nn, sizeof(double));
NRS = (int *) R_alloc((size_t) nn, sizeof(int));
cNRS = (int *) R_alloc((size_t) nn, sizeof(int));
for (i=0, li=0; i<nn; i++) {
card[i] = 0;
icard[i] = 0;
bb1[i] = NUMERIC_POINTER(bb)[i];
bb2[i] = NUMERIC_POINTER(bb)[i+(1*nn)];
bb3[i] = NUMERIC_POINTER(bb)[i+(2*nn)];
bb4[i] = NUMERIC_POINTER(bb)[i+(3*nn)];
NRS[i] = INTEGER_POINTER(nrs)[i];
li += NRS[i];
}
for (i=0; i<nn; i++) {
if (i == 0) cNRS[i] = 0;
else cNRS[i] = NRS[i-1] + cNRS[i-1];
}
for (i=0; i<uBound; i++) {
is[i] = 0;
jjs[i] = 0;
}
plx = (double *) R_alloc((size_t) li, sizeof(double));
ply = (double *) R_alloc((size_t) li, sizeof(double));
for (i=0, jj=0; i<nn; i++) {
nrsi = NRS[i];
for (j=0; j<nrsi; j++) {
plx[jj] = NUMERIC_POINTER(VECTOR_ELT(pl, i))[j];
ply[jj] = NUMERIC_POINTER(VECTOR_ELT(pl, i))[j+nrsi];
jj++;
/* if (i < (nn-1) && jj == li) error("polygon memory overflow");*/
}
}
for (i=0; i<(nn-1); i++) {
li = length(VECTOR_ELT(i_findInBox, i));
nrsi = NRS[i];
for (j=0; j<li; j++) {
jj = INTEGER_POINTER(VECTOR_ELT(i_findInBox, i))[j] - ROFFSET;
jhit = spOverlapC(bb1[i], bb2[i], bb3[i], bb4[i], bb1[jj],
bb2[jj], bb3[jj], bb4[jj]);
if (jhit > 0) {
khit = 0;
nrsj = NRS[jj];
if (nrsi > 0 && nrsj > 0){
khit = polypolyC(&plx[cNRS[i]], &ply[cNRS[i]], nrsi,
&plx[cNRS[jj]], &ply[cNRS[jj]], nrsj, Dsnap, crit+1L);
}
if (khit > crit) {
card[i]++;
card[jj]++;
is[ii] = i;
jjs[ii] = jj;
ii++;
/* if (ii == uBound) error("memory error, scale problem");*/
}
}
}
}
PROTECT(ans = NEW_LIST(nn)); pc++;
for (i=0; i<nn; i++) {
if (card[i] == 0) {
SET_VECTOR_ELT(ans, i, NEW_INTEGER(1));
INTEGER_POINTER(VECTOR_ELT(ans, i))[0] = 0;
} else {
SET_VECTOR_ELT(ans, i, NEW_INTEGER(card[i]));
}
}
for (i=0; i<ii; i++) {
xx = is[i];
yy = jjs[i];
zz = icard[yy];
ww = icard[xx];
/* if (zz == card[yy]) error("memory error, overflow");
if (ww == card[xx]) error("memory error, overflow");*/
INTEGER_POINTER(VECTOR_ELT(ans, yy))[zz] = xx + ROFFSET;
INTEGER_POINTER(VECTOR_ELT(ans, xx))[ww] = yy + ROFFSET;
icard[yy]++;
icard[xx]++;
}
for (i=0; i<nn; i++) {
if ((li = length(VECTOR_ELT(ans, i))) > 1) {
for (j=0; j<li; j++)
icard[j] = INTEGER_POINTER(VECTOR_ELT(ans, i))[j];
R_isort(icard, li);
for (j=0; j<li; j++)
INTEGER_POINTER(VECTOR_ELT(ans, i))[j] = icard[j];
}
}
UNPROTECT(pc);
return(ans);
}
