Graph* Stack_Graph(const Stack *stack, int conn, const int *range,
Weight_Func_t *wf)
{
int x, y, z;
int offset = 0;
int is_in_bound[26];
int nbound;
int i;
int stack_range[6];
if (range == NULL) {
stack_range[0] = 0;
stack_range[1] = stack->width - 1;
stack_range[2] = 0;
stack_range[3] = stack->height - 1;
stack_range[4] = 0;
stack_range[5] = stack->depth - 1;
} else {
stack_range[0] = imax2(0, range[0]);
stack_range[1] = imin2(stack->width - 1, range[1]);
stack_range[2] = imax2(0, range[2]);
stack_range[3] = imin2(stack->height - 1, range[3]);
stack_range[4] = imax2(0, range[4]);
stack_range[5] = imin2(stack->depth - 1, range[5]);
}
int cdepth = stack_range[5] - stack_range[4];
int cheight = stack_range[3] - stack_range[2];
int cwidth = stack_range[1] - stack_range[0];
int nvertex = (cwidth + 1) * (cheight + 1) * (cdepth + 1);
Graph *graph = Make_Graph(nvertex, nvertex, TRUE);
int neighbor[26];
int scan_mask[26];
Stack_Neighbor_Offset(conn, cwidth + 1, cheight + 1, neighbor);
const double *dist = Stack_Neighbor_Dist(conn);
const int *x_offset = Stack_Neighbor_X_Offset(conn);
const int *y_offset = Stack_Neighbor_Y_Offset(conn);
const int *z_offset = Stack_Neighbor_Z_Offset(conn);
double args[3];
for (i = 0; i < conn; i++) {
scan_mask[i] = (neighbor[i] > 0);
}
for (z = 0; z <= cdepth; z++) {
for (y = 0; y <= cheight; y++) {
for (x = 0; x <= cwidth; x++) {
nbound = Stack_Neighbor_Bound_Test(conn, cwidth, cheight, cdepth,
x, y, z, is_in_bound);
if (nbound == conn) {
for (i = 0; i < conn; i++) {
if (scan_mask[i] == 1) {
double weight = dist[i];
if (wf != NULL) {
args[0] = dist[i];
args[1] = Get_Stack_Pixel((Stack *)stack, x + stack_range[0],
y + stack_range[2],
z + stack_range[4], 0);
args[2] = Get_Stack_Pixel((Stack *)stack,
x + stack_range[0] + x_offset[i],
y + stack_range[2] + y_offset[i],
z + stack_range[4] + z_offset[i], 0);
weight = wf(args);
}
Graph_Add_Weighted_Edge(graph, offset, offset + neighbor[i],
weight);
}
}
} else {
for (i = 0; i < conn; i++) {
if ((scan_mask[i] == 1) && is_in_bound[i]){
double weight = dist[i];
if (wf != NULL) {
args[0] = dist[i];
args[1] = Get_Stack_Pixel((Stack *)stack, x + stack_range[0],
y + stack_range[2],
z + stack_range[4], 0);
args[2] = Get_Stack_Pixel((Stack *)stack,
x + stack_range[0] + x_offset[i],
y + stack_range[2] + y_offset[i],
z + stack_range[4] + z_offset[i], 0);
weight = wf(args);
}
Graph_Add_Weighted_Edge(graph, offset, offset + neighbor[i],
weight);
}
}
}
offset++;
}
}
}
return graph;
}
Graph* Stack_Graph_W(const Stack *stack, Stack_Graph_Workspace *sgw)
{
int x, y, z;
int offset = 0;
int is_in_bound[26];
int nbound;
int i;
int stack_range[6];
int *range = sgw->range;
if (range == NULL) {
stack_range[0] = 0;
stack_range[1] = stack->width - 1;
stack_range[2] = 0;
stack_range[3] = stack->height - 1;
stack_range[4] = 0;
stack_range[5] = stack->depth - 1;
} else {
stack_range[0] = imax2(0, range[0]);
stack_range[1] = imin2(stack->width - 1, range[1]);
stack_range[2] = imax2(0, range[2]);
stack_range[3] = imin2(stack->height - 1, range[3]);
stack_range[4] = imax2(0, range[4]);
stack_range[5] = imin2(stack->depth - 1, range[5]);
}
int cdepth = stack_range[5] - stack_range[4];
int cheight = stack_range[3] - stack_range[2];
int cwidth = stack_range[1] - stack_range[0];
int nvertex = (cwidth + 1) * (cheight + 1) * (cdepth + 1);
sgw->virtualVertex = nvertex;
BOOL weighted = TRUE;
if (sgw->sp_option == 1) {
weighted = FALSE;
sgw->intensity = darray_malloc(nvertex + 1);
sgw->intensity[nvertex] = Infinity;
}
Graph *graph = Make_Graph(nvertex, nvertex, weighted);
int neighbor[26];
int scan_mask[26];
Stack_Neighbor_Offset(sgw->conn, cwidth + 1, cheight + 1, neighbor);
int org_neighbor[26];
Stack_Neighbor_Offset(sgw->conn, Stack_Width(stack), Stack_Height(stack),
org_neighbor);
double dist[26];
Stack_Neighbor_Dist_R(sgw->conn, sgw->resolution, dist);
//const double *dist = Stack_Neighbor_Dist(sgw->conn);
const int *x_offset = Stack_Neighbor_X_Offset(sgw->conn);
const int *y_offset = Stack_Neighbor_Y_Offset(sgw->conn);
const int *z_offset = Stack_Neighbor_Z_Offset(sgw->conn);
/* go forward */
for (i = 0; i < sgw->conn; i++) {
scan_mask[i] = (neighbor[i] > 0);
}
#define STACK_GRAPH_ADD_EDGE(cond) \
for (i = 0; i < sgw->conn; i++) { \
if (cond) { \
int nx = x + stack_range[0]; \
int ny = y + stack_range[2]; \
int nz = z + stack_range[4]; \
if (Graph_Is_Weighted(graph)) { \
double weight = dist[i]; \
if (sgw->wf != NULL) { \
sgw->argv[0] = dist[i]; \
\
sgw->argv[1] = Get_Stack_Pixel((Stack *)stack, nx, ny, nz, 0); \
sgw->argv[2] = \
Get_Stack_Pixel((Stack *)stack, nx + x_offset[i], \
ny + y_offset[i], nz + z_offset[i], 0); \
weight = sgw->wf(sgw->argv); \
} \
Graph_Add_Weighted_Edge(graph, offset, offset + neighbor[i], \
weight); \
} else { \
Graph_Add_Edge(graph, offset, offset + neighbor[i]); \
sgw->intensity[offset] = Get_Stack_Pixel((Stack*) stack, \
nx, ny, nz, 0); \
} \
} \
}
int groupVertexMap[256];
for (i = 0; i < 256; ++i) {
groupVertexMap[i] = 0;
}
int swidth = cwidth + 1;
int sarea = (cwidth + 1) * (cheight + 1);
int area = stack->width * stack->height;
for (z = 0; z <= cdepth; z++) {
for (y = 0; y <= cheight; y++) {
for (x = 0; x <= cwidth; x++) {
nbound = Stack_Neighbor_Bound_Test_S(sgw->conn, cwidth, cheight,
cdepth,
x, y, z, is_in_bound);
size_t offset2 = Stack_Subindex((size_t) offset, stack_range[0],
stack_range[2], stack_range[4],
swidth, sarea, stack->width, area);
#ifdef _DEBUG_2
if (offset == 36629) {
printf("debug here\n");
}
#endif
if (nbound == sgw->conn) {
STACK_GRAPH_ADD_EDGE((scan_mask[i] == 1) &&
(sgw->signal_mask == NULL ? 1 :
((sgw->signal_mask->array[offset2] > 0) &&
(sgw->signal_mask->array[offset2+org_neighbor[i]] > 0))))
} else {
STACK_GRAPH_ADD_EDGE((scan_mask[i] == 1) && is_in_bound[i] &&
(sgw->signal_mask == NULL ? 1 :
((sgw->signal_mask->array[offset2] > 0) &&
(sgw->signal_mask->array[offset2+org_neighbor[i]]) >
0)))
}
if (sgw->group_mask != NULL) {
int groupId = sgw->group_mask->array[offset2];
if (groupId > 0) {
#ifdef _DEBUG_2
sgw->group_mask->array[offset2] = 2;
#endif
int groupVertex = groupVertexMap[groupId];
if (groupVertex <= 0) {
groupVertex = nvertex++;
groupVertexMap[groupId] = groupVertex;
}
Graph_Add_Weighted_Edge(graph, groupVertex, offset, 0.0);
}
}
offset++;
}
}
}
return graph;
}
static Rboolean
stem_leaf(double *x, int n, double scale, int width, double atom)
{
double r, c, x1, x2;
int mm, mu, k, i, j, hi, lo, xi;
int ldigits, hdigits, ndigits, pdigits;
R_rsort(x,n);
if(n <= 1)
return FALSE;
Rprintf("\n");
if(x[n-1] > x[0]) {
r = atom+(x[n-1]-x[0])/scale;
c = pow(10.,(11.-(int)(log10(r)+10)));
mm = imin2(2, imax2(0, (int)(r*c/25)));
k = 3*mm + 2 - 150/(n+50);
if ((k-1)*(k-2)*(k-5)==0)
c *= 10.;
/* need to ensure that x[i]*c does not integer overflow */
x1 = fabs(x[0]); x2 = fabs(x[n-1]);
if(x2 > x1) x1 = x2;
while(x1*c > INT_MAX) c /= 10;
if (k*(k-4)*(k-8)==0) mu = 5;
if ((k-1)*(k-5)*(k-6)==0) mu = 20;
} else {
r = atom + fabs(x[0])/scale;
c = pow(10.,(11.-(int)(log10(r)+10)));
k = 2; /* not important what */
}
mu = 10;
if (k*(k-4)*(k-8)==0) mu = 5;
if ((k-1)*(k-5)*(k-6)==0) mu = 20;
/* Find the print width of the stem. */
lo = floor(x[0] *c/mu)*mu;
hi = floor(x[n-1]*c/mu)*mu;
ldigits = (lo < 0) ? floor(log10(-lo))+1 : 0;
hdigits = (hi > 0) ? floor(log10(hi)) : 0;
ndigits = (ldigits < hdigits) ? hdigits : ldigits;
/* Starting cell */
if(lo < 0 && floor(x[0]*c) == lo)
lo=lo-mu;
hi = lo+mu;
if(floor(x[0]*c+0.5) > hi) {
lo = hi;
hi = lo+mu;
}
/* Print out the info about the decimal place */
pdigits= 1 - floor(log10(c)+0.5);
Rprintf(" The decimal point is ");
if(pdigits == 0)
Rprintf("at the |\n\n");
else
Rprintf("%d digit(s) to the %s of the |\n\n",abs(pdigits),
(pdigits > 0) ? "right" : "left");
i = 0;
do {
if(lo < 0)
stem_print(hi,lo,ndigits);
else
stem_print(lo,hi,ndigits);
j = 0;
do {
if(x[i] < 0)xi = x[i]*c - .5;
else xi = x[i]*c + .5;
if( (hi == 0 && x[i] >= 0)||
(lo < 0 && xi > hi) ||
(lo >= 0 && xi >= hi) )
break;
j++;
if(j <= width-12) {
Rprintf("%1d", abs(xi)%10);
}
i++;
} while(i < n);
if(j > width) {
Rprintf("+%d", j-width);
}
Rprintf("\n");
if(i >= n)
break;
hi += mu;
lo += mu;
} while(1);
Rprintf("\n");
return TRUE;
}
void findBestSplit(double *x, int *jdex, double *y, int mdim, int nsample,
int ndstart, int ndend, int *msplit, double *decsplit,
double *ubest, int *ndendl, int *jstat, int mtry,
double sumnode, int nodecnt, int *cat) {
int last, ncat[32], icat[32], lc, nl, nr, npopl, npopr;
int i, j, kv, l;
static int *mind, *ncase;
static double *xt, *ut, *v, *yl;
double sumcat[32], avcat[32], tavcat[32], ubestt;
double crit, critmax, critvar, suml, sumr, d, critParent;
if (in_findBestSplit==-99){
free(ncase);
free(mind); //had to remove this so that it wont crash for when mdim=0, strangely happened for replace=0
free(v);
free(yl);
free(xt);
free(ut);
// PRINTF("giving up mem in findBestSplit\n");
return;
}
if (in_findBestSplit==0){
in_findBestSplit=1;
ut = (double *) calloc(nsample, sizeof(double));
xt = (double *) calloc(nsample, sizeof(double));
v = (double *) calloc(nsample, sizeof(double));
yl = (double *) calloc(nsample, sizeof(double));
mind = (int *) calloc(mdim+1, sizeof(int)); //seems that the sometimes i am asking for kv[10] and that causes problesmms
//so allocate 1 more. helps with not crashing in windows
ncase = (int *) calloc(nsample, sizeof(int));
}
zeroDouble(ut, nsample);
zeroDouble(xt, nsample);
zeroDouble(v, nsample);
zeroDouble(yl, nsample);
zeroInt(mind, mdim);
zeroInt(ncase, nsample);
zeroDouble(avcat, 32);
zeroDouble(tavcat, 32);
/* START BIG LOOP */
*msplit = -1;
*decsplit = 0.0;
critmax = 0.0;
ubestt = 0.0;
for (i=0; i < mdim; ++i) mind[i] = i;
last = mdim - 1;
for (i = 0; i < mtry; ++i) {
critvar = 0.0;
j = (int) (unif_rand() * (last+1));
//PRINTF("j=%d, last=%d mind[j]=%d\n", j, last, mind[j]);fflush(stdout);
kv = mind[j];
//if(kv>100){
// 1;
// getchar();
//}
swapInt(mind[j], mind[last]);
/* mind[j] = mind[last];
* mind[last] = kv; */
last--;
lc = cat[kv];
if (lc == 1) {
/* numeric variable */
for (j = ndstart; j <= ndend; ++j) {
xt[j] = x[kv + (jdex[j] - 1) * mdim];
yl[j] = y[jdex[j] - 1];
}
} else {
/* categorical variable */
zeroInt(ncat, 32);
zeroDouble(sumcat, 32);
for (j = ndstart; j <= ndend; ++j) {
l = (int) x[kv + (jdex[j] - 1) * mdim];
sumcat[l - 1] += y[jdex[j] - 1];
ncat[l - 1] ++;
}
/* Compute means of Y by category. */
for (j = 0; j < lc; ++j) {
avcat[j] = ncat[j] ? sumcat[j] / ncat[j] : 0.0;
}
/* Make the category mean the `pseudo' X data. */
for (j = 0; j < nsample; ++j) {
xt[j] = avcat[(int) x[kv + (jdex[j] - 1) * mdim] - 1];
yl[j] = y[jdex[j] - 1];
}
}
/* copy the x data in this node. */
for (j = ndstart; j <= ndend; ++j) v[j] = xt[j];
for (j = 1; j <= nsample; ++j) ncase[j - 1] = j;
R_qsort_I(v, ncase, ndstart + 1, ndend + 1);
if (v[ndstart] >= v[ndend]) continue;
/* ncase(n)=case number of v nth from bottom */
/* Start from the right and search to the left. */
critParent = sumnode * sumnode / nodecnt;
suml = 0.0;
sumr = sumnode;
npopl = 0;
npopr = nodecnt;
crit = 0.0;
/* Search through the "gaps" in the x-variable. */
for (j = ndstart; j <= ndend - 1; ++j) {
d = yl[ncase[j] - 1];
suml += d;
sumr -= d;
npopl++;
npopr--;
if (v[j] < v[j+1]) {
crit = (suml * suml / npopl) + (sumr * sumr / npopr) -
critParent;
if (crit > critvar) {
ubestt = (v[j] + v[j+1]) / 2.0;
critvar = crit;
}
}
}
if (critvar > critmax) {
*ubest = ubestt;
*msplit = kv + 1;
critmax = critvar;
for (j = ndstart; j <= ndend; ++j) {
ut[j] = xt[j];
}
if (cat[kv] > 1) {
for (j = 0; j < cat[kv]; ++j) tavcat[j] = avcat[j];
}
}
}
*decsplit = critmax;
/* If best split can not be found, set to terminal node and return. */
if (*msplit != -1) {
nl = ndstart;
for (j = ndstart; j <= ndend; ++j) {
if (ut[j] <= *ubest) {
nl++;
ncase[nl-1] = jdex[j];
}
}
*ndendl = imax2(nl - 1, ndstart);
nr = *ndendl + 1;
for (j = ndstart; j <= ndend; ++j) {
if (ut[j] > *ubest) {
if (nr >= nsample) break;
nr++;
ncase[nr - 1] = jdex[j];
}
}
if (*ndendl >= ndend) *ndendl = ndend - 1;
for (j = ndstart; j <= ndend; ++j) jdex[j] = ncase[j];
lc = cat[*msplit - 1];
if (lc > 1) {
for (j = 0; j < lc; ++j) {
icat[j] = (tavcat[j] < *ubest) ? 1 : 0;
}
*ubest = pack(lc, icat);
}
} else *jstat = 1;
}
void simdetect (
int *detect, /* detector -1 single, 0 multi, 1 proximity, 2 count,... */
double *gsb0val, /* Parameter values (matrix nr= comb of g0,sigma,b nc=3) [naive animal] */
double *gsb1val, /* Parameter values (matrix nr= comb of g0,sigma,b nc=3) [caught before] */
int *cc0, /* number of g0/sigma/b combinations for naive animals */
int *cc1, /* number of g0/sigma/b combinations for caught before */
int *gsb0, /* lookup which g0/sigma/b combination to use for given g, S, K
[naive animal] */
int *gsb1, /* lookup which g0/sigma/b combination to use for given n, S, K
[caught before] */
int *N, /* number of animals */
int *ss, /* number of occasions */
int *kk, /* number of traps */
int *nmix, /* number of classes */
int *knownclass, /* known membership of 'latent' classes */
double *animals, /* x,y points of animal range centres (first x, then y) */
double *traps, /* x,y locations of traps (first x, then y) */
double *dist2, /* distances squared (optional: -1 if unused) */
double *Tsk, /* ss x kk array of 0/1 usage codes or effort */
int *btype, /* code for behavioural response
0 none
1 individual
2 individual, trap-specific
3 trap-specific
*/
int *Markov, /* learned vs transient behavioural response
0 learned
1 Markov
*/
int *binomN, /* number of trials for 'count' detector modelled with binomial */
double *miscparm, /* detection threshold on transformed scale, etc. */
int *fn, /* code 0 = halfnormal, 1 = hazard, 2 = exponential, 3 = uniform */
int *maxperpoly, /* */
int *n, /* number of individuals caught */
int *caught, /* sequence number in session (0 if not caught) */
double *detectedXY, /* x,y locations of detections */
double *signal, /* vector of signal strengths, one per detection */
int *value, /* return value array of trap locations n x s */
int *resultcode
)
{
double d2val;
double p;
int i,j,k,l,s;
int ik;
int nc = 0;
int nk = 0; /* number of detectors (polygons or transects when *detect==6,7) */
int count = 0;
int *caughtbefore;
int *x; /* mixture class of animal i */
double *pmix;
double runif;
int wxi = 0;
int c = 0;
int gpar = 2;
double g0 = 0;
double sigma = 0;
double z = 0;
double Tski = 1.0;
double *work = NULL;
double *noise = NULL; /* detectfn 12,13 only */
int *sortorder = NULL;
double *sortkey = NULL;
/*
*detect may take values -
-1 single-catch traps
0 multi-catch traps
1 binary proximity detectors
2 count proximity detectors
5 signal detectors
6 polygon detectors
7 transect detectors
*/
/*========================================================*/
/* 'single-catch only' declarations */
int tr_an_indx = 0;
int nanimals;
int ntraps;
int *occupied = NULL;
int *intrap = NULL;
struct trap_animal *tran = NULL;
double event_time;
int anum = 0;
int tnum = 0;
int nextcombo;
int finished;
int OK;
/*========================================================*/
/* 'multi-catch only' declarations */
double *h = NULL; /* multi-catch only */
double *hsum = NULL; /* multi-catch only */
double *cump = NULL; /* multi-catch only */
/*========================================================*/
/* 'polygon & transect only' declarations */
int nd = 0;
int cumk[maxnpoly+1];
int sumk; /* total number of vertices */
int g=0;
int *gotcha;
double xy[2];
int n1,n2,t;
double par[3];
int np = 1; /* n points each call of gxy */
double w, ws;
int maxdet=1;
double *cumd = NULL;
struct rpoint *line = NULL;
struct rpoint xyp;
struct rpoint animal;
double lx;
double maxg = 0;
double lambdak; /* temp value for Poisson rate */
double grx; /* temp value for integral gr */
double H;
int J;
int maybecaught;
double dx,dy,d;
double pks;
double sumhaz;
/*========================================================*/
/* 'signal-strength only' declarations */
double beta0;
double beta1;
double muS;
double sdS;
double muN = 0;
double sdN = 1;
double signalvalue;
double noisevalue;
double cut;
double *ex;
/*========================================================*/
/* MAIN LINE */
gotcha = &g;
*resultcode = 1;
caughtbefore = (int *) R_alloc(*N * *kk, sizeof(int));
x = (int *) R_alloc(*N, sizeof(int));
for (i=0; i<*N; i++) x[i] = 0;
pmix = (double *) R_alloc(*nmix, sizeof(double));
/* ------------------------------------------------------ */
/* pre-compute distances */
if (dist2[0] < 0) {
dist2 = (double *) S_alloc(*kk * *N, sizeof(double));
makedist2 (*kk, *N, traps, animals, dist2);
}
else {
squaredist (*kk, *N, dist2);
}
/* ------------------------------------------------------ */
if ((*detect < -1) || (*detect > 7)) return;
if (*detect == -1) { /* single-catch only */
occupied = (int*) R_alloc(*kk, sizeof(int));
intrap = (int*) R_alloc(*N, sizeof(int));
tran = (struct trap_animal *) R_alloc(*N * *kk,
sizeof(struct trap_animal));
/* 2*sizeof(int) + sizeof(double)); */
}
if (*detect == 0) { /* multi-catch only */
h = (double *) R_alloc(*N * *kk, sizeof(double));
hsum = (double *) R_alloc(*N, sizeof(double));
cump = (double *) R_alloc(*kk+1, sizeof(double));
cump[0] = 0;
}
if (*detect == 5) { /* signal only */
maxdet = *N * *ss * *kk;
if (!((*fn == 10) || (*fn == 11)))
error ("simsecr not implemented for this combination of detector & detectfn");
}
if ((*detect == 3) || (*detect == 4) || (*detect == 6) || (*detect == 7)) {
/* polygon or transect */
cumk[0] = 0;
for (i=0; i<maxnpoly; i++) { /* maxnpoly much larger than npoly */
if (kk[i]<=0) break;
cumk[i+1] = cumk[i] + kk[i];
nk++;
}
sumk = cumk[nk];
if ((*detect == 6) || (*detect == 7))
maxdet = *N * *ss * nk * *maxperpoly;
else
maxdet = *N * *ss;
}
else nk = *kk;
if ((*detect == 4) || (*detect == 7)) { /* transect only */
line = (struct rpoint *) R_alloc(sumk, sizeof(struct rpoint));
cumd = (double *) R_alloc(sumk, sizeof(double));
/* coordinates of vertices */
for (i=0; i<sumk; i++) {
line[i].x = traps[i];
line[i].y = traps[i+sumk];
}
/* cumulative distance along line; all transects end on end */
for (k=0; k<nk; k++) {
cumd[cumk[k]] = 0;
for (i=cumk[k]; i<(cumk[k+1]-1); i++) {
cumd[i+1] = cumd[i] + distance(line[i], line[i+1]);
}
}
}
if ((*detect==3) || (*detect==4) || (*detect==5) || (*detect==6) || (*detect==7)) {
work = (double*) R_alloc(maxdet*2, sizeof(double)); /* twice size needed for signal */
sortorder = (int*) R_alloc(maxdet, sizeof(int));
sortkey = (double*) R_alloc(maxdet, sizeof(double));
}
if ((*fn==12) || (*fn==13)) {
noise = (double*) R_alloc(maxdet*2, sizeof(double)); /* twice size needed for signal */
}
GetRNGstate();
gpar = 2;
if ((*fn == 1) || (*fn == 3) || (*fn == 5)|| (*fn == 6) || (*fn == 7) || (*fn == 8) ||
(*fn == 10) || (*fn == 11)) gpar ++;
/* ------------------------------------------------------------------------- */
/* mixture models */
/* may be better to pass pmix */
if (*nmix>1) {
if (*nmix>2)
error("simsecr nmix>2 not implemented");
gpar++; /* these models have one more detection parameter */
for (i=0; i<*nmix; i++) {
wxi = i4(0,0,0,i,*N,*ss,nk);
c = gsb0[wxi] - 1;
pmix[i] = gsb0val[*cc0 * (gpar-1) + c]; /* assuming 4-column gsb */
}
for (i=0; i<*N; i++) {
if (knownclass[i] > 1)
x[i] = knownclass[i] - 2; /* knownclass=2 maps to x=0 etc. */
else
x[i] = rdiscrete(*nmix, pmix) - 1;
}
}
/* ------------------------------------------------------------------------- */
/* zero caught status */
for (i=0; i<*N; i++)
caught[i] = 0;
for (i=0; i<*N; i++)
for (k=0; k < nk; k++)
caughtbefore[k * (*N-1) + i] = 0;
/* ------------------------------------------------------------------------- */
/* MAIN LOOP */
for (s=0; s<*ss; s++) {
/* ------------------ */
/* single-catch traps */
if (*detect == -1) {
/* initialise day */
tr_an_indx = 0;
nanimals = *N;
ntraps = nk;
for (i=0; i<*N; i++) intrap[i] = 0;
for (k=0; k<nk; k++) occupied[k] = 0;
nextcombo = 0;
/* make tran */
for (i=0; i<*N; i++) { /* animals */
for (k=0; k<nk; k++) { /* traps */
Tski = Tsk[s * nk + k];
if (fabs(Tski) > 1e-10) {
getpar (i, s, k, x[i], *N, *ss, nk, *cc0, *cc1, *fn,
bswitch (*btype, *N, i, k, caughtbefore),
gsb0, gsb0val, gsb1, gsb1val, &g0, &sigma, &z);
/* d2val = d2(i,k, animals, traps, *N, nk); */
d2val = d2L(k, i, dist2, nk);
p = pfn(*fn, d2val, g0, sigma, z, miscparm, 1e20); /* effectively inf w2 */
if (fabs(Tski-1) > 1e-10)
p = 1 - pow(1-p, Tski);
event_time = randomtime(p);
if (event_time <= 1) {
tran[tr_an_indx].time = event_time;
tran[tr_an_indx].animal = i; /* 0..*N-1 */
tran[tr_an_indx].trap = k; /* 0..nk-1 */
tr_an_indx++;
}
}
}
}
/* end of make tran */
if (tr_an_indx > 1) probsort (tr_an_indx, tran);
while ((nextcombo < tr_an_indx) && (nanimals>0) && (ntraps>0)) {
finished = 0;
OK = 0;
while ((1-finished)*(1-OK) > 0) { /* until finished or OK */
if (nextcombo >= (tr_an_indx))
finished = 1; /* no more to process */
else {
anum = tran[nextcombo].animal;
tnum = tran[nextcombo].trap;
OK = (1-occupied[tnum]) * (1-intrap[anum]); /* not occupied and not intrap */
nextcombo++;
}
}
if (finished==0) {
/* Record this capture */
occupied[tnum] = 1;
intrap[anum] = tnum+1; /* trap = k+1 */
nanimals--;
ntraps--;
}
}
for (i=0; i<*N; i++) {
if (intrap[i]>0) {
if (caught[i]==0) { /* first capture of this animal */
nc++;
caught[i] = nc; /* nc-th animal to be captured */
for (j=0; j<*ss; j++)
value[*ss * (nc-1) + j] = 0;
}
value[*ss * (caught[i]-1) + s] = intrap[i]; /* trap = k+1 */
}
}
}
/* -------------------------------------------------------------------------- */
/* multi-catch trap; only one site per occasion (drop last dimension of capt) */
else if (*detect == 0) {
for (i=0; i<*N; i++) {
hsum[i] = 0;
for (k=0; k<nk; k++) {
Tski = Tsk[s * nk + k];
if (fabs(Tski) > 1e-10) {
getpar (i, s, k, x[i], *N, *ss, nk, *cc0, *cc1, *fn,
bswitch (*btype, *N, i, k, caughtbefore),
gsb0, gsb0val, gsb1, gsb1val, &g0, &sigma, &z);
/* d2val = d2(i,k, animals, traps, *N, nk); */
d2val = d2L(k, i, dist2, nk);
p = pfn(*fn, d2val, g0, sigma, z, miscparm, 1e20);
h[k * *N + i] = - Tski * log(1 - p);
hsum[i] += h[k * *N + i];
}
}
for (k=0; k<nk; k++) {
cump[k+1] = cump[k] + h[k * *N + i]/hsum[i];
}
if (Random() < (1-exp(-hsum[i]))) {
if (caught[i]==0) { /* first capture of this animal */
nc++;
caught[i] = nc;
for (j=0; j<*ss; j++)
value[*ss * (nc-1) + j] = 0;
}
/* find trap with probability proportional to p
searches cumulative distribution of p */
runif = Random();
k = 0;
while ((runif > cump[k]) && (k<nk)) k++;
value[*ss * (caught[i]-1) + s] = k; /* trap = k+1 */
}
}
}
/* -------------------------------------------------------------------------------- */
/* the 'proximity' group of detectors 1:2 - proximity, count */
else if ((*detect >= 1) && (*detect <= 2)) {
for (i=0; i<*N; i++) {
for (k=0; k<nk; k++) {
Tski = Tsk[s * nk + k];
if (fabs(Tski) > 1e-10) {
getpar (i, s, k, x[i], *N, *ss, nk, *cc0, *cc1, *fn,
bswitch (*btype, *N, i, k, caughtbefore),
gsb0, gsb0val, gsb1, gsb1val, &g0, &sigma, &z);
/* d2val = d2(i,k, animals, traps, *N, nk); */
d2val = d2L(k, i, dist2, nk);
p = pfn(*fn, d2val, g0, sigma, z, miscparm, 1e20);
if (p < -0.1) { PutRNGstate(); return; } /* error */
if (p>0) {
if (*detect == 1) {
if (fabs(Tski-1) > 1e-10)
p = 1 - pow(1-p, Tski);
count = Random() < p; /* binary proximity */
}
else if (*detect == 2) { /* count proximity */
if (*binomN == 1)
count = rcount(round(Tski), p, 1);
else
count = rcount(*binomN, p, Tski);
}
if (count>0) {
if (caught[i]==0) { /* first capture of this animal */
nc++;
caught[i] = nc;
for (j=0; j<*ss; j++)
for (l=0; l<nk; l++)
value[*ss * ((nc-1) * nk + l) + j] = 0;
}
value[*ss * ((caught[i]-1) * nk + k) + s] = count;
}
}
}
}
}
}
/* -------------------------------------------------------------------------------- */
/* exclusive polygon detectors */
else if (*detect == 3) {
/* find maximum distance between animal and detector vertex */
w = 0;
J = cumk[nk];
for (i = 0; i< *N; i++) {
for (j = 0; j < J; j++) {
dx = animals[i] - traps[j];
dy = animals[*N + i] - traps[J + j];
d = sqrt(dx*dx + dy*dy);
if (d > w) w = d;
}
}
for (i=0; i<*N; i++) {
/* this implementation assumes NO VARIATION AMONG DETECTORS */
getpar (i, s, 0, x[i], *N, *ss, nk, *cc0, *cc1, *fn,
bswitch (*btype, *N, i, 0, caughtbefore),
gsb0, gsb0val, gsb1, gsb1val, &g0, &sigma, &z);
maybecaught = Random() < g0;
if (w > (10 * sigma))
ws = 10 * sigma;
else
ws = w;
par[0] = 1;
par[1] = sigma;
par[2] = z;
if (maybecaught) {
gxy (&np, fn, par, &ws, xy); /* simulate location */
xy[0] = xy[0] + animals[i];
xy[1] = xy[1] + animals[*N + i];
for (k=0; k<nk; k++) { /* each polygon */
Tski = Tsk[s * nk + k];
if (fabs(Tski) > 1e-10) {
n1 = cumk[k];
n2 = cumk[k+1]-1;
inside(xy, &n1, &n2, &sumk, traps, gotcha); /* assume closed */
if (*gotcha > 0) {
if (caught[i]==0) { /* first capture of this animal */
nc++;
caught[i] = nc;
for (t=0; t<*ss; t++)
value[*ss * (nc-1) + t] = 0;
}
nd++;
value[*ss * (caught[i]-1) + s] = k+1;
work[(nd-1)*2] = xy[0];
work[(nd-1)*2+1] = xy[1];
sortkey[nd-1] = (double) (s * *N + caught[i]);
break; /* no need to look at more poly */
}
}
}
}
}
}
/* -------------------------------------------------------------------------------- */
/* exclusive transect detectors */
else if (*detect == 4) {
ex = (double *) R_alloc(10 + 2 * maxvertices, sizeof(double));
for (i=0; i<*N; i++) { /* each animal */
animal.x = animals[i];
animal.y = animals[i + *N];
sumhaz = 0;
/* ------------------------------------ */
/* sum hazard */
for (k=0; k<nk; k++) {
Tski = Tsk[s * nk + k];
if (fabs(Tski) > 1e-10) {
getpar (i, s, k, x[i], *N, *ss, nk, *cc0, *cc1, *fn,
bswitch (*btype, *N, i, k, caughtbefore),
gsb0, gsb0val, gsb1, gsb1val, &g0, &sigma, &z);
par[0] = g0;
par[1] = sigma;
par[2] = z;
n1 = cumk[k];
n2 = cumk[k+1]-1;
H = hintegral1(*fn, par);
sumhaz += -log(1 - par[0] * integral1D (*fn, i, 0, par, 1, traps,
animals, n1, n2, sumk, *N, ex) / H);
}
}
/* ------------------------------------ */
for (k=0; k<nk; k++) { /* each transect */
Tski = Tsk[s * nk + k];
if (fabs(Tski) > 1e-10) {
getpar (i, s, k, x[i], *N, *ss, nk, *cc0, *cc1, *fn,
bswitch (*btype, *N, i, k, caughtbefore),
gsb0, gsb0val, gsb1, gsb1val, &g0, &sigma, &z);
par[0] = g0;
par[1] = sigma;
par[2] = z;
n1 = cumk[k];
n2 = cumk[k+1]-1;
H = hintegral1(*fn, par);
lambdak = par[0] * integral1D (*fn, i, 0, par, 1, traps, animals,
n1, n2, sumk, *N, ex) / H;
pks = (1 - exp(-sumhaz)) * (-log(1-lambdak)) / sumhaz;
count = Random() < pks;
maxg = 0;
if (count>0) { /* find maximum - approximate */
for (l=0; l<=100; l++) {
lx = (cumd[n2] - cumd[n1]) * l/100;
xyp = getxy (lx, cumd, line, sumk, n1);
grx = gr (fn, par, xyp, animal);
if (R_FINITE(grx))
maxg = fmax2(maxg, grx);
}
for (l=n1; l<=n2; l++) {
xyp = line[l];
grx = gr (fn, par, xyp, animal);
if (R_FINITE(grx))
maxg = fmax2(maxg, grx);
}
maxg= 1.2 * maxg; /* safety margin */
if (maxg<=0)
Rprintf("maxg error in simsecr\n"); /* not found */
*gotcha = 0;
l = 0;
while (*gotcha == 0) {
lx = Random() * (cumd[n2] - cumd[n1]); /* simulate location */
xyp = getxy (lx, cumd, line, sumk, n1);
grx = gr (fn, par, xyp, animal);
if (Random() < (grx/maxg)) /* rejection sampling */
*gotcha = 1;
l++;
if (l % 10000 == 0)
R_CheckUserInterrupt();
if (l>1e8) *gotcha = 1; /* give up and accept anything!!!! */
}
if (caught[i]==0) { /* first capture of this animal */
nc++;
caught[i] = nc;
for (t=0; t<*ss; t++)
value[*ss * (nc-1) + t] = 0;
}
nd++;
if (nd >= maxdet) {
*resultcode = 2; /* error */
return;
}
value[*ss * (caught[i]-1) + s] = k+1;
work[(nd-1)*2] = xyp.x;
work[(nd-1)*2+1] = xyp.y;
sortkey[nd-1] = (double) (s * *N + caught[i]);
}
if (count>0) break; /* no need to look further */
}
} /* end loop over transects */
} /* end loop over animals */
}
/* -------------------------------------------------------------------------------- */
/* polygon detectors */
else if (*detect == 6) {
for (i=0; i<*N; i++) {
/* this implementation assumes NO VARIATION AMONG DETECTORS */
getpar (i, s, 0, x[i], *N, *ss, nk, *cc0, *cc1, *fn,
bswitch (*btype, *N, i, 0, caughtbefore),
gsb0, gsb0val, gsb1, gsb1val, &g0, &sigma, &z);
count = rcount(*binomN, g0, Tski);
w = 10 * sigma;
par[0] = 1;
par[1] = sigma;
par[2] = z;
for (j=0; j<count; j++) {
gxy (&np, fn, par, &w, xy); /* simulate location */
xy[0] = xy[0] + animals[i];
xy[1] = xy[1] + animals[*N + i];
for (k=0; k<nk; k++) { /* each polygon */
Tski = Tsk[s * nk + k];
if (fabs(Tski) > 1e-10) {
n1 = cumk[k];
n2 = cumk[k+1]-1;
inside(xy, &n1, &n2, &sumk, traps, gotcha); /* assume closed */
if (*gotcha > 0) {
if (caught[i]==0) { /* first capture of this animal */
nc++;
caught[i] = nc;
for (t=0; t<*ss; t++)
for (l=0; l<nk; l++)
value[*ss * ((nc-1) * nk + l) + t] = 0;
}
nd++;
if (nd > maxdet) {
*resultcode = 2;
return; /* error */
}
value[*ss * ((caught[i]-1) * nk + k) + s]++;
work[(nd-1)*2] = xy[0];
work[(nd-1)*2+1] = xy[1];
sortkey[nd-1] = (double) (k * *N * *ss + s * *N + caught[i]);
}
}
}
}
}
}
/* -------------------------------------------------------------------------------- */
/* transect detectors */
else if (*detect == 7) {
ex = (double *) R_alloc(10 + 2 * maxvertices, sizeof(double));
for (i=0; i<*N; i++) { /* each animal */
animal.x = animals[i];
animal.y = animals[i + *N];
for (k=0; k<nk; k++) { /* each transect */
Tski = Tsk[s * nk + k];
if (fabs(Tski) > 1e-10) {
getpar (i, s, k, x[i], *N, *ss, nk, *cc0, *cc1, *fn,
bswitch (*btype, *N, i, k, caughtbefore),
gsb0, gsb0val, gsb1, gsb1val, &g0, &sigma, &z);
par[0] = g0;
par[1] = sigma;
par[2] = z;
n1 = cumk[k];
n2 = cumk[k+1]-1;
H = hintegral1(*fn, par);
lambdak = par[0] * integral1D (*fn, i, 0, par, 1, traps, animals,
n1, n2, sumk, *N, ex) / H;
count = rcount(*binomN, lambdak, Tski); /* numb detections on transect */
maxg = 0;
if (count>0) { /* find maximum - approximate */
for (l=0; l<=100; l++) {
lx = (cumd[n2]-cumd[n1]) * l/100;
xyp = getxy (lx, cumd, line, sumk, n1);
grx = gr (fn, par, xyp, animal);
if (R_FINITE(grx))
maxg = fmax2(maxg, grx);
}
for (l=n1; l<=n2; l++) {
xyp = line[l];
grx = gr (fn, par, xyp, animal);
if (R_FINITE(grx))
maxg = fmax2(maxg, grx);
}
maxg= 1.2 * maxg; /* safety margin */
if (maxg<=0)
Rprintf("maxg error in simsecr\n"); /* not found */
}
for (j=0; j<count; j++) {
*gotcha = 0;
l = 0;
while (*gotcha == 0) {
lx = Random() * (cumd[n2]-cumd[n1]); /* simulate location */
xyp = getxy (lx, cumd, line, sumk, n1);
grx = gr (fn, par, xyp, animal);
if (Random() < (grx/maxg)) /* rejection sampling */
*gotcha = 1;
l++;
if (l % 10000 == 0)
R_CheckUserInterrupt();
if (l>1e8) *gotcha = 1; /* give up and accept anything!!!! */
}
if (caught[i]==0) { /* first capture of this animal */
nc++;
caught[i] = nc;
for (t=0; t<*ss; t++)
for (l=0; l<nk; l++)
value[*ss * ((nc-1) * nk + l) + t] = 0;
}
nd++;
if (nd >= maxdet) {
*resultcode = 2; /* error */
return;
}
value[*ss * ((caught[i]-1) * nk + k) + s]++;
work[(nd-1)*2] = xyp.x;
work[(nd-1)*2+1] = xyp.y;
sortkey[nd-1] = (double) (k * *N * *ss + s * *N + caught[i]);
}
}
} /* end loop over transects */
} /* end loop over animals */
}
/* ------------------------ */
/* signal strength detector */
else if (*detect == 5) {
cut = miscparm[0];
if ((*fn == 12) || (*fn == 13)) {
muN = miscparm[1];
sdN = miscparm[2];
}
for (i=0; i<*N; i++) {
for (k=0; k<nk; k++) {
Tski = Tsk[s * nk + k];
if (fabs(Tski) > 1e-10) {
/* sounds not recaptured */
getpar (i, s, k, x[i], *N, *ss, nk, *cc0, *cc1, *fn,
0, gsb0, gsb0val, gsb0, gsb0val, &beta0, &beta1, &sdS);
/*
if ((*fn == 10) || (*fn == 12))
muS = mufn (i, k, beta0, beta1, animals, traps, *N, nk, 0);
else
muS = mufn (i, k, beta0, beta1, animals, traps, *N, nk, 1);
*/
if ((*fn == 10) || (*fn == 12))
muS = mufnL (k, i, beta0, beta1, dist2, nk, 0);
else
muS = mufnL (k, i, beta0, beta1, dist2, nk, 1);
signalvalue = norm_rand() * sdS + muS;
if ((*fn == 10) || (*fn == 11)) {
if (signalvalue > cut) {
if (caught[i]==0) { /* first capture of this animal */
nc++;
caught[i] = nc;
for (j=0; j<*ss; j++)
for (l=0; l<nk; l++)
value[*ss * ((nc-1) * *kk + l) + j] = 0;
}
nd++;
value[*ss * ((caught[i]-1) * *kk + k) + s] = 1;
work[nd-1] = signalvalue;
sortkey[nd-1] = (double) (k * *N * *ss + s * *N + caught[i]);
}
}
else {
noisevalue = norm_rand() * sdN + muN;
if ((signalvalue - noisevalue) > cut) {
if (caught[i]==0) { /* first capture of this animal */
nc++;
caught[i] = nc;
for (j=0; j<*ss; j++)
for (l=0; l<nk; l++)
value[*ss * ((nc-1) * *kk + l) + j] = 0;
}
nd++;
value[*ss * ((caught[i]-1) * *kk + k) + s] = 1;
work[nd-1] = signalvalue;
noise[nd-1] = noisevalue;
sortkey[nd-1] = (double) (k * *N * *ss + s * *N + caught[i]);
}
}
}
}
}
}
if ((*btype > 0) && (s < (*ss-1))) {
/* update record of 'previous-capture' status */
if (*btype == 1) {
for (i=0; i<*N; i++) {
if (*Markov)
caughtbefore[i] = 0;
for (k=0; k<nk; k++)
caughtbefore[i] = imax2 (value[i3(s, k, i, *ss, nk)], caughtbefore[i]);
}
}
else if (*btype == 2) {
for (i=0; i<*N; i++) {
for (k=0; k<nk; k++) {
ik = k * (*N-1) + i;
if (*Markov)
caughtbefore[ik] = value[i3(s, k, i, *ss, nk)];
else
caughtbefore[ik] = imax2 (value[i3(s, k, i, *ss, nk)],
caughtbefore[ik]);
}
}
}
else {
for (k=0;k<nk;k++) {
if (*Markov)
caughtbefore[k] = 0;
for (i=0; i<*N; i++)
caughtbefore[k] = imax2 (value[i3(s, k, i, *ss, nk)], caughtbefore[k]);
}
}
}
} /* loop over s */
if ((*detect==3) || (*detect==4) || (*detect==5) || (*detect==6) || (*detect==7)) {
for (i=0; i<nd; i++) sortorder[i] = i;
if (nd>0) rsort_with_index (sortkey, sortorder, nd);
if (*detect==5) {
for (i=0; i<nd; i++) signal[i] = work[sortorder[i]];
if ((*fn == 12) || (*fn == 13)) {
for (i=0; i<nd; i++) signal[i+nd] = noise[sortorder[i]];
}
}
else {
for (i=0; i<nd; i++) {
detectedXY[i] = work[sortorder[i]*2];
detectedXY[i+nd] = work[sortorder[i]*2+1];
}
}
}
*n = nc;
PutRNGstate();
*resultcode = 0;
}
double rhyper(double nn1in, double nn2in, double kkin)
{
const static double deltal = 0.0078;
const static double deltau = 0.0034;
/* extern double afc(int); */
int nn1, nn2, kk;
int i, ix;
Rboolean reject, setup1, setup2;
double e, f, g, r, t, y;
/* These should become 'thread_local globals' : */
static int ks = -1, n1s = -1, n2s = -1;
static int k, m, minjx, maxjx, n1, n2;
static double tn;
// II :
static double w;
// III:
static double a, d, s, xl, xr, kl, kr, lamdl, lamdr, p1, p2, p3;
/* check parameter validity */
if(!R_FINITE(nn1in) || !R_FINITE(nn2in) || !R_FINITE(kkin))
ML_ERR_return_NAN;
// Disabling large (nn1, nn2, kk) { =^= rhyper (m,n,k) }:
nn1 = (int) R_forceint(nn1in);
nn2 = (int) R_forceint(nn2in);
kk = (int) R_forceint(kkin);
if (nn1 < 0 || nn2 < 0 || kk < 0 || kk > nn1 + nn2)
ML_ERR_return_NAN;
/* if new parameter values, initialize */
reject = TRUE;
if (nn1 != n1s || nn2 != n2s) {
setup1 = TRUE; setup2 = TRUE;
} else if (kk != ks) {
setup1 = FALSE; setup2 = TRUE;
} else {
setup1 = FALSE; setup2 = FALSE;
}
if (setup1) {
n1s = nn1;
n2s = nn2;
tn = nn1 + nn2;
if (nn1 <= nn2) {
n1 = nn1;
n2 = nn2;
} else {
n1 = nn2;
n2 = nn1;
}
}
if (setup2) {
ks = kk;
if (kk + kk >= tn) {
k = (int)(tn - kk);
} else {
k = kk;
}
}
if (setup1 || setup2) {
m = (int) ((k + 1.0) * (n1 + 1.0) / (tn + 2.0));
minjx = imax2(0, k - n2);
maxjx = imin2(n1, k);
}
/* generate random variate --- Three basic cases */
if (minjx == maxjx) { /* I: degenerate distribution ---------------- */
ix = maxjx;
/* return ix;
No, need to unmangle <TSL>*/
/* return appropriate variate */
if (kk + kk >= tn) {
if (nn1 > nn2) {
ix = kk - nn2 + ix;
} else {
ix = nn1 - ix;
}
} else {
if (nn1 > nn2)
ix = kk - ix;
}
return ix;
} else if (m - minjx < 10) { // II: (Scaled) algorithm HIN (inverse transformation) ----
const static double scale = 1e25; // scaling factor against (early) underflow
const static double con = 57.5646273248511421;
// 25*log(10) = log(scale) { <==> exp(con) == scale }
if (setup1 || setup2) {
double lw; // log(w); w = exp(lw) * scale = exp(lw + log(scale)) = exp(lw + con)
if (k < n2) {
lw = afc(n2) + afc(n1 + n2 - k) - afc(n2 - k) - afc(n1 + n2);
} else {
lw = afc(n1) + afc( k ) - afc(k - n2) - afc(n1 + n2);
}
w = exp(lw + con);
}
double p, u;
L10:
p = w;
ix = minjx;
u = unif_rand() * scale;
while (u > p) {
u -= p;
p *= ((double) n1 - ix) * (k - ix);
ix++;
p = p / ix / (n2 - k + ix);
if (ix > maxjx)
goto L10;
}
} else { /* III : H2PE Algorithm --------------------------------------- */
double u,v;
if (setup1 || setup2) {
s = sqrt((tn - k) * k * n1 * n2 / (tn - 1) / tn / tn);
/* remark: d is defined in reference without int. */
/* the truncation centers the cell boundaries at 0.5 */
d = (int) (1.5 * s) + .5;
xl = m - d + .5;
xr = m + d + .5;
a = afc(m) + afc(n1 - m) + afc(k - m) + afc(n2 - k + m);
kl = exp(a - afc((int) (xl)) - afc((int) (n1 - xl))
- afc((int) (k - xl))
- afc((int) (n2 - k + xl)));
kr = exp(a - afc((int) (xr - 1))
- afc((int) (n1 - xr + 1))
- afc((int) (k - xr + 1))
- afc((int) (n2 - k + xr - 1)));
lamdl = -log(xl * (n2 - k + xl) / (n1 - xl + 1) / (k - xl + 1));
lamdr = -log((n1 - xr + 1) * (k - xr + 1) / xr / (n2 - k + xr));
p1 = d + d;
p2 = p1 + kl / lamdl;
p3 = p2 + kr / lamdr;
}
L30:
u = unif_rand() * p3;
v = unif_rand();
if (u < p1) { /* rectangular region */
ix = (int) (xl + u);
} else if (u <= p2) { /* left tail */
ix = (int) (xl + log(v) / lamdl);
if (ix < minjx)
goto L30;
v = v * (u - p1) * lamdl;
} else { /* right tail */
ix = (int) (xr - log(v) / lamdr);
if (ix > maxjx)
goto L30;
v = v * (u - p2) * lamdr;
}
/* acceptance/rejection test */
if (m < 100 || ix <= 50) {
/* explicit evaluation */
/* The original algorithm (and TOMS 668) have
f = f * i * (n2 - k + i) / (n1 - i) / (k - i);
in the (m > ix) case, but the definition of the
recurrence relation on p134 shows that the +1 is
needed. */
f = 1.0;
if (m < ix) {
for (i = m + 1; i <= ix; i++)
f = f * (n1 - i + 1) * (k - i + 1) / (n2 - k + i) / i;
} else if (m > ix) {
for (i = ix + 1; i <= m; i++)
f = f * i * (n2 - k + i) / (n1 - i + 1) / (k - i + 1);
}
if (v <= f) {
reject = FALSE;
}
} else {
double de, dg, dr, ds, dt, gl, gu, nk, nm, ub;
double xk, xm, xn, y1, ym, yn, yk, alv;
/* squeeze using upper and lower bounds */
y = ix;
y1 = y + 1.0;
ym = y - m;
yn = n1 - y + 1.0;
yk = k - y + 1.0;
nk = n2 - k + y1;
r = -ym / y1;
s = ym / yn;
t = ym / yk;
e = -ym / nk;
g = yn * yk / (y1 * nk) - 1.0;
dg = 1.0;
if (g < 0.0)
dg = 1.0 + g;
gu = g * (1.0 + g * (-0.5 + g / 3.0));
gl = gu - .25 * (g * g * g * g) / dg;
xm = m + 0.5;
xn = n1 - m + 0.5;
xk = k - m + 0.5;
nm = n2 - k + xm;
ub = y * gu - m * gl + deltau
+ xm * r * (1. + r * (-0.5 + r / 3.0))
+ xn * s * (1. + s * (-0.5 + s / 3.0))
+ xk * t * (1. + t * (-0.5 + t / 3.0))
+ nm * e * (1. + e * (-0.5 + e / 3.0));
/* test against upper bound */
alv = log(v);
if (alv > ub) {
reject = TRUE;
} else {
/* test against lower bound */
dr = xm * (r * r * r * r);
if (r < 0.0)
dr /= (1.0 + r);
ds = xn * (s * s * s * s);
if (s < 0.0)
ds /= (1.0 + s);
dt = xk * (t * t * t * t);
if (t < 0.0)
dt /= (1.0 + t);
de = nm * (e * e * e * e);
if (e < 0.0)
de /= (1.0 + e);
if (alv < ub - 0.25 * (dr + ds + dt + de)
+ (y + m) * (gl - gu) - deltal) {
reject = FALSE;
}
else {
/* * Stirling's formula to machine accuracy
*/
if (alv <= (a - afc(ix) - afc(n1 - ix)
- afc(k - ix) - afc(n2 - k + ix))) {
reject = FALSE;
} else {
reject = TRUE;
}
}
}
} // else
if (reject)
goto L30;
}
/* return appropriate variate */
if (kk + kk >= tn) {
if (nn1 > nn2) {
ix = kk - nn2 + ix;
} else {
ix = nn1 - ix;
}
} else {
if (nn1 > nn2)
ix = kk - ix;
}
return ix;
}
nlopt_result isres_minimize(int n, nlopt_func f, void *f_data,
int m, nlopt_constraint *fc, /* fc <= 0 */
int p, nlopt_constraint *h, /* h == 0 */
const double *lb, const double *ub, /* bounds */
double *x, /* in: initial guess, out: minimizer */
double *minf,
nlopt_stopping *stop,
int population) /* pop. size (= 0 for default) */
{
const double ALPHA = 0.2; /* smoothing factor from paper */
const double GAMMA = 0.85; /* step-reduction factor from paper */
const double PHI = 1.0; /* expected rate of convergence, from paper */
const double PF = 0.45; /* fitness probability, from paper */
const double SURVIVOR = 1.0/7.0; /* survivor fraction, from paper */
int survivors;
nlopt_result ret = NLOPT_SUCCESS;
double *sigmas = 0, *xs; /* population-by-n arrays (row-major) */
double *fval; /* population array of function vals */
double *penalty; /* population array of penalty vals */
double *x0;
int *irank = 0;
int k, i, j, c;
int mp = m + p;
double minf_penalty = HUGE_VAL, minf_gpenalty = HUGE_VAL;
double taup, tau;
double *results = 0; /* scratch space for mconstraint results */
unsigned ires;
*minf = HUGE_VAL;
if (!population) population = 20 * (n + 1);
if (population < 1) {
nlopt_stop_msg(stop, "population %d is too small", population);
return NLOPT_INVALID_ARGS;
}
survivors = (int) ceil(population * SURVIVOR);
taup = PHI / sqrt(2*n);
tau = PHI / sqrt(2*sqrt(n));
/* we don't handle unbounded search regions */
for (j = 0; j < n; ++j) if (nlopt_isinf(lb[j]) || nlopt_isinf(ub[j])) {
nlopt_stop_msg(stop, "isres requires a finite search region");
return NLOPT_INVALID_ARGS;
}
ires = imax2(nlopt_max_constraint_dim(m, fc),
nlopt_max_constraint_dim(p, h));
results = (double *) malloc(ires * sizeof(double));
if (ires > 0 && !results) return NLOPT_OUT_OF_MEMORY;
sigmas = (double*) malloc(sizeof(double) * (population*n*2
+ population
+ population
+ n));
if (!sigmas) { free(results); return NLOPT_OUT_OF_MEMORY; }
xs = sigmas + population*n;
fval = xs + population*n;
penalty = fval + population;
x0 = penalty + population;
irank = (int*) malloc(sizeof(int) * population);
if (!irank) { ret = NLOPT_OUT_OF_MEMORY; goto done; }
for (k = 0; k < population; ++k) {
for (j = 0; j < n; ++j) {
sigmas[k*n+j] = (ub[j] - lb[j]) / sqrt(n);
xs[k*n+j] = nlopt_urand(lb[j], ub[j]);
}
}
memcpy(xs, x, sizeof(double) * n); /* use input x for xs_0 */
while (1) { /* each loop body = one generation */
int all_feasible = 1;
/* evaluate f and constraint violations for whole population */
for (k = 0; k < population; ++k) {
int feasible = 1;
double gpenalty;
++ *(stop->nevals_p);
fval[k] = f(n, xs + k*n, NULL, f_data);
if (nlopt_stop_forced(stop)) {
ret = NLOPT_FORCED_STOP; goto done; }
penalty[k] = 0;
for (c = 0; c < m; ++c) { /* inequality constraints */
nlopt_eval_constraint(results, NULL,
fc + c, n, xs + k*n);
if (nlopt_stop_forced(stop)) {
ret = NLOPT_FORCED_STOP; goto done; }
for (ires = 0; ires < fc[c].m; ++ires) {
double gval = results[ires];
if (gval > fc[c].tol[ires]) feasible = 0;
if (gval < 0) gval = 0;
penalty[k] += gval*gval;
}
}
gpenalty = penalty[k];
for (c = m; c < mp; ++c) { /* equality constraints */
nlopt_eval_constraint(results, NULL,
h + (c-m), n, xs + k*n);
if (nlopt_stop_forced(stop)) {
ret = NLOPT_FORCED_STOP; goto done; }
for (ires = 0; ires < h[c-m].m; ++ires) {
double hval = results[ires];
if (fabs(hval) > h[c-m].tol[ires]) feasible = 0;
penalty[k] += hval*hval;
}
}
if (penalty[k] > 0) all_feasible = 0;
/* convergence criteria (FIXME: improve?) */
/* FIXME: with equality constraints, how do
we decide which solution is the "best" so far?
... need some total order on the solutions? */
if ((penalty[k] <= minf_penalty || feasible)
&& (fval[k] <= *minf || minf_gpenalty > 0)
&& ((feasible ? 0 : penalty[k]) != minf_penalty
|| fval[k] != *minf)) {
if (fval[k] < stop->minf_max && feasible)
ret = NLOPT_MINF_MAX_REACHED;
else if (!nlopt_isinf(*minf)) {
if (nlopt_stop_f(stop, fval[k], *minf)
&& nlopt_stop_f(stop, feasible ? 0 : penalty[k],
minf_penalty))
ret = NLOPT_FTOL_REACHED;
else if (nlopt_stop_x(stop, xs+k*n, x))
ret = NLOPT_XTOL_REACHED;
}
memcpy(x, xs+k*n, sizeof(double)*n);
*minf = fval[k];
minf_penalty = feasible ? 0 : penalty[k];
minf_gpenalty = feasible ? 0 : gpenalty;
if (ret != NLOPT_SUCCESS) goto done;
}
if (nlopt_stop_forced(stop)) ret = NLOPT_FORCED_STOP;
else if (nlopt_stop_evals(stop)) ret = NLOPT_MAXEVAL_REACHED;
else if (nlopt_stop_time(stop)) ret = NLOPT_MAXTIME_REACHED;
if (ret != NLOPT_SUCCESS) goto done;
}
/* "selection" step: rank the population */
for (k = 0; k < population; ++k) irank[k] = k;
if (all_feasible) /* special case: rank by objective function */
nlopt_qsort_r(irank, population, sizeof(int), fval,key_compare);
else {
/* Runarsson & Yao's stochastic ranking of the population */
for (i = 0; i < population; ++i) {
int swapped = 0;
for (j = 0; j < population-1; ++j) {
double u = nlopt_urand(0,1);
if (u < PF || (penalty[irank[j]] == 0
&& penalty[irank[j+1]] == 0)) {
if (fval[irank[j]] > fval[irank[j+1]]) {
int irankj = irank[j];
irank[j] = irank[j+1];
irank[j+1] = irankj;
swapped = 1;
}
}
else if (penalty[irank[j]] > penalty[irank[j+1]]) {
int irankj = irank[j];
irank[j] = irank[j+1];
irank[j+1] = irankj;
swapped = 1;
}
}
if (!swapped) break;
}
}
/* evolve the population:
differential evolution for the best survivors,
and standard mutation of the best survivors for the rest: */
for (k = survivors; k < population; ++k) { /* standard mutation */
double taup_rand = taup * nlopt_nrand(0,1);
int rk = irank[k], ri;
i = k % survivors;
ri = irank[i];
for (j = 0; j < n; ++j) {
double sigmamax = (ub[j] - lb[j]) / sqrt(n);
sigmas[rk*n+j] = sigmas[ri*n+j]
* exp(taup_rand + tau*nlopt_nrand(0,1));
if (sigmas[rk*n+j] > sigmamax)
sigmas[rk*n+j] = sigmamax;
do {
xs[rk*n+j] = xs[ri*n+j]
+ sigmas[rk*n+j] * nlopt_nrand(0,1);
} while (xs[rk*n+j] < lb[j] || xs[rk*n+j] > ub[j]);
sigmas[rk*n+j] = sigmas[ri*n+j] + ALPHA*(sigmas[rk*n+j]
- sigmas[ri*n+j]);
}
}
memcpy(x0, xs, n * sizeof(double));
for (k = 0; k < survivors; ++k) { /* differential variation */
double taup_rand = taup * nlopt_nrand(0,1);
int rk = irank[k];
for (j = 0; j < n; ++j) {
double xi = xs[rk*n+j];
if (k+1 < survivors)
xs[rk*n+j] += GAMMA * (x0[j] - xs[(k+1)*n+j]);
if (k+1 == survivors
|| xs[rk*n+j] < lb[j] || xs[rk*n+j] > ub[j]) {
/* standard mutation for last survivor and
for any survivor components that are now
outside the bounds */
double sigmamax = (ub[j] - lb[j]) / sqrt(n);
double sigi = sigmas[rk*n+j];
sigmas[rk*n+j] *= exp(taup_rand
+ tau*nlopt_nrand(0,1));
if (sigmas[rk*n+j] > sigmamax)
sigmas[rk*n+j] = sigmamax;
do {
xs[rk*n+j] = xi
+ sigmas[rk*n+j] * nlopt_nrand(0,1);
} while (xs[rk*n+j] < lb[j] || xs[rk*n+j] > ub[j]);
sigmas[rk*n+j] = sigi
+ ALPHA * (sigmas[rk*n+j] - sigi);
}
}
}
}
done:
if (irank) free(irank);
if (sigmas) free(sigmas);
if (results) free(results);
return ret;
}
extern "C" SEXP covOPW(SEXP SX, SEXP Siter, SEXP SscaleFun, SEXP SrcovFun)
{
std::cout << "calling covOPW" << std::endl;
char CHARA = 'A', CHARL = 'L', CHARN = 'N', CHART = 'T', CHARV = 'V';
double *X = NULL, *Z = NULL, *ZCOPY = NULL, *U = NULL, **A = NULL, *d = NULL;
double *dwork2 = NULL, *dwork3 = NULL, *diagT = NULL, *offdiagT = NULL;
double *tau = NULL, *gamma = NULL, *cov = NULL, *covcopy = NULL, *center = NULL, *dist = NULL;
double mu = 0.0, alpha = 0.0, DZERO = 0.0, DONE = 1.0;
int n = 0, p = 0, np = 0, pp = 0, iter = -1, i = 0, j = 0, info = 0, lwork = 0;
int liwork = 0, IONE = 1;
int *isuppz = NULL, *iwork = NULL;
SEXP Sans = R_NilValue, Scov = R_NilValue, Scenter = R_NilValue;
SEXP Sdist = R_NilValue, Sdim = R_NilValue, Snames = R_NilValue;
scaleFnPtr *scalefn = NULL;
rcovFnPtr *rcovfn = NULL;
if(strncmp(CHAR(asChar(SscaleFun)), "s_mad", 5) == 0)
scalefn = &my_mad;
else if(strncmp(CHAR(asChar(SscaleFun)), "scaleTau2", 9) == 0)
scalefn = &scaleTau2;
else
error("unable to set scale function pointer in C function covOPW");
if(strncmp(CHAR(asChar(SrcovFun)), "gk", 2) == 0)
rcovfn = &gk;
else if(strncmp(CHAR(asChar(SrcovFun)), "qc", 2) == 0)
rcovfn = &qc;
else
error("unable to set rcov function pointer in C function covOPW");
if(!isMatrix(SX))
error("first argument to C function covOPW is not a matrix");
PROTECT(Sdim = getAttrib(SX, R_DimSymbol));
n = INTEGER(Sdim)[0];
p = INTEGER(Sdim)[1];
Sdim = R_NilValue;
UNPROTECT(1);
np = n*p;
pp = p*p;
lwork = 18*p;
liwork = 10*p;
iter = INTEGER(Siter)[0];
X = REAL(SX);
Z = (double*) R_alloc((size_t) np, sizeof(double));
arma::mat ZZ(X,n,p,false,true);
F77_CALL(dcopy)(&np, X, &IONE, Z, &IONE);
ZCOPY = (double*) R_alloc((size_t) np, sizeof(double));
U = (double*) R_alloc((size_t) (p*(p+1))/2, sizeof(double));
covcopy = (double*) R_alloc((size_t) pp, sizeof(double));
A = (double**) R_alloc((size_t) iter, sizeof(double*));
for(int k = 0; k < iter; k++)
A[k] = (double*) R_alloc((size_t) pp, sizeof(double));
d = (double*) R_alloc((size_t) p, sizeof(double));
dwork2 = (double*) R_alloc((size_t) n, sizeof(double));
dwork3 = (double*) R_alloc((size_t) imax2(n, lwork), sizeof(double));
diagT = (double*) R_alloc((size_t) p, sizeof(double));
offdiagT = (double*) R_alloc((size_t) (p-1), sizeof(double));
tau = (double*) R_alloc((size_t) (p-1), sizeof(double));
gamma = (double*) R_alloc((size_t) p, sizeof(double));
isuppz = (int*) R_alloc((size_t) (2*p), sizeof(int));
iwork = (int*) R_alloc((size_t) liwork, sizeof(int));
for(int k = 0; k < iter; k++) {
for(j = 0; j < p; j++) {
d[j] = scalefn(n, ZZ.colptr(j), &mu);
//this can be handled better
if(fabs(d[j]) < 1e-12) error("column with zero scale encountered in C function covOPW");
alpha = 1.0 / d[j];
ZZ.col(j) *= alpha;
}
for(i = 0; i < p; i++) U[i+((2*p-i-1)*i)/2] = 1.0;
calcCovs(U, ZZ, rcovfn, scalefn);
F77_CALL(dsptrd)(&CHARL, &p, U, diagT, offdiagT, tau, &info);
F77_CALL(dstegr)(&CHARV, &CHARA, &p, diagT, offdiagT, &mu, &mu, &i,
&i, &DZERO, &j, gamma, A[k], &p, isuppz, dwork3,
&lwork, iwork, &liwork, &info);
F77_CALL(dopmtr)(&CHARL, &CHARL, &CHARN, &p, &p, U, tau, A[k], &p,
dwork2, &info);
for(j = 0; j < p/2; j++) {
F77_CALL(dswap)(&p, A[k]+j*p, &IONE, A[k]+p*(p-j-1), &IONE);
}
F77_CALL(dcopy)(&np, Z, &IONE, ZCOPY, &IONE);
F77_CALL(dgemm)(&CHARN, &CHARN, &n, &p, &p, &DONE, ZCOPY, &n, A[k],
&p, &DZERO, Z, &n);
for(i = 0; i < p; i++)
for(j = 0; j < p; j++)
A[k][i+j*p] = d[i] * A[k][i+j*p];
}
PROTECT(Scov = allocMatrix(REALSXP, p, p));
PROTECT(Scenter = allocVector(REALSXP, p));
PROTECT(Sdist = allocVector(REALSXP, n));
cov = REAL(Scov);
center = REAL(Scenter);
dist = REAL(Sdist);
for(j = 0; j < p; j++) {
gamma[j] = scalefn(n, Z+j*n, &mu);
for(i = 0; i < p; i++)
cov[i+j*p] = i == j ? gamma[j] * gamma[j] : 0.0;
center[j] = mu;
}
for(i = 0; i < n; i++) {
for(j = 0; j < p; j++)
Z[i+j*n] = R_pow_di(((Z[i+j*n] - center[j]) / gamma[j]), 2);
dist[i] = F77_CALL(dasum)(&p, Z+i, &n);
}
for(int k = iter-1; k >= 0; k--) {
F77_CALL(dcopy)(&pp, cov, &IONE, covcopy, &IONE);
F77_CALL(dgemm)(&CHARN, &CHARN, &p, &p, &p, &DONE, A[k], &p, covcopy,
&p, &DZERO, cov, &p);
F77_CALL(dcopy)(&pp, cov, &IONE, covcopy, &IONE);
F77_CALL(dgemm)(&CHARN, &CHART, &p, &p, &p, &DONE, covcopy, &p, A[k],
&p, &DZERO, cov, &p);
F77_CALL(dcopy)(&p, center, &IONE, gamma, &IONE);
F77_CALL(dgemv)(&CHARN, &p, &p, &DONE, A[k], &p, gamma, &IONE,
&DZERO, center, &IONE);
}
PROTECT(Sans = allocVector(VECSXP, 3));
SET_VECTOR_ELT(Sans, 0, Scenter);
SET_VECTOR_ELT(Sans, 1, Scov);
SET_VECTOR_ELT(Sans, 2, Sdist);
PROTECT(Snames = allocVector(STRSXP, 3));
SET_STRING_ELT(Snames, 0, mkChar("center"));
SET_STRING_ELT(Snames, 1, mkChar("cov"));
SET_STRING_ELT(Snames, 2, mkChar("distances"));
setAttrib(Sans, R_NamesSymbol, Snames);
UNPROTECT(5);
return Sans;
}
/* used in graphics and grid */
SEXP CreateAtVector(double *axp, double *usr, int nint, Rboolean logflag)
{
/* Create an 'at = ...' vector for axis(.)
* i.e., the vector of tick mark locations,
* when none has been specified (= default).
*
* axp[0:2] = (x1, x2, nInt), where x1..x2 are the extreme tick marks
* {unless in log case, where nInt \in {1,2,3 ; -1,-2,....}
* and the `nint' argument is used *instead*.}
* The resulting REAL vector must have length >= 1, ideally >= 2
*/
SEXP at = R_NilValue;/* -Wall*/
double umin, umax, dn, rng, small;
int i, n, ne;
if (!logflag || axp[2] < 0) { /* --- linear axis --- Only use axp[] arg. */
n = (int)(fabs(axp[2]) + 0.25);/* >= 0 */
dn = imax2(1, n);
rng = axp[1] - axp[0];
small = fabs(rng)/(100.*dn);
at = allocVector(REALSXP, n + 1);
for (i = 0; i <= n; i++) {
REAL(at)[i] = axp[0] + (i / dn) * rng;
if (fabs(REAL(at)[i]) < small)
REAL(at)[i] = 0;
}
}
else { /* ------ log axis ----- */
Rboolean reversed = FALSE;
n = (int)(axp[2] + 0.5);
/* {xy}axp[2] for 'log': GLpretty() [./graphics.c] sets
n < 0: very small scale ==> linear axis, above, or
n = 1,2,3. see switch() below */
umin = usr[0];
umax = usr[1];
if (umin > umax) {
reversed = (axp[0] > axp[1]);
if (reversed) {
/* have *reversed* log axis -- whereas
* the switch(n) { .. } below assumes *increasing* values
* --> reverse axis direction here, and reverse back at end */
umin = usr[1];
umax = usr[0];
dn = axp[0]; axp[0] = axp[1]; axp[1] = dn;
}
else {
/* can the following still happen... ? */
warning("CreateAtVector \"log\"(from axis()): "
"usr[0] = %g > %g = usr[1] !", umin, umax);
}
}
/* allow a fuzz since we will do things like 0.2*dn >= umin */
umin *= 1 - 1e-12;
umax *= 1 + 1e-12;
dn = axp[0];
if (dn < DBL_MIN) {/* was 1e-300; now seems too cautious */
warning("CreateAtVector \"log\"(from axis()): axp[0] = %g !", dn);
if (dn <= 0) /* real trouble (once for Solaris) later on */
error("CreateAtVector [log-axis()]: axp[0] = %g < 0!", dn);
}
/* You get the 3 cases below by
* for (y in 1e-5*c(1,2,8)) plot(y, log = "y")
*/
switch(n) {
case 1: /* large range: 1 * 10^k */
i = (int)(floor(log10(axp[1])) - ceil(log10(axp[0])) + 0.25);
ne = i / nint + 1;
#ifdef DEBUG_axis
REprintf("CreateAtVector [log-axis(), case 1]: (nint, ne) = (%d,%d)\n",
nint, ne);
#endif
if (ne < 1)
error("log - axis(), 'at' creation, _LARGE_ range: "
"ne = %d <= 0 !!\n"
"\t axp[0:1]=(%g,%g) ==> i = %d; nint = %d",
ne, axp[0],axp[1], i, nint);
rng = Rexp10((double)ne); /* >= 10 */
n = 0;
while (dn < umax) {
n++;
dn *= rng;
}
if (!n)
error("log - axis(), 'at' creation, _LARGE_ range: "
"invalid {xy}axp or par; nint=%d\n"
" axp[0:1]=(%g,%g), usr[0:1]=(%g,%g); i=%d, ni=%d",
nint, axp[0],axp[1], umin,umax, i,ne);
at = allocVector(REALSXP, n);
dn = axp[0];
n = 0;
while (dn < umax) {
REAL(at)[n++] = dn;
dn *= rng;
}
break;
case 2: /* medium range: 1, 5 * 10^k */
n = 0;
if (0.5 * dn >= umin) n++;
for (;;) {
if (dn > umax) break; n++;
if (5 * dn > umax) break; n++;
dn *= 10;
}
if (!n)
error("log - axis(), 'at' creation, _MEDIUM_ range: "
"invalid {xy}axp or par;\n"
" axp[0]= %g, usr[0:1]=(%g,%g)",
axp[0], umin,umax);
at = allocVector(REALSXP, n);
dn = axp[0];
n = 0;
if (0.5 * dn >= umin) REAL(at)[n++] = 0.5 * dn;
for (;;) {
if (dn > umax) break; REAL(at)[n++] = dn;
if (5 * dn > umax) break; REAL(at)[n++] = 5 * dn;
dn *= 10;
}
break;
case 3: /* small range: 1,2,5,10 * 10^k */
n = 0;
if (0.2 * dn >= umin) n++;
if (0.5 * dn >= umin) n++;
for (;;) {
if (dn > umax) break; n++;
if (2 * dn > umax) break; n++;
if (5 * dn > umax) break; n++;
dn *= 10;
}
if (!n)
error("log - axis(), 'at' creation, _SMALL_ range: "
"invalid {xy}axp or par;\n"
" axp[0]= %g, usr[0:1]=(%g,%g)",
axp[0], umin,umax);
at = allocVector(REALSXP, n);
dn = axp[0];
n = 0;
if (0.2 * dn >= umin) REAL(at)[n++] = 0.2 * dn;
if (0.5 * dn >= umin) REAL(at)[n++] = 0.5 * dn;
for (;;) {
if (dn > umax) break; REAL(at)[n++] = dn;
if (2 * dn > umax) break; REAL(at)[n++] = 2 * dn;
if (5 * dn > umax) break; REAL(at)[n++] = 5 * dn;
dn *= 10;
}
break;
default:
error("log - axis(), 'at' creation: INVALID {xy}axp[3] = %g",
axp[2]);
}
if (reversed) {/* reverse back again - last assignment was at[n++]= . */
for (i = 0; i < n/2; i++) { /* swap( at[i], at[n-i-1] ) : */
dn = REAL(at)[i];
REAL(at)[i] = REAL(at)[n-i-1];
REAL(at)[n-i-1] = dn;
}
}
} /* linear / log */
return at;
}
/* format.default(x, trim, digits, nsmall, width, justify, na.encode,
scientific) */
SEXP attribute_hidden do_format(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP l, x, y, swd;
int il, digits, trim = 0, nsmall = 0, wd = 0, adj = -1, na, sci = 0;
int w, d, e;
int wi, di, ei, scikeep;
const char *strp;
R_xlen_t i, n;
checkArity(op, args);
PrintDefaults();
scikeep = R_print.scipen;
if (isEnvironment(x = CAR(args))) {
return mkString(EncodeEnvironment(x));
}
else if (!isVector(x))
error(_("first argument must be atomic"));
args = CDR(args);
trim = asLogical(CAR(args));
if (trim == NA_INTEGER)
error(_("invalid '%s' argument"), "trim");
args = CDR(args);
if (!isNull(CAR(args))) {
digits = asInteger(CAR(args));
if (digits == NA_INTEGER || digits < R_MIN_DIGITS_OPT
|| digits > R_MAX_DIGITS_OPT)
error(_("invalid '%s' argument"), "digits");
R_print.digits = digits;
}
args = CDR(args);
nsmall = asInteger(CAR(args));
if (nsmall == NA_INTEGER || nsmall < 0 || nsmall > 20)
error(_("invalid '%s' argument"), "nsmall");
args = CDR(args);
if (isNull(swd = CAR(args))) wd = 0; else wd = asInteger(swd);
if(wd == NA_INTEGER)
error(_("invalid '%s' argument"), "width");
args = CDR(args);
adj = asInteger(CAR(args));
if(adj == NA_INTEGER || adj < 0 || adj > 3)
error(_("invalid '%s' argument"), "justify");
args = CDR(args);
na = asLogical(CAR(args));
if(na == NA_LOGICAL)
error(_("invalid '%s' argument"), "na.encode");
args = CDR(args);
if(LENGTH(CAR(args)) != 1)
error(_("invalid '%s' argument"), "scientific");
if(isLogical(CAR(args))) {
int tmp = LOGICAL(CAR(args))[0];
if(tmp == NA_LOGICAL) sci = NA_INTEGER;
else sci = tmp > 0 ?-100 : 100;
} else if (isNumeric(CAR(args))) {
sci = asInteger(CAR(args));
} else
error(_("invalid '%s' argument"), "scientific");
if(sci != NA_INTEGER) R_print.scipen = sci;
if ((n = XLENGTH(x)) <= 0) {
PROTECT(y = allocVector(STRSXP, 0));
} else {
switch (TYPEOF(x)) {
case LGLSXP:
PROTECT(y = allocVector(STRSXP, n));
if (trim) w = 0; else formatLogical(LOGICAL(x), n, &w);
w = imax2(w, wd);
for (i = 0; i < n; i++) {
strp = EncodeLogical(LOGICAL(x)[i], w);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case INTSXP:
PROTECT(y = allocVector(STRSXP, n));
if (trim) w = 0;
else formatInteger(INTEGER(x), n, &w);
w = imax2(w, wd);
for (i = 0; i < n; i++) {
strp = EncodeInteger(INTEGER(x)[i], w);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case REALSXP:
formatReal(REAL(x), n, &w, &d, &e, nsmall);
if (trim) w = 0;
w = imax2(w, wd);
PROTECT(y = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
strp = EncodeReal0(REAL(x)[i], w, d, e, OutDec);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case CPLXSXP:
formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei, nsmall);
if (trim) wi = w = 0;
w = imax2(w, wd); wi = imax2(wi, wd);
PROTECT(y = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
strp = EncodeComplex(COMPLEX(x)[i], w, d, e, wi, di, ei, OutDec);
SET_STRING_ELT(y, i, mkChar(strp));
}
break;
case STRSXP:
{
/* this has to be different from formatString/EncodeString as
we don't actually want to encode here */
const char *s;
char *q;
int b, b0, cnt = 0, j;
SEXP s0, xx;
/* This is clumsy, but it saves rewriting and re-testing
this complex code */
PROTECT(xx = duplicate(x));
for (i = 0; i < n; i++) {
SEXP tmp = STRING_ELT(xx, i);
if(IS_BYTES(tmp)) {
const char *p = CHAR(tmp), *q;
char *pp = R_alloc(4*strlen(p)+1, 1), *qq = pp, buf[5];
for (q = p; *q; q++) {
unsigned char k = (unsigned char) *q;
if (k >= 0x20 && k < 0x80) {
*qq++ = *q;
} else {
snprintf(buf, 5, "\\x%02x", k);
for(int j = 0; j < 4; j++) *qq++ = buf[j];
}
}
*qq = '\0';
s = pp;
} else s = translateChar(tmp);
if(s != CHAR(tmp)) SET_STRING_ELT(xx, i, mkChar(s));
}
w = wd;
if (adj != Rprt_adj_none) {
for (i = 0; i < n; i++)
if (STRING_ELT(xx, i) != NA_STRING)
w = imax2(w, Rstrlen(STRING_ELT(xx, i), 0));
else if (na) w = imax2(w, R_print.na_width);
} else w = 0;
/* now calculate the buffer size needed, in bytes */
for (i = 0; i < n; i++)
if (STRING_ELT(xx, i) != NA_STRING) {
il = Rstrlen(STRING_ELT(xx, i), 0);
cnt = imax2(cnt, LENGTH(STRING_ELT(xx, i)) + imax2(0, w-il));
} else if (na) cnt = imax2(cnt, R_print.na_width + imax2(0, w-R_print.na_width));
R_CheckStack2(cnt+1);
char buff[cnt+1];
PROTECT(y = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
if(!na && STRING_ELT(xx, i) == NA_STRING) {
SET_STRING_ELT(y, i, NA_STRING);
} else {
q = buff;
if(STRING_ELT(xx, i) == NA_STRING) s0 = R_print.na_string;
else s0 = STRING_ELT(xx, i) ;
s = CHAR(s0);
il = Rstrlen(s0, 0);
b = w - il;
if(b > 0 && adj != Rprt_adj_left) {
b0 = (adj == Rprt_adj_centre) ? b/2 : b;
for(j = 0 ; j < b0 ; j++) *q++ = ' ';
b -= b0;
}
for(j = 0; j < LENGTH(s0); j++) *q++ = *s++;
if(b > 0 && adj != Rprt_adj_right)
for(j = 0 ; j < b ; j++) *q++ = ' ';
*q = '\0';
SET_STRING_ELT(y, i, mkChar(buff));
}
}
}
UNPROTECT(2); /* xx , y */
PROTECT(y);
break;
default:
error(_("Impossible mode ( x )")); y = R_NilValue;/* -Wall */
}
}
if((l = getAttrib(x, R_DimSymbol)) != R_NilValue) {
setAttrib(y, R_DimSymbol, l);
if((l = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
setAttrib(y, R_DimNamesSymbol, l);
} else if((l = getAttrib(x, R_NamesSymbol)) != R_NilValue)
setAttrib(y, R_NamesSymbol, l);
/* In case something else forgets to set PrintDefaults(), PR#14477 */
R_print.scipen = scikeep;
UNPROTECT(1); /* y */
return y;
}
static void measurement_loop(struct term *t)
{
struct variable spent_time;
int i, p;
int result_index, start_not_yet_gathered_results;
int source, dest;
double *local_results; /* local_results[max_rep_hard_limit] */
double previous_interval;
int previous_max_counter;
bool stop;
double *quantiles;
int *recv_counts = NULL;
int *recv_displs = NULL;
logging(DBG_MEAS, "starting measurement with min_repetitions = %d\n",
min_repetitions);
logging(DBG_MEAS, " max_repetitions = %d\n",
max_repetitions);
logging(DBG_MEAS, " max_relative_standard_error = %f\n",
max_relative_standard_error);
assert( min_repetitions <= max_repetitions );
max_rep_hard_limit = imax2(First_max_counter,
max_repetitions*1.5+0.5); /* @@ pretty arbitrary */
local_results = skampi_malloc_doubles(max_rep_hard_limit);
invalid = skampi_malloc_ints(max_rep_hard_limit);
if( lrootproc() ) {
all_results = skampi_malloc_doubles(get_measurement_size()*max_rep_hard_limit);
global_invalid = skampi_malloc_ints(get_measurement_size()*max_rep_hard_limit);
recv_counts = skampi_malloc_ints(get_measurement_size());
recv_displs = skampi_malloc_ints(get_measurement_size());
max_results = skampi_malloc_doubles(max_rep_hard_limit); /* @@ max_repetitions? */
final_results = skampi_malloc_doubles(get_measurement_size());
}
sum_of_results = 0.0;
sum_of_squares = 0.0;
result_index = 0;
start_not_yet_gathered_results = 0;
init_buffer();
init_struct_variable(&spent_time, TYPE_VOID, NULL, NULL);
stop = False;
do { /* measurement loop */
logging(DBG_MEAS, "max_counter = %d\n", max_counter);
/* assert( result_index + max_counter <= max_rep_hard_limit); */
max_counter = imin2(max_rep_hard_limit - result_index, max_counter);
for( counter = 0; counter < max_counter; counter++ ) { /* doing the actual measurements */
check_buffer();
t->call_fp(&spent_time, meas_params);
assert( spent_time.type == TYPE_DOUBLE );
logging(DBG_MEAS, "spent_time = %9.1f\n", spent_time.u.doublev*1.0e6);
local_results[result_index] = spent_time.u.doublev;
result_index++;
}
logging(DBG_MEAS, "result_index = %d\n", result_index);
DEBUG(DBG_MEAS,
{
for( i = start_not_yet_gathered_results; i < result_index; i++)
logging(DBG_MEAS, "local_results[%d] = %9.1f\n", i, local_results[i]*1.0e6);
});
if( lrootproc() ) {
for( p = 0; p < get_measurement_size(); p++) {
recv_counts[p] = result_index - start_not_yet_gathered_results;
recv_displs[p] = p*max_rep_hard_limit + start_not_yet_gathered_results;
}
}
MPI_Gatherv(&(local_results[start_not_yet_gathered_results]),
result_index - start_not_yet_gathered_results, MPI_DOUBLE,
all_results, recv_counts, recv_displs, MPI_DOUBLE, 0, get_measurement_comm());
if( current_synchronization == SYNC_REAL ) {
MPI_Gather(invalid, max_counter, MPI_INT,
global_invalid, max_counter, MPI_INT, 0, get_measurement_comm());
stop_batch += tds[get_global_rank(0)];
MPI_Reduce(&stop_batch, &global_stop_batch, 1, MPI_DOUBLE, MPI_MAX, 0, get_measurement_comm());
}
if( lrootproc() ) { /* overwrite invalid results */
for( i = start_not_yet_gathered_results; i < result_index; i++ ) {
logging(DBG_MEAS, "all_results[%d] = [%9.1f", i, all_results[0*max_rep_hard_limit + i]*1.0e6);
for( p = 1; p < get_measurement_size(); p++)
logging(DBG_MEAS, " %9.1f", all_results[p*max_rep_hard_limit + i]*1.0e6);
logging(DBG_MEAS, "]\n");
}
previous_interval = interval;
previous_max_counter = max_counter;
update_batch_params(); /* adapt max_counter for next batch of measurements */
logging(DBG_MEAS, "start overwrite invalid results\n");
logging(DBG_MEAS, "start_not_yet_gathered_results = %d result_index = %d\n",
start_not_yet_gathered_results, result_index);
/* move up valid results in all_results[] and global_invalid[], overwriting invalid ones */
if( current_synchronization == SYNC_REAL ) {
source = start_not_yet_gathered_results;
dest = start_not_yet_gathered_results;
while( source < result_index ) {
while( source < result_index &&
global_invalid[source-start_not_yet_gathered_results] ) {
if( global_invalid[source-start_not_yet_gathered_results] == INVALID_TOOK_TOO_LONG ) {
/* double m = 0.0; */
/* for(p = 0; p < get_measurement_size(); p++ ) */
/* m = fmax2(m, all_results[p * max_rep_hard_limit + source]); */
/* add_to_over_time(m); */
add_to_over_time(previous_interval);
}
source++;
}
if( source >= result_index ) break;
{
double m = 0.0;
for(p = 0; p < get_measurement_size(); p++ )
m = fmax2(m, all_results[p * max_rep_hard_limit + source]);
add_to_comm_time(m); /* @@ actually that's wrong, we should add stop_sync - start_sync */
add_to_wait_time(previous_interval - m);
}
if( source != dest ) {
for( p = 0; p < get_measurement_size(); p++ )
all_results[p*max_rep_hard_limit + dest] =
all_results[p*max_rep_hard_limit + source];
}
source++;
dest++;
}
logging(DBG_MEAS, "%d results thrown away\n", source - dest);
result_index = dest;
logging(DBG_MEAS, "result_index = %d start_not_yet_gathered_results = %d\n",
result_index, start_not_yet_gathered_results);
add_to_over_time(global_stop_batch - start_batch - previous_max_counter*previous_interval);
}
DEBUG(DBG_MEAS,
{
for( i = start_not_yet_gathered_results; i < result_index; i++ ) {
logging(DBG_MEAS, "all_results[%d] = [%9.1f", i, all_results[0*max_rep_hard_limit +i]*1.0e6);
for( p = 1; p < get_measurement_size(); p++)
logging(DBG_MEAS, " %9.1f", all_results[p*max_rep_hard_limit + i]*1.0e6);
logging(DBG_MEAS, "]\n");
}
});
update_std_error(start_not_yet_gathered_results, result_index);
/* eigentlich update_std_error(start_not_yet_gathered_results,
min(result_index, max_results)); ???!!! @@@@ */
stop = result_index >= max_repetitions ||
(result_index >= min_repetitions &&
std_error <= max_relative_standard_error*mean_value);
}
// rhyper(NR, NB, n) -- NR 'red', NB 'blue', n drawn, how many are 'red'
double rhyper(rng_t unif_rand, double nn1in, double nn2in, double kkin)
{
/* extern double afc(int); */
int nn1, nn2, kk;
int ix; // return value (coerced to double at the very end)
Rboolean setup1, setup2;
/* These should become 'thread_local globals' : */
static int ks = -1, n1s = -1, n2s = -1;
static int m, minjx, maxjx;
static int k, n1, n2; // <- not allowing larger integer par
static double tn;
// II :
static double w;
// III:
static double a, d, s, xl, xr, kl, kr, lamdl, lamdr, p1, p2, p3;
/* check parameter validity */
if(!R_FINITE(nn1in) || !R_FINITE(nn2in) || !R_FINITE(kkin))
ML_ERR_return_NAN;
nn1in = R_forceint(nn1in);
nn2in = R_forceint(nn2in);
kkin = R_forceint(kkin);
if (nn1in < 0 || nn2in < 0 || kkin < 0 || kkin > nn1in + nn2in)
ML_ERR_return_NAN;
if (nn1in >= INT_MAX || nn2in >= INT_MAX || kkin >= INT_MAX) {
/* large n -- evade integer overflow (and inappropriate algorithms)
-------- */
// FIXME: Much faster to give rbinom() approx when appropriate; -> see Kuensch(1989)
// Johnson, Kotz,.. p.258 (top) mention the *four* different binomial approximations
if(kkin == 1.) { // Bernoulli
return rbinom(unif_rand, kkin, nn1in / (nn1in + nn2in));
}
// Slow, but safe: return F^{-1}(U) where F(.) = phyper(.) and U ~ U[0,1]
return qhyper(unif_rand(), nn1in, nn2in, kkin, FALSE, FALSE);
}
nn1 = (int)nn1in;
nn2 = (int)nn2in;
kk = (int)kkin;
/* if new parameter values, initialize */
if (nn1 != n1s || nn2 != n2s) {
setup1 = TRUE; setup2 = TRUE;
} else if (kk != ks) {
setup1 = FALSE; setup2 = TRUE;
} else {
setup1 = FALSE; setup2 = FALSE;
}
if (setup1) {
n1s = nn1;
n2s = nn2;
tn = nn1 + nn2;
if (nn1 <= nn2) {
n1 = nn1;
n2 = nn2;
} else {
n1 = nn2;
n2 = nn1;
}
}
if (setup2) {
ks = kk;
if (kk + kk >= tn) {
k = (int)(tn - kk);
} else {
k = kk;
}
}
if (setup1 || setup2) {
m = (int) ((k + 1.) * (n1 + 1.) / (tn + 2.));
minjx = imax2(0, k - n2);
maxjx = imin2(n1, k);
#ifdef DEBUG_rhyper
REprintf("rhyper(nn1=%d, nn2=%d, kk=%d), setup: floor(mean)= m=%d, jx in (%d..%d)\n",
nn1, nn2, kk, m, minjx, maxjx);
#endif
}
/* generate random variate --- Three basic cases */
if (minjx == maxjx) { /* I: degenerate distribution ---------------- */
#ifdef DEBUG_rhyper
REprintf("rhyper(), branch I (degenerate)\n");
#endif
ix = maxjx;
goto L_finis; // return appropriate variate
} else if (m - minjx < 10) { // II: (Scaled) algorithm HIN (inverse transformation) ----
const static double scale = 1e25; // scaling factor against (early) underflow
const static double con = 57.5646273248511421;
// 25*log(10) = log(scale) { <==> exp(con) == scale }
if (setup1 || setup2) {
double lw; // log(w); w = exp(lw) * scale = exp(lw + log(scale)) = exp(lw + con)
if (k < n2) {
lw = afc(n2) + afc(n1 + n2 - k) - afc(n2 - k) - afc(n1 + n2);
} else {
lw = afc(n1) + afc( k ) - afc(k - n2) - afc(n1 + n2);
}
w = exp(lw + con);
}
double p, u;
#ifdef DEBUG_rhyper
REprintf("rhyper(), branch II; w = %g > 0\n", w);
#endif
L10:
p = w;
ix = minjx;
u = unif_rand() * scale;
#ifdef DEBUG_rhyper
REprintf(" _new_ u = %g\n", u);
#endif
while (u > p) {
u -= p;
p *= ((double) n1 - ix) * (k - ix);
ix++;
p = p / ix / (n2 - k + ix);
#ifdef DEBUG_rhyper
REprintf(" ix=%3d, u=%11g, p=%20.14g (u-p=%g)\n", ix, u, p, u-p);
#endif
if (ix > maxjx)
goto L10;
// FIXME if(p == 0.) we also "have lost" => goto L10
}
} else { /* III : H2PE Algorithm --------------------------------------- */
double u,v;
if (setup1 || setup2) {
s = sqrt((tn - k) * k * n1 * n2 / (tn - 1) / tn / tn);
/* remark: d is defined in reference without int. */
/* the truncation centers the cell boundaries at 0.5 */
d = (int) (1.5 * s) + .5;
xl = m - d + .5;
xr = m + d + .5;
a = afc(m) + afc(n1 - m) + afc(k - m) + afc(n2 - k + m);
kl = exp(a - afc((int) (xl)) - afc((int) (n1 - xl))
- afc((int) (k - xl))
- afc((int) (n2 - k + xl)));
kr = exp(a - afc((int) (xr - 1))
- afc((int) (n1 - xr + 1))
- afc((int) (k - xr + 1))
- afc((int) (n2 - k + xr - 1)));
lamdl = -log(xl * (n2 - k + xl) / (n1 - xl + 1) / (k - xl + 1));
lamdr = -log((n1 - xr + 1) * (k - xr + 1) / xr / (n2 - k + xr));
p1 = d + d;
p2 = p1 + kl / lamdl;
p3 = p2 + kr / lamdr;
}
#ifdef DEBUG_rhyper
REprintf("rhyper(), branch III {accept/reject}: (xl,xr)= (%g,%g); (lamdl,lamdr)= (%g,%g)\n",
xl, xr, lamdl,lamdr);
REprintf("-------- p123= c(%g,%g,%g)\n", p1,p2, p3);
#endif
int n_uv = 0;
L30:
u = unif_rand() * p3;
v = unif_rand();
n_uv++;
if(n_uv >= 10000) {
REprintf("rhyper() branch III: giving up after %d rejections", n_uv);
ML_ERR_return_NAN;
}
#ifdef DEBUG_rhyper
REprintf(" ... L30: new (u=%g, v ~ U[0,1])[%d]\n", u, n_uv);
#endif
if (u < p1) { /* rectangular region */
ix = (int) (xl + u);
} else if (u <= p2) { /* left tail */
ix = (int) (xl + log(v) / lamdl);
if (ix < minjx)
goto L30;
v = v * (u - p1) * lamdl;
} else { /* right tail */
ix = (int) (xr - log(v) / lamdr);
if (ix > maxjx)
goto L30;
v = v * (u - p2) * lamdr;
}
/* acceptance/rejection test */
Rboolean reject = TRUE;
if (m < 100 || ix <= 50) {
/* explicit evaluation */
/* The original algorithm (and TOMS 668) have
f = f * i * (n2 - k + i) / (n1 - i) / (k - i);
in the (m > ix) case, but the definition of the
recurrence relation on p134 shows that the +1 is
needed. */
int i;
double f = 1.0;
if (m < ix) {
for (i = m + 1; i <= ix; i++)
f = f * (n1 - i + 1) * (k - i + 1) / (n2 - k + i) / i;
} else if (m > ix) {
for (i = ix + 1; i <= m; i++)
f = f * i * (n2 - k + i) / (n1 - i + 1) / (k - i + 1);
}
if (v <= f) {
reject = FALSE;
}
} else {
const static double deltal = 0.0078;
const static double deltau = 0.0034;
double e, g, r, t, y;
double de, dg, dr, ds, dt, gl, gu, nk, nm, ub;
double xk, xm, xn, y1, ym, yn, yk, alv;
#ifdef DEBUG_rhyper
REprintf(" ... accept/reject 'large' case v=%g\n", v);
#endif
/* squeeze using upper and lower bounds */
y = ix;
y1 = y + 1.0;
ym = y - m;
yn = n1 - y + 1.0;
yk = k - y + 1.0;
nk = n2 - k + y1;
r = -ym / y1;
s = ym / yn;
t = ym / yk;
e = -ym / nk;
g = yn * yk / (y1 * nk) - 1.0;
dg = 1.0;
if (g < 0.0)
dg = 1.0 + g;
gu = g * (1.0 + g * (-0.5 + g / 3.0));
gl = gu - .25 * (g * g * g * g) / dg;
xm = m + 0.5;
xn = n1 - m + 0.5;
xk = k - m + 0.5;
nm = n2 - k + xm;
ub = y * gu - m * gl + deltau
+ xm * r * (1. + r * (-0.5 + r / 3.0))
+ xn * s * (1. + s * (-0.5 + s / 3.0))
+ xk * t * (1. + t * (-0.5 + t / 3.0))
+ nm * e * (1. + e * (-0.5 + e / 3.0));
/* test against upper bound */
alv = log(v);
if (alv > ub) {
reject = TRUE;
} else {
/* test against lower bound */
dr = xm * (r * r * r * r);
if (r < 0.0)
dr /= (1.0 + r);
ds = xn * (s * s * s * s);
if (s < 0.0)
ds /= (1.0 + s);
dt = xk * (t * t * t * t);
if (t < 0.0)
dt /= (1.0 + t);
de = nm * (e * e * e * e);
if (e < 0.0)
de /= (1.0 + e);
if (alv < ub - 0.25 * (dr + ds + dt + de)
+ (y + m) * (gl - gu) - deltal) {
reject = FALSE;
}
else {
/* * Stirling's formula to machine accuracy
*/
if (alv <= (a - afc(ix) - afc(n1 - ix)
- afc(k - ix) - afc(n2 - k + ix))) {
reject = FALSE;
} else {
reject = TRUE;
}
}
}
} // else
if (reject)
goto L30;
}
L_finis:
/* return appropriate variate */
if (kk + kk >= tn) {
if (nn1 > nn2) {
ix = kk - nn2 + ix;
} else {
ix = nn1 - ix;
}
} else {
if (nn1 > nn2)
ix = kk - ix;
}
return ix;
}
double rpois(double mu)
{
/* Factorial Table (0:9)! */
const static double fact[10] =
{
1., 1., 2., 6., 24., 120., 720., 5040., 40320., 362880.
};
/* These are static --- persistent between calls for same mu : */
static int l, m;
static double b1, b2, c, c0, c1, c2, c3;
static double pp[36], p0, p, q, s, d, omega;
static double big_l;/* integer "w/o overflow" */
static double muprev = 0., muprev2 = 0.;/*, muold = 0.*/
/* Local Vars [initialize some for -Wall]: */
double del, difmuk= 0., E= 0., fk= 0., fx, fy, g, px, py, t, u= 0., v, x;
double pois = -1.;
int k, kflag, big_mu, new_big_mu = FALSE;
if (!R_FINITE(mu) || mu < 0)
ML_ERR_return_NAN;
if (mu <= 0.)
return 0.;
big_mu = mu >= 10.;
if(big_mu)
new_big_mu = FALSE;
if (!(big_mu && mu == muprev)) {/* maybe compute new persistent par.s */
if (big_mu) {
new_big_mu = TRUE;
/* Case A. (recalculation of s,d,l because mu has changed):
* The poisson probabilities pk exceed the discrete normal
* probabilities fk whenever k >= m(mu).
*/
muprev = mu;
s = sqrt(mu);
d = 6. * mu * mu;
big_l = floor(mu - 1.1484);
/* = an upper bound to m(mu) for all mu >= 10.*/
}
else { /* Small mu ( < 10) -- not using normal approx. */
/* Case B. (start new table and calculate p0 if necessary) */
/*muprev = 0.;-* such that next time, mu != muprev ..*/
if (mu != muprev) {
muprev = mu;
m = imax2(1, (int) mu);
l = 0; /* pp[] is already ok up to pp[l] */
q = p0 = p = exp(-mu);
}
repeat {
/* Step U. uniform sample for inversion method */
u = unif_rand();
if (u <= p0)
return 0.;
/* Step T. table comparison until the end pp[l] of the
pp-table of cumulative poisson probabilities
(0.458 > ~= pp[9](= 0.45792971447) for mu=10 ) */
if (l != 0) {
for (k = (u <= 0.458) ? 1 : imin2(l, m); k <= l; k++)
if (u <= pp[k])
return (double)k;
if (l == 35) /* u > pp[35] */
continue;
}
/* Step C. creation of new poisson
probabilities p[l..] and their cumulatives q =: pp[k] */
l++;
for (k = l; k <= 35; k++) {
p *= mu / k;
q += p;
pp[k] = q;
if (u <= q) {
l = k;
return (double)k;
}
}
l = 35;
} /* end(repeat) */
}/* mu < 10 */
} /* end {initialize persistent vars} */
/* Only if mu >= 10 : ----------------------- */
/* Step N. normal sample */
g = mu + s * norm_rand();/* norm_rand() ~ N(0,1), standard normal */
if (g >= 0.) {
pois = floor(g);
/* Step I. immediate acceptance if pois is large enough */
if (pois >= big_l)
return pois;
/* Step S. squeeze acceptance */
fk = pois;
difmuk = mu - fk;
u = unif_rand(); /* ~ U(0,1) - sample */
if (d * u >= difmuk * difmuk * difmuk)
return pois;
}
/* Step P. preparations for steps Q and H.
(recalculations of parameters if necessary) */
if (new_big_mu || mu != muprev2) {
/* Careful! muprev2 is not always == muprev
because one might have exited in step I or S
*/
muprev2 = mu;
omega = M_1_SQRT_2PI / s;
/* The quantities b1, b2, c3, c2, c1, c0 are for the Hermite
* approximations to the discrete normal probabilities fk. */
b1 = one_24 / mu;
b2 = 0.3 * b1 * b1;
c3 = one_7 * b1 * b2;
c2 = b2 - 15. * c3;
c1 = b1 - 6. * b2 + 45. * c3;
c0 = 1. - b1 + 3. * b2 - 15. * c3;
c = 0.1069 / mu; /* guarantees majorization by the 'hat'-function. */
}
if (g >= 0.) {
/* 'Subroutine' F is called (kflag=0 for correct return) */
kflag = 0;
goto Step_F;
}
repeat {
/* Step E. Exponential Sample */
E = exp_rand(); /* ~ Exp(1) (standard exponential) */
/* sample t from the laplace 'hat'
(if t <= -0.6744 then pk < fk for all mu >= 10.) */
u = 2 * unif_rand() - 1.;
t = 1.8 + fsign(E, u);
if (t > -0.6744) {
pois = floor(mu + s * t);
fk = pois;
difmuk = mu - fk;
/* 'subroutine' F is called (kflag=1 for correct return) */
kflag = 1;
Step_F: /* 'subroutine' F : calculation of px,py,fx,fy. */
if (pois < 10) { /* use factorials from table fact[] */
px = -mu;
py = pow(mu, pois) / fact[(int)pois];
}
else {
/* Case pois >= 10 uses polynomial approximation
a0-a7 for accuracy when advisable */
del = one_12 / fk;
del = del * (1. - 4.8 * del * del);
v = difmuk / fk;
if (fabs(v) <= 0.25)
px = fk * v * v * (((((((a7 * v + a6) * v + a5) * v + a4) *
v + a3) * v + a2) * v + a1) * v + a0)
- del;
else /* |v| > 1/4 */
px = fk * log(1. + v) - difmuk - del;
py = M_1_SQRT_2PI / sqrt(fk);
}
x = (0.5 - difmuk) / s;
x *= x;/* x^2 */
fx = -0.5 * x;
fy = omega * (((c3 * x + c2) * x + c1) * x + c0);
if (kflag > 0) {
/* Step H. Hat acceptance (E is repeated on rejection) */
if (c * fabs(u) <= py * exp(px + E) - fy * exp(fx + E))
break;
} else
/* Step Q. Quotient acceptance (rare case) */
if (fy - u * fy <= py * exp(px - fx))
break;
}/* t > -.67.. */
}
return pois;
}
void trl_clear_counter(trl_info * info, int nrow, int mev, int lde) {
int ntmp;
info->stat = 0;
if (nrow != info->nloc || nrow > info->ntot)
error("TRLAN: info not setup for this problem.\n Please reset info before calling TRLAN.\n");
if (info->nec < 0)
info->nec = 0;
if (lde < nrow)
error("TRLAN: leading dimension of EVEC to small.\n");
if (info->tol >= 1.0) {
info->tol = sqrt(DBL_EPSILON);
} else if (info->tol <= DBL_MIN) {
info->tol = DBL_EPSILON;
}
if (info->ned + info->ned >= info->ntot) {
warning("TRLAN: info->ned (%d) is large relative to the matrix dimension (%d)\n",
info->ned, info->ntot);
warning(" ** It is more appropriate to use LAPACK dsyev/ssyev.\n");
if (info->ned > info->ntot) {
info->ned = imin2(info->ntot - 1, info->maxlan - 3);
warning("TRLAN: ** reduced ned to %d **\n", info->ned);
}
}
if (mev < info->ned)
error("TRLAN: array EVAL and EVEC can not hold wanted number of eigenpairs.\n");
if (info->ntot < 10)
error("TRLAN is not designed to work with such a small matrix(%dx%d). Please use LAPACK or EISPACK instead.\n",
info->ntot, info->ntot);
info->nrand = info->stat;
info->stat = trl_sync_flag(info->mpicom, info->nrand);
/* decide what is a good maximum basis size to use */
if (info->maxlan < info->ned + 3) {
info->maxlan = info->ned + imin2(info->ned, 20) +
(int)(log((double)info->ntot));
info->maxlan = imin2(info->maxlan, info->ntot);
warning("TRLAN: ** reset maxlan to %d! **\n", info->maxlan);
}
if (info->maxlan < mev) {
ntmp = imin2(info->ntot, imax2(100 + info->ned, 10 * info->ned));
if (mev < ntmp) {
info->maxlan = mev;
} else {
info->maxlan = ntmp;
}
}
if (info->maxlan < 5)
error("TRLAN must have at least 5 basis vectors, it is currently %d.\n",
info->maxlan);
/* clear regular counters */
info->tmv = -1;
info->klan = imin2(info->maxlan, info->ntot);
if (info->restart >= 7) {
info->klan = imin2(info->maxlan,
imax2(100,
imin2(info->klan, 2 * (info->ned))));
}
info->locked = info->nec;
info->matvec = 0;
info->nloop = 0;
info->north = 0;
info->nrand = 0;
info->tick_t = 0.0;
info->clk_op = 0;
info->tick_o = 0.0;
info->clk_orth = 0;
info->tick_h = 0.0;
info->clk_res = 0;
info->tick_r = 0.0;
info->clk_in = 0;
info->clk_out = 0;
info->wrds_in = 0;
info->wrds_out = 0;
info->avgm = 0.0;
return;
}
static
void clowess(double *x, double *y, int n,
double f, int nsteps, double delta,
double *ys, double *rw, double *res)
{
int i, iter, j, last, m1, m2, nleft, nright, ns;
Rboolean ok;
double alpha, c1, c9, cmad, cut, d1, d2, denom, r, sc;
if (n < 2) {
ys[0] = y[0]; return;
}
/* nleft, nright, last, etc. must all be shifted to get rid of these: */
x--;
y--;
ys--;
/* at least two, at most n points */
ns = imax2(2, imin2(n, (int)(f*n + 1e-7)));
#ifdef DEBUG_lowess
REprintf("lowess(): ns = %d\n", ns);
#endif
/* robustness iterations */
iter = 1;
while (iter <= nsteps+1) {
nleft = 1;
nright = ns;
last = 0; /* index of prev estimated point */
i = 1; /* index of current point */
for(;;) {
if (nright < n) {
/* move nleft, nright to right */
/* if radius decreases */
d1 = x[i] - x[nleft];
d2 = x[nright+1] - x[i];
/* if d1 <= d2 with */
/* x[nright+1] == x[nright], */
/* lowest fixes */
if (d1 > d2) {
/* radius will not */
/* decrease by */
/* move right */
nleft++;
nright++;
continue;
}
}
/* fitted value at x[i] */
lowest(&x[1], &y[1], n, &x[i], &ys[i],
nleft, nright, res, iter>1, rw, &ok);
if (!ok) ys[i] = y[i];
/* all weights zero */
/* copy over value (all rw==0) */
if (last < i-1) {
denom = x[i]-x[last];
/* skipped points -- interpolate */
/* non-zero - proof? */
for(j = last+1; j < i; j++) {
alpha = (x[j]-x[last])/denom;
ys[j] = alpha*ys[i] + (1.-alpha)*ys[last];
}
}
/* last point actually estimated */
last = i;
/* x coord of close points */
cut = x[last]+delta;
for (i = last+1; i <= n; i++) {
if (x[i] > cut)
break;
if (x[i] == x[last]) {
ys[i] = ys[last];
last = i;
}
}
i = imax2(last+1, i-1);
if (last >= n)
break;
}
/* residuals */
for(i = 0; i < n; i++)
res[i] = y[i+1] - ys[i+1];
/* overall scale estimate */
sc = 0.;
for(i = 0; i < n; i++) sc += fabs(res[i]);
sc /= n;
/* compute robustness weights */
/* except last time */
if (iter > nsteps)
break;
/* Note: The following code, biweight_{6 MAD|Ri|}
is also used in stl(), loess and several other places.
--> should provide API here (MM) */
for(i = 0 ; i < n ; i++)
rw[i] = fabs(res[i]);
/* Compute cmad := 6 * median(rw[], n) ---- */
/* FIXME: We need C API in R for Median ! */
m1 = n/2;
/* partial sort, for m1 & m2 */
rPsort(rw, n, m1);
if(n % 2 == 0) {
m2 = n-m1-1;
rPsort(rw, n, m2);
cmad = 3.*(rw[m1]+rw[m2]);
}
else { /* n odd */
cmad = 6.*rw[m1];
}
#ifdef DEBUG_lowess
REprintf(" cmad = %12g\n", cmad);
#endif
if(cmad < 1e-7 * sc) /* effectively zero */
break;
c9 = 0.999*cmad;
c1 = 0.001*cmad;
for(i = 0 ; i < n ; i++) {
r = fabs(res[i]);
if (r <= c1)
rw[i] = 1.;
else if (r <= c9)
rw[i] = fsquare(1.-fsquare(r/cmad));
else
rw[i] = 0.;
}
iter++;
}
}
double R_pretty0(double *lo, double *up, int *ndiv, int min_n,
double shrink_sml, double high_u_fact[],
int eps_correction, int return_bounds)
{
/* From version 0.65 on, we had rounding_eps := 1e-5, before, r..eps = 0
* 1e-7 is consistent with seq.default() */
#define rounding_eps 1e-7
#define h high_u_fact[0]
#define h5 high_u_fact[1]
double dx, cell, unit, base, U;
double ns, nu;
int k;
Rboolean i_small;
dx = *up - *lo;
/* cell := "scale" here */
if(dx == 0 && *up == 0) { /* up == lo == 0 */
cell = 1;
i_small = TRUE;
} else {
cell = fmax2(fabs(*lo),fabs(*up));
/* U = upper bound on cell/unit */
U = (1 + (h5 >= 1.5*h+.5)) ? 1/(1+h) : 1.5/(1+h5);
/* added times 3, as several calculations here */
i_small = dx < cell * U * imax2(1,*ndiv) * DBL_EPSILON *3;
}
/*OLD: cell = FLT_EPSILON+ dx / *ndiv; FLT_EPSILON = 1.192e-07 */
if(i_small) {
if(cell > 10)
cell = 9 + cell/10;
cell *= shrink_sml;
if(min_n > 1) cell /= min_n;
} else {
cell = dx;
if(*ndiv > 1) cell /= *ndiv;
}
if(cell < 20*DBL_MIN) {
warning(_("Internal(pretty()): very small range.. corrected"));
cell = 20*DBL_MIN;
} else if(cell * 10 > DBL_MAX) {
warning(_("Internal(pretty()): very large range.. corrected"));
cell = .1*DBL_MAX;
}
base = pow(10., floor(log10(cell))); /* base <= cell < 10*base */
/* unit : from { 1,2,5,10 } * base
* such that |u - cell| is small,
* favoring larger (if h > 1, else smaller) u values;
* favor '5' more than '2' if h5 > h (default h5 = .5 + 1.5 h) */
unit = base;
if((U = 2*base)-cell < h*(cell-unit)) { unit = U;
if((U = 5*base)-cell < h5*(cell-unit)) { unit = U;
if((U =10*base)-cell < h*(cell-unit)) unit = U; }}
/* Result: c := cell, u := unit, b := base
* c in [ 1, (2+ h) /(1+h) ] b ==> u= b
* c in ( (2+ h)/(1+h), (5+2h5)/(1+h5)] b ==> u= 2b
* c in ( (5+2h)/(1+h), (10+5h) /(1+h) ] b ==> u= 5b
* c in ((10+5h)/(1+h), 10 ) b ==> u=10b
*
* ===> 2/5 *(2+h)/(1+h) <= c/u <= (2+h)/(1+h) */
ns = floor(*lo/unit+rounding_eps);
nu = ceil (*up/unit-rounding_eps);
#ifdef DEBUGpr
REprintf("pretty(lo=%g,up=%g,ndiv=%d,min_n=%d,shrink=%g,high_u=(%g,%g),"
"eps=%d)\n\t dx=%g; is.small:%d. ==> cell=%g; unit=%g\n",
*lo, *up, *ndiv, min_n, shrink_sml, h, h5,
eps_correction, dx, (int)i_small, cell, unit);
#endif
if(eps_correction && (eps_correction > 1 || !i_small)) {
if(*lo) *lo *= (1- DBL_EPSILON); else *lo = -DBL_MIN;
if(*up) *up *= (1+ DBL_EPSILON); else *up = +DBL_MIN;
}
#ifdef DEBUGpr
if(ns*unit > *lo)
REprintf("\t ns= %.0f -- while(ns*unit > *lo) ns--;\n", ns);
#endif
while(ns*unit > *lo + rounding_eps*unit) ns--;
#ifdef DEBUGpr
if(nu*unit < *up)
REprintf("\t nu= %.0f -- while(nu*unit < *up) nu++;\n", nu);
#endif
while(nu*unit < *up - rounding_eps*unit) nu++;
k = .5 + nu - ns;
if(k < min_n) {
/* ensure that nu - ns == min_n */
#ifdef DEBUGpr
REprintf("\tnu-ns=%.0f-%.0f=%d SMALL -> ensure nu-ns= min_n=%d\n",
nu,ns, k, min_n);
#endif
k = min_n - k;
if(ns >= 0.) {
nu += k/2;
ns -= k/2 + k%2;/* ==> nu-ns = old(nu-ns) + min_n -k = min_n */
} else {
ns -= k/2;
nu += k/2 + k%2;
}
*ndiv = min_n;
}
else {
*ndiv = k;
}
if(return_bounds) { /* if()'s to ensure that result covers original range */
if(ns * unit < *lo) *lo = ns * unit;
if(nu * unit > *up) *up = nu * unit;
} else {
*lo = ns;
*up = nu;
}
#ifdef DEBUGpr
REprintf("\t ns=%.0f ==> lo=%g\n", ns, *lo);
REprintf("\t nu=%.0f ==> up=%g ==> ndiv = %d\n", nu, *up, *ndiv);
#endif
return unit;
#undef h
#undef h5
}
/* Matrix exponential exp(x), where x is an (n x n) matrix. Result z
* is an (n x n) matrix. Mostly lifted from the core of fonction
* expm() of package Matrix, which is itself based on the function of
* the same name in Octave.
*/
void expm(double *x, int n, double *z, precond_type precond_kind)
{
if (n == 1)
z[0] = exp(x[0]); /* scalar exponential */
else
{
/* Constants */
const double one = 1.0, zero = 0.0;
const int i1 = 1, nsqr = n * n, np1 = n + 1;
/* Variables */
int i, j, is_uppertri = TRUE;;
int ilo, ihi, iloscal, ihiscal, info, sqrpowscal;
double infnorm, trshift, m1pj = -1;
/* Arrays */
int *pivot = (int *) R_alloc(n, sizeof(int)); /* pivot vector */
double *scale; /* scale array */
double *perm = (double *) R_alloc(n, sizeof(double));/* permutation/sc array */
double *work = (double *) R_alloc(nsqr, sizeof(double)); /* workspace array */
double *npp = (double *) R_alloc(nsqr, sizeof(double)); /* num. power Pade */
double *dpp = (double *) R_alloc(nsqr, sizeof(double)); /* denom. power Pade */
Memcpy(z, x, nsqr);
/* Check if matrix x is upper triangular; stop checking as
* soon as a non-zero value is found below the diagonal. */
for (i = 0; i < n - 1 && is_uppertri; i++)
for (j = i + 1; j < n; j++)
if (!(is_uppertri = x[i * n + j] == 0.0))
break;
/* Step 1 of preconditioning: shift diagonal by average diagonal. */
trshift = 0.0;
for (i = 0; i < n; i++)
trshift += x[i * np1];
trshift /= n; /* average diagonal element */
if (trshift > 0.0)
for (i = 0; i < n; i++)
z[i * np1] -= trshift;
/* Step 2 of preconditioning: balancing with dgebal. */
if(precond_kind == Ward_2 || precond_kind == Ward_buggy_octave) {
if (is_uppertri) {
/* no need to permute if x is upper triangular */
ilo = 1;
ihi = n;
}
else {
F77_CALL(dgebal)("P", &n, z, &n, &ilo, &ihi, perm, &info);
if (info)
error(_("LAPACK routine dgebal returned info code %d when permuting"), info);
}
scale = (double *) R_alloc(n, sizeof(double));
F77_CALL(dgebal)("S", &n, z, &n, &iloscal, &ihiscal, scale, &info);
if (info)
error(_("LAPACK routine dgebal returned info code %d when scaling"), info);
}
else if(precond_kind == Ward_1) {
F77_CALL(dgebal)("B", &n, z, &n, &ilo, &ihi, perm, &info);
if (info)
error(_("LAPACK' dgebal(\"B\",.) returned info code %d"), info);
}
else {
error(_("invalid 'precond_kind: %d"), precond_kind);
}
/* Step 3 of preconditioning: Scaling according to infinity
* norm (a priori always needed). */
infnorm = F77_CALL(dlange)("I", &n, &n, z, &n, work);
sqrpowscal = (infnorm > 0) ? imax2((int) 1 + log(infnorm)/M_LN2, 0) : 0;
if (sqrpowscal > 0) {
double scalefactor = R_pow_di(2, sqrpowscal);
for (i = 0; i < nsqr; i++)
z[i] /= scalefactor;
}
/* Pade approximation (p = q = 8): compute x^8, x^7, x^6,
* ..., x^1 */
for (i = 0; i < nsqr; i++)
{
npp[i] = 0.0;
dpp[i] = 0.0;
}
for (j = 7; j >= 0; j--)
{
/* npp = z * npp + padec88[j] * z */
F77_CALL(dgemm) ("N", "N", &n, &n, &n, &one, z, &n, npp,
&n, &zero, work, &n);
/* npp <- work + padec88[j] * z */
for (i = 0; i < nsqr; i++)
npp[i] = work[i] + padec88[j] * z[i];
/* dpp = z * dpp + (-1)^j * padec88[j] * z */
F77_CALL(dgemm) ("N", "N", &n, &n, &n, &one, z, &n, dpp,
&n, &zero, work, &n);
for (i = 0; i < nsqr; i++)
dpp[i] = work[i] + m1pj * padec88[j] * z[i];
m1pj *= -1; /* (-1)^j */
}
/* power 0 */
for (i = 0; i < nsqr; i++)
dpp[i] *= -1.0;
for (j = 0; j < n; j++)
{
npp[j * np1] += 1.0;
dpp[j * np1] += 1.0;
}
/* Pade approximation is (dpp)^-1 * npp. */
F77_CALL(dgetrf) (&n, &n, dpp, &n, pivot, &info);
if (info)
error(_("LAPACK routine dgetrf returned info code %d"), info);
F77_CALL(dgetrs) ("N", &n, &n, dpp, &n, pivot, npp, &n, &info);
if (info)
error(_("LAPACK routine dgetrs returned info code %d"), info);
Memcpy(z, npp, nsqr);
/* Now undo all of the preconditioning */
/* Preconditioning 3: square the result for every power of 2 */
while (sqrpowscal--)
{
F77_CALL(dgemm)("N", "N", &n, &n, &n, &one, z, &n,
z, &n, &zero, work, &n);
Memcpy(z, work, nsqr);
}
/* Preconditioning 2: Inversion of 'dgebal()' :
* ------------------ Note that dgebak() seems *not* applicable */
/* Step 2 a) apply inverse scaling */
if(precond_kind == Ward_2 || precond_kind == Ward_buggy_octave) {
for (j = 0; j < n; j++)
for (i = 0; i < n; i++)
z[i + j * n] *= scale[i]/scale[j];
}
else if(precond_kind == Ward_1) { /* here, perm[ilo:ihi] contains scale[] */
for (j = 0; j < n; j++) {
double sj = ((ilo-1 <= j && j < ihi)? perm[j] : 1.);
for (i = 0; i < ilo-1; i++) z[i + j * n] /= sj;
for (i = ilo-1; i < ihi; i++) z[i + j * n] *= perm[i]/sj;
for (i = ihi+1; i < n; i++) z[i + j * n] /= sj;
}
}
/* 2 b) Inverse permutation (if not the identity permutation) */
if (ilo != 1 || ihi != n) {
if(precond_kind == Ward_buggy_octave) {
/* inverse permutation vector */
int *invP = (int *) R_alloc(n, sizeof(int));
/* balancing permutation vector */
for (i = 0; i < n; i++)
invP[i] = i; /* identity permutation */
/* leading permutations applied in forward order */
for (i = 0; i < (ilo - 1); i++)
{
int p_i = (int) (perm[i]) - 1;
int tmp = invP[i]; invP[i] = invP[p_i]; invP[p_i] = tmp;
}
/* trailing permutations applied in reverse order */
for (i = n - 1; i >= ihi; i--)
{
int p_i = (int) (perm[i]) - 1;
int tmp = invP[i]; invP[i] = invP[p_i]; invP[p_i] = tmp;
}
/* construct inverse balancing permutation vector */
Memcpy(pivot, invP, n);
for (i = 0; i < n; i++)
invP[pivot[i]] = i;
/* apply inverse permutation */
Memcpy(work, z, nsqr);
for (j = 0; j < n; j++)
for (i = 0; i < n; i++)
z[i + j * n] = work[invP[i] + invP[j] * n];
}
else if(precond_kind == Ward_2 || precond_kind == Ward_1) {
/* ---- new code by Martin Maechler ----- */
#define SWAP_ROW(I,J) F77_CALL(dswap)(&n, &z[(I)], &n, &z[(J)], &n)
#define SWAP_COL(I,J) F77_CALL(dswap)(&n, &z[(I)*n], &i1, &z[(J)*n], &i1)
#define RE_PERMUTE(I) \
int p_I = (int) (perm[I]) - 1; \
SWAP_COL(I, p_I); \
SWAP_ROW(I, p_I)
/* reversion of "leading permutations" : in reverse order */
for (i = (ilo - 1) - 1; i >= 0; i--) {
RE_PERMUTE(i);
}
/* reversion of "trailing permutations" : applied in forward order */
for (i = (ihi + 1) - 1; i < n; i++) {
RE_PERMUTE(i);
}
}
/* else if(precond_kind == Ward_1) { */
/* } */
}
/* Preconditioning 1: Trace normalization */
if (trshift > 0)
{
double mult = exp(trshift);
for (i = 0; i < nsqr; i++)
z[i] *= mult;
}
}
}
/* Written by Mikko Korpela */
SEXP readloop(SEXP series_index, SEXP decade, SEXP x) {
SEXP ans, dims, rw_mat, prec_rproc;
size_t i, x_nrow, rw_nrow, rw_ncol, x_idx;
int j, x_ncol, yr_idx, rw_idx, this_series, this_val, min_year, max_year;
int span, this_decade, last_valid, nseries;
int *series_index_p, *decade_p, *x_p, *prec_rproc_p, *last_yr;
double stop_marker;
double *dims_p, *rw_vec;
/* Safety checks */
if (!(isInteger(series_index) && isInteger(decade) && isInteger(x))) {
error(_("all arguments must be integers"));
}
/* Dimensions of x */
dims = PROTECT(coerceVector(getAttrib(x, R_DimSymbol), REALSXP));
if (length(dims) != 2) {
UNPROTECT(1);
error(_("'x' must be a matrix"));
}
dims_p = REAL(dims);
/* Nominally max 10 years per row, allow a few more */
if (dims_p[1] > 100) {
UNPROTECT(1);
error(_("too many columns in 'x'"));
}
x_nrow = (size_t) dims_p[0];
x_ncol = (int) dims_p[1];
UNPROTECT(1);
/* More safety checks */
if (!(dplRlength(series_index) == x_nrow &&
dplRlength(decade) == x_nrow)) {
error(_("dimensions of 'x', 'series_index' and 'decade' must match"));
}
series_index_p = INTEGER(series_index);
decade_p = INTEGER(decade);
x_p = INTEGER(x);
/* Calculate dimensions of result matrix */
nseries = 0;
min_year = INT_MAX;
max_year = INT_MIN;
for (i = 0; i < x_nrow; i++) {
if (series_index_p[i] < 1) {
error(_("'series_index' must be positive"));
}
nseries = imax2(nseries, series_index_p[i]);
this_decade = decade_p[i];
j = x_ncol - 1;
x_idx = i + j * x_nrow;
while (j >= 0 && x_p[x_idx] == NA_INTEGER) {
--j;
x_idx -= x_nrow;
}
if (j >= 0) {
min_year = imin2(min_year, this_decade);
max_year = imax2(max_year, this_decade + j);
}
}
if (max_year >= min_year) {
if (max_year >= 0 && min_year < max_year - R_INT_MAX + 1)
error(_("Number of years exceeds integer range"));
span = max_year - min_year + 1;
} else {
min_year = NA_INTEGER;
span = 0;
}
rw_nrow = (size_t) span;
rw_ncol = (size_t) nseries;
/* List for results: rw_mat, min_year, prec_rproc */
ans = PROTECT(allocVector(VECSXP, 3));
rw_mat = SET_VECTOR_ELT(ans, 0, allocMatrix(REALSXP, span, nseries));
rw_vec = REAL(rw_mat);
for (i = 0; i < rw_nrow * rw_ncol; i++) {
rw_vec[i] = NA_REAL;
}
SET_VECTOR_ELT(ans, 1, ScalarInteger(min_year));
prec_rproc = SET_VECTOR_ELT(ans, 2, allocVector(INTSXP, nseries));
prec_rproc_p = INTEGER(prec_rproc);
if (span == 0) {
for(i = 0; i < rw_ncol; i++){
prec_rproc_p[i] = NA_INTEGER;
}
warning(_("no data found in 'x'"));
UNPROTECT(1);
return ans;
}
/* Allocate internal storage */
last_yr = (int *) R_alloc(rw_ncol, sizeof(int));
for (i = 0; i < rw_ncol; i++) {
last_yr[i] = min_year;
}
/* Convert between input and output formats */
for(i = 0; i < x_nrow; i++){
this_decade = decade_p[i];
yr_idx = this_decade - min_year;
this_series = series_index_p[i] - 1;
rw_idx = this_series * rw_nrow + yr_idx;
x_idx = i;
last_valid = last_yr[this_series];
for(j = 0; j < x_ncol; j++){
this_val = x_p[x_idx];
x_idx += x_nrow;
if(this_val != NA_INTEGER){
rw_vec[rw_idx] = this_val;
last_valid = this_decade + j;
}
rw_idx++;
}
/* Needed for keeping track of the stop marker */
if(last_valid > last_yr[this_series])
last_yr[this_series] = last_valid;
}
for(i = 0; i < rw_ncol; i++){
stop_marker = rw_vec[i * rw_nrow + (last_yr[i] - min_year)];
if(stop_marker == 999.0f){
prec_rproc_p[i] = 100;
} else if(stop_marker == -9999.0f){
prec_rproc_p[i] = 1000;
} else {
prec_rproc_p[i] = 1;
}
}
UNPROTECT(1);
return ans;
}
int main(int argc, char *argv[])
{
static char *Spec[] = {"[-root_id <int>] [<input:string>]",
"[-a <string>] [-b <string>]",
"[-stitch_script] [-exclude <string>] [-tile_number <int>]",
NULL};
Process_Arguments(argc, argv, Spec, 1);
int *excluded = NULL;
int nexc = 0;
int *excluded_pair = NULL;
int nexcpair = 0;
if (Is_Arg_Matched("-exclude")) {
String_Workspace *sw = New_String_Workspace();
FILE *fp = fopen(Get_String_Arg("-exclude"), "r");
char *line = Read_Line(fp, sw);
excluded = String_To_Integer_Array(line, NULL, &nexc);
line = Read_Line(fp, sw);
if (line != NULL) {
excluded_pair = String_To_Integer_Array(line, NULL, &nexcpair);
nexcpair /= 2;
}
Kill_String_Workspace(sw);
fclose(fp);
}
int n = 0;
Graph *graph = Make_Graph(n + 1, n, TRUE);
char filepath1[100];
char filepath2[100];
int i, j;
Stack *stack1 = NULL;
FILE *fp = NULL;
if (Is_Arg_Matched("-stitch_script")) {
Cuboid_I *boxes = read_tile_array(Get_String_Arg("-a"), &n);
for (i = 0; i < n; i++) {
for (j = i + 1; j < n; j++) {
BOOL is_excluded = FALSE;
int k;
for (k = 0; k < nexc; k++) {
if ((i == excluded[k] - 1) || (j == excluded[k] - 1)) {
is_excluded = TRUE;
break;
}
}
for (k = 0; k < nexcpair; k++) {
if (((i == excluded_pair[k*2]) && (j == excluded_pair[k*2+1])) ||
((j == excluded_pair[k*2]) && (i == excluded_pair[k*2+1]))) {
is_excluded = TRUE;
break;
}
}
/*
if ((i != 103) && (j != 103) && (i != 115) && (j != 115) && (i != 59) &&
(j != 59) && !(i == 116 && j == 116)) {
*/
if (is_excluded == FALSE) {
Cuboid_I_Overlap_Volume(boxes + i, boxes + j);
Cuboid_I ibox;
Cuboid_I_Intersect(boxes + i, boxes + j, &ibox);
int width, height, depth;
Cuboid_I_Size(&ibox, &width, &height, &depth);
if ((imax2(width, height) > 1024 / 3) && (imin2(width, height) > 0)) {
sprintf(filepath1, "%s/stack/%03d.xml",
Get_String_Arg("input"), i + 1);
sprintf(filepath2, "%s/stack/%03d.xml",
Get_String_Arg("input"), j + 1);
if (stack1 == NULL) {
stack1 = Read_Stack_U(filepath1);
}
Stack *stack2 = Read_Stack_U(filepath2);
Stack *substack1= Crop_Stack(stack1, ibox.cb[0] - boxes[i].cb[0],
ibox.cb[1] - boxes[i].cb[1], 0,
width, height, stack1->depth, NULL);
Stack *substack2 = Crop_Stack(stack2, ibox.cb[0] - boxes[j].cb[0],
ibox.cb[1] - boxes[j].cb[1], 0,
width, height, stack2->depth, NULL);
Image *img1 = Proj_Stack_Zmax(substack1);
Image *img2 = Proj_Stack_Zmax(substack2);
double w = u16array_corrcoef((uint16_t*) img1->array,
(uint16_t*) img2->array,
img1->width * img1->height);
Kill_Stack(stack2);
Kill_Stack(substack1);
Kill_Stack(substack2);
Kill_Image(img1);
Kill_Image(img2);
printf("%d, %d : %g\n", i + 1, j + 1, w);
Graph_Add_Weighted_Edge(graph, i + 1, j + 1, 1000.0 / (w + 1.0));
}
}
if (stack1 != NULL) {
Kill_Stack(stack1);
stack1 = NULL;
}
}
}
Graph_Workspace *gw = New_Graph_Workspace();
Graph_To_Mst2(graph, gw);
Arrayqueue q = Graph_Traverse_B(graph, Get_Int_Arg("-root_id"), gw);
Print_Arrayqueue(&q);
int *grown = iarray_malloc(graph->nvertex);
for (i = 0; i < graph->nvertex; i++) {
grown[i] = 0;
}
int index = Arrayqueue_Dequeue(&q);
grown[index] = 1;
char stitch_p_file[5][500];
FILE *pfp[5];
for (i = 0; i < 5; i++) {
sprintf(stitch_p_file[i], "%s/stitch/stitch_%d.sh", Get_String_Arg("input"), i);
pfp[i] = fopen(stitch_p_file[i], "w");
}
sprintf(filepath1, "%s/stitch/stitch_all.sh", Get_String_Arg("input"));
fp = GUARDED_FOPEN(filepath1, "w");
fprintf(fp, "#!/bin/bash\n");
int count = 0;
while ((index = Arrayqueue_Dequeue(&q)) > 0) {
for (i = 0; i < graph->nedge; i++) {
int index2 = -1;
if (index == graph->edges[i][0]) {
index2 = graph->edges[i][1];
} else if (index == graph->edges[i][1]) {
index2 = graph->edges[i][0];
}
if (index2 > 0) {
if (grown[index2] == 1) {
char cmd[500];
sprintf(filepath2, "%s/stitch/%03d_%03d_pos.txt",
Get_String_Arg("input"), index2, index);
sprintf(cmd,
"%s/stitchstack %s/stack/%03d.xml %s/stack/%03d.xml -o %s",
Get_String_Arg("-b"), Get_String_Arg("input"),
index2, Get_String_Arg("input"), index, filepath2);
fprintf(fp, "%s\n", cmd);
count++;
fprintf(pfp[count%5], "%s\n", cmd);
/*
if (!fexist(filepath2)) {
system(cmd);
}
*/
grown[index] = 1;
break;
}
}
}
}
fclose(fp);
for (i = 0; i < 5; i++) {
fprintf(pfp[i], "touch %s/stitch/stitch_%d_done\n",
Get_String_Arg("input"), i);
fclose(pfp[i]);
}
return 0;
}
sprintf(filepath1, "%s/stitch/stitch_all.sh", Get_String_Arg("input"));
fp = GUARDED_FOPEN(filepath1, "r");
//#define MAX_TILE_INDEX 153
int tile_number = Get_Int_Arg("-tile_number");
int max_tile_index = tile_number + 1;
char *line = NULL;
String_Workspace *sw = New_String_Workspace();
int id[2];
char filepath[100];
int offset[max_tile_index][3];
int relative_offset[max_tile_index][3];
int array[max_tile_index];
for (i = 0; i < max_tile_index; i++) {
array[i] = -1;
offset[i][0] = 0;
offset[i][1] = 0;
offset[i][2] = 0;
relative_offset[i][0] = 0;
relative_offset[i][1] = 0;
relative_offset[i][2] = 0;
}
while ((line = Read_Line(fp, sw)) != NULL) {
char *remain = strsplit(line, ' ', 1);
if (String_Ends_With(line, "stitchstack")) {
String_To_Integer_Array(remain, id, &n);
id[0] = id[1];
id[1] = id[3];
array[id[1]] = id[0];
sprintf(filepath, "%s/stitch/%03d_%03d_pos.txt", Get_String_Arg("input"),
id[0], id[1]);
if (!fexist(filepath)) {
fprintf(stderr, "file %s does not exist\n", filepath);
return 1;
}
FILE *fp2 = GUARDED_FOPEN(filepath, "r");
line = Read_Line(fp2, sw);
line = Read_Line(fp2, sw);
int tmpoffset[8];
String_To_Integer_Array(line, tmpoffset, &n);
relative_offset[id[1]][0] = tmpoffset[2];
relative_offset[id[1]][1] = tmpoffset[3];
relative_offset[id[1]][2] = tmpoffset[4];
fclose(fp2);
}
}
for (i = 1; i < max_tile_index; i++) {
BOOL is_excluded = FALSE;
int k;
for (k = 0; k < nexc; k++) {
if (i == excluded[k]) {
is_excluded = TRUE;
break;
}
}
/*if ((i == 104) || (i == 116) || (i == 60) || (i == 152)) {*/
if (is_excluded) {
printf("%d: (0, 0, 10000)\n", i);
} else {
int index = i;
while (index >= 0) {
offset[i][0] += relative_offset[index][0];
offset[i][1] += relative_offset[index][1];
offset[i][2] += relative_offset[index][2];
index = array[index];
}
printf("%d: (%d, %d, %d)\n", i, offset[i][0], offset[i][1], offset[i][2]);
}
}
fclose(fp);
return 0;
}